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

[TESTS][LAMBDA] All info on types filled in ast

parent eeec8fa2
......@@ -20,11 +20,14 @@ let rec _to_typed env l expr =
match expr with
| Subst (_, e, s) ->
let _, _, e = _to_typed env l e in
(env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=(Subst (e, make_sigma s)) })
env, l, { exp_loc=loc; exp_typ=e.exp_typ;
exp_descr=(Subst (e, make_sigma s)) }
| Apply (_, e1, e2) ->
let _, _, e1 = _to_typed env l e1 in
let _, _, e2 = _to_typed env l e2 in
env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Apply(e1, e2) }
env, l, { exp_loc=loc;
exp_typ=(Types.Arrow.apply (Types.Arrow.get e1.exp_typ) e2.exp_typ);
exp_descr=Apply(e1, e2) }
| Abstr (_, fun_name, params, rtype, body) ->
parse_abstr env l [] loc (Some(0, fun_name)) params rtype body
| Match (_, e, t, b) ->
......@@ -32,15 +35,18 @@ let rec _to_typed env l expr =
let t = type_of_ptype t in
let brs = { br_typ=t; br_accept=t; br_branches=b } in
let _, _, exp_descr = _to_typed env l e in
(env, l, { exp_loc=loc; exp_typ=t; exp_descr=Match(exp_descr, brs) })
env, l, { exp_loc=loc; exp_typ=exp_descr.exp_typ;
exp_descr=Match(exp_descr, brs) }
| Pair (_, e1, e2) ->
let _, _, exp_descr1 = _to_typed env l e1 in
let _, _, exp_descr2 = _to_typed env l e2 in
(env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Pair(exp_descr1, exp_descr2) })
let _, _, e1 = _to_typed env l e1 in
let _, _, e2 = _to_typed env l e2 in
let t = Types.times (Types.cons e1.exp_typ) (Types.cons e2.exp_typ) in
env, l, { exp_loc=loc; exp_typ=t; exp_descr=Pair(e1, e2) }
| Var (origloc, vname) ->
if vname = "`nil" then
let nil_atom = Atoms.V.mk_ascii "nil" in
env, l, { exp_loc=loc; exp_typ=(Types.atom (Atoms.atom nil_atom)); exp_descr=(Cst (Types.Atom nil_atom)) }
env, l, { exp_loc=loc; exp_typ=(Types.atom (Atoms.atom nil_atom));
exp_descr=(Cst (Types.Atom nil_atom)) }
else
let line = Loc.start_line origloc in
let cbegin = Loc.start_off origloc - Loc.start_bol origloc in
......@@ -55,14 +61,16 @@ let rec _to_typed env l expr =
in env, l, { exp_loc=loc; exp_typ=t; exp_descr=v }
| Int (_, i) ->
let i = Big_int.big_int_of_int i in
(env, l, { exp_loc=loc; exp_typ=(type_of_string "Int"); exp_descr=Cst(Types.Integer i) })
env, l, { exp_loc=loc; exp_typ=(type_of_string "Int");
exp_descr=Cst(Types.Integer i) }
| String (_, s) ->
let i = Big_int.big_int_of_int 0 in
let s = Types.String (0, (String.length s) - 1, s, Types.Integer i) in
(env, l, { exp_loc=loc; exp_typ=(type_of_string "String"); exp_descr=Cst s })
env, l, { exp_loc=loc; exp_typ=(type_of_string "String");
exp_descr=Cst s }
and make_sigma s =
let rec aux acc = function
let rec aux acc = function
| (name, ptype) :: rest ->
aux ([`Var (Var.make_id name), type_of_ptype ptype] :: acc) rest
| [] -> acc
......@@ -72,12 +80,13 @@ and make_sigma s =
and type_of_sigma x s =
let rec aux x acc = function
| [] -> acc
| (id, t2) :: rest when id = x -> aux x (Types.cup acc (type_of_ptype t2)) rest
| (id, t2) :: rest when id = x ->
aux x (Types.cup acc (type_of_ptype t2)) rest
| _ :: rest -> aux x acc rest
in
aux x Types.empty s
and type_of_ptype =
and type_of_ptype =
let open Types in function
| Type(t) -> type_of_string t
| PType(t, s) ->
......@@ -119,12 +128,13 @@ and parse_abstr env l fv loc fun_name params rtype body =
else let env, l, body = _parse_abstr env l (oldfv @ fv) loc None rest
rtype body (nb + 1) in env, l, body
in
let b = { Typed.br_loc=brloc; br_used=true; br_ghost=false; br_vars_empty=[];
br_pat=node; br_body=body } in
let b = { Typed.br_loc=brloc; br_used=true; br_ghost=false;
br_vars_empty=[]; br_pat=node; br_body=body } in
let brs = { Typed.br_typ=rtype; br_accept=Types.any; br_branches=[b] } in
let abstr = { Typed.fun_name=fun_name; fun_iface=iface; fun_body=brs;
fun_typ=fun_typ; fun_fv=oldfv } in
env, l, { Typed.exp_loc=loc; exp_typ=fun_typ; exp_descr=Typed.Abstraction(abstr) }
env, l, { Typed.exp_loc=loc; exp_typ=fun_typ;
exp_descr=Typed.Abstraction(abstr) }
in
_parse_abstr env l fv loc fun_name params (type_of_ptype rtype) body 0
......@@ -160,31 +170,31 @@ and parse_branches env l toptype acc = function
let _, _, br_body = _to_typed env br_locals e in
let fname = Loc.file_name loc in
let tpat =
if not br_used then begin
Printf.eprintf
if not br_used then begin
Printf.eprintf
"File %s, line %d, characters %d-%d:\nWarning: This branch is not used\n"
fname line cbegin cend;
fname line cbegin cend;
make_patterns t [] d
end else
end else
make_patterns t fv d
in
let b = {
Typed.br_loc = caml_loc_to_cduce loc;
br_used = br_used;
br_ghost = false;
br_vars_empty = [];
br_pat = tpat;
let b = {
Typed.br_loc = caml_loc_to_cduce loc;
br_used = br_used;
br_ghost = false;
br_vars_empty = [];
br_pat = tpat;
br_body = br_body}
in
parse_branches env l toptype (acc @ [b]) rest
| [] -> acc
and make_patterns t fv d =
and make_patterns t fv d =
incr Patterns.counter;
{ Patterns.id=(!Patterns.counter);
descr=(t, fv, d);
accept=(Types.cons t);
fv=fv
accept=(Types.cons t);
fv=fv
}
and parse_match_value env l list toptype = function
......@@ -208,13 +218,16 @@ and parse_match_value env l list toptype = function
(t2, Patterns.Cap(d1, d2), list, l, is_subtype)
| MInt (_, i) ->
let t = Types.constant (Types.Integer(Big_int.big_int_of_int i)) in
let is_subtype = Types.subtype (type_of_string "Int") (type_of_ptype toptype) in
let is_subtype = Types.subtype (type_of_string "Int")
(type_of_ptype toptype) in
(t, Patterns.Constr(t), list, l, is_subtype)
| MString (_, s) ->
let t = Types.constant (Types.String(0, String.length s - 1, s, Types.Integer(Big_int.big_int_of_int 0))) in
let is_subtype = Types.subtype (type_of_string "String") (type_of_ptype toptype) in
let zero = Types.Integer(Big_int.big_int_of_int 0) in
let t = Types.constant (Types.String(0, String.length s - 1, s, zero)) in
let is_subtype = Types.subtype (type_of_string "String")
(type_of_ptype toptype) in
(t, Patterns.Constr(t), list, l, is_subtype)
let to_typed expr =
let env, l, expr = _to_typed Compile.empty_toplevel Locals.empty expr in
let env, _, expr = _to_typed Compile.empty_toplevel Locals.empty expr in
env, expr
......@@ -2,7 +2,7 @@ open OUnit2
open Camlp4.PreCast
(* Typed -> Lamda *)
let run_test_compile expected totest =
let run_test_compile msg expected totest =
let aux str =
try
let expr = Parse.ExprParser.of_string_no_file str in
......@@ -19,16 +19,20 @@ let run_test_compile expected totest =
cbegin cend; raise exn
| e -> Printf.eprintf "Runtime error.\n"; raise e
in
fun _ -> assert_equal ~printer:(fun x -> x) expected (aux totest)
fun _ -> assert_equal ~msg:msg ~printer:(fun x -> x) expected (aux totest)
let tests_poly_abstr = [
"Abstraction(Dummy,,,,Sel(,(Int -> Int),{}))","fun f x : Int : Int -> 2";
"Test CDuce.lambda.const_abstr failed",
"Abstraction(Dummy,,,,Sel(,(Int -> Int),{}))",
"fun f x : Int : Int -> 2";
"Test CDuce.lambda.poly.identity failed",
"Abstraction(Dummy,,,,Sel(,([ Char* ] | Int -> [ Char* ] | Int),Comp({},{ { (`$A/
[ Char* ]) } ,{ (`$A/Int) } })))", "(fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x) {A/Int;A/String}";
[ Char* ]) } ,{ (`$A/Int) } })))",
"(fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x) {A/Int;A/String}";
]
let tests_compile = "CDuce compile tests (Typed -> Lambda )" >:::
List.map (fun (e,f) -> f >:: run_test_compile e f) tests_poly_abstr
let tests_compile = "CDuce compile tests (Typed -> Lambda )" >:::
List.map (fun (m,e,f) -> f >:: run_test_compile m e f) tests_poly_abstr
(* Typed -> Lambda -> Value *)
let run_test_eval str =
......@@ -178,7 +182,7 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
"Abstraction((`$A & Int | Char | Atom | (Any,Any) | <(Any) (Any)>Any | \
Arrow, `$A & Int | Char | Atom | (Any,Any) | <(Any) (Any)>Any | Arrow),{})"
(run_test_eval "fun f x : 'A{} : 'A{} -> x");
(* assert_equal ~msg:"Test CDuce.runtime.poly.identity failed"
assert_equal ~msg:"Test CDuce.runtime.poly.identity failed"
~printer:(fun x -> x)
"Abstraction(([ Char* ] | Int, [ Char* ] | Int),{})"
(run_test_eval "(fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x)
......@@ -201,7 +205,7 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
~printer:(fun x -> x) "(7, (8, 5, {}), {})"
(run_test_eval "(fun tail x : ['A{}] : ['A{}] -> match x : ['A{}] with
| (el : 'A{}) :: (rest : ['A{}]) -> rest).[3; 7; 8; 5]");
*)
);
]
......
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