From 1b104a00a7f64bcc81e00e51e05ab656d86f8de1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 20 Jul 2014 13:16:50 +0900 Subject: [PATCH 1/5] add macroexpand-1 --- src/macro.c | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) diff --git a/src/macro.c b/src/macro.c index b69855c8..7e7c8ee2 100644 --- a/src/macro.c +++ b/src/macro.c @@ -10,6 +10,7 @@ #include "picrin/lib.h" #include "picrin/error.h" #include "picrin/dict.h" +#include "picrin/cont.h" pic_sym pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) @@ -508,6 +509,47 @@ pic_macroexpand(pic_state *pic, pic_value expr) return v; } +static pic_value +macroexpand_one(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + struct pic_macro *mac; + pic_value v, args; + + if (pic_sym_p(expr)) { + pic_sym sym; + + sym = pic_sym(expr); + + if (pic_interned_p(pic, sym)) { + return pic_sym_value(make_identifier(pic, pic_sym(expr), senv)); + } + } + if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) { + pic_sym sym; + + sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv); + + if ((mac = find_macro(pic, sym)) != NULL) { + if (mac->senv == NULL) { /* legacy macro */ + args = pic_cdr(pic, expr); + } + else { + args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); + } + + pic_try { + v = pic_apply(pic, mac->proc, args); + } pic_catch { + pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); + } + + return v; + } + } + + return pic_undef_value(); /* no expansion occurred */ +} + struct pic_senv * pic_senv_new(pic_state *pic, struct pic_senv *up) { @@ -595,6 +637,22 @@ pic_macro_macroexpand(pic_state *pic) return pic_macroexpand(pic, expr); } +static pic_value +pic_macro_macroexpand_1(pic_state *pic) +{ + pic_value expr, val; + + pic_get_args(pic, "o", &expr); + + val = macroexpand_one(pic, expr, pic->lib->senv); + if (pic_undef_p(val)) { + return pic_values2(pic, expr, pic_false_value()); + } + else { + return pic_values2(pic, val, pic_true_value()); + } +} + static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -645,6 +703,7 @@ pic_init_macro(pic_state *pic) pic_deflibrary ("(picrin macro)") { pic_defun(pic, "gensym", pic_macro_gensym); pic_defun(pic, "macroexpand", pic_macro_macroexpand); + pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1); pic_defun(pic, "identifier?", pic_macro_identifier_p); pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); pic_defun(pic, "make-identifier", pic_macro_make_identifier); From 95a3f8880c803553845dda83370bfdea176b4a08 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 20 Jul 2014 13:52:48 +0900 Subject: [PATCH 2/5] disallow non-symbol objects at places where symbol is required --- src/macro.c | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/src/macro.c b/src/macro.c index 7e7c8ee2..1d338cad 100644 --- a/src/macro.c +++ b/src/macro.c @@ -216,17 +216,11 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { pic_value v = pic_car(pic, a); - if (! pic_sym_p(v)) { - v = macroexpand(pic, v, senv); - } if (! pic_sym_p(v)) { pic_error(pic, "syntax error"); } pic_add_rename(pic, in, pic_sym(v)); } - if (! pic_sym_p(a)) { - a = macroexpand(pic, a, senv); - } if (pic_sym_p(a)) { pic_add_rename(pic, in, pic_sym(a)); } @@ -259,9 +253,6 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) } var = formal; } - if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv); - } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); } @@ -289,9 +280,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) } var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv); - } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); } @@ -336,9 +324,6 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv) } pic_for_each (v, formal) { var = pic_car(pic, v); - if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv); - } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); } From 0d8e50bf586b9925d92e97da22d5d424e8837aa0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 20 Jul 2014 13:54:03 +0900 Subject: [PATCH 3/5] update docs --- docs/libs.rst | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/libs.rst b/docs/libs.rst index 91593c89..b87d7980 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -50,6 +50,7 @@ Utility functions and syntaces for macro definition. - define-macro - gensym - macroexpand +- macroexpand-1 Old-fashioned macro. From 7a2f8abd9c227a3d3233d1e12a7594f0a30ff90a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 20 Jul 2014 14:55:17 +0900 Subject: [PATCH 4/5] rewrite let-syntax in scheme --- include/picrin.h | 4 ++-- piclib/prelude.scm | 9 +++++++-- src/init.c | 1 - src/macro.c | 38 -------------------------------------- src/state.c | 2 -- 5 files changed, 9 insertions(+), 45 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index ff0b1a78..fd3b4ca2 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -80,14 +80,14 @@ typedef struct { pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG; pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; - pic_sym sDEFINE_SYNTAX, sLET_SYNTAX; + pic_sym sDEFINE_SYNTAX; pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT; pic_sym sCONS, sCAR, sCDR, sNILP; pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; - pic_sym rDEFINE_SYNTAX, rLET_SYNTAX; + pic_sym rDEFINE_SYNTAX; pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT; xhash syms; /* name to symbol */ diff --git a/piclib/prelude.scm b/piclib/prelude.scm index e9c756b2..7049c2f0 100644 --- a/piclib/prelude.scm +++ b/piclib/prelude.scm @@ -271,12 +271,17 @@ formal) ,@body))))) + (define-syntax let-syntax + (er-macro-transformer + (lambda (form r c) + `(,(r 'letrec-syntax) ,@(cdr form))))) + (export let let* letrec letrec* quasiquote unquote unquote-splicing and or cond case else => do when unless - letrec-syntax + let-syntax letrec-syntax _ ... syntax-error)) (import (picrin core-syntax)) @@ -286,7 +291,7 @@ and or cond case else => do when unless - letrec-syntax + let-syntax letrec-syntax _ ... syntax-error) ;;; multiple value diff --git a/src/init.c b/src/init.c index b59e0600..56264da7 100644 --- a/src/init.c +++ b/src/init.c @@ -70,7 +70,6 @@ pic_init_core(pic_state *pic) pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX); pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/src/macro.c b/src/macro.c index 1d338cad..d0372540 100644 --- a/src/macro.c +++ b/src/macro.c @@ -305,41 +305,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) return pic_none_value(); } -static pic_value -macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - struct pic_senv *in; - pic_value formal, v, var, val; - pic_sym sym, rename; - - in = pic_senv_new(pic, senv); - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - formal = pic_cadr(pic, expr); - if (! pic_list_p(formal)) { - pic_error(pic, "syntax error"); - } - pic_for_each (v, formal) { - var = pic_car(pic, v); - if (! pic_sym_p(var)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(var); - if (! pic_find_rename(pic, in, sym, &rename)) { - rename = pic_add_rename(pic, in, sym); - } - val = pic_eval(pic, pic_cadr(pic, v)); - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluated to non-procedure object", var); - } - define_macro(pic, rename, pic_proc_ptr(val), senv); - } - return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in)); -} - static pic_value macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv) { @@ -410,9 +375,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) else if (tag == pic->rDEFINE_SYNTAX) { return macroexpand_defsyntax(pic, expr, senv); } - else if (tag == pic->rLET_SYNTAX) { - return macroexpand_let_syntax(pic, expr, senv); - } else if (tag == pic->rLAMBDA) { return macroexpand_lambda(pic, expr, senv); } diff --git a/src/state.c b/src/state.c index b910baed..758bae9c 100644 --- a/src/state.c +++ b/src/state.c @@ -95,7 +95,6 @@ pic_open(int argc, char *argv[], char **envp) register_core_symbol(pic, sUNQUOTE, "unquote"); register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing"); register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax"); - register_core_symbol(pic, sLET_SYNTAX, "let-syntax"); register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); register_core_symbol(pic, sIMPORT, "import"); register_core_symbol(pic, sEXPORT, "export"); @@ -128,7 +127,6 @@ pic_open(int argc, char *argv[], char **envp) register_renamed_symbol(pic, rSETBANG, "set!"); register_renamed_symbol(pic, rQUOTE, "quote"); register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax"); - register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax"); register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); register_renamed_symbol(pic, rIMPORT, "import"); register_renamed_symbol(pic, rEXPORT, "export"); From 72422343c08dd1c5b5b28b8b9ba235efe4a95490 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 20 Jul 2014 15:30:48 +0900 Subject: [PATCH 5/5] s/lib->senv/lib->env/g --- include/picrin/lib.h | 2 +- src/codegen.c | 2 +- src/gc.c | 2 +- src/init.c | 16 ++++++++-------- src/lib.c | 8 ++++---- src/macro.c | 8 ++++---- src/vm.c | 4 ++-- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/include/picrin/lib.h b/include/picrin/lib.h index 53a086f2..ba43e49d 100644 --- a/include/picrin/lib.h +++ b/include/picrin/lib.h @@ -12,7 +12,7 @@ extern "C" { struct pic_lib { PIC_OBJECT_HEADER pic_value name; - struct pic_senv *senv; + struct pic_senv *env; xhash exports; }; diff --git a/src/codegen.c b/src/codegen.c index df4c0239..a5c35eb8 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -51,7 +51,7 @@ static void pop_scope(analyze_state *); #define register_renamed_symbol(pic, state, slot, lib, id) do { \ pic_sym sym, gsym; \ sym = pic_intern_cstr(pic, id); \ - if (! pic_find_rename(pic, lib->senv, sym, &gsym)) { \ + if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \ pic_error(pic, "internal error! native VM procedure not found"); \ } \ state->slot = gsym; \ diff --git a/src/gc.c b/src/gc.c index 7d285b32..e673f045 100644 --- a/src/gc.c +++ b/src/gc.c @@ -463,7 +463,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_LIB: { struct pic_lib *lib = (struct pic_lib *)obj; gc_mark(pic, lib->name); - gc_mark_object(pic, (struct pic_object *)lib->senv); + gc_mark_object(pic, (struct pic_object *)lib->env); break; } case PIC_TT_VAR: { diff --git a/src/init.c b/src/init.c index 56264da7..3bb10991 100644 --- a/src/init.c +++ b/src/init.c @@ -62,14 +62,14 @@ pic_init_core(pic_state *pic) pic_deflibrary ("(scheme base)") { /* load core syntaces */ - pic->lib->senv = pic_null_syntactic_environment(pic); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE, pic->rDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG, pic->rSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE, pic->rQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA, pic->rLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); + pic->lib->env = pic_null_syntactic_environment(pic); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/src/lib.c b/src/lib.c index b12e8c9b..5ac5336a 100644 --- a/src/lib.c +++ b/src/lib.c @@ -27,7 +27,7 @@ pic_make_library(pic_state *pic, pic_value name) senv = pic_null_syntactic_environment(pic); lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); - lib->senv = senv; + lib->env = senv; lib->name = name; xh_init_int(&lib->exports, sizeof(pic_sym)); @@ -78,7 +78,7 @@ pic_import(pic_state *pic, pic_value spec) printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym))); #endif - pic_put_rename(pic, pic->lib->senv, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym)); + pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym)); } } @@ -87,7 +87,7 @@ pic_export(pic_state *pic, pic_sym sym) { pic_sym rename; - if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) { + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym)); } @@ -103,7 +103,7 @@ pic_export_as(pic_state *pic, pic_sym sym, pic_sym as) { pic_sym rename; - if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) { + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym)); } diff --git a/src/macro.c b/src/macro.c index d0372540..7711a860 100644 --- a/src/macro.c +++ b/src/macro.c @@ -445,7 +445,7 @@ pic_macroexpand(pic_state *pic, pic_value expr) puts(""); #endif - v = macroexpand(pic, expr, pic->lib->senv); + v = macroexpand(pic, expr, pic->lib->env); #if DEBUG puts("after expand:"); @@ -528,7 +528,7 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, { pic_put_rename(pic, senv, sym, rsym); - if (pic->lib && pic->lib->senv == senv) { + if (pic->lib && pic->lib->env == senv) { pic_export(pic, sym); } } @@ -540,7 +540,7 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) /* symbol registration */ sym = pic_intern_cstr(pic, name); - rename = pic_add_rename(pic, pic->lib->senv, sym); + rename = pic_add_rename(pic, pic->lib->env, sym); define_macro(pic, rename, macro, NULL); /* auto export! */ @@ -591,7 +591,7 @@ pic_macro_macroexpand_1(pic_state *pic) pic_get_args(pic, "o", &expr); - val = macroexpand_one(pic, expr, pic->lib->senv); + val = macroexpand_one(pic, expr, pic->lib->env); if (pic_undef_p(val)) { return pic_values2(pic, expr, pic_false_value()); } diff --git a/src/vm.c b/src/vm.c index 8a2430a0..7dc788cc 100644 --- a/src/vm.c +++ b/src/vm.c @@ -376,7 +376,7 @@ global_ref(pic_state *pic, const char *name) pic_sym sym, rename; sym = pic_intern_cstr(pic, name); - if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) { + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { return SIZE_MAX; } if (! (e = xh_get_int(&pic->global_tbl, rename))) { @@ -398,7 +398,7 @@ global_def(pic_state *pic, const char *name) } /* register to the senv */ - rename = pic_add_rename(pic, pic->lib->senv, sym); + rename = pic_add_rename(pic, pic->lib->env, sym); /* register to the global table */ gidx = pic->glen++;