[r2002-11-16 22:17:14 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-16 22:17:14+00:00

driver/cduce.ml

@@ -89,6 +89,16 @@ let debug ppf = function
       List.iter (fun (x,t) ->
 		   Format.fprintf ppf " %s:%a@\n" x
 		     print_norm (Types.descr t)) f
+  | `Restrict (p,t) -> 
+      Format.fprintf ppf "[DEBUG:restrict]@\n";
+      let t = Typer.typ !glb_env t
+      and p = Typer.pat !glb_env p in
+(*      let f = Patterns.restrict (Patterns.descr p) (Types.descr t) in
+      (match f with 
+	| `Pat q -> Format.fprintf ppf "Pat: %a@\n" Patterns.print q
+	| `Accept -> Format.fprintf ppf "Accept@\n"
+	| `Reject -> Format.fprintf ppf "Reject@\n") *)
+      Patterns.demo ppf (Patterns.descr p) (Types.descr t)
   | `Accept p ->
       Format.fprintf ppf "[DEBUG:accept]@\n";
       let p = Typer.pat !glb_env p in

driver/webiface.ml

@@ -266,7 +266,7 @@ let main (cgi : Netcgi.std_activation) =
     p "<a href='http://ocamlnet.sourceforge.net/'>OCamlnet</a>, ";
     p "<a href='http://www.ocaml-programming.de/programming/pxp.html'>PXP</a>, ";
     p "<a href='http://www.eleves.ens.fr/home/frisch/soft#wlex'>wlex</a>.";
-    p "<br>";
+    p "<p>";
     p "<a href='mailto:Alain.Frisch@ens.fr'>Webmaster</a>";
     p end_table;
 

parser/ast.ml

@@ -17,6 +17,7 @@ and debug_directive =
   | `Accept of ppat
   | `Compile of ppat * ppat list 
   | `Normal_record of ppat
+  | `Restrict of ppat * ppat
   ]
 
 

parser/parser.ml

@@ -75,6 +75,7 @@ EXTEND
     | LIDENT "accept"; p = pat -> `Accept p
     | LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
     | LIDENT "normal_record"; t = pat -> `Normal_record t
+    | LIDENT "restrict"; p = pat; t = pat -> `Restrict (p,t)
     ]
   ];
 

types/patterns.ml

@@ -22,10 +22,15 @@ and node = {
   fv : fv
 } and descr = Types.descr * fv * d
 
+let id x = x.id
+let descr x = match x.descr with Some d -> d | None -> failwith "Patterns.descr"
+let fv x = x.fv
+let accept x = Types.internalize x.accept
 
 let printed = ref []
 let to_print = ref []
-let rec print ppf (_,_,d) = 
+let rec print ppf (a,_,d) = 
+(*  Format.fprintf ppf "[%a]" Types.Print.print_descr a; *)
   match d with
     | Constr t -> Types.Print.print_descr ppf t
     | Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
@@ -44,6 +49,19 @@ let rec print ppf (_,_,d) =
     | Constant (x,c) ->
 	Format.fprintf ppf "(%s := %a)" x Types.Print.print_const c
 
+let dump_print ppf =
+  while !to_print <> [] do
+    let p = List.hd !to_print in
+    to_print := List.tl !to_print;
+    if not (List.mem p.id !printed) then
+      ( printed := p.id :: !printed;
+	Format.fprintf ppf "P%i:=%a\n" p.id print (descr p)
+      )
+  done
+
+let print ppf d =
+  Format.fprintf ppf "%a@\n" print d;
+  dump_print ppf
 
 
 let counter = State.ref "Patterns.counter" 0
@@ -91,10 +109,6 @@ let capture x = (Types.any, [x], Capture x)
 let constant x c = (Types.any, [x], Constant (x,c))
 
 
-let id x = x.id
-let descr x = match x.descr with Some d -> d | None -> failwith "Patterns.descr"
-let fv x = x.fv
-let accept x = Types.internalize x.accept
 
 
 (* Static semantics *)
@@ -162,19 +176,147 @@ let filter t p =
 (* Returns a pattern q equivalent to p when applied to a
    value of type t *)
 
-type pat = 
-    Types.descr 
-    * capture SortedList.t 
-    * (capture, Types.const) SortedMap.t
-    * patd
-and patd =
+module Compiler = 
+struct
+
+  type disp = {
+    did   : int;
+    results : (int *
+	       (capture, int) SortedMap.t option array * bool array) array
+  }
+
+  module DispMap = Map.Make(
+    struct
+      type t = (node * Types.descr) array * (Types.descr * Types.descr) array
+      let compare = compare
+    end
+  )
+    
+  let dispatchers = ref DispMap.empty
+  let nb_disp = ref 0		  
+    
+  let dispatcher pats typs : disp =
+    try DispMap.find (pats,typs) !dispatchers
+    with Not_found ->
+      incr nb_disp;
+      let d = { did = !nb_disp; results = [| |] } in
+      dispatchers := DispMap.add (pats,typs) d !dispatchers;
+      d
+
+  let sort_list l =
+    Array.of_list (SortedList.from_list l)
+
+type 'a pat =
   | One
   | Zero
-  | Alt of pat * pat
-  | And of pat * pat
-  | Prod of node * node
-  | XML of node * node
-  | Rec of Types.label * node
+  | Capt of capture
+  | Const of capture * Types.const
+  | Alt of 'a pat * 'a pat
+  | And of 'a pat * 'a pat
+  | Type of Types.descr * Types.descr
+  | Atom of Types.descr * 'a
+
+let rec print f ppf = function
+  | One -> Format.fprintf ppf "One"
+  | Zero -> Format.fprintf ppf "Zero"
+  | Capt x -> Format.fprintf ppf "%s" x
+  | Const (x,c) -> Format.fprintf ppf "(%s := %a)" x Types.Print.print_const c
+  | Alt (p1,p2) -> Format.fprintf ppf "(%a | %a)" (print f) p1 (print f) p2
+  | And (p1,p2) -> Format.fprintf ppf "(%a & %a)" (print f) p1 (print f) p2
+  | Atom (d, a) -> Format.fprintf ppf "[%a]%a" Types.Print.print_descr d f a
+  | Type (d, a) -> Format.fprintf ppf "[%a]%a" Types.Print.print_descr d Types.Print.print_descr a
+
+let alt = function
+  | (Zero,p) | (p,Zero) -> p
+  | (p1,p2) -> Alt (p1,p2)
+
+let and_ = function
+  | (Zero,_) | (_,Zero) -> Zero
+  | (One,p) | (p,One) -> p
+  | (p1,p2) -> And (p1,p2)
+
+let atom s a p =
+  if Types.is_empty (Types.cap s a) then Zero else
+    Atom (s, p)
+
+let rec get f (a,_,d) s =
+  if Types.is_empty (Types.cap s a) then Zero else
+  match d with
+    | Constr t -> 
+	if Types.subtype s t then One else Type (s, Types.cap s t)
+    | Cup ((a1,_,_) as d1,d2) ->
+	let p1 = get f d1 s in
+	let p2 = get f d2 (Types.diff s a1) in
+	alt (p1,p2)
+    | Cap ((a1,_,_) as d1,d2) ->
+(* could swap the two to optimize ? ... *)
+	let p1 = get f d1 s in
+	let p2 = get f d2 (Types.cap s a1) in
+	and_ (p1,p2)
+    | Capture x ->
+	Capt x
+    | Constant (x,c) ->
+	Const (x,c)
+    | d -> (match f d with None -> Zero | Some x -> Atom (s, x))
+
+let rec collect typ f (a,_,d) s =
+  if Types.is_empty (Types.cap s a) then () else
+  match d with
+    | Constr t -> if not (Types.subtype s a) then typ s (Types.cap s t)
+    | Cup ((a1,_,_) as d1,d2) -> 
+	collect typ f d1 s; collect typ f d2 (Types.diff s a1)
+    | Cap ((a1,_,_) as d1,d2) ->
+	collect typ f d1 s;
+	collect typ f d2 (Types.cap s a1)
+    | Capture _ | Constant (_,_) -> ()
+    | d -> f s d
+
+let get_prod =
+  get (function Times (n1,n2) -> Some n1 | _ -> None)
+let get_record =
+  get (function Record (l,n) -> Some (l,n) | _ -> None)
+
+let print_prod =
+  print (fun ppf p1 ->
+	   Format.fprintf ppf "(P%i)" p1.id
+	)
+let print_record =
+  print (fun ppf (l,p) ->
+	   Format.fprintf ppf "{ %s = P%i }" (Types.LabelPool.value l) p.id
+	)
+
+let demo ppf p t =
+  collect 
+    (fun w t -> 
+       Format.fprintf ppf "TYP1:%a // %a@\n"
+         Types.Print.print_descr t
+         Types.Print.print_descr w;
+       let n = Types.Product.normal t in
+       let pi1 = Types.Product.pi1 (Types.Product.get w) in
+       List.iter (fun (d1,d2) ->
+		    Format.fprintf ppf "=> %a // %a@\n"
+		    Types.Print.print_descr d1
+		    Types.Print.print_descr pi1
+		 ) n
+    )
+    (fun w -> function
+       | Times (n1,n2) -> 
+	   let pi1 = Types.Product.pi1 (Types.Product.get w) in
+	   Format.fprintf ppf "PAT1:%i // %a@\n" n1.id 
+	     Types.Print.print_descr pi1; 
+	   to_print := n1 :: !to_print
+       | _ -> ()) p t
+
+end
+
+let demo ppf p t =
+(*
+  Compiler.demo ppf p t;
+  dump_print ppf
+*)
+  Format.fprintf ppf "PROD:%a@\n" Compiler.print_prod (Compiler.get_prod p (Types.cap Types.Product.any t));
+  Format.fprintf ppf "REC :%a@\n" Compiler.print_record (Compiler.get_record p (Types.cap Types.Record.any t))
+
 
 let rec restrict ((a,fv,d) as p) t =
   (* TODO OPT: Don't call cup,cap .... *)
@@ -195,11 +337,9 @@ let rec restrict ((a,fv,d) as p) t =
 	   | Some p1, None -> p1
 	   | None, Some p2 -> p2
 	   | _ -> assert false)
-    | Cap ((_,_,Constr s), p') 
-    | Cap (p', (_,_,Constr s)) when Types.subtype t s -> restrict p' t
     | Cap (p1,p2) -> cap (restrict p1 t) (restrict p2 t)
-    | Capture _ | Constant (_,_) -> p
-    | _ -> (Types.cap a t, fv, d)
+(*    | Capture _ | Constant (_,_) -> p *)
+    | _ -> p (* (Types.cap a t, fv, d) *)
   
 let restrict ((a,fv,_) as p) t =
   if Types.is_empty (Types.cap a t) then `Reject

types/patterns.mli

@@ -26,6 +26,12 @@ val id: node -> int
 val descr: node -> descr
 val fv : node -> fv
 
+(*
+val print: Format.formatter -> descr -> unit
+val restrict: descr -> Types.descr -> [ `Pat of descr | `Reject | `Accept ]
+*)
+val demo: Format.formatter -> descr -> Types.descr -> unit
+
 (* Pattern matching: static semantics *)
 
 val accept : node -> Types.node