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

Diff of /typing/typer.ml

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

revision 109 by abate, Tue Jul 10 17:06:47 2007 UTC revision 110 by abate, Tue Jul 10 17:07:14 2007 UTC
# Line 31  Line 31 
31     | `And of ti * ti * bool     | `And of ti * ti * bool
32     | `Diff of ti * ti     | `Diff of ti * ti
33     | `Times of ti * ti     | `Times of ti * ti
34       | `Xml of ti * ti
35     | `Arrow of ti * ti     | `Arrow of ti * ti
36     | `Record of Types.label * bool * ti     | `Record of Types.label * bool * ti
37     | `Capture of Patterns.capture     | `Capture of Patterns.capture
# Line 190  Line 191 
191    | And (t1,t2,e) -> cons loc (`And (compile env t1, compile env t2,e))    | And (t1,t2,e) -> cons loc (`And (compile env t1, compile env t2,e))
192    | Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))    | Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))
193    | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))    | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
194      | XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))
195    | Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))    | Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
196    | Record (l,o,t) -> cons loc (`Record (l,o,compile env t))    | Record (l,o,t) -> cons loc (`Record (l,o,compile env t))
197    | Constant (x,v) -> cons loc (`Constant (x,v))    | Constant (x,v) -> cons loc (`Constant (x,v))
# Line 213  Line 215 
215        | `Or (s1,s2)        | `Or (s1,s2)
216        | `And (s1,s2,_)        | `And (s1,s2,_)
217        | `Diff (s1,s2)        | `Diff (s1,s2)
218        | `Times (s1,s2)        | `Times (s1,s2) | `Xml (s1,s2)
219        | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2        | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
220        | `Record (l,opt,s) -> comp_fv s        | `Record (l,opt,s) -> comp_fv s
221        | `Type _ -> ()        | `Type _ -> ()
# Line 248  Line 250 
250      | `And (s1,s2,_) ->  Types.cap (typ seen s1) (typ seen s2)      | `And (s1,s2,_) ->  Types.cap (typ seen s1) (typ seen s2)
251      | `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)      | `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
252      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
253        | `Xml (s1,s2) ->   Types.xml (typ_node s1) (typ_node s2)
254      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
255      | `Record (l,o,s) -> Types.record l o (typ_node s)      | `Record (l,o,s) -> Types.record l o (typ_node s)
256      | `Capture _ | `Constant _ -> assert false      | `Capture _ | `Constant _ -> assert false
# Line 290  Line 293 
293    | `Diff _ ->    | `Diff _ ->
294        raise (Patterns.Error "Difference not allowed in patterns")        raise (Patterns.Error "Difference not allowed in patterns")
295    | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)    | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
296      | `Xml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
297    | `Record (l,false,s) -> Patterns.record l (pat_node s)    | `Record (l,false,s) -> Patterns.record l (pat_node s)
298    | `Record _ ->    | `Record _ ->
299        raise (Patterns.Error "Optional field not allowed in record patterns")        raise (Patterns.Error "Optional field not allowed in record patterns")
# Line 375  Line 379 
379        | Pair (e1,e2) ->        | Pair (e1,e2) ->
380            let (fv1,e1) = expr glb e1 and (fv2,e2) = expr glb e2 in            let (fv1,e1) = expr glb e1 and (fv2,e2) = expr glb e2 in
381            (Fv.union fv1 fv2, Typed.Pair (e1,e2))            (Fv.union fv1 fv2, Typed.Pair (e1,e2))
382          | Xml (e1,e2) ->
383              let (fv1,e1) = expr glb e1 and (fv2,e2) = expr glb e2 in
384              (Fv.union fv1 fv2, Typed.Xml (e1,e2))
385        | Dot (e,l) ->        | Dot (e,l) ->
386            let (fv,e) = expr glb e in            let (fv,e) = expr glb e in
387            (fv,  Typed.Dot (e,l))            (fv,  Typed.Dot (e,l))
# Line 498  Line 505 
505        Types.cup te tb        Types.cup te tb
506    
507    | Pair (e1,e2) ->    | Pair (e1,e2) ->
508        let rects = Types.Product.get constr in        type_check_pair loc env e1 e2 constr precise
509        if Types.Product.is_empty rects then    | Xml (e1,e2) ->
510          raise_loc loc (ShouldHave (constr,"but it is a pair."));        type_check_pair ~kind:`XML loc env e1 e2 constr precise
       let pi1 = Types.Product.pi1 rects in  
   
       let t1 = type_check env e1 (Types.Product.pi1 rects)  
                  (precise || (Types.Product.need_second rects))in  
       let rects = Types.Product.restrict_1 rects t1 in  
       let t2 = type_check env e2 (Types.Product.pi2 rects) precise in  
       if precise then  
         Types.times (Types.cons t1) (Types.cons t2)  
       else  
         constr  
   
511    | RecordLitt r ->    | RecordLitt r ->
512        let rconstr = Types.Record.get constr in        let rconstr = Types.Record.get constr in
513        if Types.Record.is_empty rconstr then        if Types.Record.is_empty rconstr then
# Line 575  Line 571 
571          check loc res constr "";          check loc res constr "";
572          if precise then res else constr          if precise then res else constr
573    | Apply (e1,e2) ->    | Apply (e1,e2) ->
574    (*
575        let constr' = Sequence.star        let constr' = Sequence.star
576                        (Sequence.approx (Types.cap Sequence.any constr)) in                        (Sequence.approx (Types.cap Sequence.any constr)) in
577        let t1 = type_check env e1 (Types.cup Types.Arrow.any constr') true in        let t1 = type_check env e1 (Types.cup Types.Arrow.any constr') true in
# Line 601  Line 598 
598        in        in
599        check loc res constr "";        check loc res constr "";
600        res        res
601  (*  *)
602        let t1 = type_check env e1 Types.Arrow.any true in        let t1 = type_check env e1 Types.Arrow.any true in
603        let t1 = Types.Arrow.get t1 in        let t1 = Types.Arrow.get t1 in
604        let dom = Types.Arrow.domain t1 in        let dom = Types.Arrow.domain t1 in
605          let res =
606        if Types.Arrow.need_arg t1 then        if Types.Arrow.need_arg t1 then
607          let t2 = type_check env e2 dom true in          let t2 = type_check env e2 dom true in
608          Types.Arrow.apply t1 t2          Types.Arrow.apply t1 t2
609        else        else
610          (ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)          (ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
611  *)        in
612          check loc res constr "";
613          res
614    | Op ("flatten", [e]) ->    | Op ("flatten", [e]) ->
615        let constr' = Sequence.star        let constr' = Sequence.star
616                        (Sequence.approx (Types.cap Sequence.any constr)) in                        (Sequence.approx (Types.cap Sequence.any constr)) in
# Line 630  Line 629 
629        check loc t constr "";        check loc t constr "";
630        t        t
631    
632    and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
633      let rects = Types.Product.get ~kind constr in
634      if Types.Product.is_empty rects then
635        (match kind with
636          | `Normal -> raise_loc loc (ShouldHave (constr,"but it is a pair."))
637          | `XML -> raise_loc loc (ShouldHave (constr,"but it is an XML element.")));
638      let pi1 = Types.Product.pi1 rects in
639    
640      let t1 = type_check env e1 (Types.Product.pi1 rects)
641                 (precise || (Types.Product.need_second rects))in
642      let rects = Types.Product.restrict_1 rects t1 in
643      let t2 = type_check env e2 (Types.Product.pi2 rects) precise in
644      if precise then
645        match kind with
646          | `Normal -> Types.times (Types.cons t1) (Types.cons t2)
647          | `XML -> Types.xml (Types.cons t1) (Types.cons t2)
648      else
649        constr
650    
651    
652  and compute_type env e =  and compute_type env e =
653    type_check env e Types.any true    type_check env e Types.any true
654    
Legend:
Removed from v.109  
changed lines
  Added in v.110
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5