Commit 255e9a34 authored by Pietro Abate's avatar Pietro Abate

[r2006-05-29 08:38:53 by afrisch] Empty log message

Original author: afrisch
Date: 2006-05-29 08:38:54+00:00
parent 940e150d
......@@ -152,9 +152,10 @@ let compile_let_decl env decl =
let e,lsize = compile_expr env decl.Typed.let_body in
let env = enter_globals env (Patterns.fv pat) in
let te = decl.Typed.let_body.Typed.exp_typ in
let comp =
Patterns.Compile.make_branches
(Types.descr (Patterns.accept pat)) [ pat, () ] in
(te (*Types.descr (Patterns.accept pat)*)) [ pat, () ] in
let (disp, n) =
match comp with
| (disp, [| Auto_pat.Match (n, ()) |]) -> (disp,n)
......
......@@ -499,7 +499,9 @@ module Normal = struct
List.iter (fun p -> assert(Types.subtype t (Types.descr p.accept)))
(NodeSet.get pl)
let print ppf (pl,t,xs) =
Format.fprintf ppf "@[(pl=%a;t=%a)@]" NodeSet.dump pl Types.Print.print t
Format.fprintf ppf "@[(pl=%a;t=%a;xs=%a)@]"
NodeSet.dump pl Types.Print.print t
IdSet.dump xs
let compare (l1,t1,xs1) (l2,t2,xs2) =
let c = NodeSet.compare l1 l2 in if c <> 0 then c
else let c = Types.compare t1 t2 in if c <> 0 then c
......@@ -987,6 +989,7 @@ module Compile = struct
incr cur_id;
Hashtbl.add dispatcher_of_state state.uid disp;
dispatchers := DispMap.add (t,pl) disp !dispatchers;
(* dump_disp disp; *)
!compute_actions disp;
disp
......@@ -1085,8 +1088,15 @@ module Compile = struct
let get_tests facto pl f t d post =
let pl = Array.map (List.map f) pl in
let factorized = ref NfMap.empty in
(* Collect all subrequests *)
let aux reqs (req,_) = NfSet.add req reqs in
let aux reqs (req,_) =
let (_,_,((_,tr,xs) as r')) as req' =
if facto then Normal.factorize t req else [],[],req in
factorized := NfMap.add req req' !factorized;
if IdSet.is_empty xs && Types.subtype t tr then reqs
else NfSet.add r' reqs in
let reqs = Array.fold_left (List.fold_left aux) NfSet.empty pl in
let reqs = Array.of_list (NfSet.elements reqs) in
......@@ -1096,19 +1106,19 @@ module Compile = struct
let idx = !idx in
(* Build dispatcher *)
let reqs_facto =
if facto then Array.map (Normal.factorize t) reqs
else Array.map (fun r -> [],[],r) reqs in
let reqs = Array.map (fun (_,_,req) -> req) reqs_facto in
let disp = dispatcher t reqs in
let disp = dispatcher
(if Array.length reqs = 0 then Types.any else t) reqs in
(* Build continuation *)
let result (t,ar,m) =
let get (req,info) a =
let i = NfMap.find req idx in
let (var,nil,_) = reqs_facto.(i) in
match m.(i) with Some res -> ((var,nil,res),info)::a | _ -> a in
let (var,nil,r') = NfMap.find req !factorized in
try
let i = NfMap.find r' idx in
match m.(i) with Some res -> ((var,nil,res),info)::a | _ -> a
with Not_found ->
((var,nil,IdMap.empty),info)::a
in
let pl = Array.map (fun l -> List.fold_right get l []) pl in
d t ar pl
in
......@@ -1131,6 +1141,8 @@ module Compile = struct
Match (List.length xs, e)
| [] -> r | _ -> assert false in
Array.fold_left aux Fail pl in
(* Format.fprintf Format.std_formatter
"make_branches t=%a #branches=%i@." Types.Print.print t (List.length brs); *)
let pl = Array.map aux (Array.of_list brs) in
get_tests false pl (fun x -> x) t res (fun (disp,rhs) -> disp.state,rhs)
......@@ -1153,12 +1165,14 @@ module Compile = struct
let dispatch_prod disp pl =
let t = Types.Product.get disp.t in
if t == [] then Impossible else
dispatch_prod0 disp t
(Array.map (fun p -> Normal.NLineProd.elements p.Normal.nprod) pl)
(* dispatch_prod0 disp t (Array.map Normal.prod_tests disp.pl) *)
let dispatch_xml disp pl =
let t = Types.Product.get ~kind:`XML disp.t in
if t == [] then Impossible else
dispatch_prod0 disp t
(Array.map (fun p -> Normal.NLineProd.elements p.Normal.nxml) pl)
......
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