Setepenre pushed to branch master at Stefan / Typer
Commits: 713bde4f by Pierre Delaunay at 2016-09-11T09:58:49-04:00 Macro are now expanded by a builtin function.
Changes to be committed: * btl/types.typer: added `expand_macro_` builtin * src/builtin.ml: added `expand_macro_` as a predef * src/eval.ml: `expand_macro_` is a builtin function * src/lparse.ml: - updated `handle_macro_call` to call `expand_macro_` instead of expanding the macro by itself
- - - - -
4 changed files:
- btl/types.typer - src/builtin.ml - src/eval.ml - src/lparse.ml
Changes:
===================================== btl/types.typer ===================================== --- a/btl/types.typer +++ b/btl/types.typer @@ -107,6 +107,8 @@ float_ = Built-in "float_" (Float -> Sexp); Macro = inductive_ (dMacro) (Macro_ (List Sexp -> Sexp)); Macro_ = inductive-cons Macro Macro_ ;
+expand_macro_ = Built-in "expand_macro_" (Macro -> List Sexp -> Sexp); + sexp_dispatch_ = Built-in "sexp_dispatch_" ( (a : Type) ≡> Sexp
===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -57,6 +57,7 @@ let predef_name = [ "False"; "Bool"; "Macro"; + "expand_macro_"; ]
let builtin_size = ref 0 @@ -80,7 +81,7 @@ let get_predef_option (name: string) ctx = | None -> None
let get_predef (name: string) ctx = - let r = (get_size ctx) - !builtin_size - 1 in + let r = (get_size ctx) - !builtin_size - 0 in let p = get_predef_raw name in (mkSusp p (S.shift r))
@@ -157,12 +158,8 @@ let make_symbol loc depth args_val ctx =
(* lexp Imm list *) let olist2tlist_lexp lst ctx = - (* Get Constructor *) - let considx = senv_lookup "cons" ctx in - let nilidx = senv_lookup "nil" ctx in - - let tcons = Var((dloc, "cons"), considx) in - let tnil = Var((dloc, "nil"), nilidx) in + let tcons = get_predef "cons" ctx in + let tnil = get_predef "nil" ctx in
let rlst = List.rev lst in List.fold_left (fun tail elem ->
===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -236,25 +236,46 @@ and typer_builtins_impl = [ ("run-io" , run_io); ("read" , read_impl); ("write" , write_impl); + ("expand_macro_" , expand_macro_impl) ]
+and expand_macro_impl loc depth (args_val : value_type list) ctx = + (* (expand_macro_ my_macro arg type) *) + + let macro_expr, macro_args, macro_type = match args_val with + | [macro_expr; args] -> macro_expr, args, None + | [macro_expr; args; macro_type] -> macro_expr, args, Some macro_type + | _ -> eval_error loc "expand_macro_ expects two arguments" in + + (* macro_expr *) + let macro_fct, ctx = match macro_expr with + | Vcons((_, "Macro_"), [Closure(n, elxp, ctx)]) -> elxp, ctx + | _ -> eval_error loc "expand_macro_ expects a Macro_ as first argument" in + + (* add aguments to context *) + let macro_ctx = add_rte_variable None macro_args ctx in + + (* eval macro, should return a Vsexp *) + _eval macro_fct macro_ctx depth + + and bind_impl loc depth args_val ctx =
let io, cb = match args_val with | [io; callback] -> io, callback - | _ -> builtin_error loc "bind expects two arguments" in + | _ -> eval_error loc "bind expects two arguments" in
(* build Vcommand from io function *) let cmd = match io with | Vcommand (cmd) -> cmd - | _ -> builtin_error loc "bind first arguments must be a monad" in + | _ -> eval_error loc "bind first arguments must be a monad" in
(* bind returns another Vcommand *) Vcommand (fun () -> (* get callback *) let body, ctx = match cb with | Closure(_, body, ctx) -> body, ctx - | _ -> builtin_error loc "A Closure was expected" in + | _ -> eval_error loc "A Closure was expected" in
(* run given command *) let underlying = cmd () in @@ -269,11 +290,11 @@ and run_io loc depth args_val ctx =
let io, ltp = match args_val with | [io; ltp] -> io, ltp - | _ -> builtin_error loc "run-io expects 2 arguments" in + | _ -> eval_error loc "run-io expects 2 arguments" in
let cmd = match io with | Vcommand (cmd) -> cmd - | _ -> builtin_error loc "run-io expects a monad as first argument" in + | _ -> eval_error loc "run-io expects a monad as first argument" in
(* run given command *) let _ = cmd () in
===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -462,27 +462,16 @@ and lexp_call (func: pexp) (sargs: sexp list) ctx i = Call (body, List.rev largs), ret_type in
let handle_macro_call () = - (* FIXME: We shouldn't look at `body` here at all: - * Instead, we should pass `body` (along with `arg`) to - * a `typer__expand_macro` function predefined in types.typer. *) - let lxp = match OL.lexp_whnf body ctx with - | Call(Var((_, "Macro_"), _), [(_, fct)]) -> fct - | lxp -> - 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 = OL.erase_type lxp in + let macro_expand = get_predef "expand_macro_" ctx in + let args = [(Aexplicit, body); (Aexplicit, (olist2tlist_lexp sargs ctx))] in + let macro = Call(macro_expand, args) in + let emacro = OL.erase_type macro in let rctx = (from_lctx ctx 0) in
_global_eval_trace := [];
- let vxp = try eval elexp rctx + let vxp = try eval emacro rctx with e -> print_eval_trace (); raise e in
View it on GitLab: https://gitlab.com/monnier/typer/commit/713bde4f9e6e6767b8afd9ec7b031cd9464a...