upscheme/c/flisp.c

/*
  femtoLisp

  a compact interpreter for a minimal lisp/scheme dialect

  characteristics:
  * lexical scope, lisp-1
  * unrestricted macros
  * data types: 30-bit integer, symbol, pair, vector, char, string, table
      iostream, procedure, low-level data types
  * case-sensitive
  * simple compacting copying garbage collector
  * Scheme-style varargs (dotted formal argument lists)
  * "human-readable" bytecode with self-hosted compiler

  extra features:
  * circular structure can be printed and read
  * #. read macro for eval-when-read and readably printing builtins
  * read macros for backquote
  * symbol character-escaping printer
  * exceptions
  * gensyms (can be usefully read back in, too)
  * #| multiline comments |#, lots of other lexical syntax
  * generic compare function, cyclic equal
  * cvalues system providing C data types and a C FFI
  * constructor notation for nicely printing arbitrary values

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

#include <sys/types.h>

#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <limits.h>
#include <locale.h>
#include <math.h>
#include <setjmp.h>
#include <stdarg.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <wctype.h>

#include "dtypes.h"
#include "utils.h"
#include "utf8.h"
#include "ios.h"
#include "socket.h"
#include "timefuncs.h"
#include "hashing.h"
#include "htable.h"
#include "htableh_inc.h"
#include "bitvector.h"
#include "os.h"
#include "random.h"
#include "llt.h"

#include "ieee754.h"

#include "flisp.h"

#include "error.h"

#include "argcount.h"
#include "env.h"
#include "opcodes.h"

#include "../scheme-boot/boot_image.h"

static char *builtin_names[] = {
    NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
    // predicates
    "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
    "number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?",
    "function?",

    // lists
    "cons", "list", "car", "cdr", "set-car!", "set-cdr!",

    // execution
    "apply",

    // arithmetic
    "+", "-", "*", "/", "div0", "=", "<", "compare",

    // sequences
    "vector", "aref", "aset!", "", "", ""
};

#define ANYARGS -10000

static short builtin_arg_counts[] = {
    0, 0, 0, 0,  0,       0,  0,       0,  0, 0, 0, 0, 2,       2,       2,
    1, 1, 1, 1,  1,       1,  1,       1,  1, 1, 1, 1, 2,       ANYARGS, 1,
    1, 2, 2, -2, ANYARGS, -1, ANYARGS, -1, 2, 2, 2, 2, ANYARGS, 2,       3
};

static uint32_t N_STACK;
static value_t *Stack;
static uint32_t SP = 0;
static uint32_t curr_frame = 0;
#define PUSH(v) (Stack[SP++] = (v))
#define POP() (Stack[--SP])
#define POPN(n) (SP -= (n))

#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, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
value_t printwidthsym, printreadablysym, printprettysym, printlengthsym;
value_t printlevelsym, builtins_table_sym;

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

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

static value_t apply_cl(uint32_t nargs);
static value_t *alloc_words(int n);
static value_t relocate(value_t v);

static struct fl_readstate *readstate = NULL;

static void free_readstate(struct fl_readstate *rs)
{
    htable_free(&rs->backrefs);
    htable_free(&rs->gensyms);
}

static unsigned char *fromspace;
static unsigned char *tospace;
static unsigned char *curheap;
static unsigned char *lim;
static uint32_t heapsize;  // bytes
static uint32_t *consflags;

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

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

#define FL_TRY                        \
    struct fl_exception_context _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                                                     \
    else for (l__ca = 1; l__ca; l__ca = 0, fl_lasterror = FL_NIL,    \
                                fl_throwing_frame = 0, SP = _ctx.sp, \
                                curr_frame = _ctx.frame)

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

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

void fl_raise(value_t e)
{
    struct fl_exception_context *thisctx;

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

    vsnprintf(msgbuf, sizeof(msgbuf), format, args);
    return string_from_cstr(msgbuf);
}

void lerrorf(value_t e, char *format, ...)
{
    va_list args;
    value_t msg;

    PUSH(e);
    va_start(args, format);
    msg = make_error_msg(format, args);
    va_end(args);
    e = POP();
    fl_raise(fl_list2(e, msg));
}

void lerror(value_t e, const char *msg)
{
    value_t m;

    PUSH(e);
    m = cvalue_static_cstring(msg);
    e = POP();
    fl_raise(fl_list2(e, m));
}

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

void bounds_error(char *fname, value_t arr, value_t ind)
{
    fl_raise(fl_listn(4, BoundsError, symbol(fname), arr, ind));
}

void DivideByZeroError(void) { lerror(DivideError, "/: division by zero"); }

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

#define isstring fl_isstring
// TODO: Remove the spurious return statement.
#define SAFECAST_OP(type, ctype, cnvt)     \
    ctype to##type(value_t v, char *fname) \
    {                                      \
        if (is##type(v))                   \
            return (ctype)cnvt(v);         \
        type_error(fname, #type, v);       \
        return (ctype)FL_NIL;              \
    }
SAFECAST_OP(cons, struct cons *, ptr)
SAFECAST_OP(symbol, struct symbol *, ptr)
SAFECAST_OP(fixnum, fixnum_t, numval)
SAFECAST_OP(cvalue, struct cvalue *, ptr)
SAFECAST_OP(string, char *, cvalue_data)
#undef isstring

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

struct symbol *symtab = NULL;

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

static struct symbol *mk_symbol(const char *str)
{
    struct symbol *sym;
    size_t len = strlen(str);

    sym =
    (struct symbol *)malloc(sizeof(struct symbol) - sizeof(void *) + len + 1);
    assert(((uintptr_t)sym & 0x7) == 0);  // make sure malloc aligns 8
    sym->left = sym->right = NULL;
    sym->flags = 0;
    if (fl_is_keyword_name(str, len)) {
        value_t s = tagptr(sym, TAG_SYM);
        setc(s, s);
        sym->flags |= 0x2;
    } else {
        sym->binding = UNBOUND;
    }
    sym->type = sym->dlcache = NULL;
    sym->hash = memhash32(str, len) ^ 0xAAAAAAAA;
    memcpy(&sym->name[0], str, len + 1);
    return sym;
}

static struct symbol **symtab_lookup(struct symbol **ptree, const char *str)
{
    int x;

    while (*ptree != NULL) {
        x = strcmp(str, (*ptree)->name);
        if (x == 0)
            return ptree;
        if (x < 0)
            ptree = &(*ptree)->left;
        else
            ptree = &(*ptree)->right;
    }
    return ptree;
}

value_t symbol(const char *str)
{
    struct symbol **pnode;

    pnode = symtab_lookup(&symtab, str);
    if (*pnode == NULL)
        *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;
value_t fl_gensym(value_t *args, uint32_t nargs)
{
    struct gensym *gs;

    (void)args;
    argcount("gensym", nargs, 0);
    gs = (struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *));
    gs->id = _gensym_ctr++;
    gs->binding = UNBOUND;
    gs->isconst = 0;
    gs->type = NULL;
    return tagptr(gs, TAG_SYM);
}

int fl_isgensym(value_t v) { return isgensym(v); }

static value_t fl_gensymp(value_t *args, uint32_t nargs)
{
    argcount("gensym?", nargs, 1);
    return isgensym(args[0]) ? FL_T : FL_F;
}

char *symbol_name(value_t v)
{
    struct gensym *gs;
    char *n;

    if (ismanaged(v)) {
        gs = (struct gensym *)ptr(v);
        gsnameno = 1 - gsnameno;
        n = uint2str(gsname[gsnameno] + 1, sizeof(gsname[0]) - 1, gs->id, 10);
        *(--n) = 'g';
        return n;
    }
    return ((struct symbol *)ptr(v))->name;
}

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

void gc(int mustgrow);

static value_t mk_cons(void)
{
    struct cons *c;

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

static value_t *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;
}

// allocate n consecutive conses
#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)

#define cons_index(c) (((struct cons *)ptr(c)) - ((struct cons *)fromspace))
#define ismarked(c) bitvector_get(consflags, cons_index(c))
#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)

static value_t the_empty_vector;

value_t alloc_vector(size_t n, int init)
{
    value_t *c;
    value_t v;
    unsigned int i;

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

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

#include "ptrhash.h"
#include "operators.h"
#include "cvalues.h"
#include "equalhash.h"
#include "types.h"

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

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

#include "print.h"

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

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

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

static value_t relocate(value_t v)
{
    value_t a, d, nc, first, *pcdr;
    uintptr_t 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((struct cons *)curheap, TAG_CONS);
            curheap += sizeof(struct cons);
            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;
    } else if (t == TAG_CPRIM) {
        struct cprim *pcp = (struct cprim *)ptr(v);
        size_t nw = CPRIM_NWORDS - 1 + NWORDS(cp_class(pcp)->size);
        struct cprim *ncp = (struct cprim *)alloc_words(nw);
        while (nw--)
            ((value_t *)ncp)[nw] = ((value_t *)pcp)[nw];
        nc = tagptr(ncp, TAG_CPRIM);
        forward(v, nc);
        return nc;
    } else if (t == TAG_CVALUE) {
        return cvalue_relocate(v);
    } else if (t == TAG_FUNCTION) {
        struct function *fn = (struct function *)ptr(v);
        struct function *nfn = (struct function *)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;
    } else if (t == TAG_SYM) {
        struct gensym *gs = (struct gensym *)ptr(v);
        struct gensym *ng =
        (struct gensym *)alloc_words(sizeof(struct gensym) / 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(struct symbol *root)
{
    while (root != NULL) {
        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;
    struct fl_readstate *rs;

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

    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(struct cons),
           heapsize / sizeof(struct cons));
#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 == NULL)
            fl_raise(memory_exception_value);
        tospace = temp;
        if (grew) {
            heapsize *= 2;
            temp =
            bitvector_resize(consflags, 0, heapsize / sizeof(struct cons), 1);
            if (temp == NULL)
                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 + (N_STACK >> 1);
    value_t *ns = realloc(Stack, newsz * sizeof(value_t));
    if (ns == NULL)
        lerror(MemoryError, "stack overflow");
    Stack = ns;
    N_STACK = newsz;
}

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

// 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)) {
        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);
        Stack[SP - n - 1] = vector_elt(tab, uintval(f));
        v = apply_cl(n);
    } else {
        type_error("apply", "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;
    value_t v;
    size_t i;

    va_start(ap, f);
    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);
    }
    v = _applyn(n);
    POPN(n + 1);
    va_end(ap);
    return v;
}

value_t fl_listn(size_t n, ...)
{
    struct cons *c;
    struct cons *l;
    va_list ap;
    uint32_t si;
    size_t i;

    si = SP;
    va_start(ap, n);
    while (SP + n > N_STACK)
        grow_stack();
    for (i = 0; i < n; i++) {
        value_t a = va_arg(ap, value_t);
        PUSH(a);
    }
    c = (struct cons *)alloc_words(n * 2);
    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)
{
    struct cons *c;

    PUSH(a);
    PUSH(b);
    c = (struct cons *)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)
{
    value_t c;

    PUSH(a);
    PUSH(b);
    c = mk_cons();
    cdr_(c) = POP();
    car_(c) = POP();
    return c;
}

int fl_isnumber(value_t v)
{
    struct cprim *c;

    if (isfixnum(v))
        return 1;
    if (iscprim(v)) {
        c = (struct cprim *)ptr(v);
        return c->type != wchartype;
    }
    return 0;
}

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

#include "read.h"

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

#include "equal.h"

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

#define list(a, n) _list((a), (n), 0)

static value_t _list(value_t *args, uint32_t nargs, int star)
{
    struct cons *c;
    uint32_t i;
    value_t v;

    v = cons_reserve(nargs);
    c = (struct cons *)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)
{
    value_t *plcons;
    value_t *pL;
    value_t c;

    if (!iscons(L))
        return NIL;
    PUSH(NIL);
    PUSH(L);
    plcons = &Stack[SP - 2];
    pL = &Stack[SP - 1];
    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)
{
    value_t v, thunk;
    uint32_t saveSP;

    saveSP = SP;
    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)
{
    value_t hv;
    uintptr_t x;
    uintptr_t idx;
    uintptr_t n;
    uint32_t ntot;
    value_t v;
    uint32_t extr;
    value_t *args;
    uint32_t nrestargs, i, a;
    value_t s1, s2, s4, s5;

    extr = nopt + nkw;
    ntot = nreq + extr;
    if (!(args = calloc(extr, sizeof(*args)))) {
        lerror(MemoryError, "out of memory");
    }
    a = 0;
    s1 = Stack[SP - 1];
    s2 = Stack[SP - 2];
    s4 = Stack[SP - 4];
    s5 = Stack[SP - 5];
    if (nargs < nreq)
        lerror(ArgError, "apply: too few arguments");
    for (i = 0; i < extr; i++)
        args[i] = UNBOUND;
    for (i = nreq; i < nargs; i++) {
        v = Stack[bp + i];
        if (issymbol(v) && iskeyword((struct symbol *)ptr(v)))
            break;
        if (a >= nopt)
            goto no_kw;
        args[a++] = v;
    }
    if (i >= nargs)
        goto no_kw;
    // now process keywords
    n = vector_size(kwtable) / 2;
    do {
        i++;
        if (i >= nargs)
            lerrorf(ArgError, "keyword %s requires an argument",
                    symbol_name(v));
        hv = fixnum(((struct symbol *)ptr(v))->hash);
        x = 2 * (labs(numval(hv)) % n);
        if (vector_elt(kwtable, x) == v) {
            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((struct symbol *)ptr(v)));
no_kw:
    nrestargs = nargs - i;
    if (!va && nrestargs > 0)
        lerror(ArgError, "apply: too many arguments");
    nargs = ntot + nrestargs;
    if (nrestargs)
        memmove(&Stack[bp + ntot], &Stack[bp + i],
                nrestargs * sizeof(value_t));
    memcpy(&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;
}

#define bswap_16(x) (((x)&0x00ff) << 8 | ((x)&0xff00) >> 8)

#ifdef __INTEL_COMPILER
#define bswap_32(x) _bswap(x)
#else
#define bswap_32(x)                                       \
    ((((x)&0xff000000) >> 24) | (((x)&0x00ff0000) >> 8) | \
     (((x)&0x0000ff00) << 8) | (((x)&0x000000ff) << 24))
#endif

#if __BYTE_ORDER__ == __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)))
#endif

#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
#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 SWAP_INT32(a) (*(int32_t *)(a) = bswap_32(*(int32_t *)(a)))
#define SWAP_INT16(a) (*(int16_t *)(a) = bswap_16(*(int16_t *)(a)))

#ifdef USE_COMPUTED_GOTO
#define OP(x) L_##x:
#define NEXT_OP goto *vm_labels[*ip++]
#else
#define OP(x) case x:
#define NEXT_OP goto next_op
#endif

/*
  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)
{
    VM_LABELS;
    VM_APPLY_LABELS;
    uint32_t top_frame = curr_frame;
    // frame variables
    uint32_t n = 0, captured;
    uint32_t bp;
    const uint8_t *ip;
    fixnum_t s, hi;

    // temporary variables (not necessary to preserve across calls)
#ifndef USE_COMPUTED_GOTO
    uint32_t op;
#endif
    uint32_t i;
    struct symbol *sym;
    static struct cons *c;
    static value_t *pv;
    static int64_t accum;
    static value_t func, v, e;

apply_cl_top:
    captured = 0;
    func = Stack[SP - nargs - 1];
    ip = cv_data((struct cvalue *)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;

    {
#ifdef USE_COMPUTED_GOTO
        {
            NEXT_OP;
#else
    next_op:
        op = *ip++;
    dispatch:
        switch (op) {
#endif
            OP(OP_ARGC)
            n = *ip++;
        do_argc:
            if (nargs != n) {
                if (nargs > n)
                    lerror(ArgError, "apply: too many arguments");
                else
                    lerror(ArgError, "apply: too few arguments");
            }
            NEXT_OP;
            OP(OP_VARGC)
            i = *ip++;
        do_vargc:
            s = (fixnum_t)nargs - (fixnum_t)i;
            if (s > 0) {
                v = list(&Stack[bp + i], s);
                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) {
                lerror(ArgError, "apply: 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_LARGC)
            n = GET_INT32(ip);
            ip += 4;
            goto do_argc;
            OP(OP_LVARGC)
            i = GET_INT32(ip);
            ip += 4;
            goto do_vargc;
            OP(OP_BRBOUND)
            i = GET_INT32(ip);
            ip += 4;
            if (captured)
                v = vector_elt(Stack[bp], i);
            else
                v = Stack[bp + i];
            if (v != UNBOUND)
                PUSH(FL_T);
            else
                PUSH(FL_F);
            NEXT_OP;
            OP(OP_DUP) SP++;
            Stack[SP - 1] = Stack[SP - 2];
            NEXT_OP;
            OP(OP_POP) POPN(1);
            NEXT_OP;
            OP(OP_TCALL)
            n = *ip++;  // nargs
        do_tcall:
            func = Stack[SP - n - 1];
            if (tag(func) == TAG_FUNCTION) {
                if (func > (N_BUILTINS << 3)) {
                    curr_frame = Stack[curr_frame - 4];
                    for (s = -1; s < (fixnum_t)n; s++)
                        Stack[bp + s] = Stack[SP - n + s];
                    SP = bp + n;
                    nargs = n;
                    goto apply_cl_top;
                } else {
                    i = uintval(func);
                    if (i <= OP_ASET) {
                        s = builtin_arg_counts[i];
                        if (s >= 0)
                            argcount(builtin_names[i], n, s);
                        else if (s != ANYARGS && (signed)n < -s)
                            argcount(builtin_names[i], n, -s);
                        // remove function arg
                        for (s = SP - n - 1; s < (int)SP - 1; s++)
                            Stack[s] = Stack[s + 1];
                        SP--;
#ifdef USE_COMPUTED_GOTO
                        if (i == OP_APPLY)
                            goto apply_tapply;
                        goto *vm_apply_labels[i];
#else
                        switch (i) {
                        case OP_LIST:
                            goto apply_list;
                        case OP_VECTOR:
                            goto apply_vector;
                        case OP_APPLY:
                            goto apply_tapply;
                        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 = (uint8_t)i;
                            goto dispatch;
                        }
#endif
                    }
                }
            } else if (iscbuiltin(func)) {
                s = SP;
                v = ((builtin_t)(((void **)ptr(func))[3]))(&Stack[SP - n], n);
                SP = s - n;
                Stack[SP - 1] = v;
                NEXT_OP;
            }
            type_error("apply", "function", func);
            // WARNING: repeated code ahead
            OP(OP_CALL)
            n = *ip++;  // nargs
        do_call:
            func = Stack[SP - n - 1];
            if (tag(func) == TAG_FUNCTION) {
                if (func > (N_BUILTINS << 3)) {
                    Stack[curr_frame - 2] = (uintptr_t)ip;
                    nargs = n;
                    goto apply_cl_top;
                } else {
                    i = uintval(func);
                    if (i <= OP_ASET) {
                        s = builtin_arg_counts[i];
                        if (s >= 0)
                            argcount(builtin_names[i], n, s);
                        else if (s != ANYARGS && (signed)n < -s)
                            argcount(builtin_names[i], n, -s);
                        // remove function arg
                        for (s = SP - n - 1; s < (int)SP - 1; s++)
                            Stack[s] = Stack[s + 1];
                        SP--;
#ifdef USE_COMPUTED_GOTO
                        goto *vm_apply_labels[i];
#else
                        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 = (uint8_t)i;
                            goto dispatch;
                        }
#endif
                    }
                }
            } else if (iscbuiltin(func)) {
                s = SP;
                v = ((builtin_t)(((void **)ptr(func))[3]))(&Stack[SP - n], n);
                SP = s - n;
                Stack[SP - 1] = v;
                NEXT_OP;
            }
            type_error("apply", "function", func);
            OP(OP_TCALLL) n = GET_INT32(ip);
            ip += 4;
            goto do_tcall;
            OP(OP_CALLL) n = GET_INT32(ip);
            ip += 4;
            goto do_call;
            OP(OP_JMP) ip += (intptr_t)GET_INT16(ip);
            NEXT_OP;
            OP(OP_BRF)
            v = POP();
            if (v == FL_F)
                ip += (intptr_t)GET_INT16(ip);
            else
                ip += 2;
            NEXT_OP;
            OP(OP_BRT)
            v = POP();
            if (v != FL_F)
                ip += (intptr_t)GET_INT16(ip);
            else
                ip += 2;
            NEXT_OP;
            OP(OP_JMPL) ip += (intptr_t)GET_INT32(ip);
            NEXT_OP;
            OP(OP_BRFL)
            v = POP();
            if (v == FL_F)
                ip += (intptr_t)GET_INT32(ip);
            else
                ip += 4;
            NEXT_OP;
            OP(OP_BRTL)
            v = POP();
            if (v != FL_F)
                ip += (intptr_t)GET_INT32(ip);
            else
                ip += 4;
            NEXT_OP;
            OP(OP_BRNE)
            if (Stack[SP - 2] != Stack[SP - 1])
                ip += (intptr_t)GET_INT16(ip);
            else
                ip += 2;
            POPN(2);
            NEXT_OP;
            OP(OP_BRNEL)
            if (Stack[SP - 2] != Stack[SP - 1])
                ip += (intptr_t)GET_INT32(ip);
            else
                ip += 4;
            POPN(2);
            NEXT_OP;
            OP(OP_BRNN)
            v = POP();
            if (v != NIL)
                ip += (intptr_t)GET_INT16(ip);
            else
                ip += 2;
            NEXT_OP;
            OP(OP_BRNNL)
            v = POP();
            if (v != NIL)
                ip += (intptr_t)GET_INT32(ip);
            else
                ip += 4;
            NEXT_OP;
            OP(OP_BRN)
            v = POP();
            if (v == NIL)
                ip += (intptr_t)GET_INT16(ip);
            else
                ip += 2;
            NEXT_OP;
            OP(OP_BRNL)
            v = POP();
            if (v == NIL)
                ip += (intptr_t)GET_INT32(ip);
            else
                ip += 4;
            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_EQ)
            Stack[SP - 2] = ((Stack[SP - 2] == Stack[SP - 1]) ? FL_T : FL_F);
            POPN(1);
            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_PAIRP)
            Stack[SP - 1] = (iscons(Stack[SP - 1]) ? FL_T : FL_F);
            NEXT_OP;
            OP(OP_ATOMP)
            Stack[SP - 1] = (iscons(Stack[SP - 1]) ? FL_F : FL_T);
            NEXT_OP;
            OP(OP_NOT)
            Stack[SP - 1] = ((Stack[SP - 1] == FL_F) ? FL_T : FL_F);
            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_SYMBOLP)
            Stack[SP - 1] = (issymbol(Stack[SP - 1]) ? 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], "bound?");
            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 &&
              (uintval(v) <= OP_ASET || 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_CONS)
            if (curheap > lim)
                gc(0);
            c = (struct cons *)curheap;
            curheap += sizeof(struct cons);
            c->car = Stack[SP - 2];
            c->cdr = Stack[SP - 1];
            Stack[SP - 2] = tagptr(c, TAG_CONS);
            POPN(1);
            NEXT_OP;
            OP(OP_CAR)
            v = Stack[SP - 1];
            if (!iscons(v))
                type_error("car", "cons", v);
            Stack[SP - 1] = car_(v);
            NEXT_OP;
            OP(OP_CDR)
            v = Stack[SP - 1];
            if (!iscons(v))
                type_error("cdr", "cons", v);
            Stack[SP - 1] = cdr_(v);
            NEXT_OP;
            OP(OP_CADR)
            v = Stack[SP - 1];
            if (!iscons(v))
                type_error("cdr", "cons", v);
            v = cdr_(v);
            if (!iscons(v))
                type_error("car", "cons", v);
            Stack[SP - 1] = car_(v);
            NEXT_OP;
            OP(OP_SETCAR)
            car(Stack[SP - 2]) = Stack[SP - 1];
            POPN(1);
            NEXT_OP;
            OP(OP_SETCDR)
            cdr(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);
                POPN(n);
                PUSH(v);
            } else {
                PUSH(NIL);
            }
            NEXT_OP;

            OP(OP_TAPPLY)
            n = *ip++;
        apply_tapply:
            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_tcall;
            OP(OP_APPLY)
            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_ADD2)
            if (bothfixnums(Stack[SP - 1], Stack[SP - 2])) {
                s = numval(Stack[SP - 1]) + numval(Stack[SP - 2]);
                if (fits_fixnum(s))
                    v = fixnum(s);
                else
                    v = mk_long(s);
            } else {
                v = fl_add_any(&Stack[SP - 2], 2, 0);
            }
            POPN(1);
            Stack[SP - 1] = 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_NEG)
        do_neg:
            if (isfixnum(Stack[SP - 1])) {
                s = fixnum(-numval(Stack[SP - 1]));
                if (__unlikely(Stack[SP - 1] == (ufixnum_t)s))
                    Stack[SP - 1] =
                    mk_long(-numval(Stack[SP - 1]));  // negate overflows
                else
                    Stack[SP - 1] = s;
            } else
                Stack[SP - 1] = fl_neg(Stack[SP - 1]);
            NEXT_OP;
            OP(OP_SUB2)
        do_sub2:
            if (bothfixnums(Stack[SP - 2], Stack[SP - 1])) {
                s = numval(Stack[SP - 2]) - numval(Stack[SP - 1]);
                if (fits_fixnum(s))
                    v = fixnum(s);
                else
                    v = mk_long(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;
            i = SP - n;
            for (; 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) {
                if (fits_fixnum(accum))
                    v = fixnum(accum);
                else
                    v = 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, "=")) ? FL_T : FL_F;
            POPN(1);
            Stack[SP - 1] = v;
            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_COMPARE)
            Stack[SP - 2] = compare_(Stack[SP - 2], Stack[SP - 1], 0);
            POPN(1);
            NEXT_OP;

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

            OP(OP_AREF)
            v = Stack[SP - 2];
            if (isvector(v)) {
                e = Stack[SP - 1];
                if (isfixnum(e))
                    i = numval(e);
                else
                    i = (uint32_t)toulong(e, "aref");
                if ((unsigned)i >= vector_size(v))
                    bounds_error("aref", v, e);
                v = vector_elt(v, i);
            } else if (isarray(v)) {
                v = cvalue_array_aref(&Stack[SP - 2]);
            } else {
                type_error("aref", "sequence", v);
            }
            POPN(1);
            Stack[SP - 1] = v;
            NEXT_OP;
            OP(OP_ASET)
            e = Stack[SP - 3];
            if (isvector(e)) {
                i = tofixnum(Stack[SP - 2], "aset!");
                if ((unsigned)i >= vector_size(e))
                    bounds_error("aset!", 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("aset!", "sequence", e);
            }
            POPN(2);
            Stack[SP - 1] = v;
            NEXT_OP;
            OP(OP_FOR)
            s = tofixnum(Stack[SP - 3], "for");
            hi = tofixnum(Stack[SP - 2], "for");
            // 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_LOADT) PUSH(FL_T);
            NEXT_OP;
            OP(OP_LOADF) PUSH(FL_F);
            NEXT_OP;
            OP(OP_LOADNIL) PUSH(NIL);
            NEXT_OP;
            OP(OP_LOAD0) PUSH(fixnum(0));
            NEXT_OP;
            OP(OP_LOAD1) PUSH(fixnum(1));
            NEXT_OP;
            OP(OP_LOADI8) s = (int8_t)*ip++;
            PUSH(fixnum(s));
            NEXT_OP;
            OP(OP_LOADV)
            v = fn_vals(Stack[bp - 1]);
            assert(*ip < vector_size(v));
            v = vector_elt(v, *ip);
            ip++;
            PUSH(v);
            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_LOADGL)
            v = fn_vals(Stack[bp - 1]);
            v = vector_elt(v, GET_INT32(ip));
            ip += 4;
            goto do_loadg;
            OP(OP_LOADG)
            v = fn_vals(Stack[bp - 1]);
            assert(*ip < vector_size(v));
            v = vector_elt(v, *ip);
            ip++;
        do_loadg:
            assert(issymbol(v));
            sym = (struct symbol *)ptr(v);
            if (sym->binding == UNBOUND)
                fl_raise(fl_list2(UnboundError, v));
            PUSH(sym->binding);
            NEXT_OP;

            OP(OP_SETGL)
            v = fn_vals(Stack[bp - 1]);
            v = vector_elt(v, GET_INT32(ip));
            ip += 4;
            goto do_setg;
            OP(OP_SETG)
            v = fn_vals(Stack[bp - 1]);
            assert(*ip < vector_size(v));
            v = vector_elt(v, *ip);
            ip++;
        do_setg:
            assert(issymbol(v));
            sym = (struct symbol *)ptr(v);
            v = Stack[SP - 1];
            if (!isconstant(sym))
                sym->binding = v;
            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_LOADA0)
            if (captured)
                v = vector_elt(Stack[bp], 0);
            else
                v = Stack[bp];
            PUSH(v);
            NEXT_OP;
            OP(OP_LOADA1)
            if (captured)
                v = vector_elt(Stack[bp], 1);
            else
                v = Stack[bp + 1];
            PUSH(v);
            NEXT_OP;
            OP(OP_LOADAL)
            assert(nargs > 0);
            i = GET_INT32(ip);
            ip += 4;
            if (captured)
                v = vector_elt(Stack[bp], i);
            else
                v = Stack[bp + i];
            PUSH(v);
            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_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_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_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_LOADC00)
            PUSH(vector_elt(Stack[bp + nargs], 0));
            NEXT_OP;
            OP(OP_LOADC01)
            PUSH(vector_elt(Stack[bp + nargs], 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_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_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)
                lerror(ArgError, "apply: too few arguments");
            if ((int32_t)n > 0) {
                if (nargs > n)
                    lerror(ArgError, "apply: 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_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;

#ifndef USE_COMPUTED_GOTO
        default:
            goto dispatch;
#endif
        }
    }
#ifdef USE_COMPUTED_GOTO
    return UNBOUND;  // not reached
#else
    goto dispatch;
#endif
}

static uint32_t compute_maxstack(uint8_t *code, size_t len, int bswap)
{
    uint8_t *ip = code + 4, *end = code + len;
    uint8_t op;
    uint32_t i, n, sp = 0, maxsp = 0;

    while (1) {
        if ((int32_t)sp > (int32_t)maxsp)
            maxsp = sp;
        if (ip >= end)
            break;
        op = *ip++;
        switch (op) {
        case OP_ARGC:
            n = *ip++;
            break;
        case OP_VARGC:
            n = *ip++;
            sp += (n + 2);
            break;
        case OP_LARGC:
            if (bswap)
                SWAP_INT32(ip);
            n = GET_INT32(ip);
            ip += 4;
            break;
        case OP_LVARGC:
            if (bswap)
                SWAP_INT32(ip);
            n = GET_INT32(ip);
            ip += 4;
            sp += (n + 2);
            break;
        case OP_OPTARGS:
            if (bswap)
                SWAP_INT32(ip);
            i = GET_INT32(ip);
            ip += 4;
            if (bswap)
                SWAP_INT32(ip);
            n = abs(GET_INT32(ip));
            ip += 4;
            sp += (n - i);
            break;
        case OP_KEYARGS:
            if (bswap)
                SWAP_INT32(ip);
            i = GET_INT32(ip);
            ip += 4;
            if (bswap)
                SWAP_INT32(ip);
            n = GET_INT32(ip);
            ip += 4;
            if (bswap)
                SWAP_INT32(ip);
            n = abs(GET_INT32(ip));
            ip += 4;
            sp += (n - i);
            break;
        case OP_BRBOUND:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            sp++;
            break;

        case OP_TCALL:
        case OP_CALL:
            n = *ip++;  // nargs
            sp -= n;
            break;
        case OP_TCALLL:
        case OP_CALLL:
            if (bswap)
                SWAP_INT32(ip);
            n = GET_INT32(ip);
            ip += 4;
            sp -= n;
            break;
        case OP_JMP:
            if (bswap)
                SWAP_INT16(ip);
            ip += 2;
            break;
        case OP_JMPL:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            break;
        case OP_BRF:
        case OP_BRT:
            if (bswap)
                SWAP_INT16(ip);
            ip += 2;
            sp--;
            break;
        case OP_BRFL:
        case OP_BRTL:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            sp--;
            break;
        case OP_BRNE:
            if (bswap)
                SWAP_INT16(ip);
            ip += 2;
            sp -= 2;
            break;
        case OP_BRNEL:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            sp -= 2;
            break;
        case OP_BRNN:
        case OP_BRN:
            if (bswap)
                SWAP_INT16(ip);
            ip += 2;
            sp--;
            break;
        case OP_BRNNL:
        case OP_BRNL:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            sp--;
            break;
        case OP_RET:
            sp--;
            break;

        case OP_CONS:
        case OP_SETCAR:
        case OP_SETCDR:
        case OP_POP:
        case OP_EQ:
        case OP_EQV:
        case OP_EQUAL:
        case OP_ADD2:
        case OP_SUB2:
        case OP_IDIV:
        case OP_NUMEQ:
        case OP_LT:
        case OP_COMPARE:
        case OP_AREF:
        case OP_TRYCATCH:
            sp--;
            break;

        case OP_PAIRP:
        case OP_ATOMP:
        case OP_NOT:
        case OP_NULLP:
        case OP_BOOLEANP:
        case OP_SYMBOLP:
        case OP_NUMBERP:
        case OP_FIXNUMP:
        case OP_BOUNDP:
        case OP_BUILTINP:
        case OP_FUNCTIONP:
        case OP_VECTORP:
        case OP_NOP:
        case OP_CAR:
        case OP_CDR:
        case OP_NEG:
        case OP_CLOSURE:
            break;

        case OP_TAPPLY:
        case OP_APPLY:
            n = *ip++;
            sp -= (n - 1);
            break;

        case OP_LIST:
        case OP_ADD:
        case OP_SUB:
        case OP_MUL:
        case OP_DIV:
        case OP_VECTOR:
            n = *ip++;
            sp -= (n - 1);
            break;

        case OP_ASET:
            sp -= 2;
            break;
        case OP_FOR:
            if (sp + 2 > maxsp)
                maxsp = sp + 2;
            sp -= 2;
            break;

        case OP_LOADT:
        case OP_LOADF:
        case OP_LOADNIL:
        case OP_LOAD0:
        case OP_LOAD1:
        case OP_LOADA0:
        case OP_LOADA1:
        case OP_LOADC00:
        case OP_LOADC01:
        case OP_DUP:
            sp++;
            break;

        case OP_LOADI8:
        case OP_LOADV:
        case OP_LOADG:
        case OP_LOADA:
            ip++;
            sp++;
            break;
        case OP_LOADVL:
        case OP_LOADGL:
        case OP_LOADAL:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            sp++;
            break;

        case OP_SETG:
        case OP_SETA:
            ip++;
            break;
        case OP_SETGL:
        case OP_SETAL:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            break;

        case OP_LOADC:
            ip += 2;
            sp++;
            break;
        case OP_SETC:
            ip += 2;
            break;
        case OP_LOADCL:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            sp++;
            break;
        case OP_SETCL:
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            if (bswap)
                SWAP_INT32(ip);
            ip += 4;
            break;
        }
    }
    return maxsp + 5;
}

// 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];
            memcpy(&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
// -------------------------------------------------------------------

void assign_global_builtins(struct builtinspec *b)
{
    while (b->name != NULL) {
        setc(symbol(b->name), cbuiltin(b->name, b->fptr));
        b++;
    }
}

static value_t fl_function(value_t *args, uint32_t nargs)
{
    struct cvalue *arr;
    char *data;
    int swap;
    uint32_t ms;
    struct function *fn;
    value_t fv;

    if (nargs == 1 && issymbol(args[0]))
        return fl_builtin(args, nargs);
    if (nargs < 2 || nargs > 4)
        argcount("function", nargs, 2);
    if (!fl_isstring(args[0]))
        type_error("function", "string", args[0]);
    if (!isvector(args[1]))
        type_error("function", "vector", args[1]);
    arr = (struct cvalue *)ptr(args[0]);
    cv_pin(arr);
    data = cv_data(arr);
    swap = 0;
    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;
    } else {
#if __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
        swap = 1;
#endif
    }
    ms = compute_maxstack((uint8_t *)data, cv_len(arr), swap);
    PUT_INT32(data, ms);
    fn = (struct function *)alloc_words(4);
    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("function", "symbol", args[3]);
                fn->name = args[3];
            }
        }
        if (isgensym(fn->name))
            lerror(ArgError, "function: name should not be a gensym");
    }
    return fv;
}

static value_t fl_function_code(value_t *args, uint32_t nargs)
{
    value_t v;

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

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

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

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

value_t fl_copylist(value_t *args, uint32_t nargs)
{
    argcount("copy-list", nargs, 1);
    return copy_list(args[0]);
}

value_t fl_append(value_t *args, uint32_t nargs)
{
    value_t first, lst, lastcons;
    uint32_t i;

    if (nargs == 0)
        return NIL;
    first = lastcons = NIL;
    fl_gc_handle(&first);
    fl_gc_handle(&lastcons);
    i = 0;
    while (1) {
        lst = args[i++];
        if (i >= nargs)
            break;
        if (iscons(lst)) {
            lst = copy_list(lst);
            if (first == NIL)
                first = lst;
            else
                cdr_(lastcons) = lst;
            lastcons = tagptr((((struct cons *)curheap) - 1), TAG_CONS);
        } else if (lst != NIL) {
            type_error("append", "cons", lst);
        }
    }
    if (first == NIL)
        first = lst;
    else
        cdr_(lastcons) = lst;
    fl_free_gc_handles(2);
    return first;
}

value_t fl_liststar(value_t *args, uint32_t nargs)
{
    if (nargs == 1)
        return args[0];
    else if (nargs == 0)
        argcount("list*", nargs, 1);
    return _list(args, nargs, 1);
}

value_t fl_stacktrace(value_t *args, uint32_t nargs)
{
    (void)args;
    argcount("stacktrace", nargs, 0);
    return _stacktrace(fl_throwing_frame ? fl_throwing_frame : curr_frame);
}

value_t fl_map1(value_t *args, uint32_t nargs)
{
    value_t first, last, v;
    int64_t argSP;

    if (nargs < 2)
        lerror(ArgError, "map: too few arguments");
    if (!iscons(args[1]))
        return NIL;
    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 {
        size_t 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 struct builtinspec core_builtin_info[] = {
    { "function", fl_function },
    { "function:code", fl_function_code },
    { "function:vals", fl_function_vals },
    { "function:env", fl_function_env },
    { "function:name", fl_function_name },
    { "stacktrace", fl_stacktrace },
    { "gensym", fl_gensym },
    { "gensym?", fl_gensymp },
    { "hash", fl_hash },
    { "copy-list", fl_copylist },
    { "append", fl_append },
    { "list*", fl_liststar },
    { "map", fl_map1 },
    { NULL, NULL }
};

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

extern void builtins_init(void);
extern void comparehash_init(void);

static void lisp_init(size_t initial_heapsize)
{
    char buf[1024];
    char *exename;
    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(struct cons);
    consflags = bitvector_new(heapsize / sizeof(struct cons), 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");
    set(printprettysym = symbol("*print-pretty*"), FL_T);
    set(printreadablysym = symbol("*print-readably*"), FL_T);
    set(printwidthsym = symbol("*print-width*"), fixnum(print_width));
    set(printlengthsym = symbol("*print-length*"), FL_F);
    set(printlevelsym = symbol("*print-level*"), FL_F);
    builtins_table_sym = symbol("*builtins*");
    fl_lasterror = NIL;
    i = 0;
    for (i = OP_EQ; i <= OP_ASET; i++) {
        setc(symbol(builtin_names[i]), builtin(i));
    }
    setc(symbol("eq"), builtin(OP_EQ));
    setc(symbol("procedure?"), builtin(OP_FUNCTIONP));
    setc(symbol("top-level-bound?"), builtin(OP_BOUNDP));

    set(symbol("*os-name*"), symbol(env_get_os_name()));

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

    cvalues_init();

    exename = get_exename(buf, sizeof(buf));
    if (exename != NULL) {
        path_to_dirname(exename);
        setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename)));
    }

    memory_exception_value =
    fl_list2(MemoryError, cvalue_static_cstring("out of memory"));

    assign_global_builtins(core_builtin_info);

    builtins_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) { lisp_init(initial_heapsize); }

int fl_load_boot_image(void)
{
    value_t e, f;
    int saveSP;
    struct ios *s;
    struct symbol *sym;

    f = cvalue(iostreamtype, sizeof(struct ios));
    s = value2c(struct ios *, f);
    ios_static_buffer(s, boot_image, sizeof(boot_image));
    PUSH(f);
    saveSP = SP;
    {
        FL_TRY
        {
            while (1) {
                e = fl_read_sexpr(Stack[SP - 1]);
                if (ios_eof(value2c(struct ios *, 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), "bootstrap");
                        e = cdr_(e);
                        (void)tocons(e, "bootstrap");
                        sym->binding = car_(e);
                        e = cdr_(e);
                    }
                    break;
                }
            }
        }
        FL_CATCH
        {
            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(struct ios *, Stack[SP - 1]));
    POPN(1);
    return 0;
}