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

Original author: afrisch
Date: 2006-05-29 13:35:26+00:00

Makefile.distrib

@@ -146,6 +146,7 @@ OBJECTS = \
  schema/schema_builtin.cmo schema/schema_validator.cmo \
  \
  types/patterns.cmo \
+ compile/print_auto.cmo \
  \
  compile/lambda.cmo \
  runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo \
@@ -159,7 +160,6 @@ OBJECTS = \
  schema/schema_parser.cmo schema/schema_converter.cmo \
  runtime/load_xml.cmo runtime/print_xml.cmo compile/operators.cmo types/builtin.cmo \
  driver/librarian.cmo types/sample.cmo \
- compile/print_auto.cmo \
  driver/cduce.cmo \
  \
  runtime/system.cmo query/query_aggregates.cmo

compile/auto_pat.ml

@@ -30,7 +30,7 @@ and 'a dispatch =
 
 and state = {
   uid : int;
-  arity : int array; 
+  arity : int array;
   mutable actions: actions;
   mutable fail_code: int;
   mutable expected_type: string;

compile/compile.ml

@@ -152,10 +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 te = decl.Typed.let_body.Typed.exp_typ in 
   let comp = 
     Patterns.Compile.make_branches 
-      (te (*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)

types/patterns.ml

@@ -647,8 +647,9 @@ module Normal = struct
 		      (if y then Some empty_res else None))
       | Some l ->
 	  RecLabel (l,aux (Types.Record.split_normal t l)) in
-    {  nprod = aux (Types.Product.normal t);
-       nxml  = aux (Types.Product.normal ~kind:`XML t);
+    {  nprod = aux (Types.Product.clean_normal (Types.Product.normal t));
+       nxml  = 
+	aux (Types.Product.clean_normal (Types.Product.normal ~kind:`XML t));
        nrecord = record
     }
 
@@ -989,7 +990,8 @@ module Compile = struct
       incr cur_id;
       Hashtbl.add dispatcher_of_state state.uid disp;
       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;
       disp
     
@@ -1001,7 +1003,7 @@ module Compile = struct
 	    "IFACE=%a@." print_iface d.interface; 
 	  for i = 0 to Array.length a - 1 do
 	    Format.fprintf Format.std_formatter
-	      "a.(i)=%b@." (a.(i) != None)
+	      "a.(%i)=%b@." i (a.(i) != None)
 	  done;
 	  assert false
       | `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes
@@ -1106,8 +1108,9 @@ module Compile = struct
     let idx = !idx in
 
     (* Build dispatcher *)
+(*    if Array.length reqs = 0 then print_endline "NOREQ!"; *)
     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 *)
     let result (t,ar,m) =
@@ -1204,7 +1207,7 @@ module Compile = struct
       "make_branches t=%a   #branches=%i@." Types.Print.print t (List.length brs);  *)
     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 state = add_factorized disp rhs in
+    let state = add_factorized disp rhs in 
     state, 
     (Array.map 
        (function Match (n,(_,_,_,e)) -> Match (n,e) | Fail -> Fail) rhs)
@@ -1228,14 +1231,14 @@ module Compile = struct
 
   let dispatch_prod disp pl =
     let t = Types.Product.get disp.t in
-    if t == [] then Impossible else
+    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
+    if t == [] then Impossible else 
     dispatch_prod0 disp t 
       (Array.map (fun p -> Normal.NLineProd.elements p.Normal.nxml) pl)