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

Diff of /typing/typer.ml

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

revision 139 by abate, Tue Jul 10 17:09:49 2007 UTC revision 140 by abate, Tue Jul 10 17:09:53 2007 UTC
# Line 4  Line 4 
4  open Location  open Location
5  open Ast  open Ast
6    
7    module S = struct type t = string let compare = compare end
8    module StringMap = Map.Make(S)
9    module StringSet = Set.Make(S)
10    
11  exception NonExhaustive of Types.descr  exception NonExhaustive of Types.descr
12  exception MultipleLabel of Types.label  exception MultipleLabel of Types.label
13  exception Constraint of Types.descr * Types.descr * string  exception Constraint of Types.descr * Types.descr * string
# Line 19  Line 23 
23  type ti = {  type ti = {
24    id : int;    id : int;
25    mutable loc' : loc;    mutable loc' : loc;
26    mutable fv : string SortedList.t option;    mutable fv : StringSet.t option;
27    mutable descr': descr;    mutable descr': descr;
28    mutable type_node: Types.node option;    mutable type_node: Types.node option;
29    mutable pat_node: Patterns.node option    mutable pat_node: Patterns.node option
# Line 39  Line 43 
43     ]     ]
44    
45    
   
 module S = struct type t = string let compare = compare end  
 module StringMap = Map.Make(S)  
 module StringSet = Set.Make(S)  
   
46  type glb = ti StringMap.t  type glb = ti StringMap.t
47    
48  let mk' =  let mk' =
# Line 91  Line 90 
90    let uniq_id = let r = ref 0 in fun () -> incr r; !r    let uniq_id = let r = ref 0 in fun () -> incr r; !r
91    
92    type flat = [ `Epsilon    type flat = [ `Epsilon
93                | `Elem of int * Ast.ppat  (* the int arg is used to                | `Elem of int * Ast.ppat  (* the int arg is used
94                                              to stop generic comparison *)                                              to stop generic comparison *)
95                | `Seq of flat * flat                | `Seq of flat * flat
96                | `Alt of flat * flat                | `Alt of flat * flat
# Line 124  Line 123 
123    module Coind = Set.Make(struct type t = flat list let compare = compare end)    module Coind = Set.Make(struct type t = flat list let compare = compare end)
124    let memo = ref Memo.empty    let memo = ref Memo.empty
125    
126    
127    let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =    let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =
128      if Coind.mem seq !e then `Empty      if Coind.mem seq !e then `Empty
129      else (      else (
# Line 157  Line 157 
157               | `Res d -> defs := (n,d) :: !defs);               | `Res d -> defs := (n,d) :: !defs);
158            v            v
159    
160    (*
161      type trans = [ `Alt of gnode * gnode | `Elem of Ast.ppat * gnode | `Final ]
162      and gnode =
163          {
164            mutable seen  : bool;
165            mutable compile : bool;
166            name  : string;
167            mutable trans : trans;
168          }
169    
170      let new_node() = { seen = false; compile = false;
171                         name = name(); trans = `Final }
172      let to_compile = ref []
173    
174      let rec compile after = function
175        | `Epsilon -> after
176        | `Elem (_,p) ->
177            if not after.compile then (after.compile <- true;
178                                       to_compile := after :: !to_compile);
179            { new_node () with trans = `Elem (p, after)  }
180        | `Seq(r1,r2) -> compile (compile after r2) r1
181        | `Alt(r1,r2) ->
182            let r1 = compile after r1 and r2 = compile after r2 in
183            { new_node () with trans = `Alt (r1,r2) }
184        | `Star r ->
185            let n  = new_node() in
186            n.trans <- `Alt (compile n r, after);
187            n
188        | `WeakStar r ->
189            let n  = new_node() in
190            n.trans <- `Alt (after, compile n r);
191            n
192    
193      let seens = ref []
194      let rec collect_aux accu n =
195        if n.seen then accu
196        else ( seens := n :: !seens;
197               match n.trans with
198                 | `Alt (n1,n2) -> collect_aux (collect_aux accu n2) n1
199                 | _ -> n :: accu
200             )
201    
202      let collect fin n =
203        let l = collect_aux [] n in
204        List.iter (fun n -> n.seen <- false) !seens;
205        let l = List.map (fun n ->
206                            match n.trans with
207                              | `Final -> fin
208                              | `Elem (p,a) ->
209                                  mk !re_loc (Prod(p, mk !re_loc (PatVar a.name)))
210                              | _ -> assert false
211                         ) l in
212        match l with
213          | h::t ->
214              List.fold_left (fun accu p -> mk !re_loc (Or (accu,p))) h t
215          | _ -> assert false
216    *)
217    
218    
219    let constant_nil v t =    let constant_nil v t =
220      mk !re_loc      mk !re_loc
# Line 166  Line 224 
224      re_loc := loc;      re_loc := loc;
225      let vars = seq_vars StringSet.empty regexp in      let vars = seq_vars StringSet.empty regexp in
226      let fin = StringSet.fold constant_nil vars queue in      let fin = StringSet.fold constant_nil vars queue in
227      let n = guard_compile fin [propagate (fun p -> p) regexp] in      let re = propagate (fun p -> p) regexp in
228        let n = guard_compile fin [re] in
229      memo := Memo.empty;      memo := Memo.empty;
230      let d = !defs in      let d = !defs in
231      defs := [];      defs := [];
232    
233    (*
234        let after = new_node() in
235        let n = collect queue (compile after re) in
236        let d = List.map (fun n -> (n.name, collect queue n)) !to_compile in
237        to_compile := [];
238    *)
239    
240      mk !re_loc (Recurs (n,d))      mk !re_loc (Recurs (n,d))
241  end  end
242    
# Line 203  Line 270 
270    List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;    List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
271    env    env
272    
273  let comp_fv_seen = ref []  module IntSet =
274  let comp_fv_res = ref []    Set.Make(struct type t = int let compare (x:int) y = compare x y end)
275    
276    let comp_fv_seen = ref IntSet.empty
277    let comp_fv_res = ref StringSet.empty
278  let rec comp_fv s =  let rec comp_fv s =
   if List.memq s !comp_fv_seen then ()  
   else (  
     comp_fv_seen := s :: !comp_fv_seen;  
279      match s.fv with      match s.fv with
280        | Some fv -> comp_fv_res := List.rev_append fv !comp_fv_res      | Some fv -> comp_fv_res := StringSet.union fv !comp_fv_res
281        | None ->        | None ->
282            (match s.descr' with            (match s.descr' with
283               | `Alias (_,x) -> comp_fv x             | `Alias (_,x) ->
284                   if IntSet.mem x.id !comp_fv_seen then ()
285                   else (
286                     comp_fv_seen := IntSet.add x.id !comp_fv_seen;
287                     comp_fv x
288                   )
289               | `Or (s1,s2)               | `Or (s1,s2)
290               | `And (s1,s2)               | `And (s1,s2)
291               | `Diff (s1,s2)               | `Diff (s1,s2)
# Line 222  Line 294 
294               | `Record (l,opt,s) -> comp_fv s               | `Record (l,opt,s) -> comp_fv s
295               | `Type _ -> ()               | `Type _ -> ()
296               | `Capture x               | `Capture x
297               | `Constant (x,_) -> comp_fv_res := x :: !comp_fv_res               | `Constant (x,_) -> comp_fv_res := StringSet.add x !comp_fv_res
           )  
298    )    )
299    
300    
   
301  let fv s =  let fv s =
302    match s.fv with    match s.fv with
303      | Some l -> l      | Some l -> l
304      | None ->      | None ->
305          comp_fv s;          comp_fv s;
306          let l = SortedList.from_list !comp_fv_res in          let l = !comp_fv_res in
307          comp_fv_res := [];          comp_fv_res := StringSet.empty;
308          comp_fv_seen := [];          comp_fv_seen := IntSet.empty;
309          s.fv <- Some l;          s.fv <- Some l;
310          l          l
311    
312  let rec typ seen s : Types.descr =  let rec typ seen s : Types.descr =
313    match s.descr' with    match s.descr' with
314      | `Alias (v,x) ->      | `Alias (v,x) ->
315          if List.memq s seen then          if IntSet.mem s.id seen then
316            raise_loc_generic s.loc'            raise_loc_generic s.loc'
317              ("Unguarded recursion on variable " ^ v ^ " in this type")              ("Unguarded recursion on variable " ^ v ^ " in this type")
318          else typ (s :: seen) x          else typ (IntSet.add s.id seen) x
319      | `Type t -> t      | `Type t -> t
320      | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)      | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
321      | `And (s1,s2) ->  Types.cap (typ seen s1) (typ seen s2)      | `And (s1,s2) ->  Types.cap (typ seen s1) (typ seen s2)
# Line 262  Line 332 
332      | None ->      | None ->
333          let x = Types.make () in          let x = Types.make () in
334          s.type_node <- Some x;          s.type_node <- Some x;
335          let t = typ [] s in          let t = typ IntSet.empty s in
336          Types.define x t;          Types.define x t;
337          x          x
338    
# Line 273  Line 343 
343    s    s
344    
345  let rec pat seen s : Patterns.descr =  let rec pat seen s : Patterns.descr =
346    if fv s = [] then Patterns.constr (Types.descr (type_node s)) else    if StringSet.is_empty (fv s)
347      then Patterns.constr (Types.descr (type_node s))
348      else
349      try pat_aux seen s      try pat_aux seen s
350      with Patterns.Error e -> raise_loc_generic s.loc' e      with Patterns.Error e -> raise_loc_generic s.loc' e
351        | Location (loc,exn) when loc = noloc -> raise (Location (s.loc', exn))        | Location (loc,exn) when loc = noloc -> raise (Location (s.loc', exn))
# Line 281  Line 353 
353    
354  and pat_aux seen s = match s.descr' with  and pat_aux seen s = match s.descr' with
355    | `Alias (v,x) ->    | `Alias (v,x) ->
356        if List.memq s seen        if IntSet.mem s.id seen
357        then raise        then raise
358          (Patterns.Error          (Patterns.Error
359             ("Unguarded recursion on variable " ^ v ^ " in this pattern"));             ("Unguarded recursion on variable " ^ v ^ " in this pattern"));
360        pat (s :: seen) x        pat (IntSet.add s.id seen) x
361    | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)    | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
362    | `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)    | `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
363    | `Diff (s1,s2) when fv s2 = [] ->    | `Diff (s1,s2) when StringSet.is_empty (fv s2) ->
364        let s2 = Types.neg (Types.descr (type_node s2)) in        let s2 = Types.neg (Types.descr (type_node s2)) in
365        Patterns.cap (pat seen s1) (Patterns.constr s2)        Patterns.cap (pat seen s1) (Patterns.constr s2)
366    | `Diff _ ->    | `Diff _ ->
# Line 308  Line 380 
380    match s.pat_node with    match s.pat_node with
381      | Some x -> x      | Some x -> x
382      | None ->      | None ->
383          let x = Patterns.make (fv s) in          let fv = SortedList.from_list (StringSet.elements (fv s)) in
384            let x = Patterns.make fv in
385          s.pat_node <- Some x;          s.pat_node <- Some x;
386          let t = pat [] s in          let t = pat IntSet.empty s in
387          Patterns.define x t;          Patterns.define x t;
388          x          x
389    
390  let mk_typ e =  let mk_typ e =
391    if fv e = [] then type_node e    if StringSet.is_empty (fv e) then type_node e
392    else raise_loc_generic e.loc' "Capture variables are not allowed in types"    else raise_loc_generic e.loc' "Capture variables are not allowed in types"
393    
394    
Legend:
Removed from v.139  
changed lines
  Added in v.140
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5