[r2002-11-24 17:25:48 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-24 17:25:48+00:00

types/patterns.ml

@@ -707,20 +707,20 @@ struct
     record: ((Types.label, node sl) sm) line;
 
   }
-
+  type nnf = Types.descr * node sl
   type 'a nline = (result *  'a) list
   type record =
       [ `Success
       | `Fail
-      | `Dispatch of (nf * record) list
-      | `Label of Types.label * (nf * record) list * record ]
+      | `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  : (nf * nf) nline;
-    nxml   : (nf * nf) nline;
+    nprod  : (nnf * nnf) nline;
+    nxml   : (nnf * nnf) nline;
     nrecord: record nline
   }
 
@@ -870,7 +870,7 @@ struct
       | Constant (x,c) -> constant x c
       | Record (l,p) -> record acc l p
 
-  let bigcap = List.fold_left (fun a p -> cap a (nf (descr p))) any
+  let bigcap pl = pl (* List.fold_left (fun a p -> cap a (nf (descr p))) any *)
 
   let normal nf =
     let basic =
@@ -878,8 +878,7 @@ struct
 
     and prod ?kind l =
       let line accu (((res,(pl,ql)),acc)) =
-	let p = bigcap pl and q = bigcap ql in
-	let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
+	let aux accu (t1,t2) = (res,( (t1,pl), (t2,ql) ))::accu in
 	let t = Types.Product.normal ?kind acc in
 	List.fold_left aux accu t in
       List.fold_left line [] l
@@ -891,18 +890,17 @@ struct
 	  | (`Success, []) -> `Success
 	  | (`Fail,_) -> `Fail
 	  | (`Success, (l2,pl)::fields) ->
-	      `Label (l2, [bigcap pl, aux nr fields], `Fail)
+	      `Label (l2, [(Types.any,pl), aux nr fields], `Fail)
 	  | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
-	      `Label (l2, [bigcap pl, aux nr fields], `Fail)
+	      `Label (l2, [(Types.any,pl), aux nr fields], `Fail)
 	  | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
-	      let p = bigcap pl in
 	      let pr = 
-		List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in
+		List.map (fun (t,x) -> ((t,pl), 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) -> (constr 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
@@ -1197,10 +1195,15 @@ struct
     let unselect = Array.create (Array.length pl) [] in
     let aux i x = 
       let yes, no = f x in
-      List.iter (fun (p,info) ->
+      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
-		   accu := (p,[i, info]) :: !accu;
+		   accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;
 		) yes;
       unselect.(i) <- no @ unselect.(i) in
     Array.iteri (fun i -> List.iter (aux i)) pl;
@@ -1210,7 +1213,7 @@ struct
     let disp = dispatcher t (Array.map fst sorted) in
     let result (t,_,m) =
       let selected = Array.create (Array.length pl) [] in
-      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
+      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
       List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
       d t selected unselect
     in
@@ -1222,9 +1225,9 @@ struct
     let (_,brs) = 
       List.fold_left
 	(fun (t,brs) (p,e) ->
-	   let p = Normal.restrict t (Normal.nf p) in
-	   let t = Types.diff t (p.Normal.a) in
-	   (t, (p,(p.Normal.catchv,e)) :: brs)
+	   let p' = (t,[p]) in
+	   let t' = Types.diff t (Types.descr (accept p)) in
+	   (t', (p',e) :: brs)
 	) (t,[]) brs in
 	
     let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
@@ -1235,7 +1238,7 @@ struct
       (fun _ pl _ ->
 	 let r = ref None in
 	 let aux = function 
-	   | [(res,(catchv,e))] -> assert (!r = None); 
+	   | [(res,catchv,e)] -> assert (!r = None); 
 	       let catchv = List.map (fun v -> (v,-1)) catchv in
 	       r := Some (SortedMap.union_disj catchv res,e)
 	   | [] -> () | _ -> assert false in
@@ -1261,12 +1264,12 @@ struct
   and dispatch_prod1 disp t t1 pl _ =
     let t = Types.Product.restrict_1 t t1 in
     get_tests pl
-      (fun (ret1, (res,q)) -> [q, (ret1,res)], [] ) 
+      (fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] ) 
       (Types.Product.pi2 t)
       (dispatch_prod2 disp t)
       (fun x -> detect_right_tail_call (combine x))
   and dispatch_prod2 disp t t2 pl _ =
-    let aux_final (ret2, (ret1, res)) =  
+    let aux_final (ret2, ncatchv, (ret1, res)) =  
       List.map (conv_source_prod ret1 ret2) res in
     return disp pl aux_final
 
@@ -1386,7 +1389,7 @@ struct
 	  combine_record l present absent
   and dispatch_record_field l disp t plabs tfield pl others =
     let t = Types.Record.restrict_field t l tfield in
-    let aux (ret, (res, catch, rem)) = 
+    let aux (ret, ncatchv, (res, catch, rem)) = 
       let catch = if ret = [] then catch else (l,ret) :: catch in
       (res, catch, rem) in
     let pl = Array.map (List.map aux) pl in

types/patterns.mli

@@ -84,6 +84,6 @@ module Compile: sig
   val show : Format.formatter -> Types.descr -> normal array -> unit
 
   val make_branches :
-    Types.descr -> (descr * 'a) list ->
+    Types.descr -> (node * 'a) list ->
     dispatcher * ((capture, int) SortedMap.t * 'a) array
 end

typing/typed.ml

@@ -75,7 +75,7 @@ let dispatcher brs =
   match brs.br_compiled with
     | Some d -> d
     | None ->
-	let aux b = Patterns.descr b.br_pat, b.br_body in
+	let aux b = b.br_pat, b.br_body in
 	let x = Patterns.Compile.make_branches
 		  brs.br_typ
 		  (List.map aux brs.br_branches) in
@@ -88,7 +88,7 @@ let dispatcher_let_decl l =
     | None ->
 	let comp = Patterns.Compile.make_branches
 		     (Types.descr (Patterns.accept l.let_pat))
-		     [ Patterns.descr l.let_pat, () ]  in
+		     [ l.let_pat, () ]  in
 	let x = match comp with
 	  | (disp, [| l, () |]) -> (disp,l)
 	  | _ -> assert false