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

Diff of /typing/typer.ml

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

revision 35 by abate, Tue Jul 10 16:59:36 2007 UTC revision 36 by abate, Tue Jul 10 16:59:49 2007 UTC
# Line 10  Line 10 
10  exception Constraint of Types.descr * Types.descr * string  exception Constraint of Types.descr * Types.descr * string
11  exception ShouldHave of Types.descr * string  exception ShouldHave of Types.descr * string
12  exception WrongLabel of Types.descr * Types.label  exception WrongLabel of Types.descr * Types.label
13    exception UnboundId of string
14    
15  let raise_loc loc exn = raise (Location (loc,exn))  let raise_loc loc exn = raise (Location (loc,exn))
16    
# Line 287  Line 288 
288    let env = compile_many !global_types b in    let env = compile_many !global_types b in
289    List.iter (fun (v,_) ->    List.iter (fun (v,_) ->
290                 let d = Types.descr (mk_typ (StringMap.find v env)) in                 let d = Types.descr (mk_typ (StringMap.find v env)) in
291                   let d = Types.normalize d in
292                 Types.Print.register_global v d                 Types.Print.register_global v d
293              ) b;              ) b;
294    global_types := env    global_types := env
# Line 399  Line 401 
401    
402  let rec type_check env e constr precise =  let rec type_check env e constr precise =
403  (*  Format.fprintf Format.std_formatter "constr=%a precise=%b@\n"  (*  Format.fprintf Format.std_formatter "constr=%a precise=%b@\n"
404      Types.Print.print_descr constr precise;      Types.Print.print_descr constr precise;  *)
405  *)  
406    
407    let d = type_check' e.exp_loc env e.exp_descr constr precise in    let d = type_check' e.exp_loc env e.exp_descr constr precise in
408    e.exp_typ <- Types.cup e.exp_typ d;    e.exp_typ <- Types.cup e.exp_typ d;
# Line 477  Line 479 
479        let constr' = Sequence.approx (Types.cap Sequence.any constr) in        let constr' = Sequence.approx (Types.cap Sequence.any constr) in
480        let exact = Types.subtype (Sequence.star constr') constr in        let exact = Types.subtype (Sequence.star constr') constr in
481    
482        if exact then        if exact then (
483          let res = type_check_branches loc env t b constr' precise in          (* Note: typing mail fail because of the approx on t *)
484            let res = type_check_branches loc env (Sequence.approx t)
485                        b constr' precise in
486          if precise then Sequence.star res else constr          if precise then Sequence.star res else constr
487          )
488        else        else
489          (* Note:          (* Note:
490             - could be more precise by integrating the decomposition             - could be more precise by integrating the decomposition
# Line 531  Line 536 
536    
537  and compute_type' loc env = function  and compute_type' loc env = function
538    | DebugTyper t -> Types.descr t    | DebugTyper t -> Types.descr t
539    | Var s -> Env.find s env    | Var s ->
540          (try Env.find s env
541           with Not_found -> raise_loc loc (UnboundId s)
542          )
543    | Apply (e1,e2) ->    | Apply (e1,e2) ->
544        let t1 = type_check env e1 Types.Arrow.any true in        let t1 = type_check env e1 Types.Arrow.any true in
545        let t1 = Types.Arrow.get t1 in        let t1 = Types.Arrow.get t1 in
Legend:
Removed from v.35  
changed lines
  Added in v.36
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5