Commit 6b98ddda authored by Julien Lopez's avatar Julien Lopez
Browse files

[TESTS][LAMBDA] Tests are now in OUnit; better printer for values

parent 5032fcbd
<src>: include
<src/parse*>: pp(camlp4orf.opt), package(camlp4.lib)
<src/compute*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
<src/main*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
<src/main*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str, oUnit)
<src/externals>: include
<src/externals/schema_*>: package(pcre, netcgi2)
......
open OUnit2
open Printf
open Parse
open Value
open Typed
open Types
open Printer
open Camlp4.PreCast
let load_file f =
let ic = open_in f in
let n = in_channel_length ic in
let s = String.create n in
really_input ic s 0 n;
close_in ic;
s
let rec typed_to_string e = "{typ:" ^ (Types.Print.to_string e.Typed.exp_typ)
^ "; descr=" ^ (match e.Typed.exp_descr with
| Typed.Forget(e, _) -> "Forget(" ^ typed_to_string e ^ ")"
| Typed.Check(_, e, _) -> "Check(" ^ typed_to_string e ^ ")"
| 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_to_string e2) ^ ")"
| Typed.Abstraction(abstr) -> "Abstraction(" ^ (abst abstr) ^ ")"
| Typed.Cst(cst) -> const cst
| Typed.Pair(e1, e2) -> "(" ^ (typed_to_string e1) ^ ", "
^ (typed_to_string e2) ^ ")"
| Typed.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
| Typed.Match(e, b) -> "Match(" ^ (typed_to_string e) ^ "," ^ (branches b)
^ ")"
| _ -> 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) ^ ")"
| 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 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) ^ ", branches:"
^ (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) ^ "];\npat:{"
^ (node br.Typed.br_pat) ^ "};\nbody:{typ:"
^ (Types.Print.to_string br.Typed.br_body.Typed.exp_typ) ^ ", descr:"
^ (typed_to_string br.Typed.br_body) ^ "}}"
| 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) ^ "];\npat:{"
^ (node br.Typed.br_pat) ^ "};\nbody:{typ:"
^ (Types.Print.to_string br.Typed.br_body.Typed.exp_typ) ^ ", descr:"
^ (typed_to_string br.Typed.br_body) ^ "}}," ^ (branch rest)
| [] -> ""
and node node = "id:" ^ (string_of_int node.Patterns.id) ^ "; descr:["
^ (descr node.Patterns.descr) ^ "]; accept:[id:"
^ (string_of_int (Types.id node.Patterns.accept)) ^ "; descr:"
^ (Types.Print.to_string (Types.descr node.Patterns.accept)) ^ "]; fv:["
^ (fv_to_string node.Patterns.fv) ^ "]"
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) -> "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
| (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 vloc_to_string vloc = match vloc with
| Lambda.Local(i) -> "Local(" ^ (string_of_int i) ^ ")"
| Lambda.Env(i) -> "Env(" ^ (string_of_int i) ^ ")"
| Lambda.Ext(_, i) -> "Ext(?, " ^ (string_of_int i) ^ ")"
| Lambda.External(_, i) -> "External(?, " ^ (string_of_int i) ^ ")"
| Lambda.Builtin(s) -> "Builtin(" ^ s ^ ")"
| Lambda.Global(i) -> "Global(" ^ (string_of_int i) ^ ")"
| Lambda.Dummy -> "Dummy"
let print_binding key value = match key with
| (id, name) -> Printf.printf "((%d, %s)," (Upool.int id)
(Encodings.Utf8.to_string name); Printf.printf "%s" (vloc_to_string value);
Printf.printf ")\n"
let print_env env = match Ident.Env.is_empty env with
| true -> Printf.printf "<empty>\n"
| false -> Ident.Env.iter print_binding env
let rec print_value v = match v with
| Value.Pair(v1, v2) -> printf "("; print_value v1; printf ", ";
print_value v2; printf ")"
| Xml(_,_,_) -> printf "Xml"
| XmlNs(_,_,_,_) -> printf "XmlNs"
| Record(_) -> printf "Record"
| Atom(_) -> printf "Atom"
| Integer(i) -> printf "%d" (Big_int.int_of_big_int i)
| Char(i) -> printf "Char()"
| Abstraction(_, _) -> printf "Abstraction()"
| Abstract((name, _)) -> printf "Abstract(%s)" name
| String_latin1(i1, i2, s, v) -> printf "String_latin1(%d, %d, %s)" i1 i2 s;
print_value v
| String_utf8(_,_,s,_) -> printf "String(%s)" s
| Concat(v1, v2) -> printf "Concat("; print_value v1; printf ", ";
print_value v2; printf ")"
| Absent -> printf "Absent"
let str, file =
if Array.length Sys.argv > 1 then load_file Sys.argv.(1), Sys.argv.(1)
else (eprintf "Fatal error: No input file\n"; exit 1)
in
let run_test str =
try
let expr = ExprParser.of_string str file in
let expr = Parse.ExprParser.of_string_no_file str in
let env, texpr = Compute.to_typed expr in
(* eprintf "%s\n" (typed_to_string texpr); print_env env.Compile.vars;*)
let evalexpr = Compile.compile_eval_expr env texpr in
print_value evalexpr; printf "\n"
value_to_string evalexpr
with
| Compute.Error -> exit 3
| Loc.Exc_located (loc, exn) ->
......@@ -161,3 +18,65 @@ with
eprintf "File %s, line %d, characters %d-%d:\n" (Loc.file_name loc) l
cbegin cend; raise exn
| e -> eprintf "Runtime error.\n"; raise e
let tests = "CDuce runtime tests" >:::
[
"abstr" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.abstr.simple failed"
~printer:(fun x -> x) "Abstraction((Int, Int))"
(run_test "fun f x : Int : Int -> 2");
);
"apply" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.apply.simple failed"
~printer:(fun x -> x) "2"
(run_test "(fun f x : Int : Int -> x).2");
assert_equal ~msg:"Test CDuce.runtime.apply.simple_pair failed"
~printer:(fun x -> x) "(3, 2)"
(run_test "(fun f x : (Int*Int) : (Int*Int) -> x).(3,2)");
assert_equal ~msg:"Test CDuce.runtime.apply.medium failed"
~printer:(fun x -> x) "(2, 3)"
(run_test "((fun f x : Int y : Int : (Int*Int) -> x,y).2).3");
);
"misc" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.misc.firsts failed"
~printer:(fun x -> x) "Abstraction((Int,Int), X1 -> X1 where X1 = (Int,Int))"
(run_test "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");
assert_equal ~msg:"Test CDuce.runtime.misc.firsts_applied failed"
~printer:(fun x -> x) "(5, 1)"
(run_test "((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)
.(5, 3)).(1, 4)");
);
"match" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.match.simple failed"
~printer:(fun x -> x) "1"
(run_test "match 1 : Int with | 1 -> 1 | \"true\" -> \"true\"");
assert_equal ~msg:"Test CDuce.runtime.match.unused_branches failed"
~printer:(fun x -> x) "1"
(run_test "match 1 : Int with
| s : String -> s | b : Bool -> b | i : Int -> i");
assert_equal ~msg:"Test CDuce.runtime.match.simple_var failed"
~printer:(fun x -> x) "2"
(run_test "(fun f x : Int : Int ->
match x : Int with | y : Int -> x).2");
assert_equal ~msg:"Test CDuce.runtime.match.medium failed"
~printer:(fun x -> x) "2"
(run_test "(fun f x : Int : Int ->
match x : Int with | 1 -> 3 | x : Int -> x).2");
);
"string" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.string.simple failed"
~printer:(fun x -> x) "\"The cake is a lie\""
(run_test "\"The cake is a lie\"");
);
]
let _ = run_test_tt_main tests
......@@ -72,6 +72,7 @@ module ExprParser = struct
END;;
let of_string s file = Gram.parse_string exp_eoi (Loc.mk file) s
let of_string_no_file s = Gram.parse_string exp_eoi Loc.ghost s
end
let get_loc expr = match expr with
......
......@@ -23,6 +23,7 @@ and ptype =
module ExprParser : sig
val of_string : string -> string -> expr
val of_string_no_file : string -> expr
end
val get_loc : expr -> Loc.t
......
open Printf
open Value
let rec typed_to_string e = "{typ:" ^ (Types.Print.to_string e.Typed.exp_typ)
^ "; descr=" ^ (match e.Typed.exp_descr with
| Typed.Forget(e, _) -> "Forget(" ^ typed_to_string e ^ ")"
| Typed.Check(_, e, _) -> "Check(" ^ typed_to_string e ^ ")"
| 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_to_string e2) ^ ")"
| Typed.Abstraction(abstr) -> "Abstraction(" ^ (abst abstr) ^ ")"
| Typed.Cst(cst) -> const cst
| Typed.Pair(e1, e2) -> "(" ^ (typed_to_string e1) ^ ", "
^ (typed_to_string e2) ^ ")"
| Typed.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
| Typed.Match(e, b) -> "Match(" ^ (typed_to_string e) ^ "," ^ (branches b)
^ ")"
| _ -> 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) ^ ")"
| 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 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) ^ ", branches:"
^ (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) ^ "];\npat:{"
^ (node br.Typed.br_pat) ^ "};\nbody:{typ:"
^ (Types.Print.to_string br.Typed.br_body.Typed.exp_typ) ^ ", descr:"
^ (typed_to_string br.Typed.br_body) ^ "}}"
| 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) ^ "];\npat:{"
^ (node br.Typed.br_pat) ^ "};\nbody:{typ:"
^ (Types.Print.to_string br.Typed.br_body.Typed.exp_typ) ^ ", descr:"
^ (typed_to_string br.Typed.br_body) ^ "}}," ^ (branch rest)
| [] -> ""
and node node = "id:" ^ (string_of_int node.Patterns.id) ^ "; descr:["
^ (descr node.Patterns.descr) ^ "]; accept:[id:"
^ (string_of_int (Types.id node.Patterns.accept)) ^ "; descr:"
^ (Types.Print.to_string (Types.descr node.Patterns.accept)) ^ "]; fv:["
^ (fv_to_string node.Patterns.fv) ^ "]"
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) -> "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
| (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 vloc_to_string vloc = match vloc with
| Lambda.Local(i) -> "Local(" ^ (string_of_int i) ^ ")"
| Lambda.Env(i) -> "Env(" ^ (string_of_int i) ^ ")"
| Lambda.Ext(_, i) -> "Ext(?, " ^ (string_of_int i) ^ ")"
| Lambda.External(_, i) -> "External(?, " ^ (string_of_int i) ^ ")"
| Lambda.Builtin(s) -> "Builtin(" ^ s ^ ")"
| Lambda.Global(i) -> "Global(" ^ (string_of_int i) ^ ")"
| Lambda.Dummy -> "Dummy"
let print_binding key value = match key with
| (id, name) -> Printf.printf "((%d, %s)," (Upool.int id)
(Encodings.Utf8.to_string name); Printf.printf "%s" (vloc_to_string value);
Printf.printf ")\n"
let print_env env = match Ident.Env.is_empty env with
| true -> Printf.printf "<empty>\n"
| false -> Ident.Env.iter print_binding env
let rec print_value v = match v with
| Value.Pair(v1, v2) -> printf "("; print_value v1; printf ", ";
print_value v2; printf ")"
| Xml(_,_,_) -> printf "Xml"
| XmlNs(_,_,_,_) -> printf "XmlNs"
| Record(_) -> printf "Record"
| Atom(_) -> printf "Atom"
| Integer(i) -> printf "%d" (Big_int.int_of_big_int i)
| Char(i) -> printf "Char()"
| Abstraction(_, _) -> printf "Abstraction()"
| Abstract((name, _)) -> printf "Abstract(%s)" name
| String_latin1(i1, i2, s, v) -> printf "String_latin1(%d, %d, %s)" i1 i2 s;
print_value v
| String_utf8(_,_,s,_) -> printf "String(%s)" s
| Concat(v1, v2) -> printf "Concat("; print_value v1; printf ", ";
print_value v2; printf ")"
| Absent -> printf "Absent"
let rec value_to_string v = match v with
| Value.Pair(v1, v2) -> "(" ^ (value_to_string v1) ^ ", "
^ (value_to_string v2) ^ ")"
| Xml(_,_,_) -> "Xml"
| XmlNs(_,_,_,_) -> "XmlNs"
| Record(_) -> "Record"
| Atom(_) -> "Atom"
| Integer(i) -> string_of_int (Big_int.int_of_big_int i)
| Char(i) -> "Char()"
| Abstraction(t, _) ->
let t = match t with | Some t -> iface t | None -> "None" in
"Abstraction(" ^ t ^ ")"
| Abstract((name, _)) -> "Abstract(" ^ name ^ ")"
| String_latin1(_,_,s,_) -> "\"" ^ s ^ "\""
| String_utf8(_,_,s,_) -> "\"" ^ s ^ "\""
| Concat(v1, v2) -> "Concat(" ^ (value_to_string v1) ^ ", "
^ (value_to_string v2) ^ ")"
| Absent -> "Absent"
val typed_to_string : Typed.texpr -> string
val print_env : Lambda.var_loc Ident.Env.t -> unit
val print_value : Value.t -> unit
val value_to_string : Value.t -> string
File ./tests/eval/tests/match_error_simple.test, line 1, characters 6-7:
Unbound identifier x
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