Commit 60f9f5e4 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2006-05-29 13:35:26 by afrisch] Empty log message

Original author: afrisch
Date: 2006-05-29 13:35:26+00:00
parent 18653abc
...@@ -146,6 +146,7 @@ OBJECTS = \ ...@@ -146,6 +146,7 @@ OBJECTS = \
schema/schema_builtin.cmo schema/schema_validator.cmo \ schema/schema_builtin.cmo schema/schema_validator.cmo \
\ \
types/patterns.cmo \ types/patterns.cmo \
compile/print_auto.cmo \
\ \
compile/lambda.cmo \ compile/lambda.cmo \
runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo \ runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo \
...@@ -159,7 +160,6 @@ OBJECTS = \ ...@@ -159,7 +160,6 @@ OBJECTS = \
schema/schema_parser.cmo schema/schema_converter.cmo \ schema/schema_parser.cmo schema/schema_converter.cmo \
runtime/load_xml.cmo runtime/print_xml.cmo compile/operators.cmo types/builtin.cmo \ runtime/load_xml.cmo runtime/print_xml.cmo compile/operators.cmo types/builtin.cmo \
driver/librarian.cmo types/sample.cmo \ driver/librarian.cmo types/sample.cmo \
compile/print_auto.cmo \
driver/cduce.cmo \ driver/cduce.cmo \
\ \
runtime/system.cmo query/query_aggregates.cmo runtime/system.cmo query/query_aggregates.cmo
......
...@@ -30,7 +30,7 @@ and 'a dispatch = ...@@ -30,7 +30,7 @@ and 'a dispatch =
and state = { and state = {
uid : int; uid : int;
arity : int array; arity : int array;
mutable actions: actions; mutable actions: actions;
mutable fail_code: int; mutable fail_code: int;
mutable expected_type: string; mutable expected_type: string;
......
...@@ -152,10 +152,10 @@ let compile_let_decl env decl = ...@@ -152,10 +152,10 @@ let compile_let_decl env decl =
let e,lsize = compile_expr env decl.Typed.let_body in let e,lsize = compile_expr env decl.Typed.let_body in
let env = enter_globals env (Patterns.fv pat) in let env = enter_globals env (Patterns.fv pat) in
let te = decl.Typed.let_body.Typed.exp_typ in let te = decl.Typed.let_body.Typed.exp_typ in
let comp = let comp =
Patterns.Compile.make_branches Patterns.Compile.make_branches
(te (*Types.descr (Patterns.accept pat)*)) [ pat, () ] in (te (* Types.descr (Patterns.accept pat)*)) [ pat, () ] in
let (disp, n) = let (disp, n) =
match comp with match comp with
| (disp, [| Auto_pat.Match (n, ()) |]) -> (disp,n) | (disp, [| Auto_pat.Match (n, ()) |]) -> (disp,n)
......
...@@ -647,8 +647,9 @@ module Normal = struct ...@@ -647,8 +647,9 @@ module Normal = struct
(if y then Some empty_res else None)) (if y then Some empty_res else None))
| Some l -> | Some l ->
RecLabel (l,aux (Types.Record.split_normal t l)) in RecLabel (l,aux (Types.Record.split_normal t l)) in
{ nprod = aux (Types.Product.normal t); { nprod = aux (Types.Product.clean_normal (Types.Product.normal t));
nxml = aux (Types.Product.normal ~kind:`XML t); nxml =
aux (Types.Product.clean_normal (Types.Product.normal ~kind:`XML t));
nrecord = record nrecord = record
} }
...@@ -989,7 +990,8 @@ module Compile = struct ...@@ -989,7 +990,8 @@ module Compile = struct
incr cur_id; incr cur_id;
Hashtbl.add dispatcher_of_state state.uid disp; Hashtbl.add dispatcher_of_state state.uid disp;
dispatchers := DispMap.add (t,pl) disp !dispatchers; dispatchers := DispMap.add (t,pl) disp !dispatchers;
(* dump_disp disp; *) (* dump_disp disp;
Format.fprintf Format.std_formatter "IFACE=%a@." print_iface iface; *)
!compute_actions disp; !compute_actions disp;
disp disp
...@@ -1001,7 +1003,7 @@ module Compile = struct ...@@ -1001,7 +1003,7 @@ module Compile = struct
"IFACE=%a@." print_iface d.interface; "IFACE=%a@." print_iface d.interface;
for i = 0 to Array.length a - 1 do for i = 0 to Array.length a - 1 do
Format.fprintf Format.std_formatter Format.fprintf Format.std_formatter
"a.(i)=%b@." (a.(i) != None) "a.(%i)=%b@." i (a.(i) != None)
done; done;
assert false assert false
| `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes | `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes
...@@ -1106,8 +1108,9 @@ module Compile = struct ...@@ -1106,8 +1108,9 @@ module Compile = struct
let idx = !idx in let idx = !idx in
(* Build dispatcher *) (* Build dispatcher *)
(* if Array.length reqs = 0 then print_endline "NOREQ!"; *)
let disp = dispatcher let disp = dispatcher
(if Array.length reqs = 0 then Types.any else t) reqs in (if Array.length reqs = 0 then Types.Record.any_or_absent else t) reqs in
(* Build continuation *) (* Build continuation *)
let result (t,ar,m) = let result (t,ar,m) =
...@@ -1204,7 +1207,7 @@ module Compile = struct ...@@ -1204,7 +1207,7 @@ module Compile = struct
"make_branches t=%a #branches=%i@." Types.Print.print t (List.length brs); *) "make_branches t=%a #branches=%i@." Types.Print.print t (List.length brs); *)
let pl = Array.map aux (Array.of_list brs) in let pl = Array.map aux (Array.of_list brs) in
let disp,rhs = get_tests true pl (fun x -> x) t res (fun x -> x) in let disp,rhs = get_tests true pl (fun x -> x) t res (fun x -> x) in
let state = add_factorized disp rhs in let state = add_factorized disp rhs in
state, state,
(Array.map (Array.map
(function Match (n,(_,_,_,e)) -> Match (n,e) | Fail -> Fail) rhs) (function Match (n,(_,_,_,e)) -> Match (n,e) | Fail -> Fail) rhs)
...@@ -1228,14 +1231,14 @@ module Compile = struct ...@@ -1228,14 +1231,14 @@ module Compile = struct
let dispatch_prod disp pl = let dispatch_prod disp pl =
let t = Types.Product.get disp.t in let t = Types.Product.get disp.t in
if t == [] then Impossible else if t == [] then Impossible else
dispatch_prod0 disp t dispatch_prod0 disp t
(Array.map (fun p -> Normal.NLineProd.elements p.Normal.nprod) pl) (Array.map (fun p -> Normal.NLineProd.elements p.Normal.nprod) pl)
(* dispatch_prod0 disp t (Array.map Normal.prod_tests disp.pl) *) (* dispatch_prod0 disp t (Array.map Normal.prod_tests disp.pl) *)
let dispatch_xml disp pl = let dispatch_xml disp pl =
let t = Types.Product.get ~kind:`XML disp.t in let t = Types.Product.get ~kind:`XML disp.t in
if t == [] then Impossible else if t == [] then Impossible else
dispatch_prod0 disp t dispatch_prod0 disp t
(Array.map (fun p -> Normal.NLineProd.elements p.Normal.nxml) pl) (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