ref: 81fdc5ef972becd6c0f3b76f079c43f1fce8dc48
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);
uint32_t n, bp;
const uint8_t *ip;
fixnum_t s, hi;
bool tail;
// 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;
int x;
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_AREF2),
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 = true;
if(0){
OP(OP_CALLL)
tail = false;
}
n = GET_INT32(ip);
ip += 4;
if(0){
OP(OP_TCALL)
tail = true;
if(0){
OP(OP_CALL)
tail = false;
}
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;
case OP_AREF: goto apply_aref;
case OP_ASET: goto apply_aset;
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_AREF2)
n = 2;
if(0){
OP(OP_AREF)
FL(stack)[ipd] = (uintptr_t)ip;
n = 3 + *ip++;
}
apply_aref:
v = FL(stack)[FL(sp)-n];
for(i = n-1; i > 0; i--){
if(isvector(v)){
e = FL(stack)[FL(sp)-i];
isz = tosize(e);
if(__unlikely(isz >= vector_size(v)))
bounds_error(v, e);
v = vector_elt(v, isz);
}else if(__likely(isarray(v))){
FL(stack)[FL(sp)-i-1] = v;
v = cvalue_array_aref(&FL(stack)[FL(sp)-i-1]);
}else{
type_error("sequence", v);
}
}
POPN(n);
PUSH(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 = true;
if(0){
OP(OP_APPLY)
tail = false;
}
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)
FL(stack)[ipd] = (uintptr_t)ip;
v = FL(stack)[FL(sp)-3];
n = 3;
if(0){
apply_aset:
v = FL(stack)[FL(sp)-n];
for(i = n-1; i >= 3; i--){
if(isvector(v)){
e = FL(stack)[FL(sp)-i];
isz = tosize(e);
if(__unlikely(isz >= vector_size(v)))
bounds_error(v, e);
v = vector_elt(v, isz);
}else if(__likely(isarray(v))){
FL(stack)[FL(sp)-i-1] = v;
v = cvalue_array_aref(&FL(stack)[FL(sp)-i-1]);
}else{
type_error("sequence", v);
}
}
FL(stack)[FL(sp)-3] = v;
}
if(isvector(v)){
e = FL(stack)[FL(sp)-2];
isz = tosize(e);
if(__unlikely(isz >= vector_size(v)))
bounds_error(v, e);
vector_elt(v, isz) = (e = FL(stack)[FL(sp)-1]);
}else if(__likely(isarray(v))){
e = cvalue_array_aset(&FL(stack)[FL(sp)-3]);
}else{
type_error("sequence", v);
}
POPN(n);
PUSH(e);
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");
intptr_t argSP = args-FL(stack);
assert(argSP >= 0 && argSP < FL(nstack));
while(FL(sp)+2+1+nargs >= FL(nstack))
grow_stack();
uint32_t k = FL(sp);
PUSH(FL(Nil));
PUSH(FL(Nil));
for(bool first = true;;){
PUSH(FL(stack)[argSP]);
for(uint32_t i = 1; i < nargs; i++){
if(!iscons(FL(stack)[argSP+i])){
POPN(2+i);
return FL(stack)[k+1];
}
PUSH(car(FL(stack)[argSP+i]));
FL(stack)[argSP+i] = cdr_(FL(stack)[argSP+i]);
}
value_t v = _applyn(nargs-1);
POPN(nargs);
PUSH(v);
value_t c = mk_cons();
car_(c) = POP(); cdr_(c) = FL(Nil);
if(first)
FL(stack)[k+1] = c;
else
cdr_(FL(stack)[k]) = c;
FL(stack)[k] = c;
first = false;
}
}
BUILTIN("for-each", for_each)
{
if(__unlikely(nargs < 2))
lerrorf(FL(ArgError), "too few arguments");
intptr_t argSP = args-FL(stack);
assert(argSP >= 0 && argSP < FL(nstack));
if(FL(sp)+1+2*nargs >= FL(nstack))
grow_stack();
for(size_t n = 0;; n++){
PUSH(FL(stack)[argSP]);
uint32_t pargs = 0;
for(uint32_t i = 1; i < nargs; i++, pargs++){
value_t v = FL(stack)[argSP+i];
if(iscons(v)){
PUSH(car_(v));
FL(stack)[argSP+i] = cdr_(v);
continue;
}
if(isvector(v)){
size_t sz = vector_size(v);
if(n < sz){
PUSH(vector_elt(v, n));
continue;
}
}
if(isarray(v)){
size_t sz = cvalue_arraylen(v);
if(n < sz){
value_t a[2];
a[0] = v;
a[1] = fixnum(n);
PUSH(cvalue_array_aref(a));
continue;
}
}
if(ishashtable(v)){
htable_t *h = totable(v);
assert(n != 0 || h->i == 0);
void **table = h->table;
for(; h->i < h->size; h->i += 2){
if(table[h->i+1] != HT_NOTFOUND)
break;
}
if(h->i < h->size){
PUSH((value_t)table[h->i]);
pargs++;
PUSH((value_t)table[h->i+1]);
h->i += 2;
continue;
}
h->i = 0;
}
POPN(pargs+1);
return FL(t);
}
_applyn(pargs);
POPN(pargs+1);
}
}
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;
}