Add Env debugging printers to eval

update .ocamlinit with parse_expr

.ocamlinit

@@ -39,4 +39,48 @@ let mk_s ll =
     Tallying.CS.union (mk_prod l) acc1
   ) Tallying.CS.S.empty ll
 
+module BIN = struct
+  open Builtin_defs
 
+  (* Types *)
+
+  let stringn = Types.cons string
+  let namespaces =
+    Sequence.star (Types.times stringn stringn)
+
+  let types =
+    [
+      "Empty",   Types.empty;
+      "Any",     any;
+      "Int",     int;
+      "Char",    Types.char Chars.any;
+      "Byte",    char_latin1;
+      "Atom",    atom;
+      "Pair",    Types.Product.any;
+      "Arrow",   Types.Arrow.any;
+      "Record",  Types.Record.any;
+      "String",  string;
+      "Latin1",  string_latin1;
+      "Bool",    bool;
+      "Float",   float;
+      "AnyXml",  any_xml;
+      "Namespaces", namespaces;
+      "Caml_int", caml_int;
+    ]
+
+  let env =
+    List.fold_left
+      (fun accu (n,t) ->
+         let n = (Ns.empty, Ident.U.mk n) in
+         Types.Print.register_global "" n t;
+         Typer.enter_type (Ident.ident n) t accu
+      )
+      Typer.empty_env
+      types
+end
+
+let parse_expr s =
+  let astexpr = Parser.expr (Stream.of_string s) in
+  let texpr = fst (Typer.type_expr BIN.env astexpr) in
+  texpr
+;;

runtime/eval.ml

@@ -63,11 +63,72 @@ let eval_var env locals = function
 let tag_op_resolved = Obj.tag (Obj.repr (OpResolved ((fun _ -> assert false), [])))
 let tag_const = Obj.tag (Obj.repr (Const (Obj.magic 0)))
 
+(* ------------ Debugging printer *) 
+
+let print_lst f ppf l =
+  let rec aux ppf = function
+    |[] -> Format.fprintf ppf "@."
+    |[h] -> Format.fprintf ppf "%a" f h
+    |h::t -> Format.fprintf ppf "%a,%a" f h aux t
+  in
+  match l with
+  |[] -> Format.fprintf ppf ""
+  |_ -> Format.fprintf ppf "%a" aux l
+
+let rec pp_sigma ppf =
+  let pp_aux ppf =
+    print_lst (fun ppf (t1,t2) ->
+      Format.fprintf ppf "(%a -> %a)"
+      Types.Print.print t1
+      Types.Print.print t2
+    ) ppf
+  in
+  function
+  |Value.List ll -> Types.Tallying.CS.pp_sl ppf ll
+  |Value.Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
+  |Value.Sel(x,iface,s) -> Format.fprintf ppf "Sel(%d,%a,%a)" x pp_aux iface pp_sigma s
+  |Value.Identity -> Format.fprintf ppf "Id"
+
+and pp_value ppf = function
+  | Value.Pair(v1, v2, sigma) ->
+      Format.fprintf ppf "(%a,%a,%a)"
+      pp_value v1
+      pp_value v2
+      pp_sigma sigma
+  | Xml(_,_,_,sigma) -> Format.fprintf ppf "Xml(%a)" pp_sigma sigma
+  | XmlNs(_,_,_,_,sigma) -> Format.fprintf ppf "XmlNs(%a)" pp_sigma sigma
+  | Record(_,sigma) -> Format.fprintf ppf "Record(%a)" pp_sigma sigma
+  | Atom(a) -> Format.fprintf ppf "Atom(%a)" Atoms.V.print a
+  | Integer(i) -> Format.fprintf ppf "%d" (Big_int.int_of_big_int i)
+  | Char(i) -> Format.fprintf ppf "Char()"
+  | Abstraction(None, _, sigma) ->
+      Format.fprintf ppf  "Abstraction(None,%a)" pp_sigma sigma
+  | Abstraction(Some t, _, sigma) ->
+      Format.fprintf ppf  "Abstraction(%a,%a)"
+      pp_iface t
+      pp_sigma sigma
+  | Abstract((name, _)) -> Format.fprintf ppf "Abstract(%s)" name
+  | String_latin1(_,_,s,_) -> Format.fprintf ppf "\"%s\"" s
+  | String_utf8(_,_,s,_) -> Format.fprintf ppf "\"%s\"" s
+  | Concat(v1, v2) ->
+      Format.fprintf ppf "Concat(%a, %a)"
+      pp_value v1
+      pp_value v2
+  | Absent -> Format.fprintf ppf "Absent"
+
+and pp_iface ppf l =
+  let f ppf (t1,t2) =
+    Format.fprintf ppf "(%a,%a)"
+    Types.Print.print t1
+    Types.Print.print t2
+  in
+  print_lst f ppf l
+
 let pp_lambda_env ppf env locals =
   let aux a =
     let l = Array.to_list a in
     let sl = List.mapi (fun i v ->
-      Format.fprintf Format.str_formatter "%d : %a@." i Value.print v;
+      Format.fprintf Format.str_formatter "%d : %a@." i pp_value v;
       Format.flush_str_formatter ()
       ) l 
     in
@@ -75,6 +136,8 @@ let pp_lambda_env ppf env locals =
   in
   Format.fprintf ppf "env = {%s}; locals = {%s}" (aux env) (aux locals)
 
+(* ---------------- *)
+
 let apply_sigma sigma = function
   |Value.Pair(v1,v2,sigma') -> Value.Pair(v1,v2,Value.comp sigma sigma')
   |Value.Abstraction(iface,f,sigma') -> Value.Abstraction(iface,f,Value.comp sigma sigma')

typing/typer.ml

@@ -852,7 +852,6 @@ let flatten arg constr precise =
 
 
 let rec type_check env e constr precise = 
-  Printf.printf "aaaa\n%!";
   let (ed,d) = type_check' e.exp_loc env e.exp_descr constr precise in
   let d = if precise then d else constr in
   e.exp_typ <- Types.cup e.exp_typ d;