diff --git a/include/picrin.h b/include/picrin.h index f71fae63..40c27b36 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -55,8 +55,6 @@ typedef struct { struct xhash *global_tbl; pic_value *globals; size_t glen, gcapa; - struct pic_proc **macros; - size_t mlen, mcapa; /* positive for variables, negative for macros (bitwise-not) */ struct xhash *var_tbl; diff --git a/src/gc.c b/src/gc.c index c12a1633..5f9c32da 100644 --- a/src/gc.c +++ b/src/gc.c @@ -360,8 +360,6 @@ gc_mark_phase(pic_state *pic) } /* macros */ - for (i = 0; i < pic->mlen; ++i) { - gc_mark_object(pic, (struct pic_object *)pic->macros[i]); for (i = 0; i < pic->xlen; ++i) { gc_mark_object(pic, (struct pic_object *)pic->stx[i]); } diff --git a/src/macro.c b/src/macro.c index e4825e39..56c69af7 100644 --- a/src/macro.c +++ b/src/macro.c @@ -11,199 +11,19 @@ #define FALLTHROUGH ((void)0) -struct syntactic_env { - struct syntactic_env *up; - - struct xhash *tbl; -}; - static void define_macro(pic_state *pic, const char *name, struct pic_proc *macro) { int idx; - idx = pic->mlen++; - if (idx >= pic->mcapa) { + idx = pic->xlen++; + if (idx >= pic->xcapa) { pic_abort(pic, "macro table overflow"); } - pic->macros[idx] = macro; + pic->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro); xh_put(pic->global_tbl, name, ~idx); } -static struct pic_proc * -lookup_macro(pic_state *pic, struct syntactic_env *env, const char *name) -{ - struct xh_entry *e; - - e = xh_get(env->tbl, name); - if (! e) - return NULL; - - if (e->val >= 0) - return NULL; - - return pic->macros[~e->val]; -} - -pic_value -expand(pic_state *pic, pic_value obj, struct syntactic_env *env) -{ - int ai = pic_gc_arena_preserve(pic); - -#if DEBUG - printf("current ai = %d\n", ai); - - printf("expanding..."); - pic_debug(pic, obj); - puts(""); -#endif - - switch (pic_type(obj)) { - case PIC_TT_SYMBOL: { - return obj; - } - case PIC_TT_PAIR: { - pic_value v; - - if (! pic_list_p(pic, obj)) - return obj; - - if (pic_symbol_p(pic_car(pic, obj))) { - struct pic_proc *macro; - pic_sym sym; - - sym = pic_sym(pic_car(pic, obj)); - if (sym == pic->sDEFINE_MACRO) { - pic_value var, val; - struct pic_proc *proc; - - if (pic_length(pic, obj) < 2) { - pic_error(pic, "syntax error"); - } - - var = pic_car(pic, pic_cdr(pic, obj)); - if (pic_pair_p(var)) { - val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA), - pic_cons(pic, pic_cdr(pic, var), - pic_cdr(pic, pic_cdr(pic, obj)))); - var = pic_car(pic, var); - } - else { - if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax_error"); - } - val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))); - } - if (! pic_symbol_p(var)) { - pic_error(pic, "syntax error"); - } - - proc = pic_codegen(pic, val); - if (pic->errmsg) { - printf("macroexpand error: %s\n", pic->errmsg); - abort(); - } - v = pic_apply(pic, proc, pic_nil_value()); - if (pic->errmsg) { - printf("macroexpand error: %s\n", pic->errmsg); - abort(); - } - assert(pic_proc_p(v)); - define_macro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v)); - - pic_gc_arena_restore(pic, ai); - return pic_false_value(); - } - macro = lookup_macro(pic, env, pic_symbol_name(pic, sym)); - if (macro) { - v = pic_apply(pic, macro, pic_cdr(pic, obj)); - if (pic->errmsg) { - printf("macroexpand error: %s\n", pic->errmsg); - abort(); - } - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - - v = expand(pic, v, env); - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - return v; - } - } - - v = pic_nil_value(); - while (! pic_nil_p(obj)) { - v = pic_cons(pic, expand(pic, pic_car(pic, obj), env), v); - obj = pic_cdr(pic, obj); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - } - v = pic_reverse(pic, v); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - return v; - } - case PIC_TT_NIL: - case PIC_TT_BOOL: - case PIC_TT_FLOAT: - case PIC_TT_INT: - case PIC_TT_CHAR: - case PIC_TT_EOF: - case PIC_TT_STRING: - case PIC_TT_VECTOR: - case PIC_TT_BLOB: { - return obj; - } - case PIC_TT_PROC: - case PIC_TT_PORT: - case PIC_TT_ERROR: - case PIC_TT_ENV: - case PIC_TT_CONT: - case PIC_TT_UNDEF: - case PIC_TT_SENV: - case PIC_TT_SYNTAX: - pic_error(pic, "unexpected value type"); - return pic_undef_value(); /* unreachable */ - } - /* logic flaw (suppress warnings gcc will emit) */ - abort(); -} - -pic_value pic_macroexpand_2(pic_state *, pic_value); - -pic_value -pic_macroexpand(pic_state *pic, pic_value obj) -{ - struct syntactic_env env; - pic_value v; - - env.tbl = pic->global_tbl; - -#if DEBUG - puts("before expand:"); - pic_debug(pic, obj); - puts(""); -#endif - - v = expand(pic, obj, &env); - -#if DEBUG - puts("after expand:"); - pic_debug(pic, v); - puts(""); -#endif - - v = pic_macroexpand_2(pic, v); -#if DEBUG - puts("after expand:"); - pic_debug(pic, v); - puts(""); -#endif - return v; -} - static pic_sym new_uniq_sym(pic_state *pic, pic_sym base) { @@ -249,6 +69,58 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) car = macroexpand(pic, pic_car(pic, expr), senv); if (pic_syntax_p(car)) { switch (pic_syntax(car)->kind) { + case PIC_STX_DEFMACRO: { + pic_value var, val; + struct pic_proc *proc; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + var = pic_car(pic, pic_cdr(pic, expr)); + if (pic_pair_p(var)) { + val = pic_cons(pic, pic_symbol_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_symbol_p(var)) { + pic_error(pic, "syntax error"); + } + + proc = pic_codegen(pic, val); + if (pic->errmsg) { + printf("macroexpand error: %s\n", pic->errmsg); + abort(); + } + v = pic_apply(pic, proc, pic_nil_value()); + if (pic->errmsg) { + printf("macroexpand error: %s\n", pic->errmsg); + abort(); + } + assert(pic_proc_p(v)); + define_macro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v)); + + pic_gc_arena_restore(pic, ai); + return pic_false_value(); + } + case PIC_STX_MACRO: { + v = pic_apply(pic, pic_syntax(car)->macro, pic_cdr(pic, expr)); + if (pic->errmsg) { + printf("macroexpand error: %s\n", pic->errmsg); + abort(); + } + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + + return macroexpand(pic, v, senv); + } case PIC_STX_LAMBDA: { struct pic_senv *in; pic_value a; @@ -284,7 +156,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) pic_error(pic, "syntax error"); } - var = pic_car(pic, pic_cdr(pic, expr)); + var = pic_cadr(pic, expr); if (pic_pair_p(var)) { pic_value a; @@ -402,7 +274,7 @@ pic_syntax_new_macro(pic_state *pic, pic_sym sym, struct pic_proc *macro) } pic_value -pic_macroexpand_2(pic_state *pic, pic_value expr) +pic_macroexpand(pic_state *pic, pic_value expr) { struct pic_senv *senv; pic_value v; diff --git a/src/state.c b/src/state.c index 68d9c891..50dedf77 100644 --- a/src/state.c +++ b/src/state.c @@ -64,9 +64,6 @@ pic_open(int argc, char *argv[], char **envp) pic->globals = (pic_value *)calloc(PIC_GLOBALS_SIZE, sizeof(pic_value)); pic->glen = 0; pic->gcapa = PIC_GLOBALS_SIZE; - pic->macros = (struct pic_proc **)calloc(PIC_MACROS_SIZE, sizeof(struct pic_proc *)); - pic->mlen = 0; - pic->mcapa = PIC_MACROS_SIZE; /* identifier table */ pic->var_tbl = xh_new();