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

Diff of /typing/typer.ml

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

revision 425 by abate, Tue Jul 10 17:33:25 2007 UTC revision 426 by abate, Tue Jul 10 17:33:48 2007 UTC
# Line 69  Line 69 
69    | PWeakStar of derecurs_regexp    | PWeakStar of derecurs_regexp
70    
71  let rec hash_derecurs = function  let rec hash_derecurs = function
72    | PAlias s -> s.pid    | PAlias s ->
73    | PType t -> 1 + 17 * (Types.hash_descr t)        s.pid
74    | POr (p1,p2) -> 2 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)    | PType t ->
75    | PAnd (p1,p2) -> 3 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)        1 + 17 * (Types.hash_descr t)
76    | PDiff (p1,p2) -> 4 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)    | POr (p1,p2) ->
77    | PTimes (p1,p2) -> 5 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)        2 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
78    | PXml (p1,p2) -> 6 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)    | PAnd (p1,p2) ->
79    | PArrow (p1,p2) -> 7 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)        3 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
80    | POptional p -> 8 + 17 * (hash_derecurs p)    | PDiff (p1,p2) ->
81    | PRecord (o,r) -> (if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs r)        4 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
82    | PCapture x -> 11 + 17 * (Id.hash x)    | PTimes (p1,p2) ->
83    | PConstant (x,c) -> 12 + 17 * (Id.hash x) + 257 * (Types.hash_const c)        5 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
84    | PRegexp (p,q) -> 13 + 17 * (hash_derecurs_regexp p) + 257 * (hash_derecurs q)    | PXml (p1,p2) ->
85          6 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
86      | PArrow (p1,p2) ->
87          7 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
88      | POptional p ->
89          8 + 17 * (hash_derecurs p)
90      | PRecord (o,r) ->
91          (if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs r)
92      | PCapture x ->
93          11 + 17 * (Id.hash x)
94      | PConstant (x,c) ->
95          12 + 17 * (Id.hash x) + 257 * (Types.hash_const c)
96      | PRegexp (p,q) ->
97          13 + 17 * (hash_derecurs_regexp p) + 257 * (hash_derecurs q)
98  and hash_derecurs_regexp = function  and hash_derecurs_regexp = function
99    | PEpsilon -> 1    | PEpsilon ->
100    | PElem p -> 2 + 17 * (hash_derecurs p)        1
101    | PSeq (p1,p2) -> 3 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)    | PElem p ->
102    | PAlt (p1,p2) -> 4 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)        2 + 17 * (hash_derecurs p)
103    | PStar p -> 5 + 17 * (hash_derecurs_regexp p)    | PSeq (p1,p2) ->
104    | PWeakStar p -> 6 + 17 * (hash_derecurs_regexp p)        3 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
105      | PAlt (p1,p2) ->
106          4 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
107      | PStar p ->
108          5 + 17 * (hash_derecurs_regexp p)
109      | PWeakStar p ->
110          6 + 17 * (hash_derecurs_regexp p)
111    
112  let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with  let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
113    | PAlias s1, PAlias s2 -> s1 == s2    | PAlias s1, PAlias s2 ->
114    | PType t1, PType t2 -> Types.equal_descr t1 t2        s1 == s2
115      | PType t1, PType t2 ->
116          Types.equal_descr t1 t2
117    | POr (p1,q1), POr (p2,q2)    | POr (p1,q1), POr (p2,q2)
118    | PAnd (p1,q1), PAnd (p2,q2)    | PAnd (p1,q1), PAnd (p2,q2)
119    | PDiff (p1,q1), PDiff (p2,q2)    | PDiff (p1,q1), PDiff (p2,q2)
120    | PTimes (p1,q1), PTimes (p2,q2)    | PTimes (p1,q1), PTimes (p2,q2)
121    | PXml (p1,q1), PXml (p2,q2)    | PXml (p1,q1), PXml (p2,q2)
122    | PArrow (p1,q1), PArrow (p2,q2) -> (equal_derecurs p1 p2) && (equal_derecurs q1 q2)    | PArrow (p1,q1), PArrow (p2,q2) ->
123    | POptional p1, POptional p2 -> equal_derecurs p1 p2        (equal_derecurs p1 p2) && (equal_derecurs q1 q2)
124    | PRecord (o1,r1), PRecord (o2,r2) -> (o1 == o2) && (LabelMap.equal equal_derecurs r1 r2)    | POptional p1, POptional p2 ->
125    | PCapture x1, PCapture x2 -> Id.equal x1 x2        equal_derecurs p1 p2
126    | PConstant (x1,c1), PConstant (x2,c2) -> (Id.equal x1 x2) && (Types.equal_const c1 c2)    | PRecord (o1,r1), PRecord (o2,r2) ->
127    | PRegexp (p1,q1), PRegexp (p2,q2) -> (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)        (o1 == o2) && (LabelMap.equal equal_derecurs r1 r2)
128      | PCapture x1, PCapture x2 ->
129          Id.equal x1 x2
130      | PConstant (x1,c1), PConstant (x2,c2) ->
131          (Id.equal x1 x2) && (Types.equal_const c1 c2)
132      | PRegexp (p1,q1), PRegexp (p2,q2) ->
133          (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
134    | _ -> false    | _ -> false
135  and equal_derecurs_regexp r1 r2 = match r1,r2 with  and equal_derecurs_regexp r1 r2 = match r1,r2 with
136    | PEpsilon, PEpsilon -> true    | PEpsilon, PEpsilon ->
137    | PElem p1, PElem p2 -> equal_derecurs p1 p2        true
138      | PElem p1, PElem p2 ->
139          equal_derecurs p1 p2
140    | PSeq (p1,q1), PSeq (p2,q2)    | PSeq (p1,q1), PSeq (p2,q2)
141    | PAlt (p1,q1), PAlt (p2,q2) -> (equal_derecurs_regexp p1 p2) && (equal_derecurs_regexp q1 q2)    | PAlt (p1,q1), PAlt (p2,q2) ->
142          (equal_derecurs_regexp p1 p2) && (equal_derecurs_regexp q1 q2)
143    | PStar p1, PStar p2    | PStar p1, PStar p2
144    | PWeakStar p1, PWeakStar p2 -> equal_derecurs_regexp p1 p2    | PWeakStar p1, PWeakStar p2 ->
145          equal_derecurs_regexp p1 p2
146    | _ -> false    | _ -> false
147    
148  module DerecursTable = Hashtbl.Make(  module DerecursTable = Hashtbl.Make(
# Line 125  Line 156 
156  module RE = Hashtbl.Make(  module RE = Hashtbl.Make(
157    struct    struct
158      type t = derecurs_regexp * derecurs      type t = derecurs_regexp * derecurs
159      let hash (p,q) = (hash_derecurs_regexp p) + 17 * (hash_derecurs q)      let hash (p,q) =
160      let equal (p1,q1) (p2,q2) = (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)        (hash_derecurs_regexp p) + 17 * (hash_derecurs q)
161        let equal (p1,q1) (p2,q2) =
162          (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
163    end    end
164  )  )
165    
# Line 139  Line 172 
172  let rec derecurs env p = match p.descr with  let rec derecurs env p = match p.descr with
173    | PatVar v ->    | PatVar v ->
174        (try PAlias (TypeEnv.find v env)        (try PAlias (TypeEnv.find v env)
175         with Not_found -> raise_loc_generic p.loc ("Undefined type/pattern " ^ v))         with Not_found ->
176             raise_loc_generic p.loc ("Undefined type/pattern " ^ v))
177    | Recurs (p,b) -> derecurs (derecurs_def env b) p    | Recurs (p,b) -> derecurs (derecurs_def env b) p
178    | Internal t -> PType t    | Internal t -> PType t
179    | Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)    | Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)
# Line 153  Line 187 
187    | Capture x -> PCapture x    | Capture x -> PCapture x
188    | Constant (x,c) -> PConstant (x,c)    | Constant (x,c) -> PConstant (x,c)
189    | Regexp (r,q) ->    | Regexp (r,q) ->
190        let constant_nil t v = PAnd (t, PConstant (v, Types.Atom Sequence.nil_atom)) in        let constant_nil t v =
191            PAnd (t, PConstant (v, Types.Atom Sequence.nil_atom)) in
192        let vars = seq_vars IdSet.empty r in        let vars = seq_vars IdSet.empty r in
193        let q = IdSet.fold constant_nil (derecurs env q) vars in        let q = IdSet.fold constant_nil (derecurs env q) vars in
194        let r = derecurs_regexp (fun p -> p) env r in        let r = derecurs_regexp (fun p -> p) env r in
195        PRegexp (r, q)        PRegexp (r, q)
196  and derecurs_regexp vars env = function  and derecurs_regexp vars env = function
197    | Epsilon -> PEpsilon    | Epsilon ->
198    | Elem p -> PElem (vars (derecurs env p))        PEpsilon
199    | Seq (p1,p2) -> PSeq (derecurs_regexp vars env p1, derecurs_regexp vars env p2)    | Elem p ->
200    | Alt (p1,p2) -> PAlt (derecurs_regexp vars env p1, derecurs_regexp vars env p2)        PElem (vars (derecurs env p))
201    | Star p -> PStar (derecurs_regexp vars env p)    | Seq (p1,p2) ->
202    | WeakStar p -> PWeakStar (derecurs_regexp vars env p)        PSeq (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
203    | SeqCapture (x,p) -> derecurs_regexp (fun p -> PAnd (vars p, PCapture x)) env p    | Alt (p1,p2) ->
204          PAlt (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
205      | Star p ->
206          PStar (derecurs_regexp vars env p)
207      | WeakStar p ->
208          PWeakStar (derecurs_regexp vars env p)
209      | SeqCapture (x,p) ->
210          derecurs_regexp (fun p -> PAnd (vars p, PCapture x)) env p
211    
212    
213  and derecurs_def env b =  and derecurs_def env b =
# Line 234  Line 276 
276    | ITimes (x1,y1), ITimes (x2,y2)    | ITimes (x1,y1), ITimes (x2,y2)
277    | IXml (x1,y1), IXml (x2,y2)    | IXml (x1,y1), IXml (x2,y2)
278    | IArrow (x1,y1), IArrow (x2,y2) -> (equal_slot x1 x2) && (equal_slot y1 y2)    | IArrow (x1,y1), IArrow (x2,y2) -> (equal_slot x1 x2) && (equal_slot y1 y2)
279    | IRecord (o1,r1), IRecord (o2,r2) -> (o1 = o2) && (LabelMap.equal equal_slot r1 r2)    | IRecord (o1,r1), IRecord (o2,r2) ->
280          (o1 = o2) && (LabelMap.equal equal_slot r1 r2)
281    | ICapture x1, ICapture x2 -> Id.equal x1 x2    | ICapture x1, ICapture x2 -> Id.equal x1 x2
282    | IConstant (x1,y1), IConstant (x2,y2) -> (Id.equal x1 x2) && (Types.equal_const y1 y2)    | IConstant (x1,y1), IConstant (x2,y2) ->
283          (Id.equal x1 x2) && (Types.equal_const y1 y2)
284    | _ -> false    | _ -> false
285  and equal_slot s1 s2 =  and equal_slot s1 s2 =
286    ((s1.gen1 = !gen) && (s2.gen2 = !gen) && (s1.rank1 = s2.rank2))    ((s1.gen1 = !gen) && (s2.gen2 = !gen) && (s1.rank1 = s2.rank2))
# Line 284  Line 328 
328    | ITimes (s1,s2)    | ITimes (s1,s2)
329    | IXml (s1,s2)    | IXml (s1,s2)
330    | IArrow (s1,s2) -> IdSet.cup (fv_slot s1) (fv_slot s2)    | IArrow (s1,s2) -> IdSet.cup (fv_slot s1) (fv_slot s2)
331    | IRecord (o,r) -> List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_slot r)    | IRecord (o,r) ->
332          List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_slot r)
333    | ICapture x | IConstant (x,_) -> IdSet.singleton x    | ICapture x | IConstant (x,_) -> IdSet.singleton x
334    
335    
# Line 351  Line 396 
396      else (      else (
397        RE.add memo (r,q) ();        RE.add memo (r,q) ();
398        match r with        match r with
399          | PEpsilon -> (match q with PRegexp (r,q) -> aux accu r q | _ -> (compile q) :: accu)          | PEpsilon ->
400                (match q with
401                   | PRegexp (r,q) -> aux accu r q
402                   | _ -> (compile q) :: accu)
403          | PElem p -> ITimes (compile_slot p, compile_slot q) :: accu          | PElem p -> ITimes (compile_slot p, compile_slot q) :: accu
404          | PSeq (r1,r2) -> aux accu r1 (PRegexp (r2,q))          | PSeq (r1,r2) -> aux accu r1 (PRegexp (r2,q))
405          | PAlt (r1,r2) -> aux (aux accu r1 q) r2 q          | PAlt (r1,r2) -> aux (aux accu r1 q) r2 q
# Line 716  Line 764 
764        check loc res constr        check loc res constr
765    
766    | UnaryOp (o,e) ->    | UnaryOp (o,e) ->
767        let t = o.un_op_typer loc (type_check env e) constr precise in        let t = o.un_op_typer loc
768                    (type_check env e) constr precise in
769        check loc t constr        check loc t constr
770    
771    | BinaryOp (o,e1,e2) ->    | BinaryOp (o,e1,e2) ->
772        let t = o.bin_op_typer loc (type_check env e1) (type_check env e2) constr precise in        let t = o.bin_op_typer loc
773                    (type_check env e1)
774                    (type_check env e2) constr precise in
775        check loc t constr        check loc t constr
776    
777    | Var s ->    | Var s ->
Legend:
Removed from v.425  
changed lines
  Added in v.426
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5