Commit 1a96118d authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-20 17:50:57 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-20 17:50:57+00:00
parent 0746e040
......@@ -181,84 +181,185 @@ struct
type disp = {
did : int;
results : (int *
(capture, int) SortedMap.t option array * bool array) array
nb_codes : int;
results : res;
}
and bind = (capture, int) SortedMap.t
and res = [ `Return of int | `Fail | `Branch of (bind * res * res) ]
type p = [ `Pat of node | `Typ of Types.descr ]
module DispMap = Map.Make(
struct
type t = (node * Types.descr) array * (Types.descr * Types.descr) array
type t = Types.descr * (p,Types.descr) SortedMap.t
let compare = compare
end
)
let dispatchers = ref DispMap.empty
let nb_disp = ref 0
let rec make_res codes pos t l =
if Types.is_empty t then `Fail
else match l with
| [] -> incr codes; `Return (!codes - 1)
| (p,restr)::rem ->
let (pos,bind,a) = match p with
| `Pat p ->
let pos = ref pos in
let bind = List.map (fun v -> incr pos; (v,!pos-1)) (fv p) in
(!pos,bind,Types.descr (accept p))
| `Typ a -> (pos,[],a)
in
let oth = Types.diff t restr in
(* assert (Types.subtype restr t);*)
let yes = make_res codes pos (Types.cup (Types.cap t a) oth) rem
and no = make_res codes pos (Types.cup (Types.diff t a) oth) rem in
`Branch (bind,yes,no)
let dispatcher pats typs : disp =
try DispMap.find (pats,typs) !dispatchers
let make_dispatcher t pats : disp =
try DispMap.find (t,pats) !dispatchers
with Not_found ->
incr nb_disp;
let d = { did = !nb_disp; results = [| |] } in
dispatchers := DispMap.add (pats,typs) d !dispatchers;
let nbc = ref 0 in
let res = make_res nbc 0 t pats in
let d = { did = !nb_disp; results = res; nb_codes = !nbc } in
dispatchers := DispMap.add (t,pats) d !dispatchers;
d
let dispatcher t (args : (p * Types.descr * bind option ref) list) f =
let args =
List.map
(fun (p,restr,flag) -> (p,(restr,[flag]))) args in
let args =
SortedMap.from_list
(fun (r1,f1) (r2,f2) -> Types.cup r1 r2, f1 @ f2) args in
let pats =
List.map (fun (p,(r,_)) -> (p,r)) args in
let d = make_dispatcher t pats in
let res = Array.create d.nb_codes (Obj.magic 0) in
let rec aux = function
| (`Fail,_) -> ()
| (`Return c, []) -> res.(c) <- f ()
| (`Branch (bind,yes,no), (_,(_,fl))::rem) ->
List.iter (fun r -> r := Some bind) fl; aux (yes,rem);
List.iter (fun r -> r := None) fl; aux (no,rem)
| _ -> assert false
in
aux (d.results,args);
(d,res)
let sort_list l =
Array.of_list (SortedList.from_list l)
type 'a pat =
| One
| Zero
| 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))
type 'a pat =
| One
| Zero
| Capt of capture
| Const of capture * Types.const
| Alt of 'a pat * 'a pat
| And of 'a pat * 'a pat
| Atom of '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 a -> Format.fprintf ppf "%a" f 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 map f = function
| One -> One
| Zero -> Zero
| Capt x -> Capt x
| Const (x,c) -> Const (x,c)
| Alt (p1,p2) -> Alt (map f p1, map f p2)
| And (p1,p2) -> And (map f p1, map f p2)
| Atom a -> Atom (f a)
let rec get f (a,_,d) s =
if Types.is_empty (Types.cap s a) then Zero
else match d with
| Constr t when Types.subtype s t -> One
| 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 -> f d s
let prepare_prod =
get (fun d r ->
match d with
| Times (n1,n2) ->
let r = Types.Product.normal r in
Atom (`Pat (n1,n2,r))
| Constr t ->
Atom (`Typ (t,r))
| _ -> Zero
)
let dispatch_record t pats =
let pats = List.map (fun (p,restr) ->
match p with
| `Pat p -> prepare_prod (descr p) restr
| `Typ s -> Atom (`Typ (s,restr))
(* TODO: special case here ... restr<=t...*)
) pats in
(* Make dispatcher on first component *)
let lefts = ref [] in
let pats =
List.map (map (
function
| `Pat (n1,n2,r) ->
let pat =
List.map (fun (r1,r2) ->
let fl = ref None in
lefts := (`Pat n1,r1,fl) :: !lefts;
(fl, n2, r2)
) r in
`Pat pat
| `Typ (s,r) ->
(*...*)
assert false
)) pats in
let (disp1,f1) = dispatcher
(Types.Product.pi1 (Types.Product.get t))
!lefts
(fun () -> 0)
in
()
(*
let rec collect typ f (a,_,d) s =
if Types.is_empty (Types.cap s a) then () else
match d with
......@@ -307,6 +408,7 @@ let demo ppf p t =
to_print := n1 :: !to_print
| _ -> ()) p t
*)
end
let demo ppf p t =
......@@ -314,8 +416,11 @@ 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 =
......
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