shithub: femtolisp

ref: 19bd6a97e2538709bd9df13098db7c3a16c25680
dir: /flisp.c/

View raw version
/*
  femtoLisp

  by Jeff Bezanson (C) 2009
  Distributed under the BSD License
*/

#include "llt.h"
#include "flisp.h"
#include "operators.h"
#include "cvalues.h"
#include "opcodes.h"
#include "types.h"
#include "print.h"
#include "read.h"
#include "equal.h"

int
isbuiltin(value_t x)
{
	int i = uintval(x);
	return tag(x) == TAG_FUNCTION && i < nelem(builtins) && builtins[i].name != nil;
}

uint32_t N_STACK;
value_t *Stack;
uint32_t SP = 0;
uint32_t curr_frame = 0;
char *curr_fname = nil;

#define N_GC_HANDLES 1024
static value_t *GCHandleStack[N_GC_HANDLES];
static uint32_t N_GCHND = 0;

value_t FL_NIL, FL_T, FL_F, FL_EOF, QUOTE;
value_t IOError, ParseError, TypeError, ArgError, MemoryError;
value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
static value_t UnboundError;
value_t printwidthsym, printreadablysym, printprettysym, printlengthsym;
value_t printlevelsym, builtins_table_sym;

value_t NIL, LAMBDA, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;

value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
value_t definesym, defmacrosym, forsym, setqsym;
value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym, fnsym;
// for reading characters
value_t nulsym, alarmsym, backspacesym, tabsym, linefeedsym, newlinesym;
value_t vtabsym, pagesym, returnsym, escsym, spacesym, deletesym;

static value_t apply_cl(uint32_t nargs);

fl_readstate_t *readstate = nil;

uint8_t *fromspace;
uint8_t *tospace;
uint8_t *curheap;
uint8_t *lim;
uint32_t heapsize;//bytes
uint32_t *consflags;

void
free_readstate(fl_readstate_t *rs)
{
	htable_free(&rs->backrefs);
	htable_free(&rs->gensyms);
}

// error utilities ------------------------------------------------------------

// saved execution state for an unwind target
fl_exception_context_t *fl_ctx = nil;
uint32_t fl_throwing_frame = 0;  // active frame when exception was thrown
value_t fl_lasterror;

#define FL_TRY \
	fl_exception_context_t _ctx; int l__tr, l__ca; \
	_ctx.sp = SP; _ctx.frame = curr_frame; _ctx.rdst = readstate; _ctx.prev = fl_ctx; \
	_ctx.ngchnd = N_GCHND; fl_ctx = &_ctx; \
	if(!setjmp(_ctx.buf)) \
		for(l__tr = 1; l__tr; l__tr = 0, (void)(fl_ctx = fl_ctx->prev))

#define FL_CATCH_INC \
	l__ca = 0, fl_lasterror = FL_NIL, fl_throwing_frame = 0, SP = _ctx.sp, curr_frame = _ctx.frame

#define FL_CATCH \
	else \
		for(l__ca = 1; l__ca; FL_CATCH_INC)

#define FL_CATCH_NO_INC \
	else \
		for(l__ca = 1; l__ca;)

void
fl_savestate(fl_exception_context_t *_ctx)
{
	_ctx->sp = SP;
	_ctx->frame = curr_frame;
	_ctx->rdst = readstate;
	_ctx->prev = fl_ctx;
	_ctx->ngchnd = N_GCHND;
}

void
fl_restorestate(fl_exception_context_t *_ctx)
{
	fl_lasterror = FL_NIL;
	fl_throwing_frame = 0;
	SP = _ctx->sp;
	curr_frame = _ctx->frame;
}

_Noreturn void
fl_raise(value_t e)
{
	fl_lasterror = e;
	// unwind read state
	while(readstate != fl_ctx->rdst){
		free_readstate(readstate);
		readstate = readstate->prev;
	}
	if(fl_throwing_frame == 0)
		fl_throwing_frame = curr_frame;
	N_GCHND = fl_ctx->ngchnd;
	fl_exception_context_t *thisctx = fl_ctx;
	if(fl_ctx->prev)   // don't throw past toplevel
		fl_ctx = fl_ctx->prev;
	longjmp(thisctx->buf, 1);
}

static value_t
make_error_msg(char *format, va_list args)
{
	char msgbuf[512], *s;
	int n;
	if(curr_fname != nil){
		n = snprintf(msgbuf, sizeof(msgbuf), "%s: ", curr_fname);
		curr_fname = nil;
	}else{
		n = 0;
	}
	s = msgbuf + n;
	n = sizeof(msgbuf) - n;
	vsnprintf(s, n, format, args);
	return string_from_cstr(msgbuf);
}

_Noreturn void
lerrorf(value_t e, char *format, ...)
{
	va_list args;
	PUSH(e);
	va_start(args, format);
	value_t msg = make_error_msg(format, args);
	va_end(args);

	e = POP();
	fl_raise(fl_list2(e, msg));
}

_Noreturn void
type_error(char *expected, value_t got)
{
	fl_raise(fl_listn(4, TypeError, symbol(curr_fname), symbol(expected), got));
}

_Noreturn void
bounds_error(value_t arr, value_t ind)
{
	fl_raise(fl_listn(4, BoundsError, symbol(curr_fname), arr, ind));
}

_Noreturn void
unbound_error(value_t sym)
{
	fl_raise(fl_listn(3, UnboundError, symbol(curr_fname), sym));
}

// safe cast operators --------------------------------------------------------

#define isstring fl_isstring
#define SAFECAST_OP(type, ctype, cnvt) \
	ctype to##type(value_t v) \
	{ \
		if(is##type(v)) \
			return (ctype)cnvt(v); \
		type_error(#type, v); \
	}
SAFECAST_OP(cons, cons_t*, ptr)
SAFECAST_OP(symbol, symbol_t*, ptr)
SAFECAST_OP(fixnum, fixnum_t, numval)
SAFECAST_OP(cvalue, cvalue_t*, ptr)
SAFECAST_OP(string, char*, cvalue_data)
#undef isstring

// symbol table ---------------------------------------------------------------

symbol_t *symtab = nil;

int
fl_is_keyword_name(char *str, size_t len)
{
	return (str[0] == ':' || str[len-1] == ':') && str[1] != '\0';
}

static symbol_t *
mk_symbol(char *str)
{
	symbol_t *sym;
	size_t len = strlen(str);

	sym = calloc(1, sizeof(*sym)-sizeof(void*) + len + 1);
	assert(((uintptr_t)sym & 0x7) == 0); // make sure malloc aligns 8
	sym->numtype = NONNUMERIC;
	if(fl_is_keyword_name(str, len)){
		value_t s = tagptr(sym, TAG_SYM);
		setc(s, s);
		sym->flags |= FLAG_KEYWORD;
	}else{
		sym->binding = UNBOUND;
	}
	sym->hash = memhash32(str, len)^0xAAAAAAAA;
	memmove(sym->name, str, len+1);
	return sym;
}

static symbol_t **
symtab_lookup(symbol_t **ptree, char *str)
{
	int x;
	while(*ptree != nil && (x = strcmp(str, (*ptree)->name)) != 0)
		ptree = x < 0 ? &(*ptree)->left : &(*ptree)->right;
	return ptree;
}

value_t
symbol(char *str)
{
	symbol_t **pnode;

	pnode = symtab_lookup(&symtab, str);
	if(*pnode == nil)
		*pnode = mk_symbol(str);
	return tagptr(*pnode, TAG_SYM);
}

static uint32_t _gensym_ctr = 0;
// two static buffers for gensym printing so there can be two
// gensym names available at a time, mostly for compare()
static char gsname[2][16];
static int gsnameno = 0;
BUILTIN("gensym", gensym)
{
	argcount(nargs, 0);
	USED(args);
	gensym_t *gs = alloc_words(sizeof(gensym_t)/sizeof(void*));
	gs->id = _gensym_ctr++;
	gs->binding = UNBOUND;
	gs->isconst = 0;
	gs->type = nil;
	return tagptr(gs, TAG_SYM);
}

value_t
gensym(void)
{
	return fn_builtin_gensym(nil, 0);
}

BUILTIN("gensym?", gensymp)
{
	argcount(nargs, 1);
	return isgensym(args[0]) ? FL_T : FL_F;
}

char *
symbol_name(value_t v)
{
	if(ismanaged(v)){
		gensym_t *gs = (gensym_t*)ptr(v);
		gsnameno = 1-gsnameno;
		char *n = uint2str(gsname[gsnameno]+1, sizeof(gsname[0])-1, gs->id, 10);
		*(--n) = 'g';
		return n;
	}
	return ((symbol_t*)ptr(v))->name;
}

// conses ---------------------------------------------------------------------

value_t
mk_cons(void)
{
	cons_t *c;

	if(__unlikely(curheap > lim))
		gc(0);
	c = (cons_t*)curheap;
	curheap += sizeof(cons_t);
	return tagptr(c, TAG_CONS);
}

void *
alloc_words(int n)
{
	value_t *first;

	assert(n > 0);
	n = LLT_ALIGN(n, 2);   // only allocate multiples of 2 words
	if(__unlikely((value_t*)curheap > ((value_t*)lim)+2-n)){
		gc(0);
		while((value_t*)curheap > ((value_t*)lim)+2-n){
			gc(1);
		}
	}
	first = (value_t*)curheap;
	curheap += (n*sizeof(value_t));
	return first;
}

value_t the_empty_vector;

value_t
alloc_vector(size_t n, int init)
{
	if(n == 0)
		return the_empty_vector;
	value_t *c = alloc_words(n+1);
	value_t v = tagptr(c, TAG_VECTOR);
	vector_setsize(v, n);
	if(init){
		unsigned int i;
		for(i = 0; i < n; i++)
			vector_elt(v, i) = FL_UNSPECIFIED;
	}
	return v;
}

// cvalues --------------------------------------------------------------------

//#include "cvalues.c"
//#include "types.c"

// print ----------------------------------------------------------------------

//static int isnumtok(char *tok, value_t *pval);
//static inline int symchar(char c);
extern inline int symchar(char c);

//#include "print.c"

// collector ------------------------------------------------------------------

void
fl_gc_handle(value_t *pv)
{
	if(N_GCHND >= N_GC_HANDLES)
		lerrorf(MemoryError, "out of gc handles");
	GCHandleStack[N_GCHND++] = pv;
}

void
fl_free_gc_handles(uint32_t n)
{
	assert(N_GCHND >= n);
	N_GCHND -= n;
}

value_t
relocate(value_t v)
{
	value_t a, d, nc, first, *pcdr;
	uintptr_t t = tag(v);

	if(t == TAG_CONS){
		// iterative implementation allows arbitrarily long cons chains
		pcdr = &first;
		do{
			if((a = car_(v)) == TAG_FWD){
				*pcdr = cdr_(v);
				return first;
			}
			*pcdr = nc = tagptr((cons_t*)curheap, TAG_CONS);
			curheap += sizeof(cons_t);
			d = cdr_(v);
			car_(v) = TAG_FWD;
			cdr_(v) = nc;
			car_(nc) = relocate(a);
			pcdr = &cdr_(nc);
			v = d;
		}while(iscons(v));
		*pcdr = d == NIL ? NIL : relocate(d);
		return first;
	}

	if((t&3) == 0)
		return v;
	if(!ismanaged(v))
		return v;
	if(isforwarded(v))
		return forwardloc(v);

	if(t == TAG_VECTOR){
		// N.B.: 0-length vectors secretly have space for a first element
		size_t i, sz = vector_size(v);
		if(vector_elt(v, -1) & 0x1){
			// grown vector
			nc = relocate(vector_elt(v, 0));
			forward(v, nc);
		}else{
			nc = tagptr(alloc_words(sz+1), TAG_VECTOR);
			vector_setsize(nc, sz);
			a = vector_elt(v, 0);
			forward(v, nc);
			if(sz > 0){
				vector_elt(nc, 0) = relocate(a);
				for(i = 1; i < sz; i++)
					vector_elt(nc, i) = relocate(vector_elt(v, i));
			}
		}
		return nc;
	}
	if(t == TAG_CPRIM){
		cprim_t *pcp = ptr(v);
		size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size);
		cprim_t *ncp = alloc_words(nw);
		while(nw--)
			((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
		nc = tagptr(ncp, TAG_CPRIM);
		forward(v, nc);
		return nc;
	}
	if(t == TAG_CVALUE)
		return cvalue_relocate(v);
	if(t == TAG_FUNCTION){
		function_t *fn = ptr(v);
		function_t *nfn = alloc_words(4);
		nfn->bcode = fn->bcode;
		nfn->vals = fn->vals;
		nc = tagptr(nfn, TAG_FUNCTION);
		forward(v, nc);
		nfn->env = relocate(fn->env);
		nfn->vals = relocate(nfn->vals);
		nfn->bcode = relocate(nfn->bcode);
		assert(!ismanaged(fn->name));
		nfn->name = fn->name;
		return nc;
	}
	if(t == TAG_SYM){
		gensym_t *gs = ptr(v);
		gensym_t *ng = alloc_words(sizeof(gensym_t)/sizeof(void*));
		ng->id = gs->id;
		ng->binding = gs->binding;
		ng->isconst = 0;
		nc = tagptr(ng, TAG_SYM);
		forward(v, nc);
		if(ng->binding != UNBOUND)
			ng->binding = relocate(ng->binding);
		return nc;
	}
	return v;
}

value_t
relocate_lispvalue(value_t v)
{
	return relocate(v);
}

static void
trace_globals(symbol_t *root)
{
	while(root != nil){
		if(root->binding != UNBOUND)
			root->binding = relocate(root->binding);
		trace_globals(root->left);
		root = root->right;
	}
}

static value_t memory_exception_value;

void
gc(int mustgrow)
{
	static int grew = 0;
	void *temp;
	uint32_t i, f, top;
	fl_readstate_t *rs;

	curheap = tospace;
	if(grew)
		lim = curheap+heapsize*2-sizeof(cons_t);
	else
		lim = curheap+heapsize-sizeof(cons_t);

	if(fl_throwing_frame > curr_frame){
		top = fl_throwing_frame - 4;
		f = Stack[fl_throwing_frame-4];
	}else{
		top = SP;
		f = curr_frame;
	}
	while(1){
		for(i = f; i < top; i++)
			Stack[i] = relocate(Stack[i]);
		if(f == 0)
			break;
		top = f - 4;
		f = Stack[f-4];
	}
	for(i = 0; i < N_GCHND; i++)
		*GCHandleStack[i] = relocate(*GCHandleStack[i]);
	trace_globals(symtab);
	relocate_typetable();
	rs = readstate;
	while(rs){
		value_t ent;
		for(i = 0; i < rs->backrefs.size; i++){
			ent = (value_t)rs->backrefs.table[i];
			if(ent != (value_t)HT_NOTFOUND)
				rs->backrefs.table[i] = (void*)relocate(ent);
		}
		for(i = 0; i < rs->gensyms.size; i++){
			ent = (value_t)rs->gensyms.table[i];
			if(ent != (value_t)HT_NOTFOUND)
				rs->gensyms.table[i] = (void*)relocate(ent);
		}
		rs->source = relocate(rs->source);
		rs = rs->prev;
	}
	fl_lasterror = relocate(fl_lasterror);
	memory_exception_value = relocate(memory_exception_value);
	the_empty_vector = relocate(the_empty_vector);

	sweep_finalizers();

#ifdef VERBOSEGC
	printf("GC: found %d/%d live conses\n",
		   (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
#endif
	temp = tospace;
	tospace = fromspace;
	fromspace = temp;

	// if we're using > 80% of the space, resize tospace so we have
	// more space to fill next time. if we grew tospace last time,
	// grow the other half of the heap this time to catch up.
	if(grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow){
		temp = LLT_REALLOC(tospace, heapsize*2);
		if(temp == nil)
			fl_raise(memory_exception_value);
		tospace = temp;
		if(grew){
			heapsize *= 2;
			temp = bitvector_resize(consflags, 0, heapsize/sizeof(cons_t), 1);
			if(temp == nil)
				fl_raise(memory_exception_value);
			consflags = (uint32_t*)temp;
		}
		grew = !grew;
	}
	if(curheap > lim)  // all data was live
		gc(0);
}

static void
grow_stack(void)
{
	size_t newsz = N_STACK * 2;
	value_t *ns = realloc(Stack, newsz*sizeof(value_t));
	if(ns == nil)
		lerrorf(MemoryError, "stack overflow");
	Stack = ns;
	N_STACK = newsz;
}

// utils ----------------------------------------------------------------------

static char *
cvalue_name(value_t v)
{
	cvalue_t *cv = ptr(v);
	static char name[64];
	value_t label;

	void *data = cptr(v);
	void *fptr = *(void**)data;
	label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, cv);
	if(label == (value_t)HT_NOTFOUND)
		snprintf(name, sizeof(name), "#<builtin @%p>", fptr);
	else
		snprintf(name, sizeof(name), "#fn(%s)", symbol_name(label));
	return name;
}


// apply function with n args on the stack
static value_t
_applyn(uint32_t n)
{
	value_t f = Stack[SP-n-1];
	uint32_t saveSP = SP;
	value_t v;
	if(iscbuiltin(f)){
		curr_fname = cvalue_name(f);
		v = ((builtin_t*)ptr(f))[3](&Stack[SP-n], n);
	}else if(isfunction(f)){
		v = apply_cl(n);
	}else if(isbuiltin(f)){
		value_t tab = symbol_value(builtins_table_sym);
		if(ptr(tab) == nil)
			unbound_error(tab);
		Stack[SP-n-1] = vector_elt(tab, uintval(f));
		curr_fname = builtins[uintval(f)].name;
		v = apply_cl(n);
	}else{
		type_error("function", f);
	}
	SP = saveSP;
	return v;
}

value_t
fl_apply(value_t f, value_t l)
{
	value_t v = l;
	uint32_t n = SP;

	PUSH(f);
	while(iscons(v)){
		if(SP >= N_STACK)
			grow_stack();
		PUSH(car_(v));
		v = cdr_(v);
	}
	n = SP - n - 1;
	v = _applyn(n);
	POPN(n+1);
	return v;
}

value_t
fl_applyn(uint32_t n, value_t f, ...)
{
	va_list ap;
	va_start(ap, f);
	size_t i;

	PUSH(f);
	while(SP+n > N_STACK)
		grow_stack();
	for(i = 0; i < n; i++){
		value_t a = va_arg(ap, value_t);
		PUSH(a);
	}
	value_t v = _applyn(n);
	POPN(n+1);
	va_end(ap);
	return v;
}

value_t
fl_listn(size_t n, ...)
{
	va_list ap;
	va_start(ap, n);
	uint32_t si = SP;
	size_t i;

	while(SP+n > N_STACK)
		grow_stack();
	for(i = 0; i < n; i++){
		value_t a = va_arg(ap, value_t);
		PUSH(a);
	}
	cons_t *c = alloc_words(n*2);
	cons_t *l = c;
	for(i = 0; i < n; i++){
		c->car = Stack[si++];
		c->cdr = tagptr(c+1, TAG_CONS);
		c++;
	}
	c[-1].cdr = NIL;

	POPN(n);
	va_end(ap);
	return tagptr(l, TAG_CONS);
}

value_t
fl_list2(value_t a, value_t b)
{
	PUSH(a);
	PUSH(b);
	cons_t *c = alloc_words(4);
	b = POP();
	a = POP();
	c[0].car = a;
	c[0].cdr = tagptr(c+1, TAG_CONS);
	c[1].car = b;
	c[1].cdr = NIL;
	return tagptr(c, TAG_CONS);
}

value_t
fl_cons(value_t a, value_t b)
{
	PUSH(a);
	PUSH(b);
	value_t c = mk_cons();
	cdr_(c) = POP();
	car_(c) = POP();
	return c;
}

int
fl_isnumber(value_t v)
{
	if(isfixnum(v))
		return 1;
	if(iscprim(v)){
		cprim_t *c = ptr(v);
		return c->type != wchartype;
	}
	if(iscvalue(v)){
		cvalue_t *c = ptr(v);
		return valid_numtype(cv_class(c)->numtype);
	}
	return 0;
}

// read -----------------------------------------------------------------------

//#include "read.c"

// equal ----------------------------------------------------------------------

//#include "equal.c"

// eval -----------------------------------------------------------------------

static value_t
list(value_t *args, uint32_t nargs, int star)
{
	cons_t *c;
	uint32_t i;
	value_t v;
	v = cons_reserve(nargs);
	c = ptr(v);
	for(i = 0; i < nargs; i++){
		c->car = args[i];
		c->cdr = tagptr(c+1, TAG_CONS);
		c++;
	}
	if(star)
		(c-2)->cdr = (c-1)->car;
	else
		(c-1)->cdr = NIL;
	return v;
}

static value_t
copy_list(value_t L)
{
	if(!iscons(L))
		return NIL;
	PUSH(NIL);
	PUSH(L);
	value_t *plcons = &Stack[SP-2];
	value_t *pL = &Stack[SP-1];
	value_t c;
	c = mk_cons(); PUSH(c);  // save first cons
	car_(c) = car_(*pL);
	cdr_(c) = NIL;
	*plcons = c;
	*pL = cdr_(*pL);
	while(iscons(*pL)){
		c = mk_cons();
		car_(c) = car_(*pL);
		cdr_(c) = NIL;
		cdr_(*plcons) = c;
		*plcons = c;
		*pL = cdr_(*pL);
	}
	c = POP();  // first cons
	POPN(2);
	return c;
}

static value_t
do_trycatch(void)
{
	uint32_t saveSP = SP;
	value_t v = NIL;
	value_t thunk = Stack[SP-2];
	Stack[SP-2] = Stack[SP-1];
	Stack[SP-1] = thunk;

	FL_TRY{
		v = apply_cl(0);
	}
	FL_CATCH{
		v = Stack[saveSP-2];
		PUSH(v);
		PUSH(fl_lasterror);
		v = apply_cl(1);
	}
	SP = saveSP;
	return v;
}

/*
  argument layout on stack is
  |--required args--|--opt args--|--kw args--|--rest args...
*/
static uint32_t
process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw, uint32_t nopt, uint32_t bp, uint32_t nargs, int va)
{
	uint32_t extr = nopt+nkw;
	uint32_t ntot = nreq+extr;
	value_t args[64], v = NIL;
	uint32_t i, a = 0, nrestargs;
	value_t s1 = Stack[SP-1];
	value_t s2 = Stack[SP-2];
	value_t s4 = Stack[SP-4];
	value_t s5 = Stack[SP-5];
	if(nargs < nreq)
		lerrorf(ArgError, "too few arguments");
	if(extr > nelem(args))
		lerrorf(ArgError, "too many arguments");
	for(i = 0; i < extr; i++)
		args[i] = UNBOUND;
	for(i = nreq; i < nargs; i++){
		v = Stack[bp+i];
		if(issymbol(v) && iskeyword((symbol_t*)ptr(v)))
			break;
		if(a >= nopt)
			goto no_kw;
		args[a++] = v;
	}
	if(i >= nargs)
		goto no_kw;
	// now process keywords
	uintptr_t n = vector_size(kwtable)/2;
	do{
		i++;
		if(i >= nargs)
			lerrorf(ArgError, "keyword %s requires an argument", symbol_name(v));
		value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
		lltint_t lx = numval(hv);
		uintptr_t x = 2*((lx < 0 ? -lx : lx) % n);
		if(vector_elt(kwtable, x) == v){
			uintptr_t idx = numval(vector_elt(kwtable, x+1));
			assert(idx < nkw);
			idx += nopt;
			if(args[idx] == UNBOUND){
				// if duplicate key, keep first value
				args[idx] = Stack[bp+i];
			}
		}else{
			lerrorf(ArgError, "unsupported keyword %s", symbol_name(v));
		}
		i++;
		if(i >= nargs)
			break;
		v = Stack[bp+i];
	}while(issymbol(v) && iskeyword((symbol_t*)ptr(v)));
no_kw:
	nrestargs = nargs - i;
	if(!va && nrestargs > 0)
		lerrorf(ArgError, "too many arguments");
	nargs = ntot + nrestargs;
	if(nrestargs)
		memmove(&Stack[bp+ntot], &Stack[bp+i], nrestargs*sizeof(value_t));
	memmove(&Stack[bp+nreq], args, extr*sizeof(value_t));
	SP = bp + nargs;
	assert(SP < N_STACK-5);
	PUSH(s5);
	PUSH(s4);
	PUSH(nargs);
	PUSH(s2);
	PUSH(s1);
	curr_frame = SP;
	return nargs;
}

#if BYTE_ORDER == BIG_ENDIAN
#define GET_INT32(a) \
	((int32_t) \
	((((int32_t)a[0])<<0)  | \
	 (((int32_t)a[1])<<8)  | \
	 (((int32_t)a[2])<<16) | \
	 (((int32_t)a[3])<<24)))
#define GET_INT16(a) \
	((int16_t) \
	((((int16_t)a[0])<<0)  | \
	 (((int16_t)a[1])<<8)))
#define PUT_INT32(a, i) (*(int32_t*)(a) = bswap_32((int32_t)(i)))
#else
#define GET_INT32(a) (*(int32_t*)a)
#define GET_INT16(a) (*(int16_t*)a)
#define PUT_INT32(a, i) (*(int32_t*)(a) = (int32_t)(i))
#endif

#define OP(x) case x:
#define NEXT_OP break

/*
  stack on entry: <func>  <nargs args...>
  caller's responsibility:
  - put the stack in this state
  - provide arg count
  - respect tail position
  - restore SP

  callee's responsibility:
  - check arg counts
  - allocate vararg array
  - push closed env, set up new environment
*/
static value_t
apply_cl(uint32_t nargs)
{
	uint32_t top_frame = curr_frame;
	// frame variables
	uint32_t n, captured;
	uint32_t bp;
	const uint8_t *ip;
	fixnum_t s, hi;
	int tail;

	// temporary variables (not necessary to preserve across calls)
	uint32_t op, i;
	symbol_t *sym;
	cons_t *c;
	value_t *pv;
	int64_t accum;
	value_t func, v, e;

	n = 0;
	v = 0;
	USED(n);
	USED(v);
apply_cl_top:
	captured = 0;
	func = Stack[SP-nargs-1];
	ip = cv_data((cvalue_t*)ptr(fn_bcode(func)));
	assert(!ismanaged((uintptr_t)ip));
	while(SP+GET_INT32(ip) > N_STACK)
		grow_stack();
	ip += 4;

	bp = SP-nargs;
	PUSH(fn_env(func));
	PUSH(curr_frame);
	PUSH(nargs);
	SP++;//PUSH(0); //ip
	PUSH(0); //captured?
	curr_frame = SP;

	op = *ip++;
	while(1){
		if(op < nelem(builtins) && builtins[op].name != nil)
			curr_fname = builtins[op].name;

		switch(op){
		OP(OP_LOADA0)
			PUSH(captured ? vector_elt(Stack[bp], 0) : Stack[bp]);
			NEXT_OP;

		OP(OP_LOADA1)
			PUSH(captured ? vector_elt(Stack[bp], 1) : Stack[bp+1]);
			NEXT_OP;

		OP(OP_LOADV)
			v = fn_vals(Stack[bp-1]);
			assert(*ip < vector_size(v));
			PUSH(vector_elt(v, *ip++));
			NEXT_OP;

		OP(OP_BRF)
			ip += POP() == FL_F ? GET_INT16(ip) : 2;
			NEXT_OP;

		OP(OP_POP)
			POPN(1);
			NEXT_OP;

		OP(OP_TCALLL)
			tail = 1;
			if(0){
		OP(OP_CALLL)
				tail = 0;
			}
			n = GET_INT32(ip);
			ip += 4;
			if(0){
		OP(OP_TCALL)
				tail = 1;
				if(0){
		OP(OP_CALL)
					tail = 0;
				}
				n = *ip++;  // nargs
			}
		do_call:
			func = Stack[SP-n-1];
			if(tag(func) == TAG_FUNCTION){
				if(func > (N_BUILTINS<<3)){
					if(tail){
						curr_frame = Stack[curr_frame-4];
						for(s = -1; s < (fixnum_t)n; s++)
							Stack[bp+s] = Stack[SP-n+s];
						SP = bp+n;
					}else{
						Stack[curr_frame-2] = (uintptr_t)ip;
					}
					nargs = n;
					function_t *fn = (function_t*)ptr(func);
					curr_fname = fn->name == LAMBDA ? "lambda" : symbol_name(fn->name);
					goto apply_cl_top;
				}else{
					i = uintval(func);
					if(isbuiltin(func)){
						s = builtins[i].nargs;
						if(s >= 0)
							argcount(n, s);
						else if(s != ANYARGS && (signed)n < -s)
							argcount(n, -s);
						// remove function arg
						for(s = SP-n-1; s < (int)SP-1; s++)
							Stack[s] = Stack[s+1];
						SP--;
						curr_fname = builtins[i].name;
						switch(i){
						case OP_LIST:   goto apply_list;
						case OP_VECTOR: goto apply_vector;
						case OP_APPLY:  goto apply_apply;
						case OP_ADD:	goto apply_add;
						case OP_SUB:	goto apply_sub;
						case OP_MUL:	goto apply_mul;
						case OP_DIV:	goto apply_div;
						default:
							op = i;
							continue;
						}
					}
				}
			}else if(iscbuiltin(func)){
				s = SP;
				curr_fname = cvalue_name(func);
				v = ((builtin_t)(((void**)ptr(func))[3]))(&Stack[SP-n], n);
				SP = s-n;
				Stack[SP-1] = v;
				NEXT_OP;
			}
			type_error("function", func);

		OP(OP_LOADGL)
			v = fn_vals(Stack[bp-1]);
			v = vector_elt(v, GET_INT32(ip));
			ip += 4;
			if(0){
		OP(OP_LOADG)
				v = fn_vals(Stack[bp-1]);
				assert(*ip < vector_size(v));
				v = vector_elt(v, *ip);
				ip++;
			}
			assert(issymbol(v));
			sym = (symbol_t*)ptr(v);
			if(sym->binding == UNBOUND)
				unbound_error(v);
			PUSH(sym->binding);
			NEXT_OP;

		OP(OP_LOADA)
			assert(nargs > 0);
			i = *ip++;
			if(captured){
				e = Stack[bp];
				assert(isvector(e));
				assert(i < vector_size(e));
				v = vector_elt(e, i);
			}else{
				v = Stack[bp+i];
			}
			PUSH(v);
			NEXT_OP;

		OP(OP_LOADC)
			s = *ip++;
			i = *ip++;
			v = Stack[bp+nargs];
			while(s--)
				v = vector_elt(v, vector_size(v)-1);
			assert(isvector(v));
			assert(i < vector_size(v));
			PUSH(vector_elt(v, i));
			NEXT_OP;

		OP(OP_RET)
			v = POP();
			SP = curr_frame;
			curr_frame = Stack[SP-4];
			if(curr_frame == top_frame)
				return v;
			SP -= 5+nargs;
			captured = Stack[curr_frame-1];
			ip = (uint8_t*)Stack[curr_frame-2];
			nargs = Stack[curr_frame-3];
			bp = curr_frame - 5 - nargs;
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_DUP)
			SP++;
			Stack[SP-1] = Stack[SP-2];
			NEXT_OP;

		OP(OP_CAR)
			v = Stack[SP-1];
			if(!iscons(v))
				type_error("cons", v);
			Stack[SP-1] = car_(v);
			NEXT_OP;

		OP(OP_CDR)
			v = Stack[SP-1];
			if(!iscons(v))
				type_error("cons", v);
			Stack[SP-1] = cdr_(v);
			NEXT_OP;

		OP(OP_CLOSURE)
			// build a closure (lambda args body . env)
			if(nargs > 0 && !captured){
				// save temporary environment to the heap
				n = nargs;
				pv = alloc_words(n + 2);
				PUSH(tagptr(pv, TAG_VECTOR));
				pv[0] = fixnum(n+1);
				pv++;
				do{
					pv[n] = Stack[bp+n];
				}while(n--);
				// environment representation changed; install
				// the new representation so everybody can see it
				captured = 1;
				Stack[curr_frame-1] = 1;
				Stack[bp] = Stack[SP-1];
			}else{
				PUSH(Stack[bp]); // env has already been captured; share
			}
			if(curheap > lim-2)
				gc(0);
			pv = (value_t*)curheap;
			curheap += (4*sizeof(value_t));
			e = Stack[SP-2];  // closure to copy
			assert(isfunction(e));
			pv[0] = ((value_t*)ptr(e))[0];
			pv[1] = ((value_t*)ptr(e))[1];
			pv[2] = Stack[SP-1];  // env
			pv[3] = ((value_t*)ptr(e))[3];
			POPN(1);
			Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
			NEXT_OP;

		OP(OP_SETA)
			assert(nargs > 0);
			v = Stack[SP-1];
			i = *ip++;
			if(captured){
				e = Stack[bp];
				assert(isvector(e));
				assert(i < vector_size(e));
				vector_elt(e, i) = v;
			}else{
				Stack[bp+i] = v;
			}
			NEXT_OP;

		OP(OP_JMP)
			ip += GET_INT16(ip);
			NEXT_OP;

		OP(OP_LOADC00)
			PUSH(vector_elt(Stack[bp+nargs], 0));
			NEXT_OP;

		OP(OP_PAIRP)
			Stack[SP-1] = iscons(Stack[SP-1]) ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_BRNE)
			ip += Stack[SP-2] != Stack[SP-1] ? GET_INT16(ip) : 2;
			POPN(2);
			NEXT_OP;

		OP(OP_LOADT)
			PUSH(FL_T);
			NEXT_OP;

		OP(OP_LOAD0)
			PUSH(fixnum(0));
			NEXT_OP;

		OP(OP_LOADC01)
			PUSH(vector_elt(Stack[bp+nargs], 1));
			NEXT_OP;

		OP(OP_AREF)
			v = Stack[SP-2];
			if(isvector(v)){
				e = Stack[SP-1];
				i = isfixnum(e) ? numval(e) : (uint32_t)toulong(e);
				if((unsigned)i >= vector_size(v))
					bounds_error(v, e);
				v = vector_elt(v, i);
			}else if(isarray(v)){
				v = cvalue_array_aref(&Stack[SP-2]);
			}else{
				type_error("sequence", v);
			}
			POPN(1);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_ATOMP)
			Stack[SP-1] = iscons(Stack[SP-1]) ? FL_F : FL_T;
			NEXT_OP;

		OP(OP_BRT)
			ip += POP() != FL_F ? GET_INT16(ip) : 2;
			NEXT_OP;

		OP(OP_BRNN)
			ip += POP() != NIL ? GET_INT16(ip) : 2;
			NEXT_OP;

		OP(OP_LOAD1)
			PUSH(fixnum(1));
			NEXT_OP;

		OP(OP_LT)
			if(bothfixnums(Stack[SP-2], Stack[SP-1]))
				v = numval(Stack[SP-2]) < numval(Stack[SP-1]) ? FL_T : FL_F;
			else
				v = numval(fl_compare(Stack[SP-2], Stack[SP-1])) < 0 ? FL_T : FL_F;
			POPN(1);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_ADD2)
			if(bothfixnums(Stack[SP-1], Stack[SP-2])){
				s = numval(Stack[SP-1]) + numval(Stack[SP-2]);
				v = fits_fixnum(s) ? fixnum(s) : mk_xlong(s);
			}else{
				v = fl_add_any(&Stack[SP-2], 2, 0);
			}
			POPN(1);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_SETCDR)
			cdr(Stack[SP-2]) = Stack[SP-1];
			POPN(1);
			NEXT_OP;

		OP(OP_LOADF)
			PUSH(FL_F);
			NEXT_OP;

		OP(OP_CONS)
			if(curheap > lim)
				gc(0);
			c = (cons_t*)curheap;
			curheap += sizeof(cons_t);
			c->car = Stack[SP-2];
			c->cdr = Stack[SP-1];
			Stack[SP-2] = tagptr(c, TAG_CONS);
			POPN(1); NEXT_OP;

		OP(OP_EQ)
			Stack[SP-2] = Stack[SP-2] == Stack[SP-1] ? FL_T : FL_F;
			POPN(1);
			NEXT_OP;

		OP(OP_SYMBOLP)
			Stack[SP-1] = issymbol(Stack[SP-1]) ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_NOT)
			Stack[SP-1] = Stack[SP-1] == FL_F ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_CADR)
			v = Stack[SP-1];
			if(!iscons(v))
				type_error("cons", v);
			v = cdr_(v);
			if(!iscons(v))
				type_error("cons", v);
			Stack[SP-1] = car_(v);
			NEXT_OP;

		OP(OP_NEG)
		do_neg:
			Stack[SP-1] = fl_neg(Stack[SP-1]);
			NEXT_OP;

		OP(OP_NULLP)
			Stack[SP-1] = Stack[SP-1] == NIL ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_BOOLEANP)
			v = Stack[SP-1];
			Stack[SP-1] = (v == FL_T || v == FL_F) ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_NUMBERP)
			v = Stack[SP-1];
			Stack[SP-1] = fl_isnumber(v) ? FL_T:FL_F;
			NEXT_OP;

		OP(OP_FIXNUMP)
			Stack[SP-1] = isfixnum(Stack[SP-1]) ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_BOUNDP)
			sym = tosymbol(Stack[SP-1]);
			Stack[SP-1] = sym->binding == UNBOUND ? FL_F : FL_T;
			NEXT_OP;

		OP(OP_BUILTINP)
			v = Stack[SP-1];
			Stack[SP-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_FUNCTIONP)
			v = Stack[SP-1];
			Stack[SP-1] = ((tag(v) == TAG_FUNCTION &&
							(isbuiltin(v) || v>(N_BUILTINS<<3))) ||
						   iscbuiltin(v)) ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_VECTORP)
			Stack[SP-1] = isvector(Stack[SP-1]) ? FL_T : FL_F;
			NEXT_OP;

		OP(OP_JMPL)
			ip += GET_INT32(ip);
			NEXT_OP;

		OP(OP_BRFL)
			ip += POP() == FL_F ? GET_INT32(ip) : 4;
			NEXT_OP;

		OP(OP_BRTL)
			ip += POP() != FL_F ? GET_INT32(ip) : 4;
			NEXT_OP;

		OP(OP_BRNEL)
			ip += Stack[SP-2] != Stack[SP-1] ? GET_INT32(ip) : 4;
			POPN(2);
			NEXT_OP;

		OP(OP_BRNNL)
			ip += POP() != NIL ? GET_INT32(ip) : 4;
			NEXT_OP;

		OP(OP_BRN)
			ip += POP() == NIL ? GET_INT16(ip) : 2;
			NEXT_OP;

		OP(OP_BRNL)
			ip += POP() == NIL ? GET_INT32(ip) : 4;
			NEXT_OP;

		OP(OP_EQV)
			if(Stack[SP-2] == Stack[SP-1])
				v = FL_T;
			else if(!leafp(Stack[SP-2]) || !leafp(Stack[SP-1]))
				v = FL_F;
			else
				v = compare_(Stack[SP-2], Stack[SP-1], 1) == 0 ? FL_T : FL_F;
			Stack[SP-2] = v;
			POPN(1);
			NEXT_OP;

		OP(OP_EQUAL)
			if(Stack[SP-2] == Stack[SP-1])
				v = FL_T;
			else
				v = compare_(Stack[SP-2], Stack[SP-1], 1) == 0 ? FL_T : FL_F;
			Stack[SP-2] = v;
			POPN(1);
			NEXT_OP;

		OP(OP_SETCAR)
			car(Stack[SP-2]) = Stack[SP-1];
			POPN(1);
			NEXT_OP;

		OP(OP_LIST)
			n = *ip++;
		apply_list:
			if(n > 0){
				v = list(&Stack[SP-n], n, 0);
				POPN(n);
				PUSH(v);
			}else{
				PUSH(NIL);
			}
			NEXT_OP;

		OP(OP_TAPPLY)
			tail = 1;
			if(0){
		OP(OP_APPLY)
				tail = 0;
			}
			n = *ip++;
		apply_apply:
			v = POP();	 // arglist
			n = SP-(n-2);  // n-2 == # leading arguments not in the list
			while(iscons(v)){
				if(SP >= N_STACK)
					grow_stack();
				PUSH(car_(v));
				v = cdr_(v);
			}
			n = SP-n;
			goto do_call;

		OP(OP_ADD)
			n = *ip++;
		apply_add:
			s = 0;
			i = SP-n;
			for(; i < SP; i++){
				if(isfixnum(Stack[i])){
					s += numval(Stack[i]);
					if(!fits_fixnum(s)){
						i++;
						goto add_ovf;
					}
				}else{
				add_ovf:
					v = fl_add_any(&Stack[i], SP-i, s);
					break;
				}
			}
			if(i == SP)
				v = fixnum(s);
			POPN(n);
			PUSH(v);
			NEXT_OP;

		OP(OP_SUB)
			n = *ip++;
		apply_sub:
			if(n == 2)
				goto do_sub2;
			if(n == 1)
				goto do_neg;
			i = SP-n;
			// we need to pass the full arglist on to fl_add_any
			// so it can handle rest args properly
			PUSH(Stack[i]);
			Stack[i] = fixnum(0);
			Stack[i+1] = fl_neg(fl_add_any(&Stack[i], n, 0));
			Stack[i] = POP();
			v = fl_add_any(&Stack[i], 2, 0);
			POPN(n);
			PUSH(v);
			NEXT_OP;

		OP(OP_SUB2)
		do_sub2:
			if(bothfixnums(Stack[SP-2], Stack[SP-1])){
				s = numval(Stack[SP-2]) - numval(Stack[SP-1]);
				v = fits_fixnum(s) ? fixnum(s) : mk_xlong(s);
			}else{
				Stack[SP-1] = fl_neg(Stack[SP-1]);
				v = fl_add_any(&Stack[SP-2], 2, 0);
			}
			POPN(1);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_MUL)
			n = *ip++;
		apply_mul:
			accum = 1;
			for(i = SP-n; i < SP; i++){
				if(isfixnum(Stack[i])){
					accum *= numval(Stack[i]);
				}else{
					v = fl_mul_any(&Stack[i], SP-i, accum);
					break;
				}
			}
			if(i == SP)
				v = fits_fixnum(accum) ? fixnum(accum) : return_from_int64(accum);
			POPN(n);
			PUSH(v);
			NEXT_OP;

		OP(OP_DIV)
			n = *ip++;
		apply_div:
			i = SP-n;
			if(n == 1){
				Stack[SP-1] = fl_div2(fixnum(1), Stack[i]);
			}else{
				if(n > 2){
					PUSH(Stack[i]);
					Stack[i] = fixnum(1);
					Stack[i+1] = fl_mul_any(&Stack[i], n, 1);
					Stack[i] = POP();
				}
				v = fl_div2(Stack[i], Stack[i+1]);
				POPN(n);
				PUSH(v);
			}
			NEXT_OP;

		OP(OP_IDIV)
			v = Stack[SP-2]; e = Stack[SP-1];
			if(bothfixnums(v, e)){
				if(e == 0)
					DivideByZeroError();
				v = fixnum(numval(v) / numval(e));
			}else
				v = fl_idiv2(v, e);
			POPN(1);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_NUMEQ)
			v = Stack[SP-2]; e = Stack[SP-1];
			if(bothfixnums(v, e))
				v = v == e ? FL_T : FL_F;
			else
				v = numeric_compare(v, e, 1, 0, 1) == 0 ? FL_T : FL_F;
			POPN(1);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_COMPARE)
			Stack[SP-2] = compare_(Stack[SP-2], Stack[SP-1], 0);
			POPN(1);
			NEXT_OP;

		OP(OP_ARGC)
			n = *ip++;
			if(0){
		OP(OP_LARGC)
				n = GET_INT32(ip);
				ip += 4;
			}
			argcount(nargs, n);
			NEXT_OP;

		OP(OP_VECTOR)
			n = *ip++;
		apply_vector:
			v = alloc_vector(n, 0);
			if(n){
				memmove(&vector_elt(v, 0), &Stack[SP-n], n*sizeof(value_t));
				POPN(n);
			}
			PUSH(v);
			NEXT_OP;

		OP(OP_ASET)
			e = Stack[SP-3];
			if(isvector(e)){
				i = tofixnum(Stack[SP-2]);
				if((unsigned)i >= vector_size(e))
					bounds_error(v, Stack[SP-1]);
				vector_elt(e, i) = (v = Stack[SP-1]);
			}else if(isarray(e)){
				v = cvalue_array_aset(&Stack[SP-3]);
			}else{
				type_error("sequence", e);
			}
			POPN(2);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_FOR)
			s  = tofixnum(Stack[SP-3]);
			hi = tofixnum(Stack[SP-2]);
			//f = Stack[SP-1];
			v = FL_UNSPECIFIED;
			SP += 2;
			n = SP;
			for(; s <= hi; s++){
				Stack[SP-2] = Stack[SP-3];
				Stack[SP-1] = fixnum(s);
				v = apply_cl(1);
				SP = n;
			}
			POPN(4);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_LOADNIL)
			PUSH(NIL);
			NEXT_OP;

		OP(OP_LOADI8)
			s = (int8_t)*ip++;
			PUSH(fixnum(s));
			NEXT_OP;

		OP(OP_LOADVL)
			v = fn_vals(Stack[bp-1]);
			v = vector_elt(v, GET_INT32(ip));
			ip += 4;
			PUSH(v);
			NEXT_OP;

		OP(OP_SETGL)
			v = fn_vals(Stack[bp-1]);
			v = vector_elt(v, GET_INT32(ip));
			ip += 4;
			if(0){
		OP(OP_SETG)
				v = fn_vals(Stack[bp-1]);
				assert(*ip < vector_size(v));
				v = vector_elt(v, *ip);
				ip++;
			}
			assert(issymbol(v));
			sym = (symbol_t*)ptr(v);
			v = Stack[SP-1];
			if(!isconstant(sym))
				sym->binding = v;
			NEXT_OP;

		OP(OP_LOADAL)
			assert(nargs > 0);
			i = GET_INT32(ip);
			ip += 4;
			v = captured ? vector_elt(Stack[bp], i) : Stack[bp+i];
			PUSH(v);
			NEXT_OP;

		OP(OP_SETAL)
			assert(nargs > 0);
			v = Stack[SP-1];
			i = GET_INT32(ip);
			ip += 4;
			if(captured)
				vector_elt(Stack[bp], i) = v;
			else
				Stack[bp+i] = v;
			NEXT_OP;

		OP(OP_SETC)
			s = *ip++;
			i = *ip++;
			v = Stack[bp+nargs];
			while(s--)
				v = vector_elt(v, vector_size(v)-1);
			assert(isvector(v));
			assert(i < vector_size(v));
			vector_elt(v, i) = Stack[SP-1];
			NEXT_OP;

		OP(OP_LOADCL)
			s = GET_INT32(ip);
			ip += 4;
			i = GET_INT32(ip);
			ip += 4;
			v = Stack[bp+nargs];
			while(s--)
				v = vector_elt(v, vector_size(v)-1);
			PUSH(vector_elt(v, i));
			NEXT_OP;

		OP(OP_SETCL)
			s = GET_INT32(ip);
			ip += 4;
			i = GET_INT32(ip);
			ip += 4;
			v = Stack[bp+nargs];
			while(s--)
				v = vector_elt(v, vector_size(v)-1);
			assert(i < vector_size(v));
			vector_elt(v, i) = Stack[SP-1];
			NEXT_OP;

		OP(OP_VARGC)
			i = *ip++;
			if(0){
		OP(OP_LVARGC)
				i = GET_INT32(ip);
				ip += 4;
			}
			s = (fixnum_t)nargs - (fixnum_t)i;
			if(s > 0){
				v = list(&Stack[bp+i], s, 0);
				Stack[bp+i] = v;
				if(s > 1){
					Stack[bp+i+1] = Stack[bp+nargs+0];
					Stack[bp+i+2] = Stack[bp+nargs+1];
					Stack[bp+i+3] = i+1;
					//Stack[bp+i+4] = 0;
					Stack[bp+i+5] = 0;
					SP =  bp+i+6;
					curr_frame = SP;
				}
			}else if(s < 0){
				lerrorf(ArgError, "too few arguments");
			}else{
				PUSH(0);
				Stack[SP-3] = i+1;
				Stack[SP-4] = Stack[SP-5];
				Stack[SP-5] = Stack[SP-6];
				Stack[SP-6] = NIL;
				curr_frame = SP;
			}
			nargs = i+1;
			NEXT_OP;

		OP(OP_TRYCATCH)
			v = do_trycatch();
			POPN(1);
			Stack[SP-1] = v;
			NEXT_OP;

		OP(OP_OPTARGS)
			i = GET_INT32(ip);
			ip += 4;
			n = GET_INT32(ip);
			ip += 4;
			if(nargs < i)
				lerrorf(ArgError, "too few arguments");
			if((int32_t)n > 0){
				if(nargs > n)
					lerrorf(ArgError, "too many arguments");
			}else
				n = -n;
			if(n > nargs){
				n -= nargs;
				SP += n;
				Stack[SP-1] = Stack[SP-n-1];
				Stack[SP-2] = Stack[SP-n-2];
				Stack[SP-3] = nargs+n;
				Stack[SP-4] = Stack[SP-n-4];
				Stack[SP-5] = Stack[SP-n-5];
				curr_frame = SP;
				for(i = 0; i < n; i++)
					Stack[bp+nargs+i] = UNBOUND;
				nargs += n;
			}
			NEXT_OP;

		OP(OP_BRBOUND)
			i = GET_INT32(ip);
			ip += 4;
			v = captured ? vector_elt(Stack[bp], i) : Stack[bp+i];
			PUSH(v != UNBOUND ? FL_T : FL_F);
			NEXT_OP;

		OP(OP_KEYARGS)
			v = fn_vals(Stack[bp-1]);
			v = vector_elt(v, 0);
			i = GET_INT32(ip);
			ip += 4;
			n = GET_INT32(ip);
			ip += 4;
			s = GET_INT32(ip);
			ip += 4;
			nargs = process_keys(v, i, n, labs(s)-(i+n), bp, nargs, s<0);
			NEXT_OP;
		}
		op = *ip++;
	}
}

#define SWAP_INT32(a)
#define SWAP_INT16(a)
#include "maxstack.inc"

#if BYTE_ORDER == BIG_ENDIAN
#undef SWAP_INT32
#undef SWAP_INT16
#if defined(__sparc__)
#define SWAP_INT32(a) \
	do{ \
		uint8_t *x = (void*)a, y; \
		y = x[0]; x[0] = x[3]; x[3] = y; \
		y = x[1]; x[1] = x[2]; x[2] = y; \
	}while(0)
#define SWAP_INT16(a) \
	do{ \
		uint8_t *x = (void*)a, y; \
		y = x[0]; x[0] = x[1]; x[1] = y; \
	}while(0)
#else
#define SWAP_INT32(a) (*(int32_t*)(a) = bswap_32(*(int32_t*)(a)))
#define SWAP_INT16(a) (*(int16_t*)(a) = bswap_16(*(int16_t*)(a)))
#endif
#define compute_maxstack compute_maxstack_swap
#include "maxstack.inc"
#undef compute_maxstack
#else
#endif

// top = top frame pointer to start at
static value_t
_stacktrace(uint32_t top)
{
	uint32_t bp, sz;
	value_t v, lst = NIL;
	fl_gc_handle(&lst);
	while(top > 0){
		sz = Stack[top-3]+1;
		bp = top-5-sz;
		v = alloc_vector(sz, 0);
		if(Stack[top-1] /*captured*/){
			vector_elt(v, 0) = Stack[bp];
			memmove(&vector_elt(v, 1),
				   &vector_elt(Stack[bp+1], 0), (sz-1)*sizeof(value_t));
		}else{
			uint32_t i;
			for(i = 0; i < sz; i++){
				value_t si = Stack[bp+i];
				// if there's an error evaluating argument defaults some slots
				// might be left set to UNBOUND (issue #22)
				vector_elt(v, i) = si == UNBOUND ? FL_UNSPECIFIED : si;
			}
		}
		lst = fl_cons(v, lst);
		top = Stack[top-4];
	}
	fl_free_gc_handles(1);
	return lst;
}

// builtins -------------------------------------------------------------------

BUILTIN("gc", gc)
{
	USED(args);
	argcount(nargs, 0);
	gc(0);
	return FL_T;
}

BUILTIN("function", function)
{
	if(nargs == 1 && issymbol(args[0]))
		return fn_builtin_builtin(args, nargs);
	if(nargs < 2 || nargs > 4)
		argcount(nargs, 2);
	if(!fl_isstring(args[0]))
		type_error("string", args[0]);
	if(!isvector(args[1]))
		type_error("vector", args[1]);
	cvalue_t *arr = (cvalue_t*)ptr(args[0]);
	cv_pin(arr);
	char *data = cv_data(arr);
	uint32_t ms;
	if((uint8_t)data[4] >= N_OPCODES){
		// read syntax, shifted 48 for compact text representation
		size_t i, sz = cv_len(arr);
		for(i = 0; i < sz; i++)
			data[i] -= 48;
#if BYTE_ORDER == BIG_ENDIAN
		ms = compute_maxstack((uint8_t*)data, cv_len(arr));
	}else{
		ms = compute_maxstack_swap((uint8_t*)data, cv_len(arr));
	}
#else
	}
	ms = compute_maxstack((uint8_t*)data, cv_len(arr));
#endif
	PUT_INT32(data, ms);
	function_t *fn = alloc_words(4);
	value_t fv = tagptr(fn, TAG_FUNCTION);
	fn->bcode = args[0];
	fn->vals = args[1];
	fn->env = NIL;
	fn->name = LAMBDA;
	if(nargs > 2){
		if(issymbol(args[2])){
			fn->name = args[2];
			if(nargs > 3)
				fn->env = args[3];
		}else{
			fn->env = args[2];
			if(nargs > 3){
				if(!issymbol(args[3]))
					type_error("symbol", args[3]);
				fn->name = args[3];
			}
		}
		if(isgensym(fn->name))
			lerrorf(ArgError, "name should not be a gensym");
	}
	return fv;
}

BUILTIN("function:code", function_code)
{
	argcount(nargs, 1);
	value_t v = args[0];
	if(!isclosure(v))
		type_error("function", v);
	return fn_bcode(v);
}

BUILTIN("function:vals", function_vals)
{
	argcount(nargs, 1);
	value_t v = args[0];
	if(!isclosure(v))
		type_error("function", v);
	return fn_vals(v);
}

BUILTIN("function:env", function_env)
{
	argcount(nargs, 1);
	value_t v = args[0];
	if(!isclosure(v))
		type_error("function", v);
	return fn_env(v);
}

BUILTIN("function:name", function_name)
{
	argcount(nargs, 1);
	value_t v = args[0];
	if(!isclosure(v))
		type_error("function", v);
	return fn_name(v);
}

BUILTIN("copy-list", copy_list)
{
	argcount(nargs, 1);
	return copy_list(args[0]);
}

BUILTIN("append", append)
{
	value_t first = NIL, lst, lastcons = NIL;
	int i;
	if(nargs == 0)
		return NIL;
	fl_gc_handle(&first);
	fl_gc_handle(&lastcons);
	for(i = 0; i < nargs; i++){
		lst = args[i];
		if(iscons(lst)){
			lst = copy_list(lst);
			if(first == NIL)
				first = lst;
			else
				cdr_(lastcons) = lst;
			lastcons = tagptr((((cons_t*)curheap)-1), TAG_CONS);
		}else if(lst != NIL){
			type_error("cons", lst);
		}
	}
	fl_free_gc_handles(2);
	return first;
}

BUILTIN("list*", liststar)
{
	if(nargs == 1)
		return args[0];
	if(nargs == 0)
		argcount(nargs, 1);
	return list(args, nargs, 1);
}

BUILTIN("stacktrace", stacktrace)
{
	USED(args);
	argcount(nargs, 0);
	return _stacktrace(fl_throwing_frame ? fl_throwing_frame : curr_frame);
}

BUILTIN("map", map)
{
	if(nargs < 2)
		lerrorf(ArgError, "too few arguments");
	if(!iscons(args[1]))
		return NIL;
	value_t first, last, v;
	int64_t argSP = args-Stack;
	assert(argSP >= 0 && argSP < N_STACK);
	if(nargs == 2){
		if(SP+3 > N_STACK)
			grow_stack();
		PUSH(Stack[argSP]);
		PUSH(car_(Stack[argSP+1]));
		v = _applyn(1);
		PUSH(v);
		v = mk_cons();
		car_(v) = POP(); cdr_(v) = NIL;
		last = first = v;
		Stack[argSP+1] = cdr_(Stack[argSP+1]);
		fl_gc_handle(&first);
		fl_gc_handle(&last);
		while(iscons(Stack[argSP+1])){
			Stack[SP-2] = Stack[argSP];
			Stack[SP-1] = car_(Stack[argSP+1]);
			v = _applyn(1);
			PUSH(v);
			v = mk_cons();
			car_(v) = POP(); cdr_(v) = NIL;
			cdr_(last) = v;
			last = v;
			Stack[argSP+1] = cdr_(Stack[argSP+1]);
		}
		POPN(2);
		fl_free_gc_handles(2);
	}else{
		int i;
		while(SP+nargs+1 > N_STACK)
			grow_stack();
		PUSH(Stack[argSP]);
		for(i = 1; i < nargs; i++){
			PUSH(car(Stack[argSP+i]));
			Stack[argSP+i] = cdr_(Stack[argSP+i]);
		}
		v = _applyn(nargs-1);
		POPN(nargs);
		PUSH(v);
		v = mk_cons();
		car_(v) = POP(); cdr_(v) = NIL;
		last = first = v;
		fl_gc_handle(&first);
		fl_gc_handle(&last);
		while(iscons(Stack[argSP+1])){
			PUSH(Stack[argSP]);
			for(i = 1; i < nargs; i++){
				PUSH(car(Stack[argSP+i]));
				Stack[argSP+i] = cdr_(Stack[argSP+i]);
			}
			v = _applyn(nargs-1);
			POPN(nargs);
			PUSH(v);
			v = mk_cons();
			car_(v) = POP(); cdr_(v) = NIL;
			cdr_(last) = v;
			last = v;
		}
		fl_free_gc_handles(2);
	}
	return first;
}

static const builtinspec_t builtin_fns[] = {
#define BUILTIN_FN(l, c){l, fn_builtin_##c},
#include "builtin_fns.h"
#undef BUILTIN_FN

};

// initialization -------------------------------------------------------------

extern void comparehash_init(void);
extern void table_init(void);
extern void iostream_init(void);

static void
lisp_init(size_t initial_heapsize)
{
	int i;

	llt_init();
	setlocale(LC_NUMERIC, "C");

	heapsize = initial_heapsize;

	fromspace = LLT_ALLOC(heapsize);
	tospace   = LLT_ALLOC(heapsize);
	curheap = fromspace;
	lim = curheap+heapsize-sizeof(cons_t);
	consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
	htable_new(&printconses, 32);
	comparehash_init();
	N_STACK = 262144;
	Stack = malloc(N_STACK*sizeof(value_t));

	FL_NIL = NIL = builtin(OP_THE_EMPTY_LIST);
	FL_T = builtin(OP_BOOL_CONST_T);
	FL_F = builtin(OP_BOOL_CONST_F);
	FL_EOF = builtin(OP_EOF_OBJECT);
	LAMBDA = symbol("lambda");
	FUNCTION = symbol("function");
	QUOTE = symbol("quote");
	TRYCATCH = symbol("trycatch");
	BACKQUOTE = symbol("quasiquote");
	COMMA = symbol("unquote");
	COMMAAT = symbol("unquote-splicing");
	COMMADOT = symbol("unquote-nsplicing");
	IOError = symbol("io-error");
	ParseError = symbol("parse-error");
	TypeError = symbol("type-error");
	ArgError = symbol("arg-error");
	UnboundError = symbol("unbound-error");
	KeyError = symbol("key-error");
	MemoryError = symbol("memory-error");
	BoundsError = symbol("bounds-error");
	DivideError = symbol("divide-error");
	EnumerationError = symbol("enumeration-error");
	Error = symbol("error");
	pairsym = symbol("pair");
	symbolsym = symbol("symbol");
	fixnumsym = symbol("fixnum");
	vectorsym = symbol("vector");
	builtinsym = symbol("builtin");
	booleansym = symbol("boolean");
	nullsym = symbol("null");
	definesym = symbol("define");
	defmacrosym = symbol("define-macro");
	forsym = symbol("for");
	setqsym = symbol("set!");
	evalsym = symbol("eval");
	vu8sym = symbol("vu8");
	fnsym = symbol("fn");
	nulsym = symbol("nul");
	alarmsym = symbol("alarm");
	backspacesym = symbol("backspace");
	tabsym = symbol("tab");
	linefeedsym = symbol("linefeed");
	vtabsym = symbol("vtab");
	pagesym = symbol("page");
	returnsym = symbol("return");
	escsym = symbol("esc");
	spacesym = symbol("space");
	deletesym = symbol("delete");
	newlinesym = symbol("newline");
	tsym = symbol("t");
	Tsym = symbol("T");
	fsym = symbol("f");
	Fsym = symbol("F");
	builtins_table_sym = symbol("*builtins*");
	set(printprettysym = symbol("*print-pretty*"), FL_T);
	set(printreadablysym = symbol("*print-readably*"), FL_T);
	set(printwidthsym = symbol("*print-width*"), fixnum(SCR_WIDTH));
	set(printlengthsym = symbol("*print-length*"), FL_F);
	set(printlevelsym = symbol("*print-level*"), FL_F);
	fl_lasterror = NIL;
	for(i = 0; i < nelem(builtins); i++){
		if(builtins[i].name)
			setc(symbol(builtins[i].name), builtin(i));
	}
	setc(symbol("eq"), builtin(OP_EQ));
	setc(symbol("procedure?"), builtin(OP_FUNCTIONP));
	setc(symbol("top-level-bound?"), builtin(OP_BOUNDP));

#if defined(__linux__)
	set(symbol("*os-name*"), symbol("linux"));
#elif defined(__OpenBSD__)
	set(symbol("*os-name*"), symbol("openbsd"));
#elif defined(__FreeBSD__)
	set(symbol("*os-name*"), symbol("freebsd"));
#elif defined(__NetBSD__)
	set(symbol("*os-name*"), symbol("netbsd"));
#elif defined(__DragonFly__)
	set(symbol("*os-name*"), symbol("dragonflybsd"));
#elif defined(__plan9__)
	set(symbol("*os-name*"), symbol("plan9"));
#else
	set(symbol("*os-name*"), symbol("unknown"));
#endif

	the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR);
	vector_setsize(the_empty_vector, 0);

	cvalues_init();

	memory_exception_value = fl_list2(MemoryError, cvalue_static_cstring("out of memory"));
	const builtinspec_t *b;
	for(i = 0, b = builtin_fns; i < nelem(builtin_fns); i++, b++)
		setc(symbol(b->name), cbuiltin(b->name, b->fptr));

	table_init();
	iostream_init();
}

// top level ------------------------------------------------------------------

value_t
fl_toplevel_eval(value_t expr)
{
	return fl_applyn(1, symbol_value(evalsym), expr);
}

void
fl_init(size_t initial_heapsize)
{
#ifdef BOEHM_GC
	GC_init();
#endif
	lisp_init(initial_heapsize);
}

int
fl_load_system_image(value_t sys_image_iostream)
{
	value_t e;
	int saveSP;
	symbol_t *sym;

	PUSH(sys_image_iostream);
	saveSP = SP;
	FL_TRY{
		curr_fname = "bootstrap";
		while(1){
			e = fl_read_sexpr(Stack[SP-1]);
			if(ios_eof(value2c(ios_t*, Stack[SP-1])))
				break;
			if(isfunction(e)){
				// stage 0 format: series of thunks
				PUSH(e);
				(void)_applyn(0);
				SP = saveSP;
			}else{
				// stage 1 format: list alternating symbol/value
				while(iscons(e)){
					sym = tosymbol(car_(e));
					e = cdr_(e);
					(void)tocons(e);
					sym->binding = car_(e);
					e = cdr_(e);
				}
				break;
			}
		}
	}
	FL_CATCH_NO_INC{
		ios_puts("fatal error during bootstrap:\n", ios_stderr);
		fl_print(ios_stderr, fl_lasterror);
		ios_putc('\n', ios_stderr);
		return 1;
	}
	ios_close(value2c(ios_t*, Stack[SP-1]));
	POPN(1);
	return 0;
}