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

Diff of /typing/typer.ml

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

revision 63 by abate, Tue Jul 10 17:01:56 2007 UTC revision 64 by abate, Tue Jul 10 17:02:32 2007 UTC
# Line 363  Line 363 
363            let (fv1,e) = expr e            let (fv1,e) = expr e
364            and (fv2,b) = branches b in            and (fv2,b) = branches b in
365            (Fv.union fv1 fv2, Typed.Map (e, b))            (Fv.union fv1 fv2, Typed.Map (e, b))
366          | Try (e,b) ->
367              let (fv1,e) = expr e
368              and (fv2,b) = branches b in
369              (Fv.union fv1 fv2, Typed.Try (e, b))
370    in    in
371    fv,    fv,
372    { Typed.exp_loc = loc;    { Typed.exp_loc = loc;
# Line 426  Line 430 
430          | Some f -> Env.add f a.fun_typ env in          | Some f -> Env.add f a.fun_typ env in
431        List.iter        List.iter
432          (fun (t1,t2) ->          (fun (t1,t2) ->
433             ignore (type_check_branches loc env t1 a.fun_body t2 false)             ignore (type_check_branches loc env true t1 a.fun_body t2 false)
434          ) a.fun_iface;          ) a.fun_iface;
435        t        t
436    
437    | Match (e,b) ->    | Match (e,b) ->
438        let t = type_check env e b.br_accept true in        let t = type_check env e b.br_accept true in
439        type_check_branches loc env t b constr precise        type_check_branches loc env true t b constr precise
440    
441      | Try (e,b) ->
442          let te = type_check env e constr precise in
443          let tb = type_check_branches loc env false Types.any b constr precise in
444          Types.cup te tb
445    
446    | Pair (e1,e2) ->    | Pair (e1,e2) ->
447        let rects = Types.Product.get constr in        let rects = Types.Product.get constr in
# Line 493  Line 503 
503        let res =        let res =
504          Sequence.map          Sequence.map
505            (fun t ->            (fun t ->
506               type_check_branches loc env t b constr' (precise || (not exact)))               type_check_branches loc env true t b constr' (precise || (not exact)))
507            t in            t in
508        if not exact then check loc res constr "";        if not exact then check loc res constr "";
509        if precise then res else constr        if precise then res else constr
# Line 560  Line 570 
570        type_op loc op args        type_op loc op args
571    | Map (e,b) ->    | Map (e,b) ->
572        let t = compute_type env e in        let t = compute_type env e in
573        Sequence.map (fun t -> type_check_branches loc env t b Types.any true) t        Sequence.map (fun t -> type_check_branches loc env true t b Types.any true) t
574    
575  (* We keep these cases here to allow comparison and benchmarking ...  (* We keep these cases here to allow comparison and benchmarking ...
576     Just comment the corresponding cases in type_check' to     Just comment the corresponding cases in type_check' to
# Line 581  Line 591 
591    
592    | _ -> assert false    | _ -> assert false
593    
594  and type_check_branches loc env targ brs constr precise =  and type_check_branches loc env exh targ brs constr precise =
595    if Types.is_empty targ then Types.empty    if Types.is_empty targ then Types.empty
596    else (    else (
597      brs.br_typ <- Types.cup brs.br_typ targ;      brs.br_typ <- Types.cup brs.br_typ targ;
598      branches_aux loc env targ      branches_aux loc env exh targ
599        (if precise then Types.empty else constr)        (if precise then Types.empty else constr)
600        constr precise brs.br_branches        constr precise brs.br_branches
601    )    )
602    
603  and branches_aux loc env targ tres constr precise = function  and branches_aux loc env exh targ tres constr precise = function
604    | [] -> raise_loc loc (NonExhaustive targ)    | [] -> if exh then raise_loc loc (NonExhaustive targ) else tres
605    | b :: rem ->    | b :: rem ->
606        let p = b.br_pat in        let p = b.br_pat in
607        let acc = Types.descr (Patterns.accept p) in        let acc = Types.descr (Patterns.accept p) in
608    
609        let targ' = Types.cap targ acc in        let targ' = Types.cap targ acc in
610        if Types.is_empty targ'        if Types.is_empty targ'
611        then branches_aux loc env targ tres constr precise rem        then branches_aux loc env exh targ tres constr precise rem
612        else        else
613          ( b.br_used <- true;          ( b.br_used <- true;
614            let res = Patterns.filter targ' p in            let res = Patterns.filter targ' p in
# Line 609  Line 619 
619            let tres = if precise then Types.cup t tres else tres in            let tres = if precise then Types.cup t tres else tres in
620            let targ'' = Types.diff targ acc in            let targ'' = Types.diff targ acc in
621            if (Types.non_empty targ'') then            if (Types.non_empty targ'') then
622              branches_aux loc env targ'' tres constr precise rem              branches_aux loc env exh targ'' tres constr precise rem
623            else            else
624              tres              tres
625          )          )
# Line 634  Line 644 
644          check loc1 t1 Sequence.string          check loc1 t1 Sequence.string
645            "The argument of load_xml must be a string (filename)";            "The argument of load_xml must be a string (filename)";
646          Types.any          Types.any
647        | "raise", [loc1,t1] ->
648            Types.empty
649      | _ -> assert false      | _ -> assert false
650    
651  and type_int_binop f loc1 t1 loc2 t2 =  and type_int_binop f loc1 t1 loc2 t2 =
Legend:
Removed from v.63  
changed lines
  Added in v.64
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5