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...
Afficher les réponses par date
- src/eval.ml: `expand_macro_` is a builtin function
BTW, the "_" final de case_, lambda_, etc... est présent parce que ce sont des opérateurs préfixes, donc dans le code source ils apparaissent comme case/lambda mais dans la sexp un _ est ajouté.
Les fonctions normales que nous définissons ne devraient pas avoir de "_" à la fin, parce que ce ne sont pas des opérateurs préfixes. Plus précisément, on a pas défini la grammaire de manière à pouvoir écrire
expand_macro a b
pour dire (expand_macro_ (a b)).
Stefan
+expand_macro_ = Built-in "expand_macro_" (Macro -> List Sexp -> Sexp);
Qu'est-ce qu'il manque pour pouvoir l'écrire en Typer?
Stefan
Qu'est-ce qu'il manque pour pouvoir l'écrire en Typer?
Je pense qu'on aurait seulement besoin de la fonction "eval".
Hmm.. je ne comprends pas. Pourquoi ne peut-on pas juste faire:
diff --git a/btl/types.typer b/btl/types.typer index 99101b4..92c81d8 100644 --- a/btl/types.typer +++ b/btl/types.typer @@ -107,7 +107,10 @@ 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); +expand_macro_ : Macro -> List Sexp -> Sexp; +expand_macro_ = lambda m args -> + case m + | Macro_ f => f args;
sexp_dispatch_ = Built-in "sexp_dispatch_" ( (a : Type) ≡>
Je ne vois pas le besoin d'un "eval" ici.
Stefan
Ah, effectivement, cela marche.
Cependant, j'avais pris un raccourcis dans le code qui gère le case dans lparse.ml. C'est pour ça que cela ne marchait pas. Je l'ai modifié dans mon nouveau commit.