conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'syntactic-closure'

This commit is contained in:
Yuichi Nishiwaki 2013-11-27 14:26:30 +09:00
parent bbe3e990e4 a7a3bfc270
commit 4b2534e2bd
12 changed files with 383 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
extlib/xhash/xhash.h
View File

@ -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;

10
include/picrin.h
View File

@ -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);

34
include/picrin/macro.h Normal file
View File

@ -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

5
include/picrin/pair.h
View File

@ -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

4
include/picrin/value.h
View File

@ -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 \

12
piclib/built-in.scm
View File

@ -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)

9
src/codegen.c
View File

@ -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");
}
}

41
src/gc.c
View File

@ -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 <stdio.h>
@ -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:

278
src/macro.c
View File

@ -1,95 +1,159 @@
#include <stdio.h>
#include <assert.h>
#include <string.h>
#include <math.h>
#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:");

24
src/pair.c
View File

@ -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)
{

6
src/port.c
View File

@ -97,6 +97,12 @@ write(pic_state *pic, pic_value obj)
case PIC_TT_CONT:
printf("#<cont %p>", pic_ptr(obj));
break;
case PIC_TT_SENV:
printf("#<senv %p>", pic_ptr(obj));
break;
case PIC_TT_SYNTAX:
printf("#<senv %p>", pic_ptr(obj));
break;
}
}

78
src/state.c
View File

@ -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);