Commit ab10beba authored by Julien Lopez's avatar Julien Lopez
Browse files

[TESTS][LAMBDA] Add printer for typed ast; add test on match (fail because it

	has more than one used branches)
parent 96a91969
......@@ -2,6 +2,8 @@ open Parse
open Typed
open Compile
open Camlp4.PreCast
open Types
open Big_int
(* Gives a unique id for a name *)
module Locals = Map.Make(String)
......@@ -22,7 +24,7 @@ let rec _to_typed env l expr =
let _, _, e2 = _to_typed env l e2 in
env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Apply(e1, e2) }
| Abstr (_, fun_name, params, return_type, body) ->
parse_abstr env l loc fun_name params return_type body
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
let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=b } in
......@@ -55,22 +57,30 @@ and parse_abstr env l loc fun_name params return_type body =
let rec _parse_abstr env l fv loc fun_name params return_type body nb =
let brloc = caml_loc_to_cduce (get_loc body) in
let empty, env, l, nfv, iface, rest = parse_iface env l params [] nb [] in
let node = Patterns.make (fv @ nfv) in
let node = make_node (fv @ nfv) nfv in
let body = if empty
then let _, _, body = _to_typed env l body in body
else let _, _, body = _parse_abstr env l (fv @ nfv) loc fun_name rest
else let _, _, body = _parse_abstr env l (fv @ nfv) loc None rest
return_type body (nb + 1) in body
in
let br = { br_loc=brloc; br_used=true; br_ghost=false;
br_vars_empty=[]; br_pat=node; br_body=body } in
let brs = { br_typ=Types.empty; br_accept=Types.empty;
br_branches=[br] } in
let abstr = { fun_name=Some (0, fun_name); fun_iface=iface; fun_body=brs;
let b = { br_loc=brloc; br_used=true; br_ghost=false; br_vars_empty=[];
br_pat=node; br_body=body } in
let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=[b] } in
let abstr = { fun_name=fun_name; fun_iface=iface; fun_body=brs;
fun_typ=Types.empty; fun_fv=[] } in
env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Abstraction(abstr) }
in
_parse_abstr env l [] loc fun_name params return_type body 0
and make_node fv nfv =
let d = (match nfv with
| el :: rest -> Patterns.Capture(el)
| [] -> Patterns.Dummy)
in
incr Patterns.counter;
{ Patterns.id=(!Patterns.counter); Patterns.descr=(Types.empty, fv, d);
Patterns.accept=(Types.make ()); Patterns.fv=fv }
and parse_iface env l params fv nb iface = match params with
| (_, pname, _) :: [] -> true, env, (Locals.add pname nb l),
(fv @ [nb, pname]), (iface @ [Types.empty, Types.empty]), []
......@@ -81,7 +91,7 @@ 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 list, br_locals, br_used = parse_match_value env l [] p toptype in
let t, 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
......@@ -91,20 +101,30 @@ 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; Patterns.make [])
else Patterns.make list) in
fname line cbegin cend; make_patterns [] t)
else make_patterns list t) 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;
{ Patterns.id=(!Patterns.counter);
Patterns.descr=(Types.empty,Ident.IdSet.empty,pattype);
Patterns.accept=(Types.make()); fv=fv }
and parse_match_value env l list p toptype = match p with
| MPair (_) -> list, l, false; (* TODO: Allow pairs in types *)
| MPair (_) -> Patterns.Dummy, list, l, false;
(* TODO: Allow pairs in types *)
| MVar (_, mname, mtype) ->
let lsize = Locals.cardinal l in
(list @ [lsize, mname]), Locals.add mname lsize l, is_subtype toptype mtype
| MInt (_) -> list, l, is_subtype toptype "Int"
| MString (_) -> list, l, is_subtype toptype "String"
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 to_typed expr =
let env, _, expr = _to_typed empty_toplevel Locals.empty expr in
......
open Printf
open Parse
open Value
open Typed
open Types
open Camlp4.PreCast
let load_file f =
......@@ -11,6 +13,81 @@ let load_file f =
close_in ic;
s
let rec typed_to_string e = match e with
| Typed.Forget(e, _) -> "Forget(" ^ typed_to_string e.Typed.exp_descr ^ ")"
| Typed.Check(_, e, _) -> "Check(" ^ typed_to_string e.Typed.exp_descr ^ ")"
| Typed.Var(id, name) -> "Var(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ ")"
| Typed.ExtVar(_, (id, name), _) -> "ExtVar("
^ (string_of_int (Upool.int id)) ^ ", " ^ (Encodings.Utf8.to_string name)
^ ")"
| Typed.Apply(e1, e2) -> "(" ^ typed_to_string e1.Typed.exp_descr ^ ").("
^ (typed_to_string e2.Typed.exp_descr) ^ ")"
| Typed.Abstraction(abstr) -> "Abstraction(" ^ (abst abstr) ^ ")"
| Typed.Cst(cst) -> const cst
| 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) ^ ")"
| _ -> assert false
and const cst = match cst with
| Types.Integer(i) -> "Integer(" ^ (Intervals.V.to_string i) ^ ")"
| Types.Atom(a) -> "Atom(" ^ (Atoms.V.to_string a) ^ ")"
| Types.Char(c) -> "Char(" ^ (string_of_int (Chars.V.to_int c)) ^ ")"
| Types.Pair(c1, c2) -> "(" ^ const c1 ^ ", " ^ const c2 ^ ")"
| Types.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
| _ -> assert false
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:["
^ (fv_to_string abstr.Typed.fun_fv) ^ "]"
and branches brs = match brs with
| br :: [] -> "{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:"
^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}"
| br :: rest -> "{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:"
^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}, "
^ (branches rest)
| [] -> ""
and node node = "id:" ^ (string_of_int node.Patterns.id) ^ "; descr:["
^ (descr node.Patterns.descr) ^ "]; fv:[" ^ (fv_to_string node.Patterns.fv)
^ "]"
and descr (t, fv, d) = "<type>; [" ^ (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.Dummy -> "Dummy"
and fv_to_string fv = match fv with
| (id, name) :: [] -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ ")"
| (id, name) :: rest -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ "), " ^ (fv_to_string rest)
| [] -> ""
let rec print_value v = match v with
| Value.Pair(v1, v2) -> printf "("; print_value v1; printf ", ";
print_value v2; printf ")"
......@@ -36,6 +113,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);*)
let evalexpr = Compile.compile_eval_expr env texpr in
print_value evalexpr; printf "\n"
with
......
(fun f x : Int : Int -> match x : Int with | 1 -> 0 | x : Int -> x).1
match 1 : Int with | 1 -> 1 | 2 -> 2
match 1 : Int with | 1 -> 1 | "true" -> "true"
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