Setepenre pushed to branch master at Stefan / Typer

Commits: 781a872a by Pierre Delaunay at 2016-05-31T15:39:54-04:00 Macro are passing.

sqr = Macro_ (lambda (x : List Sexp) -> let hd = (head Sexp x) in (node_ (symbol_ "_*_") (cons hd (cons hd nil))));

This does not work, but if the lambda is declared separately, it works

Changes to be committed: * src/builtin.ml * src/debug_util.ml * src/env.ml * src/eval.ml * src/lparse.ml * tests/macro_test.ml

- - - - -

6 changed files:

- src/builtin.ml - src/debug_util.ml - src/env.ml - src/eval.ml - src/lparse.ml - tests/macro_test.ml

Changes:

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -165,6 +165,8 @@ let make_node loc args_val ctx = | _ -> builtin_error loc "node_ expects one 'Sexp' and one 'List Sexp'" in

+ value_print tlist; print_string "\n"; + let args = tlist2olist [] tlist in

let s = List.map (fun g -> match g with @@ -172,8 +174,11 @@ let make_node loc args_val ctx = (* eval transform sexp into those... *) | Vint (i) -> Integer(dloc, i) | Vstring (s) -> String(dloc, s) - | _ -> value_print g; - builtin_error loc ("node_ expects sexp as arguments")) args in + | _ -> + print_rte_ctx ctx; + print_string (value_name g); print_string "\n"; + value_print g; print_string "\n"; + builtin_error loc ("node_ expects 'List Sexp' second as arguments")) args in

Vsexp(Node(op, s))

===================================== src/debug_util.ml ===================================== --- a/src/debug_util.ml +++ b/src/debug_util.ml @@ -305,10 +305,16 @@ let main () = loop n env Myers.nil in *)

(if (get_p_option "typecheck") then( + print_string (make_title " TYPECHECK "); + let cctx = lctx_to_cctx ctx in (* run type check *) List.iter (fun (_, lxp, _) -> - let _ = TC.check cctx lxp in ()) flexps)); + let _ = TC.check cctx lxp in ()) flexps; + + print_string (make_line '-' 76); + + ));

(if (get_p_option "lexp") then( print_string (make_title " Lexp ");

===================================== src/env.ml ===================================== --- a/src/env.ml +++ b/src/env.ml @@ -55,14 +55,14 @@ type value_type = | Vcons of symbol * value_type list | Vbuiltin of string | Vfloat of float - | Closure of elexp * (((string option * value_type) ref myers) * (int * int)) + | Closure of string * elexp * (((string option * value_type) ref myers) * (int * int)) | Vsexp of sexp (* Values passed to macros. *) (* Unable to eval during macro expansion, only throw if the value is used *) | Vdummy

let rec value_print (vtp: value_type) = match vtp with - | Closure (lxp, _) -> + | Closure (_, lxp, _) -> print_string ("Closure(" ^ (elexp_str lxp) ^ ")") | Vsexp sxp -> sexp_print sxp | Vint(i) -> print_int i @@ -80,7 +80,7 @@ let rec value_print (vtp: value_type) = let value_location (vtp: value_type) = match vtp with | Vcons ((loc, _), _) -> loc - | Closure (lxp, _) -> elexp_location lxp + | Closure (_, lxp, _) -> elexp_location lxp (* location info was lost or never existed *) | _ -> dloc

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -80,11 +80,12 @@ let rec _eval lxp ctx i: (value_type) = | Imm(sxp) -> Vsexp(sxp) | Inductive (_, _) -> Vdummy | Cons (label) -> Vcons (label, []) - | Lambda (_, lxp) -> Closure(lxp, ctx) + | Lambda ((_, n), lxp) -> Closure(n, lxp, ctx) | Builtin ((_, str)) -> Vbuiltin(str)

(* Return a value stored in env *) - | Var((loc, name), idx) as e -> eval_var ctx e ((loc, name), idx) + | Var((loc, name), idx) as e -> + eval_var ctx e ((loc, name), idx)

(* Nodes *) (* ---------------- *) @@ -110,16 +111,20 @@ and eval_var ctx lxp v =

and eval_call ctx i lname args = let loc = elexp_location lname in - let args = List.map (fun e -> _eval e ctx (i + 1)) args in + let args = List.map (fun e -> + (* elexp_print e; print_string "\n"; *) + _eval e ctx (i + 1)) args in let f = _eval lname ctx (i + 1) in

let rec eval_call f args ctx = match f, args with - | Vcons (n, []), _ -> Vcons(n, args) + | Vcons (n, []), _ -> + let e = Vcons(n, args) in + (* value_print e; print_string "\n"; *) e

(* we add an argument to the closure *) - | Closure (lxp, ctx), hd::tl -> - let nctx = add_rte_variable None hd ctx in + | Closure (n, lxp, ctx), hd::tl -> + let nctx = add_rte_variable (Some n) hd ctx in let ret = _eval lxp nctx (i + 1) in eval_call ret tl nctx

@@ -229,7 +234,7 @@ and typer_eval loc args ctx = (* I need to be able to lexp sexp but I don't have lexp ctx *) match arg with (* Nodes that can be evaluated *) - | Closure (body, ctx) -> _eval body ctx 1 + | Closure (_, body, ctx) -> _eval body ctx 1 (* Leaf *) | _ -> arg

@@ -251,9 +256,9 @@ and get_builtin_impl str loc = and sexp_dispatch loc args ctx = let eval a b = _eval a b 1 in let sxp, nd, sym, str, it, flt, blk, rctx = match args with - | [sxp; Closure(nd, rctx); Closure(sym, _); - Closure(str, _); Closure(it, _); - Closure(flt, _); Closure(blk, _)] -> + | [sxp; Closure(_, nd, rctx); Closure(_, sym, _); + Closure(_, str, _); Closure(_, it, _); + Closure(_, flt, _); Closure(_, blk, _)] -> sxp, nd, sym, str, it, flt, blk, rctx | _ -> eval_error loc "sexp_dispatch expects 7 arguments" in

@@ -268,7 +273,7 @@ and sexp_dispatch loc args ctx = let rctx = add_rte_variable None (Vsexp(op)) rctx in let rctx = add_rte_variable None (olist2tlist_rte s) rctx in match eval nd rctx with - | Closure(nd, _) -> eval nd rctx + | Closure(_, nd, _) -> eval nd rctx | _ -> eval_error loc "Node has 2 arguments")

| Symbol (_ , s) -> @@ -312,15 +317,18 @@ let eval_all lxps rctx silent = List.map (fun g -> evalfun g rctx) lxps

-(* build a rctx from a lctx *) -let from_lctx (ctx: lexp_context): runtime_env = +let maybe s = match s with Some v -> v | _ -> "" + +(* build a rctx from a lctx, rm is used to ignore the last 'rm' elements *) +let from_lctx (ctx: lexp_context) rm: runtime_env = let ((n, _), env, _) = ctx in let n = n - 1 in let rctx = ref make_runtime_ctx in

- for i = 0 to n do + for i = 0 to (n - rm) do let name, exp = match (Myers.nth (n - i) env) with | (_, Some (_, name), LetDef exp, _) -> Some name, Some exp + | (_, Some (_, name), _, _) -> Some name, None | _ -> None, None in

let vxp = match exp with @@ -331,7 +339,8 @@ let from_lctx (ctx: lexp_context): runtime_env = with e -> elexp_print lxp; print_string "\n"; raise e)

- | None -> Vdummy in + | None -> eval_warning dloc ("Unable to eval expr: " ^ (maybe name)); + Vdummy in

rctx := add_rte_variable name vxp (!rctx) done;

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -50,6 +50,7 @@ open Builtin

module TC = Typecheck module EL = Elexp +module SU = Subst

(* Shortcut => Create a Var *) let make_var name index loc = @@ -455,25 +456,50 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = lexp_fatal loc (name ^ " was found but " ^ (string_of_int idx) ^ " is not a correct index.") in

- let lxp = match lxp with - | Call(Var((_, "Macro_"), _), [(Aexplicit, fct)]) -> fct - | _ -> lexp_fatal loc "Macro is ill formed" in + let lxp = match unsusp_all lxp with + | Call(Var((_, "Macro_"), _), [(_, fct)]) -> fct + | _ -> + print_string "\n"; + print_string (lexp_to_string lxp); print_string "\n"; + lexp_print lxp; print_string "\n"; + lexp_fatal loc "Macro is ill formed" in

(* Build function to be called *) let arg = olist2tlist_lexp sargs ctx in + + let lxp = Call(lxp, [(Aexplicit, arg)]) in + let elexp = EL.erase_type lxp in + let rctx = (from_lctx ctx 0) in + + (* + let rargs = eval (EL.erase_type arg) rctx in + let rctx = add_rte_variable None rargs rctx in + + let lxp = Susp(lxp, (SU.shift 1)) in + let body = eval (EL.erase_type lxp) rctx in + + print_string "HERE2\n"; + value_print body; *)

(* + EL.elexp_print elexp; print_string "\n\n"; lexp_print lxp; print_string "\n\n"; *)

- let rctx = (from_lctx ctx) in - let sxp = match eval (EL.erase_type lxp) rctx with + (* print_string "DH: "; + value_print (eval (EL.erase_type arg) rctx); print_string "\n"; *) + (* + print_rte_ctx rctx; print_string "\n"; + print_lexp_ctx ctx; print_string "\n";*) + + let sxp = match eval elexp rctx with | Vsexp(sxp) -> sxp (* Those are sexp converted by the eval function *) | Vint(i) -> Integer(dloc, i) | Vstring(s) -> String(dloc, s) | Vfloat(f) -> Float(dloc, f) + (* I have vdum here WHY *) | v -> debug_msg (value_print v); lexp_fatal loc "Macro_ expects '(List Sexp) -> Sexp'" in

@@ -644,6 +670,7 @@ and _lexp_decls decls ctx i: (((vdef * lexp * ltype) list list) * lexp_context) let offset = ref 1 in

let ctx = List.fold_left (fun vctx expr -> + _global_lexp_trace := []; match expr with | Pexpr((l, s), pxp) ->( try let idx = senv_lookup s vctx in

===================================== tests/macro_test.ml ===================================== --- a/tests/macro_test.ml +++ b/tests/macro_test.ml @@ -42,15 +42,16 @@ open Env let lctx = default_lctx let rctx = default_rctx

- let _ = (add_test "MACROS" "macros base" (fun () -> reset_eval_trace ();

(* define 'lambda x -> x * x' using macros *) let dcode = " - sqr = Macro_ (lambda (x : List Sexp) -> + my_fun = lambda (x : List Sexp) -> let hd = head Sexp x in - (node_ (symbol_ "_*_") (cons hd (cons hd nil)))); + (node_ (symbol_ "_*_") (cons hd (cons hd nil))); + + sqr = Macro_ my_fun; " in

let rctx, lctx = eval_decl_str dcode lctx rctx in

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