diff --git a/include/picrin.h b/include/picrin.h index 2bf9f9fd..6b6629a5 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -81,6 +81,7 @@ typedef struct { pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG; pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO; + pic_sym sLET_SYNTAX, sLETREC_SYNTAX; pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT; pic_sym sCONS, sCAR, sCDR, sNILP; pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; @@ -127,6 +128,13 @@ void pic_gc_run(pic_state *); pic_value pic_gc_protect(pic_state *, pic_value); size_t pic_gc_arena_preserve(pic_state *); void pic_gc_arena_restore(pic_state *, size_t); +#define pic_void(exec) \ + pic_void_(GENSYM(ai), exec) +#define pic_void_(ai,exec) do { \ + size_t ai = pic_gc_arena_preserve(pic); \ + exec; \ + pic_gc_arena_restore(pic, ai); \ + } while (0) pic_state *pic_open(int argc, char *argv[], char **envp); void pic_close(pic_state *); diff --git a/include/picrin/dict.h b/include/picrin/dict.h index ae118e13..8bc58ad8 100644 --- a/include/picrin/dict.h +++ b/include/picrin/dict.h @@ -23,6 +23,7 @@ pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym); void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value); void pic_dict_del(pic_state *, struct pic_dict *, pic_sym); size_t pic_dict_size(pic_state *, struct pic_dict *); +bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym); #if defined(__cplusplus) } diff --git a/src/dict.c b/src/dict.c index e9fd5e80..d3eb895b 100644 --- a/src/dict.c +++ b/src/dict.c @@ -44,6 +44,14 @@ pic_dict_size(pic_state *pic, struct pic_dict *dict) return dict->hash.count; } +bool +pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key) +{ + UNUSED(pic); + + return xh_get_int(&dict->hash, key) != NULL; +} + void pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key) { diff --git a/src/init.c b/src/init.c index 5770d819..b6051a3f 100644 --- a/src/init.c +++ b/src/init.c @@ -75,6 +75,8 @@ pic_init_core(pic_state *pic) pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX); pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/src/macro.c b/src/macro.c index ea200e7d..c9da6aee 100644 --- a/src/macro.c +++ b/src/macro.c @@ -9,33 +9,7 @@ #include "picrin/macro.h" #include "picrin/lib.h" #include "picrin/error.h" -#include "picrin/box.h" - -struct pic_senv * -pic_null_syntactic_environment(pic_state *pic) -{ - struct pic_senv *senv; - - senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); - senv->up = NULL; - xh_init_int(&senv->renames, sizeof(pic_sym)); - - pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY); - pic_define_syntactic_keyword(pic, senv, pic->sIMPORT); - pic_define_syntactic_keyword(pic, senv, pic->sEXPORT); - - return senv; -} - -void -pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym) -{ - pic_put_rename(pic, senv, sym, sym); - - if (pic->lib && pic->lib->senv == senv) { - pic_export(pic, sym); - } -} +#include "picrin/dict.h" pic_sym pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) @@ -94,108 +68,10 @@ find_macro(pic_state *pic, pic_sym rename) return xh_val(e, struct pic_macro *); } -void -pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) -{ - pic_sym sym, rename; - - /* symbol registration */ - sym = pic_intern_cstr(pic, name); - rename = pic_add_rename(pic, pic->lib->senv, sym); - define_macro(pic, rename, macro, NULL); - - /* auto export! */ - pic_export(pic, sym); -} - -static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, pic_value); - -static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v; - - v = macroexpand_node(pic, expr, senv, assoc_box); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - 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) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v, vs; - - /* macroexpand in order */ - vs = pic_nil_value(); - while (pic_pair_p(list)) { - v = pic_car(pic, list); - - vs = pic_cons(pic, macroexpand(pic, v, senv, assoc_box), vs); - list = pic_cdr(pic, list); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, vs); - pic_gc_protect(pic, list); - } - - list = macroexpand(pic, list, senv, assoc_box); - - /* reverse the result */ - pic_for_each (v, vs) { - list = pic_cons(pic, v, list); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, vs); - pic_gc_protect(pic, list); - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, list); - return list; -} - static pic_sym -macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) +translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { pic_sym rename; - pic_value x; if (! pic_interned_p(pic, sym)) { return sym; @@ -208,48 +84,27 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value break; senv = senv->up; } - x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box)); - if (pic_test(x)) { - return pic_sym(pic_cdr(pic, x)); + if (pic_dict_has(pic, cxt, sym)) { + return pic_sym(pic_dict_ref(pic, cxt, sym)); } else { rename = pic_gensym(pic, sym); - pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box))); + pic_dict_set(pic, cxt, sym, pic_sym_value(rename)); return rename; } } +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *); + static pic_value -macroexpand_deflibrary(pic_state *pic, pic_value expr) +macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { - struct pic_lib *prev = pic->lib; - pic_value v; + return pic_sym_value(translate(pic, sym, senv, cxt)); +} - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - pic_make_library(pic, pic_cadr(pic, expr)); - - pic_try { - pic_in_library(pic, pic_cadr(pic, expr)); - - pic_for_each (v, pic_cddr(pic, expr)) { - size_t ai = pic_gc_arena_preserve(pic); - - pic_eval(pic, v); - - pic_gc_arena_restore(pic, ai); - } - - pic_in_library(pic, prev->name); - } - pic_catch { - /* restores pic->lib even if an error occurs */ - pic_in_library(pic, prev->name); - pic_throw_error(pic, pic->err); - } - - return pic_none_value(); +static pic_value +macroexpand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr)); } static pic_value @@ -301,7 +156,135 @@ macroexpand_export(pic_state *pic, pic_value expr) } static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_deflibrary(pic_state *pic, pic_value expr) +{ + struct pic_lib *prev = pic->lib; + pic_value v; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + pic_make_library(pic, pic_cadr(pic, expr)); + + pic_try { + pic_in_library(pic, pic_cadr(pic, expr)); + + pic_for_each (v, pic_cddr(pic, expr)) { + pic_void(pic_eval(pic, v)); + } + + pic_in_library(pic, prev->name); + } + pic_catch { + pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */ + pic_throw_error(pic, pic->err); + } + + return pic_none_value(); +} + +static pic_value +macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value x, head, tail; + + if (pic_pair_p(obj)) { + head = macroexpand(pic, pic_car(pic, obj), senv, cxt); + tail = macroexpand_list(pic, pic_cdr(pic, obj), senv, cxt); + x = pic_cons(pic, head, tail); + } else { + x = macroexpand(pic, obj, senv, cxt); + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, x); + return x; +} + +static pic_value +macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + pic_value formal, body; + struct pic_senv *in; + pic_value a; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + in->up = senv; + xh_init_int(&in->renames, sizeof(pic_sym)); + + 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, cxt); + } + 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, cxt); + } + if (pic_sym_p(a)) { + pic_add_rename(pic, in, pic_sym(a)); + } + else if (! pic_nil_p(a)) { + pic_error(pic, "syntax error"); + } + + formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt); + body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt); + + return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body)); +} + +static pic_value +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + pic_sym sym; + pic_value formal, body, var, val; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + formal = pic_cadr(pic, expr); + if (pic_pair_p(formal)) { + var = pic_car(pic, formal); + } else { + if (pic_length(pic, expr) != 3) { + pic_error(pic, "syntax error"); + } + var = formal; + } + if (! pic_sym_p(var)) { + var = macroexpand(pic, var, senv, cxt); + } + if (! pic_sym_p(var)) { + pic_error(pic, "binding to non-symbol object"); + } + sym = pic_sym(var); + if (! pic_find_rename(pic, senv, sym, NULL)) { + pic_add_rename(pic, senv, sym); + } + body = pic_cddr(pic, expr); + if (pic_pair_p(formal)) { + val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv, cxt); + } else { + val = macroexpand(pic, pic_car(pic, body), senv, cxt); + } + return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); +} + +static pic_value +macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { pic_value var, val; pic_sym sym, rename; @@ -312,7 +295,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic var = pic_cadr(pic, expr); if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv, assoc_box); + var = macroexpand(pic, var, senv, cxt); } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); @@ -387,73 +370,47 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) } static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { - pic_sym sym; - pic_value formals; + struct pic_senv *in; + pic_value formal, v, var, val; + pic_sym sym, rename; + + in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + in->up = senv; + xh_init_int(&in->renames, sizeof(pic_sym)); if (pic_length(pic, expr) < 2) { pic_error(pic, "syntax error"); } - formals = pic_cadr(pic, expr); - if (pic_pair_p(formals)) { - struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, assoc_box); - pic_value a; - - /* defined symbol */ - a = pic_car(pic, formals); - if (! pic_sym_p(a)) { - a = macroexpand(pic, a, senv, assoc_box); + 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)) { + var = macroexpand(pic, var, senv, cxt); } - if (! pic_sym_p(a)) { + if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); } - sym = pic_sym(a); - if (! pic_find_rename(pic, senv, sym, NULL)) { - pic_add_rename(pic, senv, sym); + sym = pic_sym(var); + if (! pic_find_rename(pic, in, sym, &rename)) { + rename = pic_add_rename(pic, in, sym); } - - /* binding value */ - return pic_cons(pic, pic_sym_value(pic->sDEFINE), - pic_cons(pic, - macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box), - macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); + 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); } - - if (! pic_sym_p(formals)) { - formals = macroexpand(pic, formals, senv, assoc_box); - } - if (! pic_sym_p(formals)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(formals); - if (! pic_find_rename(pic, senv, sym, NULL)) { - pic_add_rename(pic, senv, sym); - } - - return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); + return pic_cons(pic, pic_sym_value(pic->sBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)); } static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) -{ - struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, assoc_box); - - return pic_cons(pic, pic_sym_value(pic->sLAMBDA), - pic_cons(pic, - macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box), - macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); -} - -static pic_value -macroexpand_quote(pic_state *pic, pic_value expr) -{ - return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr)); -} - -static pic_value -macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { pic_value v, args; @@ -482,11 +439,11 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct puts(""); #endif - return macroexpand(pic, v, senv, assoc_box); + return macroexpand(pic, v, senv, cxt); } static pic_value -macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { #if DEBUG printf("[macroexpand] expanding... "); @@ -496,10 +453,10 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu switch (pic_type(expr)) { case PIC_TT_SC: { - return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box); + return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, cxt); } case PIC_TT_SYMBOL: { - return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box)); + return macroexpand_symbol(pic, pic_sym(expr), senv, cxt); } case PIC_TT_PAIR: { pic_value car; @@ -509,7 +466,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); } - car = macroexpand(pic, pic_car(pic, expr), senv, assoc_box); + car = macroexpand(pic, pic_car(pic, expr), senv, cxt); if (pic_sym_p(car)) { pic_sym tag = pic_sym(car); @@ -523,27 +480,33 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu return macroexpand_export(pic, expr); } else if (tag == pic->sDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, senv, assoc_box); + return macroexpand_defsyntax(pic, expr, senv, cxt); } else if (tag == pic->sDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, senv); } + else if (tag == pic->sLET_SYNTAX) { + return macroexpand_let_syntax(pic, expr, senv, cxt); + } + /* else if (tag == pic->sLETREC_SYNTAX) { */ + /* return macroexpand_letrec_syntax(pic, expr, senv, cxt); */ + /* } */ else if (tag == pic->sLAMBDA) { - return macroexpand_lambda(pic, expr, senv, assoc_box); + return macroexpand_lambda(pic, expr, senv, cxt); } else if (tag == pic->sDEFINE) { - return macroexpand_define(pic, expr, senv, assoc_box); + return macroexpand_define(pic, expr, senv, cxt); } else if (tag == pic->sQUOTE) { return macroexpand_quote(pic, expr); } if ((mac = find_macro(pic, tag)) != NULL) { - return macroexpand_macro(pic, mac, expr, senv, assoc_box); + return macroexpand_macro(pic, mac, expr, senv, cxt); } } - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); + return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt)); } case PIC_TT_EOF: case PIC_TT_NIL: @@ -575,10 +538,23 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu UNREACHABLE(); } +static pic_value +macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value v; + + v = macroexpand_node(pic, expr, senv, cxt); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; +} + pic_value pic_macroexpand(pic_state *pic, pic_value expr) { - pic_value v, box; + pic_value v; #if DEBUG puts("before expand:"); @@ -586,9 +562,7 @@ pic_macroexpand(pic_state *pic, pic_value expr) puts(""); #endif - box = pic_box(pic, pic_nil_value()); - - v = macroexpand(pic, expr, pic->lib->senv, box); + v = macroexpand(pic, expr, pic->lib->senv, pic_dict_new(pic)); #if DEBUG puts("after expand:"); @@ -599,6 +573,46 @@ pic_macroexpand(pic_state *pic, pic_value expr) return v; } +struct pic_senv * +pic_null_syntactic_environment(pic_state *pic) +{ + struct pic_senv *senv; + + senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + senv->up = NULL; + xh_init_int(&senv->renames, sizeof(pic_sym)); + + pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY); + pic_define_syntactic_keyword(pic, senv, pic->sIMPORT); + pic_define_syntactic_keyword(pic, senv, pic->sEXPORT); + + return senv; +} + +void +pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym) +{ + pic_put_rename(pic, senv, sym, sym); + + if (pic->lib && pic->lib->senv == senv) { + pic_export(pic, sym); + } +} + +void +pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) +{ + pic_sym sym, rename; + + /* symbol registration */ + sym = pic_intern_cstr(pic, name); + rename = pic_add_rename(pic, pic->lib->senv, sym); + define_macro(pic, rename, macro, NULL); + + /* auto export! */ + pic_export(pic, sym); +} + static pic_value pic_macro_gensym(pic_state *pic) { @@ -647,16 +661,16 @@ sc_identifier_p(pic_value obj) static bool sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y) { - pic_value box; + struct pic_dict *cxt; if (! (sc_identifier_p(x) && sc_identifier_p(y))) { return false; } - box = pic_box(pic, pic_nil_value()); + cxt = pic_dict_new(pic); - x = macroexpand(pic, x, e1, box); - y = macroexpand(pic, y, e2, box); + x = macroexpand(pic, x, e1, cxt); + y = macroexpand(pic, y, e2, cxt); return pic_eq_p(x, y); } @@ -713,14 +727,14 @@ er_macro_rename(pic_state *pic) { pic_sym sym; struct pic_senv *mac_env; - pic_value assoc_box; + struct pic_dict *cxt; pic_get_args(pic, "m", &sym); mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); - assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); + cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - return pic_sym_value(macroexpand_symbol(pic, sym, mac_env, assoc_box)); + return pic_sym_value(translate(pic, sym, mac_env, cxt)); } static pic_value @@ -729,7 +743,7 @@ er_macro_compare(pic_state *pic) pic_value a, b; struct pic_senv *use_env; pic_sym m, n; - pic_value assoc_box; + struct pic_dict *cxt; pic_get_args(pic, "oo", &a, &b); @@ -737,10 +751,10 @@ er_macro_compare(pic_state *pic) return pic_false_value(); /* should be an error? */ use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); - assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); + cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - m = macroexpand_symbol(pic, pic_sym(a), use_env, assoc_box); - n = macroexpand_symbol(pic, pic_sym(b), use_env, assoc_box); + m = translate(pic, pic_sym(a), use_env, cxt); + n = translate(pic, pic_sym(b), use_env, cxt); return pic_bool_value(m == n); } @@ -748,8 +762,9 @@ er_macro_compare(pic_state *pic) static pic_value er_macro_call(pic_state *pic) { - pic_value expr, use_env, mac_env, box; + pic_value expr, use_env, mac_env; struct pic_proc *rename, *compare, *cb; + struct pic_dict *cxt; pic_get_args(pic, "ooo", &expr, &use_env, &mac_env); @@ -760,19 +775,19 @@ er_macro_call(pic_state *pic) pic_error(pic, "unexpected type of argument 3"); } - box = pic_box(pic, pic_nil_value()); + cxt = pic_dict_new(pic); rename = pic_proc_new(pic, er_macro_rename, ""); pic_proc_cv_init(pic, rename, 3); pic_proc_cv_set(pic, rename, 0, use_env); pic_proc_cv_set(pic, rename, 1, mac_env); - pic_proc_cv_set(pic, rename, 2, box); + pic_proc_cv_set(pic, rename, 2, pic_obj_value(cxt)); compare = pic_proc_new(pic, er_macro_compare, ""); pic_proc_cv_init(pic, compare, 3); pic_proc_cv_set(pic, compare, 0, use_env); pic_proc_cv_set(pic, compare, 1, mac_env); - pic_proc_cv_set(pic, compare, 2, box); + pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt)); cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); @@ -798,14 +813,14 @@ ir_macro_inject(pic_state *pic) { pic_sym sym; struct pic_senv *use_env; - pic_value assoc_box; + struct pic_dict *cxt; pic_get_args(pic, "m", &sym); use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); - assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); + cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - return pic_sym_value(macroexpand_symbol(pic, sym, use_env, assoc_box)); + return pic_sym_value(translate(pic, sym, use_env, cxt)); } static pic_value @@ -814,7 +829,7 @@ ir_macro_compare(pic_state *pic) pic_value a, b; struct pic_senv *mac_env; pic_sym m, n; - pic_value assoc_box; + struct pic_dict *cxt; pic_get_args(pic, "oo", &a, &b); @@ -822,27 +837,27 @@ ir_macro_compare(pic_state *pic) return pic_false_value(); /* should be an error? */ mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); - assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); + cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - m = macroexpand_symbol(pic, pic_sym(a), mac_env, assoc_box); - n = macroexpand_symbol(pic, pic_sym(b), mac_env, assoc_box); + m = translate(pic, pic_sym(a), mac_env, cxt); + n = translate(pic, pic_sym(b), mac_env, cxt); return pic_bool_value(m == n); } static pic_value -ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_value assoc_box, pic_value *ir) +ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct pic_dict *cxt, pic_value *ir) { if (pic_sym_p(expr)) { pic_value r; - r = pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), use_env, assoc_box)); + r = pic_sym_value(translate(pic, pic_sym(expr), use_env, cxt)); *ir = pic_acons(pic, r, expr, *ir); return r; } else if (pic_pair_p(expr)) { return pic_cons(pic, - ir_macro_wrap(pic, pic_car(pic, expr), use_env, assoc_box, ir), - ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, assoc_box, ir)); + ir_macro_wrap(pic, pic_car(pic, expr), use_env, cxt, ir), + ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, cxt, ir)); } else { return expr; @@ -850,19 +865,19 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu } static pic_value -ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_value assoc_box, pic_value *ir) +ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct pic_dict *cxt, pic_value *ir) { if (pic_sym_p(expr)) { pic_value r; if (pic_test(r = pic_assq(pic, expr, *ir))) { return pic_cdr(pic, r); } - return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), mac_env, assoc_box)); + return pic_sym_value(translate(pic, pic_sym(expr), mac_env, cxt)); } else if (pic_pair_p(expr)) { return pic_cons(pic, - ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, assoc_box, ir), - ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, assoc_box, ir)); + ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, cxt, ir), + ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, cxt, ir)); } else { return expr; @@ -872,8 +887,9 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_va static pic_value ir_macro_call(pic_state *pic) { - pic_value expr, use_env, mac_env, box; + pic_value expr, use_env, mac_env; struct pic_proc *inject, *compare, *cb; + struct pic_dict *cxt; pic_value ir = pic_nil_value(); pic_get_args(pic, "ooo", &expr, &use_env, &mac_env); @@ -885,25 +901,25 @@ ir_macro_call(pic_state *pic) pic_error(pic, "unexpected type of argument 3"); } - box = pic_box(pic, pic_nil_value()); + cxt = pic_dict_new(pic); inject = pic_proc_new(pic, ir_macro_inject, ""); pic_proc_cv_init(pic, inject, 3); pic_proc_cv_set(pic, inject, 0, use_env); pic_proc_cv_set(pic, inject, 1, mac_env); - pic_proc_cv_set(pic, inject, 2, box); + pic_proc_cv_set(pic, inject, 2, pic_obj_value(cxt)); compare = pic_proc_new(pic, ir_macro_compare, ""); pic_proc_cv_init(pic, compare, 3); pic_proc_cv_set(pic, compare, 0, use_env); pic_proc_cv_set(pic, compare, 1, mac_env); - pic_proc_cv_set(pic, compare, 2, box); + pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt)); cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); - expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), box, &ir); + expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), cxt, &ir); expr = pic_apply3(pic, cb, expr, pic_obj_value(inject), pic_obj_value(compare)); - expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), box, &ir); + expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), cxt, &ir); return expr; } diff --git a/src/state.c b/src/state.c index 63a25254..9db4986b 100644 --- a/src/state.c +++ b/src/state.c @@ -96,6 +96,8 @@ pic_open(int argc, char *argv[], char **envp) 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, sLETREC_SYNTAX, "letrec-syntax"); register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); register_core_symbol(pic, sIMPORT, "import"); register_core_symbol(pic, sEXPORT, "export");