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

Diff of /typing/typer.ml

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

revision 120 by abate, Tue Jul 10 17:07:37 2007 UTC revision 121 by abate, Tue Jul 10 17:08:00 2007 UTC
# Line 28  Line 28 
28     [ `Alias of string * ti     [ `Alias of string * ti
29     | `Type of Types.descr     | `Type of Types.descr
30     | `Or of ti * ti     | `Or of ti * ti
31     | `And of ti * ti * bool     | `And of ti * ti
32     | `Diff of ti * ti     | `Diff of ti * ti
33     | `Times of ti * ti     | `Times of ti * ti
34     | `Xml of ti * ti     | `Xml of ti * ti
# Line 109  Line 109 
109      | WeakStar r -> `WeakStar (propagate vars r)      | WeakStar r -> `WeakStar (propagate vars r)
110      | SeqCapture (v,x) ->      | SeqCapture (v,x) ->
111          let v= mk !re_loc (Capture v) in          let v= mk !re_loc (Capture v) in
112          propagate (fun p -> mk !re_loc (And (vars p,v,true))) x          propagate (fun p -> mk !re_loc (And (vars p,v))) x
113    
114    let cup r1 r2 =    let cup r1 r2 =
115      match (r1,r2) with      match (r1,r2) with
# Line 160  Line 160 
160    
161    let constant_nil v t =    let constant_nil v t =
162      mk !re_loc      mk !re_loc
163        (And (t,        (And (t, (mk !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))
             (mk !re_loc (Constant (v, Types.Atom Sequence.nil_atom))), true))  
164    
165    let compile loc regexp queue : ppat =    let compile loc regexp queue : ppat =
166      re_loc := loc;      re_loc := loc;
# Line 188  Line 187 
187    | Regexp (r,q) -> compile env (Regexp.compile loc r q)    | Regexp (r,q) -> compile env (Regexp.compile loc r q)
188    | Internal t -> cons loc (`Type t)    | Internal t -> cons loc (`Type t)
189    | Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))    | Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
190    | And (t1,t2,e) -> cons loc (`And (compile env t1, compile env t2,e))    | And (t1,t2) -> cons loc (`And (compile env t1, compile env t2))
191    | Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))    | Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))
192    | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))    | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
193    | XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))    | XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))
# Line 216  Line 215 
215            (match s.descr' with            (match s.descr' with
216               | `Alias (_,x) -> comp_fv x               | `Alias (_,x) -> comp_fv x
217               | `Or (s1,s2)               | `Or (s1,s2)
218               | `And (s1,s2,_)               | `And (s1,s2)
219               | `Diff (s1,s2)               | `Diff (s1,s2)
220               | `Times (s1,s2) | `Xml (s1,s2)               | `Times (s1,s2) | `Xml (s1,s2)
221               | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2               | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
# Line 249  Line 248 
248          else typ (s :: seen) x          else typ (s :: seen) x
249      | `Type t -> t      | `Type t -> t
250      | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)      | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
251      | `And (s1,s2,_) ->  Types.cap (typ seen s1) (typ seen s2)      | `And (s1,s2) ->  Types.cap (typ seen s1) (typ seen s2)
252      | `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)      | `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
253      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
254      | `Xml (s1,s2) ->   Types.xml (typ_node s1) (typ_node s2)      | `Xml (s1,s2) ->   Types.xml (typ_node s1) (typ_node s2)
255      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
256      | `Record (l,o,s) -> Types.record l o (typ_node s)      | `Record (l,o,s) -> Types.record l o (typ_node s)
257      | `Capture x -> failwith ("bla1:" ^ x)      | `Capture x | `Constant (x,_) -> assert false
     | `Constant (x,_) ->  
         (match s.fv with  
           | Some fv ->  
               List.iter (fun y -> Printf.eprintf "+++%s++++\n" y) fv);  
         failwith ("bla:" ^ x); assert false  
258    
259  and typ_node s : Types.node =  and typ_node s : Types.node =
260    match s.type_node with    match s.type_node with
# Line 279  Line 273 
273    s    s
274    
275  let rec pat seen s : Patterns.descr =  let rec pat seen s : Patterns.descr =
276    if fv s = [] then Patterns.constr (type_node s) else    if fv s = [] then Patterns.constr (Types.descr (type_node s)) else
277      try pat_aux seen s      try pat_aux seen s
278      with Patterns.Error e -> raise_loc_generic s.loc' e      with Patterns.Error e -> raise_loc_generic s.loc' e
279        | Location (loc,exn) when loc = noloc -> raise (Location (s.loc', exn))        | Location (loc,exn) when loc = noloc -> raise (Location (s.loc', exn))
# Line 293  Line 287 
287             ("Unguarded recursion on variable " ^ v ^ " in this pattern"));             ("Unguarded recursion on variable " ^ v ^ " in this pattern"));
288        pat (s :: seen) x        pat (s :: seen) x
289    | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)    | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
290    | `And (s1,s2,e) -> Patterns.cap (pat seen s1) (pat seen s2) e    | `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
291    | `Diff (s1,s2) when fv s2 = [] ->    | `Diff (s1,s2) when fv s2 = [] ->
292        let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in        let s2 = Types.neg (Types.descr (type_node s2)) in
293        Patterns.cap (pat seen s1) (Patterns.constr s2) true        Patterns.cap (pat seen s1) (Patterns.constr s2)
294    | `Diff _ ->    | `Diff _ ->
295        raise (Patterns.Error "Difference not allowed in patterns")        raise (Patterns.Error "Difference not allowed in patterns")
296    | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)    | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
Legend:
Removed from v.120  
changed lines
  Added in v.121
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5