static void __attribute__((noreturn)) apply_implementation(closure *self,
int argc,
oop k,
oop f,
...)
{
pair *prev = NULL;
pair *arglist = mknull();
pair *p;
int i;
va_list vl;
oop a;
if (argc < 3) {
wrong_variable_argc(argc, 3);
}
va_start(vl, f);
for (i = (argc - 3) - 1; i >= 0; i--) {
p = alloca(sizeof(pair));
a = va_arg(vl, oop);
*p = (pair) mkpair(a, mknull());
if (prev == NULL) {
arglist = p;
} else {
prev->cdr = p;
}
prev = p;
}
a = va_arg(vl, oop);
if (!(ispair(a) || isnil(a))) {
wrong_type(argc);
}
if (prev == NULL) {
arglist = a;
} else {
prev->cdr = a;
}
va_end(vl);
p = alloca(sizeof(pair));
*p = (pair) mkpair(k, arglist);
arglist = p;
checkedcallfun(f, -1, arglist);
}
Value *lread()
{
char ch;
again:
ch = getchar();
if (isspace(ch)) goto again;
ungetc(ch, stdin);
if (isalpha(ch)) return lreadsym();
else if (isdigit(ch)) return lreadint();
else if (ch == '(') { getchar(); return lreadlist(); }
else if (ch == '\'') {
getchar();
return mkpair(quote_sym, mkpair(lread(), LISP_NIL));
} else {
getchar();
error("Unrecognized token.");
exit(1);
}
}
Value *lreadlist()
{
Value *car, *cdr;
if (peekchar() == ')') {
getchar(); // eat )
return LISP_NIL;
}
car = lread();
cdr = lreadlist();
return mkpair(car, cdr);
}
void init()
{
int i;
size_t s = 16384;
heap = malloc(s);
heap_end = heap + s;
for (i = 0; i < SYMBOL_TABLE_SIZE; i++) {
syms[i] = LISP_NIL;
}
quote_sym = mksym("QUOTE");
lambda_sym = mksym("LAMBDA");
define_sym = mksym("DEFINE");
if_sym = mksym("IF");
// Set up the global environment as a single, "empty" binding.
// This is done so that we can "splice" global definitions into
// the global environment rather than "extending" the global
// environment in the regular fashion. Otherwise, global mutual
// recursion would not be possible.
global_env = mkpair(mkpair(LISP_NIL, LISP_NIL), LISP_NIL);
}
Value *mksym(const char *sym)
{
uint8_t hash = gethash(sym);
const size_t length = strlen(sym);
const size_t nalloc = sizeof(Value) + length + 1;
Value *pair, *prim;
pair = syms[hash];
for (; !LISP_NILP(pair); pair = CDR(pair)) {
Value *prim = CAR(pair);
if (strcasecmp(prim->sym, sym) == 0) {
return prim;
}
}
maybe_gc(nalloc);
prim = (Value *) heap;
prim->type = T_SYM;
strcpy(prim->sym, sym);
heap += nalloc;
syms[hash] = mkpair(prim, syms[hash]);
return prim;
}
// List manipulation.
Value *native_cons(Value *args) { return mkpair(CAR(args), CADR(args)); }
Value *bind(Value *name, Value *value, Value *env)
{
Value *binding = mkpair(name, value);
return mkpair(binding, env);
}
Value *mapeval(Value *list, Value *env)
{
if (list == LISP_NIL)
return LISP_NIL;
return mkpair(eval(CAR(list), env), mapeval(CDR(list), env));
}