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

Diff of /typing/typer.ml

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

revision 277 by abate, Tue Jul 10 17:21:46 2007 UTC revision 278 by abate, Tue Jul 10 17:21:59 2007 UTC
# Line 1  Line 1 
1  (* TODO:  (* TODO:
2   - rewrite type-checking of operators to propagate constraint   - rewrite type-checking of operators to propagate constraint
3   - rewrite translation of types and patterns -> hash cons   - optimize computation of pattern free variables
4       CONTINUE THIS...   - check whether it is worth using recursive hash-consing internally
      Problem with same name for recursive binders in different  
      recursive type/patterns definitions because of hash-consing  
5  *)  *)
6    
7    
# Line 17  Line 15 
15  module S = struct type t = string let compare = compare end  module S = struct type t = string let compare = compare end
16  module StringSet = Set.Make(S)  module StringSet = Set.Make(S)
17  module TypeEnv = Map.Make(S)  module TypeEnv = Map.Make(S)
18  module Env = Map.Make(Ident.Id)  module Env = Map.Make(Id)
19    
20    
21  exception NonExhaustive of Types.descr  exception NonExhaustive of Types.descr
# Line 28  Line 26 
26    
27  let raise_loc loc exn = raise (Location (loc,exn))  let raise_loc loc exn = raise (Location (loc,exn))
28    
 (* Note:  
    Compilation of Regexp is implemented as a ``rewriting'' of  
    the parsed syntax, in order to be able to print its result  
    (for debugging for instance)  
29    
30     It would be possible (and a little more efficient) to produce  (* Eliminate Recursion, propagate Sequence Capture Variables *)
    directly ti nodes.  
 *)  
   
 module Regexp = struct  
   let defs = ref []  
   let name =  
     let c = ref 0 in  
     fun () ->  
       incr c;  
       "#" ^ (string_of_int !c)  
31    
32    let rec seq_vars accu = function    let rec seq_vars accu = function
33      | Epsilon | Elem _ -> accu      | Epsilon | Elem _ -> accu
# Line 51  Line 35 
35      | Star r | WeakStar r -> seq_vars accu r      | Star r | WeakStar r -> seq_vars accu r
36      | SeqCapture (v,r) -> seq_vars (IdSet.add v accu) r      | SeqCapture (v,r) -> seq_vars (IdSet.add v accu) r
37    
38    let uniq_id = let r = ref 0 in fun () -> incr r; !r  type derecurs_slot = {
39      ploc : Location.loc;
40    type flat =    pid  : int;
41      | REpsilon    mutable ploop : bool;
42      | RElem of int * Ast.ppat  (* the int arg is used    mutable pdescr : derecurs option
43                                              to stop generic comparison *)  } and derecurs =
44      | RSeq of flat * flat    | PAlias of derecurs_slot
45      | RAlt of flat * flat    | PType of Types.descr
46      | RStar of flat    | POr of derecurs * derecurs
47      | RWeakStar of flat    | PAnd of derecurs * derecurs
48      | PDiff of derecurs * derecurs
49    let re_loc = ref noloc    | PTimes of derecurs * derecurs
50      | PXml of derecurs * derecurs
51    let rec propagate vars : regexp -> flat = function    | PArrow of derecurs * derecurs
52      | Epsilon -> REpsilon    | POptional of derecurs
53      | Elem x -> let p = vars x in RElem (uniq_id (),p)    | PRecord of bool * derecurs label_map
54      | Seq (r1,r2) -> RSeq (propagate vars r1,propagate vars r2)    | PCapture of id
55      | Alt (r1,r2) -> RAlt (propagate vars r1, propagate vars r2)    | PConstant of id * Types.const
56      | Star r -> RStar (propagate vars r)    | PRegexp of derecurs_regexp * derecurs
57      | WeakStar r -> RWeakStar (propagate vars r)  and derecurs_regexp =
58      | SeqCapture (v,x) ->    | PEpsilon
59          let v= mk_loc !re_loc (Capture v) in    | PElem of derecurs
60          propagate (fun p -> mk_loc !re_loc (And (vars p,v))) x    | PSeq of derecurs_regexp * derecurs_regexp
61      | PAlt of derecurs_regexp * derecurs_regexp
62    let dummy_pat = mknoloc (PatVar "DUMMY")    | PStar of derecurs_regexp
63    let cup r1 r2 =    | PWeakStar of derecurs_regexp
64      if r1 == dummy_pat then r2 else  
65        if r2 == dummy_pat then r1 else  let rec hash_derecurs = function
66          mk_loc !re_loc (Or (r1,r2))    | PAlias s -> s.pid
67      | PType t -> 1 + 17 * (Types.hash_descr t)
68  (*TODO: review this compilation schema to avoid explosion when    | POr (p1,p2) -> 2 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
69    coding (Optional x) by  (Or(Epsilon,x)); memoization ... *)    | PAnd (p1,p2) -> 3 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
70      | PDiff (p1,p2) -> 4 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
71    module Memo = Map.Make(struct type t = flat list let compare = compare end)    | PTimes (p1,p2) -> 5 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
72    module Coind = Set.Make(struct type t = flat list let compare = compare end)    | PXml (p1,p2) -> 6 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
73    let memo = ref Memo.empty    | PArrow (p1,p2) -> 7 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
74      | POptional p -> 8 + 17 * (hash_derecurs p)
75      | PRecord (o,r) -> (if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs r)
76      | PCapture x -> 11 + 17 * (Id.hash x)
77      | PConstant (x,c) -> 12 + 17 * (Id.hash x) + 257 * (Types.hash_const c)
78      | PRegexp (p,q) -> 13 + 17 * (hash_derecurs_regexp p) + 257 * (hash_derecurs q)
79    and hash_derecurs_regexp = function
80      | PEpsilon -> 1
81      | PElem p -> 2 + 17 * (hash_derecurs p)
82      | PSeq (p1,p2) -> 3 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
83      | PAlt (p1,p2) -> 4 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
84      | PStar p -> 5 + 17 * (hash_derecurs_regexp p)
85      | PWeakStar p -> 6 + 17 * (hash_derecurs_regexp p)
86    
87    let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
88      | PAlias s1, PAlias s2 -> s1 == s2
89      | PType t1, PType t2 -> Types.equal_descr t1 t2
90      | POr (p1,q1), POr (p2,q2)
91      | PAnd (p1,q1), PAnd (p2,q2)
92      | PDiff (p1,q1), PDiff (p2,q2)
93      | PTimes (p1,q1), PTimes (p2,q2)
94      | PXml (p1,q1), PXml (p2,q2)
95      | PArrow (p1,q1), PArrow (p2,q2) -> (equal_derecurs p1 p2) && (equal_derecurs q1 q2)
96      | POptional p1, POptional p2 -> equal_derecurs p1 p2
97      | PRecord (o1,r1), PRecord (o2,r2) -> (o1 == o2) && (LabelMap.equal equal_derecurs r1 r2)
98      | PCapture x1, PCapture x2 -> Id.equal x1 x2
99      | PConstant (x1,c1), PConstant (x2,c2) -> (Id.equal x1 x2) && (Types.equal_const c1 c2)
100      | PRegexp (p1,q1), PRegexp (p2,q2) -> (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
101      | _ -> false
102    and equal_derecurs_regexp r1 r2 = match r1,r2 with
103      | PEpsilon, PEpsilon -> true
104      | PElem p1, PElem p2 -> equal_derecurs p1 p2
105      | PSeq (p1,q1), PSeq (p2,q2)
106      | PAlt (p1,q1), PAlt (p2,q2) -> (equal_derecurs_regexp p1 p2) && (equal_derecurs_regexp q1 q2)
107      | PStar p1, PStar p2
108      | PWeakStar p1, PWeakStar p2 -> equal_derecurs_regexp p1 p2
109      | _ -> false
110    
111    let rec compile fin e seq : Ast.ppat =  module DerecursTable = Hashtbl.Make(
112      if Coind.mem seq !e then dummy_pat    struct
113      else (      type t = derecurs
114        e := Coind.add seq !e;      let hash = hash_derecurs
115        match seq with      let equal = equal_derecurs
116          | [] ->    end
             fin  
         | REpsilon :: rest ->  
             compile fin e rest  
         | RElem (_,p) :: rest ->  
             mk_loc !re_loc (Prod (p, guard_compile fin rest))  
         | RSeq (r1,r2) :: rest ->  
             compile fin e (r1 :: r2 :: rest)  
         | RAlt (r1,r2) :: rest ->  
             cup (compile fin e (r1::rest)) (compile fin e (r2::rest))  
         | RStar r :: rest ->  
             cup (compile fin e (r::seq)) (compile fin e rest)  
         | RWeakStar r :: rest ->  
             cup (compile fin e rest) (compile fin e (r::seq))  
117      )      )
   and guard_compile fin seq =  
     try Memo.find seq !memo  
     with  
         Not_found ->  
           let n = name () in  
           let v = mk_loc !re_loc (PatVar n) in  
           memo := Memo.add seq v !memo;  
           let d = compile fin (ref Coind.empty) seq in  
           assert (d != dummy_pat);  
           defs := (n,d) :: !defs;  
           v  
   
   let constant_nil t v =  
     mk_loc !re_loc  
       (And (t, (mk_loc !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))  
   
   let compile loc regexp queue : ppat =  
     re_loc := loc;  
     let vars = seq_vars IdSet.empty regexp in  
     let fin = IdSet.fold constant_nil queue vars in  
     let re = propagate (fun p -> p) regexp in  
     let n = guard_compile fin [re] in  
     memo := Memo.empty;  
     let d = !defs in  
     defs := [];  
     mk_loc !re_loc (Recurs (n,d))  
118    
119  (*  module RE = Hashtbl.Make(
   module H = Hashtbl.Make(  
120      struct      struct
121        type t = Ast.regexp * Ast.ppat      type t = derecurs_regexp * derecurs
122        let equal (r1,p1) (r2,p2) =      let hash (p,q) = (hash_derecurs_regexp p) + 17 * (hash_derecurs q)
123          (Ast.equal_regexp r1 r2) &&      let equal (p1,q1) (p2,q2) = (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
         (Ast.equal_ppat p1 p2)  
       let hash (r,p) =  
         (Ast.hash_regexp r) + 16637 * (Ast.hash_ppat p)  
     end)  
   let hash = H.create 67  
   
   let compile loc regexp queue : ppat =  
     try  
       let c = H.find hash (regexp,queue) in  
 (*      Printf.eprintf "regexp cached\n"; flush stderr; *)  
       c  
     with  
         Not_found ->  
           let c = compile loc regexp queue in  
           H.add hash (regexp,queue) c;  
           c  
 *)  
124  end  end
125    )
126    
127    
128    let counter = State.ref "Typer.counter - derecurs" 0
129    let mk_slot loc =
130      incr counter;
131      { ploop = false; ploc = loc; pid = !counter; pdescr = None }
132    
133    let rec derecurs env p = match p.descr with
134      | PatVar v ->
135          (try PAlias (TypeEnv.find v env)
136           with Not_found -> raise_loc_generic p.loc ("Undefined type/pattern " ^ v))
137      | Recurs (p,b) -> derecurs (derecurs_def env b) p
138      | Internal t -> PType t
139      | Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)
140      | And (p1,p2) -> PAnd (derecurs env p1, derecurs env p2)
141      | Diff (p1,p2) -> PDiff (derecurs env p1, derecurs env p2)
142      | Prod (p1,p2) -> PTimes (derecurs env p1, derecurs env p2)
143      | XmlT (p1,p2) -> PXml (derecurs env p1, derecurs env p2)
144      | Arrow (p1,p2) -> PArrow (derecurs env p1, derecurs env p2)
145      | Optional p -> POptional (derecurs env p)
146      | Record (o,r) -> PRecord (o, LabelMap.map (derecurs env) r)
147      | Capture x -> PCapture x
148      | Constant (x,c) -> PConstant (x,c)
149      | Regexp (r,q) ->
150          let constant_nil t v = PAnd (t, PConstant (v, Types.Atom Sequence.nil_atom)) in
151          let vars = seq_vars IdSet.empty r in
152          let q = IdSet.fold constant_nil (derecurs env q) vars in
153          let r = derecurs_regexp (fun p -> p) env r in
154          PRegexp (r, q)
155    and derecurs_regexp vars env = function
156      | Epsilon -> PEpsilon
157      | Elem p -> PElem (vars (derecurs env p))
158      | Seq (p1,p2) -> PSeq (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
159      | Alt (p1,p2) -> PAlt (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
160      | Star p -> PStar (derecurs_regexp vars env p)
161      | WeakStar p -> PStar (derecurs_regexp vars env p)
162      | SeqCapture (x,p) -> derecurs_regexp (fun p -> PAnd (vars p, PCapture x)) env p
163    
164    
165    and derecurs_def env b =
166      let b = List.map (fun (v,p) -> (v,p,mk_slot p.loc)) b in
167      let env = List.fold_left (fun env (v,p,s) -> TypeEnv.add v s env) env b in
168      List.iter (fun (v,p,s) -> s.pdescr <- Some (derecurs env p)) b;
169      env
170    
171    (* Stratification and recursive hash-consing *)
172    
 (*  
173  type descr =  type descr =
174    | IType of Types.descr    | IType of Types.descr
175    | IOr of descr * descr    | IOr of descr * descr
# Line 170  Line 178 
178    | ITimes of slot * slot    | ITimes of slot * slot
179    | IXml of slot * slot    | IXml of slot * slot
180    | IArrow of slot * slot    | IArrow of slot * slot
181    | IOptional of slot descr    | IOptional of descr
182    | IRecord of bool * slot label_map    | IRecord of bool * slot label_map
183    | ICapture of id    | ICapture of id
184    | IConstant of id * Types.const    | IConstant of id * Types.const
# Line 179  Line 187 
187    mutable hash : int option;    mutable hash : int option;
188    mutable rank1: int; mutable rank2: int;    mutable rank1: int; mutable rank2: int;
189    mutable gen1 : int; mutable gen2: int;    mutable gen1 : int; mutable gen2: int;
190    mutable d    : slot descr option    mutable d    : descr option
191  }  }
192    
193  let descr s =  let descr s =
# Line 211  Line 219 
219    )    )
220    
221  let rec equal_descr d1 d2 =  let rec equal_descr d1 d2 =
   (d1 == d2) ||  
222    match (d1,d2) with    match (d1,d2) with
223    | IType x1, IType x2 -> Types.equal_descr x1 x2    | IType x1, IType x2 -> Types.equal_descr x1 x2
224    | IOr (x1,y1), IOr (x2,y2)    | IOr (x1,y1), IOr (x2,y2)
# Line 247  Line 254 
254            s.hash <- Some h;            s.hash <- Some h;
255            h            h
256    
257    let equal s1 s2 = incr gen; rank := 0; equal_slot s1 s2    let equal s1 s2 =
258        (s1 == s2) ||
259        (incr gen; rank := 0;
260         let e = equal_slot s1 s2 in
261    (*     if e then Printf.eprintf "Equal\n"; *)
262         e)
263  end  end
264  module SlotTable = Hashtbl.Make(Arg)  module SlotTable = Hashtbl.Make(Arg)
265    
# Line 258  Line 270 
270          if s.gen1 = !gen then IdSet.empty          if s.gen1 = !gen then IdSet.empty
271          else (s.gen1 <- !gen; fv_descr (descr s))          else (s.gen1 <- !gen; fv_descr (descr s))
272  and fv_descr = function  and fv_descr = function
273      | IType _ -> IdSet.empty
274    | IOr (d1,d2)    | IOr (d1,d2)
275    | IAnd (d1,d2)    | IAnd (d1,d2)
276    | IDiff (d1,d2) -> IdSet.cup (fv_descr d1) (fv_descr d2)    | IDiff (d1,d2) -> IdSet.cup (fv_descr d1) (fv_descr d2)
# Line 267  Line 280 
280    | IArrow (s1,s2) -> IdSet.cup (fv_slot s1) (fv_slot s2)    | IArrow (s1,s2) -> IdSet.cup (fv_slot s1) (fv_slot s2)
281    | IRecord (o,r) -> List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_slot r)    | IRecord (o,r) -> List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_slot r)
282    | ICapture x | IConstant (x,_) -> IdSet.singleton x    | ICapture x | IConstant (x,_) -> IdSet.singleton x
283    | _ -> IdSet.empty  
284    
285  let compute_fv s =  let compute_fv s =
286    match s.fv with    match s.fv with
# Line 278  Line 291 
291          s.fv <- Some x          s.fv <- Some x
292    
293    
294  let counter = ref 0  let todo_fv = ref []
 let todo = ref []  
 let rec flush_fv () =  
   List.iter compute_fv !todo;  
   todo := []  
295    
296  let mk () =  let mk () =
297    let s =    let s =
# Line 291  Line 300 
300        hash = None;        hash = None;
301        rank1 = 0; rank2 = 0;        rank1 = 0; rank2 = 0;
302        gen1 = 0; gen2 = 0 } in        gen1 = 0; gen2 = 0 } in
303    todo := s :: !todo;    todo_fv := s :: !todo_fv;
304    s    s
305    
306  let compile_hash = Ast.PpatTable.create 65  let flush_fv () =
307      List.iter compute_fv !todo_fv;
308      todo_fv := []
309    
310    let compile_slot_hash = DerecursTable.create 67
311    let compile_hash = DerecursTable.create 67
312    
313  let defs = ref []  let defs = ref []
314  let rec compile env { loc = loc; descr = d } =  
315    match (d : Ast.ppat') with  let rec compile p =
316      | PatVar v ->    try DerecursTable.find compile_hash p
         let (d,loop) =  
           try TypeEnv.find v env  
317            with Not_found ->            with Not_found ->
318              raise_loc_generic loc ("Undefined type variable " ^ v) in      let c = real_compile p in
319          if !loop then      DerecursTable.replace compile_hash p c;
320            raise_loc_generic loc ("Unguarded recursion on type/pattern variable " ^ v);      c
321          loop := true;  and real_compile = function
322          let r = compile env d in    | PAlias v ->
323          loop := false;        if v.ploop then
324            raise_loc_generic v.ploc ("Unguarded recursion on type/pattern");
325          v.ploop <- true;
326          let r = match v.pdescr with Some x -> compile x | _ -> assert false in
327          v.ploop <- false;
328          r          r
329      | Recurs (t, b) -> compile (compile_many env b) t    | PType t -> IType t
330      | Regexp (r,q) -> compile env (Regexp.compile loc r q)    | POr (t1,t2) -> IOr (compile t1, compile t2)
331      | Internal t -> IType t    | PAnd (t1,t2) -> IAnd (compile t1, compile t2)
332      | Or (t1,t2) -> IOr (compile env t1, compile env t2)    | PDiff (t1,t2) -> IDiff (compile t1, compile t2)
333      | And (t1,t2) -> IAnd (compile env t1, compile env t2)    | PTimes (t1,t2) -> ITimes (compile_slot t1, compile_slot t2)
334      | Diff (t1,t2) -> IDiff (compile env t1, compile env t2)    | PXml (t1,t2) -> IXml (compile_slot t1, compile_slot t2)
335      | Prod (t1,t2) -> ITimes (compile_slot env t1, compile_slot env t2)    | PArrow (t1,t2) -> IArrow (compile_slot t1, compile_slot t2)
336      | XmlT (t1,t2) -> IXml (compile_slot env t1, compile_slot env t2)    | POptional t -> IOptional (compile t)
337      | Arrow (t1,t2) -> IArrow (compile_slot env t1, compile_slot env t2)    | PRecord (o,r) ->  IRecord (o, LabelMap.map compile_slot r)
338      | Optional t -> IOptional (compile env t)    | PConstant (x,v) -> IConstant (x,v)
339      | Record (o,r) ->  IRecord (o, LabelMap.map (compile_slot env) r)    | PCapture x -> ICapture x
340      | Constant (x,v) -> IConstant (x,v)    | PRegexp (r,q) -> compile_regexp r q
341      | Capture x -> ICapture x  and compile_regexp r q =
342  and compile_slot env ({ loc = loc; descr = d } as p) =    let memo = RE.create 17 in
343    try Ast.PpatTable.find compile_hash p    let rec aux accu r q =
344        if RE.mem memo (r,q) then accu
345        else (
346          RE.add memo (r,q) ();
347          match r with
348            | PEpsilon -> (match q with PRegexp (r,q) -> aux accu r q | _ -> (compile q) :: accu)
349            | PElem p -> ITimes (compile_slot p, compile_slot q) :: accu
350            | PSeq (r1,r2) -> aux accu r1 (PRegexp (r2,q))
351            | PAlt (r1,r2) -> aux (aux accu r1 q) r2 q
352            | PStar r1 -> aux (aux accu r1 (PRegexp (r,q))) PEpsilon q
353            | PWeakStar r1 -> aux (aux accu PEpsilon q) r1 (PRegexp (r,q))
354        )
355      in
356      let accu = aux [] r q in
357      match accu with
358        | [] -> assert false
359        | p::l -> List.fold_left (fun acc p -> IOr (p,acc)) p l
360    and compile_slot p =
361      try DerecursTable.find compile_slot_hash p
362    with Not_found ->    with Not_found ->
363      let s = mk () in      let s = mk () in
364      defs := (s,p,env) :: !defs;      defs := (s,p) :: !defs;
365      Ast.PpatTable.add compile_hash p s;      DerecursTable.add compile_slot_hash p s;
366      s      s
367    
 and compile_many env b =  
   List.fold_left (fun env (v,p) -> TypeEnv.add v (p,ref false) env) env b  
368    
369  let rec flush_defs () =  let rec flush_defs () =
370    match !defs with    match !defs with
371      | [] -> ()      | [] -> ()
372      | (s,p,env)::t -> defs := t; s.d <- Some (compile env p); flush_defs ()      | (s,p)::t -> defs := t; s.d <- Some (compile p); flush_defs ()
373    
374  let typ_nodes = SlotTable.create 67  let typ_nodes = SlotTable.create 67
375  let pat_nodes = SlotTable.create 67  let pat_nodes = SlotTable.create 67
# Line 408  Line 441 
441    
442    
443  let register_global_types b =  let register_global_types b =
444    List.iter (fun (v, { loc = loc }) ->    List.iter
445        (fun (v,p) ->
446                 if TypeEnv.mem v !glb                 if TypeEnv.mem v !glb
447                 then raise_loc_generic loc ("Multiple definition for type " ^ v)         then raise_loc_generic p.loc ("Multiple definition for type " ^ v)
448              ) b;              ) b;
449    glb := compile_many !glb b;    glb := derecurs_def !glb b;
450    let b = List.map (fun (v,p) -> (v,p,compile !glb p)) b in    let b = List.map (fun (v,p) -> (v,p,compile (derecurs !glb p))) b in
451    flush_defs ();    flush_defs ();
452    flush_fv ();    flush_fv ();
453    List.iter (fun (v,p,s) ->    List.iter (fun (v,p,s) ->
# Line 421  Line 455 
455                   raise_loc_generic p.loc "Capture variables are not allowed in types";                   raise_loc_generic p.loc "Capture variables are not allowed in types";
456                 Types.Print.register_global v (typ s)) b                 Types.Print.register_global v (typ s)) b
457    
458    let dump_global_types ppf =
459      TypeEnv.iter (fun v _ -> Format.fprintf ppf " %s" v) !glb
460    
461    
462  let typ p =  let typ p =
463    let s = compile_slot !glb p in    let s = compile_slot (derecurs !glb p) in
464    flush_defs ();    flush_defs ();
465    flush_fv ();    flush_fv ();
466    if IdSet.is_empty (fv_slot s) then typ_node s    if IdSet.is_empty (fv_slot s) then typ_node s
467    else raise_loc_generic p.loc "Capture variables are not allowed in types"    else raise_loc_generic p.loc "Capture variables are not allowed in types"
468    
469  let pat p =  let pat p =
470    let s = compile_slot !glb p in    let s = compile_slot (derecurs !glb p) in
471    flush_defs ();    flush_defs ();
472    flush_fv ();    flush_fv ();
473    try pat_node s    try pat_node s
# Line 438  Line 475 
475      | Location (loc,exn) when loc = noloc -> raise (Location (p.loc, exn))      | Location (loc,exn) when loc = noloc -> raise (Location (p.loc, exn))
476    
477    
 *)  
   
 (* Internal representation as a graph (desugar recursive types and regexp),  
    to compute freevars, etc... *)  
   
 type ti = {  
   id : int;  
   mutable seen : bool;  
   mutable loc' : loc;  
   mutable fv : fv option;  
   mutable descr': descr;  
   mutable type_node: Types.node option;  
   mutable pat_node: Patterns.node option  
 }  
 and descr =  
   | IAlias of string * ti  
   | IType of Types.descr  
   | IOr of ti * ti  
   | IAnd of ti * ti  
   | IDiff of ti * ti  
   | ITimes of ti * ti  
   | IXml of ti * ti  
   | IArrow of ti * ti  
   | IOptional of ti  
   | IRecord of bool * ti label_map  
   | ICapture of id  
   | IConstant of id * Types.const  
   
   
   
 type glb = ti TypeEnv.t  
   
 let mk' =  
   let counter = ref 0 in  
   fun loc ->  
     incr counter;  
     let rec x = {  
       id = !counter;  
       seen = false;  
       loc' = loc;  
       fv = None;  
       descr' = IAlias ("__dummy__", x);  
       type_node = None;  
       pat_node = None  
     } in  
     x  
   
 let cons loc d =  
   let x = mk' loc in  
   x.descr' <- d;  
   x  
   
   
   
 let rec compile env { loc = loc; descr = d } : ti =  
   match (d : Ast.ppat') with  
   | PatVar s ->  
       (try TypeEnv.find s env  
        with Not_found ->  
          raise_loc_generic loc ("Undefined type variable " ^ s)  
       )  
   | Recurs (t, b) -> compile (compile_many env b) t  
   | Regexp (r,q) -> compile env (Regexp.compile loc r q)  
   | Internal t -> cons loc (IType t)  
   | Or (t1,t2) -> cons loc (IOr (compile env t1, compile env t2))  
   | And (t1,t2) -> cons loc (IAnd (compile env t1, compile env t2))  
   | Diff (t1,t2) -> cons loc (IDiff (compile env t1, compile env t2))  
   | Prod (t1,t2) -> cons loc (ITimes (compile env t1, compile env t2))  
   | XmlT (t1,t2) -> cons loc (IXml (compile env t1, compile env t2))  
   | Arrow (t1,t2) -> cons loc (IArrow (compile env t1, compile env t2))  
   | Optional t -> cons loc (IOptional (compile env t))  
   | Record (o,r) ->  cons loc (IRecord (o, LabelMap.map (compile env) r))  
   | Constant (x,v) -> cons loc (IConstant (x,v))  
   | Capture x -> cons loc (ICapture x)  
   
 and compile_many env b =  
   let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in  
   let env =  
     List.fold_left (fun env (v,t,x) -> TypeEnv.add v x env) env b in  
   List.iter (fun (v,t,x) -> x.descr' <- IAlias (v, compile env t)) b;  
   env  
   
 module IntSet =  
   Set.Make(struct type t = int let compare (x:int) y = compare x y end)  
   
 let comp_fv_seen = ref []  
 let comp_fv_res = ref IdSet.empty  
 let rec comp_fv s =  
   match s.fv with  
     | Some fv -> comp_fv_res := IdSet.cup fv !comp_fv_res  
     | None ->  
         (match s.descr' with  
            | IAlias (_,x) ->  
                if x.seen then ()  
                else (  
                  x.seen <- true;  
                  comp_fv_seen := x :: !comp_fv_seen;  
                  comp_fv x  
                )  
            | IOr (s1,s2)  
            | IAnd (s1,s2)  
            | IDiff (s1,s2)  
            | ITimes (s1,s2) | IXml (s1,s2)  
            | IArrow (s1,s2) -> comp_fv s1; comp_fv s2  
            | IOptional r -> comp_fv r  
            | IRecord (_,r) -> LabelMap.iter comp_fv r  
            | IType _ -> ()  
            | ICapture x  
            | IConstant (x,_) -> comp_fv_res := IdSet.add x !comp_fv_res  
         )  
   
   
 let fv s =  
   match s.fv with  
     | Some l -> l  
     | None ->  
         comp_fv s;  
         let l = !comp_fv_res in  
         comp_fv_res := IdSet.empty;  
         List.iter (fun n -> n.seen <- false) !comp_fv_seen;  
         comp_fv_seen := [];  
         s.fv <- Some l;  
         l  
   
 let rec typ seen s : Types.descr =  
   match s.descr' with  
     | IAlias (v,x) ->  
         if IntSet.mem s.id seen then  
           raise_loc_generic s.loc'  
             ("Unguarded recursion on variable " ^ v ^ " in this type")  
         else typ (IntSet.add s.id seen) x  
     | IType t -> t  
     | IOr (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)  
     | IAnd (s1,s2) ->  Types.cap (typ seen s1) (typ seen s2)  
     | IDiff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)  
     | ITimes (s1,s2) -> Types.times (typ_node s1) (typ_node s2)  
     | IXml (s1,s2) ->   Types.xml (typ_node s1) (typ_node s2)  
     | IArrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)  
     | IOptional s -> Types.Record.or_absent (typ seen s)  
     | IRecord (o,r) ->  
         Types.record'  
           (o, LabelMap.map typ_node r)  
     | ICapture x | IConstant (x,_) -> assert false  
   
 and typ_node s : Types.node =  
   match s.type_node with  
     | Some x -> x  
     | None ->  
         let x = Types.make () in  
         s.type_node <- Some x;  
         let t = typ IntSet.empty s in  
         Types.define x t;  
         x  
   
 let type_node s =  
   let s = typ_node s in  
   let s = Types.internalize s in  
 (*  Types.define s (Types.normalize (Types.descr s)); *)  
   s  
   
 let rec pat seen s : Patterns.descr =  
   if IdSet.is_empty (fv s)  
   then Patterns.constr (Types.descr (type_node s))  
   else  
     try pat_aux seen s  
     with Patterns.Error e -> raise_loc_generic s.loc' e  
       | Location (loc,exn) when loc = noloc -> raise (Location (s.loc', exn))  
   
   
 and pat_aux seen s = match s.descr' with  
   | IAlias (v,x) ->  
       if IntSet.mem s.id seen  
       then raise  
         (Patterns.Error  
            ("Unguarded recursion on variable " ^ v ^ " in this pattern"));  
       pat (IntSet.add s.id seen) x  
   | IOr (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)  
   | IAnd (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)  
   | IDiff (s1,s2) when IdSet.is_empty (fv s2) ->  
       let s2 = Types.neg (Types.descr (type_node s2)) in  
       Patterns.cap (pat seen s1) (Patterns.constr s2)  
   | IDiff _ ->  
       raise (Patterns.Error "Difference not allowed in patterns")  
   | ITimes (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)  
   | IXml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)  
   | IOptional _ ->  
       raise  
       (Patterns.Error  
          "Optional field not allowed in record patterns")  
   | IRecord (o,r) ->  
       let pats = ref [] in  
       let aux l s =  
         if IdSet.is_empty (fv s) then type_node s  
         else  
           ( pats := Patterns.record l (pat_node s) :: !pats;  
             Types.any_node )  
       in  
       let constr = Types.record' (o,LabelMap.mapi aux r) in  
       List.fold_left Patterns.cap (Patterns.constr constr) !pats  
 (* TODO: can avoid constr when o=true, and all fields have fv *)  
   | ICapture x ->  Patterns.capture x  
   | IConstant (x,c) -> Patterns.constant x c  
   | IArrow _ ->  
       raise (Patterns.Error "Arrow not allowed in patterns")  
   | IType _ -> assert false  
   
 and pat_node s : Patterns.node =  
   match s.pat_node with  
     | Some x -> x  
     | None ->  
         let x = Patterns.make (fv s) in  
         s.pat_node <- Some x;  
         let t = pat IntSet.empty s in  
         Patterns.define x t;  
         x  
   
 let mk_typ e =  
   if IdSet.is_empty (fv e) then type_node e  
   else raise_loc_generic e.loc' "Capture variables are not allowed in types"  
   
   
 let glb = State.ref "Typer.glb_env" TypeEnv.empty  
   
 let typ e =  
   mk_typ (compile !glb e)  
   
 let pat e =  
   pat_node (compile !glb e)  
   
 let register_global_types b =  
   let env' = compile_many !glb b in  
   List.iter  
     (fun (v,{ loc = loc }) ->  
        let t = TypeEnv.find v env' in  
        let d = Types.descr (mk_typ t) in  
        (*              let d = Types.normalize d in*)  
        Types.Print.register_global v d;  
        if TypeEnv.mem v !glb  
        then raise_loc_generic loc ("Multiple definition for type " ^ v);  
        glb := TypeEnv.add v t !glb  
     ) b  
   
   
   
478  (* II. Build skeleton *)  (* II. Build skeleton *)
479    
480  module Fv = IdSet  module Fv = IdSet
Legend:
Removed from v.277  
changed lines
  Added in v.278
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5