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

Diff of /typing/typer.ml

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

revision 354 by abate, Tue Jul 10 17:26:17 2007 UTC revision 355 by abate, Tue Jul 10 17:27:46 2007 UTC
# Line 27  Line 27 
27  exception NonExhaustive of Types.descr  exception NonExhaustive of Types.descr
28  exception Constraint of Types.descr * Types.descr * string  exception Constraint of Types.descr * Types.descr * string
29  exception ShouldHave of Types.descr * string  exception ShouldHave of Types.descr * string
30    exception ShouldHave2 of Types.descr * string * Types.descr
31  exception WrongLabel of Types.descr * label  exception WrongLabel of Types.descr * label
32  exception UnboundId of string  exception UnboundId of string
33    
# Line 264  Line 265 
265      (s1 == s2) ||      (s1 == s2) ||
266      (incr gen; rank := 0;      (incr gen; rank := 0;
267       let e = equal_slot s1 s2 in       let e = equal_slot s1 s2 in
268  (*     if e then Printf.eprintf "Equal\n"; *)  (*     if e then Printf.eprintf "Recursive hash-consig: Equal\n";  *)
269       e)       e)
270  end  end
271  module SlotTable = Hashtbl.Make(Arg)  module SlotTable = Hashtbl.Make(Arg)
# Line 813  Line 814 
814      (match kind with      (match kind with
815        | `Normal -> raise_loc loc (ShouldHave (constr,"but it is a pair."))        | `Normal -> raise_loc loc (ShouldHave (constr,"but it is a pair."))
816        | `XML -> raise_loc loc (ShouldHave (constr,"but it is an XML element.")));        | `XML -> raise_loc loc (ShouldHave (constr,"but it is an XML element.")));
   let pi1 = Types.Product.pi1 rects in  
   
817    let need_s = Types.Product.need_second rects in    let need_s = Types.Product.need_second rects in
818  (*  Printf.eprintf "need_second: %b\n" need_s; *)    let t1 = type_check env e1 (Types.Product.pi1 rects) (precise || need_s) in
819    let precise = precise || need_s in    let c2 = Types.Product.constraint_on_2 rects t1 in
820    let t1 = type_check env e1 (Types.Product.pi1 rects) precise in    if Types.is_empty c2 then
821    let rects = Types.Product.restrict_1 rects t1 in      raise_loc loc (ShouldHave2 (constr,"but the first component has type",t1));
822    let t2 = type_check env e2 (Types.Product.pi2 rects) precise in    let t2 = type_check env e2 c2 precise in
823    
824    if precise then    if precise then
     let t =  
825        match kind with        match kind with
826          | `Normal -> Types.times (Types.cons t1) (Types.cons t2)          | `Normal -> Types.times (Types.cons t1) (Types.cons t2)
827          | `XML -> Types.xml (Types.cons t1) (Types.cons t2) in        | `XML -> Types.xml (Types.cons t1) (Types.cons t2)
     check loc t constr "";  
     t  
828    else    else
829      constr      constr
830    
Legend:
Removed from v.354  
changed lines
  Added in v.355
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5