diff --git a/include/picrin/macro.h b/include/picrin/macro.h index b22de253..dac3ea72 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -37,8 +37,6 @@ struct pic_sc { #define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v)) struct pic_senv *pic_null_syntactic_env(pic_state *); -struct pic_senv *pic_minimal_syntactic_env(pic_state *); -struct pic_senv *pic_core_syntactic_env(pic_state *); pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym); bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */); diff --git a/src/init.c b/src/init.c index 4a8f323a..5c6142c5 100644 --- a/src/init.c +++ b/src/init.c @@ -85,14 +85,21 @@ pic_init_core(pic_state *pic) pic_deflibrary ("(scheme base)") { /* load core syntaces */ - pic->lib->senv = pic_core_syntactic_env(pic); - pic_export(pic, pic_intern_cstr(pic, "define")); - pic_export(pic, pic_intern_cstr(pic, "set!")); - pic_export(pic, pic_intern_cstr(pic, "quote")); - pic_export(pic, pic_intern_cstr(pic, "lambda")); - pic_export(pic, pic_intern_cstr(pic, "if")); - pic_export(pic, pic_intern_cstr(pic, "begin")); - pic_export(pic, pic_intern_cstr(pic, "define-syntax")); + pic->lib->senv = pic_null_syntactic_env(pic); + pic_put_rename(pic, pic->lib->senv, pic->sDEFINE, pic->sDEFINE); + pic_put_rename(pic, pic->lib->senv, pic->sSETBANG, pic->sSETBANG); + pic_put_rename(pic, pic->lib->senv, pic->sQUOTE, pic->sQUOTE); + pic_put_rename(pic, pic->lib->senv, pic->sLAMBDA, pic->sLAMBDA); + pic_put_rename(pic, pic->lib->senv, pic->sIF, pic->sIF); + pic_put_rename(pic, pic->lib->senv, pic->sBEGIN, pic->sBEGIN); + pic_put_rename(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->sDEFINE_SYNTAX); + pic_export(pic, pic->sDEFINE); + pic_export(pic, pic->sSETBANG); + pic_export(pic, pic->sQUOTE); + pic_export(pic, pic->sLAMBDA); + pic_export(pic, pic->sIF); + pic_export(pic, pic->sBEGIN); + pic_export(pic, pic->sDEFINE_SYNTAX); pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/src/lib.c b/src/lib.c index adb34b31..003ff6f6 100644 --- a/src/lib.c +++ b/src/lib.c @@ -24,7 +24,7 @@ pic_make_library(pic_state *pic, pic_value name) return lib; } - senv = pic_minimal_syntactic_env(pic); + senv = pic_null_syntactic_env(pic); lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); lib->senv = senv; diff --git a/src/macro.c b/src/macro.c index 508c2904..9d2cb441 100644 --- a/src/macro.c +++ b/src/macro.c @@ -20,14 +20,6 @@ pic_null_syntactic_env(pic_state *pic) senv->up = NULL; xh_init_int(&senv->renames, sizeof(pic_sym)); - return senv; -} - -struct pic_senv * -pic_minimal_syntactic_env(pic_state *pic) -{ - struct pic_senv *senv = pic_null_syntactic_env(pic); - pic_put_rename(pic, senv, pic->sDEFINE_LIBRARY, pic->sDEFINE_LIBRARY); pic_put_rename(pic, senv, pic->sIMPORT, pic->sIMPORT); pic_put_rename(pic, senv, pic->sEXPORT, pic->sEXPORT); @@ -35,57 +27,6 @@ pic_minimal_syntactic_env(pic_state *pic) return senv; } -struct pic_senv * -pic_core_syntactic_env(pic_state *pic) -{ - struct pic_senv *senv = pic_minimal_syntactic_env(pic); - - pic_put_rename(pic, senv, pic->sDEFINE, pic->sDEFINE); - pic_put_rename(pic, senv, pic->sSETBANG, pic->sSETBANG); - pic_put_rename(pic, senv, pic->sQUOTE, pic->sQUOTE); - pic_put_rename(pic, senv, pic->sLAMBDA, pic->sLAMBDA); - pic_put_rename(pic, senv, pic->sIF, pic->sIF); - pic_put_rename(pic, senv, pic->sBEGIN, pic->sBEGIN); - pic_put_rename(pic, senv, pic->sDEFINE_SYNTAX, pic->sDEFINE_SYNTAX); - - return senv; -} - -static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, pic_value); - -static struct pic_senv * -push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box) -{ - struct pic_senv *senv; - pic_value a; - - senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); - senv->up = up; - xh_init_int(&senv->renames, sizeof(pic_sym)); - - for (a = formals; 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, up, assoc_box); - } - if (! pic_sym_p(v)) { - pic_error(pic, "syntax error"); - } - pic_add_rename(pic, senv, pic_sym(v)); - } - if (! pic_sym_p(a)) { - a = macroexpand(pic, a, up, assoc_box); - } - if (pic_sym_p(a)) { - pic_add_rename(pic, senv, pic_sym(a)); - } - else if (! pic_nil_p(a)) { - pic_error(pic, "syntax error"); - } - return senv; -} - pic_sym pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) { @@ -209,6 +150,39 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value ass return v; } +static struct pic_senv * +push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box) +{ + struct pic_senv *senv; + pic_value a; + + senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + senv->up = up; + xh_init_int(&senv->renames, sizeof(pic_sym)); + + for (a = formals; 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, up, assoc_box); + } + if (! pic_sym_p(v)) { + pic_error(pic, "syntax error"); + } + pic_add_rename(pic, senv, pic_sym(v)); + } + if (! pic_sym_p(a)) { + a = macroexpand(pic, a, up, assoc_box); + } + if (pic_sym_p(a)) { + pic_add_rename(pic, senv, pic_sym(a)); + } + else if (! pic_nil_p(a)) { + pic_error(pic, "syntax error"); + } + return senv; +} + static pic_value macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box) {