upscheme/femtolisp/flisp.c

/*
  femtoLisp

  a minimal interpreter for a minimal lisp dialect

  this lisp dialect uses lexical scope and self-evaluating lambda.
  it supports 30-bit integers, symbols, conses, and full macros.
  it is case-sensitive.
  it features a simple compacting copying garbage collector.
  it uses a Scheme-style evaluation rule where any expression may appear in
    head position as long as it evaluates to a function.
  it uses Scheme-style varargs (dotted formal argument lists)
  lambdas can have only 1 body expression; use (progn ...) for multiple
    expressions. this is due to the closure representation
    (lambda args body . env)

  This is a fork of femtoLisp with advanced reading and printing facilities:
  * circular structure can be printed and read
  * #. read macro for eval-when-read and correctly printing builtins
  * read macros for backquote
  * symbol character-escaping printer

  The value of this extra complexity, and what makes this fork worthy of
  the femtoLisp brand, is that the interpreter is fully "closed" in the
  sense that all representable values can be read and printed.

  This is a fully fleshed-out lisp built up from femtoLisp. It has all the
  remaining features needed to be taken seriously:
  * vectors
  * exceptions
  * gensyms (can be usefully read back in, too)
  * #| multiline comments |#
  * generic compare function
  * cvalues system providing C data types and a C FFI
  * constructor notation for nicely printing arbitrary values
  * cyclic equal
  * strings
  - hash tables

  by Jeff Bezanson (C) 2008
  Distributed under the Common Public License v1.0
*/

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <setjmp.h>
#include <stdarg.h>
#include <assert.h>
#include <ctype.h>
#include <wctype.h>
#include <sys/types.h>
#include <locale.h>
#include <limits.h>
#include <errno.h>
#include "llt.h"
#include "flisp.h"

static char *builtin_names[] =
    { "quote", "cond", "if", "and", "or", "while", "lambda",
      "trycatch", "%apply", "progn",

      "eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
      "builtinp", "vectorp", "fixnump", "equal",
      "cons", "car", "cdr", "rplaca", "rplacd",
      "eval", "apply", "set", "prog1", "raise",
      "+", "-", "*", "/", "<", "~", "&", "!", "$",
      "vector", "aref", "aset", "length", "assoc", "compare",
      "for" };

static char *stack_bottom;
#define PROCESS_STACK_SIZE (2*1024*1024)
#define N_STACK 98304
value_t Stack[N_STACK];
u_int32_t SP = 0;

value_t NIL, T, LAMBDA, QUOTE, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
value_t defunsym, defmacrosym, forsym, labelsym, printprettysym;

static value_t eval_sexpr(value_t e, uint32_t penv, int tail);
static value_t *alloc_words(int n);
static value_t relocate(value_t v);
static void do_print(ios_t *f, value_t v, int princ);

typedef struct _readstate_t {
    ptrhash_t backrefs;
    ptrhash_t gensyms;
    struct _readstate_t *prev;
} readstate_t;
static readstate_t *readstate = NULL;

static void free_readstate(readstate_t *rs)
{
    ptrhash_free(&rs->backrefs);
    ptrhash_free(&rs->gensyms);
}

static unsigned char *fromspace;
static unsigned char *tospace;
static unsigned char *curheap;
static unsigned char *lim;
static u_int32_t heapsize = 256*1024;//bytes
static u_int32_t *consflags;

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

// saved execution state for an unwind target
typedef struct _ectx_t {
    jmp_buf buf;
    u_int32_t sp;
    readstate_t *rdst;
    struct _ectx_t *prev;
} exception_context_t;

static exception_context_t *ctx = NULL;
static value_t lasterror;
static char lerrorbuf[512];

#define FL_TRY \
  exception_context_t _ctx; int l__tr, l__ca; \
  _ctx.sp=SP; _ctx.rdst=readstate; _ctx.prev=ctx; \
  ctx = &_ctx; \
  if (!setjmp(_ctx.buf)) \
      for (l__tr=1; l__tr; l__tr=0, (void)(ctx->prev && (ctx=ctx->prev)))

#define FL_CATCH \
  else \
      for (l__ca=1; l__ca; l__ca=0, lerrorbuf[0]='\0', lasterror=NIL)

void raise(value_t e)
{
    if (e != lasterror) {
        lasterror = e;
        lerrorbuf[0] = '\0';  // overwriting exception; clear error buf
    }
    // unwind read state
    while (readstate != ctx->rdst) {
        free_readstate(readstate);
        readstate = readstate->prev;
    }
    SP = ctx->sp;
    exception_context_t *thisctx = ctx;
    if (ctx->prev)   // don't throw past toplevel
        ctx = ctx->prev;
    longjmp(thisctx->buf, 1);
}

void lerror(value_t e, char *format, ...)
{
    va_list args;
    va_start(args, format);
    vsnprintf(lerrorbuf, sizeof(lerrorbuf), format, args);
    va_end(args);

    lasterror = e;
    raise(e);
}

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

void bounds_error(char *fname, value_t arr, value_t ind)
{
    lerror(listn(3, BoundsError, arr, ind), "%s: index out of bounds", fname);
}

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

#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)0;                                                          \
}
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)

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

symbol_t *symtab = NULL;

static symbol_t *mk_symbol(char *str)
{
    symbol_t *sym;

    sym = (symbol_t*)malloc_aligned(sizeof(symbol_t)-sizeof(void*) +
                                        strlen(str)+1,
                                    8);
    sym->left = sym->right = NULL;
    sym->binding = UNBOUND;
    sym->syntax = 0;
    strcpy(&sym->name[0], str);
    return sym;
}

static symbol_t **symtab_lookup(symbol_t **ptree, 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(char *str)
{
    symbol_t **pnode;

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

typedef struct {
    value_t binding;   // global value binding
    value_t syntax;    // syntax environment entry
    void *dlcache;     // dlsym address
    u_int32_t id;
} gensym_t;

static u_int32_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 gensym(value_t *args, u_int32_t nargs)
{
    (void)args;
    (void)nargs;
    gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
    gs->id = _gensym_ctr++;
    gs->binding = UNBOUND;
    gs->syntax = 0;
    return tagptr(gs, TAG_SYM);
}

value_t fl_gensym()
{
    return gensym(NULL, 0);
}

static char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g)
{
    size_t i=n-1;

    nbuf[i--] = '\0';
    do {
        nbuf[i--] = '0' + g%10;
        g/=10;
    } while (g && i);
    nbuf[i] = 'g';
    return &nbuf[i];
}

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

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

void gc(int mustgrow);

static value_t mk_cons(void)
{
    cons_t *c;

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

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

    assert(n > 0);
    n = ALIGN(n, 2);   // only allocate multiples of 2 words
    if ((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)  (((cons_t*)ptr(c))-((cons_t*)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)

value_t alloc_vector(size_t n, int init)
{
    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) = NIL;
    }
    return v;
}

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

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

#include "print.c"

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

#include "cvalues.c"

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

static value_t relocate(value_t v)
{
    value_t a, d, nc, first, *pcdr;

    if (isfixnum(v))
        return(v);
    else if (iscons(v)) {
        // iterative implementation allows arbitrarily long cons chains
        pcdr = &first;
        do {
            if ((a=car_(v)) == UNBOUND) {
                *pcdr = cdr_(v);
                return first;
            }
            *pcdr = nc = mk_cons();
            d = cdr_(v);
            car_(v) = UNBOUND; cdr_(v) = nc;
            car_(nc) = relocate(a);
            pcdr = &cdr_(nc);
            v = d;
        } while (iscons(v));
        *pcdr = (d==NIL) ? NIL : relocate(d);

        return first;
    }
    else if (isvector(v)) {
        // 0-length vectors secretly have space for a first element
        if (vector_elt(v,0) == UNBOUND)
            return vector_elt(v,-1);
        size_t i, newsz, sz = vector_size(v);
        newsz = sz;
        if (vector_elt(v,-1) & 0x1)
            newsz += vector_grow_amt(sz);
        nc = alloc_vector(newsz, 0);
        a = vector_elt(v,0);
        vector_elt(v,0) = UNBOUND;
        vector_elt(v,-1) = nc;
        i = 0;
        if (sz > 0) {
            vector_elt(nc,0) = relocate(a); i++;
            for(; i < sz; i++)
                vector_elt(nc,i) = relocate(vector_elt(v,i));
        }
        for(; i < newsz; i++)
            vector_elt(nc,i) = NIL;
        return nc;
    }
    else if (iscvalue(v)) {
        return cvalue_relocate(v);
    }
    else if (ismanaged(v)) {
        assert(issymbol(v));
        gensym_t *gs = (gensym_t*)ptr(v);
        if (gs->id == 0xffffffff)
            return gs->binding;
        gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
        *ng = *gs;
        gs->id = 0xffffffff;
        nc = tagptr(ng, TAG_SYM);
        gs->binding = nc;
        if (ng->binding != UNBOUND)
            ng->binding = relocate(ng->binding);
        return nc;
    }
    return v;
}

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

static value_t special_apply_form;

void gc(int mustgrow)
{
    static int grew = 0;
    void *temp;
    u_int32_t i;
    readstate_t *rs;

    curheap = tospace;
    lim = curheap+heapsize-sizeof(cons_t);

    for (i=0; i < SP; i++)
        Stack[i] = relocate(Stack[i]);
    trace_globals(symtab);
    rs = readstate;
    while (rs) {
        for(i=0; i < rs->backrefs.size; i++)
            rs->backrefs.table[i] = (void*)relocate((value_t)rs->backrefs.table[i]);
        for(i=0; i < rs->gensyms.size; i++)
            rs->gensyms.table[i] = (void*)relocate((value_t)rs->gensyms.table[i]);
        rs = rs->prev;
    }
    lasterror = relocate(lasterror);
    special_apply_form = relocate(special_apply_form);
#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 = realloc_aligned(tospace, grew ? heapsize : heapsize*2, 16);
        if (temp == NULL)
            lerror(MemoryError, "out of memory");
        tospace = temp;
        if (!grew) {
            heapsize*=2;
        }
        else {
            temp = bitvector_resize(consflags, heapsize/sizeof(cons_t), 1);
            if (temp == NULL)
                lerror(MemoryError, "out of memory");
            consflags = (u_int32_t*)temp;
        }
        grew = !grew;
    }
    if (curheap > lim)  // all data was live
        gc(0);
}

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

value_t apply(value_t f, value_t l)
{
    PUSH(f);
    PUSH(l);
    value_t v = toplevel_eval(special_apply_form);
    POPN(2);
    return v;
}

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

    for(i=0; i < n; i++) {
        value_t a = va_arg(ap, value_t);
        PUSH(a);
    }
    cons_t *c = (cons_t*)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 list2(value_t a, value_t b)
{
    PUSH(a);
    PUSH(b);
    cons_t *c = (cons_t*)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;
}

// NOTE: this is NOT an efficient operation. it is only used by the
// reader; vectors should not generally be resized.
// vector_grow requires at least 1 and up to 3 garbage collections!
static value_t vector_grow(value_t v)
{
    size_t s = vector_size(v);
    size_t d = vector_grow_amt(s);
    PUSH(v);
    // first allocate enough space to guarantee the heap will be big enough
    // for the new vector
    alloc_words(d);
    // setting low bit of vector's size acts as a flag to the collector
    // to grow this vector as it is relocated
    ((size_t*)ptr(Stack[SP-1]))[0] |= 0x1;
    gc(0);
    return POP();
}

extern value_t compare(value_t a, value_t b);

int isnumber(value_t v)
{
    return (isfixnum(v) ||
            (iscvalue(v) &&
             valid_numtype(cv_numtype((cvalue_t*)ptr(v)))));
}

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

#include "read.c"

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

// return a cons element of v whose car is item
static value_t assoc(value_t item, value_t v)
{
    value_t bind;

    while (iscons(v)) {
        bind = car_(v);
        if (iscons(bind) && car_(bind) == item)
            return bind;
        v = cdr_(v);
    }
    return NIL;
}

#define eval(e)         (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0))
#define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1))
#define tail_eval(xpr) do { SP = saveSP;  \
    if (selfevaluating(xpr)) { return (xpr); }  \
    else { e=(xpr); goto eval_top; } } while (0)

static value_t do_trycatch(value_t expr, uint32_t penv)
{
    value_t v;

    FL_TRY {
        v = eval(expr);
    }
    FL_CATCH {
        v = cdr_(Stack[SP-1]);
        if (!iscons(v)) {
            v = NIL;   // 1-argument form
        }
        else {
            Stack[SP-1] = car_(v);
            value_t quoted = list2(QUOTE, lasterror);
            expr = list2(Stack[SP-1], quoted);
            v = eval(expr);
        }
    }
    return v;
}

/* stack setup on entry:
  n     n+1   ...
 +-----+-----+-----+-----+-----+-----+-----+-----+
 | LL  | VAL | VAL | CLO |     |     |     |     |
 +-----+-----+-----+-----+-----+-----+-----+-----+
  ^                                                   ^
  |                                                   |
  penv                                                SP (who knows where)

 where LL is the lambda list, CLO is a closed-up environment vector
 (which can be empty, i.e. NIL). An environment vector is just a copy
 of the stack from LL through CLO.
 There might be zero values, in which case LL is NIL.

 Stack[penv-1] is the size of the whole environment (as a fixnum)

 if tail==1, you are allowed (indeed encouraged) to overwrite this
 environment, otherwise you have to put any new environment on the top
 of the stack.
*/
static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
{
    value_t f, v, *pv, *argsyms, *body;
    cons_t *c;
    symbol_t *sym;
    uint32_t saveSP, envsz, lenv;
    int i, nargs, noeval=0;
    fixnum_t s, lo, hi;
    cvalue_t *cv;
    int64_t accum;

 eval_top:
    if (issymbol(e)) {
        sym = (symbol_t*)ptr(e);
        if (sym->syntax == TAG_CONST) return sym->binding;
        pv = &Stack[penv];
        while (1) {
            v = *pv++;
            while (iscons(v)) {
                if (car_(v)==e) return *pv;
                v = cdr_(v); pv++;
            }
            if (v == e) return *pv;  // dotted list
            if (v != NIL) pv++;
            if (*pv == NIL) break;
            pv = &vector_elt(*pv, 0);
        }
        if ((v = sym->binding) == UNBOUND)
            raise(list2(UnboundError, e));
        return v;
    }
    if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
        lerror(MemoryError, "eval: stack overflow");
    saveSP = SP;
    v = car_(e);
    PUSH(cdr_(e));
    if (selfevaluating(v)) f=v;
    else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax)) {
        // handle special syntax forms
        if (isspecial(f))
            goto apply_special;
        else if (f == TAG_CONST)
            f = ((symbol_t*)ptr(v))->binding;
        else
            noeval = 2;
    }
    else f = eval(v);
    v = Stack[saveSP];
    if (isbuiltinish(f)) {
        // handle builtin function
        // evaluate argument list, placing arguments on stack
        while (iscons(v)) {
            v = eval(car_(v));
            PUSH(v);
            v = Stack[saveSP] = cdr_(Stack[saveSP]);
        }
    apply_builtin:
        nargs = SP - saveSP - 1;
    apply_special:
        switch (uintval(f)) {
        // special forms
        case F_QUOTE:
            if (!iscons(Stack[saveSP]))
                lerror(ArgError, "quote: expected argument");
            v = car_(Stack[saveSP]);
            break;
        case F_LAMBDA:
            // build a closure (lambda args body . env)
            if (Stack[penv] != NIL) {
                // save temporary environment to the heap
                lenv = penv;
                envsz = numval(Stack[penv-1]);
                pv = alloc_words(envsz + 1);
                PUSH(tagptr(pv, TAG_VECTOR));
                pv[0] = fixnum(envsz);
                pv++;
                while (envsz--)
                    *pv++ = Stack[penv++];
                // environment representation changed; install
                // the new representation so everybody can see it
                Stack[lenv]   = NIL;
                Stack[lenv+1] = Stack[SP-1];
            }
            else {
                PUSH(Stack[penv+1]); // env has already been captured; share
            }
            c = (cons_t*)ptr(v=cons_reserve(3));
            c->car = LAMBDA;
            c->cdr = tagptr(c+1, TAG_CONS); c++;
            c->car = car(Stack[saveSP]); //argsyms
            c->cdr = tagptr(c+1, TAG_CONS); c++;
            c->car = car(cdr_(Stack[saveSP])); //body
            c->cdr = Stack[SP-1]; //env
            break;
        case F_IF:
            v = car(Stack[saveSP]);
            if (eval(v) != NIL)
                v = car(cdr_(Stack[saveSP]));
            else
                v = car(cdr(cdr_(Stack[saveSP])));
            tail_eval(v);
            break;
        case F_COND:
            pv = &Stack[saveSP]; v = NIL;
            while (iscons(*pv)) {
                c = tocons(car_(*pv), "cond");
                v = eval(c->car);
                if (v != NIL) {
                    *pv = cdr_(car_(*pv));
                    // evaluate body forms
                    if (iscons(*pv)) {
                        while (iscons(cdr_(*pv))) {
                            v = eval(car_(*pv));
                            *pv = cdr_(*pv);
                        }
                        tail_eval(car_(*pv));
                    }
                    break;
                }
                *pv = cdr_(*pv);
            }
            break;
        case F_AND:
            pv = &Stack[saveSP]; v = T;
            if (iscons(*pv)) {
                while (iscons(cdr_(*pv))) {
                    if ((v=eval(car_(*pv))) == NIL) {
                        SP = saveSP; return NIL;
                    }
                    *pv = cdr_(*pv);
                }
                tail_eval(car_(*pv));
            }
            break;
        case F_OR:
            pv = &Stack[saveSP]; v = NIL;
            if (iscons(*pv)) {
                while (iscons(cdr_(*pv))) {
                    if ((v=eval(car_(*pv))) != NIL) {
                        SP = saveSP; return v;
                    }
                    *pv = cdr_(*pv);
                }
                tail_eval(car_(*pv));
            }
            break;
        case F_WHILE:
            PUSH(cdr(Stack[saveSP]));
            body = &Stack[SP-1];
            PUSH(*body);
            Stack[saveSP] = car_(Stack[saveSP]);
            value_t *cond = &Stack[saveSP];
            PUSH(NIL);
            pv = &Stack[SP-1];
            while (eval(*cond) != NIL) {
                *body = Stack[SP-2];
                while (iscons(*body)) {
                    *pv = eval(car_(*body));
                    *body = cdr_(*body);
                }
            }
            v = *pv;
            break;
        case F_PROGN:
            // return last arg
            pv = &Stack[saveSP]; v = NIL;
            if (iscons(*pv)) {
                while (iscons(cdr_(*pv))) {
                    v = eval(car_(*pv));
                    *pv = cdr_(*pv);
                }
                tail_eval(car_(*pv));
            }
            break;
        case F_TRYCATCH:
            v = do_trycatch(car(Stack[saveSP]), penv);
            break;

        // ordinary functions
        case F_SET:
            argcount("set", nargs, 2);
            e = Stack[SP-2];
            pv = &Stack[penv];
            while (1) {
                v = *pv++;
                while (iscons(v)) {
                    if (car_(v)==e) {
                        *pv = Stack[SP-1];
                        SP=saveSP;
                        return *pv;
                    }
                    v = cdr_(v); pv++;
                }
                if (v == e) {
                    *pv = Stack[SP-1];
                    SP=saveSP;
                    return *pv;
                }
                if (v != NIL) pv++;
                if (*pv == NIL) break;
                pv = &vector_elt(*pv, 0);
            }
            sym = tosymbol(e, "set");
            v = Stack[SP-1];
            if (sym->syntax != TAG_CONST)
                sym->binding = v;
            break;
        case F_BOUNDP:
            argcount("boundp", nargs, 1);
            sym = tosymbol(Stack[SP-1], "boundp");
            v = (sym->binding == UNBOUND) ? NIL : T;
            break;
        case F_EQ:
            argcount("eq", nargs, 2);
            v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
            break;
        case F_CONS:
            argcount("cons", nargs, 2);
            if (curheap > lim)
                gc(0);
            c = (cons_t*)curheap;
            curheap += sizeof(cons_t);
            c->car = Stack[SP-2];
            c->cdr = Stack[SP-1];
            v = tagptr(c, TAG_CONS);
            break;
        case F_CAR:
            argcount("car", nargs, 1);
            v = car(Stack[SP-1]);
            break;
        case F_CDR:
            argcount("cdr", nargs, 1);
            v = cdr(Stack[SP-1]);
            break;
        case F_RPLACA:
            argcount("rplaca", nargs, 2);
            car(v=Stack[SP-2]) = Stack[SP-1];
            break;
        case F_RPLACD:
            argcount("rplacd", nargs, 2);
            cdr(v=Stack[SP-2]) = Stack[SP-1];
            break;
        case F_VECTOR:
            v = alloc_vector(nargs, 0);
            memcpy(&vector_elt(v,0), &Stack[saveSP+1], nargs*sizeof(value_t));
            break;
        case F_LENGTH:
            argcount("length", nargs, 1);
            if (isvector(Stack[SP-1])) {
                v = fixnum(vector_size(Stack[SP-1]));
                break;
            }
            else if (iscvalue(Stack[SP-1])) {
                cv = (cvalue_t*)ptr(Stack[SP-1]);
                v = cv_type(cv);
                if (iscons(v) && car_(v) == arraysym) {
                    v = size_wrap(cvalue_arraylen(Stack[SP-1]));
                    break;
                }
                else if (v == charsym) {
                    v = fixnum(1);
                    break;
                }
                else if (v == wcharsym) {
                    v = fixnum(u8_charlen(*(wchar_t*)cv_data(cv)));
                    break;
                }
            }
            else if (Stack[SP-1] == NIL) {
                v = fixnum(0); break;
            }
            else if (iscons(Stack[SP-1])) {
                v = fixnum(llength(Stack[SP-1])); break;
            }
            type_error("length", "sequence", Stack[SP-1]);
            break;
        case F_AREF:
            argcount("aref", nargs, 2);
            v = Stack[SP-2];
            i = tofixnum(Stack[SP-1], "aref");
            if (isvector(v)) {
                if ((unsigned)i >= vector_size(v))
                    bounds_error("aref", v, Stack[SP-1]);
                v = vector_elt(v, i);
            }
            else {
                // TODO other sequence types?
                type_error("aref", "sequence", v);
            }
            break;
        case F_ASET:
            argcount("aset", nargs, 3);
            e = Stack[SP-3];
            i = tofixnum(Stack[SP-2], "aset");
            if (isvector(e)) {
                if ((unsigned)i >= vector_size(e))
                    bounds_error("aref", v, Stack[SP-1]);
                vector_elt(e, i) = (v=Stack[SP-1]);
            }
            else {
                type_error("aset", "sequence", e);
            }
            break;
        case F_ATOM:
            argcount("atom", nargs, 1);
            v = ((!iscons(Stack[SP-1])) ? T : NIL);
            break;
        case F_CONSP:
            argcount("consp", nargs, 1);
            v = (iscons(Stack[SP-1]) ? T : NIL);
            break;
        case F_SYMBOLP:
            argcount("symbolp", nargs, 1);
            v = ((issymbol(Stack[SP-1])) ? T : NIL);
            break;
        case F_NUMBERP:
            argcount("numberp", nargs, 1);
            v = ((isfixnum(Stack[SP-1]) ||
                  (iscvalue(Stack[SP-1]) &&
                   valid_numtype(cv_numtype((cvalue_t*)ptr(Stack[SP-1]))) ))
                 ? T : NIL);
            break;
        case F_FIXNUMP:
            argcount("fixnump", nargs, 1);
            v = ((isfixnum(Stack[SP-1])) ? T : NIL);
            break;
        case F_BUILTINP:
            argcount("builtinp", nargs, 1);
            v = (isbuiltinish(Stack[SP-1]) ||
                 (iscvalue(Stack[SP-1]) &&
                  ((cvalue_t*)ptr(Stack[SP-1]))->flags.islispfunction))? T:NIL;
            break;
        case F_VECTORP:
            argcount("vectorp", nargs, 1);
            v = ((isvector(Stack[SP-1])) ? T : NIL);
            break;
        case F_NOT:
            argcount("not", nargs, 1);
            v = ((Stack[SP-1] == NIL) ? T : NIL);
            break;
        case F_ADD:
            s = 0;
            for (i=saveSP+1; i < (int)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);
                    SP = saveSP;
                    return v;
                }
            }
            v = fixnum(s);
            break;
        case F_SUB:
            if (nargs < 1) lerror(ArgError, "-: too few arguments");
            i = saveSP+1;
            if (nargs == 1) {
                if (isfixnum(Stack[i]))
                    v = fixnum(-numval(Stack[i]));
                else
                    v = fl_neg(Stack[i]);
                break;
            }
            if (nargs == 2) {
                if (bothfixnums(Stack[i], Stack[i+1])) {
                    s = numval(Stack[i]) - numval(Stack[i+1]);
                    if (fits_fixnum(s)) {
                        v = fixnum(s);
                        break;
                    }
                    Stack[i+1] = fixnum(-numval(Stack[i+1]));
                }
                else {
                    Stack[i+1] = fl_neg(Stack[i+1]);
                }
            }
            else {
                Stack[i+1] = fl_neg(fl_add_any(&Stack[i+1], nargs-1, 0));
            }
            v = fl_add_any(&Stack[i], 2, 0);
            break;
        case F_MUL:
            accum = 1;
            for (i=saveSP+1; i < (int)SP; i++) {
                if (isfixnum(Stack[i])) {
                    accum *= numval(Stack[i]);
                }
                else {
                    v = fl_mul_any(&Stack[i], SP-i, accum);
                    SP = saveSP;
                    return v;
                }
            }
            if (fits_fixnum(accum))
                v = fixnum(accum);
            else
                v = return_from_int64(accum);
            break;
        case F_DIV:
            if (nargs < 1) lerror(ArgError, "/: too few arguments");
            i = saveSP+1;
            if (nargs == 1) {
                v = fl_div2(fixnum(1), Stack[i]);
            }
            else {
                if (nargs > 2)
                    Stack[i+1] = fl_mul_any(&Stack[i+1], nargs-1, 1);
                v = fl_div2(Stack[i], Stack[i+1]);
            }
            break;
        case F_BNOT:
            argcount("~", nargs, 1);
            if (isfixnum(Stack[SP-1]))
                v = fixnum(~numval(Stack[SP-1]));
            else
                v = fl_bitwise_not(Stack[SP-1]);
            break;
        case F_BAND:
            argcount("&", nargs, 2);
            if (bothfixnums(Stack[SP-1], Stack[SP-2]))
                v = Stack[SP-1] & Stack[SP-2];
            else
                v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 0, "&");
            break;
        case F_BOR:
            argcount("!", nargs, 2);
            if (bothfixnums(Stack[SP-1], Stack[SP-2]))
                v = Stack[SP-1] | Stack[SP-2];
            else
                v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 1, "!");
            break;
        case F_BXOR:
            argcount("$", nargs, 2);
            if (bothfixnums(Stack[SP-1], Stack[SP-2]))
                v = fixnum(numval(Stack[SP-1]) ^ numval(Stack[SP-2]));
            else
                v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$");
            break;
        case F_COMPARE:
            argcount("compare", nargs, 2);
            v = compare(Stack[SP-2], Stack[SP-1]);
            break;
        case F_LT:
            argcount("<", nargs, 2);
            if (bothfixnums(Stack[SP-2], Stack[SP-1])) {
                v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
            }
            else {
                v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? T : NIL;
            }
            break;
        case F_EQUAL:
            argcount("equal", nargs, 2);
            if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
                v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL;
            }
            else {
                v = (compare(Stack[SP-2], Stack[SP-1])==0) ? T : NIL;
            }
            break;
        case F_EVAL:
            argcount("eval", nargs, 1);
            v = Stack[SP-1];
            if (selfevaluating(v)) { SP=saveSP; return v; }
            if (tail) {
                Stack[penv-1] = fixnum(2);
                Stack[penv] = NIL;
                Stack[penv+1] = NIL;
                SP = penv + 2;
                e=v;
                goto eval_top;
            }
            else {
                PUSH(fixnum(2));
                PUSH(NIL);
                PUSH(NIL);
                v = eval_sexpr(v, SP-2, 1);
            }
            break;
        case F_RAISE:
            argcount("raise", nargs, 1);
            raise(Stack[SP-1]);
            break;
        case F_PROG1:
            // return first arg
            if (nargs < 1) lerror(ArgError, "prog1: too few arguments");
            v = Stack[saveSP+1];
            break;
        case F_ASSOC:
            argcount("assoc", nargs, 2);
            v = assoc(Stack[SP-2], Stack[SP-1]);
            break;
        case F_FOR:
            argcount("for", nargs, 3);
            lo = tofixnum(Stack[SP-3], "for");
            hi = tofixnum(Stack[SP-2], "for");
            f = Stack[SP-1];
            v = car(cdr(f));
            if (!iscons(v) || !iscons(cdr_(cdr_(f))) || cdr_(v) != NIL)
                lerror(ArgError, "for: expected 1 argument lambda");
            f = cdr_(f);
            PUSH(f);  // save function cdr
            SP += 4;  // make space
            Stack[SP-4] = fixnum(3);       // env size
            Stack[SP-1] = cdr_(cdr_(f));   // cloenv
            v = NIL;
            for(s=lo; s <= hi; s++) {
                f = Stack[SP-5];
                Stack[SP-3] = car_(f);     // lambda list
                Stack[SP-2] = fixnum(s);   // argument value
                v = eval_sexpr(car_(cdr_(f)), SP-3, 0);
            }
            break;
        case F_SPECIAL_APPLY:
            v = Stack[saveSP-4];
            f = Stack[saveSP-5];
            PUSH(f);
            PUSH(v);
            nargs = 2;
            // falls through!!
        case F_APPLY:
            argcount("apply", nargs, 2);
            v = Stack[saveSP] = Stack[SP-1];  // second arg is new arglist
            f = Stack[SP-2];            // first arg is new function
            POPN(2);                    // pop apply's args
            if (isbuiltinish(f)) {
                assert(!isspecial(f));
                // unpack arglist onto the stack
                while (iscons(v)) {
                    PUSH(car_(v));
                    v = cdr_(v);
                }
                goto apply_builtin;
            }
            noeval = 1;
            goto apply_lambda;
        default:
            // a guest function is a cvalue tagged as a builtin
            cv = (cvalue_t*)ptr(f);
            if (cv->flags.islispfunction) {
                v = ((guestfunc_t)cv->data)(&Stack[saveSP+1], nargs);
            }
            else {
                goto apply_lambda;  // trigger type error
            }
        }
        SP = saveSP;
        return v;
    }
 apply_lambda:
    if (iscons(f)) {
        // apply lambda expression
        f = cdr_(f);
        PUSH(f);
        PUSH(car(f)); // arglist
        argsyms = &Stack[SP-1];
        // build a calling environment for the lambda
        // the environment is the argument binds on top of the captured
        // environment
        if (noeval) {
            while (iscons(v)) {
                // bind args
                if (!iscons(*argsyms)) {
                    if (*argsyms == NIL)
                        lerror(ArgError, "apply: too many arguments");
                    break;
                }
                PUSH(car_(v));
                *argsyms = cdr_(*argsyms);
                v = cdr_(v);
            }
            if (*argsyms != NIL && issymbol(*argsyms))
                PUSH(v);
        }
        else {
            while (iscons(v)) {
                // bind args
                if (!iscons(*argsyms)) {
                    if (*argsyms == NIL)
                        lerror(ArgError, "apply: too many arguments");
                    break;
                }
                v = eval(car_(v));
                PUSH(v);
                *argsyms = cdr_(*argsyms);
                v = Stack[saveSP] = cdr_(Stack[saveSP]);
            }
            if (*argsyms != NIL && issymbol(*argsyms)) {
                PUSH(Stack[saveSP]);
                // this version uses collective allocation. about 7-10%
                // faster for lists with > 2 elements, but uses more
                // stack space
                i = SP;
                while (iscons(Stack[saveSP])) {
                    v = car_(Stack[saveSP]);
                    v = eval(v);
                    PUSH(v);
                    Stack[saveSP] = cdr_(Stack[saveSP]);
                }
                nargs = SP-i;
                if (nargs) {
                    Stack[i-1] = cons_reserve(nargs);
                    c = (cons_t*)ptr(Stack[i-1]);
                    for(; i < (int)SP; i++) {
                        c->car = Stack[i];
                        c->cdr = tagptr(c+1, TAG_CONS);
                        c++;
                    }
                    (c-1)->cdr = Stack[saveSP];
                    POPN(nargs);
                }
            }
        }
        if (iscons(*argsyms)) {
            lerror(ArgError, "apply: too few arguments");
        }
        f = cdr_(Stack[saveSP+1]);
        e = car(f);
        if (selfevaluating(e)) { SP=saveSP; return(e); }
        PUSH(cdr_(f));                     // add closed environment
        *argsyms = car_(Stack[saveSP+1]);  // put lambda list

        if (noeval == 2) {
            // macro: evaluate body in lambda environment
            Stack[saveSP+1] = fixnum(SP-saveSP-2);
            e = eval_sexpr(e, saveSP+2, 1);
            SP = saveSP;
            if (selfevaluating(e)) return(e);
            noeval = 0;
            // macro: evaluate expansion in calling environment
            goto eval_top;
        }
        else {
            envsz = SP - saveSP - 2;
            if (tail) {
                noeval = 0;
                // ok to overwrite environment
                for(i=0; i < (int)envsz; i++)
                    Stack[penv+i] = Stack[saveSP+2+i];
                SP = penv+envsz;
                Stack[penv-1] = fixnum(envsz);
                goto eval_top;
            }
            else {
                Stack[saveSP+1] = fixnum(envsz);
                v = eval_sexpr(e, saveSP+2, 1);
                SP = saveSP;
                return v;
            }
        }
        // not reached
    }
    type_error("apply", "function", f);
    return NIL;
}

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

extern void builtins_init();

void lisp_init(void)
{
    int i;

    llt_init();

    fromspace = malloc_aligned(heapsize, 16);
    tospace   = malloc_aligned(heapsize, 16);
    curheap = fromspace;
    lim = curheap+heapsize-sizeof(cons_t);
    consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
    ptrhash_new(&printconses, 32);

    NIL = symbol("nil"); setc(NIL, NIL);
    T   = symbol("T");   setc(T,   T);
    LAMBDA = symbol("lambda");
    QUOTE = symbol("quote");
    TRYCATCH = symbol("trycatch");
    BACKQUOTE = symbol("backquote");
    COMMA = symbol("*comma*");
    COMMAAT = symbol("*comma-at*");
    COMMADOT = symbol("*comma-dot*");
    IOError = symbol("io-error");
    ParseError = symbol("parse-error");
    TypeError = symbol("type-error");
    ArgError = symbol("arg-error");
    UnboundError = symbol("unbound-error");
    MemoryError = symbol("memory-error");
    BoundsError = symbol("bounds-error");
    DivideError = symbol("divide-error");
    Error = symbol("error");
    conssym = symbol("cons");
    symbolsym = symbol("symbol");
    fixnumsym = symbol("fixnum");
    vectorsym = symbol("vector");
    builtinsym = symbol("builtin");
    defunsym = symbol("defun");
    defmacrosym = symbol("defmacro");
    forsym = symbol("for");
    labelsym = symbol("label");
    set(printprettysym=symbol("*print-pretty*"), T);
    lasterror = NIL;
    lerrorbuf[0] = '\0';
    special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL);
    i = 0;
    while (isspecial(builtin(i))) {
        if (i != F_SPECIAL_APPLY)
            ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
        i++;
    }
    for (; i < N_BUILTINS; i++) {
        setc(symbol(builtin_names[i]), builtin(i));
    }

#ifdef LINUX
    set(symbol("os.name"), symbol("linux"));
#elif defined(WIN32) || defined(WIN64)
    set(symbol("os.name"), symbol("win32"));
#elif defined(MACOSX)
    set(symbol("os.name"), symbol("macos"));
#else
    set(symbol("os.name"), symbol("unknown"));
#endif

    cvalues_init();
    set(symbol("gensym"), guestfunc(gensym));
    builtins_init();
}

// repl -----------------------------------------------------------------------

value_t toplevel_eval(value_t expr)
{
    value_t v;
    u_int32_t saveSP = SP;
    PUSH(fixnum(2));
    PUSH(NIL);
    PUSH(NIL);
    v = topeval(expr, SP-2);
    SP = saveSP;
    return v;
}

static void print_toplevel_exception()
{
    if (iscons(lasterror) && car_(lasterror) == TypeError &&
        llength(lasterror) == 4) {
        ios_printf(ios_stderr, "type-error: ");
        print(ios_stderr, car_(cdr_(lasterror)), 1);
        ios_printf(ios_stderr, ": expected ");
        print(ios_stderr, car_(cdr_(cdr_(lasterror))), 1);
        ios_printf(ios_stderr, ", got ");
        print(ios_stderr, car_(cdr_(cdr_(cdr_(lasterror)))), 0);
    }
    else if (iscons(lasterror) && car_(lasterror) == UnboundError &&
             iscons(cdr_(lasterror))) {
        ios_printf(ios_stderr, "unbound-error: eval: variable %s has no value",
                   (symbol_name(car_(cdr_(lasterror)))));
    }
    else if (iscons(lasterror) && car_(lasterror) == Error) {
        value_t v = cdr_(lasterror);
        ios_printf(ios_stderr, "error: ");
        while (iscons(v)) {
            print(ios_stderr, car_(v), 1);
            v = cdr_(v);
        }
    }
    else {
        if (lasterror != NIL) {
            if (!lerrorbuf[0])
                ios_printf(ios_stderr, "*** Unhandled exception: ");
            print(ios_stderr, lasterror, 0);
            if (lerrorbuf[0])
                ios_printf(ios_stderr, ": ");
        }
    }

    if (lerrorbuf[0])
        ios_printf(ios_stderr, "%s", lerrorbuf);
}

value_t load_file(char *fname)
{
    value_t volatile e, v=NIL;
    ios_t fi;
    ios_t * volatile f;
    f = &fi; f = ios_file(f, fname, 0, 0);
    if (f == NULL) lerror(IOError, "file \"%s\" not found", fname);
    FL_TRY {
        while (1) {
            e = read_sexpr(f);
            //print(ios_stdout,e,0); ios_puts("\n", ios_stdout);
            if (ios_eof(f)) break;
            v = toplevel_eval(e);
        }
    }
    FL_CATCH {
        ios_close(f);
        size_t msglen = strlen(lerrorbuf);
        snprintf(&lerrorbuf[msglen], sizeof(lerrorbuf)-msglen,
                 "\nin file \"%s\"", fname);
        lerrorbuf[sizeof(lerrorbuf)-1] = '\0';
        raise(lasterror);
    }
    ios_close(f);
    return v;
}

static value_t argv_list(int argc, char *argv[])
{
    int i;
    PUSH(NIL);
    if (argc > 1) { argc--; argv++; }
    for(i=argc-1; i >= 0; i--)
        Stack[SP-1] = fl_cons(cvalue_pinned_cstring(argv[i]), Stack[SP-1]);
    return POP();
}

int locale_is_utf8;

int main(int argc, char *argv[])
{
    value_t v;

    locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, ""));

    stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
    lisp_init();
    set(symbol("argv"), argv_list(argc, argv));
    FL_TRY {
        // install toplevel exception handler
    }
    FL_CATCH {
        print_toplevel_exception();

        lerrorbuf[0] = '\0';
        lasterror = NIL;
        ios_puts("\n\n", ios_stderr);
        goto repl;
    }
    load_file("system.lsp");
    if (argc > 1) { load_file(argv[1]); return 0; }
    printf(";  _                   \n");
    printf("; |_ _ _ |_ _ |  . _ _\n");
    printf("; | (-||||_(_)|__|_)|_)\n");
    printf(";-------------------|----------------------------------------------------------\n\n");
 repl:
    while (1) {
        ios_puts("> ", ios_stdout); ios_flush(ios_stdout);
        v = read_sexpr(ios_stdin);
        if (ios_eof(ios_stdin)) break;
        print(ios_stdout, v=toplevel_eval(v), 0);
        set(symbol("that"), v);
        ios_puts("\n\n", ios_stdout);
    }
    ios_puts("\n", ios_stdout);
    return 0;
}