[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

parser/ast.ml

@@ -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

parser/parser.ml

@@ -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)

query/query.ml

@@ -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

typing/typer.ml

@@ -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)