[r2004-12-24 17:39:42 by afrisch] Empty log message

Original author: afrisch
Date: 2004-12-24 17:39:42+00:00

types/patterns.ml

@@ -1690,10 +1690,8 @@ x=(1,2)
       | TCapt of TargExpr.t * t
       | TAlt of descr * Types.t * t * t
       | TConj of Types.t * fv * t * t
-      | TOther of descr * Types.t * fv * atoms
       | TTimes of Types.pair_kind * int * descr * Types.t * fv * node * node 
-    and atoms = 
-      | TRecord of label * node
+      | TRecord of int * descr * Types.t * fv * label * node
 
     let capt pr p = 
       if IdMap.is_empty pr then p else match p with
@@ -1732,20 +1730,16 @@ x=(1,2)
 	  Format.fprintf ppf "(%a | %a)" print l print r
       | TConj (_,_,l,r) -> 
 	  Format.fprintf ppf "(%a & %a)" print l print r
-      | TOther (_,t,xs,x) -> 
-	  Format.fprintf ppf "<t=%a;xs=%a;%a>"
+      | TRecord (_,_,t,xs,l,q) -> 
+	  Format.fprintf ppf "<t=%a;xs=%a;{_}>"
 	    Types.Print.print t
 	    Print.print_xs xs
-	    print_atom (t,xs,x)
       | TTimes (kind,_,_,t,xs,q1,q2) ->
 	  Format.fprintf ppf "<t=%a;xs=%a;(%a,%a)>"
 	    Types.Print.print t
 	    Print.print_xs xs
 	    Print.print q1.descr
 	    Print.print q2.descr
-    and print_atom ppf (t,xs,d) =
-      match d with
-	| TRecord _ -> Format.fprintf ppf "{_}"
 
     let get_result = function
       | TSucceed -> Some TargExpr.empty
@@ -1761,20 +1755,19 @@ x=(1,2)
 
 
     let uid = ref 0
-    let rec mk ((a,fv,d) as p) =
-      let oth x = TOther (p,Types.any,fv,x) in
-      match d with
-	| Constr t -> TConstr (t, Types.any)
-	| Cup ((a1,_,_) as p1,p2) -> TAlt (p, a1,mk p1, mk p2)
-	| Cap ((a1,fv1,_) as p1,p2) -> TConj (a1,fv1,mk p1,mk p2)
-	| Capture x -> success (TargExpr.capture x)
-	| Constant (x,c) -> success (TargExpr.cst x c)
-	| Times (q1,q2) -> 
-	    TTimes (`Normal,(incr uid; !uid), p,Types.any,fv,q1,q2)
-	| Xml (q1,q2) -> 
-	    TTimes (`XML,(incr uid; !uid), p,Types.any,fv,q1,q2)
-	| Record (l,q) -> oth (TRecord (l,q))
-	| Dummy -> assert false
+    let rec mk ((a,fv,d) as p) = match d with
+      | Constr t -> TConstr (t, Types.any)
+      | Cup ((a1,_,_) as p1,p2) -> TAlt (p, a1,mk p1, mk p2)
+      | Cap ((a1,fv1,_) as p1,p2) -> TConj (a1,fv1,mk p1,mk p2)
+      | Capture x -> success (TargExpr.capture x)
+      | Constant (x,c) -> success (TargExpr.cst x c)
+      | Times (q1,q2) -> 
+	  TTimes (`Normal,(incr uid; !uid), p,Types.any,fv,q1,q2)
+      | Xml (q1,q2) -> 
+	  TTimes (`XML,(incr uid; !uid), p,Types.any,fv,q1,q2)
+      | Record (l,q) -> 
+	  TRecord ((incr uid; !uid),p, Types.any,fv,l,q)
+      | Dummy -> assert false
 
     let constr a t = 
       if Types.disjoint a t then TFail
@@ -1814,8 +1807,8 @@ x=(1,2)
       | TConstr (a,_) -> constr a t
       | TTimes (kind,uid, p,_,_,q1,q2) ->
 	  factorize p t xs (fun xs -> TTimes (kind,uid, p,t,xs,q1,q2))
-      | TOther (p,_,_,x) ->
-	  factorize p t xs (fun xs -> TOther (p,t,xs,x))
+      | TRecord (uid,p,_,_,l,q) ->
+	  factorize p t xs (fun xs -> TRecord (uid,p,t,xs,l,q))
       | TSucceed -> if Types.is_empty t then TFail else TSucceed
       | TFail -> TFail
 
@@ -1852,19 +1845,17 @@ x=(1,2)
       try TargExpr.merge r (find_binds q (PatList.Map.get reqs) binds fetch)
       with Not_found -> r
 
+    let pair swap l r = let (l,r) = swap (l,r) in  TargExpr.SrcPair (l,r) 
     let rec set_times k swap swap' extra1 extra2 reqs1 reqs2 binds1 binds2 = 
-      let rec aux = 
-	function
-	  | TTimes (kind,uid,_,t,xs,q1,q2) when k == kind->
-	      let (q1,q2) = swap (q1,q2) in
-	      let r1 = find_binds q1 reqs1 binds1 TargExpr.fetch_left uid extra1
-	      and r2 = find_binds q2 reqs2 binds2 TargExpr.fetch_right uid extra2
-	      in
-	      let r = IdMap.merge (fun l r -> 
-				     let (l,r) = swap' (l,r) in 
-				     TargExpr.SrcPair (l,r)) r1 r2 in
-	      success (IdMap.restrict r xs)
-	  | x -> map aux x
+      let rec aux = function
+	| TTimes (kind,uid,_,t,xs,q1,q2) when k == kind->
+	    let (q1,q2) = swap (q1,q2) in
+	    let r1 = find_binds q1 reqs1 binds1 TargExpr.fetch_left uid extra1
+	    and r2 = find_binds q2 reqs2 binds2 TargExpr.fetch_right uid extra2
+	    in
+	    let r = IdMap.merge (pair swap') r1 r2 in
+	    success (IdMap.restrict r xs)
+	| x -> map aux x
       in
       aux