ref: 14c196a5da48284123d615418c80b6fbc87d7f46
dir: /flisp.c/
/* femtoLisp by Jeff Bezanson (C) 2009 Distributed under the BSD License */ #include "flisp.h" #include "operators.h" #include "cvalues.h" #include "opcodes.h" #include "types.h" #include "print.h" #include "read.h" #include "timefuncs.h" #include "equal.h" #include "hashing.h" #include "table.h" #include "iostream.h" #include "fsixel.h" typedef struct { char *name; builtin_t fptr; }builtinspec_t; #ifdef NDEBUG __thread #endif Fl *fl; bool isbuiltin(value_t x) { uint32_t i; return tag(x) == TAG_FUNCTION && (i = uintval(x)) < nelem(builtins) && builtins[i].name != nil; } static value_t apply_cl(uint32_t nargs); // error utilities ------------------------------------------------------------ void free_readstate(fl_readstate_t *rs) { htable_free(&rs->backrefs); htable_free(&rs->gensyms); } _Noreturn void fl_exit(int status) { FL(exiting) = true; gc(0); exit(status); } #define FL_TRY \ fl_exception_context_t _ctx; int l__tr, l__ca; \ _ctx.sp = FL(sp); _ctx.frame = FL(curr_frame); _ctx.rdst = FL(readstate); _ctx.prev = FL(exctx); \ _ctx.ngchnd = FL(ngchandles); FL(exctx) = &_ctx; \ if(!setjmp(_ctx.buf)) \ for(l__tr = 1; l__tr; l__tr = 0, (void)(FL(exctx) = FL(exctx)->prev)) #define FL_CATCH_INC \ l__ca = 0, FL(lasterror) = FL(Nil), FL(throwing_frame) = 0, FL(sp) = _ctx.sp, FL(curr_frame) = _ctx.frame #define FL_CATCH \ else \ for(l__ca = 1; l__ca; FL_CATCH_INC) #define FL_CATCH_NO_INC \ else \ for(l__ca = 1; l__ca;) void fl_savestate(fl_exception_context_t *_ctx) { _ctx->sp = FL(sp); _ctx->frame = FL(curr_frame); _ctx->rdst = FL(readstate); _ctx->prev = FL(exctx); _ctx->ngchnd = FL(ngchandles); } void fl_restorestate(fl_exception_context_t *_ctx) { FL(lasterror) = FL(Nil); FL(throwing_frame) = 0; FL(sp) = _ctx->sp; FL(curr_frame) = _ctx->frame; } _Noreturn void fl_raise(value_t e) { FL(lasterror) = e; // unwind read state while(FL(readstate) != FL(exctx)->rdst){ free_readstate(FL(readstate)); FL(readstate) = FL(readstate)->prev; } if(FL(throwing_frame) == 0) FL(throwing_frame) = FL(curr_frame); FL(ngchandles) = FL(exctx)->ngchnd; fl_exception_context_t *thisctx = FL(exctx); if(FL(exctx)->prev) // don't throw past toplevel FL(exctx) = FL(exctx)->prev; longjmp(thisctx->buf, 1); } _Noreturn void lerrorf(value_t e, const char *format, ...) { char msgbuf[256]; va_list args; PUSH(e); va_start(args, format); vsnprintf(msgbuf, sizeof(msgbuf), format, args); value_t msg = string_from_cstr(msgbuf); va_end(args); e = POP(); fl_raise(fl_list2(e, msg)); } _Noreturn void type_error(const char *expected, value_t got) { fl_raise(fl_listn(3, FL(TypeError), symbol(expected, false), got)); } _Noreturn void bounds_error(value_t arr, value_t ind) { fl_raise(fl_listn(3, FL(BoundsError), arr, ind)); } _Noreturn void unbound_error(value_t sym) { fl_raise(fl_listn(2, FL(UnboundError), sym)); } // safe cast operators -------------------------------------------------------- #define isstring fl_isstring #define SAFECAST_OP(type, ctype, cnvt) \ ctype to##type(value_t v) \ { \ if(__likely(is##type(v))) \ return (ctype)cnvt(v); \ type_error(#type, v); \ } SAFECAST_OP(cons, cons_t*, ptr) SAFECAST_OP(symbol, symbol_t*, ptr) SAFECAST_OP(fixnum, fixnum_t, numval) //SAFECAST_OP(cvalue, cvalue_t*, ptr) SAFECAST_OP(string, char*, cvalue_data) #undef isstring // symbol table --------------------------------------------------------------- bool fl_is_keyword_name(const char *str, size_t len) { return (str[0] == ':' || str[len-1] == ':') && str[1] != '\0'; } static symbol_t * mk_symbol(const char *str, bool copy) { symbol_t *sym; int len = strlen(str); sym = calloc(1, sizeof(*sym) + (copy ? len+1 : 0)); assert(((uintptr_t)sym & 0x7) == 0); // make sure malloc aligns 8 sym->numtype = NONNUMERIC; if(fl_is_keyword_name(str, len)){ value_t s = tagptr(sym, TAG_SYM); setc(s, s); sym->flags |= FLAG_KEYWORD; }else{ sym->binding = UNBOUND; } sym->hash = memhash32(str, len)^0xAAAAAAAA; if(copy){ sym->name = (const char*)(sym+1); memcpy((char*)sym->name, str, len+1); }else{ sym->name = str; } return sym; } static symbol_t ** symtab_lookup(symbol_t **ptree, const char *str) { int x; while(*ptree != nil && (x = strcmp(str, (*ptree)->name)) != 0) ptree = x < 0 ? &(*ptree)->left : &(*ptree)->right; return ptree; } value_t symbol(const char *str, bool copy) { symbol_t **pnode; pnode = symtab_lookup(&FL(symtab), str); if(*pnode == nil) *pnode = mk_symbol(str, copy); return tagptr(*pnode, TAG_SYM); } BUILTIN("gensym", gensym) { argcount(nargs, 0); USED(args); gensym_t *gs = alloc_words(sizeof(gensym_t)/sizeof(value_t)); gs->id = FL(gensym_ctr)++; gs->binding = UNBOUND; gs->type = nil; return tagptr(gs, TAG_SYM); } value_t gensym(void) { return fn_builtin_gensym(nil, 0); } BUILTIN("gensym?", gensymp) { argcount(nargs, 1); return isgensym(args[0]) ? FL(t) : FL(f); } char * uint2str(char *dest, size_t len, uint64_t num, uint32_t base) { int i = len-1; uint64_t b = (uint64_t)base; char ch; dest[i--] = '\0'; while(i >= 0){ ch = (char)(num % b); if(ch < 10) ch += '0'; else ch = ch-10+'a'; dest[i--] = ch; num /= b; if(num == 0) break; } return &dest[i+1]; } const char * symbol_name(value_t v) { if(ismanaged(v)){ gensym_t *gs = (gensym_t*)ptr(v); FL(gsnameno) = 1-FL(gsnameno); char *n = uint2str(FL(gsname)[FL(gsnameno)]+1, sizeof(FL(gsname)[0])-1, gs->id, 10); *(--n) = 'g'; return n; } return ((symbol_t*)ptr(v))->name; } // conses --------------------------------------------------------------------- value_t mk_cons(void) { cons_t *c; if(__unlikely(FL(curheap) > FL(lim))) gc(0); c = (cons_t*)FL(curheap); FL(curheap) += sizeof(cons_t); return tagptr(c, TAG_CONS); } void * alloc_words(uint32_t n) { value_t *first; assert(n > 0); n = ALIGNED(n, 2); // only allocate multiples of 2 words if(__unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)+2-n)){ gc(0); while((value_t*)FL(curheap) > ((value_t*)FL(lim))+2-n) gc(1); } first = (value_t*)FL(curheap); FL(curheap) += n*sizeof(value_t); return first; } value_t alloc_vector(size_t n, int init) { if(n == 0) return FL(the_empty_vector); value_t *c = alloc_words(n+1); value_t v = tagptr(c, TAG_VECTOR); vector_setsize(v, n); if(init){ unsigned int i; for(i = 0; i < n; i++) vector_elt(v, i) = FL(unspecified); } return v; } // collector ------------------------------------------------------------------ void fl_gc_handle(value_t *pv) { if(__unlikely(FL(ngchandles) >= N_GC_HANDLES)) lerrorf(FL(MemoryError), "out of gc handles"); FL(gchandles)[FL(ngchandles)++] = pv; } void fl_free_gc_handles(uint32_t n) { assert(FL(ngchandles) >= n); FL(ngchandles) -= n; } value_t relocate(value_t v) { value_t a, d, nc, first, *pcdr; if(isfixnum(v)) return v; uintptr_t t = tag(v); if(t == TAG_CONS){ // iterative implementation allows arbitrarily long cons chains pcdr = &first; do{ if((a = car_(v)) == TAG_FWD){ *pcdr = cdr_(v); return first; } car_(v) = TAG_FWD; d = cdr_(v); *pcdr = nc = tagptr((cons_t*)FL(curheap), TAG_CONS); FL(curheap) += sizeof(cons_t); cdr_(v) = nc; car_(nc) = relocate(a); pcdr = &cdr_(nc); v = d; }while(iscons(v)); *pcdr = d == FL(Nil) ? FL(Nil) : relocate(d); return first; } if(!ismanaged(v)) return v; if(isforwarded(v)) return forwardloc(v); if(t == TAG_CVALUE) return cvalue_relocate(v); if(t == TAG_CPRIM){ cprim_t *pcp = ptr(v); size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size); cprim_t *ncp = alloc_words(nw); while(nw--) ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw]; nc = tagptr(ncp, TAG_CPRIM); forward(v, nc); return nc; } if(t == TAG_FUNCTION){ function_t *fn = ptr(v); function_t *nfn = alloc_words(4); nfn->bcode = fn->bcode; nfn->vals = fn->vals; nc = tagptr(nfn, TAG_FUNCTION); forward(v, nc); nfn->env = relocate(fn->env); nfn->vals = relocate(nfn->vals); nfn->bcode = relocate(nfn->bcode); assert(!ismanaged(fn->name)); nfn->name = fn->name; return nc; } if(t == TAG_VECTOR){ // N.B.: 0-length vectors secretly have space for a first element size_t i, sz = vector_size(v); if(vector_elt(v, -1) & 0x1){ // grown vector nc = relocate(vector_elt(v, 0)); forward(v, nc); }else{ nc = tagptr(alloc_words(sz+1), TAG_VECTOR); vector_setsize(nc, sz); a = vector_elt(v, 0); forward(v, nc); if(sz > 0){ vector_elt(nc, 0) = relocate(a); for(i = 1; i < sz; i++) vector_elt(nc, i) = relocate(vector_elt(v, i)); } } return nc; } if(t == TAG_SYM){ gensym_t *gs = ptr(v); gensym_t *ng = alloc_words(sizeof(gensym_t)/sizeof(value_t)); ng->id = gs->id; ng->binding = gs->binding; nc = tagptr(ng, TAG_SYM); forward(v, nc); if(__likely(ng->binding != UNBOUND)) ng->binding = relocate(ng->binding); return nc; } return v; } static void trace_globals(symbol_t *root) { while(root != nil){ if(root->binding != UNBOUND) root->binding = relocate(root->binding); trace_globals(root->left); root = root->right; } } void gc(int mustgrow) { void *temp; uint32_t i, f, top; fl_readstate_t *rs; FL(gccalls)++; FL(curheap) = FL(tospace); if(FL(grew)) FL(lim) = FL(curheap)+FL(heapsize)*2-sizeof(cons_t); else FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t); if(FL(throwing_frame) > FL(curr_frame)){ top = FL(throwing_frame) - 3; f = FL(stack)[FL(throwing_frame)-3]; }else{ top = FL(sp); f = FL(curr_frame); } while(1){ for(i = f; i < top; i++) FL(stack)[i] = relocate(FL(stack)[i]); if(f == 0) break; top = f - 3; f = FL(stack)[f-3]; } for(i = 0; i < FL(ngchandles); i++) *FL(gchandles)[i] = relocate(*FL(gchandles)[i]); trace_globals(FL(symtab)); relocate_typetable(); rs = FL(readstate); while(rs){ value_t ent; for(i = 0; i < rs->backrefs.size; i++){ ent = (value_t)rs->backrefs.table[i]; if(ent != (value_t)HT_NOTFOUND) rs->backrefs.table[i] = (void*)relocate(ent); } for(i = 0; i < rs->gensyms.size; i++){ ent = (value_t)rs->gensyms.table[i]; if(ent != (value_t)HT_NOTFOUND) rs->gensyms.table[i] = (void*)relocate(ent); } rs->source = relocate(rs->source); rs = rs->prev; } FL(lasterror) = relocate(FL(lasterror)); FL(memory_exception_value) = relocate(FL(memory_exception_value)); FL(the_empty_vector) = relocate(FL(the_empty_vector)); sweep_finalizers(); #if defined(VERBOSEGC) printf("GC: found %d/%d live conses\n", (FL(curheap)-FL(tospace))/sizeof(cons_t), FL(heapsize)/sizeof(cons_t)); #endif temp = FL(tospace); FL(tospace) = FL(fromspace); FL(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(FL(grew) || ((FL(lim)-FL(curheap)) < (int)(FL(heapsize)/5)) || mustgrow){ temp = MEM_REALLOC(FL(tospace), FL(heapsize)*2); if(__unlikely(temp == nil)) fl_raise(FL(memory_exception_value)); FL(tospace) = temp; if(FL(grew)){ FL(heapsize) *= 2; temp = bitvector_resize(FL(consflags), 0, FL(heapsize)/sizeof(cons_t), 1); if(__unlikely(temp == nil)) fl_raise(FL(memory_exception_value)); FL(consflags) = (uint32_t*)temp; } FL(grew) = !FL(grew); } if(__unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2)){ // all data was live; gc again and grow heap. // but also always leave at least 4 words available, so a closure // can be allocated without an extra check. gc(0); } } static void grow_stack(void) { size_t newsz = FL(nstack) * 2; value_t *ns = MEM_REALLOC(FL(stack), newsz*sizeof(value_t)); if(__unlikely(ns == nil)) lerrorf(FL(MemoryError), "stack overflow"); FL(stack) = ns; FL(nstack) = newsz; } // utils ---------------------------------------------------------------------- // apply function with n args on the stack static value_t _applyn(uint32_t n) { value_t f = FL(stack)[FL(sp)-n-1]; uint32_t saveSP = FL(sp); value_t v; if(iscbuiltin(f)) v = ((builtin_t*)ptr(f))[3](&FL(stack)[FL(sp)-n], n); else if(isfunction(f)) v = apply_cl(n); else if(__likely(isbuiltin(f))){ value_t tab = symbol_value(FL(builtins_table_sym)); if(__unlikely(ptr(tab) == nil)) unbound_error(tab); FL(stack)[FL(sp)-n-1] = vector_elt(tab, uintval(f)); v = apply_cl(n); }else{ type_error("function", f); } FL(sp) = saveSP; return v; } value_t fl_apply(value_t f, value_t l) { value_t v = l; uint32_t n = FL(sp); PUSH(f); while(iscons(v)){ if(FL(sp) >= FL(nstack)) grow_stack(); PUSH(car_(v)); v = cdr_(v); } n = FL(sp) - n - 1; v = _applyn(n); POPN(n+1); return v; } value_t fl_applyn(uint32_t n, value_t f, ...) { va_list ap; va_start(ap, f); size_t i; PUSH(f); while(FL(sp)+n >= FL(nstack)) grow_stack(); for(i = 0; i < n; i++){ value_t a = va_arg(ap, value_t); PUSH(a); } value_t v = _applyn(n); POPN(n+1); va_end(ap); return v; } value_t fl_listn(size_t n, ...) { va_list ap; va_start(ap, n); uint32_t si = FL(sp); size_t i; while(FL(sp)+n >= FL(nstack)) grow_stack(); for(i = 0; i < n; i++){ value_t a = va_arg(ap, value_t); PUSH(a); } cons_t *c = alloc_words(n*2); cons_t *l = c; for(i = 0; i < n; i++){ c->car = FL(stack)[si++]; c->cdr = tagptr(c+1, TAG_CONS); c++; } c[-1].cdr = FL(Nil); POPN(n); va_end(ap); return tagptr(l, TAG_CONS); } value_t fl_list2(value_t a, value_t b) { PUSH(a); PUSH(b); cons_t *c = alloc_words(4); b = POP(); a = POP(); c[0].car = a; c[0].cdr = tagptr(c+1, TAG_CONS); c[1].car = b; c[1].cdr = FL(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; } bool fl_isnumber(value_t v) { if(isfixnum(v)) return true; if(iscprim(v)){ cprim_t *c = ptr(v); return c->type != FL(runetype) && valid_numtype(c->type->numtype); } if(iscvalue(v)){ cvalue_t *c = ptr(v); return valid_numtype(cp_numtype(c)); } return false; } // eval ----------------------------------------------------------------------- static value_t list(value_t *args, uint32_t nargs, int star) { cons_t *c; uint32_t i; value_t v; v = cons_reserve(nargs); c = ptr(v); for(i = 0; i < nargs; i++){ c->car = args[i]; c->cdr = tagptr(c+1, TAG_CONS); c++; } if(star) c[-2].cdr = c[-1].car; else c[-1].cdr = FL(Nil); return v; } static value_t copy_list(value_t L) { if(!iscons(L)) return FL(Nil); PUSH(FL(Nil)); PUSH(L); value_t *plcons = &FL(stack)[FL(sp)-2]; value_t *pL = &FL(stack)[FL(sp)-1]; value_t c; c = mk_cons(); PUSH(c); // save first cons car_(c) = car_(*pL); cdr_(c) = FL(Nil); *plcons = c; *pL = cdr_(*pL); while(iscons(*pL)){ c = mk_cons(); car_(c) = car_(*pL); cdr_(c) = FL(Nil); cdr_(*plcons) = c; *plcons = c; *pL = cdr_(*pL); } c = POP(); // first cons POPN(2); return c; } static value_t do_trycatch(void) { uint32_t saveSP = FL(sp); value_t v = FL(Nil); value_t thunk = FL(stack)[FL(sp)-2]; FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = thunk; FL_TRY{ v = apply_cl(0); } FL_CATCH{ v = FL(stack)[saveSP-2]; PUSH(v); PUSH(FL(lasterror)); v = apply_cl(1); } FL(sp) = saveSP; return v; } /* argument layout on stack is |--required args--|--opt args--|--kw args--|--rest args... */ static uint32_t process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw, uint32_t nopt, uint32_t bp, uint32_t nargs, int va) { uint32_t extr = nopt+nkw; uint32_t ntot = nreq+extr; value_t args[64], v = FL(Nil); uint32_t i, a = 0, nrestargs; value_t s1 = FL(stack)[FL(sp)-1]; value_t s3 = FL(stack)[FL(sp)-3]; value_t s4 = FL(stack)[FL(sp)-4]; if(__unlikely(nargs < nreq)) lerrorf(FL(ArgError), "too few arguments"); if(__unlikely(extr > nelem(args))) lerrorf(FL(ArgError), "too many arguments"); for(i = 0; i < extr; i++) args[i] = UNBOUND; for(i = nreq; i < nargs; i++){ v = FL(stack)[bp+i]; if(issymbol(v) && iskeyword((symbol_t*)ptr(v))) break; if(a >= nopt) goto no_kw; args[a++] = v; } if(i >= nargs) goto no_kw; // now process keywords uintptr_t n = vector_size(kwtable)/2; do{ i++; if(__unlikely(i >= nargs)) lerrorf(FL(ArgError), "keyword %s requires an argument", symbol_name(v)); value_t hv = fixnum(((symbol_t*)ptr(v))->hash); fixnum_t lx = numval(hv); uintptr_t x = 2*((lx < 0 ? -lx : lx) % n); if(__likely(vector_elt(kwtable, x) == v)){ uintptr_t idx = numval(vector_elt(kwtable, x+1)); assert(idx < nkw); idx += nopt; if(args[idx] == UNBOUND){ // if duplicate key, keep first value args[idx] = FL(stack)[bp+i]; } }else{ lerrorf(FL(ArgError), "unsupported keyword %s", symbol_name(v)); } i++; if(i >= nargs) break; v = FL(stack)[bp+i]; }while(issymbol(v) && iskeyword((symbol_t*)ptr(v))); no_kw: nrestargs = nargs - i; if(__unlikely(!va && nrestargs > 0)) lerrorf(FL(ArgError), "too many arguments"); nargs = ntot + nrestargs; if(nrestargs) memmove(&FL(stack)[bp+ntot], &FL(stack)[bp+i], nrestargs*sizeof(value_t)); memmove(&FL(stack)[bp+nreq], args, extr*sizeof(value_t)); FL(sp) = bp + nargs; assert(FL(sp) < FL(nstack)-4); PUSH(s4); PUSH(s3); PUSH(nargs); PUSH(s1); FL(curr_frame) = FL(sp); return nargs; } #define GET_INT32(a) \ ((int32_t) \ ((((uint32_t)a[0])<<0) | \ (((uint32_t)a[1])<<8) | \ (((uint32_t)a[2])<<16) | \ (((uint32_t)a[3])<<24))) #define GET_INT16(a) \ ((int16_t) \ ((((int16_t)a[0])<<0) | \ (((int16_t)a[1])<<8))) #define PUT_INT32(a, i) \ do{ \ ((uint8_t*)(a))[0] = ((uint32_t)(i)>>0)&0xff; \ ((uint8_t*)(a))[1] = ((uint32_t)(i)>>8)&0xff; \ ((uint8_t*)(a))[2] = ((uint32_t)(i)>>16)&0xff; \ ((uint8_t*)(a))[3] = ((uint32_t)(i)>>24)&0xff; \ }while(0) /* stack on entry: <func> <nargs args...> caller's responsibility: - put the stack in this state - provide arg count - respect tail position - restore SP callee's responsibility: - check arg counts - allocate vararg array - push closed env, set up new environment */ static value_t apply_cl(uint32_t nargs) { uint32_t top_frame = FL(curr_frame); // frame variables uint32_t n, bp; const uint8_t *ip; fixnum_t s, hi; int tail, x; // temporary variables (not necessary to preserve across calls) size_t isz; uint32_t i, ipd; symbol_t *sym; cons_t *c; value_t *pv; value_t func, v, e; n = 0; v = 0; USED(n); USED(v); apply_cl_top: func = FL(stack)[FL(sp)-nargs-1]; ip = cvalue_data(fn_bcode(func)); assert(!ismanaged((uintptr_t)ip)); i = FL(sp)+GET_INT32(ip); while(i >= FL(nstack)) grow_stack(); ip += 4; bp = FL(sp)-nargs; PUSH(fn_env(func)); PUSH(FL(curr_frame)); PUSH(nargs); ipd = FL(sp); FL(sp)++; // ip FL(curr_frame) = FL(sp); #if defined(COMPUTED_GOTO) #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wpedantic" #define OP(x) op_##x: #define NEXT_OP goto *ops[*ip++] #define GOTO_OP_OFFSET(op) [op] = &&op_##op static const void *ops[] = { GOTO_OP_OFFSET(OP_LOADA0), GOTO_OP_OFFSET(OP_LOADA1), GOTO_OP_OFFSET(OP_LOADV), GOTO_OP_OFFSET(OP_BRF), GOTO_OP_OFFSET(OP_POP), GOTO_OP_OFFSET(OP_CALL), GOTO_OP_OFFSET(OP_TCALL), GOTO_OP_OFFSET(OP_LOADG), GOTO_OP_OFFSET(OP_LOADA), GOTO_OP_OFFSET(OP_LOADC), GOTO_OP_OFFSET(OP_RET), GOTO_OP_OFFSET(OP_DUP), GOTO_OP_OFFSET(OP_CAR), GOTO_OP_OFFSET(OP_CDR), GOTO_OP_OFFSET(OP_CLOSURE), GOTO_OP_OFFSET(OP_SETA), GOTO_OP_OFFSET(OP_JMP), GOTO_OP_OFFSET(OP_LOADC0), GOTO_OP_OFFSET(OP_PAIRP), GOTO_OP_OFFSET(OP_BRNE), GOTO_OP_OFFSET(OP_LOADT), GOTO_OP_OFFSET(OP_LOAD0), GOTO_OP_OFFSET(OP_LOADC1), GOTO_OP_OFFSET(OP_AREF), GOTO_OP_OFFSET(OP_ATOMP), GOTO_OP_OFFSET(OP_BRT), GOTO_OP_OFFSET(OP_BRNN), GOTO_OP_OFFSET(OP_LOAD1), GOTO_OP_OFFSET(OP_LT), GOTO_OP_OFFSET(OP_ADD2), GOTO_OP_OFFSET(OP_SETCDR), GOTO_OP_OFFSET(OP_LOADF), GOTO_OP_OFFSET(OP_CONS), GOTO_OP_OFFSET(OP_EQ), GOTO_OP_OFFSET(OP_SYMBOLP), GOTO_OP_OFFSET(OP_NOT), GOTO_OP_OFFSET(OP_CADR), GOTO_OP_OFFSET(OP_NEG), GOTO_OP_OFFSET(OP_NULLP), GOTO_OP_OFFSET(OP_BOOLEANP), GOTO_OP_OFFSET(OP_NUMBERP), GOTO_OP_OFFSET(OP_FIXNUMP), GOTO_OP_OFFSET(OP_BOUNDP), GOTO_OP_OFFSET(OP_BUILTINP), GOTO_OP_OFFSET(OP_FUNCTIONP), GOTO_OP_OFFSET(OP_VECTORP), GOTO_OP_OFFSET(OP_SETCAR), GOTO_OP_OFFSET(OP_JMPL), GOTO_OP_OFFSET(OP_BRFL), GOTO_OP_OFFSET(OP_BRTL), GOTO_OP_OFFSET(OP_EQV), GOTO_OP_OFFSET(OP_EQUAL), GOTO_OP_OFFSET(OP_LIST), GOTO_OP_OFFSET(OP_APPLY), GOTO_OP_OFFSET(OP_ADD), GOTO_OP_OFFSET(OP_SUB), GOTO_OP_OFFSET(OP_MUL), GOTO_OP_OFFSET(OP_DIV), GOTO_OP_OFFSET(OP_IDIV), GOTO_OP_OFFSET(OP_NUMEQ), GOTO_OP_OFFSET(OP_COMPARE), GOTO_OP_OFFSET(OP_ARGC), GOTO_OP_OFFSET(OP_VECTOR), GOTO_OP_OFFSET(OP_ASET), GOTO_OP_OFFSET(OP_LOADNIL), GOTO_OP_OFFSET(OP_LOADI8), GOTO_OP_OFFSET(OP_LOADVL), GOTO_OP_OFFSET(OP_LOADGL), GOTO_OP_OFFSET(OP_LOADAL), GOTO_OP_OFFSET(OP_LOADCL), GOTO_OP_OFFSET(OP_SETG), GOTO_OP_OFFSET(OP_SETGL), GOTO_OP_OFFSET(OP_SETAL), GOTO_OP_OFFSET(OP_VARGC), GOTO_OP_OFFSET(OP_TRYCATCH), GOTO_OP_OFFSET(OP_FOR), GOTO_OP_OFFSET(OP_TAPPLY), GOTO_OP_OFFSET(OP_SUB2), GOTO_OP_OFFSET(OP_LARGC), GOTO_OP_OFFSET(OP_LVARGC), GOTO_OP_OFFSET(OP_CALLL), GOTO_OP_OFFSET(OP_TCALLL), GOTO_OP_OFFSET(OP_BRNEL), GOTO_OP_OFFSET(OP_BRNNL), GOTO_OP_OFFSET(OP_BRN), GOTO_OP_OFFSET(OP_BRNL), GOTO_OP_OFFSET(OP_OPTARGS), GOTO_OP_OFFSET(OP_BRBOUND), GOTO_OP_OFFSET(OP_KEYARGS), GOTO_OP_OFFSET(OP_BOX), GOTO_OP_OFFSET(OP_BOXL), GOTO_OP_OFFSET(OP_SHIFT), }; NEXT_OP; #else #define OP(x) case x: #define NEXT_OP break uint8_t op = *ip++; while(1){ switch(op){ #endif OP(OP_LOADA0) PUSH(FL(stack)[bp]); NEXT_OP; OP(OP_LOADA1) PUSH(FL(stack)[bp+1]); NEXT_OP; OP(OP_LOADV) v = fn_vals(FL(stack)[bp-1]); assert(*ip < vector_size(v)); PUSH(vector_elt(v, *ip++)); NEXT_OP; OP(OP_BRF) ip += POP() != FL(f) ? 2 : GET_INT16(ip); NEXT_OP; OP(OP_POP) POPN(1); NEXT_OP; OP(OP_TCALLL) tail = 1; if(0){ OP(OP_CALLL) tail = 0; } n = GET_INT32(ip); ip += 4; if(0){ OP(OP_TCALL) tail = 1; if(0){ OP(OP_CALL) tail = 0; } n = *ip++; // nargs } do_call: FL(stack)[ipd] = (uintptr_t)ip; func = FL(stack)[FL(sp)-n-1]; if(tag(func) == TAG_FUNCTION){ if(func > (N_BUILTINS<<3)){ if(tail){ FL(curr_frame) = FL(stack)[FL(curr_frame)-3]; for(s = -1; s < (fixnum_t)n; s++) FL(stack)[bp+s] = FL(stack)[FL(sp)-n+s]; FL(sp) = bp+n; } nargs = n; goto apply_cl_top; }else{ i = uintval(func); if(isbuiltin(func)){ s = builtins[i].nargs; if(s >= 0) argcount(n, (unsigned)s); else if(s != ANYARGS && (signed)n < -s) argcount(n, (unsigned)-s); // remove function arg for(s = FL(sp)-n-1; s < (int)FL(sp)-1; s++) FL(stack)[s] = FL(stack)[s+1]; FL(sp)--; switch(i){ case OP_LIST: goto apply_list; case OP_VECTOR: goto apply_vector; case OP_APPLY: goto apply_apply; case OP_ADD: goto apply_add; case OP_SUB: goto apply_sub; case OP_MUL: goto apply_mul; case OP_DIV: goto apply_div; default: #if defined(COMPUTED_GOTO) goto *ops[i]; #else op = i; continue; #endif } } } }else if(__likely(iscbuiltin(func))){ s = FL(sp); v = (((builtin_t*)ptr(func))[3])(&FL(stack)[FL(sp)-n], n); FL(sp) = s-n; FL(stack)[FL(sp)-1] = v; NEXT_OP; } type_error("function", func); OP(OP_LOADGL) v = fn_vals(FL(stack)[bp-1]); v = vector_elt(v, GET_INT32(ip)); ip += 4; if(0){ OP(OP_LOADG) v = fn_vals(FL(stack)[bp-1]); assert(*ip < vector_size(v)); v = vector_elt(v, *ip); ip++; } assert(issymbol(v)); sym = (symbol_t*)ptr(v); if(__unlikely(sym->binding == UNBOUND)){ FL(stack)[ipd] = (uintptr_t)ip; unbound_error(v); } PUSH(sym->binding); NEXT_OP; OP(OP_LOADA) i = *ip++; v = FL(stack)[bp+i]; PUSH(v); NEXT_OP; OP(OP_LOADC) i = *ip++; v = FL(stack)[bp+nargs]; assert(isvector(v)); assert(i < vector_size(v)); PUSH(vector_elt(v, i)); NEXT_OP; OP(OP_BOX) i = *ip++; v = mk_cons(); car_(v) = FL(stack)[bp+i]; cdr_(v) = FL(Nil); FL(stack)[bp+i] = v; NEXT_OP; OP(OP_BOXL) i = GET_INT32(ip); ip += 4; v = mk_cons(); car_(v) = FL(stack)[bp+i]; cdr_(v) = FL(Nil); FL(stack)[bp+i] = v; NEXT_OP; OP(OP_SHIFT) i = *ip++; FL(stack)[FL(sp)-1-i] = FL(stack)[FL(sp)-1]; FL(sp) -= i; NEXT_OP; OP(OP_RET) v = POP(); FL(sp) = FL(curr_frame); FL(curr_frame) = FL(stack)[FL(sp)-3]; if(FL(curr_frame) == top_frame) return v; FL(sp) -= 4+nargs; ipd = FL(curr_frame)-1; ip = (uint8_t*)FL(stack)[ipd]; nargs = FL(stack)[FL(curr_frame)-2]; bp = FL(curr_frame) - 4 - nargs; FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_DUP) FL(stack)[FL(sp)] = FL(stack)[FL(sp)-1]; FL(sp)++; NEXT_OP; OP(OP_CAR) v = FL(stack)[FL(sp)-1]; if(__likely(iscons(v))) v = car_(v); else if(__unlikely(v != FL(Nil))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_CDR) v = FL(stack)[FL(sp)-1]; if(__likely(iscons(v))) v = cdr_(v); else if(__unlikely(v != FL(Nil))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_CLOSURE) n = *ip++; assert(n > 0); pv = alloc_words(n + 1); v = tagptr(pv, TAG_VECTOR); i = 0; pv[i++] = fixnum(n); do{ pv[i] = FL(stack)[FL(sp)-n + i-1]; i++; }while(i <= n); POPN(n); PUSH(v); if(__unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2)) gc(0); pv = (value_t*)FL(curheap); FL(curheap) += 4*sizeof(value_t); e = FL(stack)[FL(sp)-2]; // closure to copy assert(isfunction(e)); pv[0] = ((value_t*)ptr(e))[0]; pv[1] = ((value_t*)ptr(e))[1]; pv[2] = FL(stack)[FL(sp)-1]; // env pv[3] = ((value_t*)ptr(e))[3]; POPN(1); FL(stack)[FL(sp)-1] = tagptr(pv, TAG_FUNCTION); NEXT_OP; OP(OP_SETA) assert(nargs > 0); v = FL(stack)[FL(sp)-1]; i = *ip++; FL(stack)[bp+i] = v; NEXT_OP; OP(OP_JMP) ip += GET_INT16(ip); NEXT_OP; OP(OP_LOADC0) PUSH(vector_elt(FL(stack)[bp+nargs], 0)); NEXT_OP; OP(OP_PAIRP) FL(stack)[FL(sp)-1] = iscons(FL(stack)[FL(sp)-1]) ? FL(t) : FL(f); NEXT_OP; OP(OP_BRNE) ip += FL(stack)[FL(sp)-2] != FL(stack)[FL(sp)-1] ? GET_INT16(ip) : 2; POPN(2); NEXT_OP; OP(OP_LOADT) PUSH(FL(t)); NEXT_OP; OP(OP_LOAD0) PUSH(fixnum(0)); NEXT_OP; OP(OP_LOADC1) PUSH(vector_elt(FL(stack)[bp+nargs], 1)); NEXT_OP; OP(OP_AREF) FL(stack)[ipd] = (uintptr_t)ip; v = FL(stack)[FL(sp)-2]; if(isvector(v)){ e = FL(stack)[FL(sp)-1]; isz = tosize(e); if(__unlikely(isz >= vector_size(v))) bounds_error(v, e); v = vector_elt(v, isz); }else if(__likely(isarray(v))){ v = cvalue_array_aref(&FL(stack)[FL(sp)-2]); }else{ type_error("sequence", v); } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_ATOMP) FL(stack)[FL(sp)-1] = iscons(FL(stack)[FL(sp)-1]) ? FL(f) : FL(t); NEXT_OP; OP(OP_BRT) ip += POP() != FL(f) ? GET_INT16(ip) : 2; NEXT_OP; OP(OP_BRNN) ip += POP() != FL(Nil) ? GET_INT16(ip) : 2; NEXT_OP; OP(OP_LOAD1) PUSH(fixnum(1)); NEXT_OP; OP(OP_LT) { value_t a = FL(stack)[FL(sp)-2], b = FL(stack)[FL(sp)-1]; POPN(1); if(bothfixnums(a, b)){ FL(stack)[FL(sp)-1] = (fixnum_t)a < (fixnum_t)b ? FL(t) : FL(f); }else{ x = numeric_compare(a, b, false, false, false); if(x > 1) x = numval(fl_compare(a, b)); FL(stack)[FL(sp)-1] = x < 0 ? FL(t) : FL(f); } } NEXT_OP; OP(OP_ADD2) do_add2: FL(stack)[ipd] = (uintptr_t)ip; if(0){ OP(OP_SUB2) do_sub2: FL(stack)[ipd] = (uintptr_t)ip; FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]); } { fixnum_t a, b, c; a = FL(stack)[FL(sp)-2]; b = FL(stack)[FL(sp)-1]; if(bothfixnums(a, b) && !sadd_overflow(numval(a), numval(b), &c) && fits_fixnum(c)){ v = fixnum(c); }else{ v = fl_add_any(&FL(stack)[FL(sp)-2], 2); } } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_SETCDR) v = FL(stack)[FL(sp)-2]; if(__unlikely(!iscons(v))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } cdr_(v) = FL(stack)[FL(sp)-1]; POPN(1); NEXT_OP; OP(OP_LOADF) PUSH(FL(f)); NEXT_OP; OP(OP_CONS) if(FL(curheap) > FL(lim)) gc(0); c = (cons_t*)FL(curheap); FL(curheap) += sizeof(cons_t); c->car = FL(stack)[FL(sp)-2]; c->cdr = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-2] = tagptr(c, TAG_CONS); POPN(1); NEXT_OP; OP(OP_EQ) FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1] ? FL(t) : FL(f); POPN(1); NEXT_OP; OP(OP_SYMBOLP) FL(stack)[FL(sp)-1] = issymbol(FL(stack)[FL(sp)-1]) ? FL(t) : FL(f); NEXT_OP; OP(OP_NOT) FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL(f) ? FL(t) : FL(f); NEXT_OP; OP(OP_CADR) v = FL(stack)[FL(sp)-1]; if(__likely(iscons(v))){ v = cdr_(v); if(__likely(iscons(v))) v = car_(v); else goto cadr_nil; }else{ cadr_nil: if(__unlikely(v != FL(Nil))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } } FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_NEG) do_neg: FL(stack)[ipd] = (uintptr_t)ip; FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]); NEXT_OP; OP(OP_NULLP) FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL(Nil) ? FL(t) : FL(f); NEXT_OP; OP(OP_BOOLEANP) v = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = (v == FL(t) || v == FL(f)) ? FL(t) : FL(f); NEXT_OP; OP(OP_NUMBERP) v = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = fl_isnumber(v) ? FL(t) : FL(f); NEXT_OP; OP(OP_FIXNUMP) FL(stack)[FL(sp)-1] = isfixnum(FL(stack)[FL(sp)-1]) ? FL(t) : FL(f); NEXT_OP; OP(OP_BOUNDP) FL(stack)[ipd] = (uintptr_t)ip; sym = tosymbol(FL(stack)[FL(sp)-1]); FL(stack)[FL(sp)-1] = sym->binding == UNBOUND ? FL(f) : FL(t); NEXT_OP; OP(OP_BUILTINP) v = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL(t) : FL(f); NEXT_OP; OP(OP_FUNCTIONP) v = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = ((tag(v) == TAG_FUNCTION && (isbuiltin(v) || v>(N_BUILTINS<<3))) || iscbuiltin(v)) ? FL(t) : FL(f); NEXT_OP; OP(OP_VECTORP) FL(stack)[FL(sp)-1] = isvector(FL(stack)[FL(sp)-1]) ? FL(t) : FL(f); NEXT_OP; OP(OP_JMPL) ip += GET_INT32(ip); NEXT_OP; OP(OP_BRFL) ip += POP() == FL(f) ? GET_INT32(ip) : 4; NEXT_OP; OP(OP_BRTL) ip += POP() != FL(f) ? GET_INT32(ip) : 4; NEXT_OP; OP(OP_BRNEL) ip += FL(stack)[FL(sp)-2] != FL(stack)[FL(sp)-1] ? GET_INT32(ip) : 4; POPN(2); NEXT_OP; OP(OP_BRNNL) ip += POP() != FL(Nil) ? GET_INT32(ip) : 4; NEXT_OP; OP(OP_BRN) ip += POP() == FL(Nil) ? GET_INT16(ip) : 2; NEXT_OP; OP(OP_BRNL) ip += POP() == FL(Nil) ? GET_INT32(ip) : 4; NEXT_OP; OP(OP_EQV) if(FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1]) v = FL(t); else if(!leafp(FL(stack)[FL(sp)-2]) || !leafp(FL(stack)[FL(sp)-1])) v = FL(f); else v = compare_(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], 1) == 0 ? FL(t) : FL(f); FL(stack)[FL(sp)-2] = v; POPN(1); NEXT_OP; OP(OP_EQUAL) if(FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1]) v = FL(t); else v = compare_(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], 1) == 0 ? FL(t) : FL(f); FL(stack)[FL(sp)-2] = v; POPN(1); NEXT_OP; OP(OP_SETCAR) v = FL(stack)[FL(sp)-2]; if(__unlikely(!iscons(v))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } car_(v) = FL(stack)[FL(sp)-1]; POPN(1); NEXT_OP; OP(OP_LIST) n = *ip++; apply_list: if(n > 0){ v = list(&FL(stack)[FL(sp)-n], n, 0); POPN(n); PUSH(v); }else{ PUSH(FL(Nil)); } NEXT_OP; OP(OP_TAPPLY) tail = 1; if(0){ OP(OP_APPLY) tail = 0; } n = *ip++; apply_apply: v = POP(); // arglist n = FL(sp)-(n-2); // n-2 == # leading arguments not in the list while(iscons(v)){ if(FL(sp) >= FL(nstack)) grow_stack(); PUSH(car_(v)); v = cdr_(v); } n = FL(sp)-n; goto do_call; OP(OP_ADD) n = *ip++; if(n == 2) goto do_add2; apply_add: FL(stack)[ipd] = (uintptr_t)ip; v = fl_add_any(&FL(stack)[FL(sp)-n], n); POPN(n); PUSH(v); NEXT_OP; OP(OP_SUB) n = *ip++; apply_sub: if(n == 2) goto do_sub2; if(n == 1) goto do_neg; FL(stack)[ipd] = (uintptr_t)ip; i = FL(sp)-n; // we need to pass the full arglist on to fl_add_any // so it can handle rest args properly PUSH(FL(stack)[i]); FL(stack)[i] = fixnum(0); FL(stack)[i+1] = fl_neg(fl_add_any(&FL(stack)[i], n)); FL(stack)[i] = POP(); v = fl_add_any(&FL(stack)[i], 2); POPN(n); PUSH(v); NEXT_OP; OP(OP_MUL) n = *ip++; apply_mul: FL(stack)[ipd] = (uintptr_t)ip; v = fl_mul_any(&FL(stack)[FL(sp)-n], n); POPN(n); PUSH(v); NEXT_OP; OP(OP_DIV) n = *ip++; apply_div: FL(stack)[ipd] = (uintptr_t)ip; i = FL(sp)-n; if(n == 1){ FL(stack)[FL(sp)-1] = fl_div2(fixnum(1), FL(stack)[i]); }else{ if(n > 2){ PUSH(FL(stack)[i]); FL(stack)[i] = fixnum(1); FL(stack)[i+1] = fl_mul_any(&FL(stack)[i], n); FL(stack)[i] = POP(); } v = fl_div2(FL(stack)[i], FL(stack)[i+1]); POPN(n); PUSH(v); } NEXT_OP; OP(OP_IDIV) FL(stack)[ipd] = (uintptr_t)ip; v = FL(stack)[FL(sp)-2]; e = FL(stack)[FL(sp)-1]; if(bothfixnums(v, e)){ if(e == 0) DivideByZeroError(); v = fixnum(numval(v) / numval(e)); }else{ v = fl_idiv2(v, e); } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_NUMEQ) v = FL(stack)[FL(sp)-2]; e = FL(stack)[FL(sp)-1]; if(bothfixnums(v, e)) v = v == e ? FL(t) : FL(f); else{ FL(stack)[ipd] = (uintptr_t)ip; v = numeric_compare(v, e, true, false, true) == 0 ? FL(t) : FL(f); } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_COMPARE) FL(stack)[FL(sp)-2] = compare_(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], 0); POPN(1); NEXT_OP; OP(OP_ARGC) n = *ip++; if(0){ OP(OP_LARGC) n = GET_INT32(ip); ip += 4; } FL(stack)[ipd] = (uintptr_t)ip; argcount(nargs, n); NEXT_OP; OP(OP_VECTOR) n = *ip++; apply_vector: v = alloc_vector(n, 0); if(n){ memcpy(&vector_elt(v, 0), &FL(stack)[FL(sp)-n], n*sizeof(value_t)); POPN(n); } PUSH(v); NEXT_OP; OP(OP_ASET) e = FL(stack)[FL(sp)-3]; FL(stack)[ipd] = (uintptr_t)ip; if(isvector(e)){ i = tofixnum(FL(stack)[FL(sp)-2]); if(__unlikely(i >= vector_size(e))) bounds_error(v, FL(stack)[FL(sp)-1]); vector_elt(e, i) = (v = FL(stack)[FL(sp)-1]); }else if(__likely(isarray(e))){ v = cvalue_array_aset(&FL(stack)[FL(sp)-3]); }else{ type_error("sequence", e); } POPN(2); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_FOR) FL(stack)[ipd] = (uintptr_t)ip; s = tofixnum(FL(stack)[FL(sp)-3]); hi = tofixnum(FL(stack)[FL(sp)-2]); v = FL(unspecified); FL(sp) += 2; n = FL(sp); for(; s <= hi; s++){ FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-3]; FL(stack)[FL(sp)-1] = fixnum(s); v = _applyn(1); FL(sp) = n; } POPN(4); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_LOADNIL) PUSH(FL(Nil)); NEXT_OP; OP(OP_LOADI8) s = (int8_t)*ip++; PUSH(fixnum(s)); NEXT_OP; OP(OP_LOADVL) v = fn_vals(FL(stack)[bp-1]); v = vector_elt(v, GET_INT32(ip)); ip += 4; PUSH(v); NEXT_OP; OP(OP_SETGL) v = fn_vals(FL(stack)[bp-1]); v = vector_elt(v, GET_INT32(ip)); ip += 4; if(0){ OP(OP_SETG) v = fn_vals(FL(stack)[bp-1]); assert(*ip < vector_size(v)); v = vector_elt(v, *ip); ip++; } assert(issymbol(v)); sym = (symbol_t*)ptr(v); v = FL(stack)[FL(sp)-1]; if(!isconstant(sym)) sym->binding = v; NEXT_OP; OP(OP_LOADAL) assert(nargs > 0); i = GET_INT32(ip); ip += 4; v = FL(stack)[bp+i]; PUSH(v); NEXT_OP; OP(OP_SETAL) assert(nargs > 0); v = FL(stack)[FL(sp)-1]; i = GET_INT32(ip); ip += 4; FL(stack)[bp+i] = v; NEXT_OP; OP(OP_LOADCL) i = GET_INT32(ip); ip += 4; v = FL(stack)[bp+nargs]; PUSH(vector_elt(v, i)); NEXT_OP; OP(OP_VARGC) i = *ip++; if(0){ OP(OP_LVARGC) i = GET_INT32(ip); ip += 4; } s = (fixnum_t)nargs - (fixnum_t)i; if(s > 0){ v = list(&FL(stack)[bp+i], s, 0); FL(stack)[bp+i] = v; if(s > 1){ FL(stack)[bp+i+1] = FL(stack)[bp+nargs+0]; FL(stack)[bp+i+2] = FL(stack)[bp+nargs+1]; FL(stack)[bp+i+3] = i+1; FL(stack)[bp+i+4] = 0; FL(sp) = bp+i+5; FL(curr_frame) = FL(sp); } }else if(__unlikely(s < 0)){ FL(stack)[ipd] = (uintptr_t)ip; lerrorf(FL(ArgError), "too few arguments"); }else{ FL(sp)++; FL(stack)[FL(sp)-2] = i+1; FL(stack)[FL(sp)-3] = FL(stack)[FL(sp)-4]; FL(stack)[FL(sp)-4] = FL(stack)[FL(sp)-5]; FL(stack)[FL(sp)-5] = FL(Nil); FL(curr_frame) = FL(sp); } ipd = FL(sp)-1; nargs = i+1; NEXT_OP; OP(OP_TRYCATCH) FL(stack)[ipd] = (uintptr_t)ip; v = do_trycatch(); POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_OPTARGS) i = GET_INT32(ip); ip += 4; n = GET_INT32(ip); ip += 4; if(__unlikely(nargs < i)){ FL(stack)[ipd] = (uintptr_t)ip; lerrorf(FL(ArgError), "too few arguments"); } if((int32_t)n > 0){ if(__unlikely(nargs > n)){ FL(stack)[ipd] = (uintptr_t)ip; lerrorf(FL(ArgError), "too many arguments"); } }else n = -n; if(__likely(n > nargs)){ n -= nargs; FL(sp) += n; FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-n-1]; FL(stack)[FL(sp)-2] = nargs+n; FL(stack)[FL(sp)-3] = FL(stack)[FL(sp)-n-3]; FL(stack)[FL(sp)-4] = FL(stack)[FL(sp)-n-4]; FL(curr_frame) = FL(sp); ipd = FL(sp)-1; for(i = 0; i < n; i++) FL(stack)[bp+nargs+i] = UNBOUND; nargs += n; } NEXT_OP; OP(OP_BRBOUND) i = GET_INT32(ip); ip += 4; v = FL(stack)[bp+i]; PUSH(v != UNBOUND ? FL(t) : FL(f)); NEXT_OP; OP(OP_KEYARGS) v = fn_vals(FL(stack)[bp-1]); v = vector_elt(v, 0); i = GET_INT32(ip); ip += 4; n = GET_INT32(ip); ip += 4; s = GET_INT32(ip); ip += 4; FL(stack)[ipd] = (uintptr_t)ip; nargs = process_keys(v, i, n, labs(s)-(i+n), bp, nargs, s<0); ipd = FL(sp)-1; NEXT_OP; #if defined(COMPUTED_GOTO) #pragma GCC diagnostic pop #else } op = *ip++; } #endif } #define SWAP_INT32(a) #define SWAP_INT16(a) #include "maxstack.inc" #if BYTE_ORDER == BIG_ENDIAN #undef SWAP_INT32 #undef SWAP_INT16 #define SWAP_INT32(a) \ do{ \ uint8_t *x = (void*)a, y; \ y = x[0]; x[0] = x[3]; x[3] = y; \ y = x[1]; x[1] = x[2]; x[2] = y; \ }while(0) #define SWAP_INT16(a) \ do{ \ uint8_t *x = (void*)a, y; \ y = x[0]; x[0] = x[1]; x[1] = y; \ }while(0) #define compute_maxstack compute_maxstack_swap #include "maxstack.inc" #undef compute_maxstack #else #endif // top = top frame pointer to start at static value_t _stacktrace(uint32_t top) { value_t lst = FL(Nil); fl_gc_handle(&lst); while(top > 0){ const uint8_t *ip1 = (void*)FL(stack)[top-1]; uint32_t sz = FL(stack)[top-2]+1; uint32_t bp = top-4-sz; value_t func = FL(stack)[bp]; const uint8_t *ip0 = cvalue_data(fn_bcode(func)); intptr_t ip = ip1 - ip0 - 1; /* -1: ip1 is *after* the one that was being executed */ value_t v = alloc_vector(sz+1, 0); vector_elt(v, 0) = fixnum(ip); vector_elt(v, 1) = func; for(uint32_t i = 1; i < sz; i++){ value_t si = FL(stack)[bp+i]; // if there's an error evaluating argument defaults some slots // might be left set to UNBOUND (issue #22) vector_elt(v, i+1) = si == UNBOUND ? FL(unspecified) : si; } lst = fl_cons(v, lst); top = FL(stack)[top-3]; } fl_free_gc_handles(1); return lst; } // builtins ------------------------------------------------------------------- BUILTIN("gc", gc) { USED(args); argcount(nargs, 0); gc(0); return FL(t); } BUILTIN("function", function) { if(nargs == 1 && issymbol(args[0])) return fn_builtin_builtin(args, nargs); if(nargs < 2 || nargs > 4) argcount(nargs, 2); if(__unlikely(!fl_isstring(args[0]))) type_error("string", args[0]); if(__unlikely(!isvector(args[1]))) type_error("vector", args[1]); cvalue_t *arr = (cvalue_t*)ptr(args[0]); cv_pin(arr); char *data = cv_data(arr); uint32_t ms; if((uint8_t)data[4] >= N_OPCODES){ // read syntax, shifted 48 for compact text representation size_t i, sz = cv_len(arr); for(i = 0; i < sz; i++) data[i] -= 48; #if BYTE_ORDER == BIG_ENDIAN ms = compute_maxstack((uint8_t*)data, cv_len(arr)); }else{ ms = compute_maxstack_swap((uint8_t*)data, cv_len(arr)); } #else } ms = compute_maxstack((uint8_t*)data, cv_len(arr)); #endif PUT_INT32(data, ms); function_t *fn = alloc_words(4); value_t fv = tagptr(fn, TAG_FUNCTION); fn->bcode = args[0]; fn->vals = args[1]; fn->env = FL(Nil); fn->name = FL(lambda); if(nargs > 2){ if(issymbol(args[2])){ fn->name = args[2]; if(nargs > 3) fn->env = args[3]; }else{ fn->env = args[2]; if(nargs > 3){ if(__unlikely(!issymbol(args[3]))) type_error("symbol", args[3]); fn->name = args[3]; } } if(__unlikely(isgensym(fn->name))) lerrorf(FL(ArgError), "name should not be a gensym"); } return fv; } BUILTIN("function:code", function_code) { argcount(nargs, 1); value_t v = args[0]; if(__unlikely(!isclosure(v))) type_error("function", v); return fn_bcode(v); } BUILTIN("function:vals", function_vals) { argcount(nargs, 1); value_t v = args[0]; if(__unlikely(!isclosure(v))) type_error("function", v); return fn_vals(v); } BUILTIN("function:env", function_env) { argcount(nargs, 1); value_t v = args[0]; if(__unlikely(!isclosure(v))) type_error("function", v); return fn_env(v); } BUILTIN("function:name", function_name) { argcount(nargs, 1); value_t v = args[0]; if(__unlikely(!isclosure(v))) type_error("function", v); return fn_name(v); } BUILTIN("copy-list", copy_list) { argcount(nargs, 1); return copy_list(args[0]); } BUILTIN("append", append) { value_t first = FL(Nil), lst, lastcons = FL(Nil); uint32_t i; if(nargs == 0) return FL(Nil); fl_gc_handle(&first); fl_gc_handle(&lastcons); for(i = 0; i < nargs; i++){ lst = args[i]; if(iscons(lst)){ lst = copy_list(lst); if(first == FL(Nil)) first = lst; else cdr_(lastcons) = lst; lastcons = tagptr((((cons_t*)FL(curheap))-1), TAG_CONS); }else if(lst != FL(Nil)){ type_error("cons", lst); } } fl_free_gc_handles(2); return first; } BUILTIN("list*", liststar) { if(nargs == 1) return args[0]; if(nargs == 0) argcount(nargs, 1); return list(args, nargs, 1); } BUILTIN("stacktrace", stacktrace) { USED(args); argcount(nargs, 0); return _stacktrace(FL(throwing_frame) ? FL(throwing_frame) : FL(curr_frame)); } BUILTIN("map", map) { if(__unlikely(nargs < 2)) lerrorf(FL(ArgError), "too few arguments"); if(!iscons(args[1])) return FL(Nil); value_t v; intptr_t first, last, argSP = args-FL(stack); assert(argSP >= 0 && argSP < FL(nstack)); if(nargs == 2){ if(FL(sp)+4 > FL(nstack)) grow_stack(); PUSH(FL(stack)[argSP]); PUSH(car_(FL(stack)[argSP+1])); v = _applyn(1); POPN(2); PUSH(v); v = mk_cons(); car_(v) = POP(); cdr_(v) = FL(Nil); PUSH(v); PUSH(v); first = FL(sp)-2; last = FL(sp)-1; FL(stack)[argSP+1] = cdr_(FL(stack)[argSP+1]); while(iscons(FL(stack)[argSP+1])){ PUSH(FL(stack)[argSP]); PUSH(car_(FL(stack)[argSP+1])); v = _applyn(1); POPN(2); PUSH(v); v = mk_cons(); car_(v) = POP(); cdr_(v) = FL(Nil); cdr_(FL(stack)[last]) = v; FL(stack)[last] = v; FL(stack)[argSP+1] = cdr_(FL(stack)[argSP+1]); } POPN(2); }else{ size_t i; while(FL(sp)+nargs+1 > FL(nstack)) grow_stack(); PUSH(FL(stack)[argSP]); for(i = 1; i < nargs; i++){ PUSH(car(FL(stack)[argSP+i])); FL(stack)[argSP+i] = cdr_(FL(stack)[argSP+i]); } v = _applyn(nargs-1); POPN(nargs); PUSH(v); v = mk_cons(); car_(v) = POP(); cdr_(v) = FL(Nil); PUSH(v); PUSH(v); first = FL(sp)-2; last = FL(sp)-1; while(iscons(FL(stack)[argSP+1])){ PUSH(FL(stack)[argSP]); for(i = 1; i < nargs; i++){ PUSH(car(FL(stack)[argSP+i])); FL(stack)[argSP+i] = cdr_(FL(stack)[argSP+i]); } v = _applyn(nargs-1); POPN(nargs); PUSH(v); v = mk_cons(); car_(v) = POP(); cdr_(v) = FL(Nil); cdr_(FL(stack)[last]) = v; FL(stack)[last] = v; } POPN(2); } return FL(stack)[first]; } BUILTIN("for-each", for_each) { argcount(nargs, 2); intptr_t argSP = args-FL(stack); assert(argSP >= 0 && argSP < FL(nstack)); if(FL(sp)+2 > FL(nstack)) grow_stack(); PUSH(FL(t)); PUSH(FL(t)); while(iscons(FL(stack)[argSP+1])){ FL(stack)[FL(sp)-2] = FL(stack)[argSP]; FL(stack)[FL(sp)-1] = car_(FL(stack)[argSP+1]); _applyn(1); FL(stack)[argSP+1] = cdr_(FL(stack)[argSP+1]); } POPN(2); return FL(t); } BUILTIN("sleep", fl_sleep) { if(nargs > 1) argcount(nargs, 1); double s = nargs > 0 ? todouble(args[0]) : 0; sleep_ms(s * 1000.0); return FL(t); } BUILTIN("*vm-stats*", vm_stats) { USED(args); argcount(nargs, 0); ios_printf(ios_stderr, "heap total %10"PRIu32"\n", FL(heapsize)); ios_printf(ios_stderr, "heap free %10"PRIu32"\n", (uint32_t)(FL(lim)-FL(curheap))); ios_printf(ios_stderr, "heap used %10"PRIu32"\n", (uint32_t)(FL(curheap)-FL(fromspace))); ios_printf(ios_stderr, "stack %10"PRIu32"\n", FL(nstack)*sizeof(value_t)); ios_printf(ios_stderr, "gc calls %10"PRIu64"\n", (uint64_t)FL(gccalls)); ios_printf(ios_stderr, "max finalizers %10"PRIu32"\n", (uint32_t)FL(maxfinalizers)); ios_printf(ios_stderr, "opcodes %10d\n", N_OPCODES); return FL(t); } static const builtinspec_t builtin_fns[] = { #define BUILTIN_FN(l, c){l, fn_builtin_##c}, #include "builtin_fns.h" #undef BUILTIN_FN }; // initialization ------------------------------------------------------------- void fl_init(size_t initial_heapsize) { int i; fl = calloc(1, sizeof(*fl)); FL(scr_width) = 80; FL(heapsize) = initial_heapsize; FL(fromspace) = MEM_ALLOC(FL(heapsize)); FL(tospace) = MEM_ALLOC(FL(heapsize)); FL(curheap) = FL(fromspace); FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t); FL(consflags) = bitvector_new(FL(heapsize)/sizeof(cons_t), 1); htable_new(&FL(printconses), 32); comparehash_init(); FL(nstack) = 4096; FL(stack) = MEM_ALLOC(FL(nstack)*sizeof(value_t)); FL(Nil) = builtin(OP_THE_EMPTY_LIST); FL(t) = builtin(OP_BOOL_CONST_T); FL(f) = builtin(OP_BOOL_CONST_F); FL(eof) = builtin(OP_EOF_OBJECT); FL(lambda) = symbol("λ", false); FL(function) = symbol("function", false); FL(quote) = symbol("quote", false); FL(trycatch) = symbol("trycatch", false); FL(backquote) = symbol("quasiquote", false); FL(comma) = symbol("unquote", false); FL(commaat) = symbol("unquote-splicing", false); FL(commadot) = symbol("unquote-nsplicing", false); FL(IOError) = symbol("io-error", false); FL(ParseError) = symbol("parse-error", false); FL(TypeError) = symbol("type-error", false); FL(ArgError) = symbol("arg-error", false); FL(UnboundError) = symbol("unbound-error", false); FL(KeyError) = symbol("key-error", false); FL(MemoryError) = symbol("memory-error", false); FL(BoundsError) = symbol("bounds-error", false); FL(DivideError) = symbol("divide-error", false); FL(EnumerationError) = symbol("enumeration-error", false); FL(Error) = symbol("error", false); FL(pairsym) = symbol("pair", false); FL(symbolsym) = symbol("symbol", false); FL(fixnumsym) = symbol("fixnum", false); FL(vectorsym) = symbol("vector", false); FL(builtinsym) = symbol("builtin", false); FL(booleansym) = symbol("boolean", false); FL(nullsym) = symbol("null", false); FL(definesym) = symbol("define", false); FL(defmacrosym) = symbol("define-macro", false); FL(forsym) = symbol("for", false); FL(setqsym) = symbol("set!", false); FL(evalsym) = symbol("eval", false); FL(vu8sym) = symbol("vu8", false); FL(fnsym) = symbol("fn", false); FL(nulsym) = symbol("nul", false); FL(alarmsym) = symbol("alarm", false); FL(backspacesym) = symbol("backspace", false); FL(tabsym) = symbol("tab", false); FL(linefeedsym) = symbol("linefeed", false); FL(vtabsym) = symbol("vtab", false); FL(pagesym) = symbol("page", false); FL(returnsym) = symbol("return", false); FL(escsym) = symbol("esc", false); FL(spacesym) = symbol("space", false); FL(deletesym) = symbol("delete", false); FL(newlinesym) = symbol("newline", false); FL(tsym) = symbol("t", false); FL(Tsym) = symbol("T", false); FL(fsym) = symbol("f", false); FL(Fsym) = symbol("F", false); FL(builtins_table_sym) = symbol("*builtins*", false); set(FL(printprettysym) = symbol("*print-pretty*", false), FL(t)); set(FL(printreadablysym) = symbol("*print-readably*", false), FL(t)); set(FL(printwidthsym) = symbol("*print-width*", false), fixnum(FL(scr_width))); set(FL(printlengthsym) = symbol("*print-length*", false), FL(f)); set(FL(printlevelsym) = symbol("*print-level*", false), FL(f)); FL(lasterror) = FL(Nil); for(i = 0; i < nelem(builtins); i++){ if(builtins[i].name) set(symbol(builtins[i].name, false), builtin(i)); } set(symbol("eq", false), builtin(OP_EQ)); set(symbol("procedure?", false), builtin(OP_FUNCTIONP)); set(symbol("top-level-bound?", false), builtin(OP_BOUNDP)); FL(the_empty_vector) = tagptr(alloc_words(1), TAG_VECTOR); vector_setsize(FL(the_empty_vector), 0); cvalues_init(); set(symbol("*os-name*", false), cvalue_static_cstring(__os_name__)); FL(memory_exception_value) = fl_list2(FL(MemoryError), cvalue_static_cstring("out of memory")); const builtinspec_t *b; for(i = 0, b = builtin_fns; i < nelem(builtin_fns); i++, b++) set(symbol(b->name, false), cbuiltin(b->name, b->fptr)); table_init(); iostream_init(); fsixel_init(); } // top level ------------------------------------------------------------------ value_t fl_toplevel_eval(value_t expr) { return fl_applyn(1, symbol_value(FL(evalsym)), expr); } int fl_load_system_image(value_t sys_image_iostream) { value_t e; uint32_t saveSP; symbol_t *sym; PUSH(sys_image_iostream); saveSP = FL(sp); FL_TRY{ while(1){ e = fl_read_sexpr(FL(stack)[FL(sp)-1]); if(ios_eof(value2c(ios_t*, FL(stack)[FL(sp)-1]))) break; if(isfunction(e)){ // stage 0 format: series of thunks PUSH(e); (void)_applyn(0); FL(sp) = saveSP; }else{ // stage 1 format: list alternating symbol/value while(iscons(e)){ sym = tosymbol(car_(e)); e = cdr_(e); (void)tocons(e); sym->binding = car_(e); e = cdr_(e); } break; } } } FL_CATCH_NO_INC{ ios_puts("fatal error during bootstrap:\n", ios_stderr); fl_print(ios_stderr, FL(lasterror)); ios_putc('\n', ios_stderr); return 1; } ios_close(value2c(ios_t*, FL(stack)[FL(sp)-1])); POPN(1); return 0; }