Commit c3f63583 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-11-03 22:50:16 by afrisch] Guarded pattern + back to old semantics for default patterns in

regexps

Original author: afrisch
Date: 2004-11-03 22:50:16+00:00
parent 85584cf2
......@@ -112,6 +112,7 @@ and ppat' =
and regexp =
| Epsilon
| Elem of ppat
| Guard of ppat
| Seq of regexp * regexp
| Alt of regexp * regexp
| Star of regexp
......
......@@ -457,6 +457,7 @@ EXTEND
Elem (multi_prod loc x))
| "("; a = IDENT; ":="; c = expr; ")" ->
Elem (mk loc (Constant ((ident a,c))))
| "/"; p = pat LEVEL "simple" -> Guard p
| IDENT "PCDATA" -> string_regexp
| i = STRING1; "--"; j = STRING1 ->
let i = Chars.V.mk_int (parse_char loc i)
......
......@@ -48,7 +48,8 @@ let rec ast_of_bool(c,loc)=
let rec string_of_ppat p =
let rec string_of_regexp rg =
match rg with
Elem(e) -> string_of_ppat e
|Elem(e) -> string_of_ppat e
|Guard(e) -> "/" ^ (string_of_ppat e)
|SeqCapture(id,rg) -> U.get_str (Id.value id) ^"::"^ string_of_regexp rg
|Seq(r1,r2) -> string_of_regexp r1 ^ " "^string_of_regexp r2
|Alt(r1,r2) -> " ("^string_of_regexp r1 ^"|"^ string_of_regexp r2^")"
......@@ -89,7 +90,8 @@ mais pas prioritaire [] -> ""
let rec var_of_ppat x =
let rec var_of_rg rg =
match rg with
Elem(e) -> []
|Elem(e) -> []
|Guard(e) -> []
|SeqCapture(id,rg) -> [id] @ var_of_rg rg
|Seq(r1,r2) -> var_of_rg r1 @ var_of_rg r2
|Alt(r1,r2) -> var_of_rg r1 @ var_of_rg r2
......
......@@ -250,7 +250,7 @@ let find_schema_descr env kind schema name =
(* Eliminate Recursion, propagate Sequence Capture Variables *)
let rec seq_vars accu = function
| Epsilon | Elem _ -> accu
| Epsilon | Elem _ | Guard _ -> accu
| Seq (r1,r2) | Alt (r1,r2) -> seq_vars (seq_vars accu r1) r2
| Star r | WeakStar r -> seq_vars accu r
| SeqCapture (v,r) -> seq_vars (IdSet.add v accu) r
......@@ -292,11 +292,14 @@ type derecurs_slot = {
and derecurs_regexp =
| PEpsilon
| PElem of derecurs
| PGuard of derecurs
| PSeq of derecurs_regexp * derecurs_regexp
| PAlt of derecurs_regexp * derecurs_regexp
| PStar of derecurs_regexp
| PWeakStar of derecurs_regexp
let pregexp r q = PRegexp (r,q)
type descr =
| IDummy
......@@ -378,6 +381,8 @@ and hash_derecurs_regexp = function
5 + 17 * (hash_derecurs_regexp p)
| PWeakStar p ->
6 + 17 * (hash_derecurs_regexp p)
| PGuard p ->
7 + 17 * (hash_derecurs p)
let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
| PAlias s1, PAlias s2 ->
......@@ -407,6 +412,8 @@ and equal_derecurs_regexp r1 r2 = match r1,r2 with
true
| PElem p1, PElem p2 ->
equal_derecurs p1 p2
| PGuard p1, PGuard 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)
......@@ -505,6 +512,64 @@ module SlotTable = Hashtbl.Make(
end)
let pempty = PType Types.empty
let por p1 p2 =
if p1 == pempty then p2 else
if p2 == pempty then p1 else
POr (p1,p2)
let pand p1 p2 =
if (p1 == pempty) || (p2 == pempty) then pempty else PAnd (p1,p2)
let rec remove_regexp r q = match r with
| PEpsilon ->
q
| PElem p ->
PTimes (p, q)
| PGuard p ->
pand p q
| PSeq (r1,r2) ->
remove_regexp r1 (remove_regexp r2 q)
| PAlt (r1,r2) ->
por (remove_regexp r1 q) (remove_regexp r2 q)
| PStar r ->
let x = mk_derecurs_slot noloc in
let res = POr (PAlias x, q) in
x.pdescr <- remove_regexp2 r res pempty;
res
| PWeakStar r ->
let x = mk_derecurs_slot noloc in
let res = POr (q, PAlias x) in
x.pdescr <- remove_regexp2 r res pempty;
res
and remove_regexp2 r q_nonempty q_empty =
if q_nonempty == q_empty then remove_regexp r q_empty
else match r with
| PEpsilon ->
q_empty
| PElem p ->
PTimes (p, q_nonempty)
| PGuard p ->
pand p q_empty
| PSeq (r1,r2) ->
remove_regexp2 r1
(remove_regexp2 r2 q_nonempty q_nonempty)
(remove_regexp2 r2 q_nonempty q_empty)
| PAlt (r1,r2) ->
por
(remove_regexp2 r1 q_nonempty q_empty)
(remove_regexp2 r2 q_nonempty q_empty)
| PStar r ->
let x = mk_derecurs_slot noloc in
x.pdescr <- remove_regexp2 r (POr (PAlias x, q_nonempty)) pempty;
por (PAlias x) q_empty
| PWeakStar r ->
let x = mk_derecurs_slot noloc in
x.pdescr <- remove_regexp2 r (POr (q_nonempty, PAlias x)) pempty;
por q_empty (PAlias x)
let rec derecurs env p = match p.descr with
| PatVar v -> derecurs_var env p.loc v
| SchemaVar (kind, schema_name, component_name) ->
......@@ -529,11 +594,16 @@ let rec derecurs env p = match p.descr with
let q = IdSet.fold constant_nil (derecurs env q) vars in
let r = derecurs_regexp (fun p -> p) env r in
PRegexp (r, q)
(* Note: computing remove_regexp here is slower (because
of caching ?) *)
and derecurs_regexp vars env = function
| Epsilon ->
PEpsilon
| Elem p ->
PElem (vars (derecurs env p))
| Guard p ->
PGuard (vars (derecurs env p))
| Seq (p1,p2) ->
PSeq (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
| Alt (p1,p2) ->
......@@ -561,8 +631,6 @@ and derecurs_var env loc v =
raise_loc_generic loc
("Unbound external type " ^ cu ^ ":" ^ (U.to_string v))
and derecurs_def env b =
let b = List.map (fun (v,p) -> (v,p,mk_derecurs_slot p.loc)) b in
let n =
......@@ -571,6 +639,7 @@ and derecurs_def env b =
List.iter (fun (v,p,s) -> s.pdescr <- derecurs env p) b;
env
let rec fv_slot s =
match s.fv with
| Some x -> x
......@@ -637,48 +706,8 @@ and real_compile = function
| PRecord (o,r) -> IRecord (o, LabelMap.map compile_slot r)
| PConstant (x,v) -> IConstant (x,v)
| PCapture x -> ICapture x
| PRegexp (r,q) -> compile_regexp r q
and compile_regexp r q =
let memo = RE.create 17 in
let add accu i =
match accu with None -> Some i | Some j -> Some (IOr (j,i)) in
let get = function Some x -> x | None -> assert false in
let rec queue accu = function
| PRegexp (r,q) -> aux accu r q
| _ -> add accu (compile q)
and aux accu r q =
if RE.mem memo (r,q) then accu
else (
RE.add memo (r,q) ();
match r with
| PEpsilon -> queue accu q
| PElem p ->
(* Be careful not to create pairs with same second component *)
let rec extract = function
| PConstant (x,v) -> `Const (x,v)
| POr (x,y) ->
(match extract x, extract y with
| `Pat x, `Pat y -> `Pat (POr (x,y))
| x, y -> `Or (x,y))
| p -> `Pat p
in
let rec mk accu = function
| `Const (x,v) ->
(match queue None q with
| Some q -> add accu (IAnd (IConstant (x,v), q))
| None -> accu)
| `Or (x,y) -> mk (mk accu x) y
| `Pat p ->
add accu (ITimes (compile_slot p, compile_slot q))
in
mk accu (extract p)
| PSeq (r1,r2) -> aux accu r1 (PRegexp (r2,q))
| PAlt (r1,r2) -> aux (aux accu r1 q) r2 q
| PStar r1 -> aux (aux accu r1 (PRegexp (r,q))) PEpsilon q
| PWeakStar r1 -> aux (aux accu PEpsilon q) r1 (PRegexp (r,q))
)
in
get (aux None r q)
| PRegexp (r,q) -> compile (remove_regexp r q)
and compile_slot p =
try DerecursTable.find compile_slot_hash p
with Not_found ->
......@@ -1451,18 +1480,19 @@ module Schema_converter =
let mk_seq_derecurs ~base facets =
match facets with
| { length = Some (v, _) } ->
PRegexp (mk_len_regexp ~min:v ~max:v base, nil_type)
pregexp (mk_len_regexp ~min:v ~max:v base) nil_type
| { minLength = Some (v, _); maxLength = None } ->
PRegexp (mk_len_regexp ~min:v base, nil_type)
pregexp (mk_len_regexp ~min:v base) nil_type
| { minLength = None; maxLength = Some (v, _) } ->
PRegexp (mk_len_regexp ~max:v base, nil_type)
| _ -> PRegexp (base, nil_type)
pregexp (mk_len_regexp ~max:v base) nil_type
| _ -> pregexp base nil_type
let mix_regexp =
let pcdata = PStar (PElem (PType Builtin_defs.string)) in
let rec aux = function
| PEpsilon -> PEpsilon
| PElem re -> PElem re
| PGuard re -> PGuard re
| PSeq (re1, re2) -> PSeq (aux re1, PSeq (pcdata, aux re2))
| PAlt (re1, re2) -> PAlt (aux re1, aux re2)
| PStar re -> PStar (aux re)
......@@ -1565,7 +1595,7 @@ module Schema_converter =
if mixed then
Value.failwith' "Mixed content models aren't supported";
let regexp = regexp_of_particle ~schema particle in
PRegexp (regexp, PType Sequence.nil_type)
pregexp regexp (PType Sequence.nil_type)
in
slot.pdescr <-
PTimes (cd_type_of_attr_uses ~schema ct.ct_attrs, content_ast_node);
......@@ -1617,7 +1647,7 @@ module Schema_converter =
PXml (PType Types.any, cd_type_of_complex_type' ~schema ct)
let cd_type_of_model_group ~schema g =
PRegexp (regexp_of_model_group ~schema g, nil_type)
pregexp (regexp_of_model_group ~schema g) nil_type
let typ r = Types.descr (do_typ noloc r)
......
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