Commit 632727ee authored by Julien Lopez's avatar Julien Lopez
Browse files

[TESTS][LAMBDA] Few fixes; improved printer

parent 5d94bf3f
......@@ -13,7 +13,12 @@ exception Error
(* TODO: We will need a much better representation of types and a much better
function when we'll add union types and polymorphism. *)
let is_subtype t1 t2 = if String.compare t1 t2 = 0 then true else false
let is_subtype _ _ = true
(*t1 t2 = if String.compare t1 t2 = 0 then true else false*)
let type_of_string s = match s with
| "Int" -> interval [Intervals.Any]
| _ -> Types.empty
let rec _to_typed env l expr =
(* From Camlp4 locations to CDuce locations *)
......@@ -27,6 +32,7 @@ let rec _to_typed env l expr =
parse_abstr env l loc (Some(0, fun_name)) params return_type body
| Match (_, e, t, b) ->
let b = parse_branches env l t b [] in
(* TODO: Fix br_typ *)
let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=b } in
let _, _, exp_descr = _to_typed env l e in
env, l, { exp_loc=loc; exp_typ=Types.empty;
......@@ -78,7 +84,7 @@ and make_node fv nfv =
| [] -> Patterns.Dummy)
in
incr Patterns.counter;
{ Patterns.id=(!Patterns.counter); Patterns.descr=(Types.empty, fv, d);
{ Patterns.id=(!Patterns.counter); Patterns.descr=(Types.any, fv, d);
Patterns.accept=(Types.make ()); Patterns.fv=fv }
and parse_iface env l params fv nb iface = match params with
......@@ -91,7 +97,8 @@ and parse_iface env l params fv nb iface = match params with
and parse_branches env l toptype brs res = match brs with
| (loc, p, e) :: rest ->
let brloc = caml_loc_to_cduce loc in
let t, list, br_locals, br_used = parse_match_value env l [] p toptype in
let t, d, list, br_locals, br_used =
parse_match_value env l [] p toptype in
let line = Loc.start_line loc in
let cbegin = Loc.start_off loc - Loc.start_bol loc in
let cend = Loc.stop_off loc - Loc.start_bol loc in
......@@ -101,30 +108,36 @@ and parse_branches env l toptype brs res = match brs with
(if not br_used then
(Printf.eprintf
"File %s, line %d, characters %d-%d:\nWarning: This branch is not used\n"
fname line cbegin cend; make_patterns [] t)
else make_patterns list t) in
fname line cbegin cend; make_patterns t [] d)
else make_patterns t list d) in
let b = { br_loc=brloc; br_used=br_used; br_ghost=false; br_vars_empty=[];
br_pat=node; br_body=br_body} in
parse_branches env l toptype rest (res @ [b])
| [] -> res
and make_patterns fv pattype = incr Patterns.counter;
and make_patterns t fv d = incr Patterns.counter;
{ Patterns.id=(!Patterns.counter);
Patterns.descr=(Types.empty,Ident.IdSet.empty,pattype);
Patterns.descr=(t, fv, d);
Patterns.accept=(Types.make()); fv=fv }
and parse_match_value env l list p toptype = match p with
| MPair (_) -> Patterns.Dummy, list, l, false;
(* TODO: Allow pairs in types *)
| MPair (_) -> Types.empty, Patterns.Dummy, list, l, false;
| MVar (_, mname, mtype) ->
let lsize = Locals.cardinal l in
Patterns.Dummy, (list @ [lsize, mname]), Locals.add mname lsize l,
is_subtype toptype mtype
| MInt (_, i) -> Patterns.Constr(constant (Integer(big_int_of_int i))), list,
l, is_subtype toptype "Int"
| MString (_, s) -> Patterns.Constr(constant (
String(0,String.length s - 1,s, Integer(big_int_of_int 0)))),
list, l, is_subtype toptype "String"
let l = Locals.add mname lsize l in
let list = list @ [lsize, mname] in
let d1 = Types.any, list, Patterns.Capture(lsize, mname) in
let t2 = type_of_string mtype in
let d2 = t2, [], Patterns.Constr(t2) in
t2, Patterns.Cap(d1, d2), list, l, is_subtype toptype mtype
| MInt (_, i) ->
let t = constant (Integer(big_int_of_int i)) in
t, Patterns.Constr(t), list, l, is_subtype toptype "Int"
| MString (_, s) ->
let t = constant (String(0, String.length s - 1, s,
Integer(big_int_of_int 0))) in
t, Patterns.Constr(t), list, l, is_subtype toptype "String"
let to_typed expr =
let env, _, expr = _to_typed empty_toplevel Locals.empty expr in
......
......@@ -28,8 +28,8 @@ let rec typed_to_string e = match e with
| Typed.Pair(e1, e2) -> "(" ^ (typed_to_string e1.Typed.exp_descr) ^ ", " ^
(typed_to_string e2.Typed.exp_descr) ^ ")"
| Typed.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
| Typed.Match(e, b) -> "Match(" ^ (typed_to_string e.Typed.exp_descr) ^ ", "
^ (branches b.Typed.br_branches) ^ ")"
| Typed.Match(e, b) -> "Match(" ^ (typed_to_string e.Typed.exp_descr) ^ ","
^ (branches b) ^ ")"
| _ -> assert false
and const cst = match cst with
......@@ -42,43 +42,57 @@ and const cst = match cst with
and abst abstr = (match abstr.Typed.fun_name with
| Some (id, name) -> "name:(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ "), body:["
| None -> "name:<none>, body:[") ^
(branches abstr.Typed.fun_body.Typed.br_branches) ^ "], fv:["
^ (Encodings.Utf8.to_string name)
| None -> "name:<none>") ^ "),\niface:[" ^ (iface abstr.Typed.fun_iface)
^ "]\nbody:[" ^ (branches abstr.Typed.fun_body) ^ "], "
^ "typ:" ^ (Types.Print.to_string abstr.Typed.fun_typ) ^ ", fv:["
^ (fv_to_string abstr.Typed.fun_fv) ^ "]"
and branches brs = match brs with
| br :: [] -> "{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
and iface list = match list with
| (t1, t2) :: [] -> "(" ^ (Types.Print.to_string t1) ^ ", "
^ (Types.Print.to_string t2) ^ ")"
| (t1, t2) :: rest -> "(" ^ (Types.Print.to_string t1) ^ ", "
^ (Types.Print.to_string t2) ^ "),"
| [] -> ""
and branches brs = "typ:" ^ (Types.Print.to_string brs.Typed.br_typ)
^ ", accept:" ^ (Types.Print.to_string brs.Typed.br_accept)
^ (branch brs.Typed.br_branches)
and branch brs = match brs with
| br :: [] -> "\n{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
^ (fv_to_string br.Typed.br_vars_empty) ^ "]; pat:{"
^ (node br.Typed.br_pat) ^ "}; body:"
^ (fv_to_string br.Typed.br_vars_empty) ^ "];\npat:{"
^ (node br.Typed.br_pat) ^ "};\nbody:"
^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}"
| br :: rest -> "{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
| br :: rest -> "\n{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
^ (fv_to_string br.Typed.br_vars_empty) ^ "]; pat:{"
^ (node br.Typed.br_pat) ^ "}; body:"
^ (fv_to_string br.Typed.br_vars_empty) ^ "];\npat:{"
^ (node br.Typed.br_pat) ^ "};\nbody:"
^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}, "
^ (branches rest)
^ (branch rest)
| [] -> ""
and node node = "id:" ^ (string_of_int node.Patterns.id) ^ "; descr:["
^ (descr node.Patterns.descr) ^ "]; fv:[" ^ (fv_to_string node.Patterns.fv)
^ "]"
^ (descr node.Patterns.descr) ^ "]; fv:["
^ (fv_to_string node.Patterns.fv) ^ "]"
and descr (t, fv, d) = "<type>; [" ^ (fv_to_string fv) ^ "]; " ^ descr2 d
and descr (t, fv, d) = (Types.Print.to_string t)
^ "; [" ^ (fv_to_string fv) ^ "]; " ^ descr2 d
and descr2 d = match d with
| Patterns.Constr(t) -> "<type>"
| Patterns.Cup(d1, d2) -> "Cup(" ^ (descr d1) ^ ", " ^ (descr d2) ^ ")"
| Patterns.Cap(d1, d2) -> "Cap(" ^ (descr d1) ^ ", " ^ (descr d2) ^ ")"
| Patterns.Times(n1, n2) -> "Times(" ^ (node n1) ^ ", " ^ (node n2) ^ ")"
| Patterns.Xml(n1, n2) -> "Xml(" ^ (node n1) ^ ", " ^ (node n2) ^ ")"
| Patterns.Record(l, n) -> "Record(" ^ (Ns.Label.string_of_tag l) ^ ", "
^ (node n) ^ ")"
| Patterns.Capture((id, name)) -> "Capture(" ^ "<id>, "
^ (Encodings.Utf8.to_string name) ^ ")"
| Patterns.Constant((id, name), ct) -> "Constant((" ^ "<id>, "
^ (Encodings.Utf8.to_string name) ^ "), " ^ const ct ^ ")"
| Patterns.Constr(t) -> "Constr(" ^ (Types.Print.to_string t) ^ ")"
| Patterns.Cup(d1, d2) -> "Cup([" ^ (descr d1) ^ "], [" ^ (descr d2) ^ "])"
| Patterns.Cap(d1, d2) -> "Cap([" ^ (descr d1) ^ "], [" ^ (descr d2) ^ "])"
| Patterns.Times(n1, n2) -> "Times({" ^ (node n1) ^ "}, {" ^ (node n2) ^ "})"
| Patterns.Xml(n1, n2) -> "Xml({" ^ (node n1) ^ "}, {" ^ (node n2) ^ "})"
| Patterns.Record(l, n) -> "Record(" ^ (Ns.Label.string_of_tag l) ^ ", {"
^ (node n) ^ "})"
| Patterns.Capture((id, name)) -> "Capture(" ^ (string_of_int (Upool.int id))
^ ", " ^ (Encodings.Utf8.to_string name) ^ ")"
| Patterns.Constant((id, name), ct) -> "Constant(("
^ (string_of_int (Upool.int id)) ^ ", " ^ (Encodings.Utf8.to_string name)
^ "), " ^ const ct ^ ")"
| Patterns.Dummy -> "Dummy"
and fv_to_string fv = match fv with
......@@ -113,7 +127,7 @@ in
try
let expr = ExprParser.of_string str file in
let env, texpr = Compute.to_typed expr in
(* printf "%s\n" (typed_to_string texpr.exp_descr);*)
eprintf "%s\n" (typed_to_string texpr.exp_descr);
let evalexpr = Compile.compile_eval_expr env texpr in
print_value evalexpr; printf "\n"
with
......
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