diff --git a/include/picrin.h b/include/picrin.h index 2d14dc68..ff0b1a78 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, sDEFINE_MACRO, sLET_SYNTAX; + pic_sym sDEFINE_SYNTAX, sLET_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, rDEFINE_MACRO, rLET_SYNTAX; + pic_sym rDEFINE_SYNTAX, rLET_SYNTAX; pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT; xhash syms; /* name to symbol */ diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index 9c3d482e..2f9fe7e0 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -124,10 +124,25 @@ (rename sym))) (f (walk inject expr) inject compare)))) + (define-syntax define-macro + (er-macro-transformer + (lambda (expr r c) + (define formal (car (cdr expr))) + (define body (cdr (cdr expr))) + (if (symbol? formal) + (list (r 'define-syntax) formal + (list (r 'lambda) (list (r 'form) '_ '_) + (list (r 'apply) (car body) (list (r 'cdr) (r 'form))))) + (list (r 'define-macro) (car formal) + (cons (r 'lambda) + (cons (cdr formal) + body))))))) + (export make-syntactic-closure close-syntax capture-syntactic-environment sc-macro-transformer rsc-macro-transformer er-macro-transformer - ir-macro-transformer)) + ir-macro-transformer + define-macro)) diff --git a/src/macro.c b/src/macro.c index 13eea311..b69855c8 100644 --- a/src/macro.c +++ b/src/macro.c @@ -316,53 +316,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) return pic_none_value(); } -static pic_value -macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - pic_value var, val; - pic_sym sym, rename; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - var = pic_car(pic, pic_cdr(pic, expr)); - if (pic_pair_p(var)) { - /* FIXME: unhygienic */ - val = pic_cons(pic, pic_sym_value(pic->sLAMBDA), - pic_cons(pic, pic_cdr(pic, var), - pic_cdr(pic, pic_cdr(pic, expr)))); - var = pic_car(pic, var); - } - else { - if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax_error"); - } - val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr))); - } - if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); - } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); - } - - pic_try { - val = pic_eval(pic, val); - } pic_catch { - pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); - } - - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - define_macro(pic, rename, pic_proc_ptr(val), NULL); - - return pic_none_value(); -} - static pic_value macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv) { @@ -471,9 +424,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->rDEFINE_MACRO) { - return macroexpand_defmacro(pic, expr, senv); - } else if (tag == pic->rLET_SYNTAX) { return macroexpand_let_syntax(pic, expr, senv); } @@ -693,10 +643,6 @@ void pic_init_macro(pic_state *pic) { pic_deflibrary ("(picrin macro)") { - - /* export define-macro syntax */ - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->rDEFINE_MACRO); - pic_defun(pic, "gensym", pic_macro_gensym); pic_defun(pic, "macroexpand", pic_macro_macroexpand); pic_defun(pic, "identifier?", pic_macro_identifier_p); diff --git a/src/state.c b/src/state.c index 9da1852c..b910baed 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, sDEFINE_MACRO, "define-macro"); register_core_symbol(pic, sLET_SYNTAX, "let-syntax"); register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); register_core_symbol(pic, sIMPORT, "import"); @@ -129,7 +128,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, rDEFINE_MACRO, "define-macro"); register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax"); register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); register_renamed_symbol(pic, rIMPORT, "import");