Setepenre pushed to branch master at Stefan / Typer

Commits: a6e1dc19 by Pierre Delaunay at 2016-09-20T13:07:36-04:00 Added a new way to make tests for eval using a similar mechanism that what is used for sexp

* src/env.ml - new functions (value_equal) and (value_eq_list) * tests/eval_test.ml - new function (test_eval_eqv) - modified tests to use the new mechanism - added 3 new tests on special forms (decltype) (declexpr) and (has-attribute)

- - - - - 2eb9aeee by Pierre Delaunay at 2016-09-20T16:53:19-04:00 Special forms are macros but conv_p does not recognize them as such (db index problem). I have implemented a temporary work around. - src/lparse.ml

- - - - - 66020e6c by Pierre Delaunay at 2016-09-20T16:53:37-04:00 Merge branch 'master' of gitlab.com:monnier/typer

- - - - -

5 changed files:

- src/builtin.ml - src/env.ml - src/lexp.ml - src/lparse.ml - tests/eval_test.ml

Changes:

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -190,7 +190,8 @@ let make_node loc depth args_val ctx = | [Vsexp(op); lst] -> op, lst | op::_ -> builtin_error loc - ("node_ expects one 'Sexp' got " ^ (value_name op)) in + ("node_ expects one 'Sexp' got " ^ (value_name op)) + | _ -> typer_unreachable "-" in

(* value_print tlist; print_string "\n"; *)

@@ -306,7 +307,10 @@ let get_attribute_impl loc largs ctx ftype = | _ -> builtin_error loc "get-attribute expects two arguments" in

let lxp = get_property ctx (vi, vn) (ai, an) in - let Some ltype = env_lookup_expr ctx ((loc, an), ai) in + let ltype = match env_lookup_expr ctx ((loc, an), ai) with + | Some ltp -> ltp + | None -> builtin_error loc "not expression available" in + lxp, ltype

let new_attribute_impl loc largs ctx ftype = @@ -336,7 +340,9 @@ let declexpr_impl loc largs ctx ftype = | [Var((_, vn), vi)] -> (vi, vn) | _ -> builtin_error loc "declexpr expects one argument" in

- let Some lxp = env_lookup_expr ctx ((loc, vn), vi) in + let lxp = match env_lookup_expr ctx ((loc, vn), vi) with + | Some lxp -> lxp + | None -> builtin_error loc "no expr available" in let ltp = env_lookup_type ctx ((loc, vn), vi) in lxp, ftype

===================================== src/env.ml ===================================== --- a/src/env.ml +++ b/src/env.ml @@ -44,6 +44,8 @@ let env_error loc msg = msg_error "ENV" loc msg; raise (internal_error msg)

+let env_warning loc msg = msg_warning "ENV" loc msg + let str_idx idx = "[" ^ (string_of_int idx) ^ "]"

@@ -62,6 +64,37 @@ type value_type = | Vcommand of (unit -> value_type)

+let rec value_equal a b = + match a, b with + | Vint(i1), Vint(i2) -> i1 = i2 + | Vstring(s1), Vstring(s2) -> s1 = s2 + | Vbuiltin(s1), Vbuiltin(s2) -> s1 = s2 + | Vfloat(f1), Vfloat(f2) -> f1 = f2 + | Vsexp(a), Vsexp(b) -> sexp_equal a b + | Vin (c1), Vin(c2) -> c1 = c2 + | Vout (c1), Vout(c2) -> c2 = c2 + | Vcommand (f1), Vcommand(f2)-> f1 = f2 + | Vdummy, Vdummy -> + env_warning dloc "Vdummy"; true + + | Closure(s1, b1, ctx1), Closure(s2, b2, ctx2) -> + env_warning dloc "Closure"; + if (s1 != s2) then false else true + + | Vcons((_, ct1), a1), Vcons((_, ct2), a2) -> + if (ct1 != ct2) then false else + not (List.exists2 + (fun a b -> not (value_equal a b)) a1 a2) + + | _ -> false + +let rec value_eq_list a b = + match a, b with + | [], [] -> true + | v1::vv1, v2::vv2 -> + value_equal v1 v2 && value_eq_list vv1 vv2 + | _ -> false + let rec value_print (vtp: value_type) = match vtp with | Closure (_, lxp, _) ->

===================================== src/lexp.ml ===================================== --- a/src/lexp.ml +++ b/src/lexp.ml @@ -490,43 +490,43 @@ let lexp_print e = sexp_print (pexp_unparse (lexp_unparse e)) *)

-(* ugly printing (sexp_print (pexp_unparse (lexp_to_pexp e))) *) -let rec lexp_to_pexp lxp = +(* ugly printing (sexp_print (pexp_unparse (lexp_unparse e))) *) +let rec lexp_unparse lxp = match lxp with - | Susp _ as e -> lexp_to_pexp (nosusp e) + | Susp _ as e -> lexp_unparse (nosusp e) | Imm (sexp) -> Pimm (sexp) | Builtin ((loc, name), _) -> Pvar((loc, name)) | Var ((loc, name), _) -> Pvar((loc, name)) | Cons (((iloc, iname), idx), ctor) -> Pcons((iloc, iname), ctor) | Lambda (kind, vdef, ltp, body) -> - Plambda(kind, vdef, Some (lexp_to_pexp ltp), lexp_to_pexp body) + Plambda(kind, vdef, Some (lexp_unparse ltp), lexp_unparse body) | Arrow (arg_kind, vdef, ltp1, loc, ltp2) -> - Parrow(arg_kind, vdef, lexp_to_pexp ltp1, loc, lexp_to_pexp ltp2) + Parrow(arg_kind, vdef, lexp_unparse ltp1, loc, lexp_unparse ltp2)

| Let (loc, ldecls, body) -> (* (vdef * lexp * ltype) list *) let pdecls = List.fold_left (fun acc (vdef, lxp, ltp) -> - Ptype(vdef, lexp_to_pexp ltp)::Pexpr(vdef, lexp_to_pexp lxp)::acc) [] ldecls in - Plet (loc, pdecls, lexp_to_pexp body) + Ptype(vdef, lexp_unparse ltp)::Pexpr(vdef, lexp_unparse lxp)::acc) [] ldecls in + Plet (loc, pdecls, lexp_unparse body)

| Call(lxp, largs) -> (* (arg_kind * lexp) list *) - let pargs = List.map (fun (kind, elem) -> lexp_to_pexp elem) largs in + let pargs = List.map (fun (kind, elem) -> lexp_unparse elem) largs in let sargs = List.map (fun elem -> pexp_unparse elem) pargs in - Pcall(lexp_to_pexp lxp, sargs) + Pcall(lexp_unparse lxp, sargs)

| Inductive(loc, label, lfargs, ctor) -> (* (arg_kind * vdef * ltype) list *) (* (arg_kind * pvar * pexp option) list *) let pfargs = List.map (fun (kind, vdef, ltp) -> - (kind, vdef, Some (lexp_to_pexp ltp))) lfargs in + (kind, vdef, Some (lexp_unparse ltp))) lfargs in

(* ((arg_kind * vdef option * ltype) list) SMap.t *) (* (symbol * (arg_kind * pvar option * pexp) list) list *) let ctor = List.map (fun (str, largs) -> let pargs = List.map (fun (kind, var, ltp) -> match var with - | Some (loc, name) -> (kind, Some (loc, name), lexp_to_pexp ltp) - | None -> (kind, None, lexp_to_pexp ltp)) largs + | Some (loc, name) -> (kind, Some (loc, name), lexp_unparse ltp) + | None -> (kind, None, lexp_unparse ltp)) largs in ((loc, str), pargs) ) (SMap.bindings ctor) in Pinductive(label, pfargs, ctor) @@ -534,25 +534,25 @@ let rec lexp_to_pexp lxp = | Case (loc, target, tltp, bltp, branches, default) -> let pbranch = List.map (fun (str, (loc, args, bch)) -> match args with - | [] -> Ppatvar (loc, str), lexp_to_pexp bch + | [] -> Ppatvar (loc, str), lexp_unparse bch | _ -> let pat_args = List.map (fun (kind, vdef) -> match vdef with | Some vdef -> Some (kind, vdef), Ppatvar(vdef) | None -> None, Ppatany(loc)) args - in Ppatcons ((loc, str), pat_args), lexp_to_pexp bch + in Ppatcons ((loc, str), pat_args), lexp_unparse bch ) (SMap.bindings branches) in

let pbranch = match default with - | Some dft -> (Ppatany(loc), lexp_to_pexp dft)::pbranch + | Some dft -> (Ppatany(loc), lexp_unparse dft)::pbranch | None -> pbranch - in Pcase (loc, lexp_to_pexp target, pbranch) + in Pcase (loc, lexp_unparse target, pbranch)

(* | SortLevel of sort_level | Sort of U.location * sort *)

- | _ as e -> Pimm (String(lexp_location e, "Type")) + | _ as e -> Pimm (Symbol(lexp_location e, "Type"))

(* @@ -577,7 +577,7 @@ let debug_ppctx = ref (false, 0, true, true , false, 4, true) let rec lexp_print e = _lexp_print (!debug_ppctx) e and _lexp_print ctx e = print_string (_lexp_to_str ctx e)

-(*) +(* type print_context2 = int SMap.t

let default_print_context =

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -516,8 +516,14 @@ and lexp_call (func: pexp) (sargs: sexp list) ctx i =

(* determine function type *) match func, ltp with - (* FIXME: this branch is never used because of missing shift somewhere *) - (* while special form have a type macro this does not recognize them as such *) + (* This is a work around for the bug described below *) + | Pvar(l, name), _ when is_builtin_macro name -> + let pargs = List.map pexp_parse sargs in + let largs = _lexp_parse_all pargs ctx i in + (get_macro_impl loc name) loc largs ctx ltp + + (* FIXME: the branch 'builtin macro' is never used because of missing shift somewhere *) + (* while special forms have a type macro this does not recognize them as such *) | macro, _ when OL.conv_p ltp macro_type -> ( match macro with | Pvar(l, name) when is_builtin_macro name ->

===================================== tests/eval_test.ml ===================================== --- a/tests/eval_test.ml +++ b/tests/eval_test.ml @@ -41,161 +41,98 @@ open Env let lctx = default_lctx let rctx = default_rctx

-let _ = (add_test "EVAL" "Variable Cascade" (fun () -> +(* Params: + * decl: declarations to be processed before evaluating + * run : expr to be evaluated + * res : expected result + *) +let test_eval_eqv_named name decl run res = + add_test "EVAL" name (fun () -> reset_eval_trace (); + let rctx, lctx = eval_decl_str decl lctx rctx in

- let dcode = " - a = 10; - b = a; - c = b; - d = c;" in + let erun = eval_expr_str run lctx rctx in (* evaluated run expr *) + let eres = eval_expr_str res lctx rctx in (* evaluated res expr *)

- let rctx, lctx = eval_decl_str dcode lctx rctx in + if value_eq_list erun eres + then success () + else ( + value_print (List.hd erun); + value_print (List.hd eres); + failure ()))

- let ecode = "d;" in +let test_eval_eqv decl run res = test_eval_eqv_named run decl run res

- let ret = eval_expr_str ecode lctx rctx in +let _ = test_eval_eqv "" "2 + 2" "4"

- match ret with - | [Vint(r)] -> expect_equal_int r 10 - | _ -> failure ()) -) +let _ = test_eval_eqv_named + "Variable Cascade"

+ "a = 10; b = a; c = b; d = c;" + + "d" (* == *) "10"

(* Let * ------------------------ *)

-let _ = (add_test "EVAL" "Let" (fun () -> - reset_eval_trace (); +let _ = test_eval_eqv_named + "Let"

- (* Noise. Makes sure the correct variables are selected *) - let dcode = " - c = 3; e = 1; f = 2; d = 4;" in - let rctx, lctx = eval_decl_str dcode lctx rctx in - - let ecode = " - let a = 10; x = 50; y = 60; b = 20; in a + b;" in - - let ret = eval_expr_str ecode lctx rctx in - (* Expect a single result *) - match ret with - | [Vint(r)] -> expect_equal_int r 30 - | _ -> failure ()) -) + "c = 3; e = 1; f = 2; d = 4;"

+ "let a = 10; x = 50; y = 60; b = 20; + in a + b;" (* == *) "30"

(* Lambda * ------------------------ *) -let _ = (add_test "EVAL" "Lambda" (fun () -> - reset_eval_trace ();

- let dcode = " - sqr : Int -> Int; - sqr = lambda x -> x * x; - " in +let _ = test_eval_eqv_named + "Lambda"

- (* Declare lambda *) - let rctx, lctx = eval_decl_str dcode lctx rctx in - - (* Eval defined lambda *) - let ret = eval_expr_str "(sqr 4);" lctx rctx in - (* Expect a single result *) - match ret with - | [Vint(r)] -> expect_equal_int r (4 * 4) - | _ -> failure ()) -) - -let _ = (add_test "EVAL" "Nested Lambda" (fun () -> - reset_eval_trace (); - - let code = " - sqr : Int -> Int; - sqr = lambda x -> x * x; + "sqr : Int -> Int; + sqr = lambda x -> x * x;"

- cube : Int -> Int; - cube = lambda x -> x * (sqr x);" in + "(sqr 4);" (* == *) "16"

- (* Declare lambda *) - let rctx, lctx = eval_decl_str code lctx rctx in - - (* Eval defined lambda *) - let ret = eval_expr_str "(cube 4);" lctx rctx in - (* Expect a single result *) - match ret with - | [Vint(r)] -> expect_equal_int r (4 * 4 * 4) - | _ -> failure ()) -) +let _ = test_eval_eqv_named + "Nested Lambda"

-(* This makes sure contexts are reinitialized between calls - * i.e the context should not grow *) -let _ = (add_test "EVAL" "Infinite Recursion failure" (fun () -> - reset_eval_trace (); - _typer_verbose := (-1); + "sqr : Int -> Int; + sqr = lambda x -> x * x;

- let code = " - infinity : Int -> Int; - infinity = lambda (beyond : Int) -> (infinity beyond);" in + cube : Int -> Int; + cube = lambda x -> x * (sqr x);"

- let rctx, lctx = eval_decl_str code lctx rctx in + "(cube 4)" (* == *) "64"

- (* Expect throwing *) - try (* use the silent version as an error will be thrown *) - let _ = _eval_expr_str "(infinity 0);" lctx rctx true in - _typer_verbose := 20; - failure () - with - Internal_error m -> ( - _typer_verbose := 20; - if m = "Recursion Depth exceeded" then - success () - else - failure ()) -))

(* Cases + Inductive types * ------------------------ *)

-let _ = (add_test "EVAL" "Inductive::Case" (fun () -> - reset_eval_trace (); +let _ = test_eval_eqv_named + "Inductive::Case"

- (* Inductive type declaration + Noisy declarations *) - let code = " - i = 90; - idt : Type; - idt = inductive_ (idtd) (ctr0) (ctr1 idt) (ctr2 idt) (ctr3 idt); - d = 10; - ctr0 = inductive-cons idt ctr0; e = 20; - ctr1 = inductive-cons idt ctr1; f = 30; - ctr2 = inductive-cons idt ctr2; g = 40; - ctr3 = inductive-cons idt ctr3; h = 50; - - a = (ctr1 (ctr2 ctr0)); y = 2; - b = (ctr2 (ctr2 ctr0)); z = 3; - c = (ctr3 (ctr2 ctr0)); w = 4; - - test_fun = lambda (k : idt) -> case k - | ctr1 l => 1 - | ctr2 l => 2 - | _ => 3;" in + "i = 90; + idt : Type; + idt = inductive_ (idtd) (ctr0) (ctr1 idt) (ctr2 idt) (ctr3 idt); + d = 10; + ctr0 = inductive-cons idt ctr0; e = 20; + ctr1 = inductive-cons idt ctr1; f = 30; + ctr2 = inductive-cons idt ctr2; g = 40; + ctr3 = inductive-cons idt ctr3; h = 50;

- let rctx, lctx = eval_decl_str code lctx rctx in + a = (ctr1 (ctr2 ctr0)); y = 2; + b = (ctr2 (ctr2 ctr0)); z = 3; + c = (ctr3 (ctr2 ctr0)); w = 4;

- let rcode = "(test_fun a); (test_fun b); (test_fun c)"in + test_fun = lambda (k : idt) -> case k + | ctr1 l => 1 + | ctr2 l => 2 + | _ => 3;"

- (* Eval defined lambda *) - let ret = eval_expr_str rcode lctx rctx in - (* Expect 3 results *) - match ret with - | [Vint(a); Vint(b); Vint(c)] -> - let t1 = expect_equal_int a 1 in - let t2 = expect_equal_int b 2 in - let t3 = expect_equal_int c 3 in - if t1 = 0 && t2 = 0 && t3 = 0 then - success () - else - failure () - | _ -> failure () -)) + "(test_fun a); (test_fun b); (test_fun c)" + + "1; 2; 3"

(* Those wil be used multiple times *) let nat_decl = " @@ -215,165 +152,129 @@ let bool_decl = " false = inductive-cons Bool false; true = inductive-cons Bool true;"

-let _ = (add_test "EVAL" "Inductive::Recursive Call" (fun () -> - reset_eval_trace (); +let _ = test_eval_eqv_named + "Inductive::Recursive Call"

- let code = nat_decl ^ " - one = (succ zero); - two = (succ one); - three = (succ two);" in + (nat_decl ^ " + one = (succ zero); + two = (succ one); + three = (succ two);")

- let rctx, lctx = eval_decl_str code lctx rctx in + "(to-num zero); (to-num one); (to-num two);"

- let rcode = "(to-num zero); (to-num one); (to-num two);"in + "0; 1; 2"

- (* Eval defined lambda *) - let ret = eval_expr_str rcode lctx rctx in - (* Expect a 3 results *) - match ret with - | [Vint(a); Vint(b); Vint(c)] -> - let t1 = expect_equal_int a 0 in - let t2 = expect_equal_int b 1 in - let t3 = expect_equal_int c 2 in - if t1 = 0 && t2 = 0 && t3 = 0 then - success () - else - failure () - | _ -> failure ()) -) - -let _ = (add_test "EVAL" "Inductive::Nat Plus" (fun () -> - reset_eval_trace (); +let _ = test_eval_eqv_named + "Inductive::Nat Plus"

- let code = nat_decl ^ " - one = (succ zero); - two = (succ one); - three = (succ two); + (nat_decl ^ " + one = (succ zero); + two = (succ one); + three = (succ two);

- plus : Nat -> Nat -> Nat; - plus = lambda (x : Nat) -> lambda (y : Nat) -> case x - | zero => y - | succ z => succ (plus z y); - " in + plus : Nat -> Nat -> Nat; + plus = lambda (x : Nat) -> lambda (y : Nat) -> case x + | zero => y + | succ z => succ (plus z y);")

- let rctx, lctx = eval_decl_str code lctx rctx in + "to-num (plus zero two); + to-num (plus two zero); + to-num (plus two one);"

- let rcode = " - (to-num (plus zero two)); - (to-num (plus two zero)); - (to-num (plus two one));"in + "2; 2; 3"

- (* Eval defined lambda *) - let ret = eval_expr_str rcode lctx rctx in - (* Expect a 3 results *) - match ret with - | [Vint(a); Vint(b); Vint(c)] -> - let t1 = expect_equal_int a 2 in - let t2 = expect_equal_int b 2 in - let t3 = expect_equal_int c 3 in - if t1 = 0 && t2 = 0 && t3 = 0 then - success () - else - failure () - | _ -> failure () -)) +let _ = test_eval_eqv_named + "Mutually Recursive Definition"

-let _ = (add_test "EVAL" "Mutually Recursive Definition" (fun () -> - reset_eval_trace (); + (nat_decl ^ " + one = (succ zero); + two = (succ one); + three = (succ two);

- let dcode = nat_decl ^ " - one = (succ zero); - two = (succ one); - three = (succ two); + even : Nat -> Int; + odd = lambda (n : Nat) -> case n + | zero => 0 + | succ y => (even y);

- even : Nat -> Int; - odd = lambda (n : Nat) -> case n - | zero => 0 - | succ y => (even y); + even = lambda (n : Nat) -> case n + | zero => 1 + | succ y => (odd y);")

- even = lambda (n : Nat) -> case n - | zero => 1 - | succ y => (odd y);" in + "(odd one); (even one); (odd two); (even two);"

- let rctx, lctx = eval_decl_str dcode lctx rctx in + "1; 0; 0; 1"

- let rcode = "(odd one); (even one); (odd two); (even two);" in

- (* Eval defined lambda *) - let ret = eval_expr_str rcode lctx rctx in - (* Expect a 3 results *) - match ret with - | [Vint(a); Vint(b); Vint(c); Vint(d)] -> - let t1 = expect_equal_int a 1 in - let t2 = expect_equal_int b 0 in - let t3 = expect_equal_int c 0 in - let t4 = expect_equal_int d 1 in - if t1 = 0 && t2 = 0 && t3 = 0 && t4 = 0 then - success () - else - failure () - | _ -> failure () -)) +let _ = test_eval_eqv_named + "Partial Application"

+ "add : Int -> Int -> Int; + add = lambda x y -> (x + y);

-let _ = (add_test "EVAL" "Partial Application" (fun () -> - reset_eval_trace (); + inc : Int -> Int; + inc = (add 1);"

- let dcode = " - add : Int -> Int -> Int; - add = lambda x y -> (x + y); + "(inc 1); (inc 2); (inc 3);"

- inc : Int -> Int; - inc = (add 1);" in + "2; 3; 4"

- let rctx, lctx = eval_decl_str dcode lctx rctx in +(* + * Lists + *) +let _ = test_eval_eqv_named + "Lists"

- let rcode = "(inc 1); (inc 2); (inc 3);" in + "my_list = cons (a := Int) 1 + (cons (a := Int) 2 + (cons (a := Int) 3 + (cons (a := Int) 4 (nil (a := Int)))))"

- (* Eval defined lambda *) - let ret = eval_expr_str rcode lctx rctx in - (* Expect a 3 results *) - match ret with - | [Vint(a); Vint(b); Vint(c)] -> - let t1 = expect_equal_int a 2 in - let t2 = expect_equal_int b 3 in - let t3 = expect_equal_int c 4 in - if t1 = 0 && t2 = 0 && t3 = 0 then - success () - else - failure () - | _ -> failure () -)) + "length (a := Int) my_list; + head (a := Int) my_list; + head (a := Int) (tail (a := Int) my_list)"

+ "4; 1; 2"

-let _ = (add_test "EVAL" "List" (fun () -> - reset_eval_trace (); +(* + * Special forms + *) +let _ = test_eval_eqv "w = 2" "decltype w" "Int" +let _ = test_eval_eqv "w = 2" "declexpr w" "2"

- let dcode = " - my_list = (cons(a := Int) 1 (cons(a := Int) 2 (cons(a := Int) 3 (cons(a := Int) 4 (nil(a := Int)))))); - " in +let attr_decl = " + w = 2; + greater-than = new-attribute (Int -> Bool); + attribute w greater-than (lambda (y : Int) -> True);"

- let rctx, lctx = eval_decl_str dcode lctx rctx in +let _ = test_eval_eqv attr_decl + "has-attribute w greater-than" + "True"

- let rcode = "(length(a := Int) my_list); - (head(a := Int) my_list); - (head(a := Int) (tail(a := Int) my_list));" in +(* This makes sure contexts are reinitialized between calls + * i.e the context should not grow *) +let _ = (add_test "EVAL" "Infinite Recursion failure" (fun () -> + reset_eval_trace (); + _typer_verbose := (-1);

- (* Eval defined lambda *) - let ret = eval_expr_str rcode lctx rctx in - (* Expect a 3 results *) - match ret with - | [Vint(a); Vint(b); Vint(c)] -> - let t1 = expect_equal_int a 4 in - let t2 = expect_equal_int b 1 in - let t3 = expect_equal_int c 2 in - if t1 = 0 && t2 = 0 && t3 = 0 then - success () - else - failure () - | _ -> failure () -)) + let code = " + infinity : Int -> Int; + infinity = lambda (beyond : Int) -> (infinity beyond);" in

+ let rctx, lctx = eval_decl_str code lctx rctx in + + (* Expect throwing *) + try (* use the silent version as an error will be thrown *) + let _ = _eval_expr_str "(infinity 0);" lctx rctx true in + _typer_verbose := 20; + failure () + with + Internal_error m -> ( + _typer_verbose := 20; + if m = "Recursion Depth exceeded" then + success () + else + failure ()) +))

let _ = (add_test "EVAL" "Monads" (fun () -> reset_eval_trace (); @@ -382,7 +283,6 @@ let _ = (add_test "EVAL" "Monads" (fun () -> c = bind (a := Type) (b := Type) (open "./_build/w_file.txt" "w") (lambda (f : FileHandle) -> write f "Hello2"); - " in

let rctx, lctx = eval_decl_str dcode lctx rctx in @@ -391,30 +291,11 @@ let _ = (add_test "EVAL" "Monads" (fun () ->

(* Eval defined lambda *) let ret = eval_expr_str rcode lctx rctx in - (* Expect a 3 results *) match ret with | [v] -> success () | _ -> failure () ))

-(* -let test_eval_eqv decl run expected_result = - add_test "EVAL" dcode1 (fun () -> - - let rctx, lctx = eval_decl_str decl lctx rctx in - - let result = eval_expr_str rcode lctx rctx - let expected_result = eval_expr_str expected_result lctx rctx - - if sexp_eq_list result expected_result - then success () - else ( - value_print (List.hd s1); - value_print (List.hd s2); - failure ())) - -*) - (* run all tests *) let _ = run_all ()

View it on GitLab: https://gitlab.com/monnier/typer/compare/222406c230ecab382880a7ec8804b3dec15...