Setepenre pushed to branch master at Stefan / Typer

Commits: b1ff2b13 by Pierre Delaunay at 2016-04-01T09:46:40-04:00 Improved eval_case and partial eval is working

eval.case, now, do check if the constructor exists. lparse.case check if name fields are constructors or not

Changes to be committed: * src/eval.ml: - case: ctor check - partial eval working - new function (is_free_var) * src/lparse.ml - Case: check uniqueness, print a warning if not unique * src/REPL.ml - ityper does not crash when an error is thrown - added support for repl command with arguments * src/debruijn.ml - new function (_env_lookup). (env_lookup_type) and (env_lookup_expr) are specialized version of (_env_lookup)

- - - - -

5 changed files:

- src/REPL.ml - src/debruijn.ml - src/eval.ml - src/lparse.ml - tests/eval_test.ml

Changes:

===================================== src/REPL.ml ===================================== --- a/src/REPL.ml +++ b/src/REPL.ml @@ -36,8 +36,6 @@ this program. If not, see http://www.gnu.org/licenses/. *) * * -------------------------------------------------------------------------- *)

-(* FIXME: Prevent ityper from crashing when an error is thrown *) - open Debug open Prelexer open Lexer @@ -58,6 +56,10 @@ let print_input_line i = print_string "] >> " ;;

+let ieval_error loc msg = + msg_error "IEVAL" loc msg; +;; + (* Read stdin for input. Returns only when the last char is ';' * We can use '%' to prevent evaluation * If return is pressed and the last char is not ';' then @@ -134,25 +136,102 @@ let _ieval f str lctx rctx = let pxps = ipexp_parse nods in let lxps, lctx = ilexp_parse pxps lctx in let v, rctx = ieval lxps rctx in - v, lctx, rctx + v, lctx, (local_ctx rctx) ;;

let ieval_string = _ieval prelex_string let ieval_file = _ieval prelex_file

-(* Specials commands %[command-name] *) + +let _welcome_msg = +" Typer 0.0.0 - Interpreter - (c) 2016 + + %quit (%q) : leave REPL + %help (%h) : print help +";; + +let _help_msg = +" %quit (%q) : leave REPL + %who (%w) : print runtime environment + %info (%i) : print elaboration environment + %calltrace (%ct): print call trace of last call + %readfile : read a typer/ityper file + %help (%h) : print help +";; + + +let str_split str sep = + let str = String.trim str in + let n = String.length str in + + if n = 0 then [] + else ( + + let ret = ref [] in + let buffer = Buffer.create 10 in + Buffer.add_char buffer (str.[0]); + + for i = 1 to n - 1 do + if str.[i] = sep then ( + ret := (Buffer.contents buffer)::(!ret); + Buffer.reset buffer) + else + Buffer.add_char buffer (str.[i]); + done; + (if (Buffer.length buffer) > 0 then + ret := (Buffer.contents buffer)::(!ret)); + + List.rev (!ret));; + + +let readfiles files (i, lctx, rctx) prt = + (* Read specified files *) + List.fold_left (fun (i, lctx, rctx) file -> + + (if prt then ( + print_string " In["; ralign_print_int i 2; print_string "] >> "; + print_string ("%readfile " ^ file); print_string "\n";)); + + try let (ret, lctx, rctx) = ieval_file file lctx rctx in + (List.iter (print_eval_result i) ret; (i + 1, lctx, rctx)) + with + Sys_error _ -> ( + ieval_error dloc ("file "" ^ file ^ "" does not exist."); + (i, lctx, rctx)) + ) + (i, lctx, rctx) files;; + + +(* Specials commands %[command-name] [args] *) let rec repl i clxp rctx = + let repl = repl (i + 1) in let ipt = read_input i in match ipt with (* Check special keywords *) | "%quit" | "%q" -> () - | "%who" | "%w" -> (print_rte_ctx rctx; repl (i + 1) clxp rctx) - | "%info" | "%i" -> (print_lexp_ctx clxp; repl (i + 1) clxp rctx) - | "%calltrace" | "%ct" -> (print_eval_trace (); repl (i + 1) clxp rctx) + | "%help" | "%h" -> (print_string _help_msg; repl clxp rctx) + | "%who" | "%w" -> (print_rte_ctx rctx; repl clxp rctx) + | "%info" | "%i" -> (print_lexp_ctx clxp; repl clxp rctx) + | "%calltrace" | "%ct" -> (print_eval_trace (); repl clxp rctx) + + (* command with arguments *) + | _ when (ipt.[0] = '%' && ipt.[1] != ' ') -> ( + match (str_split ipt ' ') with + | "%readfile"::args -> + let (i, clxp, rctx) = readfiles args (i, clxp, rctx) false in + repl clxp rctx; + | cmd::_ -> + ieval_error dloc (" "" ^ cmd ^ "" is not a correct repl command"); + repl clxp rctx + | _ -> repl clxp rctx) + (* eval input *) - | _ -> let (ret, clxp, rctx) = (ieval_string ipt clxp rctx) in - List.iter (print_eval_result i) ret; - repl (i + 1) clxp rctx + | _ -> ( + try let (ret, clxp, rctx) = (ieval_string ipt clxp rctx) in + List.iter (print_eval_result i) ret; + repl clxp rctx + with e -> + repl clxp rctx) ;;

let arg_files = ref [] @@ -171,36 +250,20 @@ let parse_args () = let main () = parse_args ();

- let lctx = ref (default_lctx ()) in - let rctx = ref make_runtime_ctx in + let lctx = (default_lctx ()) in + let rctx = make_runtime_ctx in

print_string (make_title " TYPER REPL "); - print_string " %quit : leave REPL\n"; - print_string " %who : print runtime environment\n"; - print_string " %info : print elaboration environment\n"; - print_string " %calltrace : print call trace of last call \n"; + print_string _welcome_msg; print_string (make_sep '-'); flush stdout;

- let nfiles = List.length !arg_files in - - (* Read specified files *) - List.iteri (fun i file -> - print_string " In["; ralign_print_int (i + 1) 2; print_string "] >> "; - print_string ("%readfile " ^ file); print_string "\n"; - - let (ret, lctx1, rctx1) = ieval_file file (!lctx) (!rctx) in - lctx := lctx1; - rctx := rctx1; - List.iter (print_eval_result i) ret; - ) - - !arg_files; + let (i, lctx, rctx) = readfiles (!arg_files) (1, lctx, rctx) true in

flush stdout;

(* Initiate REPL. This will allow us to inspect interpreted code *) - repl (nfiles + 1) (!lctx) (!rctx) + repl i lctx rctx ;;

===================================== src/debruijn.ml ===================================== --- a/src/debruijn.ml +++ b/src/debruijn.ml @@ -123,7 +123,9 @@ let env_add_var_info var (ctx: lexp_context) = let env_extend (ctx:lexp_context) (def:vdef) (v: lexp option) (t:lexp) = env_add_var_info (0, def, v, t) (senv_add_var def ctx)

-let env_lookup_type ctx (v : vref) = + +(* generic lookup *) +let _env_lookup ctx (v : vref) = let ((dv_size, _), info_env, _) = ctx in let ti_size = Myers.length info_env in let sync_offset = dv_size - ti_size in @@ -131,17 +133,20 @@ let env_lookup_type ctx (v : vref) = let ((_, rname), dbi) = v in let idx = (dbi - sync_offset) in

- try let (rof, (_, dname), _, t) = Myers.nth idx info_env in - if dname = rname then - t (* Shift (dbi - roft, t) *) - else ( - let (rof, (_, dname), _, t) = Myers.nth (dbi - sync_offset) info_env in - print_string (" DBI: " ^ dname ^ " " ^ rname); - print_int (dbi - sync_offset); print_string "\n"; - internal_error ("DeBruijn index refers to wrong name. Expected: "" - ^ rname ^ "" got "" ^ dname ^ """)) - - with Not_found -> internal_error "DeBruijn index out of bounds!" + let ret = try Myers.nth idx info_env + with Not_found -> internal_error "DeBruijn index out of bounds!" in + + let (_, (_, dname), _, _) = ret in + if dname = rname then ret + else + internal_error ("DeBruijn index refers to wrong name. " ^ + "Expected: "" ^ rname ^ "" got "" ^ dname ^ """) + +let env_lookup_type ctx (v : vref) = + let (_, (_, _), _, t) = _env_lookup ctx v in t + +let env_lookup_expr ctx (v : vref) = + let (_, (_, _), lxp, _) = _env_lookup ctx v in lxp

let env_lookup_by_index index (ctx: lexp_context): env_elem = Myers.nth index (_get_env ctx)

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -48,6 +48,7 @@ let eval_error loc msg =

let dloc = dummy_location let eval_warning = msg_warning "EVAL" +let str_idx idx = "[" ^ (string_of_int idx) ^ "]"

let print_myers_list l print_fun = let n = (length l) - 1 in @@ -93,15 +94,23 @@ type runtime_env = ((string option * lexp) myers) * (int * int * decls_offset)

let make_runtime_ctx = (nil, (0, 0, 0));;

+let get_rte_size (ctx: runtime_env): int = let (l, _) = ctx in length l;; + let add_rte_variable name x ctx = let (l, b) = ctx in let lst = (cons (name, x) l) in (lst, b);;

+let is_free_var idx ctx = + let (l, (osize, _, offset)) = ctx in + let tsize = (get_rte_size ctx) - osize in + if idx > tsize then true else false +;; + let get_rte_variable (name: string option) (idx: int) (ctx: runtime_env): lexp = let (l, (_, _, offset)) = ctx in - let idx = if idx >= offset then idx - offset else idx in - let (tn, x) = (nth idx l) in + let idx = if (is_free_var idx ctx) then idx - offset else idx in + try (let (tn, x) = (nth idx l) in match (tn, name) with | (Some n1, Some n2) -> ( if n1 = n2 then @@ -111,13 +120,18 @@ let get_rte_variable (name: string option) (idx: int) (ctx: runtime_env): lexp = ("Variable lookup failure. Expected: "" ^ n2 ^ "[" ^ (string_of_int idx) ^ "]" ^ "" got "" ^ n1 ^ """)))

- | _ -> x (* can't check variable's name (call args do not have names) *) + | _ -> x) + with Not_found -> + let n = match name with Some n -> n | None -> "" in + eval_error dloc ("Variable lookup failure. Var: "" ^ + n ^ "" idx: " ^ (str_idx idx) ^ " offset: " ^ (str_idx offset) ^ + " free_var? " ^ (string_of_bool (is_free_var idx ctx))) ;;

-let get_rte_size (ctx: runtime_env): int = let (l, _) = ctx in length l;;

-(* This function is used when we enter a new scope *) -(* it allow us to removed temporary variables when we enter temporary scope *) +(* This function is used when we enter a new scope *) +(* it saves the size of the environment before temp var are added *) +(* it allow us to remove temporary variables when we enter a new scope *) let local_ctx ctx = let (l, (_, _, off)) = ctx in let osize = length l in @@ -140,12 +154,13 @@ let temp_ctx ctx = let tsize = length l in (* Check if temporary variables are present *) if tsize != osize then - (* remove temp var *) + (* remove them *) (select_n ctx osize) else ctx ;;

+(* Select the n first variable present in the env *) let nfirst_rte_var n ctx = let rec loop i acc = if i < n then @@ -167,12 +182,11 @@ type value_type = lexp * 'i' is the recursion depth used to print the call trace *) let rec _eval lxp ctx i: (value_type) = let tloc = lexp_location lxp in - let str_idx idx = "[" ^ (string_of_int idx) ^ "]" in

(if i > (!_eval_max_recursion_depth) then raise (internal_error "Recursion Depth exceeded"));

- _global_eval_ctx := ctx; (* Allow us to print the latest used environment *) + _global_eval_ctx := ctx; (* Allow us to print the latest used environment *) _global_eval_trace := (i, tloc, lxp)::!_global_eval_trace;

match lxp with @@ -182,42 +196,23 @@ let rec _eval lxp ctx i: (value_type) = | Inductive (_, _, _, _) as e -> e | Cons (_, _) as e -> e

- (* Lambda's body is evaluated when called *) + (* Lambda's body is evaluated when called *) | Lambda _ -> lxp

- (* Return a value stored in the environ *) - | Var((loc, name), idx) as e ->( - (* find variable binding i.e we do not want a another variable *) - (* (-3) represent a variable which should not be replaced *) - let rec var_crawling expr k = - (if k > 255 then( - lexp_print expr; print_string "\n"; flush stdout; - eval_error tloc "Variable lookup failed")); - match expr with - | Var(_, j) when j = (-3)-> e - | Var((_, name2), j) -> - let p = (get_rte_variable (Some name2) j ctx) in - var_crawling p (k + 1) - | _ -> expr in - - try (var_crawling e 0) - with Not_found -> - eval_error tloc ("Variable: " ^ - name ^ (str_idx idx) ^ " was not found ")) + (* Return a value stored in the env *) + | Var((loc, name), idx) as e -> eval_var ctx e ((loc, name), idx)

(* Nodes *) (* ---------------- *) - (* this works for non recursive let *) | Let(_, decls, inst) -> - (* First we _evaluate all declaration then we eval the instruction *) - let nctx = build_ctx decls ctx i in - _eval inst (local_ctx nctx) (i + 1) + let nctx = _eval_decls decls ctx i in + _eval inst nctx (i + 1)

(* Built-in Function * ) | Call(Builtin(v, name, ltp), args) -> let nctx = build_arg_list args ctx i in *)

- (* Function call *) + (* Function call *) | Call (lname, args) -> eval_call ctx i lname args

(* Case *) @@ -225,6 +220,26 @@ let rec _eval lxp ctx i: (value_type) =

| _ -> Imm(String(dloc, "eval Not Implemented"))

+and eval_var ctx lxp v = + let ((loc, name), idx) = v in + + (* find variable binding i.e we do not want a another variable *) + (* (-3) represent a variable that should not be replaced *) + let rec var_crawling expr k = + (if k > 255 then( + lexp_print expr; print_string "\n"; flush stdout; + eval_error loc "Variable lookup failed")); + + match expr with + | Var(_, j) when j = (-3) -> lxp + | Var((_, name2), j) -> + var_crawling (get_rte_variable (Some name2) j ctx) (k + 1) + | _ -> expr in + + try var_crawling lxp 0 + with Not_found -> + eval_error loc ("Variable: " ^ name ^ (str_idx idx) ^ " was not found ") + and eval_call ctx i lname args = (* create a clean environment *) let tloc = lexp_location lname in @@ -232,7 +247,7 @@ and eval_call ctx i lname args = let args_n = List.length args in

(* To handle partial call we need to consume args and *) - (* lambdas together an return the remaining lambda *) + (* lambdas together and return the remaining lambda *) (* Call by name: replace variables then eval *) let rec consume_args (ctx: runtime_env) (lxp: lexp) args (k: int): value_type = match lxp, args with @@ -244,10 +259,11 @@ and eval_call ctx i lname args = (* Partial Application *) (* In truth we don't really stop here. We push missing args *) (* as such that missing args will be replaced by themselves *) - (* when the full eval will be called *) + (* when the full eval branch will be called *) | Lambda(kind, (loc, name), l, body), [] -> let ctx = add_rte_variable (Some name) (Var((loc, name), -3)) ctx in let b = consume_args ctx body [] (k + 1) in + (* Build a new lambda *) Lambda(kind, (loc, name), l, b)

(* Full Eval *) @@ -256,9 +272,9 @@ and eval_call ctx i lname args =

(* Too many args *) | _, _ -> - eval_error tloc ("Wrong Number of arguments. " ^ - " Got:" ^ (string_of_int args_n) ^ " arg(s) " ^ - " Expected: " ^ (string_of_int k) ^ " arg(s) ") in + eval_error tloc ("Wrong Number of arguments." ^ + " Got:" ^ (string_of_int args_n) ^ " arg(s)." ^ + " Expected: " ^ (string_of_int k) ^ " arg(s)") in

match lname with (* Hardcoded functions *) @@ -291,13 +307,18 @@ and eval_call ctx i lname args = let vint = (nfirst_rte_var args_n nctx) in let varg = List.map (fun g -> get_int g) vint in

+ (* check for partial eval and compute product *) let (partial, prod) = List.fold_left (fun a g -> let (partial, prod) = a in match g with | Some v -> (partial, v * prod) - | None -> (true, 0)) + | None -> (true, 1)) (false, 1) varg in

+ (* we could partially eval partial call *) + (* i.e (a * 2 * 2 * b * 4) => (a * b * 16) *) + (* but we don't here *) + if partial then let args = List.map (fun g -> (Aexplicit, g)) vint in Call(lname, args) @@ -327,7 +348,8 @@ and eval_call ctx i lname args = clean_ctx arg_val in _eval body nctx (i + 1))

- (* TODO Everything else *) + (* if lname is not a Var them it is the body itself *) + (* FIXME:TODO Everything else *) (* Which includes a call to a lambda *) | _ -> Imm(String(dloc, "Funct Not Implemented"))

@@ -335,45 +357,60 @@ and eval_case ctx i loc target pat dflt = (* Eval target *) let v = _eval target ctx (i + 1) in

- let (_, (osize, _, _)) = ctx in - let csize = get_rte_size ctx in + let (_, (osize, _, _)) = ctx in (* number of variable declared outside *) + let csize = get_rte_size ctx in (* current size *) let offset = csize - osize in

- (* V must be a constructor Call *) + (* Get inductive type from a constructor *) + let get_inductive_ref lxp = + match lxp with + | Cons(((_, vname), idx), (_, cname)) ->( + let info = get_rte_variable (Some vname) (idx + offset) ctx in + let ctor_def = match info with + | Inductive(_, _, _, c) -> c + | _ -> eval_error loc "Not an Inductive Type" in + info, ctor_def) + | _ -> eval_error loc "Target is not a Constructor" in + + (* I think checks should be in lexp not done during eval *) + (* check if a constructor 'cname' exist *) + let check_ctor cname cargs ctor_def = + try let targs = (SMap.find cname ctor_def) in + let n_targs = List.length targs in + let n_cargs = List.length cargs in + + match (n_targs - n_cargs) with + | 0 -> cname, cargs + | _ -> eval_error loc ("Constructor not applied. " ^ + cname ^ " expected " ^ (string_of_int n_targs) ^ " arg(s)." ^ + " Given " ^ (string_of_int n_cargs) ^ " arg(s).") + + with Not_found -> + eval_error loc ("Constructor "" ^ cname ^ "" does not exist") in + + (* extract constructor name and check its validity *) let ctor_name, args = match v with - | Call(lname, args) -> (match lname with - (* FIXME we should check that ctor_name is an existing - * constructor with the correct number of args *) - | Var((_, ctor_name), _) -> ctor_name, args - | _ -> eval_error loc "Target is not a Constructor" ) - - | Cons(((_, vname), idx), (_, cname)) -> begin - (* retrieve type definition *) - let info = get_rte_variable (Some vname) (idx + offset) ctx in - let ctor_def = match info with - | Inductive(_, _, _, c) -> c - | _ -> eval_error loc "Not an Inductive Type" in - - try match SMap.find cname ctor_def with - | [] -> cname, [] - | carg -> - let ctor_n = List.length carg in - eval_error loc ("Constructor not applied. " ^ - "Constructor name: "" ^ cname ^ - "": " ^ (string_of_int ctor_n) ^ - " argument(s) expected") - with - Not_found -> - eval_error loc "Constructor does not exist" end + | Call(Var((_, cname), tp), args) ->( + (* get constructor *) + try let ctor = get_rte_variable None (tp + offset) ctx in + let idt, ctor_def = get_inductive_ref ctor in + check_ctor cname args ctor_def + + (* currently we have a little bug with ctor checking *) + with e -> cname, args) + + | Cons(((_, vname), idx), (_, cname)) as ctor -> + let idt, ctor_def = get_inductive_ref ctor in + check_ctor cname [] ctor_def

| _ -> lexp_print target; print_string "\n"; lexp_print v; print_string "\n"; - eval_error loc "Can't match expression" in + eval_error loc "Target is not a Constructor" in

(* Check if a default is present *) let run_default df = match df with - | None -> Imm(String(loc, "Match Failure")) + | None -> eval_error loc "Match Failure" | Some lxp -> _eval lxp ctx (i + 1) in

let ctor_n = List.length args in @@ -382,6 +419,7 @@ and eval_case ctx i loc target pat dflt = let is_true key value = let (_, pat_args, _) = value in let pat_n = List.length pat_args in + (* FIXME: Shouldn't pat_n != ctor_n cause an error ? *) if pat_n = ctor_n && ctor_name = key then true else @@ -429,14 +467,6 @@ and build_arg_list args ctx i = (* Add args inside context *) List.fold_left (fun c v -> add_rte_variable None v c) ctx arg_val

-and build_ctx decls ctx i = - let f nctx e = - let (v, exp, tp) = e in - let value = _eval exp ctx (i + 1) in - add_rte_variable None value nctx in - - List.fold_left f ctx decls - and eval_decls decls ctx = _eval_decls decls ctx 1 and _eval_decls (decls: ((vdef * lexp * ltype) list)) (ctx: runtime_env) i: runtime_env = @@ -447,26 +477,17 @@ and _eval_decls (decls: ((vdef * lexp * ltype) list))

let n = (List.length decls) - 1 in

- try - let dctx, _ = List.fold_left (fun (ctx, k) g -> let ((_, name), lxp, _) = g in let lxp = _eval lxp ctx (i + 1) in - let ctx = set_offset ctx (n - k) in let ctx = add_rte_variable (Some name) lxp ctx in - (ctx, k + 1)) - (ctx, 0) decls in + let ctx = set_offset ctx (n - k) in + (local_ctx ctx, k + 1)) + (local_ctx ctx, 0) decls in

let dctx = set_offset dctx 0 in (local_ctx dctx)

- with e ->( - print_rte_ctx (!_global_eval_ctx); - print_eval_trace (); - raise e - ) - - and print_eval_result i lxp = print_string " Out["; ralign_print_int i 2;

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -175,10 +175,22 @@ and _lexp_parse p ctx i: lexp = (* Pcons *) | Pcons(vr, sym) -> ( let (loc, type_name) = vr in + let (_, cname) = sym in + (* An inductive type named type_name must be in the environment *) try let idx = senv_lookup type_name ctx in (* Check if the constructor exists *) - (* TODO *) + let idt = env_lookup_type ctx (vr, idx) in + + let _ = match idt with + | Inductive(_, _, _, ctor_def) -> ( + try let _ = (SMap.find cname ctor_def) in () + with Not_found -> + lexp_error loc + ("Constructor "" ^ cname ^ "" does not exist")) + + | _ -> lexp_error loc "Not an Inductive Type" in + Cons((vr, idx), sym) with Not_found -> lexp_error loc @@ -188,10 +200,17 @@ and _lexp_parse p ctx i: lexp = (* Pcase *) | Pcase (loc, target, patterns) ->

- (* I need type info HERE *) let lxp = lexp_parse target ctx in let ltp = UnknownType(loc) in

+ let uniqueness_warn name = + lexp_warning loc ("Pattern " ^ name ^ " is a duplicate." ^ + " It will override previous pattern.") in + + let check_uniqueness loc name map = ( + try let _ = SMap.find name map in uniqueness_warn name + with e -> ()) in + (* Read patterns one by one *) let rec loop ptrns merged dflt = match ptrns with @@ -203,11 +222,13 @@ and _lexp_parse p ctx i: lexp = (* parse using pattern context *) let exp = lexp_parse exp nctx in

- if name = "_" then - loop tl merged (Some exp) - else + if name = "_" then ( + (if dflt != None then uniqueness_warn name); + loop tl merged (Some exp)) + else ( + check_uniqueness iloc name merged; let merged = SMap.add name (iloc, arg, exp) merged in - loop tl merged dflt in + loop tl merged dflt) in

let (lpattern, dflt) = loop patterns SMap.empty None in Case(loc, lxp, ltp, lpattern, dflt) @@ -261,11 +282,18 @@ and lexp_read_pattern pattern exp target ctx: ("_", loc, []), ctx

| Ppatvar ((loc, name) as var) ->( - (* FIXME better check *) - try - let _ = senv_lookup name ctx in - (* constructor with no args *) - (name, loc, []), ctx + try( + let idx = senv_lookup name ctx in + match (env_lookup_expr ctx ((loc, name), idx)) with + (* We are matching a constructor *) + | Some Cons _ -> + (name, loc, []), ctx + + (* name is defined but is not a constructor *) + (* it technically could be ... (expr option) *) + (* What about Var -> Cons ? *) + | _ -> let nctx = env_extend ctx var (Some target) dltype in + (name, loc, []), nctx)

(* would it not make a default match too? *) with Not_found ->

===================================== tests/eval_test.ml ===================================== --- a/tests/eval_test.ml +++ b/tests/eval_test.ml @@ -20,6 +20,7 @@ let rctx = make_runtime_ctx let rctx = add_rte_variable (Some "_+_") iop_binary rctx let rctx = add_rte_variable (Some "_*_") iop_binary rctx

+ let _ = (add_test "EVAL" "Variable Cascade" (fun () -> reset_eval_trace ();

@@ -287,10 +288,10 @@ let _ = (add_test "EVAL" "Mutually Recursive Definition" (fun () -> | _ -> failure () ));;

+ let _ = (add_test "EVAL" "Partial Application" (fun () -> reset_eval_trace ();

- let dcode = " add : Int -> Int -> Int; add = lambda x y -> (x + y); @@ -308,8 +309,8 @@ let _ = (add_test "EVAL" "Partial Application" (fun () -> match ret with | [a; b; c] -> let t1 = expect_equal_int (get_int a) 2 in - let t2 = expect_equal_int (get_int b) 4 in - let t3 = expect_equal_int (get_int c) 6 in + let t2 = expect_equal_int (get_int b) 3 in + let t3 = expect_equal_int (get_int c) 4 in if t1 = 0 && t2 = 0 && t3 = 0 then success () else

View it on GitLab: https://gitlab.com/monnier/typer/commit/b1ff2b13be6db10670f599f0307076dcd879...