[r2002-11-24 20:44:12 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-24 20:44:13+00:00

driver/cduce.ml

@@ -109,10 +109,7 @@ let debug ppf = function
       Format.fprintf ppf "[DEBUG:compile]@\n";
       let t = Typer.typ !glb_env t
       and pl = List.map (Typer.pat !glb_env) pl in
-      let pl = Array.of_list 
-		 (List.map (fun p -> Patterns.Compile.normal 
-			      (Patterns.descr p)) pl) in
-      Patterns.Compile.show ppf (Types.descr t) pl
+      Patterns.Compile.debug_compile ppf t pl
   | `Normal_record t ->
       Format.fprintf ppf "[DEBUG:normal_record]@\n";
       let t = Types.descr (Typer.typ !glb_env t) in

types/patterns.ml

@@ -684,7 +684,37 @@ let restrict ((a,fv,_) as p) t =
 
 (* Normal forms for patterns and compilation *)
 
-module Normal = 
+module Normal : sig 
+  type 'a sl = 'a SortedList.t
+  type ('a,'b) sm = ('a,'b) SortedMap.t
+
+  type source = 
+      [ `Catch | `Const of Types.const 
+      | `Left | `Right | `Recompose 
+      | `Field of Types.label 
+      ]
+  type result = (capture, source) sm
+
+  type nnf = node sl * Types.descr
+  type 'a nline = (result *  'a) list
+  type record =
+      [ `Success
+      | `Fail
+      | `Dispatch of (nnf * record) list
+      | `Label of Types.label * (nnf * record) list * record ]
+  type t = {
+    nfv    : fv;
+    ncatchv: fv;
+    na     : Types.descr;
+    nbasic : Types.descr nline;
+    nprod  : (nnf * nnf) nline;
+    nxml   : (nnf * nnf) nline;
+    nrecord: record nline
+  }
+
+  val any_basic: Types.descr
+  val normal: Types.descr -> node list -> t
+end = 
 struct
   type 'a sl = 'a SortedList.t
   type ('a,'b) sm = ('a,'b) SortedMap.t
@@ -707,8 +737,9 @@ struct
     record: ((Types.label, node sl) sm) line;
 
   }
-  type nnf = Types.descr * node sl
-  type 'a nline = (result *  'a) list
+
+  type nnf = node sl * Types.descr   (* pl,t;   t <= \accept{pl} *)
+  type 'a nline = (result *  'a) sl
   type record =
       [ `Success
       | `Fail
@@ -724,6 +755,72 @@ struct
     nrecord: record nline
   }
 
+  let nempty = { nfv = []; ncatchv = []; na = Types.empty;
+		 nbasic = []; nprod = []; nxml = []; nrecord = [] }
+
+
+  let ncup nf1 nf2 = 
+    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
+    (* assert (nf1.nfv = nf2.nfv); *)
+    { nfv = nf1.nfv;
+      ncatchv = SortedList.cap nf1.ncatchv nf2.ncatchv;
+      na      = Types.cup nf1.na nf2.na;
+      nbasic  = SortedList.cup nf1.nbasic nf2.nbasic;
+      nprod   = SortedList.cup nf1.nprod nf2.nprod;
+      nxml    = SortedList.cup nf1.nxml nf2.nxml;
+      nrecord = SortedList.cup nf1.nrecord nf2.nrecord;
+    }
+
+  let fus = SortedMap.union_disj
+  let slcup = SortedList.cup
+
+  let double_fold f l1 l2 =
+    SortedList.from_list
+      (List.fold_left 
+	 (fun accu x1 ->
+	    List.fold_left
+	    (fun accu x2 ->
+	       f accu x1 x2
+	    )
+	    accu l2
+	 ) [] l1)
+	 
+  let ncap nf1 nf2 =
+    let prod accu (res1,((pl1,t1),(ql1,s1))) (res2,((pl2,t2),(ql2,s2))) =
+      let t = Types.cap t1 t2 in
+      if Types.is_empty t then accu else
+	let s = Types.cap s1 s2  in
+	if Types.is_empty s then accu else
+	  (fus res1 res2, ((slcup pl1 pl2,t),(slcup ql1 ql2,s))) :: accu
+    in
+    let basic accu (res1,t1) (res2,t2) =
+      let t = Types.cap t1 t2 in
+      if Types.is_empty t then accu else
+	(fus res1 res2, t) :: accu
+    in
+    { nfv = SortedList.cup nf1.nfv nf2.nfv;
+      ncatchv = SortedList.cup nf1.ncatchv nf2.ncatchv;
+      na = Types.cap nf1.na nf2.na;
+      nbasic = double_fold basic nf1.nbasic nf2.nbasic;
+      nprod = double_fold prod nf1.nprod nf2.nprod;
+      nxml = double_fold prod nf1.nxml nf2.nxml;
+      nrecord = []; (* TODO ... *)
+    }
+
+  let ntimes acc p q = 
+    let src_p = List.map (fun v -> (v,`Left)) p.fv
+    and src_q = List.map (fun v -> (v,`Right)) q.fv in
+    let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in 
+    let rects = Types.Product.normal acc in
+    let prod = List.map (fun (t1,t2) -> (src, (([p],t1),([q],t2)))) rects in
+    { nempty with 
+	nfv = SortedList.cup p.fv q.fv; 
+	na = acc;
+	nprod = SortedList.from_list prod
+    }
+
+    
+
   let empty = { v = []; catchv = []; 
 		a = Types.empty; 
 		basic = []; prod = []; xml = []; record = [] }
@@ -747,8 +844,6 @@ struct
        record = filter nf.record;
     }
 
-  let fus = SortedMap.union_disj
-  let slcup = SortedList.cup
 
   let cap nf1 nf2 =
     let merge f lines1 lines2 =
@@ -870,15 +965,13 @@ struct
       | Constant (x,c) -> constant x c
       | Record (l,p) -> record acc l p
 
-  let bigcap pl = pl (* List.fold_left (fun a p -> cap a (nf (descr p))) any *)
-
   let normal nf =
     let basic =
       List.map (fun ((res,()),acc) -> (res,acc)) 
 
     and prod ?kind l =
       let line accu (((res,(pl,ql)),acc)) =
-	let aux accu (t1,t2) = (res,( (t1,pl), (t2,ql) ))::accu in
+	let aux accu (t1,t2) = (res,( (pl,t1), (ql,t2) ))::accu in
 	let t = Types.Product.normal ?kind acc in
 	List.fold_left aux accu t in
       List.fold_left line [] l
@@ -890,17 +983,17 @@ struct
 	  | (`Success, []) -> `Success
 	  | (`Fail,_) -> `Fail
 	  | (`Success, (l2,pl)::fields) ->
-	      `Label (l2, [(Types.any,pl), aux nr fields], `Fail)
+	      `Label (l2, [(pl,Types.any), aux nr fields], `Fail)
 	  | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
-	      `Label (l2, [(Types.any,pl), aux nr fields], `Fail)
+	      `Label (l2, [(pl,Types.any), aux nr fields], `Fail)
 	  | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
 	      let pr = 
-		List.map (fun (t,x) -> ((t,pl), aux x fields)) pr in
+		List.map (fun (t,x) -> (((pl,t) : nnf), aux x fields)) pr in
 	      `Label (l1, pr, `Fail)
 	  | (`Label (l1, pr, ab),_) ->
 	      let aux_ab = aux ab fields in
 	      let pr = 
-		List.map (fun (t,x) -> ((t,[]), 
+		List.map (fun (t,x) -> (([],t), 
 (* Types.Record.normal enforce physical equility
    in case of a ? field *)
 					if x==ab then aux_ab else
@@ -927,6 +1020,9 @@ struct
       nrecord = nlines (record nf.record);
     }
 
+  let normal t pl =
+    normal (List.fold_left (fun a p -> cap a (nf (descr p))) (constr t) pl)
+
 end
 
 
@@ -1195,14 +1291,8 @@ struct
     let unselect = Array.create (Array.length pl) [] in
     let aux i x = 
       let yes, no = f x in
-      List.iter (fun ( (ty,pl), info) ->
-		   let p = 
-		     List.fold_left (fun a p -> Normal.cap a 
-				       (Normal.nf (descr p))) 
-		       (Normal.constr ty) pl in
-		   
-		   let p = Normal.restrict t p in
-		   let p = Normal.normal p in
+      List.iter (fun ( (pl,ty), info) ->
+		   let p = Normal.normal ty pl in
 		   accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;
 		) yes;
       unselect.(i) <- no @ unselect.(i) in
@@ -1225,7 +1315,7 @@ struct
     let (_,brs) = 
       List.fold_left
 	(fun (t,brs) (p,e) ->
-	   let p' = (t,[p]) in
+	   let p' = ([p],t) in
 	   let t' = Types.diff t (Types.descr (accept p)) in
 	   (t', (p',e) :: brs)
 	) (t,[]) brs in
@@ -1590,9 +1680,11 @@ struct
     queue disp;
     print_dispatchers ppf
 
-  type normal = Normal.t
-  let normal p = Normal.normal (Normal.nf p)
-
+  let debug_compile ppf t pl =
+    let pl = Array.of_list 
+	       (List.map (fun p -> Normal.normal Types.any [p]) pl) in
+    let t = Types.descr t in
+    show ppf t pl
 end
 
 

types/patterns.mli

@@ -46,11 +46,7 @@ end
 (* Pattern matching: compilation *)
 
 module Compile: sig
-  type normal
-  val normal : descr -> normal
-
   type dispatcher
-  val dispatcher: Types.descr -> normal array -> dispatcher
 
   type actions =
       [ `Ignore of result
@@ -81,9 +77,9 @@ module Compile: sig
 
   val actions: dispatcher -> actions
 
-  val show : Format.formatter -> Types.descr -> normal array -> unit
-
   val make_branches :
     Types.descr -> (node * 'a) list ->
     dispatcher * ((capture, int) SortedMap.t * 'a) array
+
+  val debug_compile : Format.formatter -> Types.node -> node list -> unit
 end

types/types.ml

@@ -24,13 +24,13 @@ type pair_kind = [ `Normal | `XML ]
 
 module I = struct
   type 'a t = {
-    ints  : Intervals.t;
     atoms : atom Atoms.t;
+    ints  : Intervals.t;
+    chars : Chars.t;
     times : ('a * 'a) Boolean.t;
     xml   : ('a * 'a) Boolean.t;
     arrow : ('a * 'a) Boolean.t;
     record: (label * bool * 'a) Boolean.t;
-    chars : Chars.t;
   }
 
   let empty = {