| 335 |
(l,e) |
(l,e) |
| 336 |
) r in |
) r in |
| 337 |
(!fv, Typed.RecordLitt r) |
(!fv, Typed.RecordLitt r) |
| 338 |
| UnaryOp (o,e) -> |
| Op (op,le) -> |
| 339 |
let (fv,e) = expr e in (fv, Typed.UnaryOp (o,e)) |
let (fvs,ltes) = List.split (List.map expr le) in |
| 340 |
| BinaryOp (o,e1,e2) -> |
let fv = List.fold_left Fv.union Fv.empty fvs in |
| 341 |
let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in |
(fv, Typed.Op (op,ltes)) |
|
(Fv.union fv1 fv2, Typed.BinaryOp (o,e1,e2)) |
|
| 342 |
| Match (e,b) -> |
| Match (e,b) -> |
| 343 |
let (fv1,e) = expr e |
let (fv1,e) = expr e |
| 344 |
and (fv2,b) = branches b in |
and (fv2,b) = branches b in |
| 370 |
|
|
| 371 |
open Typed |
open Typed |
| 372 |
|
|
| 373 |
|
|
| 374 |
|
let check loc t s msg = |
| 375 |
|
if not (Types.subtype t s) then raise_loc loc (Constraint (t, s, msg)) |
| 376 |
|
|
| 377 |
let rec compute_type env e = |
let rec compute_type env e = |
| 378 |
let d = compute_type' e.exp_loc env e.exp_descr in |
let d = compute_type' e.exp_loc env e.exp_descr in |
| 379 |
e.exp_typ <- Types.cup e.exp_typ d; |
e.exp_typ <- Types.cup e.exp_typ d; |
| 422 |
let t = Types.record l false (Types.cons t) in |
let t = Types.record l false (Types.cons t) in |
| 423 |
Types.cap accu t |
Types.cap accu t |
| 424 |
) Types.Record.any r |
) Types.Record.any r |
| 425 |
| UnaryOp (op,e) -> |
| Op (op, el) -> |
| 426 |
let t = compute_type env e in |
let args = List.map (fun e -> (e.exp_loc, compute_type env e)) el in |
| 427 |
op.Op.un_type loc e.exp_loc t |
type_op loc op args |
|
| BinaryOp (op,e1,e2) -> |
|
|
let t1 = compute_type env e1 and t2 = compute_type env e2 in |
|
|
op.Op.bin_type loc e1.exp_loc t1 e2.exp_loc t2 |
|
| 428 |
| Match (e,b) -> |
| Match (e,b) -> |
| 429 |
let t = compute_type env e in |
let t = compute_type env e in |
| 430 |
type_branches loc env t b |
type_branches loc env t b |
| 431 |
| Map (e,b) -> assert false |
| Map (e,b) -> |
| 432 |
|
let t = compute_type env e in |
| 433 |
|
Sequence.map (fun t -> type_branches loc env t b) t |
| 434 |
|
|
| 435 |
and type_branches loc env targ brs = |
and type_branches loc env targ brs = |
| 436 |
if Types.is_empty targ then Types.empty |
if Types.is_empty targ then Types.empty |
| 462 |
else |
else |
| 463 |
tres |
tres |
| 464 |
) |
) |
| 465 |
|
|
| 466 |
|
and type_op loc op args = |
| 467 |
|
match (op,args) with |
| 468 |
|
| ("+", [loc1,t1; loc2,t2]) -> |
| 469 |
|
type_int_binop Intervals.add loc1 t1 loc2 t2 |
| 470 |
|
| ("*", [loc1,t1; loc2,t2]) -> |
| 471 |
|
type_int_binop (fun i1 i2 -> Intervals.any) loc1 t1 loc2 t2 |
| 472 |
|
| ("@", [loc1,t1; loc2,t2]) -> |
| 473 |
|
check loc1 t1 Sequence.any |
| 474 |
|
"The first argument of @ must be a sequence"; |
| 475 |
|
Sequence.concat t1 t2 |
| 476 |
|
| ("flatten", [loc1,t1]) -> |
| 477 |
|
check loc1 t1 Sequence.seqseq |
| 478 |
|
"The argument of flatten must be a sequence of sequences"; |
| 479 |
|
Sequence.flatten t1 |
| 480 |
|
| _ -> assert false |
| 481 |
|
|
| 482 |
|
and type_int_binop f loc1 t1 loc2 t2 = |
| 483 |
|
if not (Types.Int.is_int t1) then |
| 484 |
|
raise_loc loc1 |
| 485 |
|
(Constraint |
| 486 |
|
(t1,Types.Int.any, |
| 487 |
|
"The first argument must be an integer")); |
| 488 |
|
if not (Types.Int.is_int t2) then |
| 489 |
|
raise_loc loc2 |
| 490 |
|
(Constraint |
| 491 |
|
(t1,Types.Int.any, |
| 492 |
|
"The second argument must be an integer")); |
| 493 |
|
Types.Int.put |
| 494 |
|
(f (Types.Int.get t1) (Types.Int.get t2)); |
| 495 |
|
|
| 496 |
|
|
Parent Directory
| 
Revision Log
| 
Patch