/[svn]/typing/typer.ml
ViewVC logotype

Diff of /typing/typer.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 15 by abate, Tue Jul 10 16:57:55 2007 UTC revision 16 by abate, Tue Jul 10 16:58:05 2007 UTC
# Line 335  Line 335 
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
# Line 419  Line 418 
418             let t = Types.record l false (Types.cons t) in             let t = Types.record l false (Types.cons t) in
419             Types.cap accu t             Types.cap accu t
420          ) Types.Record.any r          ) Types.Record.any r
421    | UnaryOp (op,e) ->    | Op (op, el) ->
422        let t = compute_type env e in        let args = List.map (fun e -> (e.exp_loc, compute_type env e)) el in
423        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  
424    | Match (e,b) ->    | Match (e,b) ->
425        let t = compute_type env e in        let t = compute_type env e in
426        type_branches loc env t b        type_branches loc env t b
# Line 460  Line 456 
456            else            else
457              tres              tres
458          )          )
459    
460    and type_op loc op args =
461      match (op,args) with
462        | ("+", [loc1,t1; loc2,t2]) ->
463            type_int_binop Intervals.add loc1 t1 loc2 t2
464        | ("*", [loc1,t1; loc2,t2]) ->
465            type_int_binop (fun i1 i2 -> Intervals.any) loc1 t1 loc2 t2
466        | _ -> assert false
467    
468    and type_int_binop f loc1 t1 loc2 t2 =
469      if not (Types.Int.is_int t1) then
470        raise_loc loc1
471          (Constraint
472             (t1,Types.Int.any,
473              "The first argument must be an integer"));
474      if not (Types.Int.is_int t2) then
475        raise_loc loc2
476          (Constraint
477                   (t1,Types.Int.any,
478                    "The second argument must be an integer"));
479      Types.Int.put
480        (f (Types.Int.get t1) (Types.Int.get t2));
481    
482    
Legend:
Removed from v.15  
changed lines
  Added in v.16
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5