Skip to content

GitLab

Commit 3a61c941 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-24 15:35:53 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-11-24 15:35:54+00:00
parent f8e56c92
Hide whitespace changes
Inline Side-by-side
driver/cduce.ml
View file @ 3a61c941
......@@ -91,11 +91,14 @@ let debug ppf = function
print_norm (Types.descr t)) f
| `Compile2 (t,pl) ->
Format.fprintf ppf "[DEBUG:compile2]@\n";
let t = Typer.typ !glb_env t
and pl = List.map (fun p -> (`Pat (Typer.pat !glb_env p), Types.any)) pl in
let d = Patterns.Compiler.make_dispatcher
(Types.descr t) pl in
Patterns.Compiler.print_disp ppf d
(* let t = Types.descr (Typer.typ !glb_env t) in
let pl = List.map (fun p ->
let p = Typer.pat !glb_env p in
let a = Types.descr (Patterns.accept p) in
(Some p, Types.cap a t)) pl in
let d = Patterns.Compiler.make_dispatcher t pl in
Patterns.Compiler.print_disp ppf d *)
()
| `Accept p ->
Format.fprintf ppf "[DEBUG:accept]@\n";
......
types/patterns.ml
View file @ 3a61c941
......@@ -175,17 +175,15 @@ let filter t p =
(* Returns a pattern q equivalent to p when applied to a
value of type t *)
(*
module Compiler =
struct
type p = [ `Pat of node | `Typ of Types.descr ]
type dispatcher = {
did : int;
nb_codes : int;
results : res;
t : Types.descr;
pats : (p,Types.descr) SortedMap.t;
pats : (node option * Types.descr) SortedList.t;
mutable actions : actions option;
}
and bind = (capture, int) SortedMap.t
......@@ -207,7 +205,7 @@ struct
module DispMap = Map.Make(
struct
type t = Types.descr * (p,Types.descr) SortedMap.t
type t = Types.descr * (node option * Types.descr) SortedList.t
let compare = compare
end
)
......@@ -222,19 +220,15 @@ struct
incr codes; `Return (t, !codes - 1)
| (p,restr)::rem ->
let (pos,bind,a) = match p with
| `Pat p ->
| Some 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)
(!pos,bind,Types.cap restr (Types.descr (accept p)))
| None -> (pos,[],restr)
in
let oth = Types.diff t restr in
(* Format.fprintf Format.std_formatter
"<<<%a>>>@\n" Types.Print.print_descr (Types.cap t a);
*)
(* 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
let yes = make_res codes pos (Types.cap t a) rem
and no = make_res codes pos (Types.diff t a) rem in
`Branch (bind,yes,no)
......@@ -260,26 +254,30 @@ struct
find_code accu (no,rem)
| (`Branch (_,yes,_),Some x::rem) ->
find_code (List.rev_append x accu) (yes,rem)
| (`Fail,_) -> assert false
| _ -> assert false
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 dispatcher t (args : (node option * Types.descr * bind option ref)
list) f =
(* let args =
List.map
(function
| (`Pat p, s, r) -> (`Pat p, Types.cap t s, r)
| (`Typ c, s, r) ->
let s = Types.cap t s in
(`Typ (Types.cap c s), s, r)) args in *)
let args = List.map (fun (p,restr,flag) -> ((p,restr),[flag])) args in
let args = SortedMap.from_list (@) args in
let pats = List.map fst 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 (t,c), []) -> res.(c) <- f t
| (`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)
| (`Branch (bind,yes,no), (_,fls)::rem) ->
List.iter (fun r -> r := Some bind) fls; aux (yes,rem);
List.iter (fun r -> r := None) fls; aux (no,rem)
| _ -> assert false
in
aux (d.results,args);
......@@ -293,8 +291,8 @@ struct
type 'a pat =
| One
| Zero
| Capt of capture
| Const of capture * Types.const
| Capt of Types.descr * capture
| Const of Types.descr * capture * Types.const
| Alt of 'a pat * 'a pat
| And of 'a pat * 'a pat
| Atom of 'a
......@@ -302,8 +300,11 @@ struct
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
| Capt (t,x) ->
Format.fprintf ppf "[%a]%s" Types.Print.print_descr t x
| Const (t,x,c) ->
Format.fprintf ppf "[%a](%s:=%a)" Types.Print.print_descr t
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
......@@ -317,6 +318,10 @@ struct
| (One,p) | (p,One) -> p
| (p1,p2) -> And (p1,p2)
(*
debug compile2 (Int,Int)|(Char,Char) (Int,x)|(x,Char);;
*)
(*
let atom s a p =
if Types.is_empty (Types.cap s a) then Zero else
......@@ -326,28 +331,27 @@ struct
let rec map f = function
| One -> One
| Zero -> Zero
| Capt x -> Capt x
| Const (x,c) -> Const (x,c)
| Capt (t,x) -> Capt (t,x)
| Const (t,x,c) -> Const (t,x,c)
| Alt (p1,p2) -> alt (map f p1, map f p2)
| And (p1,p2) -> and_ (map f p1, map f p2)
| Atom a -> f a
let rec get f (a,_,d) s =
if Types.is_empty (Types.cap s a) then Zero
let s = Types.cap s a in
if Types.is_empty s 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
let p2 = get f d2 s in
and_ (p1,p2)
| Capture x ->
Capt x
| Constant (x,c) ->
Capt (s,x)
| Constant (s,x,c) ->
Const (x,c)
| d -> f d s
......@@ -355,8 +359,8 @@ struct
| Atom x -> f x
| One -> Some []
| Zero -> None
| Capt x -> Some [x, `Capture]
| Const (x,c) -> Some [x, `Const c]
| Capt (s,x) -> Some [x, `Capture]
| Const (s,x,c) -> Some [x, `Const c]
| Alt (p1,p2) ->
(match get_final f p1 with
| Some _ as x -> x
......@@ -370,7 +374,7 @@ struct
| None -> None)
let get_final f p =
match get_final f p with
match get_final f t p with
| None -> None
| Some l -> Some (List.map snd l)
......@@ -386,85 +390,67 @@ struct
get (fun d r ->
match d with
| Times (n1,n2) ->
Atom (`Pat (n1,n2,r))
| Constr t ->
Atom (`Typ (Types.cap t r,r))
Atom (Some (n1,n2),r)
| Constr _ ->
Atom (None,r)
| _ -> Zero
)
let prepare_prod (p,restr) =
match p with
| `Pat p -> prepare_prod' (descr p) restr
| `Typ s -> Atom (`Typ (s,restr))
| Some p -> prepare_prod' (descr p) restr
| None -> Atom (None, restr)
(* TODO: special case here ... restr<=t...*)
let map_prod1 collect = function
| `Pat (n1,n2,r) ->
let fl = ref None in
collect := (`Pat n1,pi1 r,fl) :: !collect;
Atom (`Pat (fl, n2, r))
| `Typ (s,r) ->
let r1 = pi1 r in
let l =
List.map
(fun (s1,s2) ->
let fl = ref None in
collect := (`Typ s1,r1,fl) :: !collect;
(fl, s2)
) (Types.Product.normal s) in
(* would be ok with Types.Product.get ... *)
Atom (`Typ (l,r))
let map_prod2 t1 collect = function
| `Pat (fl1,n2,r) ->
(match !fl1 with
| None -> Zero
| Some bind ->
let fl2 = ref None in
collect := (`Pat n2, pi2 r t1,fl2) :: !collect;
Atom (`Pat (bind,fl2))
)
| `Typ (l,r) ->
let r2 = pi2 r t1 in
let l =
List.fold_left
(fun accu (fl1,s2) ->
match !fl1 with
| None -> accu
| Some bind ->
assert(bind = []);
let fl2 = ref None in
collect := (`Typ s2, r2, fl2) :: !collect;
fl2::accu
) [] l in
Atom (`Typ l)
let prod_final =
get_final (
function
| `Pat (bind1,{ contents = Some bind2 }) ->
let x =
SortedMap.combine
let map_prod1 collect (p,r) =
let (n1,n2) = match p with
| Some (n1,n2) -> Some n1, Some n2
| None -> None, None in
let l =
List.map
(fun (r1,r2) ->
let fl = ref None in
collect := (n1,r1,fl) :: !collect;
(fl,n2,r2)
) (Types.Product.normal r) in
Atom l
let map_prod2 collect l =
let l =
List.fold_left
(fun accu (fl1,n2,r2) ->
match !fl1 with
| None -> accu
| Some bind ->
let fl2 = ref None in
collect := (n2, r2, fl2) :: !collect;
(bind,fl2)::accu
) [] l in
Atom l
let rec prod_final = function
| [] -> None
| (bind1,{contents = Some bind2})::_ ->
Some (SortedMap.combine
(fun x -> `Left x) (fun x -> `Right x)
(fun x y -> `Combine (x,y))
bind1 bind2
in
Some x
| `Typ l when List.exists (fun fl -> !fl <> None) l -> Some []
| _ -> None
)
let dispatch_prod (res:res) t (pats:(p*Types.descr) list) : prod_actions =
bind1 bind2)
| _::rem -> prod_final rem
let dispatch_prod (res:res) t (pats:(node option * Types.descr) list) :
prod_actions =
let pats = List.map prepare_prod pats in
let lefts = ref [] in
let pats = map_list (map_prod1 lefts) pats in
dispatcher (pi1 t) !lefts
(fun t1 ->
let rights = ref [] in
let pats = map_list (map_prod2 t1 rights) pats in
let pats = map_list (map_prod2 rights) pats in
dispatcher (pi2 t t1) !rights
(fun t2 ->
let pats = List.map prod_final pats in
let pats = List.map (get_final (prod_final)) pats in
find_code [] (res,pats)
)
)
......@@ -477,13 +463,13 @@ struct
let prepare_basic' =
get (fun d r ->
match d with
| Constr t -> Atom t
| Constr _ -> Atom r
| _ -> Zero)
let prepare_basic (p,restr) =
match p with
| `Pat p -> prepare_basic' (descr p) restr
| `Typ s -> Atom s
| Some p -> prepare_basic' (descr p) restr
| None -> Atom restr
let basic_final t =
get_final (
......@@ -497,14 +483,31 @@ struct
let rec aux = function
| `Fail -> ()
| `Branch (bind,yes,no) -> aux yes; aux no
| `Return (t,_) ->
| `Return (t,c) ->
(* Format.fprintf Format.std_formatter "<<<%a -> %i>>>@\n"
Types.Print.print_descr t c; *)
let t = Types.cap t any_basic in
if not (Types.is_empty t) then types := t :: !types in
aux res;
let pats = List.map prepare_basic pats in
Format.fprintf Format.std_formatter "BASIC:%i@\n" (List.length !types);
List.iter (fun p ->
Format.fprintf Format.std_formatter
"==> %a@\n"
(print Types.Print.print_descr) p
) pats;
List.map
(fun t ->
let pats = List.map (basic_final t) pats in
Format.fprintf Format.std_formatter "BASIC:";
List.iter (function
| Some _ ->
Format.fprintf Format.std_formatter "YES"
| None ->
Format.fprintf Format.std_formatter "NO "
) pats;
Format.fprintf Format.std_formatter "@\n";
(t, find_code [] (res,pats))
) !types
......@@ -676,6 +679,7 @@ let restrict ((a,fv,_) as p) t =
if Types.is_empty (Types.cap a t) then `Reject
else if (fv = []) && (Types.subtype t a) then `Accept
else `Pat (restrict p t)
*)
(* Normal forms for patterns and compilation *)
......
types/patterns.mli
View file @ 3a61c941
......@@ -26,24 +26,22 @@ 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
val filter : Types.descr -> node -> (capture,Types.node) SortedMap.t
(*
module Compiler: sig
type p = [ `Pat of node | `Typ of Types.descr ]
type dispatcher
val make_dispatcher : Types.descr -> (p,Types.descr) SortedMap.t -> dispatcher
val make_dispatcher :
Types.descr ->
(node option * Types.descr) SortedList.t -> dispatcher
val print_disp: Format.formatter -> dispatcher -> unit
val demo: Format.formatter -> descr -> Types.descr -> unit
end
*)
(* Pattern matching: compilation *)
......
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