/* 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 (begin ...) for multiple expressions. this is due to the closure representation (lambda args body . env) This is a fully fleshed-out lisp built up from femtoLisp. It has all the remaining features needed to be taken seriously: * 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 * vectors * exceptions * gensyms (can be usefully read back in, too) * #| multiline comments |# * generic compare function, cyclic equal * cvalues system providing C data types and a C FFI * constructor notation for nicely printing arbitrary values * strings * hash tables * I/O streams by Jeff Bezanson (C) 2009 Distributed under the BSD License */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include "llt.h" #include "flisp.h" #include "opcodes.h" static char *builtin_names[] = { // special forms "quote", "cond", "if", "and", "or", "while", "lambda", "trycatch", "%apply", "set!", "prog1", "for", "begin", // predicates "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?", "number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?", // lists "cons", "list", "car", "cdr", "set-car!", "set-cdr!", // execution "eval", "apply", // arithmetic "+", "-", "*", "/", "=", "<", "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, 0, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, ANYARGS, 1, 1, 2, 2, 1, 2, ANYARGS, -1, ANYARGS, -1, 2, 2, 2, ANYARGS, 2, 3 }; #define N_STACK 262144 value_t StaticStack[N_STACK]; value_t *Stack = StaticStack; uint32_t SP = 0; typedef struct _stackseg_t { value_t *Stack; uint32_t SP; struct _stackseg_t *prev; } stackseg_t; stackseg_t stackseg0 = { StaticStack, 0, NULL }; stackseg_t *current_stack_seg = &stackseg0; value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH; value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, COMPILEDLAMBDA; value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t DivideError, BoundsError, Error, KeyError, EnumerationError; value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym; value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym; static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz); static value_t apply_cl(uint32_t nargs); static value_t *alloc_words(int n); static value_t relocate(value_t v); typedef struct _readstate_t { htable_t backrefs; htable_t gensyms; value_t source; struct _readstate_t *prev; } readstate_t; static readstate_t *readstate = NULL; static void free_readstate(readstate_t *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 = 512*1024;//bytes static uint32_t *consflags; // error utilities ------------------------------------------------------------ // saved execution state for an unwind target typedef struct _ectx_t { jmp_buf buf; uint32_t sp; readstate_t *rdst; struct _ectx_t *prev; } exception_context_t; static exception_context_t *ctx = NULL; static value_t lasterror; #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, lasterror=NIL) void raise(value_t e) { lasterror = e; // 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); } 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; PUSH(e); va_start(args, format); value_t msg = make_error_msg(format, args); va_end(args); e = POP(); raise(list2(e, msg)); } void lerror(value_t e, const char *msg) { PUSH(e); value_t m = cvalue_static_cstring(msg); e = POP(); raise(list2(e, m)); } 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) { lerrorf(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 (__likely(is##type(v))) \ return (ctype)cnvt(v); \ type_error(fname, #type, v); \ } SAFECAST_OP(cons, cons_t*, ptr) SAFECAST_OP(symbol,symbol_t*,ptr) SAFECAST_OP(fixnum,fixnum_t, numval) SAFECAST_OP(cvalue,cvalue_t*,ptr) SAFECAST_OP(string,char*, cvalue_data) // symbol table --------------------------------------------------------------- symbol_t *symtab = NULL; static symbol_t *mk_symbol(char *str) { symbol_t *sym; size_t len = strlen(str); sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1); assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8 sym->left = sym->right = NULL; if (str[0] == ':') { value_t s = tagptr(sym, TAG_SYM); setc(s, s); } else { sym->binding = UNBOUND; sym->syntax = 0; } sym->type = sym->dlcache = NULL; sym->hash = memhash32(str, len)^0xAAAAAAAA; 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 syntax; // syntax environment entry value_t binding; // global value binding fltype_t *type; uint32_t id; } gensym_t; 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 gensym(value_t *args, uint32_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; gs->type = NULL; return tagptr(gs, TAG_SYM); } value_t fl_gensym() { return gensym(NULL, 0); } char *symbol_name(value_t v) { if (ismanaged(v)) { gensym_t *gs = (gensym_t*)ptr(v); gsnameno = 1-gsnameno; char *n = uint2str(gsname[gsnameno]+1, sizeof(gsname[0])-1, gs->id, 10); *(--n) = 'g'; return n; } return ((symbol_t*)ptr(v))->name; } // conses --------------------------------------------------------------------- void gc(int mustgrow); static value_t mk_cons(void) { cons_t *c; if (__unlikely(curheap > lim)) gc(0); c = (cons_t*)curheap; curheap += sizeof(cons_t); return tagptr(c, TAG_CONS); } static value_t *alloc_words(int n) { value_t *first; assert(n > 0); n = 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) (((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; } // cvalues -------------------------------------------------------------------- #include "cvalues.c" #include "types.c" // print ---------------------------------------------------------------------- static int isnumtok(char *tok, value_t *pval); static int symchar(char c); #include "print.c" // collector ------------------------------------------------------------------ static value_t relocate(value_t v) { value_t a, d, nc, first, *pcdr; uptrint_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 = mk_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, 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); forward(v, 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 (t == TAG_CPRIM) { cprim_t *pcp = (cprim_t*)ptr(v); size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size); cprim_t *ncp = (cprim_t*)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_SYM) { gensym_t *gs = (gensym_t*)ptr(v); gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*)); ng->id = gs->id; ng->binding = gs->binding; ng->syntax = gs->syntax; nc = tagptr(ng, TAG_SYM); forward(v, nc); if (ng->binding != UNBOUND) ng->binding = relocate(ng->binding); if (iscons(ng->syntax)) ng->syntax = relocate(ng->syntax); return nc; } return v; } value_t relocate_lispvalue(value_t v) { return relocate(v); } static void trace_globals(symbol_t *root) { while (root != NULL) { if (root->binding != UNBOUND) 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; static value_t apply1_args; static value_t memory_exception_value; void gc(int mustgrow) { static int grew = 0; void *temp; uint32_t i; readstate_t *rs; stackseg_t *ss; curheap = tospace; lim = curheap+heapsize-sizeof(cons_t); ss = current_stack_seg; ss->SP = SP; while (ss) { for (i=0; i < ss->SP; i++) ss->Stack[i] = relocate(ss->Stack[i]); ss = ss->prev; } trace_globals(symtab); relocate_typetable(); 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->source = relocate(rs->source); rs = rs->prev; } lasterror = relocate(lasterror); special_apply_form = relocate(special_apply_form); apply1_args = relocate(apply1_args); memory_exception_value = relocate(memory_exception_value); sweep_finalizers(); #ifdef VERBOSEGC printf("GC: found %d/%d live conses\n", (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t)); #endif temp = tospace; tospace = fromspace; fromspace = temp; // if we're using > 80% of the space, resize tospace so we have // more space to fill next time. if we grew tospace last time, // grow the other half of the heap this time to catch up. if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) { temp = realloc(tospace, grew ? heapsize : heapsize*2); if (temp == NULL) raise(memory_exception_value); tospace = temp; if (!grew) { heapsize*=2; } else { temp = bitvector_resize(consflags, heapsize/sizeof(cons_t), 1); if (temp == NULL) raise(memory_exception_value); consflags = (uint32_t*)temp; } grew = !grew; } if (curheap > lim) // all data was live gc(0); } // utils ---------------------------------------------------------------------- #define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1,2)) // apply function with n args on the stack static value_t _applyn(uint32_t n) { PUSH(fixnum(n)); return topeval(special_apply_form, NULL); } value_t apply(value_t f, value_t l) { value_t v = l; uint32_t n = SP; PUSH(f); while (iscons(v)) { if (n == MAX_ARGS) { PUSH(v); break; } PUSH(car_(v)); v = cdr_(v); } n = SP - n - 1; v = _applyn(n); POPN(n+1); return v; } value_t applyn(uint32_t n, value_t f, ...) { va_list ap; va_start(ap, f); size_t i; PUSH(f); for(i=0; i < n; i++) { value_t a = va_arg(ap, value_t); PUSH(a); } value_t v = _applyn(n); POPN(n+1); return v; } value_t listn(size_t n, ...) { va_list ap; va_start(ap, n); uint32_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(); } int isnumber(value_t v) { return (isfixnum(v) || iscprim(v)); } // read ----------------------------------------------------------------------- #include "read.c" // eval ----------------------------------------------------------------------- /* there is one interesting difference between this and (lambda x x). (eq a (apply list a)) is always false for nonempty a, while (eq a (apply (lambda x x) a)) is always true. the justification for this is that a vararg lambda often needs to recur by applying itself to the tail of its argument list, so copying the list would be unacceptable. */ static value_t list(value_t *args, uint32_t nargs) { cons_t *c; uint32_t i; value_t v; v = cons_reserve(nargs); c = (cons_t*)ptr(v); for(i=0; i < nargs; i++) { c->car = args[i]; c->cdr = tagptr(c+1, TAG_CONS); c++; } if (nargs > MAX_ARGS) (c-2)->cdr = (c-1)->car; else (c-1)->cdr = NIL; return v; } #define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0,envsz)) #define tail_eval(xpr) do { \ if (selfevaluating(xpr)) { SP=saveSP; return (xpr); } \ else { e=(xpr); goto eval_top; } } while (0) /* eval a list of expressions, giving a list of the results */ static value_t evlis(value_t *pv, value_t *penv, uint32_t envsz) { PUSH(NIL); PUSH(NIL); value_t *rest = &Stack[SP-1]; value_t a, v = *pv; while (iscons(v)) { a = car_(v); v = eval(a); PUSH(v); v = mk_cons(); car_(v) = Stack[SP-1]; cdr_(v) = NIL; POPN(1); if (*rest == NIL) Stack[SP-2] = v; else cdr_(*rest) = v; *rest = v; v = *pv = cdr_(*pv); } POPN(1); return POP(); } /* If we start to run out of space on the lisp value stack, we allocate a new stack array and put it on the top of the chain. The new stack is active until this function returns. Any return past this function must free the new segment. */ static value_t new_stackseg(value_t e, value_t *penv, int tail, uint32_t envsz) { stackseg_t s; s.prev = current_stack_seg; s.Stack = (value_t*)malloc(N_STACK * sizeof(value_t)); if (s.Stack == NULL) lerror(MemoryError, "eval: stack overflow"); current_stack_seg->SP = SP; current_stack_seg = &s; SP = 0; Stack = s.Stack; value_t v = NIL; int err = 0; FL_TRY { v = eval_sexpr(e, penv, tail, envsz); } FL_CATCH { err = 1; v = lasterror; } free(s.Stack); current_stack_seg = s.prev; SP = current_stack_seg->SP; Stack = current_stack_seg->Stack; if (err) raise(v); return v; } static value_t do_trycatch(value_t expr, value_t *penv, uint32_t envsz) { value_t v; FL_TRY { v = eval(expr); } FL_CATCH { v = cdr_(Stack[SP-1]); if (!iscons(v)) { v = FL_F; // 1-argument form } else { v = car_(v); Stack[SP-1] = eval(v); v = applyn(1, Stack[SP-1], lasterror); } } return v; } static value_t do_trycatch2() { uint32_t saveSP = SP; value_t v; value_t thunk = Stack[SP-2]; Stack[SP-2] = Stack[SP-1]; Stack[SP-1] = thunk; FL_TRY { v = apply_cl(0); } FL_CATCH { Stack[SP-1] = lasterror; v = apply_cl(1); } SP = saveSP; 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. penv[-1] tells you the environment size, from LL through CLO, as a fixnum. */ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz) { value_t f, v, *pv, *lenv; cons_t *c; symbol_t *sym; uint32_t saveSP, bp, nargs; int i, noeval=0; fixnum_t s, lo, hi; int64_t accum; /* ios_printf(ios_stdout, "eval "); print(ios_stdout, e, 0); ios_printf(ios_stdout, " in "); print(ios_stdout, penv[0], 0); ios_printf(ios_stdout, "\n"); */ saveSP = SP; eval_top: if (issymbol(e)) { sym = (symbol_t*)ptr(e); while (1) { v = *penv++; while (iscons(v)) { if (car_(v)==e) { SP=saveSP; return *penv; } v = cdr_(v); penv++; } if (v != NIL) { if (v == e) { SP=saveSP; return *penv; } // dotted list penv++; } if (*penv == NIL) break; assert(isvector(*penv)); penv = &vector_elt(*penv, 0); } if (__unlikely((v = sym->binding) == UNBOUND)) raise(list2(UnboundError, e)); SP = saveSP; return v; } if (__unlikely(SP >= (N_STACK-MAX_ARGS-4))) { v = new_stackseg(e, penv, tail, envsz); SP = saveSP; return v; } bp = SP; v = car_(e); PUSH(cdr_(e)); if (selfevaluating(v)) f=v; else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax) && f!=TAG_CONST) { // handle special syntax forms if (isspecial(f)) goto apply_special; else { PUSH(f); noeval = 2; v = Stack[bp]; goto move_args; } } else f = eval(v); PUSH(f); v = Stack[bp]; // evaluate argument list, placing arguments on stack while (iscons(v)) { if (SP-bp-2 == MAX_ARGS) { v = evlis(&Stack[bp], penv, envsz); PUSH(v); break; } v = car_(v); v = eval(v); PUSH(v); v = Stack[bp] = cdr_(Stack[bp]); } do_apply: nargs = SP - bp - 2; if (isbuiltinish(f)) { // handle builtin function apply_special: switch (uintval(f)) { // special forms case F_QUOTE: if (__unlikely(!iscons(Stack[bp]))) lerror(ArgError, "quote: expected argument"); v = car_(Stack[bp]); break; case F_SETQ: e = car(Stack[bp]); v = car(cdr_(Stack[bp])); v = eval(v); while (1) { f = *penv++; while (iscons(f)) { if (car_(f)==e) { *penv = v; SP = saveSP; return v; } f = cdr_(f); penv++; } if (f != NIL) { if (f == e) { *penv = v; SP = saveSP; return v; } penv++; } if (*penv == NIL) break; penv = &vector_elt(*penv, 0); } sym = tosymbol(e, "set!"); if (sym->syntax != TAG_CONST) sym->binding = v; break; case F_LAMBDA: // build a closure (lambda args body . env) if (*penv != NIL) { // save temporary environment to the heap lenv = penv; assert(penv[envsz-1]==NIL || isvector(penv[envsz-1])); pv = alloc_words(envsz + 1); PUSH(tagptr(pv, TAG_VECTOR)); pv[0] = fixnum(envsz); pv++; while (envsz--) *pv++ = *penv++; assert(pv[-1]==NIL || isvector(pv[-1])); // environment representation changed; install // the new representation so everybody can see it lenv[0] = NIL; lenv[1] = Stack[SP-1]; } else { PUSH(penv[1]); // env has already been captured; share } c = (cons_t*)ptr(v=cons_reserve(3)); e = Stack[bp]; if (!iscons(e)) goto notpair; c->car = LAMBDA; c->cdr = tagptr(c+1, TAG_CONS); c++; c->car = car_(e); //argsyms c->cdr = tagptr(c+1, TAG_CONS); c++; if (!iscons(e=cdr_(e))) goto notpair; c->car = car_(e); //body c->cdr = Stack[SP-1]; //env break; case F_IF: if (!iscons(Stack[bp])) goto notpair; v = car_(Stack[bp]); if (eval(v) != FL_F) { v = cdr_(Stack[bp]); if (!iscons(v)) goto notpair; v = car_(v); } else { v = cdr_(Stack[bp]); if (!iscons(v)) goto notpair; if (!iscons(v=cdr_(v))) v = FL_F; // allow 2-arg form else v = car_(v); } tail_eval(v); break; case F_COND: pv = &Stack[bp]; v = FL_F; while (iscons(*pv)) { c = tocons(car_(*pv), "cond"); v = c->car; // allow last condition to be 'else' if (iscons(cdr_(*pv)) || v != elsesym) v = eval(v); if (v != FL_F) { *pv = cdr_(car_(*pv)); // evaluate body forms if (iscons(*pv)) { while (iscons(cdr_(*pv))) { v = car_(*pv); v = eval(v); *pv = cdr_(*pv); } tail_eval(car_(*pv)); } break; } *pv = cdr_(*pv); } break; case F_AND: pv = &Stack[bp]; v = FL_T; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { if ((v=eval(car_(*pv))) == FL_F) { SP = saveSP; return FL_F; } *pv = cdr_(*pv); } tail_eval(car_(*pv)); } break; case F_OR: pv = &Stack[bp]; v = FL_F; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { if ((v=eval(car_(*pv))) != FL_F) { SP = saveSP; return v; } *pv = cdr_(*pv); } tail_eval(car_(*pv)); } break; case F_WHILE: PUSH(cdr(Stack[bp])); lenv = &Stack[SP-1]; PUSH(*lenv); Stack[bp] = car_(Stack[bp]); value_t *cond = &Stack[bp]; PUSH(FL_F); pv = &Stack[SP-1]; while (eval(*cond) != FL_F) { *lenv = Stack[SP-2]; while (iscons(*lenv)) { *pv = eval(car_(*lenv)); *lenv = cdr_(*lenv); } } v = *pv; break; case F_BEGIN: // return last arg pv = &Stack[bp]; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { v = car_(*pv); (void)eval(v); *pv = cdr_(*pv); } tail_eval(car_(*pv)); } v = FL_F; break; case F_PROG1: // return first arg pv = &Stack[bp]; if (__unlikely(!iscons(*pv))) lerror(ArgError, "prog1: too few arguments"); PUSH(eval(car_(*pv))); *pv = cdr_(*pv); while (iscons(*pv)) { (void)eval(car_(*pv)); *pv = cdr_(*pv); } v = POP(); break; case F_FOR: if (!iscons(Stack[bp])) goto notpair; v = car_(Stack[bp]); lo = tofixnum(eval(v), "for"); Stack[bp] = cdr_(Stack[bp]); if (!iscons(Stack[bp])) goto notpair; v = car_(Stack[bp]); hi = tofixnum(eval(v), "for"); Stack[bp] = cdr_(Stack[bp]); if (!iscons(Stack[bp])) goto notpair; v = car_(Stack[bp]); f = eval(v); v = car(cdr(f)); if (!iscons(v) || !iscons(cdr_(cdr_(f))) || cdr_(v) != NIL || car_(f) != LAMBDA) lerror(ArgError, "for: expected 1 argument lambda"); f = cdr_(f); PUSH(f); // save function cdr SP += 3; // make space Stack[SP-1] = cdr_(cdr_(f)); // cloenv v = FL_F; for(s=lo; s <= hi; s++) { f = Stack[SP-4]; Stack[SP-3] = car_(f); // lambda list Stack[SP-2] = fixnum(s); // argument value v = car_(cdr_(f)); if (!selfevaluating(v)) v = eval_sexpr(v, &Stack[SP-3], 0, 3); } break; case F_TRYCATCH: v = do_trycatch(car(Stack[bp]), penv, envsz); break; // ordinary functions case F_BOUNDP: argcount("bound?", nargs, 1); sym = tosymbol(Stack[SP-1], "bound?"); v = (sym->binding == UNBOUND) ? FL_F : FL_T; break; case F_EQ: argcount("eq?", nargs, 2); v = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F); 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_LIST: if (nargs) v = list(&Stack[SP-nargs], nargs); else v = NIL; break; case F_CAR: argcount("car", nargs, 1); v = Stack[SP-1]; if (!iscons(v)) goto notpair; v = car_(v); break; case F_CDR: argcount("cdr", nargs, 1); v = Stack[SP-1]; if (!iscons(v)) goto notpair; v = cdr_(v); break; case F_SETCAR: argcount("set-car!", nargs, 2); car(v=Stack[SP-2]) = Stack[SP-1]; break; case F_SETCDR: argcount("set-cdr!", nargs, 2); cdr(v=Stack[SP-2]) = Stack[SP-1]; break; case F_VECTOR: if (nargs > MAX_ARGS) { i = llength(Stack[SP-1]); nargs--; } else i = 0; v = alloc_vector(nargs+i, 0); memcpy(&vector_elt(v,0), &Stack[bp+2], nargs*sizeof(value_t)); if (i > 0) { e = Stack[SP-1]; while (iscons(e)) { vector_elt(v,nargs) = car_(e); nargs++; e = cdr_(e); } } break; case F_AREF: argcount("aref", nargs, 2); v = Stack[SP-2]; if (isvector(v)) { i = tofixnum(Stack[SP-1], "aref"); if (__unlikely((unsigned)i >= vector_size(v))) bounds_error("aref", v, Stack[SP-1]); v = vector_elt(v, i); } else if (isarray(v)) { v = cvalue_array_aref(&Stack[SP-2]); } else { // TODO other sequence types? type_error("aref", "sequence", v); } break; case F_ASET: argcount("aset!", nargs, 3); e = Stack[SP-3]; if (isvector(e)) { i = tofixnum(Stack[SP-2], "aset!"); if (__unlikely((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); } break; case F_ATOM: argcount("atom?", nargs, 1); v = (iscons(Stack[SP-1]) ? FL_F : FL_T); break; case F_CONSP: argcount("pair?", nargs, 1); v = (iscons(Stack[SP-1]) ? FL_T : FL_F); break; case F_SYMBOLP: argcount("symbol?", nargs, 1); v = ((issymbol(Stack[SP-1])) ? FL_T : FL_F); break; case F_NUMBERP: argcount("number?", nargs, 1); v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? FL_T : FL_F); break; case F_FIXNUMP: argcount("fixnum?", nargs, 1); v = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); break; case F_BUILTINP: argcount("builtin?", nargs, 1); v = Stack[SP-1]; v = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL) ? FL_T : FL_F); break; case F_VECTORP: argcount("vector?", nargs, 1); v = ((isvector(Stack[SP-1])) ? FL_T : FL_F); break; case F_NOT: argcount("not", nargs, 1); v = ((Stack[SP-1] == FL_F) ? FL_T : FL_F); break; case F_NULL: argcount("null?", nargs, 1); v = ((Stack[SP-1] == NIL) ? FL_T : FL_F); break; case F_BOOLEANP: argcount("boolean?", nargs, 1); v = Stack[SP-1]; v = ((v == FL_T || v == FL_F) ? FL_T : FL_F); break; case F_ADD: s = 0; i = bp+2; if (nargs > MAX_ARGS) goto add_ovf; for (; i < (int)SP; i++) { if (__likely(isfixnum(Stack[i]))) { s += numval(Stack[i]); if (__unlikely(!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 (__unlikely(nargs < 1)) lerror(ArgError, "-: too few arguments"); i = bp+2; if (nargs == 1) { if (__likely(isfixnum(Stack[i]))) v = fixnum(-numval(Stack[i])); else v = fl_neg(Stack[i]); break; } if (nargs == 2) { if (__likely(bothfixnums(Stack[i], Stack[i+1]))) { s = numval(Stack[i]) - numval(Stack[i+1]); if (__likely(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 { // 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], nargs, 0)); Stack[i] = POP(); } v = fl_add_any(&Stack[i], 2, 0); break; case F_MUL: accum = 1; i = bp+2; if (nargs > MAX_ARGS) goto mul_ovf; for (; i < (int)SP; i++) { if (__likely(isfixnum(Stack[i]))) { accum *= numval(Stack[i]); } else { mul_ovf: v = fl_mul_any(&Stack[i], SP-i, accum); SP = saveSP; return v; } } if (__likely(fits_fixnum(accum))) v = fixnum(accum); else v = return_from_int64(accum); break; case F_DIV: if (__unlikely(nargs < 1)) lerror(ArgError, "/: too few arguments"); i = bp+2; if (nargs == 1) { v = fl_div2(fixnum(1), Stack[i]); } else { if (nargs > 2) { PUSH(Stack[i]); Stack[i] = fixnum(1); Stack[i+1] = fl_mul_any(&Stack[i], nargs, 1); Stack[i] = POP(); } v = fl_div2(Stack[i], Stack[i+1]); } break; case F_COMPARE: argcount("compare", nargs, 2); v = compare(Stack[SP-2], Stack[SP-1]); break; case F_NUMEQ: argcount("=", nargs, 2); 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; } break; case F_LT: argcount("<", nargs, 2); if (bothfixnums(Stack[SP-2], Stack[SP-1])) { v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? FL_T : FL_F; } else { v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? FL_T : FL_F; } break; case F_EQUAL: argcount("equal?", nargs, 2); if (Stack[SP-2] == Stack[SP-1]) { v = FL_T; } else if (eq_comparable(Stack[SP-2],Stack[SP-1])) { v = FL_F; } else { v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? FL_T : FL_F; } break; case F_EQV: argcount("eqv?", nargs, 2); 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 = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? FL_T : FL_F; } break; case F_EVAL: argcount("eval", nargs, 1); e = Stack[SP-1]; if (selfevaluating(e)) { SP=saveSP; return e; } envsz = 2; if (tail) { assert((ulong_t)(penv-Stack) (signed)bp+1); if (__likely(iscons(f))) { if (car_(f) == COMPILEDLAMBDA) { i = SP; e = apply_cl(nargs); SP = i; if (noeval == 2) { if (selfevaluating(e)) { SP=saveSP; return(e); } noeval = 0; goto eval_top; } else { SP = saveSP; return e; } } // apply lambda expression f = Stack[bp+1] = cdr_(f); if (!iscons(f)) goto notpair; v = car_(f); // arglist i = nargs; while (iscons(v)) { if (i == 0) lerror(ArgError, "apply: too few arguments"); i--; v = cdr_(v); } if (v == NIL) { if (i > 0) lerror(ArgError, "apply: too many arguments"); } else { v = NIL; if (i > 0) { v = list(&Stack[SP-i], i); if (nargs > MAX_ARGS) { c = (cons_t*)curheap; (c-2)->cdr = (c-1)->car; } } Stack[SP-i] = v; SP -= (i-1); } f = cdr_(Stack[bp+1]); if (!iscons(f)) goto notpair; e = car_(f); if (selfevaluating(e)) { SP=saveSP; return(e); } PUSH(cdr_(f)); // add closed environment assert(Stack[SP-1]==NIL || isvector(Stack[SP-1])); Stack[bp+1] = car_(Stack[bp+1]); // put lambda list if (noeval == 2) { // macro: evaluate body in lambda environment e = eval_sexpr(e, &Stack[bp+1], 1, SP - bp - 1); if (selfevaluating(e)) { SP=saveSP; return(e); } noeval = 0; // macro: evaluate expansion in calling environment goto eval_top; } else { envsz = SP - bp - 1; if (tail) { // ok to overwrite environment for(i=0; i < (int)envsz; i++) penv[i] = Stack[bp+1+i]; SP = (penv-Stack)+envsz; assert(penv[envsz-1]==NIL || isvector(penv[envsz-1])); goto eval_top; } else { penv = &Stack[bp+1]; tail = 1; goto eval_top; } } // not reached } apply_type_error: type_error("apply", "function", f); notpair: lerror(TypeError, "expected cons"); return NIL; } /* stack on entry: caller's responsibility: - put the stack in this state - provide arg count - respect tail position - call correct entry point (either eval_sexpr or apply_cl) - restore SP callee's responsibility: - check arg counts - allocate vararg array - push closed env, set up new environment ** need 'copyenv' instruction that moves env to heap, installs heap version as the current env, and pushes the result vector. this can be used to implement the copy-closure op in terms of other ops. and it can be the first instruction in lambdas in head position (let optimization). */ static value_t apply_cl(uint32_t nargs) { uint32_t i, n, ip, bp, envsz, captured, op; fixnum_t s, lo, hi; int64_t accum; uint8_t *code; value_t func, v, bcode, x, e; value_t *pvals, *lenv, *pv; symbol_t *sym; cons_t *c; apply_cl_top: captured = 0; func = Stack[SP-nargs-1]; assert(iscons(func)); assert(iscons(cdr_(func))); assert(iscons(cdr_(cdr_(func)))); x = cdr_(cdr_(func)); bcode = car_(x); code = cv_data((cvalue_t*)ptr(car_(bcode))); assert(!ismanaged((uptrint_t)code)); if (nargs < code[1]) lerror(ArgError, "apply: too few arguments"); bp = SP-nargs; x = cdr_(x); // cloenv PUSH(x); PUSH(cdr_(bcode)); pvals = &Stack[SP-1]; ip = 0; while (1) { op = code[ip++]; dispatch: switch (op) { case OP_ARGC: if (nargs > code[ip++]) { lerror(ArgError, "apply: too many arguments"); } break; case OP_VARGC: i = code[ip++]; s = (fixnum_t)nargs - (fixnum_t)i; v = NIL; if (s > 0) { v = list(&Stack[bp+i], s); if (nargs > MAX_ARGS) { c = (cons_t*)curheap; (c-2)->cdr = (c-1)->car; } Stack[bp+i] = v; Stack[bp+i+1] = Stack[bp+nargs]; Stack[bp+i+2] = Stack[bp+nargs+1]; pvals = &Stack[bp+i+2]; } else { PUSH(NIL); Stack[SP-1] = Stack[SP-2]; Stack[SP-2] = Stack[SP-3]; Stack[SP-3] = NIL; pvals = &Stack[SP-1]; } nargs = i+1; break; case OP_LET: ip++; // last arg is closure environment to use nargs--; Stack[SP-2] = Stack[SP-1]; POPN(1); pvals = &Stack[SP-1]; break; case OP_NOP: break; case OP_DUP: v = Stack[SP-1]; PUSH(v); break; case OP_POP: POPN(1); break; case OP_TCALL: case OP_CALL: i = code[ip++]; // nargs do_call: s = SP; func = Stack[SP-i-1]; if (isbuiltinish(func)) { op = uintval(func); if (op > N_BUILTINS) { v = ((builtin_t)ptr(func))(&Stack[SP-i], i); } else { s = builtin_arg_counts[op]; if (s >= 0) argcount(builtin_names[op], i, s); else if (s != ANYARGS && (signed)i < -s) argcount(builtin_names[op], i, -s); // remove function arg for(s=SP-i-1; s < (int)SP-1; s++) Stack[s] = Stack[s+1]; SP--; n = i; switch (op) { case OP_LIST: goto apply_list; case OP_ADD: goto apply_add; case OP_SUB: goto apply_sub; case OP_MUL: goto apply_mul; case OP_DIV: goto apply_div; case OP_VECTOR: goto apply_vector; default: goto dispatch; } } } else if (iscons(func)) { if (car_(func) == COMPILEDLAMBDA) { if (op == OP_TCALL) { for(s=-1; s < (fixnum_t)i; s++) Stack[bp+s] = Stack[SP-i+s]; SP = bp+i; nargs = i; goto apply_cl_top; } else { v = apply_cl(i); } } else { v = _applyn(i); } } else { type_error("apply", "function", func); } SP = s-i-1; PUSH(v); break; case OP_JMP: ip = (uint32_t)*(uint16_t*)&code[ip]; break; case OP_BRF: v = POP(); if (v == FL_F) ip = (uint32_t)*(uint16_t*)&code[ip]; else ip += 2; break; case OP_BRT: v = POP(); if (v != FL_F) ip = (uint32_t)*(uint16_t*)&code[ip]; else ip += 2; break; case OP_JMPL: ip = *(uint32_t*)&code[ip]; break; case OP_BRFL: v = POP(); if (v == FL_F) ip = *(uint32_t*)&code[ip]; else ip += 4; break; case OP_BRTL: v = POP(); if (v != FL_F) ip = *(uint32_t*)&code[ip]; else ip += 4; break; case OP_RET: v = POP(); return v; case OP_EQ: Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F); POPN(1); break; case 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 = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? FL_T : FL_F; } Stack[SP-2] = v; POPN(1); break; case OP_EQUAL: if (Stack[SP-2] == Stack[SP-1]) { v = FL_T; } else if (eq_comparable(Stack[SP-2],Stack[SP-1])) { v = FL_F; } else { v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? FL_T : FL_F; } Stack[SP-2] = v; POPN(1); break; case OP_PAIRP: Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); break; case OP_ATOMP: Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_F : FL_T); break; case OP_NOT: Stack[SP-1] = ((Stack[SP-1]==FL_F) ? FL_T : FL_F); break; case OP_NULLP: Stack[SP-1] = ((Stack[SP-1]==NIL) ? FL_T : FL_F); break; case OP_BOOLEANP: v = Stack[SP-1]; Stack[SP-1] = ((v == FL_T || v == FL_F) ? FL_T : FL_F); break; case OP_SYMBOLP: Stack[SP-1] = (issymbol(Stack[SP-1]) ? FL_T : FL_F); break; case OP_NUMBERP: v = Stack[SP-1]; Stack[SP-1] = (isfixnum(v) || iscprim(v) ? FL_T : FL_F); break; case OP_FIXNUMP: Stack[SP-1] = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); break; case OP_BOUNDP: sym = tosymbol(Stack[SP-1], "bound?"); Stack[SP-1] = ((sym->binding == UNBOUND) ? FL_F : FL_T); break; case OP_BUILTINP: v = Stack[SP-1]; Stack[SP-1] = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL) ? FL_T : FL_F); break; case OP_VECTORP: Stack[SP-1] = (isvector(Stack[SP-1]) ? FL_T : FL_F); break; case OP_CONS: if (curheap > lim) gc(0); c = (cons_t*)curheap; curheap += sizeof(cons_t); c->car = Stack[SP-2]; c->cdr = Stack[SP-1]; Stack[SP-2] = tagptr(c, TAG_CONS); POPN(1); break; case OP_CAR: c = tocons(Stack[SP-1], "car"); Stack[SP-1] = c->car; break; case OP_CDR: c = tocons(Stack[SP-1], "cdr"); Stack[SP-1] = c->cdr; break; case OP_SETCAR: car(Stack[SP-2]) = Stack[SP-1]; POPN(1); break; case OP_SETCDR: cdr(Stack[SP-2]) = Stack[SP-1]; POPN(1); break; case OP_LIST: i = code[ip++]; apply_list: if (i > 0) v = list(&Stack[SP-i], i); else v = NIL; POPN(i); PUSH(v); break; case OP_EVAL: v = toplevel_eval(POP()); PUSH(v); break; case OP_TAPPLY: case OP_APPLY: v = POP(); // arglist i = SP; while (iscons(v)) { if (SP-i == MAX_ARGS) { PUSH(v); break; } PUSH(car_(v)); v = cdr_(v); } i = SP-i; if (op==OP_TAPPLY) op = OP_TCALL; goto do_call; case OP_ADD: n = code[ip++]; apply_add: s = 0; i = SP-n; if (n > MAX_ARGS) goto add_ovf; for (; i < SP; i++) { if (__likely(isfixnum(Stack[i]))) { s += numval(Stack[i]); if (__unlikely(!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); break; case OP_SUB: n = code[ip++]; apply_sub: if (__unlikely(n < 1)) lerror(ArgError, "-: too few arguments"); i = SP-n; if (n == 1) { if (__likely(isfixnum(Stack[i]))) Stack[SP-1] = fixnum(-numval(Stack[i])); else Stack[SP-1] = fl_neg(Stack[i]); break; } if (n == 2) { if (__likely(bothfixnums(Stack[i], Stack[i+1]))) { s = numval(Stack[i]) - numval(Stack[i+1]); if (__likely(fits_fixnum(s))) { POPN(1); Stack[SP-1] = fixnum(s); break; } Stack[i+1] = fixnum(-numval(Stack[i+1])); } else { Stack[i+1] = fl_neg(Stack[i+1]); } } else { // 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); break; case OP_MUL: n = code[ip++]; apply_mul: accum = 1; i = SP-n; if (n > MAX_ARGS) goto mul_ovf; for (; i < SP; i++) { if (__likely(isfixnum(Stack[i]))) { accum *= numval(Stack[i]); } else { mul_ovf: v = fl_mul_any(&Stack[i], SP-i, accum); break; } } if (i == SP) { if (__likely(fits_fixnum(accum))) v = fixnum(accum); else v = return_from_int64(accum); } POPN(n); PUSH(v); break; case OP_DIV: n = code[ip++]; apply_div: if (__unlikely(n < 1)) lerror(ArgError, "/: too few arguments"); 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); } break; case F_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; break; case 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(compare(Stack[SP-2], Stack[SP-1])) < 0) ? FL_T : FL_F; } POPN(1); Stack[SP-1] = v; break; case OP_COMPARE: Stack[SP-2] = compare(Stack[SP-2], Stack[SP-1]); POPN(1); break; case OP_VECTOR: n = code[ip++]; apply_vector: if (n > MAX_ARGS) { i = llength(Stack[SP-1])-1; } else i = 0; v = alloc_vector(n+i, 0); memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t)); e = POP(); POPN(n-1); if (n > MAX_ARGS) { i = n-1; while (iscons(e)) { vector_elt(v,i) = car_(e); i++; e = cdr_(e); } } PUSH(v); break; case OP_AREF: v = Stack[SP-2]; if (isvector(v)) { i = tofixnum(Stack[SP-1], "aref"); if (__unlikely((unsigned)i >= vector_size(v))) bounds_error("aref", v, Stack[SP-1]); 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; break; case OP_ASET: e = Stack[SP-3]; if (isvector(e)) { i = tofixnum(Stack[SP-2], "aset!"); if (__unlikely((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; break; case OP_FOR: lo = tofixnum(Stack[SP-3], "for"); hi = tofixnum(Stack[SP-2], "for"); //f = Stack[SP-1]; v = FL_F; SP += 2; i = SP; for(s=lo; s <= hi; s++) { Stack[SP-2] = Stack[SP-3]; Stack[SP-1] = fixnum(s); v = apply_cl(1); SP = i; } POPN(4); Stack[SP-1] = v; break; case OP_LOADT: PUSH(FL_T); break; case OP_LOADF: PUSH(FL_F); break; case OP_LOADNIL: PUSH(NIL); break; case OP_LOAD0: PUSH(fixnum(0)); break; case OP_LOAD1: PUSH(fixnum(1)); break; case OP_LOADI8: s = (int8_t)code[ip++]; PUSH(fixnum(s)); break; case OP_LOADV: assert(code[ip] < vector_size(*pvals)); v = vector_elt(*pvals, code[ip]); ip++; PUSH(v); break; case OP_LOADVL: v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; PUSH(v); break; case OP_LOADGL: v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; goto do_loadg; case OP_LOADG: assert(code[ip] < vector_size(*pvals)); v = vector_elt(*pvals, code[ip]); ip++; do_loadg: assert(issymbol(v)); sym = (symbol_t*)ptr(v); if (sym->binding == UNBOUND) raise(list2(UnboundError, v)); PUSH(sym->binding); break; case OP_SETGL: v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; goto do_setg; case OP_SETG: assert(code[ip] < vector_size(*pvals)); v = vector_elt(*pvals, code[ip]); ip++; do_setg: assert(issymbol(v)); sym = (symbol_t*)ptr(v); v = Stack[SP-1]; if (sym->syntax != TAG_CONST) sym->binding = v; break; case OP_LOADA: assert(nargs > 0); i = code[ip++]; if (captured) { x = Stack[bp]; assert(isvector(x)); assert(i < vector_size(x)); v = vector_elt(x, i); } else { assert(bp+i < SP); v = Stack[bp+i]; } PUSH(v); break; case OP_SETA: assert(nargs > 0); v = Stack[SP-1]; i = code[ip++]; if (captured) { x = Stack[bp]; assert(isvector(x)); assert(i < vector_size(x)); vector_elt(x, i) = v; } else { assert(bp+i < SP); Stack[bp+i] = v; } break; case OP_LOADC: case OP_SETC: s = code[ip++]; i = code[ip++]; if (captured) { if (nargs > 0) { // current frame has been captured s++; } v = Stack[bp]; } else { v = Stack[bp+nargs]; } while (s--) v = vector_elt(v, vector_size(v)-1); assert(isvector(v)); assert(i < vector_size(v)); if (op == OP_SETC) vector_elt(v, i) = Stack[SP-1]; else PUSH(vector_elt(v, i)); break; case OP_CLOSURE: case OP_CLOSE: // build a closure (lambda args body . env) if (nargs > 0 && !captured) { // save temporary environment to the heap lenv = &Stack[bp]; envsz = nargs+1; pv = alloc_words(envsz + 1); PUSH(tagptr(pv, TAG_VECTOR)); pv[0] = fixnum(envsz); pv++; while (envsz--) *pv++ = *lenv++; // environment representation changed; install // the new representation so everybody can see it captured = 1; Stack[bp] = Stack[SP-1]; } else { PUSH(Stack[bp]); // env has already been captured; share } if (op == OP_CLOSURE) { c = (cons_t*)ptr(v=cons_reserve(3)); e = cdr_(Stack[SP-2]); // closure to copy //if (!iscons(e)) goto notpair; c->car = COMPILEDLAMBDA; c->cdr = tagptr(c+1, TAG_CONS); c++; c->car = car_(e); //argsyms c->cdr = tagptr(c+1, TAG_CONS); c++; e = cdr_(e); //if (!iscons(e=cdr_(e))) goto notpair; c->car = car_(e); //body c->cdr = Stack[SP-1]; //env POPN(1); Stack[SP-1] = v; } break; case OP_TRYCATCH: v = do_trycatch2(); POPN(1); Stack[SP-1] = v; break; } } } // initialization ------------------------------------------------------------- extern void builtins_init(); extern void comparehash_init(); static char *EXEDIR = NULL; void assign_global_builtins(builtinspec_t *b) { while (b->name != NULL) { set(symbol(b->name), cbuiltin(b->name, b->fptr)); b++; } } static void lisp_init(void) { int i; llt_init(); fromspace = malloc(heapsize); tospace = malloc(heapsize); curheap = fromspace; lim = curheap+heapsize-sizeof(cons_t); consflags = bitvector_new(heapsize/sizeof(cons_t), 1); htable_new(&printconses, 32); comparehash_init(); NIL = builtin(F_NIL); FL_T = builtin(F_TRUE); FL_F = builtin(F_FALSE); LAMBDA = symbol("lambda"); COMPILEDLAMBDA = symbol("compiled-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"); KeyError = symbol("key-error"); MemoryError = symbol("memory-error"); BoundsError = symbol("bounds-error"); DivideError = symbol("divide-error"); EnumerationError = symbol("enumeration-error"); Error = symbol("error"); conssym = symbol("cons"); 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"); labelsym = symbol("label"); setqsym = symbol("set!"); elsesym = symbol("else"); tsym = symbol("t"); Tsym = symbol("T"); fsym = symbol("f"); Fsym = symbol("F"); set(printprettysym=symbol("*print-pretty*"), FL_T); set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH)); lasterror = NIL; special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL); apply1_args = fl_cons(NIL, 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 < F_TRUE; i++) { setc(symbol(builtin_names[i]), builtin(i)); } setc(symbol("eq"), builtin(F_EQ)); setc(symbol("equal"), builtin(F_EQUAL)); #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"), cbuiltin("gensym", gensym)); set(symbol("hash"), cbuiltin("hash", fl_hash)); char buf[1024]; char *exename = get_exename(buf, sizeof(buf)); if (exename != NULL) { path_to_dirname(exename); EXEDIR = strdup(exename); setc(symbol("*install-dir*"), cvalue_static_cstring(EXEDIR)); } memory_exception_value = list2(MemoryError, cvalue_static_cstring("out of memory")); builtins_init(); } // repl ----------------------------------------------------------------------- value_t toplevel_eval(value_t expr) { value_t v; uint32_t saveSP = SP; PUSH(NIL); PUSH(NIL); v = topeval(expr, &Stack[SP-2]); SP = saveSP; return v; } static value_t argv_list(int argc, char *argv[]) { int i; PUSH(NIL); for(i=argc-1; i >= 0; i--) { PUSH(cvalue_static_cstring(argv[i])); Stack[SP-2] = fl_cons(Stack[SP-1], Stack[SP-2]); POPN(1); } return POP(); } int locale_is_utf8; extern value_t fl_file(value_t *args, uint32_t nargs); int main(int argc, char *argv[]) { value_t e, v; char fname_buf[1024]; locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, "")); lisp_init(); fname_buf[0] = '\0'; if (EXEDIR != NULL) { strcat(fname_buf, EXEDIR); strcat(fname_buf, PATHSEPSTRING); } strcat(fname_buf, "system.lsp"); FL_TRY { // install toplevel exception handler PUSH(cvalue_static_cstring(fname_buf)); PUSH(symbol(":read")); value_t f = fl_file(&Stack[SP-2], 2); POPN(2); PUSH(f); while (1) { e = read_sexpr(Stack[SP-1]); if (ios_eof(value2c(ios_t*,Stack[SP-1]))) break; v = toplevel_eval(e); } ios_close(value2c(ios_t*,Stack[SP-1])); POPN(1); PUSH(symbol_value(symbol("__start"))); PUSH(argv_list(argc, argv)); (void)_applyn(1); } FL_CATCH { ios_puts("fatal error during bootstrap:\n", ios_stderr); print(ios_stderr, lasterror, 0); ios_putc('\n', ios_stderr); return 1; } return 0; }