Commit 9bd487ed authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-05-25 12:04:58 by cvscast] Menage

Original author: cvscast
Date: 2003-05-25 12:04:58+00:00
parent ad651c2e
......@@ -69,49 +69,80 @@ and derecurs_regexp =
| PWeakStar of derecurs_regexp
let rec hash_derecurs = function
| PAlias s -> s.pid
| PType t -> 1 + 17 * (Types.hash_descr t)
| POr (p1,p2) -> 2 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PAnd (p1,p2) -> 3 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PDiff (p1,p2) -> 4 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PTimes (p1,p2) -> 5 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PXml (p1,p2) -> 6 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PArrow (p1,p2) -> 7 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| POptional p -> 8 + 17 * (hash_derecurs p)
| PRecord (o,r) -> (if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs r)
| PCapture x -> 11 + 17 * (Id.hash x)
| PConstant (x,c) -> 12 + 17 * (Id.hash x) + 257 * (Types.hash_const c)
| PRegexp (p,q) -> 13 + 17 * (hash_derecurs_regexp p) + 257 * (hash_derecurs q)
| PAlias s ->
s.pid
| PType t ->
1 + 17 * (Types.hash_descr t)
| POr (p1,p2) ->
2 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PAnd (p1,p2) ->
3 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PDiff (p1,p2) ->
4 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PTimes (p1,p2) ->
5 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PXml (p1,p2) ->
6 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| PArrow (p1,p2) ->
7 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
| POptional p ->
8 + 17 * (hash_derecurs p)
| PRecord (o,r) ->
(if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs r)
| PCapture x ->
11 + 17 * (Id.hash x)
| PConstant (x,c) ->
12 + 17 * (Id.hash x) + 257 * (Types.hash_const c)
| PRegexp (p,q) ->
13 + 17 * (hash_derecurs_regexp p) + 257 * (hash_derecurs q)
and hash_derecurs_regexp = function
| PEpsilon -> 1
| PElem p -> 2 + 17 * (hash_derecurs p)
| PSeq (p1,p2) -> 3 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
| PAlt (p1,p2) -> 4 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
| PStar p -> 5 + 17 * (hash_derecurs_regexp p)
| PWeakStar p -> 6 + 17 * (hash_derecurs_regexp p)
| PEpsilon ->
1
| PElem p ->
2 + 17 * (hash_derecurs p)
| PSeq (p1,p2) ->
3 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
| PAlt (p1,p2) ->
4 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
| PStar p ->
5 + 17 * (hash_derecurs_regexp p)
| PWeakStar p ->
6 + 17 * (hash_derecurs_regexp p)
let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
| PAlias s1, PAlias s2 -> s1 == s2
| PType t1, PType t2 -> Types.equal_descr t1 t2
| PAlias s1, PAlias s2 ->
s1 == s2
| PType t1, PType t2 ->
Types.equal_descr t1 t2
| POr (p1,q1), POr (p2,q2)
| PAnd (p1,q1), PAnd (p2,q2)
| PDiff (p1,q1), PDiff (p2,q2)
| PTimes (p1,q1), PTimes (p2,q2)
| PXml (p1,q1), PXml (p2,q2)
| PArrow (p1,q1), PArrow (p2,q2) -> (equal_derecurs p1 p2) && (equal_derecurs q1 q2)
| POptional p1, POptional p2 -> equal_derecurs p1 p2
| PRecord (o1,r1), PRecord (o2,r2) -> (o1 == o2) && (LabelMap.equal equal_derecurs r1 r2)
| PCapture x1, PCapture x2 -> Id.equal x1 x2
| PConstant (x1,c1), PConstant (x2,c2) -> (Id.equal x1 x2) && (Types.equal_const c1 c2)
| PRegexp (p1,q1), PRegexp (p2,q2) -> (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
| PArrow (p1,q1), PArrow (p2,q2) ->
(equal_derecurs p1 p2) && (equal_derecurs q1 q2)
| POptional p1, POptional p2 ->
equal_derecurs p1 p2
| PRecord (o1,r1), PRecord (o2,r2) ->
(o1 == o2) && (LabelMap.equal equal_derecurs r1 r2)
| PCapture x1, PCapture x2 ->
Id.equal x1 x2
| PConstant (x1,c1), PConstant (x2,c2) ->
(Id.equal x1 x2) && (Types.equal_const c1 c2)
| PRegexp (p1,q1), PRegexp (p2,q2) ->
(equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
| _ -> false
and equal_derecurs_regexp r1 r2 = match r1,r2 with
| PEpsilon, PEpsilon -> true
| PElem p1, PElem p2 -> equal_derecurs p1 p2
| PEpsilon, PEpsilon ->
true
| PElem p1, PElem p2 ->
equal_derecurs p1 p2
| PSeq (p1,q1), PSeq (p2,q2)
| PAlt (p1,q1), PAlt (p2,q2) -> (equal_derecurs_regexp p1 p2) && (equal_derecurs_regexp q1 q2)
| PAlt (p1,q1), PAlt (p2,q2) ->
(equal_derecurs_regexp p1 p2) && (equal_derecurs_regexp q1 q2)
| PStar p1, PStar p2
| PWeakStar p1, PWeakStar p2 -> equal_derecurs_regexp p1 p2
| PWeakStar p1, PWeakStar p2 ->
equal_derecurs_regexp p1 p2
| _ -> false
module DerecursTable = Hashtbl.Make(
......@@ -125,8 +156,10 @@ module DerecursTable = Hashtbl.Make(
module RE = Hashtbl.Make(
struct
type t = derecurs_regexp * derecurs
let hash (p,q) = (hash_derecurs_regexp p) + 17 * (hash_derecurs q)
let equal (p1,q1) (p2,q2) = (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
let hash (p,q) =
(hash_derecurs_regexp p) + 17 * (hash_derecurs q)
let equal (p1,q1) (p2,q2) =
(equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
end
)
......@@ -139,7 +172,8 @@ let mk_slot loc =
let rec derecurs env p = match p.descr with
| PatVar v ->
(try PAlias (TypeEnv.find v env)
with Not_found -> raise_loc_generic p.loc ("Undefined type/pattern " ^ v))
with Not_found ->
raise_loc_generic p.loc ("Undefined type/pattern " ^ v))
| Recurs (p,b) -> derecurs (derecurs_def env b) p
| Internal t -> PType t
| Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)
......@@ -153,19 +187,27 @@ let rec derecurs env p = match p.descr with
| Capture x -> PCapture x
| Constant (x,c) -> PConstant (x,c)
| Regexp (r,q) ->
let constant_nil t v = PAnd (t, PConstant (v, Types.Atom Sequence.nil_atom)) in
let constant_nil t v =
PAnd (t, PConstant (v, Types.Atom Sequence.nil_atom)) in
let vars = seq_vars IdSet.empty r in
let q = IdSet.fold constant_nil (derecurs env q) vars in
let r = derecurs_regexp (fun p -> p) env r in
PRegexp (r, q)
and derecurs_regexp vars env = function
| Epsilon -> PEpsilon
| Elem p -> PElem (vars (derecurs env p))
| Seq (p1,p2) -> PSeq (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
| Alt (p1,p2) -> PAlt (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
| Star p -> PStar (derecurs_regexp vars env p)
| WeakStar p -> PWeakStar (derecurs_regexp vars env p)
| SeqCapture (x,p) -> derecurs_regexp (fun p -> PAnd (vars p, PCapture x)) env p
| Epsilon ->
PEpsilon
| Elem p ->
PElem (vars (derecurs env p))
| Seq (p1,p2) ->
PSeq (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
| Alt (p1,p2) ->
PAlt (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
| Star p ->
PStar (derecurs_regexp vars env p)
| WeakStar p ->
PWeakStar (derecurs_regexp vars env p)
| SeqCapture (x,p) ->
derecurs_regexp (fun p -> PAnd (vars p, PCapture x)) env p
and derecurs_def env b =
......@@ -234,9 +276,11 @@ let rec equal_descr d1 d2 =
| ITimes (x1,y1), ITimes (x2,y2)
| IXml (x1,y1), IXml (x2,y2)
| IArrow (x1,y1), IArrow (x2,y2) -> (equal_slot x1 x2) && (equal_slot y1 y2)
| IRecord (o1,r1), IRecord (o2,r2) -> (o1 = o2) && (LabelMap.equal equal_slot r1 r2)
| IRecord (o1,r1), IRecord (o2,r2) ->
(o1 = o2) && (LabelMap.equal equal_slot r1 r2)
| ICapture x1, ICapture x2 -> Id.equal x1 x2
| IConstant (x1,y1), IConstant (x2,y2) -> (Id.equal x1 x2) && (Types.equal_const y1 y2)
| IConstant (x1,y1), IConstant (x2,y2) ->
(Id.equal x1 x2) && (Types.equal_const y1 y2)
| _ -> false
and equal_slot s1 s2 =
((s1.gen1 = !gen) && (s2.gen2 = !gen) && (s1.rank1 = s2.rank2))
......@@ -284,7 +328,8 @@ and fv_descr = function
| ITimes (s1,s2)
| IXml (s1,s2)
| IArrow (s1,s2) -> IdSet.cup (fv_slot s1) (fv_slot s2)
| 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)
| ICapture x | IConstant (x,_) -> IdSet.singleton x
......@@ -351,7 +396,10 @@ and compile_regexp r q =
else (
RE.add memo (r,q) ();
match r with
| PEpsilon -> (match q with PRegexp (r,q) -> aux accu r q | _ -> (compile q) :: accu)
| PEpsilon ->
(match q with
| PRegexp (r,q) -> aux accu r q
| _ -> (compile q) :: accu)
| PElem p -> ITimes (compile_slot p, compile_slot q) :: accu
| PSeq (r1,r2) -> aux accu r1 (PRegexp (r2,q))
| PAlt (r1,r2) -> aux (aux accu r1 q) r2 q
......@@ -716,11 +764,14 @@ and type_check' loc env e constr precise = match e with
check loc res constr
| UnaryOp (o,e) ->
let t = o.un_op_typer loc (type_check env e) constr precise in
let t = o.un_op_typer loc
(type_check env e) constr precise in
check loc t constr
| BinaryOp (o,e1,e2) ->
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
(type_check env e1)
(type_check env e2) constr precise in
check loc t constr
| Var s ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment