From b7e55b043fe9696b4049ff1b91f74484b3d7bf28 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 30 Oct 2013 16:37:43 +0900 Subject: [PATCH] introduce legacy macros --- include/picconf.h | 1 + include/picrin.h | 5 ++ src/codegen.c | 2 +- src/expand.c | 127 ++++++++++++++++++++++++++++++++++++++++++++++ src/state.c | 5 ++ 5 files changed, 139 insertions(+), 1 deletion(-) create mode 100644 src/expand.c diff --git a/include/picconf.h b/include/picconf.h index b3225fdf..315504ff 100644 --- a/include/picconf.h +++ b/include/picconf.h @@ -13,6 +13,7 @@ #define PIC_STACK_SIZE 1024 #define PIC_IREP_SIZE 256 #define PIC_GLOBALS_SIZE 1024 +#define PIC_MACROS_SIZE 1024 #define PIC_SYM_POOL_SIZE 128 #define PIC_POOL_SIZE 1024 diff --git a/include/picrin.h b/include/picrin.h index b897b96d..6e649b29 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -30,6 +30,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 sCONS, sCAR, sCDR, sNILP; pic_sym sADD, sSUB, sMUL, sDIV; pic_sym sEQ, sLT, sLE, sGT, sGE; @@ -38,9 +39,12 @@ typedef struct { const char **sym_pool; size_t slen, scapa; + /* positive for variables, negative for macros (bitnot) */ struct xhash *global_tbl; pic_value *globals; size_t glen, gcapa; + struct pic_proc **macros; + size_t mlen, mcapa; struct pic_irep **irep; size_t ilen, icapa; @@ -92,6 +96,7 @@ bool pic_parse_cstr(pic_state *, const char *, pic_value *); pic_value pic_apply(pic_state *pic, struct pic_proc *, pic_value); pic_value pic_apply_argv(pic_state *pic, struct pic_proc *, size_t, ...); struct pic_proc *pic_codegen(pic_state *, pic_value); +pic_value pic_expand(pic_state *, pic_value); void pic_abort(pic_state *, const char *); void pic_raise(pic_state *, pic_value); diff --git a/src/codegen.c b/src/codegen.c index b02592e6..0aab6493 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -131,7 +131,7 @@ scope_lookup(codegen_state *state, const char *key, int *depth, int *idx) enter: e = xh_get(scope->local_tbl, key); - if (e) { + if (e && e->val >= 0) { if (scope->up == NULL) { /* global */ *depth = -1; } diff --git a/src/expand.c b/src/expand.c new file mode 100644 index 00000000..9035a9e2 --- /dev/null +++ b/src/expand.c @@ -0,0 +1,127 @@ +#include +#include + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/proc.h" +#include "xhash/xhash.h" + +#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++; + pic->macros[idx] = 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); + + 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) { + v = pic_apply(pic, pic_codegen(pic, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)))), pic_nil_value()); + assert(pic_proc_p(v)); + define_macro(pic, pic_symbol_name(pic, pic_sym(pic_car(pic, pic_cdr(pic, obj)))), pic_proc_ptr(v)); + 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(); + } + return v; + } + } + + v = pic_cons(pic, pic_car(pic, obj), pic_nil_value()); + for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) { + v = pic_cons(pic, expand(pic, pic_car(pic, obj), env), 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_EOF: + case PIC_TT_STRING: + case PIC_TT_VECTOR: { + return obj; + } + case PIC_TT_PROC: + case PIC_TT_PORT: + case PIC_TT_ENV: + case PIC_TT_UNDEF: + pic_error(pic, "logic flaw"); + abort(); /* unreachable */ + } +} + +pic_value +pic_expand(pic_state *pic, pic_value obj) +{ + struct syntactic_env env; + pic_value v; + int ai = pic_gc_arena_preserve(pic); + + env.tbl = pic->global_tbl; + + v = expand(pic, obj, &env); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + +#if DEBUG + puts("expanded:"); + pic_debug(pic, v); +#endif + + return v; +} diff --git a/src/state.c b/src/state.c index e040ccde..852d3083 100644 --- a/src/state.c +++ b/src/state.c @@ -48,6 +48,9 @@ pic_open(int argc, char *argv[], char **envp) pic->globals = (pic_value *)malloc(sizeof(pic_value) * PIC_GLOBALS_SIZE); pic->glen = 0; pic->gcapa = PIC_GLOBALS_SIZE; + pic->macros = (struct pic_proc **)malloc(sizeof(struct pic_proc *) * PIC_MACROS_SIZE); + pic->mlen = 0; + pic->mcapa = PIC_MACROS_SIZE; /* pool */ pic->pool = (pic_value *)malloc(sizeof(pic_value) * PIC_POOL_SIZE); @@ -71,6 +74,8 @@ pic_open(int argc, char *argv[], char **envp) pic->sQUASIQUOTE = pic_intern_cstr(pic, "quasiquote"); pic->sUNQUOTE = pic_intern_cstr(pic, "unquote"); pic->sUNQUOTE_SPLICING = pic_intern_cstr(pic, "unquote-splicing"); + pic->sDEFINE_SYNTAX = pic_intern_cstr(pic, "define-syntax"); + pic->sDEFINE_MACRO = pic_intern_cstr(pic, "define-macro"); pic->sCONS = pic_intern_cstr(pic, "cons"); pic->sCAR = pic_intern_cstr(pic, "car"); pic->sCDR = pic_intern_cstr(pic, "cdr");