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

Diff of /typing/typer.ml

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

revision 69 by abate, Tue Jul 10 17:03:11 2007 UTC revision 71 by abate, Tue Jul 10 17:03:32 2007 UTC
# Line 87  Line 87 
87      | Star r | WeakStar r -> seq_vars accu r      | Star r | WeakStar r -> seq_vars accu r
88      | SeqCapture (v,r) -> seq_vars (StringSet.add v accu) r      | SeqCapture (v,r) -> seq_vars (StringSet.add v accu) r
89    
90    let rec propagate vars = function    let uniq_id = let r = ref 0 in fun () -> incr r; !r
91    
92      type flat = [ `Epsilon
93                  | `Elem of int * Ast.ppat  (* the int arg is used to
94                                                to stop generic comparison *)
95                  | `Seq of flat * flat
96                  | `Alt of flat * flat
97                  | `Star of flat
98                  | `WeakStar of flat ]
99    
100      let rec propagate vars : regexp -> flat = function
101      | Epsilon -> `Epsilon      | Epsilon -> `Epsilon
102      | Elem x -> `Elem (vars,x)      | Elem x -> let p = vars x in `Elem (uniq_id (),p)
103      | Seq (r1,r2) -> `Seq (propagate vars r1,propagate vars r2)      | Seq (r1,r2) -> `Seq (propagate vars r1,propagate vars r2)
104      | Alt (r1,r2) -> `Alt (propagate vars r1, propagate vars r2)      | Alt (r1,r2) -> `Alt (propagate vars r1, propagate vars r2)
105      | Star r -> `Star (propagate vars r)      | Star r -> `Star (propagate vars r)
106      | WeakStar r -> `WeakStar (propagate vars r)      | WeakStar r -> `WeakStar (propagate vars r)
107      | SeqCapture (v,x) -> propagate (StringSet.add v vars) x      | SeqCapture (v,x) ->
108            let v= mk noloc (Capture v) in
109            propagate (fun p -> mk noloc (And (vars p,v,true))) x
110    
111    let cup r1 r2 =    let cup r1 r2 =
112      match (r1,r2) with      match (r1,r2) with
# Line 102  Line 114 
114        | (`Empty, _) -> r2        | (`Empty, _) -> r2
115        | (`Res t1, `Res t2) -> `Res (mk noloc (Or (t1,t2)))        | (`Res t1, `Res t2) -> `Res (mk noloc (Or (t1,t2)))
116    
117    (*TODO: review this compilation schema to avoid explosion when
118      coding (Optional x) by  (Or(Epsilon,x)); memoization ... *)
119    
120      module Memo = Map.Make(struct type t = flat list let compare = compare end)
121      module Coind = Set.Make(struct type t = flat list let compare = compare end)
122      let memo = ref Memo.empty
123    
124    let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =    let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =
125      if List.mem seq e then `Empty      if Coind.mem seq !e then `Empty
126      else      else (
127        let e = seq :: e in        e := Coind.add seq !e;
128        match seq with        match seq with
129          | [] ->          | [] ->
130              `Res fin              `Res fin
131          | `Epsilon :: rest ->          | `Epsilon :: rest ->
132              compile fin e rest              compile fin e rest
133          | `Elem (vars,x) :: rest ->          | `Elem (_,p) :: rest ->
134              let capt = StringSet.fold              `Res (mk noloc (Prod (p, guard_compile fin rest)))
                          (fun v t -> mk noloc (And (t, (mk noloc (Capture v)), true)))  
                          vars x in  
             `Res (mk noloc (Prod (capt, guard_compile fin rest)))  
135          | `Seq (r1,r2) :: rest ->          | `Seq (r1,r2) :: rest ->
136              compile fin e (r1 :: r2 :: rest)              compile fin e (r1 :: r2 :: rest)
137          | `Alt (r1,r2) :: rest ->          | `Alt (r1,r2) :: rest ->
138              cup (compile fin e (r1::rest)) (compile fin e (r2::rest))              cup (compile fin e (r1::rest)) (compile fin e (r2::rest))
139          | `Star r :: rest -> cup (compile fin e (r::seq)) (compile fin e rest)          | `Star r :: rest ->
140          | `WeakStar r :: rest -> cup (compile fin e rest) (compile fin e (r::seq))              cup (compile fin e (r::seq)) (compile fin e rest)
141            | `WeakStar r :: rest ->
142                cup (compile fin e rest) (compile fin e (r::seq))
143        )
144    and guard_compile fin seq =    and guard_compile fin seq =
145      try Hashtbl.find memo seq      try Memo.find seq !memo
146      with      with
147          Not_found ->          Not_found ->
148            let n = name () in            let n = name () in
149            let v = mk noloc (PatVar n) in            let v = mk noloc (PatVar n) in
150            Hashtbl.add memo seq v;            memo := Memo.add seq v !memo;
151            let d = compile fin [] seq in            let d = compile fin (ref Coind.empty) seq in
152            (match d with            (match d with
153               | `Empty -> assert false               | `Empty -> assert false
154               | `Res d -> defs := (n,d) :: !defs);               | `Res d -> defs := (n,d) :: !defs);
# Line 144  Line 162 
162    let compile regexp queue : ppat =    let compile regexp queue : ppat =
163      let vars = seq_vars StringSet.empty regexp in      let vars = seq_vars StringSet.empty regexp in
164      let fin = StringSet.fold constant_nil vars queue in      let fin = StringSet.fold constant_nil vars queue in
165      let n = guard_compile fin [propagate StringSet.empty regexp] in      let n = guard_compile fin [propagate (fun p -> p) regexp] in
166      Hashtbl.clear memo;      memo := Memo.empty;
167      let d = !defs in      let d = !defs in
168      defs := [];      defs := [];
169      mk noloc (Recurs (n,d))      mk noloc (Recurs (n,d))
# Line 181  Line 199 
199    env    env
200    
201    
202  let rec comp_fv seen s =  let comp_fv_seen = ref []
203    match s.fv with  let comp_fv_res = ref []
204      | Some l -> l  let rec comp_fv s =
205      | None ->    if List.memq s !comp_fv_seen then ()
206          let l =    else (
207            match s.descr' with      comp_fv_seen := s :: !comp_fv_seen;
208              | `Alias (_,x) -> if List.memq s seen then [] else comp_fv (s :: seen) x      (match s.descr' with
209          | `Alias (_,x) -> comp_fv x
210              | `Or (s1,s2)              | `Or (s1,s2)
211              | `And (s1,s2,_)              | `And (s1,s2,_)
212              | `Diff (s1,s2)              | `Diff (s1,s2)
213              | `Times (s1,s2)              | `Times (s1,s2)
214              | `Arrow (s1,s2) -> SortedList.cup (comp_fv seen s1) (comp_fv seen s2)        | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
215              | `Record (l,opt,s) -> comp_fv seen s        | `Record (l,opt,s) -> comp_fv s
216              | `Type _ -> []        | `Type _ -> ()
217              | `Capture x              | `Capture x
218              | `Constant (x,_) -> [x]        | `Constant (x,_) -> comp_fv_res := x :: !comp_fv_res);
219          in      if (!comp_fv_res = []) then s.fv <- Some [];
220          if seen = [] then s.fv <- Some l;      (* TODO: check that the above line is correct *)
221          l    )
222    
223    
224    
225  let fv = comp_fv []  let fv s =
226      match s.fv with
227        | Some l -> l
228        | None ->
229            comp_fv s;
230            let l = SortedList.from_list !comp_fv_res in
231            comp_fv_res := [];
232            comp_fv_seen := [];
233            s.fv <- Some l;
234            l
235    
236  let rec typ seen s : Types.descr =  let rec typ seen s : Types.descr =
237    match s.descr' with    match s.descr' with
# Line 231  Line 260 
260          Types.define x t;          Types.define x t;
261          x          x
262    
263  let type_node s = Types.internalize (typ_node s)  let type_node s =
264      let s = typ_node s in
265      let s = Types.internalize s in
266    (*  Types.define s (Types.normalize (Types.descr s)); *)
267      s
268    
269  let rec pat seen s : Patterns.descr =  let rec pat seen s : Patterns.descr =
270    if fv s = [] then Patterns.constr (type_node s) else    if fv s = [] then Patterns.constr (type_node s) else
# Line 288  Line 321 
321    let env = compile_many !global_types b in    let env = compile_many !global_types b in
322    List.iter (fun (v,_) ->    List.iter (fun (v,_) ->
323                 let d = Types.descr (mk_typ (StringMap.find v env)) in                 let d = Types.descr (mk_typ (StringMap.find v env)) in
324                 let d = Types.normalize d in  (*             let d = Types.normalize d in*)
325                 Types.Print.register_global v d                 Types.Print.register_global v d;
326                   ()
327              ) b;              ) b;
328    global_types := env    global_types := env
329    
Legend:
Removed from v.69  
changed lines
  Added in v.71
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5