From b75736874861a9bd0de8074dfc249d6809c6d29c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 25 Mar 2014 14:12:53 +0900 Subject: [PATCH] add renamer APIs --- include/picrin/macro.h | 4 ++ src/codegen.c | 8 ++-- src/macro.c | 86 +++++++++++++++++++++++++++--------------- src/vm.c | 15 +++----- 4 files changed, 70 insertions(+), 43 deletions(-) diff --git a/include/picrin/macro.h b/include/picrin/macro.h index f1ca1b12..e34b63c6 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -41,6 +41,10 @@ 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); +pic_sym pic_find_rename(pic_state *, struct pic_senv *, pic_sym); /* may return 0! */ +void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym); + #if defined(__cplusplus) } #endif diff --git a/src/codegen.c b/src/codegen.c index 5c458317..c17da0f0 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -49,10 +49,12 @@ static void pop_scope(analyze_state *); } while (0) #define register_renamed_symbol(pic, state, slot, lib, id) do { \ - xh_entry *e; \ - if (! (e = xh_get_int(lib->senv->name, pic_intern_cstr(pic, id)))) \ + pic_sym sym, gsym; \ + sym = pic_intern_cstr(pic, id); \ + if ((gsym = pic_find_rename(pic, lib->senv, sym)) == 0) { \ pic_error(pic, "internal error! native VM procedure not found"); \ - state->slot = e->val; \ + } \ + state->slot = gsym; \ } while (0) static analyze_state * diff --git a/src/macro.c b/src/macro.c index 014cc024..7a5cb6a3 100644 --- a/src/macro.c +++ b/src/macro.c @@ -10,6 +10,37 @@ #include "picrin/lib.h" #include "picrin/error.h" +pic_sym +pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) +{ + pic_sym rename; + + rename = pic_gensym(pic, sym); + pic_put_rename(pic, senv, sym, rename); + return rename; +} + +void +pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename) +{ + UNUSED(pic); + + xh_put_int(senv->name, sym, rename); +} + +pic_sym +pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) +{ + xh_entry *e; + + UNUSED(pic); + + if ((e = xh_get_int(senv->name, sym)) == NULL) { + return 0; + } + return e->val; +} + static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); static pic_value macroexpand_list(pic_state *, pic_value, struct pic_senv *); @@ -30,7 +61,6 @@ senv_new_local(pic_state *pic, pic_value formals, struct pic_senv *up) { struct pic_senv *senv; pic_value a; - pic_sym sym; senv = senv_new(pic, up); @@ -43,15 +73,13 @@ senv_new_local(pic_state *pic, pic_value formals, struct pic_senv *up) if (! pic_sym_p(v)) { pic_error(pic, "syntax error"); } - sym = pic_sym(v); - xh_put_int(senv->name, sym, pic_gensym(pic, sym)); + pic_add_rename(pic, senv, pic_sym(v)); } if (! pic_sym_p(a)) { a = macroexpand(pic, a, up); } if (pic_sym_p(a)) { - sym = pic_sym(a); - xh_put_int(senv->name, sym, pic_gensym(pic, sym)); + pic_add_rename(pic, senv, pic_sym(a)); } else if (! pic_nil_p(a)) { pic_error(pic, "syntax error"); @@ -125,36 +153,35 @@ pic_import(pic_state *pic, pic_value spec) pic_symbol_name(pic, it.e->val)); #endif - xh_put_int(pic->lib->senv->name, (long)it.e->key, it.e->val); + pic_put_rename(pic, pic->lib->senv, (long)it.e->key, it.e->val); } } void pic_export(pic_state *pic, pic_sym sym) { - xh_entry *e; + pic_sym rename; - e = xh_get_int(pic->lib->senv->name, sym); - if (! e) { + rename = pic_find_rename(pic, pic->lib->senv, sym); + if (rename == 0) { pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym)); } - xh_put_int(pic->lib->exports, (long)e->key, e->val); + xh_put_int(pic->lib->exports, sym, rename); } void pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) { struct pic_macro *mac; - pic_sym sym, uniq; + pic_sym sym, rename; /* new macro */ mac = macro_new(pic, macro, NULL); /* symbol registration */ sym = pic_intern_cstr(pic, name); - uniq = pic_gensym(pic, sym); - xh_put_int(pic->lib->senv->name, sym, uniq); - xh_put_int(pic->macros, uniq, (long)mac); + rename = pic_add_rename(pic, pic->lib->senv, sym); + xh_put_int(pic->macros, rename, (long)mac); /* auto export! */ pic_export(pic, sym); @@ -163,14 +190,14 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) static pic_sym symbol_rename(pic_state *pic, pic_sym sym, struct pic_senv *senv) { - xh_entry *e; + pic_sym rename; if (! pic_interned_p(pic, sym)) { return sym; } while (true) { - if ((e = xh_get_int(senv->name, sym)) != NULL) { - return (pic_sym)e->val; + if ((rename = pic_find_rename(pic, senv, sym)) != 0) { + return rename; } if (! senv->up) break; @@ -260,7 +287,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) else if (tag == pic->sDEFINE_SYNTAX) { pic_value var, val; - pic_sym uniq; + pic_sym rename; struct pic_macro *mac; if (pic_length(pic, expr) != 3) { @@ -274,8 +301,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); } - uniq = pic_gensym(pic, pic_sym(var)); - xh_put_int(senv->name, pic_sym(var), uniq); + rename = pic_add_rename(pic, senv, pic_sym(var)); val = pic_cadr(pic, pic_cdr(pic, expr)); @@ -290,7 +316,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) } mac = macro_new(pic, pic_proc_ptr(v), senv); - xh_put_int(pic->macros, uniq, (long)mac); + xh_put_int(pic->macros, rename, (long)mac); pic_gc_arena_restore(pic, ai); return pic_none_value(); @@ -298,7 +324,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) else if (tag == pic->sDEFINE_MACRO) { pic_value var, val; - pic_sym uniq; + pic_sym rename; struct pic_macro *mac; if (pic_length(pic, expr) < 2) { @@ -322,8 +348,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) if (! pic_sym_p(var)) { pic_error(pic, "syntax error"); } - uniq = pic_gensym(pic, pic_sym(var)); - xh_put_int(senv->name, pic_sym(var), uniq); + rename = pic_add_rename(pic, senv, pic_sym(var)); pic_try { v = pic_eval(pic, val); @@ -336,7 +361,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) } mac = macro_new(pic, pic_proc_ptr(v), NULL); - xh_put_int(pic->macros, uniq, (long)mac); + xh_put_int(pic->macros, rename, (long)mac); pic_gc_arena_restore(pic, ai); return pic_none_value(); @@ -376,8 +401,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) if (! pic_sym_p(a)) { pic_error(pic, "binding to non-symbol object"); } - var = pic_sym(a); - xh_put_int(senv->name, var, pic_gensym(pic, var)); + pic_add_rename(pic, senv, pic_sym(a)); /* binding value */ v = pic_cons(pic, car, @@ -398,8 +422,8 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) } var = pic_sym(formals); /* do not make duplicate variable slot */ - if (xh_get_int(senv->name, var) == NULL) { - xh_put_int(senv->name, var, pic_gensym(pic, var)); + if (pic_find_rename(pic, senv, var) == 0) { + pic_add_rename(pic, senv, var); } v = pic_cons(pic, pic_symbol_value(tag), @@ -558,7 +582,7 @@ pic_null_syntactic_env(pic_state *pic) #define register_core_syntax(pic,senv,id) do { \ pic_sym sym = pic_intern_cstr(pic, id); \ - xh_put_int(senv->name, sym, sym); \ + pic_put_rename(pic, senv, sym, sym); \ } while (0) struct pic_senv * @@ -902,7 +926,7 @@ pic_init_macro(pic_state *pic) pic_deflibrary ("(picrin macro)") { /* export define-macro syntax */ - xh_put_int(pic->lib->senv->name, pic->sDEFINE_MACRO, pic->sDEFINE_MACRO); + pic_put_rename(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->sDEFINE_MACRO); pic_export(pic, pic->sDEFINE_MACRO); pic_defun(pic, "gensym", pic_macro_gensym); diff --git a/src/vm.c b/src/vm.c index 4cefff0b..0d3561ee 100644 --- a/src/vm.c +++ b/src/vm.c @@ -333,14 +333,13 @@ static size_t global_ref(pic_state *pic, const char *name) { xh_entry *e; - pic_sym sym; + pic_sym sym, rename; sym = pic_intern_cstr(pic, name); - if (! (e = xh_get_int(pic->lib->senv->name, sym))) { + if ((rename = pic_find_rename(pic, pic->lib->senv, sym)) == 0) { return SIZE_MAX; } - assert(e->val >= 0); - if (! (e = xh_get_int(pic->global_tbl, e->val))) { + if (! (e = xh_get_int(pic->global_tbl, rename))) { return SIZE_MAX; } return e->val; @@ -349,7 +348,7 @@ global_ref(pic_state *pic, const char *name) static size_t global_def(pic_state *pic, const char *name) { - pic_sym sym, gsym; + pic_sym sym, rename; size_t gidx; sym = pic_intern_cstr(pic, name); @@ -358,17 +357,15 @@ global_def(pic_state *pic, const char *name) return gidx; } - gsym = pic_gensym(pic, sym); - /* register to the senv */ - xh_put_int(pic->lib->senv->name, sym, gsym); + rename = pic_add_rename(pic, pic->lib->senv, sym); /* register to the global table */ gidx = pic->glen++; if (pic->glen >= pic->gcapa) { pic_error(pic, "global table overflow"); } - xh_put_int(pic->global_tbl, gsym, gidx); + xh_put_int(pic->global_tbl, rename, gidx); return gidx; }