Commit 07489b93 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: cvscast
Date: 2002-11-16 22:17:14+00:00
parent 34c2cc05
......@@ -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
......
......@@ -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;
......
......@@ -17,6 +17,7 @@ and debug_directive =
| `Accept of ppat
| `Compile of ppat * ppat list
| `Normal_record of ppat
| `Restrict of ppat * ppat
]
......
......@@ -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)
]
];
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment