Commit 8c96ed41 authored by Pietro Abate's avatar Pietro Abate

Add Env debugging printers to eval

update .ocamlinit with parse_expr
parent 555e7a7f
......@@ -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
;;
......@@ -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')
......
......@@ -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;
......
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