diff --git a/extlib/xhash/xhash.h b/extlib/xhash/xhash.h index 3566e5d9..b20af2c3 100644 --- a/extlib/xhash/xhash.h +++ b/extlib/xhash/xhash.h @@ -53,7 +53,7 @@ xh_get(struct xhash *x, const char *key) idx = xh_hash(key) % x->size; for (e = x->buckets[idx]; e; e = e->next) { - if (! strcmp(key, e->key)) + if (strcmp(key, e->key) == 0) return e; } return NULL; @@ -62,8 +62,7 @@ xh_get(struct xhash *x, const char *key) static inline struct xh_entry * xh_put(struct xhash *x, const char *key, int val) { - int idx, len; - char *new_key; + int idx; struct xh_entry *e; if ((e = xh_get(x, key))) { @@ -71,14 +70,10 @@ xh_put(struct xhash *x, const char *key, int val) return e; } - len = strlen(key); - new_key = (char *)malloc(len+1); - strcpy(new_key, key); - idx = xh_hash(key) % x->size; e = (struct xh_entry *)malloc(sizeof(struct xh_entry)); e->next = x->buckets[idx]; - e->key = new_key; + e->key = strdup(key); e->val = val; return x->buckets[idx] = e; diff --git a/include/picrin.h b/include/picrin.h index 7588ec61..c69b2d46 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -50,13 +50,16 @@ typedef struct { struct xhash *sym_tbl; const char **sym_pool; size_t slen, scapa; + int uniq_sym_count; - /* positive for variables, negative for macros (bitwise-not) */ 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; + struct pic_syntax **stx; + size_t xlen, xcapa; struct pic_irep **irep; size_t ilen, icapa; @@ -98,6 +101,7 @@ void pic_close(pic_state *); struct pic_proc *pic_get_proc(pic_state *); int pic_get_args(pic_state *, const char *, ...); void pic_defun(pic_state *, const char *, pic_func_t); +void pic_defmacro(pic_state *, const char *, struct pic_proc *); pic_sym pic_intern_cstr(pic_state *, const char *); const char *pic_symbol_name(pic_state *, pic_sym); diff --git a/include/picrin/macro.h b/include/picrin/macro.h new file mode 100644 index 00000000..672feb73 --- /dev/null +++ b/include/picrin/macro.h @@ -0,0 +1,34 @@ +#ifndef MACRO_H__ +#define MACRO_H__ + +struct pic_senv { + PIC_OBJECT_HEADER + struct pic_senv *up; + struct xhash *tbl; + struct pic_syntax **stx; + size_t xlen, xcapa; +}; + +struct pic_syntax { + PIC_OBJECT_HEADER + enum { + PIC_STX_DEFINE, + PIC_STX_SET, + PIC_STX_QUOTE, + PIC_STX_LAMBDA, + PIC_STX_IF, + PIC_STX_BEGIN, + PIC_STX_MACRO, + PIC_STX_DEFMACRO + } kind; + pic_sym sym; + struct pic_proc *macro; +}; + +#define pic_syntax(v) ((struct pic_syntax *)pic_ptr(v)) +#define pic_syntax_p(v) (pic_type(v) == PIC_TT_SYNTAX) + +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 *); + +#endif diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 28c722bf..5fd18e62 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -15,4 +15,9 @@ pic_value pic_reverse(pic_state *, pic_value); pic_value pic_assq(pic_state *, pic_value key, pic_value assoc); pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc); +pic_value pic_caar(pic_state *, pic_value); +pic_value pic_cadr(pic_state *, pic_value); +pic_value pic_cdar(pic_state *, pic_value); +pic_value pic_cddr(pic_state *, pic_value); + #endif diff --git a/include/picrin/value.h b/include/picrin/value.h index 42354c78..d14b8a51 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -89,7 +89,9 @@ enum pic_tt { PIC_TT_PORT, PIC_TT_ERROR, PIC_TT_ENV, - PIC_TT_CONT + PIC_TT_CONT, + PIC_TT_SENV, + PIC_TT_SYNTAX }; #define PIC_OBJECT_HEADER \ diff --git a/piclib/built-in.scm b/piclib/built-in.scm index ca27563d..23392f82 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -314,18 +314,6 @@ ;;; 6.2. Numbers -(define (+ . args) - (do ((acc 0) - (nums args (cdr nums))) - ((pair? nums) acc) - (set! acc (+ acc (car nums))))) - -(define (* . args) - (do ((acc 1) - (nums args (cdr nums))) - ((pair? nums) acc) - (set! acc (* acc (car nums))))) - (define (min x . args) (let loop ((pivot x) (rest args)) (if (null? rest) diff --git a/src/codegen.c b/src/codegen.c index 6aac14b5..98320508 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -201,7 +201,10 @@ codegen(codegen_state *state, pic_value obj, bool tailpos) name = pic_symbol_name(pic, pic_sym(obj)); s = scope_lookup(state, name, &depth, &idx); if (! s) { - pic_error(pic, "unbound variable"); +#if DEBUG + printf("%s\n", name); +#endif + pic_error(pic, "symbol: unbound variable"); } switch (depth) { @@ -658,7 +661,9 @@ codegen(codegen_state *state, pic_value obj, bool tailpos) case PIC_TT_UNDEF: case PIC_TT_EOF: case PIC_TT_PORT: - case PIC_TT_ERROR: { + case PIC_TT_ERROR: + case PIC_TT_SENV: + case PIC_TT_SYNTAX: { pic_error(pic, "invalid expression given"); } } diff --git a/src/gc.c b/src/gc.c index 6f597213..83532f54 100644 --- a/src/gc.c +++ b/src/gc.c @@ -8,6 +8,8 @@ #include "picrin/blob.h" #include "picrin/cont.h" #include "picrin/error.h" +#include "picrin/macro.h" +#include "xhash/xhash.h" #if GC_DEBUG # include @@ -259,6 +261,29 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) gc_mark(pic, cont->result); break; } + case PIC_TT_SYNTAX: { + struct pic_syntax *stx = (struct pic_syntax *)obj; + + if (stx->macro) { + gc_mark_object(pic, (struct pic_object *)stx->macro); + } + break; + } + case PIC_TT_SENV: { + struct pic_senv *senv = (struct pic_senv *)obj; + + if (senv->up) { + gc_mark_object(pic, (struct pic_object *)senv->up); + } + if (senv->stx) { + int i; + + for (i = 0; i < senv->xlen; ++i) { + gc_mark_object(pic, (struct pic_object *)senv->stx[i]); + } + } + break; + } case PIC_TT_NIL: case PIC_TT_BOOL: case PIC_TT_FLOAT: @@ -321,8 +346,8 @@ 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]); } /* pool */ @@ -383,6 +408,18 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) PIC_BLK_DECREF(pic, cont->blk); break; } + 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); + } + break; + } + case PIC_TT_SYNTAX: { + break; + } case PIC_TT_NIL: case PIC_TT_BOOL: case PIC_TT_FLOAT: diff --git a/src/macro.c b/src/macro.c index ff716c42..ce7c7b69 100644 --- a/src/macro.c +++ b/src/macro.c @@ -1,95 +1,159 @@ #include #include +#include +#include #include "picrin.h" #include "picrin/pair.h" #include "picrin/proc.h" +#include "picrin/macro.h" #include "xhash/xhash.h" #define FALLTHROUGH ((void)0) -struct syntactic_env { - struct syntactic_env *up; +static pic_sym +new_uniq_sym(pic_state *pic, pic_sym base) +{ + int s = ++pic->uniq_sym_count; + char *str; + pic_sym uniq; - struct xhash *tbl; -}; + str = (char *)pic_alloc(pic, strlen(pic_symbol_name(pic, base)) + (int)log10(s) + 2); + sprintf(str, "%s@%d", pic_symbol_name(pic, base), s); + uniq = pic_intern_cstr(pic, str); -static void -define_macro(pic_state *pic, const char *name, struct pic_proc *macro) + pic_free(pic, str); + return uniq; +} + +static struct pic_senv * +new_global_senv(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; + return senv; +} + +static struct pic_senv * +new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up) +{ + struct pic_senv *senv; + pic_value a; + pic_sym sym; + + senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + senv->up = up; + senv->tbl = xh_new(); + senv->stx = NULL; + senv->xlen = 0; + senv->xcapa = 0; + + for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) { + sym = pic_sym(pic_car(pic, a)); + xh_put(senv->tbl, pic_symbol_name(pic, sym), (int)new_uniq_sym(pic, sym)); + } + if (pic_symbol_p(a)) { + sym = pic_sym(a); + xh_put(senv->tbl, pic_symbol_name(pic, sym), (int)new_uniq_sym(pic, sym)); + } + return senv; +} + +struct pic_syntax * +pic_syntax_new(pic_state *pic, int kind, pic_sym sym) +{ + struct pic_syntax *stx; + + stx = (struct pic_syntax *)pic_obj_alloc(pic, sizeof(struct pic_syntax), PIC_TT_SYNTAX); + stx->kind = kind; + stx->sym = sym; + stx->macro = NULL; + return stx; +} + +struct pic_syntax * +pic_syntax_new_macro(pic_state *pic, pic_sym sym, struct pic_proc *macro) +{ + struct pic_syntax *stx; + + stx = (struct pic_syntax *)pic_obj_alloc(pic, sizeof(struct pic_syntax), PIC_TT_SYNTAX); + stx->kind = PIC_STX_MACRO; + stx->sym = sym; + stx->macro = macro; + return stx; +} + +void +pic_defmacro(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; - xh_put(pic->global_tbl, name, ~idx); + pic->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro); + xh_put(pic->var_tbl, name, ~idx); + pic->xlen++; } -static struct pic_proc * -lookup_macro(pic_state *pic, struct syntactic_env *env, const char *name) -{ - struct xh_entry *e; +static pic_value macroexpand_list(pic_state *, pic_value, struct pic_senv *); - 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) +static pic_value +macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) { 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)) { + switch (pic_type(expr)) { case PIC_TT_SYMBOL: { - return obj; + struct xh_entry *e; + while (senv) { + if ((e = xh_get(senv->tbl, pic_symbol_name(pic, pic_sym(expr)))) != NULL) { + if (e->val >= 0) + return pic_symbol_value((pic_sym)e->val); + else + return pic_obj_value(senv->stx[~e->val]); + } + senv = senv->up; + } + return expr; } case PIC_TT_PAIR: { - pic_value v; + pic_value car, v; - if (! pic_list_p(pic, obj)) - return obj; + if (! pic_list_p(pic, expr)) + return expr; - 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) { + 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, obj) < 2) { + if (pic_length(pic, expr) < 2) { pic_error(pic, "syntax error"); } - var = pic_car(pic, pic_cdr(pic, obj)); + var = pic_car(pic, pic_cdr(pic, expr)); if (pic_pair_p(var)) { + /* FIXME: unhygienic */ val = pic_cons(pic, pic_symbol_value(pic->sLAMBDA), pic_cons(pic, pic_cdr(pic, var), - pic_cdr(pic, pic_cdr(pic, obj)))); + pic_cdr(pic, pic_cdr(pic, expr)))); var = pic_car(pic, var); } else { - if (pic_length(pic, obj) != 3) { + if (pic_length(pic, expr) != 3) { pic_error(pic, "syntax_error"); } - val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))); + val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr))); } if (! pic_symbol_p(var)) { pic_error(pic, "syntax error"); @@ -106,14 +170,13 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env) abort(); } assert(pic_proc_p(v)); - define_macro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v)); + pic_defmacro(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)); + 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(); @@ -121,37 +184,87 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env) pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, v); - v = expand(pic, v, env); + return macroexpand(pic, v, senv); + } + case PIC_STX_LAMBDA: { + struct pic_senv *in = new_local_senv(pic, pic_cadr(pic, expr), senv); + + v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), + pic_cons(pic, + macroexpand_list(pic, pic_cadr(pic, expr), in), + macroexpand_list(pic, pic_cddr(pic, expr), in))); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; + } + case PIC_STX_DEFINE: { + pic_sym uniq; + pic_value var; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (pic_pair_p(var)) { + struct pic_senv *in = new_local_senv(pic, pic_cdr(pic, var), senv); + pic_value a; + pic_sym sym; + + /* defined symbol */ + a = pic_car(pic, var); + if (! pic_symbol_p(a)) { + pic_error(pic, "binding to non-symbol object"); + } + sym = pic_sym(a); + xh_put(senv->tbl, pic_symbol_name(pic, sym), (int)new_uniq_sym(pic, sym)); + + /* binding value */ + v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), + pic_cons(pic, + macroexpand_list(pic, pic_cadr(pic, expr), in), + macroexpand_list(pic, pic_cddr(pic, expr), in))); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; + } + + uniq = new_uniq_sym(pic, pic_sym(var)); + xh_put(senv->tbl, pic_symbol_name(pic, pic_sym(var)), (int)uniq); + } + FALLTHROUGH; + case PIC_STX_SET: + case PIC_STX_IF: + case PIC_STX_BEGIN: + v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), macroexpand_list(pic, pic_cdr(pic, expr), senv)); + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; + case PIC_STX_QUOTE: + v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), pic_cdr(pic, expr)); 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); - + v = pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv)); pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, v); return v; } + case PIC_TT_EOF: 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; + return expr; } case PIC_TT_PROC: case PIC_TT_PORT: @@ -159,28 +272,45 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env) 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) */ + /* suppress warnings, never be called */ abort(); } -pic_value -pic_macroexpand(pic_state *pic, pic_value obj) +static pic_value +macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv) { - struct syntactic_env env; pic_value v; - env.tbl = pic->global_tbl; + if (pic_nil_p(list)) + return pic_nil_value(); + + if (pic_symbol_p(list)) + return macroexpand(pic, list, senv); + + v = macroexpand(pic, pic_car(pic, list), senv); + return pic_cons(pic, v, macroexpand_list(pic, pic_cdr(pic, list), senv)); +} + +pic_value +pic_macroexpand(pic_state *pic, pic_value expr) +{ + struct pic_senv *senv; + pic_value v; + + senv = new_global_senv(pic); #if DEBUG puts("before expand:"); - pic_debug(pic, obj); + pic_debug(pic, expr); puts(""); #endif - v = expand(pic, obj, &env); + v = macroexpand(pic, expr, senv); #if DEBUG puts("after expand:"); diff --git a/src/pair.c b/src/pair.c index c1c78af1..193d4c77 100644 --- a/src/pair.c +++ b/src/pair.c @@ -134,6 +134,30 @@ pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc) return pic_cons(pic, pic_cons(pic, key, val), assoc); } +pic_value +pic_caar(pic_state *pic, pic_value v) +{ + return pic_car(pic, pic_car(pic, v)); +} + +pic_value +pic_cadr(pic_state *pic, pic_value v) +{ + return pic_car(pic, pic_cdr(pic, v)); +} + +pic_value +pic_cdar(pic_state *pic, pic_value v) +{ + return pic_cdr(pic, pic_car(pic, v)); +} + +pic_value +pic_cddr(pic_state *pic, pic_value v) +{ + return pic_cdr(pic, pic_cdr(pic, v)); +} + static pic_value pic_pair_pair_p(pic_state *pic) { diff --git a/src/port.c b/src/port.c index 0c3709fd..06a2f5f9 100644 --- a/src/port.c +++ b/src/port.c @@ -97,6 +97,12 @@ write(pic_state *pic, pic_value obj) case PIC_TT_CONT: printf("#", pic_ptr(obj)); break; + case PIC_TT_SENV: + printf("#", pic_ptr(obj)); + break; + case PIC_TT_SYNTAX: + printf("#", pic_ptr(obj)); + break; } } diff --git a/src/state.c b/src/state.c index d8db2f75..9b7e2eae 100644 --- a/src/state.c +++ b/src/state.c @@ -3,6 +3,7 @@ #include "picrin.h" #include "picrin/gc.h" #include "picrin/proc.h" +#include "picrin/macro.h" #include "xhash/xhash.h" void pic_init_core(pic_state *); @@ -51,6 +52,7 @@ pic_open(int argc, char *argv[], char **envp) pic->sym_pool = (const char **)calloc(PIC_SYM_POOL_SIZE, sizeof(const char *)); pic->slen = 0; pic->scapa = pic->slen + PIC_SYM_POOL_SIZE; + pic->uniq_sym_count = 0; /* irep */ pic->irep = (struct pic_irep **)calloc(PIC_IREP_SIZE, sizeof(struct pic_irep *)); @@ -62,9 +64,12 @@ 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(); + pic->stx = (struct pic_syntax **)calloc(PIC_MACROS_SIZE, sizeof(struct pic_syntax *)); + pic->xlen = 0; + pic->xcapa = PIC_MACROS_SIZE; /* pool */ pic->pool = (pic_value *)calloc(PIC_POOL_SIZE, sizeof(pic_value)); @@ -81,31 +86,50 @@ pic_open(int argc, char *argv[], char **envp) /* native stack marker */ pic->native_stack_start = &t; +#define register_core_symbol(pic,slot,name) do { \ + pic->slot = pic_intern_cstr(pic, name); \ + } while (0) + ai = pic_gc_arena_preserve(pic); - pic->sDEFINE = pic_intern_cstr(pic, "define"); - pic->sLAMBDA = pic_intern_cstr(pic, "lambda"); - pic->sIF = pic_intern_cstr(pic, "if"); - pic->sBEGIN = pic_intern_cstr(pic, "begin"); - pic->sSETBANG = pic_intern_cstr(pic, "set!"); - pic->sQUOTE = pic_intern_cstr(pic, "quote"); - 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"); - pic->sNILP = pic_intern_cstr(pic, "null?"); - pic->sADD = pic_intern_cstr(pic, "+"); - pic->sSUB = pic_intern_cstr(pic, "-"); - pic->sMUL = pic_intern_cstr(pic, "*"); - pic->sDIV = pic_intern_cstr(pic, "/"); - pic->sEQ = pic_intern_cstr(pic, "="); - pic->sLT = pic_intern_cstr(pic, "<"); - pic->sLE = pic_intern_cstr(pic, "<="); - pic->sGT = pic_intern_cstr(pic, ">"); - pic->sGE = pic_intern_cstr(pic, ">="); + register_core_symbol(pic, sDEFINE, "define"); + register_core_symbol(pic, sLAMBDA, "lambda"); + register_core_symbol(pic, sIF, "if"); + register_core_symbol(pic, sBEGIN, "begin"); + register_core_symbol(pic, sSETBANG, "set!"); + register_core_symbol(pic, sQUOTE, "quote"); + register_core_symbol(pic, sQUASIQUOTE, "quasiquote"); + register_core_symbol(pic, sUNQUOTE, "unquote"); + 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, sCONS, "cons"); + register_core_symbol(pic, sCAR, "car"); + register_core_symbol(pic, sCDR, "cdr"); + register_core_symbol(pic, sNILP, "null?"); + register_core_symbol(pic, sADD, "+"); + register_core_symbol(pic, sSUB, "-"); + register_core_symbol(pic, sMUL, "*"); + register_core_symbol(pic, sDIV, "/"); + register_core_symbol(pic, sEQ, "="); + register_core_symbol(pic, sLT, "<"); + register_core_symbol(pic, sLE, "<="); + register_core_symbol(pic, sGT, ">"); + 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"); pic_gc_arena_restore(pic, ai); pic_init_core(pic);