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

Diff of /typing/typer.ml

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

revision 12 by abate, Tue Jul 10 16:57:31 2007 UTC revision 13 by abate, Tue Jul 10 16:57:42 2007 UTC
# Line 42  Line 42 
42    
43  let mk' =  let mk' =
44    let counter = ref 0 in    let counter = ref 0 in
45    fun () ->    fun loc ->
46      incr counter;      incr counter;
47      let rec x = {      let rec x = {
48        id = !counter;        id = !counter;
49        loc' = noloc;        loc' = loc;
50        fv = None;        fv = None;
51        descr' = `Alias ("__dummy__", x);        descr' = `Alias ("__dummy__", x);
52        type_node = None;        type_node = None;
# Line 55  Line 55 
55      x      x
56    
57  let cons loc d =  let cons loc d =
58    let x = mk' () in    let x = mk' loc in
   x.loc' <- loc;  
59    x.descr' <- d;    x.descr' <- d;
60    x    x
61    
# Line 158  Line 157 
157         with Not_found ->         with Not_found ->
158           raise_loc loc (Pattern ("Undefined type variable " ^ s))           raise_loc loc (Pattern ("Undefined type variable " ^ s))
159        )        )
160    | Recurs (t, b) ->    | Recurs (t, b) -> compile (compile_many env b) t
       let b = List.map (fun (v,t) -> (v,t,mk' ())) b in  
       let env =  
         List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in  
       List.iter  
         (fun (v,t,x) -> x.loc' <- t.loc; x.descr' <- `Alias (v, compile env t))  
         b;  
       compile env t  
161    | Regexp (r,q) -> compile env (Regexp.compile r q)    | Regexp (r,q) -> compile env (Regexp.compile r q)
162    | Internal t -> cons loc (`Type t)    | Internal t -> cons loc (`Type t)
163    | Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))    | Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
# Line 177  Line 169 
169    | Constant (x,v) -> cons loc (`Constant (x,v))    | Constant (x,v) -> cons loc (`Constant (x,v))
170    | Capture x -> cons loc (`Capture x)    | Capture x -> cons loc (`Capture x)
171    
172    and compile_many env b =
173      let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in
174      let env =
175        List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
176      List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
177      env
178    
179    
180  let rec comp_fv seen s =  let rec comp_fv seen s =
181    match s.fv with    match s.fv with
182      | Some l -> l      | Some l -> l
# Line 266  Line 266 
266          Patterns.define x t;          Patterns.define x t;
267          x          x
268    
269  let typ e =  let global_types = ref StringMap.empty
270    let e = compile StringMap.empty e in  
271    let mk_typ e =
272    if fv e = [] then type_node e    if fv e = [] then type_node e
273    else (raise_loc e.loc'    else raise_loc e.loc' (Pattern "Capture variables are not allowed in types")
274            (Pattern "Capture variables are not allowed in types"))  
275    
276    let typ e =
277      mk_typ (compile !global_types e)
278    
279  let pat e =  let pat e =
280    let e = compile StringMap.empty e in    let e = compile !global_types e in
281    pat_node e    pat_node e
282    
283    let register_global_types b =
284      let env = compile_many !global_types b in
285      List.iter (fun (v,_) -> ignore (mk_typ (StringMap.find v env))) b;
286      global_types := env
287    
288    
289  (* II. Build skeleton *)  (* II. Build skeleton *)
Legend:
Removed from v.12  
changed lines
  Added in v.13
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5