ref: 75fa6d220de69bdb91954ea8cf942611b25214cb
dir: /src/flisp.c/
/*
femtoLisp
by Jeff Bezanson (C) 2009
Distributed under the BSD License
*/
#include "flisp.h"
#include "operators.h"
#include "cvalues.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 "compress.h"
value_t FL_builtins_table_sym, FL_quote, FL_lambda, FL_function, FL_comma, FL_commaat;
value_t FL_commadot, FL_trycatch, FL_backquote;
value_t FL_conssym, FL_symbolsym, FL_fixnumsym, FL_vectorsym, FL_builtinsym, FL_vu8sym;
value_t FL_defsym, FL_defmacrosym, FL_forsym, FL_setqsym;
value_t FL_booleansym, FL_nullsym, FL_evalsym, FL_fnsym;
value_t FL_nulsym, FL_alarmsym, FL_backspacesym, FL_tabsym, FL_linefeedsym, FL_newlinesym;
value_t FL_vtabsym, FL_pagesym, FL_returnsym, FL_escsym, FL_spacesym, FL_deletesym;
value_t FL_IOError, FL_ParseError, FL_TypeError, FL_ArgError, FL_MemoryError;
value_t FL_DivideError, FL_BoundsError, FL_Error, FL_KeyError, FL_UnboundError;
value_t FL_printwidthsym, FL_printreadablysym, FL_printprettysym, FL_printlengthsym;
value_t FL_printlevelsym;
value_t FL_tablesym, FL_arraysym;
value_t FL_iostreamsym, FL_rdsym, FL_wrsym, FL_apsym, FL_crsym, FL_truncsym;
value_t FL_instrsym, FL_outstrsym;
value_t FL_int8sym, FL_uint8sym, FL_int16sym, FL_uint16sym, FL_int32sym, FL_uint32sym;
value_t FL_int64sym, FL_uint64sym, FL_bignumsym;
value_t FL_bytesym, FL_runesym, FL_floatsym, FL_doublesym;
value_t FL_stringtypesym, FL_runestringtypesym;
fl_thread(Fl *fl);
typedef struct {
const char *name;
builtin_t fptr;
}builtinspec_t;
bool
isbuiltin(value_t x)
{
int i;
return tag(x) == TAG_FUNCTION && (i = uintval(x)) < nelem(builtins) && builtins[i].name != nil;
}
static value_t apply_cl(int nargs) fl_hotfn;
// 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;
fl_gc(false);
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(!fl_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)
{
ios_flush(ios_stdout);
ios_flush(ios_stderr);
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;
fl_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));
}
_Noreturn void
arity_error(int nargs, int c)
{
lerrorf(FL_ArgError, "arity mismatch: wanted %"PRId32", got %"PRId32, c, nargs);
}
// safe cast operators --------------------------------------------------------
#define isstring fl_isstring
#define SAFECAST_OP(type, ctype, cnvt) \
ctype to##type(value_t v) \
{ \
if(fl_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 ---------------------------------------------------------------
static symbol_t *
mk_symbol(const char *str, int len, bool copy)
{
symbol_t *sym = MEM_ALLOC(sizeof(*sym) + (copy ? len+1 : 0));
sym->numtype = NONNUMERIC;
if(str[0] == ':' && str[1] != 0){
value_t s = tagptr(sym, TAG_SYM);
sym->flags = FLAG_KEYWORD;
setc(s, s);
}else{
sym->binding = UNBOUND;
sym->flags = 0;
}
sym->type = nil;
sym->hash = memhash(str, len)^0xAAAAAAAAAAAAAAAAULL;
if(copy){
memcpy((char*)(sym+1), str, len+1);
sym->name = (const char*)(sym+1);
}else{
sym->name = str;
}
sym->size = 0;
return sym;
}
value_t
symbol(const char *str, bool copy)
{
int len = strlen(str);
symbol_t *v;
const char *k;
if(!Tgetkv(FL(symtab), str, len, &k, (void**)&v)){
v = mk_symbol(str, len, copy);
FL(symtab) = Tsetl(FL(symtab), v->name, len, v);
}
return tagptr(v, TAG_SYM);
}
value_t
csymbol_(const char *str, int len)
{
symbol_t *v = mk_symbol(str, len, false);
FL(symtab) = Tsetl(FL(symtab), str, len, v);
return tagptr(v, 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);
}
fl_purefn
BUILTIN("gensym?", gensymp)
{
argcount(nargs, 1);
return isgensym(args[0]) ? FL_t : FL_nil;
}
char *
uint2str(char *dest, size_t len, uint64_t num, int 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 = 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(fl_unlikely(FL(curheap) > FL(lim)))
fl_gc(false);
c = (cons_t*)FL(curheap);
FL(curheap) += sizeof(cons_t);
return tagptr(c, TAG_CONS);
}
void *
alloc_words(int n)
{
value_t *first;
#if !defined(BITS64)
// force 8-byte alignment
if(n & 1)
n++;
#endif
if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)+2-n)){
fl_gc(false);
while(fl_unlikely((value_t*)FL(curheap) > ((value_t*)FL(lim))+2-n))
fl_gc(true);
}
first = (value_t*)FL(curheap);
FL(curheap) += n*sizeof(value_t);
return first;
}
value_t
alloc_vector(size_t n, bool 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){
for(size_t i = 0; i < n; i++)
vector_elt(v, i) = FL_void;
}
return v;
}
// collector ------------------------------------------------------------------
void
fl_gc_handle(value_t *pv)
{
if(fl_unlikely(FL(ngchandles) >= N_GC_HANDLES))
lerrorf(FL_MemoryError, "out of gc handles");
FL(gchandles)[FL(ngchandles)++] = pv;
}
void
fl_free_gc_handles(int 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{
a = car_(v);
if(isforwarded(v)){
*pcdr = forwardloc(v);
return first;
}
d = cdr_(v);
*pcdr = nc = tagptr((cons_t*)FL(curheap), TAG_CONS);
FL(curheap) += sizeof(cons_t);
forward(v, nc);
car_(nc) = ismanaged(a) ? relocate(a) : 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_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_FUNCTION){
function_t *fn = ptr(v);
function_t *nfn = alloc_words(sizeof(function_t)/sizeof(value_t));
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_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;
ng->type = gs->type;
nc = tagptr(ng, TAG_SYM);
forward(v, nc);
if(fl_likely(ng->binding != UNBOUND))
ng->binding = relocate(ng->binding);
return nc;
}
if(t == TAG_CPRIM){
cprim_t *pcp = ptr(v);
size_t nw = CPRIM_NWORDS+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;
}
return v;
}
static void
trace_globals(void)
{
const char *k = nil;
symbol_t *v;
while(Tnext(FL(symtab), &k, (void**)&v)){
if(v->binding != UNBOUND)
v->binding = relocate(v->binding);
}
}
void
fl_gc(bool mustgrow)
{
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);
value_t *top, *f;
if(FL(throwing_frame) > FL(curr_frame)){
top = FL(throwing_frame) - 3;
f = (value_t*)*top;
}else{
top = FL(sp);
f = FL(curr_frame);
}
for(;;){
for(value_t *p = f; p < top; p++)
*p = relocate(*p);
if(f == FL(stack))
break;
top = f - 3;
f = (value_t*)*top;
}
for(int i = 0; i < FL(ngchandles); i++)
*FL(gchandles)[i] = relocate(*FL(gchandles)[i]);
trace_globals();
relocate_typetable();
fl_readstate_t *rs = FL(readstate);
while(rs){
value_t ent;
for(int 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(int 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));
FL(the_empty_string) = relocate(FL(the_empty_string));
sweep_finalizers();
void *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) || ((intptr_t)(FL(lim)-FL(curheap)) < (intptr_t)FL(heapsize)/5) || mustgrow){
temp = MEM_REALLOC(FL(tospace), FL(heapsize)*2);
if(fl_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(fl_unlikely(temp == nil))
fl_raise(FL(memory_exception_value));
FL(consflags) = (uint32_t*)temp;
}
FL(grew) = !FL(grew);
}
if(fl_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.
fl_gc(false);
}
}
// utils ----------------------------------------------------------------------
// apply function with n args on the stack
fl_hotfn
static value_t
_applyn(int n)
{
value_t f = FL(sp)[-n-1];
value_t *saveSP = FL(sp);
value_t v;
if(iscbuiltin(f))
v = ((cvalue_t*)ptr(f))->cbuiltin(saveSP-n, n);
else if(isfunction(f))
v = apply_cl(n);
else if(fl_likely(isbuiltin(f))){
value_t tab = symbol_value(FL_builtins_table_sym);
if(fl_unlikely(ptr(tab) == nil))
unbound_error(tab);
saveSP[-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 v)
{
value_t *saveSP = FL(sp);
PUSH(f);
int n;
for(n = 0; iscons(v); n++){
PUSH(car_(v));
v = cdr_(v);
}
if(v != FL_nil)
lerrorf(FL_ArgError, "apply: last argument: not a list");
v = _applyn(n);
FL(sp) = saveSP;
return v;
}
value_t
fl_applyn(int n, value_t f, ...)
{
va_list ap;
va_start(ap, f);
PUSH(f);
for(int 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(int n, ...)
{
va_list ap;
va_start(ap, n);
value_t *si = FL(sp);
for(int 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(int i = 0; i < n; i++){
c->car = *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) || ismpint(v))
return true;
if(iscprim(v)){
cprim_t *c = ptr(v);
return c->type != FL(runetype) && valid_numtype(c->type->numtype);
}
return false;
}
// eval -----------------------------------------------------------------------
fl_hotfn
static value_t
list(value_t *args, int nargs, int star)
{
value_t v = cons_reserve(nargs);
cons_t *c = ptr(v);
for(int 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(sp)-2;
value_t *pL = 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)
{
value_t *saveSP = FL(sp);
value_t v = FL_nil;
value_t thunk = FL(sp)[-2];
FL(sp)[-2] = FL(sp)[-1];
FL(sp)[-1] = thunk;
FL_TRY{
v = apply_cl(0);
}
FL_CATCH{
v = 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 int
process_keys(value_t kwtable, int nreq, int nkw, int nopt, value_t *bp, int nargs, int va)
{
int extr = nopt+nkw;
int ntot = nreq+extr;
value_t args[64], v = FL_nil;
int i, a = 0, nrestargs;
value_t s1 = FL(sp)[-1];
value_t s3 = FL(sp)[-3];
value_t s4 = FL(sp)[-4];
if(fl_unlikely(nargs < nreq))
lerrorf(FL_ArgError, "too few arguments");
if(fl_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 = 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(fl_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(fl_likely(vector_elt(kwtable, x) == v)){
intptr_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] = bp[i];
}
}else{
lerrorf(FL_ArgError, "unsupported keyword %s", symbol_name(v));
}
i++;
if(i >= nargs)
break;
v = bp[i];
}while(issymbol(v) && iskeyword((symbol_t*)ptr(v)));
no_kw:
nrestargs = nargs - i;
if(fl_unlikely(!va && nrestargs > 0))
lerrorf(FL_ArgError, "too many arguments");
nargs = ntot + nrestargs;
if(nrestargs)
memmove(bp+ntot, bp+i, nrestargs*sizeof(value_t));
memmove(bp+nreq, args, extr*sizeof(value_t));
FL(sp) = bp + nargs;
assert(FL(sp)-FL(stack) < FL(nstack)-4);
PUSH(s4);
PUSH(s3);
PUSH(nargs);
PUSH(s1);
FL(curr_frame) = FL(sp);
return nargs;
}
#if BYTE_ORDER == LITTLE_ENDIAN && defined(MEM_UNALIGNED_ACCESS)
#define GET_INT32(a) *(const int32_t*)(a)
#define GET_INT16(a) *(const int16_t*)(a)
#else
#define GET_INT32(a) (int32_t)((a)[0]<<0 | (a)[1]<<8 | (a)[2]<<16 | (uint32_t)(a)[3]<<24)
#define GET_INT16(a) (int16_t)((a)[0]<<0 | (a)[1]<<8)
#endif
/*
stack on entry: <func> <nargs args...>
caller's responsibility:
- put the stack in this state
- provide arg count
- respect tail position
- restore SP
callee's responsibility:
- check arg counts
- allocate vararg array
- push closed env, set up new environment
*/
static value_t
apply_cl(int nargs)
{
value_t *top_frame = FL(curr_frame);
register value_t *sp = FL(sp);
bool tail;
int n;
apply_cl_top:;
value_t *bp = sp-nargs;
function_t *fn = (function_t*)ptr(bp[-1]);
const uint8_t *ip = cvalue_data(fn->bcode);
assert(!ismanaged((uintptr_t)ip));
*sp++ = fn->env;
*sp++ = (value_t)FL(curr_frame);
*sp++ = nargs;
value_t *ipd = sp++;
FL(curr_frame) = sp;
#if defined(COMPUTED_GOTO)
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wpedantic"
static const void * const ops[] = {
#define GOTO_OP_OFFSET(op) [op] = &&op_##op
#include "vm_goto.inc"
#undef GOTO_OP_OFFSET
};
#define NEXT_OP goto *ops[*ip++]
#define LABEL(x) x
#define OP(x) op_##x:
NEXT_OP;
#include "vm.inc"
#undef OP
#undef LABEL
#undef NEXT_OP
#pragma GCC diagnostic pop
#else /* just a usual (portable) switch/case */
uint8_t op = *ip++;
while(1){
switch(op){
#define NEXT_OP break
#define LABEL(x) x
#define OP(x) case x:
#include "vm.inc"
#undef OP
#undef LABEL
#undef NEXT_OP
}
op = *ip++;
}
#endif
}
// top = top frame pointer to start at
static value_t
_stacktrace(value_t *top)
{
value_t lst = FL_nil;
value_t *stack = FL(stack);
fl_gc_handle(&lst);
while(top > stack){
const uint8_t *ip1 = (void*)top[-1];
int sz = top[-2]+1;
value_t *bp = top-4-sz;
value_t func = bp[0];
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(int i = 1; i < sz; i++){
value_t si = bp[i];
// if there's an error evaluating argument defaults some slots
// might be left set to UNBOUND
vector_elt(v, i+1) = si == UNBOUND ? FL_void : si;
}
lst = fl_cons(v, lst);
top = (value_t*)top[-3];
}
fl_free_gc_handles(1);
return lst;
}
// builtins -------------------------------------------------------------------
BUILTIN("gc", gc)
{
USED(args);
argcount(nargs, 0);
fl_gc(false);
return FL_void;
}
BUILTIN("function", function)
{
if(nargs == 1 && issymbol(args[0]))
return fn_builtin_builtin(args, nargs);
if(nargs < 2 || nargs > 4)
argcount(nargs, 2);
if(fl_unlikely(!fl_isstring(args[0])))
type_error("string", args[0]);
if(fl_unlikely(!isvector(args[1])))
type_error("vector", args[1]);
cvalue_t *arr = ptr(args[0]);
cv_pin(arr);
uint8_t *data = cv_data(arr);
if(FL(loading)){
// read syntax, shifted 48 for compact text representation
size_t i, sz = cv_len(arr);
for(i = 0; i < sz; i++)
data[i] -= 48;
}
function_t *fn = alloc_words(sizeof(function_t)/sizeof(value_t));
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(fl_unlikely(!issymbol(args[3])))
type_error("symbol", args[3]);
fn->name = args[3];
}
}
if(fl_unlikely(isgensym(fn->name)))
lerrorf(FL_ArgError, "name should not be a gensym");
}
return fv;
}
fl_purefn
BUILTIN("function:code", function_code)
{
argcount(nargs, 1);
value_t v = args[0];
if(fl_unlikely(!isfunction(v)))
type_error("function", v);
return fn_bcode(v);
}
fl_purefn
BUILTIN("function:vals", function_vals)
{
argcount(nargs, 1);
value_t v = args[0];
if(fl_unlikely(!isfunction(v)))
type_error("function", v);
return fn_vals(v);
}
fl_purefn
BUILTIN("function:env", function_env)
{
argcount(nargs, 1);
value_t v = args[0];
if(fl_unlikely(!isfunction(v)))
type_error("function", v);
return fn_env(v);
}
BUILTIN("function:name", function_name)
{
argcount(nargs, 1);
value_t v = args[0];
if(isfunction(v))
return fn_name(v);
if(isbuiltin(v))
return symbol(builtins[uintval(v)].name, false);
if(iscbuiltin(v)){
v = (value_t)ptrhash_get(&FL(reverse_dlsym_lookup_table), ptr(v));
if(v == (value_t)HT_NOTFOUND)
return FL_nil;
return v;
}
type_error("function", 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;
int 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(fl_unlikely(nargs < 2))
lerrorf(FL_ArgError, "too few arguments");
value_t *k = FL(sp);
PUSH(FL_nil);
PUSH(FL_nil);
for(bool first = true;;){
PUSH(args[0]);
for(int i = 1; i < nargs; i++){
if(!iscons(args[i])){
POPN(2+i);
return k[1];
}
PUSH(car(args[i]));
args[i] = cdr_(args[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)
k[1] = c;
else
cdr_(k[0]) = c;
k[0] = c;
first = false;
}
}
BUILTIN("for-each", for_each)
{
if(fl_unlikely(nargs < 2))
lerrorf(FL_ArgError, "too few arguments");
for(size_t n = 0;; n++){
PUSH(args[0]);
int pargs = 0;
for(int i = 1; i < nargs; i++, pargs++){
value_t v = args[i];
if(iscons(v)){
PUSH(car_(v));
args[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_void;
}
_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_void;
}
BUILTIN("vm-stats", vm_stats)
{
USED(args);
argcount(nargs, 0);
ios_printf(ios_stderr, "heap total %10"PRIuPTR" bytes\n", FL(heapsize));
ios_printf(ios_stderr, "heap free %10"PRIuPTR" bytes\n", (uintptr_t)(FL(lim)-FL(curheap)));
ios_printf(ios_stderr, "heap used %10"PRIuPTR" bytes\n", (uintptr_t)(FL(curheap)-FL(fromspace)));
ios_printf(ios_stderr, "stack %10"PRIu64" bytes\n", (uint64_t)FL(nstack)*sizeof(value_t));
ios_printf(ios_stderr, "finalizers %10"PRIu32"\n", (uint32_t)FL(nfinalizers));
ios_printf(ios_stderr, "max finalizers %10"PRIu32"\n", (uint32_t)FL(maxfinalizers));
ios_printf(ios_stderr, "gc handles %10"PRIu32"\n", (uint32_t)FL(ngchandles));
ios_printf(ios_stderr, "gc calls %10"PRIu64"\n", (uint64_t)FL(gccalls));
ios_printf(ios_stderr, "opcodes %10d\n", N_OPCODES);
return FL_void;
}
static const builtinspec_t builtin_fns[] = {
#define BUILTIN_FN(l, c, attr){l, (builtin_t)fn_builtin_##c},
#include "builtin_fns.h"
#undef BUILTIN_FN
};
// initialization -------------------------------------------------------------
int
fl_init(size_t heapsize, size_t stacksize)
{
int i;
if((fl = MEM_CALLOC(1, sizeof(*fl))) == nil)
return -1;
FL(scr_width) = 100;
FL(heapsize) = heapsize*sizeof(value_t);
if((FL(fromspace) = MEM_ALLOC(FL(heapsize))) == nil){
failed:
MEM_FREE(FL(fromspace));
MEM_FREE(FL(tospace));
MEM_FREE(FL(consflags));
MEM_FREE(FL(finalizers));
fl_segfree(FL(stack), stacksize*sizeof(value_t));
htable_free(&FL(printconses));
MEM_FREE(fl);
return -1;
}
if((FL(tospace) = MEM_ALLOC(FL(heapsize))) == nil)
goto failed;
FL(curheap) = FL(fromspace);
FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t);
if((FL(stack) = fl_segalloc(stacksize*sizeof(value_t))) == nil)
goto failed;
FL(curr_frame) = FL(sp) = FL(stack);
FL(nstack) = stacksize;
FL(maxfinalizers) = 512;
if((FL(finalizers) = MEM_ALLOC(FL(maxfinalizers) * sizeof(*FL(finalizers)))) == nil)
goto failed;
if((FL(consflags) = bitvector_new(FL(heapsize)/sizeof(cons_t), 1)) == nil)
goto failed;
if((htable_new(&FL(printconses), 32)) == nil)
goto failed;
comparehash_init();
FL_lambda = csymbol("λ");
FL_function = csymbol("function");
FL_quote = csymbol("quote");
FL_trycatch = csymbol("trycatch");
FL_backquote = csymbol("quasiquote");
FL_comma = csymbol("unquote");
FL_commaat = csymbol("unquote-splicing");
FL_commadot = csymbol("unquote-nsplicing");
FL_IOError = csymbol("io-error");
FL_ParseError = csymbol("parse-error");
FL_TypeError = csymbol("type-error");
FL_ArgError = csymbol("arg-error");
FL_UnboundError = csymbol("unbound-error");
FL_KeyError = csymbol("key-error");
FL_MemoryError = csymbol("memory-error");
FL_BoundsError = csymbol("bounds-error");
FL_DivideError = csymbol("divide-error");
FL_Error = csymbol("error");
FL_conssym = csymbol("cons");
FL_symbolsym = csymbol("symbol");
FL_fixnumsym = csymbol("fixnum");
FL_vectorsym = csymbol("vector");
FL_builtinsym = csymbol("builtin");
FL_booleansym = csymbol("boolean");
FL_nullsym = csymbol("null");
FL_defsym = csymbol("def");
FL_defmacrosym = csymbol("defmacro");
FL_forsym = csymbol("for");
FL_setqsym = csymbol("set!");
FL_evalsym = csymbol("eval");
FL_vu8sym = csymbol("vu8");
FL_fnsym = csymbol("fn");
FL_nulsym = csymbol("nul");
FL_alarmsym = csymbol("alarm");
FL_backspacesym = csymbol("backspace");
FL_tabsym = csymbol("tab");
FL_linefeedsym = csymbol("linefeed");
FL_vtabsym = csymbol("vtab");
FL_pagesym = csymbol("page");
FL_returnsym = csymbol("return");
FL_escsym = csymbol("esc");
FL_spacesym = csymbol("space");
FL_deletesym = csymbol("delete");
FL_newlinesym = csymbol("newline");
FL_builtins_table_sym = csymbol("*builtins*");
set(FL_printprettysym = csymbol("*print-pretty*"), FL_t);
set(FL_printreadablysym = csymbol("*print-readably*"), FL_t);
set(FL_printwidthsym = csymbol("*print-width*"), fixnum(FL(scr_width)));
set(FL_printlengthsym = csymbol("*print-length*"), FL_nil);
set(FL_printlevelsym = csymbol("*print-level*"), FL_nil);
FL(lasterror) = FL_nil;
for(i = 0; i < nelem(builtins); i++){
if(builtins[i].name)
set(symbol(builtins[i].name, false), builtin(i));
}
setc(csymbol("procedure?"), builtin(OP_FUNCTIONP));
setc(csymbol("top-level-bound?"), builtin(OP_BOUNDP));
FL(the_empty_vector) = tagptr(alloc_words(1), TAG_VECTOR);
vector_setsize(FL(the_empty_vector), 0);
cvalues_init();
set(csymbol("*os-name*"), cvalue_static_cstring(__os_name__));
#if defined(__os_version__)
set(csymbol("*os-version*"), cvalue_static_cstring(__os_version__));
#endif
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++)
cbuiltin(b->name, b->fptr);
table_init();
iostream_init();
compress_init();
return 0;
}
// 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)
{
FL(loading) = true;
PUSH(sys_image_iostream);
value_t *saveSP = FL(sp);
FL_TRY{
while(1){
FL(sp) = saveSP;
value_t e = fl_read_sexpr(FL(sp)[-1]);
if(ios_eof(value2c(ios_t*, FL(sp)[-1])))
break;
if(isfunction(e)){
// stage 0 format: series of thunks
PUSH(e);
(void)_applyn(0);
}else{
// stage 1 format: list alternating symbol/value
while(iscons(e)){
symbol_t *sym = tosymbol(car_(e));
e = cdr_(e);
if(sym->binding != UNBOUND)
ios_printf(ios_stderr, "%s redefined on boot\n", sym->name);
sym->binding = car_(e);
e = cdr_(e);
}
break;
}
}
}
FL_CATCH_NO_INC{
ios_puts(ios_stderr, "fatal error during bootstrap: ");
fl_print(ios_stderr, FL(lasterror));
ios_putc(ios_stderr, '\n');
return -1;
}
FL(sp) = saveSP-1;
FL(loading) = false;
return 0;
}