[r2005-07-07 08:58:53 by afrisch] Empty log message

Original author: afrisch
Date: 2005-07-07 08:58:53+00:00

compile/auto_pat.ml

@@ -33,7 +33,7 @@ and state = {
   arity : int array;
   mutable actions: actions;
   mutable fail_code: int;
-  mutable expected_type: Types.t
+  mutable expected_type: string;
 }
 
 

compile/auto_pat.mli

@@ -33,7 +33,7 @@ and state = {
   arity : int array;
   mutable actions: actions;
   mutable fail_code: int;
-  mutable expected_type: Types.t
+  mutable expected_type: string;
 }
 
 

runtime/eval.ml

@@ -9,13 +9,6 @@ let ops = Hashtbl.create 13
 let register_op = Hashtbl.add ops
 let eval_op = Hashtbl.find ops
 
-let print_to_string f x =
-  let b = Buffer.create 1024 in
-  let ppf = Format.formatter_of_buffer b in
-  f ppf x;
-  Buffer.contents b
-
-
 (* To write tail-recursive map-like iteration *)
 
 let make_accu () = Value.Pair(nil,Absent)

runtime/explain.ml

@@ -4,21 +4,22 @@ open Auto_pat
 open Encodings
 
 
-type t = (Value.t * Types.t) list
+type t = (Value.t * string) list
 
 let rec print ppf = function
   | [] -> ()
   | (v, t) :: l ->
       print ppf l;
       Format.fprintf ppf 
-	"Value @[%a@] does not match type @[%a@]@."
+	"Value @[%a@] does not match type @[%s@]@."
 	Value.print v
-	Types.Print.print t
+	t
 
 let print_to_string f x =
   let b = Buffer.create 1024 in
   let ppf = Format.formatter_of_buffer b in
   f ppf x;
+  Format.pp_print_flush ppf ();
   Buffer.contents b
 
 let to_string e =
@@ -133,14 +134,6 @@ let explain d v =
   try  check d v; None
   with Failed p -> Some p
 
-
-
-let print_to_string f x =
-  let b = Buffer.create 1024 in
-  let ppf = Format.formatter_of_buffer b in
-  f ppf x;
-  Buffer.contents b
-
 let do_check d v =
   try check d v; v
   with Failed p ->

runtime/explain.mli

-type t = (Value.t * Types.t) list
+type t = (Value.t * string) list
 exception Failed of t
 
 

types/patterns.ml

@@ -978,7 +978,7 @@ module Compile = struct
 	arity = Array.map (fun (_,ar,_) -> ar) codes;
 	actions = dummy_actions;
 	fail_code = (-1);
-	expected_type = Types.empty 
+	expected_type = "";
       } in
       let disp = { 
 	id = !cur_id; 
@@ -1244,10 +1244,12 @@ module Compile = struct
       assert(state.fail_code == fail);
     ) else (
       state.fail_code <- fail;
+      let expect = ref Types.empty in
       Array.iteri
 	(fun i (t,_,_) -> 
-	   if i != fail then state.expected_type <- Types.cup t state.expected_type)
+	   if i != fail then expect := Types.cup t !expect)
 	(Hashtbl.find dispatcher_of_state state.uid).codes;
+      state.expected_type <- Types.Print.to_string !expect;
       prepare_checker_actions fail state.actions
     )
   and prepare_checker_actions fail = function

types/types.ml

@@ -1517,6 +1517,16 @@ struct
   let print_node ppf n = print ppf (descr n)
 
   let () = forward_print := print
+
+  let print_to_string f x =
+    let b = Buffer.create 1024 in
+    let ppf = Format.formatter_of_buffer b in
+    f ppf x;
+    Format.pp_print_flush ppf ();
+    Buffer.contents b
+
+  let to_string t = print_to_string print t
+    
 end
 
 module Positive =

types/types.mli

@@ -272,6 +272,8 @@ sig
 
   (* Don't try to find a global name at toplevel *)
   val print_noname: Format.formatter -> t -> unit
+
+  val to_string: t -> string
 end