From ef04e3f02c2fe105f46d8915046d6936e00a89dd Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 6 Dec 2013 18:04:36 +0900 Subject: [PATCH] add pic_core_syntactic_env --- include/picrin.h | 5 +---- include/picrin/macro.h | 3 +++ src/gc.c | 12 +++++------- src/macro.c | 44 +++++++++++++++++++++++++++++++----------- src/state.c | 24 +++-------------------- 5 files changed, 45 insertions(+), 43 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index ba688f02..ff241611 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -56,10 +56,7 @@ typedef struct { pic_value *globals; size_t glen, gcapa; - /* positive for variables, negative for macros (bitwise-not) */ - struct xhash *var_tbl; - struct pic_syntax **stx; - size_t xlen, xcapa; + struct pic_senv *global_senv; struct pic_irep **irep; size_t ilen, icapa; diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 17be817d..c10f1e5a 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -4,6 +4,7 @@ struct pic_senv { PIC_OBJECT_HEADER struct pic_senv *up; + /* positive for variables, negative for macros (bitwise-not) */ struct xhash *tbl; struct pic_syntax **stx; size_t xlen, xcapa; @@ -42,6 +43,8 @@ struct pic_sc { #define pic_senv(v) ((struct pic_senv *)pic_ptr(v)) #define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV) +struct pic_senv *pic_core_syntactic_env(pic_state *pic); + struct pic_syntax *pic_syntax_new(pic_state *, int kind, pic_sym sym); struct pic_syntax *pic_syntax_new_macro(pic_state *, pic_sym, struct pic_proc *, struct pic_senv *senv); diff --git a/src/gc.c b/src/gc.c index 8049a2af..7a064729 100644 --- a/src/gc.c +++ b/src/gc.c @@ -458,8 +458,8 @@ gc_mark_phase(pic_state *pic) } /* macros */ - for (i = 0; i < pic->xlen; ++i) { - gc_mark_object(pic, (struct pic_object *)pic->stx[i]); + if (pic->global_senv) { + gc_mark_object(pic, (struct pic_object *)pic->global_senv); } /* pool */ @@ -522,11 +522,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_SENV: { struct pic_senv *senv = (struct pic_senv *)obj; - if (senv->up) { - xh_destory(senv->tbl); - if (senv->stx) - pic_free(pic, senv->stx); - } + xh_destory(senv->tbl); + if (senv->stx) + pic_free(pic, senv->stx); break; } case PIC_TT_SYNTAX: { diff --git a/src/macro.c b/src/macro.c index a0417e3c..8048f4fe 100644 --- a/src/macro.c +++ b/src/macro.c @@ -29,20 +29,42 @@ new_uniq_sym(pic_state *pic, pic_sym base) return uniq; } -static struct pic_senv * -new_global_senv(pic_state *pic) +struct pic_senv * +pic_core_syntactic_env(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; - senv->tbl = pic->var_tbl; - senv->stx = pic->stx; - senv->xlen = pic->xlen; - senv->xcapa = pic->xcapa; + senv->tbl = xh_new(); + senv->stx = (struct pic_syntax **)pic_calloc(pic, PIC_MACROS_SIZE, sizeof(struct pic_syntax *)); + senv->xlen = 0; + senv->xcapa = PIC_MACROS_SIZE; + +#define register_core_syntax(pic,senv,kind,name) do { \ + senv->stx[senv->xlen] = pic_syntax_new(pic, kind, pic_intern_cstr(pic, name)); \ + xh_put(senv->tbl, name, ~senv->xlen); \ + senv->xlen++; \ + } while (0) + + register_core_syntax(pic, senv, PIC_STX_DEFINE, "define"); + register_core_syntax(pic, senv, PIC_STX_SET, "set!"); + register_core_syntax(pic, senv, PIC_STX_QUOTE, "quote"); + register_core_syntax(pic, senv, PIC_STX_LAMBDA, "lambda"); + register_core_syntax(pic, senv, PIC_STX_IF, "if"); + register_core_syntax(pic, senv, PIC_STX_BEGIN, "begin"); + register_core_syntax(pic, senv, PIC_STX_DEFMACRO, "define-macro"); + register_core_syntax(pic, senv, PIC_STX_DEFSYNTAX, "define-syntax"); + return senv; } +static struct pic_senv * +new_global_senv(pic_state *pic) +{ + return pic->global_senv; +} + static struct pic_senv * new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up) { @@ -136,13 +158,13 @@ pic_defsyntax(pic_state *pic, const char *name, struct pic_proc *macro, struct p { int idx; - idx = pic->xlen; - if (idx >= pic->xcapa) { + idx = pic->global_senv->xlen; + if (idx >= pic->global_senv->xcapa) { pic_abort(pic, "macro table overflow"); } - pic->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro, mac_env); - xh_put(pic->var_tbl, name, ~idx); - pic->xlen++; + pic->global_senv->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro, mac_env); + xh_put(pic->global_senv->tbl, name, ~idx); + pic->global_senv->xlen++; } void diff --git a/src/state.c b/src/state.c index 0127f10b..51cc80f6 100644 --- a/src/state.c +++ b/src/state.c @@ -65,11 +65,9 @@ pic_open(int argc, char *argv[], char **envp) pic->glen = 0; pic->gcapa = PIC_GLOBALS_SIZE; - /* identifier table */ - pic->var_tbl = xh_new(); - pic->stx = (struct pic_syntax **)calloc(PIC_MACROS_SIZE, sizeof(struct pic_syntax *)); - pic->xlen = 0; - pic->xcapa = PIC_MACROS_SIZE; + /* syntactic env */ + pic->global_senv = NULL; /* prevent gc from hanging during marking phase */ + pic->global_senv = pic_core_syntactic_env(pic); /* pool */ pic->pool = (pic_value *)calloc(PIC_POOL_SIZE, sizeof(pic_value)); @@ -117,22 +115,6 @@ pic_open(int argc, char *argv[], char **envp) register_core_symbol(pic, sGE, ">="); pic_gc_arena_restore(pic, ai); -#define register_core_syntax(pic,kind,name) do { \ - pic->stx[pic->xlen] = pic_syntax_new(pic, kind, pic_intern_cstr(pic, name)); \ - xh_put(pic->var_tbl, name, ~pic->xlen); \ - pic->xlen++; \ - } while (0) - - register_core_syntax(pic, PIC_STX_DEFINE, "define"); - register_core_syntax(pic, PIC_STX_SET, "set!"); - register_core_syntax(pic, PIC_STX_QUOTE, "quote"); - register_core_syntax(pic, PIC_STX_LAMBDA, "lambda"); - register_core_syntax(pic, PIC_STX_IF, "if"); - register_core_syntax(pic, PIC_STX_BEGIN, "begin"); - register_core_syntax(pic, PIC_STX_DEFMACRO, "define-macro"); - register_core_syntax(pic, PIC_STX_DEFSYNTAX, "define-syntax"); - pic_gc_arena_restore(pic, ai); - pic_init_core(pic); return pic;