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

[TESTS][LAMBDA] Add info on types in ast

parent fb31f5f4
......@@ -45,13 +45,14 @@ let rec _to_typed env l expr =
let line = Loc.start_line origloc in
let cbegin = Loc.start_off origloc - Loc.start_bol origloc in
let cend = Loc.stop_off origloc - Loc.start_bol origloc in
let index = (try Locals.find vname l with Not_found -> Printf.eprintf
"File %s, line %d, characters %d-%d:\nUnbound identifier %s\n"
let index, vtype = (try Locals.find vname l with Not_found ->
Printf.eprintf
"File %s, line %d, characters %d-%d:\nUnbound identifier %s\n"
(Loc.file_name origloc) line cbegin cend vname; raise Error)
in
let t = (* Ident.Env.find index env.Compile.gamma *) Types.any in
let v = if Types.no_var t then Var(index, vname) else TVar(index, vname) in
(env, l, { exp_loc=loc; exp_typ=t; exp_descr=v })
let t = (* Ident.Env.find index env.Compile.gamma *) vtype in
let v = if Types.no_var t then Var(index, vname) else TVar(index, vname)
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) })
......@@ -112,7 +113,7 @@ and parse_abstr env l fv loc fun_name params rtype body =
let node = make_node fv in
let l = (match fun_name with
| None -> l
| Some (id, name) -> Locals.add name id l) in
| Some (id, name) -> Locals.add name (id,fun_typ) l) in
let env, l, body = if empty
then let _, _, body = _to_typed env l body in env, l, body
else let env, l, body = _parse_abstr env l (oldfv @ fv) loc None rest
......@@ -123,7 +124,7 @@ and parse_abstr env l fv loc fun_name params rtype body =
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=Types.any; 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
......@@ -135,11 +136,14 @@ and make_node fv =
make_patterns Types.any fv d
and parse_iface env l params fv nb iface rtype = match params with
| (_, pname, ptype) :: [] -> true, env, (Locals.add pname nb l),
(fv @ [nb, pname]), (iface @ [type_of_ptype ptype, rtype]), []
| (_, pname, ptype) :: rest -> false, env, (Locals.add pname nb l),
(fv @ [nb, pname]),
(iface @ [type_of_ptype ptype, type_of_iface rest rtype]), rest
| (_, pname, ptype) :: [] ->
let ptype = type_of_ptype ptype in
true, env, (Locals.add pname (nb,ptype) l), (fv @ [nb, pname]),
(iface @ [ptype, rtype]), []
| (_, pname, ptype) :: rest ->
let ptype = type_of_ptype ptype in
false, env, (Locals.add pname (nb,ptype) l), (fv @ [nb, pname]),
(iface @ [ptype, type_of_iface rest rtype]), rest
| [] -> true, env, l, fv, iface, []
and itype acc =
......@@ -195,7 +199,7 @@ and parse_match_value env l list toptype = function
(list1 @ list2), l, b1 && b2;
| MVar (_, mname, mtype) ->
let lsize = Locals.cardinal l in
let l = Locals.add mname lsize l in
let l = Locals.add mname (lsize, type_of_ptype mtype) l in
let list = list @ [lsize, mname] in
let d1 = Types.any, list, Patterns.Capture(lsize, mname) in
let t2 = type_of_ptype mtype in
......
......@@ -22,8 +22,9 @@ let run_test_compile expected totest =
fun _ -> assert_equal ~printer:(fun x -> x) expected (aux totest)
let tests_poly_abstr = [
"Abstraction((Int, Int),{})","fun f x : Int : Int -> 2";
"Abstraction(([ Char* ] | Int, [ Char* ] | Int),{})", "(fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x) {A/Int;A/String}";
"Abstraction(Dummy,,,,Sel(,(Int -> Int),{}))","fun f x : Int : Int -> 2";
"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}";
]
let tests_compile = "CDuce compile tests (Typed -> Lambda )" >:::
......@@ -53,7 +54,8 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
~printer:(fun x -> x) "Abstraction((Int, Int),{})"
(run_test_eval "fun f x : Int : Int -> 2");
assert_equal ~msg:"Test CDuce.runtime.abstr.medium failed"
~printer:(fun x -> x) "Abstraction((Int, [ Char* ] -> [ Int Char* ]),{})"
~printer:(fun x -> x)
"Abstraction((Int, [ Char* ] -> [ Int Char* ]),{})"
(run_test_eval "fun f x : Int y : String : (Int*String) -> x,y");
);
......@@ -71,7 +73,8 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
"misc" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.misc.firsts failed"
~printer:(fun x -> x) "Abstraction(((Int,Int), (Int,Int) -> (Int,Int)),{})"
~printer:(fun x -> x)
"Abstraction(((Int,Int), X1 -> X1 where X1 = (Int,Int)),{})"
(run_test_eval "fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) ->
match x,y : ((Int*Int)*(Int*Int)) with
| (a : Int,_ : Int),(b : Int,_ : Int) -> a,b");
......@@ -175,7 +178,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)
......@@ -184,7 +187,6 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
~printer:(fun x -> x) "2"
(run_test_eval "((fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x)
{A/Int;A/String}).2");
(* TODO: Should have error (?) *)
assert_equal ~msg:"Test CDuce.runtime.poly.identity_applied2 failed"
~printer:(fun x -> x) "2"
(run_test_eval "((fun f x : 'A{A/String} : 'A{A/String} -> x){A/String}).2");
......@@ -199,6 +201,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]");
*)
);
]
......@@ -207,7 +210,7 @@ let _ =
run_test_tt_main (
test_list
[ tests_compile;
(* tests_eval *)
tests_eval
]
)
;;
......
......@@ -55,7 +55,7 @@ and pp_typed_aux ppf e =
| _ -> assert false
and pp_abst ppf abstr =
Format.fprintf ppf "%a,,\niface:[%a],\nbody:[%a], typ:%a, fv:[%a]"
Format.fprintf ppf "%a,\niface:[%a],\nbody:[%a], typ:%a, fv:[%a]"
pp_fun_name abstr.Typed.fun_name
pp_iface abstr.Typed.fun_iface
pp_branches abstr.Typed.fun_body
......
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