#include <u.h>
#include <libc.h>
#include <bio.h>
#include "aa.h"
#include "qp.h"

#define CAR(x)        ( (x)->car.o )
#define CDR(x)        ( (x)->cdr.o )
#define TAG(x)        ( (x)->car.c )
#define ISUNBOUND(x)  ( (x) == nil )
#define ISNULL(x)     ( (x) == &Null )
#define ISTRUE(x)     ( (x) == &True )
#define ISFALSE(x)    ( (x) == &False )
#define TYPE(x)       ( TAG(x) & 0x1 ? TAG(x) >> 2 : AA_TPAIR )
#define SETTYPE(x,t)  ( TAG(x) = (t) << 2 | 1 )
#define NUMBER(x)     ( (x)->cdr.n )
#define PRIM(x)       ( (x)->cdr.c )
#define CFUNC(x)      ( (x)->cdr.f )
#define STRBUF(x)     ( &(x)->car.c + 1 )

#define STRBUFSIZE    ( (int)sizeof(aaValue) - 1 )
#define GCMARKBIT     ( 0x2 )

#define MAX(a,b) ((a)>(b)?(a):(b))
#define MIN(a,b) ((a)<(b)?(a):(b))

#define evalarg() (nargs++, eval(ctx, aa_nextarg(ctx, &arg, 0), env, nil))

#define arithop(op, init) { \
	aaNumber x = {init}; \
	while(!ISNULL(arg)){ \
		aaNumber y = aa_tonumber(ctx, evalarg()); \
		x.r = x.r op y.r; \
	} \
	res = aa_number(ctx, x); \
}

#define numcmpop(op) { \
	int c; \
	va = checktype(ctx, evalarg(), AA_TNUMBER); \
	vb = checktype(ctx, evalarg(), AA_TNUMBER); \
	while((c = (NUMBER(va).r op NUMBER(vb).r)) && !ISNULL(arg)){ \
		va = vb; \
		vb = checktype(ctx, evalarg(), AA_TNUMBER); \
	} \
	res = aa_bool(ctx, c); \
}

enum {
	P_LET,
	P_DEFINE,
	P_SET_YAS,
	P_IF,
	P_LAMBDA,
	P_MAC,
	P_WHILE,
	P_QUOTE,
	P_EVAL,
	P_AND,
	P_OR,
	P_BEGIN,
	P_CONS,
	P_CAR,
	P_CDR,
	P_SETCAR,
	P_SETCDR,
	P_LIST,
	P_NOT,
	P_DISPLAY,
	P_EQ_HUH,
	P_EQUAL_HUH,
	P_ATOM_HUH,
	P_NUMBER_HUH,
	P_BOOLEAN_HUH,
	P_PORT_HUH,
	P_DEFINED_HUH,
	P_STRING_HUH,
	P_NAN_HUH,
	P_INF_HUH,
	P_EQN,
	P_LT,
	P_GT,
	P_LTE,
	P_GTE,
	P_ADD,
	P_SUB,
	P_MUL,
	P_DIV,
	P_MAX,
	P_MIN,

	Numprims
};

static const char *primnames[Numprims] = {
	[P_LET] = "let",
	[P_DEFINE] = "define",
	[P_SET_YAS] = "set!",
	[P_IF] = "if",
	[P_LAMBDA] = "lambda",
	[P_MAC] = "mac",
	[P_WHILE] = "while",
	[P_QUOTE] = "quote",
	[P_EVAL] = "eval",
	[P_AND] = "and",
	[P_OR] = "or",
	[P_BEGIN] = "begin",
	[P_CONS] = "cons",
	[P_CAR] = "car",
	[P_CDR] = "cdr",
	[P_SETCAR] = "setcar",
	[P_SETCDR] = "setcdr",
	[P_LIST] = "list",
	[P_NOT] = "not",
	[P_DISPLAY] = "display",
	[P_EQ_HUH] = "eq?",
	[P_EQUAL_HUH] = "equal?",
	[P_ATOM_HUH] = "atom?",
	[P_NUMBER_HUH] = "number?",
	[P_BOOLEAN_HUH] = "boolean?",
	[P_PORT_HUH] = "port?",
	[P_DEFINED_HUH] = "defined?",
	[P_STRING_HUH] = "string?",
	[P_NAN_HUH] = "nan?",
	[P_INF_HUH] = "infinite?",
	[P_EQN] = "=",
	[P_LT] = "<",
	[P_GT] = ">",
	[P_LTE] = "<=",
	[P_GTE] = ">=",
	[P_ADD] = "+",
	[P_SUB] = "-",
	[P_MUL] = "*",
	[P_DIV] = "/",
	[P_MAX] = "max",
	[P_MIN] = "min",
};

static const char *typenames[AA_TMAX] = {
	[AA_TPAIR] = "pair",
	[AA_TFREE] = "free",
	[AA_TNUMBER] = "number",
	[AA_TSYMBOL] = "symbol",
	[AA_TSTRING] = "string",
	[AA_TFUNC] = "func",
	[AA_TMACRO] = "macro",
	[AA_TPRIM] = "prim",
	[AA_TCFUNC] = "cfunc",
	[AA_TPTR] = "ptr",
	[AA_TBOOL] = "bool",
	[AA_TPORT] = "port",
};

aaObject Null = {{ (void*)(AA_TPAIR << 2 | 1) }, { nil }};
aaObject False = {{ (void*)(AA_TBOOL << 2 | 1) }, { nil }};
aaObject True = {{ (void*)(AA_TBOOL << 2 | 1) }, { nil }};
static aaObject rparen;

static char prelude[] = "\
(define newline (lambda () (display \"\\n\")))\
(define square (lambda (x) (* x x)))\
(define null? (lambda (x) (eq? x ())))\
(define finite? (lambda (x) (not (infinite? x))))\
";

static aaObject *eval(aaContext *ctx, aaObject *obj, aaObject *env, aaObject **bind);

aaHandlers *
aa_handlers(aaContext *ctx)
{
	return &ctx->handlers;
}

void
aa_error(aaContext *ctx, const char *fmt, ...)
{
	char buf[128];
	va_list arg;
	aaObject *cl = ctx->calllist;

	/* reset context state */
	ctx->calllist = &Null;

	va_start(arg, fmt);
	vsnprint(buf, sizeof(buf), fmt, arg);
	va_end(arg);

	/* do error handler */
	if(ctx->handlers.error)
		ctx->handlers.error(ctx, buf, cl);

	/* error handler returned -- print error and traceback, exit */
	Bprint(ctx->fd[2], "error: %s\n", buf);
	for(; !ISNULL(cl); cl = CDR(cl))
		Bprint(ctx->fd[2], "=> %ß\n", CAR(cl));

	exits(buf);
}

aaObject *
aa_nextarg(aaContext *ctx, aaObject **arg, int optional)
{
	aaObject *a = *arg;

	if(TYPE(a) != AA_TPAIR)
		aa_error(ctx, "dotted pair in argument list");
	if(ISNULL(a)){
		if(optional)
			return nil;
		aa_error(ctx, "too few arguments");
	}

	*arg = CDR(a);

	return CAR(a);
}

static aaObject *
checktype(aaContext *ctx, aaObject *obj, int type)
{
	if(TYPE(obj) != type)
		aa_error(ctx, "expected %s, got %s", typenames[type], typenames[TYPE(obj)]);

	return obj;
}

int
aa_type(aaContext *ctx, aaObject *obj)
{
	USED(ctx);
	return TYPE(obj);
}

void
aa_pushgc(aaContext *ctx, aaObject *obj)
{
	if(ctx->gcstack_idx == GCSTACKSIZE)
		aa_error(ctx, "gc stack overflow");

	ctx->gcstack[ctx->gcstack_idx++] = obj;
}

void
aa_restoregc(aaContext *ctx, int idx)
{
	ctx->gcstack_idx = idx;
}

int
aa_savegc(aaContext *ctx)
{
	return ctx->gcstack_idx;
}

void
aa_mark(aaContext *ctx, aaObject *obj)
{
	aaObject *car;

begin:
	if(ISNULL(obj) || (TAG(obj) & GCMARKBIT) != 0)
		return;
	car = CAR(obj); /* store car before modifying it with GCMARKBIT */
	TAG(obj) |= GCMARKBIT;

	switch(TYPE(obj)){
	case AA_TPAIR:
		aa_mark(ctx, car);
		/* fall through */

	case AA_TFUNC:
	case AA_TMACRO:
	case AA_TSYMBOL:
	case AA_TSTRING:
		obj = CDR(obj);
		goto begin;

	case AA_TPTR:
		if(ctx->handlers.mark)
			ctx->handlers.mark(ctx, obj);
		break;
	}
}

static void
collectgarbage(aaContext *ctx)
{
	aaObject *obj;
	int i;

	/* mark */
	for(i = 0; i < ctx->gcstack_idx; i++)
		aa_mark(ctx, ctx->gcstack[i]);

	aa_mark(ctx, ctx->symlist);

	/* sweep and unmark */
	for(i = 0; i < ctx->object_count; i++){
		obj = &ctx->objects[i];

		if(TYPE(obj) == AA_TFREE)
			continue;

		if(~TAG(obj) & GCMARKBIT){
			if(TYPE(obj) == AA_TPTR && ctx->handlers.gc)
				ctx->handlers.gc(ctx, obj);

			SETTYPE(obj, AA_TFREE);
			CDR(obj) = ctx->freelist;
			ctx->freelist = obj;
		}else{
			TAG(obj) &= ~GCMARKBIT;
		}
	}
}

static int
equal(aaObject *a, aaObject *b)
{
	if(a == b)
		return 1;

	if(TYPE(a) != TYPE(b) || TYPE(a) == AA_TBOOL)
		return 0;

	if(TYPE(a) == AA_TNUMBER)
		return NUMBER(a).r == NUMBER(b).r;

	if(TYPE(a) == AA_TSTRING){
		for(; !ISNULL(a); a = CDR(a), b = CDR(b)){
			if(CAR(a) != CAR(b))
				return 0;
		}
		return a == b;
	}

	for(; TYPE(a) == AA_TPAIR && TYPE(b) == AA_TPAIR && !ISNULL(a) && !ISNULL(b) && a != b; a = CDR(a), b = CDR(b)){
		if(!equal(CAR(a), CAR(b)))
			return 0;
	}

	return a == b;
}

static int
streq(aaObject *obj, const char *str)
{
	int i;

	while(!ISNULL(obj)){
		for(i = 0; i < STRBUFSIZE; i++){
			if(STRBUF(obj)[i] != *str)
				return 0;
			if(*str)
				str++;
		}
		obj = CDR(obj);
	}

	return *str == 0;
}

static aaObject *
object(aaContext *ctx)
{
	aaObject *obj;

	/* do gc if freelist has no more objects */
	if(ISNULL(ctx->freelist)){
		collectgarbage(ctx);
		if(ISNULL(ctx->freelist))
			aa_error(ctx, "out of memory");
	}

	/* get object from freelist and push to the gcstack */
	obj = ctx->freelist;
	ctx->freelist = CDR(obj);
	aa_pushgc(ctx, obj);

	return obj;
}

aaObject *
aa_cons(aaContext *ctx, aaObject *car, aaObject *cdr)
{
	aaObject *obj = object(ctx);

	CAR(obj) = car;
	CDR(obj) = cdr;

	return obj;
}

aaObject *
aa_bool(aaContext *ctx, int b)
{
	USED(ctx);
	return b ? &True : &False;
}

aaObject *
aa_number(aaContext *ctx, aaNumber n)
{
	aaObject *obj = object(ctx);

	SETTYPE(obj, AA_TNUMBER);
	NUMBER(obj) = n;

	return obj;
}

static aaObject *
buildstring(aaContext *ctx, aaObject *tail, int chr)
{
	aaObject *obj;

	if(!tail || STRBUF(tail)[STRBUFSIZE - 1] != '\0'){
		obj = aa_cons(ctx, nil, &Null);
		SETTYPE(obj, AA_TSTRING);
		if(tail){
			CDR(tail) = obj;
			ctx->gcstack_idx--;
		}
		tail = obj;
	}
	STRBUF(tail)[strlen(STRBUF(tail))] = chr;

	return tail;
}

aaObject *
aa_string(aaContext *ctx, const char *str)
{
	aaObject *obj = buildstring(ctx, nil, '\0');
	aaObject *tail = obj;

	while(*str)
		tail = buildstring(ctx, tail, *str++);

	return obj;
}

aaObject *
aa_symbol_find(aaContext *ctx, const char *name)
{
	aaObject *obj;
	char *pk;

	obj = nil;
	qpget(ctx->symtrie, name, 0, &pk, &obj);

	return obj;
}

aaObject *
aa_symbol(aaContext *ctx, const char *name)
{
	aaObject *obj;

	/* try to find it first */
	if((obj = aa_symbol_find(ctx, name)) != nil)
		return obj;

	/* create new object, push to symlist and return */
	obj = object(ctx);
	SETTYPE(obj, AA_TSYMBOL);
	CDR(obj) = aa_cons(ctx, aa_string(ctx, name), nil); /* nil not &Null, because it's unbound */
	ctx->symlist = aa_cons(ctx, obj, ctx->symlist);
	ctx->symtrie = qpset(ctx->symtrie, strdup(name), 0, obj);

	return obj;
}

aaObject *
aa_cfunc(aaContext *ctx, aaCFunc fn)
{
	aaObject *obj = object(ctx);

	SETTYPE(obj, AA_TCFUNC);
	CFUNC(obj) = fn;

	return obj;
}

aaObject *
aa_ptr(aaContext *ctx, void *ptr)
{
	aaObject *obj = object(ctx);

	SETTYPE(obj, AA_TPTR);
	CDR(obj) = ptr;

	return obj;
}

aaObject *
aa_list(aaContext *ctx, aaObject **objs, int n)
{
	aaObject *res = &Null;

	while(n--)
		res = aa_cons(ctx, objs[n], res);

	return res;
}

aaObject *
aa_car(aaContext *ctx, aaObject *obj)
{
	return ISNULL(obj) ? obj : CAR(checktype(ctx, obj, AA_TPAIR));
}

aaObject *
aa_cdr(aaContext *ctx, aaObject *obj)
{
	return ISNULL(obj) ? obj : CDR(checktype(ctx, obj, AA_TPAIR));
}

static int
objfmt(Fmt *f)
{
	aaObject *obj;
	int qt, i;

	obj = va_arg(f->args, aaObject*);
	if(ISNULL(obj)){
		fmtstrcpy(f, "()");
		return 0;
	}

	switch(TYPE(obj)){
	case AA_TNUMBER:
		fmtprint(f, "%.9g", NUMBER(obj).r);
		break;

	case AA_TPAIR:
		fmtrune(f, '(');
		do{
			fmtprint(f, "%§", CAR(obj));
			obj = CDR(obj);
			if(ISNULL(obj))
				break;
			fmtrune(f, ' ');
		}while(TYPE(obj) == AA_TPAIR);
		if(!ISNULL(obj))
			fmtprint(f, ". %§", obj);
		fmtrune(f, ')');
		break;

	case AA_TSYMBOL:
		fmtprint(f, "%ß", CAR(CDR(obj)));
		break;

	case AA_TSTRING:
		qt = f->r == L'§';
		if(qt)
			fmtrune(f, '"');
		while(!ISNULL(obj)){
			for(i = 0; i < STRBUFSIZE && STRBUF(obj)[i]; i++){
				if(qt && STRBUF(obj)[i] == '"')
					fmtrune(f, '\\');
				fmtrune(f, STRBUF(obj)[i]);
			}
			obj = CDR(obj);
		}
		if(qt)
			fmtrune(f, '"');
		break;

	case AA_TBOOL:
		fmtprint(f, ISTRUE(obj) ? "#t" : "#f");
		break;

	default:
		fmtprint(f, "[%s %p]", typenames[TYPE(obj)], (void*)obj);
		break;
	}

	return 0;
}

aaNumber
aa_tonumber(aaContext *ctx, aaObject *obj)
{
	return NUMBER(checktype(ctx, obj, AA_TNUMBER));
}

void *
aa_toptr(aaContext *ctx, aaObject *obj)
{
	return CDR(checktype(ctx, obj, AA_TPTR));
}

static aaObject *
getbound(aaContext *ctx, aaObject *sym, aaObject *env)
{
	aaObject *x;

	/* try to find in environment */
	for(; !ISNULL(env); env = CDR(env)){
		x = checktype(ctx, CAR(checktype(ctx, env, AA_TPAIR)), AA_TPAIR);
		if(CAR(x) == sym)
			return x;
	}

	/* return global */
	return CDR(sym);
}

void
aa_set(aaContext *ctx, aaObject *sym, aaObject *v)
{
	USED(ctx);
	CDR(getbound(ctx, sym, &Null)) = v;
}

static aaObject *
read_(aaContext *ctx, Biobuf *fp)
{
	const char *delimiter = " \n\t\r();";
	aaObject *v, *res, **tail;
	aaNumber n;
	long r;
	int gc, i;
	char buf[64], c[5], *p, *p2;

	/* get next character */
	r = ctx->nextrune ? ctx->nextrune : Bgetrune(fp);
	ctx->nextrune = 0;

	/* skip whitespace */
	while(r > 0 && utfrune(" \n\t\r", r))
		r = Bgetrune(fp);

	if(r <= 0)
		return nil;

	switch(r){
	case ';':
		while(r > 0 && r != '\n')
			r = Bgetrune(fp);
		return read_(ctx, fp);

	case ')':
		return &rparen;

	case '(':
		res = &Null;
		tail = &res;
		gc = aa_savegc(ctx);
		aa_pushgc(ctx, res); /* to cause error on too-deep nesting */
		while((v = read_(ctx, fp)) != &rparen){
			if(v == nil)
				aa_error(ctx, "unclosed list");
			if(TYPE(v) == AA_TSYMBOL && streq(CAR(CDR(v)), ".")){
				/* dotted pair */
				*tail = aa_read(ctx, fp);
			}else{
				/* proper pair */
				*tail = aa_cons(ctx, v, &Null);
				tail = &CDR(*tail);
			}
			aa_restoregc(ctx, gc);
			aa_pushgc(ctx, res);
		}
		return res;

	case '\'':
		v = aa_read(ctx, fp);
		if(!v)
			aa_error(ctx, "stray '''");
		return aa_cons(ctx, aa_symbol(ctx, "quote"), aa_cons(ctx, v, &Null));

	case '"':
		res = buildstring(ctx, nil, '\0');
		v = res;
		for(r = Bgetrune(fp); r != '"'; r = Bgetrune(fp)){
			if(r <= 0)
				aa_error(ctx, "unclosed string");
			if(r == '\\'){
				r = Bgetrune(fp);
				if(utfrune("nrt", r))
					r = utfrune("n\nr\rt\t", r)[1];
			}
			c[runetochar(c, (Rune*)&r)] = 0;
			for(i = 0; c[i] != 0; i++)
				v = buildstring(ctx, v, c[i]);
		}
		return res;

	default:
		p = buf;
		do{
			c[runetochar(c, (Rune*)&r)] = 0;
			if(p == (p2 = utfecpy(p, buf+sizeof(buf), c)))
				aa_error(ctx, "symbol too long");
			p = p2;
			r = Bgetrune(fp);
		}while(r > 0 && utfrune(delimiter, r) == nil);
		*p = '\0';
		ctx->nextrune = r;
		n.r = strtod(buf, &p); /* try to read as number */
		if(p != buf && utfrune(delimiter, *p) != nil)
			return aa_number(ctx, n);
		return aa_symbol(ctx, buf);
	}
}

aaObject *
aa_read(aaContext *ctx, Biobuf *fp)
{
	aaObject *obj = read_(ctx, fp);

	if(obj == &rparen)
		aa_error(ctx, "stray ')'");

	return obj;
}

static aaObject *
evallist(aaContext *ctx, aaObject *lst, aaObject *env)
{
	aaObject *res = &Null;
	aaObject **tail;

	for(tail = &res; !ISNULL(lst); tail = &CDR(*tail))
		*tail = aa_cons(ctx, eval(ctx, aa_nextarg(ctx, &lst, 0), env, nil), &Null);

	return res;
}

static aaObject *
runlist(aaContext *ctx, aaObject *lst, aaObject *env)
{
	aaObject *res;
	int save = aa_savegc(ctx);

	for(res = &Null; !ISNULL(lst);){
		aa_restoregc(ctx, save);
		aa_pushgc(ctx, lst);
		aa_pushgc(ctx, env);
		res = eval(ctx, aa_nextarg(ctx, &lst, 0), env, &env);
	}

	return res;
}

static aaObject *
argstoenv(aaContext *ctx, aaObject *prm, aaObject *arg, aaObject *env)
{
	while(!ISNULL(prm)){
		if(TYPE(prm) != AA_TPAIR){
			env = aa_cons(ctx, aa_cons(ctx, prm, arg), env);
			break;
		}
		env = aa_cons(ctx, aa_cons(ctx, CAR(prm), aa_car(ctx, arg)), env);
		prm = CDR(prm);
		arg = aa_cdr(ctx, arg);
	}

	return env;
}

#define noargs() do{ \
	if(!ISNULL(arg)) \
		aa_error(ctx, "%s needs %d arguments", primnames[prim], nargs); \
	}while(0)

static aaObject *
eval(aaContext *ctx, aaObject *obj, aaObject *env, aaObject **newenv)
{
	aaObject *fn, *arg, *res;
	aaObject cl, *va, *vb;
	aaNumber n, n2;
	int i, gc, prim, nargs;

	if(TYPE(obj) == AA_TSYMBOL){
		arg = getbound(ctx, obj, env);
		res = CDR(arg);
		if(ISUNBOUND(res))
			aa_error(ctx, "unbound variable: %ß", CAR(arg));
		return res;
	}
	if(TYPE(obj) != AA_TPAIR || ISNULL(obj))
		return obj;

	CAR(&cl) = obj, CDR(&cl) = ctx->calllist;
	ctx->calllist = &cl;

	gc = aa_savegc(ctx);
	fn = eval(ctx, CAR(obj), env, nil);
	arg = CDR(obj);
	res = &Null;

	switch(TYPE(fn)){
	case AA_TPRIM:
		nargs = 0;
		prim = PRIM(fn);
		switch(prim){
		case P_LET:
			va = checktype(ctx, aa_nextarg(ctx, &arg, 0), AA_TSYMBOL);
			if(newenv)
				*newenv = aa_cons(ctx, aa_cons(ctx, va, evalarg()), env);
			break;

		case P_DEFINE:
			res = checktype(ctx, aa_nextarg(ctx, &arg, 0), AA_TSYMBOL);
			CDR(getbound(ctx, res, env)) = evalarg();
			break;

		case P_SET_YAS:
			va = checktype(ctx, aa_nextarg(ctx, &arg, 0), AA_TSYMBOL);
			if(ISUNBOUND(CDR(CDR(va))))
				aa_error(ctx, "unbound variable: %ß", va);
			else
				aa_set(ctx, va, evalarg());
			break;

		case P_IF:
			while(!ISNULL(arg)){
				va = evalarg();
				if(!ISFALSE(va)){
					res = ISNULL(arg) ? va : evalarg();
					break;
				}
				if(ISNULL(arg))
					break;
				arg = CDR(arg);
			}
			break;

		case P_LAMBDA:
		case P_MAC:
			va = aa_cons(ctx, env, arg);
			aa_nextarg(ctx, &arg, 0);
			res = object(ctx);
			SETTYPE(res, PRIM(fn) == P_LAMBDA ? AA_TFUNC : AA_TMACRO);
			CDR(res) = va;
			break;

		case P_WHILE:
			va = aa_nextarg(ctx, &arg, 0);
			i = aa_savegc(ctx);
			while(!ISFALSE(eval(ctx, va, env, nil))){
				runlist(ctx, arg, env);
				aa_restoregc(ctx, i);
			}
			break;

		case P_QUOTE:
			res = aa_nextarg(ctx, &arg, 0);
			break;

		case P_EVAL:
			va = evalarg();
			vb = !ISNULL(arg) ? evalarg() : env;
			res = eval(ctx, va, vb, nil);
			break;

		case P_AND:
			while(!ISNULL(arg) && !ISFALSE(res = evalarg()));
			break;

		case P_OR:
			while(!ISNULL(arg) && ISFALSE(res = evalarg()));
			break;

		case P_BEGIN:
			res = runlist(ctx, arg, env);
			break;

		case P_CONS:
			va = evalarg();
			res = aa_cons(ctx, va, evalarg());
			noargs();
			break;

		case P_CAR:
			res = aa_car(ctx, evalarg());
			break;

		case P_CDR:
			res = aa_cdr(ctx, evalarg());
			break;

		case P_SETCAR:
			va = checktype(ctx, evalarg(), AA_TPAIR);
			CAR(va) = evalarg();
			break;

		case P_SETCDR:
			va = checktype(ctx, evalarg(), AA_TPAIR);
			CDR(va) = evalarg();
			break;

		case P_LIST:
			res = evallist(ctx, arg, env);
			break;

		case P_NOT:
			res = aa_bool(ctx, ISFALSE(evalarg()));
			break;

		case P_EQ_HUH:
			res = aa_bool(ctx, evalarg() == evalarg());
			noargs();
			break;

		case P_EQUAL_HUH:
			res = aa_bool(ctx, equal(evalarg(), evalarg()));
			noargs();
			break;

		case P_ATOM_HUH:
			res = aa_bool(ctx, aa_type(ctx, evalarg()) != AA_TPAIR);
			noargs();
			break;

		case P_NUMBER_HUH:
			res = aa_bool(ctx, aa_type(ctx, evalarg()) == AA_TNUMBER);
			noargs();
			break;

		case P_BOOLEAN_HUH:
			res = aa_bool(ctx, aa_type(ctx, evalarg()) == AA_TBOOL);
			noargs();
			break;

		case P_PORT_HUH:
			res = aa_bool(ctx, aa_type(ctx, evalarg()) == AA_TPORT);
			noargs();
			break;

		case P_DEFINED_HUH:
			va = checktype(ctx, evalarg(), AA_TSYMBOL);
			res = aa_bool(ctx, !ISUNBOUND(CDR(CDR(va))));
			noargs();
			break;

		case P_STRING_HUH:
			res = aa_bool(ctx, aa_type(ctx, evalarg()) == AA_TSTRING);
			noargs();
			break;

		case P_NAN_HUH:
			n = aa_tonumber(ctx, evalarg());
			res = aa_bool(ctx, isNaN(n.r));
			noargs();
			break;

		case P_INF_HUH:
			n = aa_tonumber(ctx, evalarg());
			res = aa_bool(ctx, isInf(n.r, -1) || isInf(n.r, +1));
			noargs();
			break;

		case P_DISPLAY:
			va = evalarg();
			if(!ISNULL(arg)) /* FIXME port */
				evalarg();
			noargs();
			res = aa_bool(ctx, Bprint(ctx->fd[1], "%ß", va) >= 0);
			break;

		case P_EQN: numcmpop(==); break;
		case P_LT: numcmpop(<); break;
		case P_GT: numcmpop(>); break;
		case P_LTE: numcmpop(<=); break;
		case P_GTE: numcmpop(>=); break;
		case P_ADD: arithop(+, 0); break;
		case P_MUL: arithop(*, 1); break;

		case P_SUB:
			n = aa_tonumber(ctx, evalarg());
			if(ISNULL(arg)){
				n.r = -n.r;
				res = aa_number(ctx, n);
			}else{
				arithop(+, 0);
				NUMBER(res).r = n.r - NUMBER(res).r;
			}
			break;

		case P_DIV:
			n = aa_tonumber(ctx, evalarg());
			if(ISNULL(arg)){
				n.r = 1.0/n.r;
				res = aa_number(ctx, n);
			}else{
				arithop(*, 1);
				NUMBER(res).r = n.r / NUMBER(res).r;
			}
			break;

		case P_MAX:
			n = aa_tonumber(ctx, evalarg());
			n2 = aa_tonumber(ctx, evalarg());
			n.r = MAX(n.r, n2.r);
			while(!ISNULL(arg)){
				n2 = aa_tonumber(ctx, evalarg());
				n.r = MAX(n.r, n2.r);
			}
			res = aa_number(ctx, n);
			break;

		case P_MIN:
			n = aa_tonumber(ctx, evalarg());
			n2 = aa_tonumber(ctx, evalarg());
			n.r = MIN(n.r, n2.r);
			while(!ISNULL(arg)){
				n2 = aa_tonumber(ctx, evalarg());
				n.r = MIN(n.r, n2.r);
			}
			res = aa_number(ctx, n);
			break;

		default:
			sysfatal("%s not implemented", primnames[PRIM(fn)]);
		}
		USED(nargs);
		break;

	case AA_TCFUNC:
		res = CFUNC(fn)(ctx, evallist(ctx, arg, env));
		if(res == nil)
			aa_error(ctx, "%r");
		break;

	case AA_TFUNC:
		arg = evallist(ctx, arg, env);
		va = CDR(fn); /* (env params ...) */
		vb = CDR(va); /* (params ...) */
		res = runlist(ctx, CDR(vb), argstoenv(ctx, CAR(vb), arg, CAR(va)));
		break;

	case AA_TMACRO:
		va = CDR(fn); /* (env params ...) */
		vb = CDR(va); /* (params ...) */
		/* replace caller object with code generated by macro and re-eval */
		*obj = *runlist(ctx, CDR(vb), argstoenv(ctx, CAR(vb), arg, CAR(va)));
		aa_restoregc(ctx, gc);
		ctx->calllist = CDR(&cl);
		return eval(ctx, obj, env, nil);

	default:
		aa_error(ctx, "tried to call non-callable value");
	}

	aa_restoregc(ctx, gc);
	aa_pushgc(ctx, res);
	ctx->calllist = CDR(&cl);

	return res;
}

aaObject *
aa_eval(aaContext *ctx, aaObject *obj)
{
	return eval(ctx, obj, &Null, nil);
}

static int
eof(Biobufhdr *, void *, long)
{
	return 0;
}

aaContext *
aa_open(void *ptr, int size, int flags)
{
	int i, save;
	aaContext *ctx;
	aaObject *v;
	Biobuf b;

	fmtinstall(L'ß', objfmt);
	fmtinstall(L'§', objfmt);

	/* init context struct */
	ctx = ptr;
	memset(ctx, 0, sizeof(aaContext));
	ptr = (char*)ptr + sizeof(aaContext);
	size -= sizeof(aaContext);

	/* init objects memory region */
	ctx->objects = (aaObject*)ptr;
	ctx->object_count = size / sizeof(aaObject);

	/* init lists */
	ctx->calllist = &Null;
	ctx->freelist = &Null;
	ctx->symlist = &Null;

	/* populate freelist */
	for(i = 0; i < ctx->object_count; i++){
		v = &ctx->objects[i];
		SETTYPE(v, AA_TFREE);
		CDR(v) = ctx->freelist;
		ctx->freelist = v;
	}

	/* register built in primitives */
	save = aa_savegc(ctx);
	for(i = 0; i < nelem(primnames); i++){
		v = object(ctx);
		SETTYPE(v, AA_TPRIM);
		PRIM(v) = i;
		aa_set(ctx, aa_symbol(ctx, primnames[i]), v);
		aa_restoregc(ctx, save);
	}
	aa_set(ctx, aa_symbol(ctx, "#t"), &True);
	aa_set(ctx, aa_symbol(ctx, "#f"), &False);
	aa_set(ctx, aa_symbol(ctx, "#true"), &True);
	aa_set(ctx, aa_symbol(ctx, "#false"), &False);
	aa_restoregc(ctx, save);

	if((flags & AA_NOSTDIO) == 0){
		ctx->fd[0] = Bfdopen(0, OREAD);
		ctx->fd[1] = Bfdopen(1, OWRITE);
		ctx->fd[2] = Bfdopen(2, OWRITE);
	}

	i = strlen(prelude);
	Binits(&b, -1, OREAD, (uchar*)prelude, i);
	b.icount = -i;
	Biofn(&b, eof);
	while((v = aa_read(ctx, &b)) != nil){
		aa_eval(ctx, v);
		aa_restoregc(ctx, save);
	}

	return ctx;
}

void
aa_close(aaContext *ctx)
{
	int i;

	for(i = 0; i < nelem(ctx->fd); i++)
		Bterm(ctx->fd[i]);

	/* clear gcstack and symlist; makes all objects unreachable */
	ctx->gcstack_idx = 0;
	ctx->symlist = &Null;
	collectgarbage(ctx);
}