2699 lines
74 KiB
C
2699 lines
74 KiB
C
/*
|
|
femtoLisp
|
|
|
|
a compact interpreter for a minimal lisp/scheme dialect
|
|
|
|
characteristics:
|
|
* lexical scope, lisp-1
|
|
* unrestricted macros
|
|
* data types: 30-bit integer, symbol, pair, vector, char, string, table
|
|
iostream, procedure, low-level data types
|
|
* case-sensitive
|
|
* simple compacting copying garbage collector
|
|
* Scheme-style varargs (dotted formal argument lists)
|
|
* "human-readable" bytecode with self-hosted compiler
|
|
|
|
extra features:
|
|
* circular structure can be printed and read
|
|
* #. read macro for eval-when-read and readably printing builtins
|
|
* read macros for backquote
|
|
* symbol character-escaping printer
|
|
* exceptions
|
|
* gensyms (can be usefully read back in, too)
|
|
* #| multiline comments |#, lots of other lexical syntax
|
|
* generic compare function, cyclic equal
|
|
* cvalues system providing C data types and a C FFI
|
|
* constructor notation for nicely printing arbitrary values
|
|
|
|
by Jeff Bezanson (C) 2009
|
|
Distributed under the BSD License
|
|
*/
|
|
|
|
#include <sys/types.h>
|
|
|
|
#include <assert.h>
|
|
#include <ctype.h>
|
|
#include <errno.h>
|
|
#include <limits.h>
|
|
#include <locale.h>
|
|
#include <math.h>
|
|
#include <setjmp.h>
|
|
#include <stdarg.h>
|
|
#include <stdint.h>
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
#include <wctype.h>
|
|
|
|
#include "scheme.h"
|
|
|
|
#include "opcodes.h"
|
|
|
|
static char *builtin_names[] = {
|
|
NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
|
|
// predicates
|
|
"eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
|
|
"number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?",
|
|
"function?",
|
|
|
|
// lists
|
|
"cons", "list", "car", "cdr", "set-car!", "set-cdr!",
|
|
|
|
// execution
|
|
"apply",
|
|
|
|
// arithmetic
|
|
"+", "-", "*", "/", "div0", "=", "<", "compare",
|
|
|
|
// sequences
|
|
"vector", "aref", "aset!", "", "", ""
|
|
};
|
|
|
|
#define ANYARGS -10000
|
|
|
|
static short builtin_arg_counts[] = {
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 2,
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, ANYARGS, 1,
|
|
1, 2, 2, -2, ANYARGS, -1, ANYARGS, -1, 2, 2, 2, 2, ANYARGS, 2, 3
|
|
};
|
|
|
|
static uint32_t N_STACK;
|
|
static value_t *Stack;
|
|
static uint32_t SP = 0;
|
|
static uint32_t curr_frame = 0;
|
|
#define PUSH(v) (Stack[SP++] = (v))
|
|
#define POP() (Stack[--SP])
|
|
#define POPN(n) (SP -= (n))
|
|
|
|
#define N_GC_HANDLES 1024
|
|
static value_t *GCHandleStack[N_GC_HANDLES];
|
|
static uint32_t N_GCHND = 0;
|
|
|
|
value_t FL_NIL, FL_T, FL_F, FL_EOF, QUOTE;
|
|
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
|
|
value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
|
|
value_t printwidthsym, printreadablysym, printprettysym, printlengthsym;
|
|
value_t printlevelsym, builtins_table_sym;
|
|
|
|
static value_t NIL, LAMBDA, IF, TRYCATCH;
|
|
static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
|
|
|
|
static value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
|
|
static value_t definesym, defmacrosym, forsym, setqsym;
|
|
static value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym, fnsym;
|
|
// for reading characters
|
|
static value_t nulsym, alarmsym, backspacesym, tabsym, linefeedsym,
|
|
newlinesym;
|
|
static value_t vtabsym, pagesym, returnsym, escsym, spacesym, deletesym;
|
|
|
|
static value_t apply_cl(uint32_t nargs);
|
|
static value_t *alloc_words(int n);
|
|
static value_t relocate(value_t v);
|
|
|
|
static struct fl_readstate *readstate = NULL;
|
|
|
|
static void free_readstate(struct fl_readstate *rs)
|
|
{
|
|
htable_free(&rs->backrefs);
|
|
htable_free(&rs->gensyms);
|
|
}
|
|
|
|
static unsigned char *fromspace;
|
|
static unsigned char *tospace;
|
|
static unsigned char *curheap;
|
|
static unsigned char *lim;
|
|
static uint32_t heapsize; // bytes
|
|
static uint32_t *consflags;
|
|
|
|
// error utilities
|
|
// ------------------------------------------------------------
|
|
|
|
// saved execution state for an unwind target
|
|
struct fl_exception_context *fl_ctx = NULL;
|
|
uint32_t fl_throwing_frame = 0; // active frame when exception was thrown
|
|
value_t fl_lasterror;
|
|
|
|
#define FL_TRY \
|
|
struct fl_exception_context _ctx; \
|
|
int l__tr, l__ca; \
|
|
_ctx.sp = SP; \
|
|
_ctx.frame = curr_frame; \
|
|
_ctx.rdst = readstate; \
|
|
_ctx.prev = fl_ctx; \
|
|
_ctx.ngchnd = N_GCHND; \
|
|
fl_ctx = &_ctx; \
|
|
if (!setjmp(_ctx.buf)) \
|
|
for (l__tr = 1; l__tr; l__tr = 0, (void)(fl_ctx = fl_ctx->prev))
|
|
|
|
#define FL_CATCH \
|
|
else for (l__ca = 1; l__ca; l__ca = 0, fl_lasterror = FL_NIL, \
|
|
fl_throwing_frame = 0, SP = _ctx.sp, \
|
|
curr_frame = _ctx.frame)
|
|
|
|
void fl_savestate(struct fl_exception_context *_ctx)
|
|
{
|
|
_ctx->sp = SP;
|
|
_ctx->frame = curr_frame;
|
|
_ctx->rdst = readstate;
|
|
_ctx->prev = fl_ctx;
|
|
_ctx->ngchnd = N_GCHND;
|
|
}
|
|
|
|
void fl_restorestate(struct fl_exception_context *_ctx)
|
|
{
|
|
fl_lasterror = FL_NIL;
|
|
fl_throwing_frame = 0;
|
|
SP = _ctx->sp;
|
|
curr_frame = _ctx->frame;
|
|
}
|
|
|
|
void fl_raise(value_t e)
|
|
{
|
|
struct fl_exception_context *thisctx;
|
|
|
|
fl_lasterror = e;
|
|
// unwind read state
|
|
while (readstate != fl_ctx->rdst) {
|
|
free_readstate(readstate);
|
|
readstate = readstate->prev;
|
|
}
|
|
if (fl_throwing_frame == 0)
|
|
fl_throwing_frame = curr_frame;
|
|
N_GCHND = fl_ctx->ngchnd;
|
|
thisctx = fl_ctx;
|
|
if (fl_ctx->prev) // don't throw past toplevel
|
|
fl_ctx = fl_ctx->prev;
|
|
longjmp(thisctx->buf, 1);
|
|
}
|
|
|
|
static value_t make_error_msg(const char *format, va_list args)
|
|
{
|
|
char msgbuf[512];
|
|
|
|
vsnprintf(msgbuf, sizeof(msgbuf), format, args);
|
|
return string_from_cstr(msgbuf);
|
|
}
|
|
|
|
void lerrorf(value_t e, const char *format, ...)
|
|
{
|
|
va_list args;
|
|
value_t msg;
|
|
|
|
PUSH(e);
|
|
va_start(args, format);
|
|
msg = make_error_msg(format, args);
|
|
va_end(args);
|
|
e = POP();
|
|
fl_raise(fl_list2(e, msg));
|
|
}
|
|
|
|
void lerror(value_t e, const char *msg)
|
|
{
|
|
value_t m;
|
|
|
|
PUSH(e);
|
|
m = cvalue_static_cstring(msg);
|
|
e = POP();
|
|
fl_raise(fl_list2(e, m));
|
|
}
|
|
|
|
void type_error(const char *fname, const char *expected, value_t got)
|
|
{
|
|
fl_raise(fl_listn(4, TypeError, symbol(fname), symbol(expected), got));
|
|
}
|
|
|
|
void bounds_error(const char *fname, value_t arr, value_t ind)
|
|
{
|
|
fl_raise(fl_listn(4, BoundsError, symbol(fname), arr, ind));
|
|
}
|
|
|
|
void DivideByZeroError(void) { lerror(DivideError, "/: division by zero"); }
|
|
|
|
// safe cast operators
|
|
// --------------------------------------------------------
|
|
|
|
#define isstring fl_isstring
|
|
// TODO: Remove the spurious return statement.
|
|
#define SAFECAST_OP(type, ctype, cnvt) \
|
|
ctype to##type(value_t v, char *fname) \
|
|
{ \
|
|
if (is##type(v)) \
|
|
return (ctype)cnvt(v); \
|
|
type_error(fname, #type, v); \
|
|
return (ctype)FL_NIL; \
|
|
}
|
|
SAFECAST_OP(cons, struct cons *, ptr)
|
|
SAFECAST_OP(symbol, struct symbol *, ptr)
|
|
SAFECAST_OP(fixnum, fixnum_t, numval)
|
|
SAFECAST_OP(cvalue, struct cvalue *, ptr)
|
|
SAFECAST_OP(string, char *, cvalue_data)
|
|
#undef isstring
|
|
|
|
// symbol table
|
|
// ---------------------------------------------------------------
|
|
|
|
struct symbol *symtab = NULL;
|
|
|
|
int fl_is_keyword_name(const char *str, size_t len)
|
|
{
|
|
return ((str[0] == ':' || str[len - 1] == ':') && str[1] != '\0');
|
|
}
|
|
|
|
static struct symbol *mk_symbol(const char *str)
|
|
{
|
|
struct symbol *sym;
|
|
size_t len = strlen(str);
|
|
|
|
sym =
|
|
(struct symbol *)malloc(sizeof(struct symbol) - sizeof(void *) + len + 1);
|
|
assert(((uintptr_t)sym & 0x7) == 0); // make sure malloc aligns 8
|
|
sym->left = sym->right = NULL;
|
|
sym->flags = 0;
|
|
if (fl_is_keyword_name(str, len)) {
|
|
value_t s = tagptr(sym, TAG_SYM);
|
|
setc(s, s);
|
|
sym->flags |= 0x2;
|
|
} else {
|
|
sym->binding = UNBOUND;
|
|
}
|
|
sym->type = sym->dlcache = NULL;
|
|
sym->hash = memhash32(str, len) ^ 0xAAAAAAAA;
|
|
memcpy(&sym->name[0], str, len + 1);
|
|
return sym;
|
|
}
|
|
|
|
static struct symbol **symtab_lookup(struct symbol **ptree, const char *str)
|
|
{
|
|
int x;
|
|
|
|
while (*ptree != NULL) {
|
|
x = strcmp(str, (*ptree)->name);
|
|
if (x == 0)
|
|
return ptree;
|
|
if (x < 0)
|
|
ptree = &(*ptree)->left;
|
|
else
|
|
ptree = &(*ptree)->right;
|
|
}
|
|
return ptree;
|
|
}
|
|
|
|
value_t symbol(const char *str)
|
|
{
|
|
struct symbol **pnode;
|
|
|
|
pnode = symtab_lookup(&symtab, str);
|
|
if (*pnode == NULL)
|
|
*pnode = mk_symbol(str);
|
|
return tagptr(*pnode, TAG_SYM);
|
|
}
|
|
|
|
static uint32_t _gensym_ctr = 0;
|
|
// two static buffers for gensym printing so there can be two
|
|
// gensym names available at a time, mostly for compare()
|
|
static char gsname[2][16];
|
|
static int gsnameno = 0;
|
|
value_t fl_gensym(value_t *args, uint32_t nargs)
|
|
{
|
|
struct gensym *gs;
|
|
|
|
(void)args;
|
|
argcount("gensym", nargs, 0);
|
|
gs = (struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *));
|
|
gs->id = _gensym_ctr++;
|
|
gs->binding = UNBOUND;
|
|
gs->isconst = 0;
|
|
gs->type = NULL;
|
|
return tagptr(gs, TAG_SYM);
|
|
}
|
|
|
|
int fl_isgensym(value_t v) { return isgensym(v); }
|
|
|
|
static value_t fl_gensymp(value_t *args, uint32_t nargs)
|
|
{
|
|
argcount("gensym?", nargs, 1);
|
|
return isgensym(args[0]) ? FL_T : FL_F;
|
|
}
|
|
|
|
char *symbol_name(value_t v)
|
|
{
|
|
struct gensym *gs;
|
|
char *n;
|
|
|
|
if (ismanaged(v)) {
|
|
gs = (struct gensym *)ptr(v);
|
|
gsnameno = 1 - gsnameno;
|
|
n = uint2str(gsname[gsnameno] + 1, sizeof(gsname[0]) - 1, gs->id, 10);
|
|
*(--n) = 'g';
|
|
return n;
|
|
}
|
|
return ((struct symbol *)ptr(v))->name;
|
|
}
|
|
|
|
// conses
|
|
// ---------------------------------------------------------------------
|
|
|
|
void gc(int mustgrow);
|
|
|
|
static value_t mk_cons(void)
|
|
{
|
|
struct cons *c;
|
|
|
|
if (__unlikely(curheap > lim))
|
|
gc(0);
|
|
c = (struct cons *)curheap;
|
|
curheap += sizeof(struct cons);
|
|
return tagptr(c, TAG_CONS);
|
|
}
|
|
|
|
static value_t *alloc_words(int n)
|
|
{
|
|
value_t *first;
|
|
|
|
assert(n > 0);
|
|
n = ALIGN(n, 2); // only allocate multiples of 2 words
|
|
if (__unlikely((value_t *)curheap > ((value_t *)lim) + 2 - n)) {
|
|
gc(0);
|
|
while ((value_t *)curheap > ((value_t *)lim) + 2 - n) {
|
|
gc(1);
|
|
}
|
|
}
|
|
first = (value_t *)curheap;
|
|
curheap += (n * sizeof(value_t));
|
|
return first;
|
|
}
|
|
|
|
// allocate n consecutive conses
|
|
#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
|
|
|
|
#define cons_index(c) (((struct cons *)ptr(c)) - ((struct cons *)fromspace))
|
|
#define ismarked(c) bitvector_get(consflags, cons_index(c))
|
|
#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
|
|
#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
|
|
|
|
static value_t the_empty_vector;
|
|
|
|
value_t alloc_vector(size_t n, int init)
|
|
{
|
|
value_t *c;
|
|
value_t v;
|
|
unsigned int i;
|
|
|
|
if (n == 0)
|
|
return the_empty_vector;
|
|
c = alloc_words(n + 1);
|
|
v = tagptr(c, TAG_VECTOR);
|
|
vector_setsize(v, n);
|
|
if (init) {
|
|
for (i = 0; i < n; i++)
|
|
vector_elt(v, i) = FL_UNSPECIFIED;
|
|
}
|
|
return v;
|
|
}
|
|
|
|
// cvalues
|
|
// --------------------------------------------------------------------
|
|
|
|
#include "ptrhash.h"
|
|
#include "operators.h"
|
|
#include "cvalues.h"
|
|
#include "equalhash.h"
|
|
#include "types.h"
|
|
|
|
// print
|
|
// ----------------------------------------------------------------------
|
|
|
|
static int isnumtok(char *tok, value_t *pval);
|
|
static int symchar(char c);
|
|
|
|
#include "print.h"
|
|
|
|
// collector
|
|
// ------------------------------------------------------------------
|
|
|
|
void fl_gc_handle(value_t *pv)
|
|
{
|
|
if (N_GCHND >= N_GC_HANDLES)
|
|
lerror(MemoryError, "out of gc handles");
|
|
GCHandleStack[N_GCHND++] = pv;
|
|
}
|
|
|
|
void fl_free_gc_handles(uint32_t n)
|
|
{
|
|
assert(N_GCHND >= n);
|
|
N_GCHND -= n;
|
|
}
|
|
|
|
static value_t relocate(value_t v)
|
|
{
|
|
value_t a, d, nc, first, *pcdr;
|
|
uintptr_t t;
|
|
|
|
t = tag(v);
|
|
if (t == TAG_CONS) {
|
|
// iterative implementation allows arbitrarily long cons chains
|
|
pcdr = &first;
|
|
do {
|
|
if ((a = car_(v)) == TAG_FWD) {
|
|
*pcdr = cdr_(v);
|
|
return first;
|
|
}
|
|
*pcdr = nc = tagptr((struct cons *)curheap, TAG_CONS);
|
|
curheap += sizeof(struct cons);
|
|
d = cdr_(v);
|
|
car_(v) = TAG_FWD;
|
|
cdr_(v) = nc;
|
|
car_(nc) = relocate(a);
|
|
pcdr = &cdr_(nc);
|
|
v = d;
|
|
} while (iscons(v));
|
|
*pcdr = (d == NIL) ? NIL : relocate(d);
|
|
return first;
|
|
}
|
|
|
|
if ((t & 3) == 0)
|
|
return v;
|
|
if (!ismanaged(v))
|
|
return v;
|
|
if (isforwarded(v))
|
|
return forwardloc(v);
|
|
|
|
if (t == TAG_VECTOR) {
|
|
// N.B.: 0-length vectors secretly have space for a first element
|
|
size_t i, 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;
|
|
} else if (t == TAG_CPRIM) {
|
|
struct cprim *pcp = (struct cprim *)ptr(v);
|
|
size_t nw = CPRIM_NWORDS - 1 + NWORDS(cp_class(pcp)->size);
|
|
struct cprim *ncp = (struct cprim *)alloc_words(nw);
|
|
while (nw--)
|
|
((value_t *)ncp)[nw] = ((value_t *)pcp)[nw];
|
|
nc = tagptr(ncp, TAG_CPRIM);
|
|
forward(v, nc);
|
|
return nc;
|
|
} else if (t == TAG_CVALUE) {
|
|
return cvalue_relocate(v);
|
|
} else if (t == TAG_FUNCTION) {
|
|
struct function *fn = (struct function *)ptr(v);
|
|
struct function *nfn = (struct function *)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;
|
|
} else if (t == TAG_SYM) {
|
|
struct gensym *gs = (struct gensym *)ptr(v);
|
|
struct gensym *ng =
|
|
(struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *));
|
|
ng->id = gs->id;
|
|
ng->binding = gs->binding;
|
|
ng->isconst = 0;
|
|
nc = tagptr(ng, TAG_SYM);
|
|
forward(v, nc);
|
|
if (ng->binding != UNBOUND)
|
|
ng->binding = relocate(ng->binding);
|
|
return nc;
|
|
}
|
|
return v;
|
|
}
|
|
|
|
value_t relocate_lispvalue(value_t v) { return relocate(v); }
|
|
|
|
static void trace_globals(struct symbol *root)
|
|
{
|
|
while (root != NULL) {
|
|
if (root->binding != UNBOUND)
|
|
root->binding = relocate(root->binding);
|
|
trace_globals(root->left);
|
|
root = root->right;
|
|
}
|
|
}
|
|
|
|
static value_t memory_exception_value;
|
|
|
|
void gc(int mustgrow)
|
|
{
|
|
static int grew = 0;
|
|
void *temp;
|
|
uint32_t i, f, top;
|
|
struct fl_readstate *rs;
|
|
|
|
curheap = tospace;
|
|
if (grew)
|
|
lim = curheap + heapsize * 2 - sizeof(struct cons);
|
|
else
|
|
lim = curheap + heapsize - sizeof(struct cons);
|
|
|
|
if (fl_throwing_frame > curr_frame) {
|
|
top = fl_throwing_frame - 4;
|
|
f = Stack[fl_throwing_frame - 4];
|
|
} else {
|
|
top = SP;
|
|
f = curr_frame;
|
|
}
|
|
while (1) {
|
|
for (i = f; i < top; i++)
|
|
Stack[i] = relocate(Stack[i]);
|
|
if (f == 0)
|
|
break;
|
|
top = f - 4;
|
|
f = Stack[f - 4];
|
|
}
|
|
for (i = 0; i < N_GCHND; i++)
|
|
*GCHandleStack[i] = relocate(*GCHandleStack[i]);
|
|
trace_globals(symtab);
|
|
relocate_typetable();
|
|
rs = 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);
|
|
memory_exception_value = relocate(memory_exception_value);
|
|
the_empty_vector = relocate(the_empty_vector);
|
|
|
|
sweep_finalizers();
|
|
|
|
#ifdef VERBOSEGC
|
|
printf("GC: found %d/%d live conses\n",
|
|
(curheap - tospace) / sizeof(struct cons),
|
|
heapsize / sizeof(struct cons));
|
|
#endif
|
|
temp = tospace;
|
|
tospace = fromspace;
|
|
fromspace = temp;
|
|
|
|
// if we're using > 80% of the space, resize tospace so we have
|
|
// more space to fill next time. if we grew tospace last time,
|
|
// grow the other half of the heap this time to catch up.
|
|
if (grew || ((lim - curheap) < (int)(heapsize / 5)) || mustgrow) {
|
|
temp = realloc(tospace, heapsize * 2);
|
|
if (temp == NULL)
|
|
fl_raise(memory_exception_value);
|
|
tospace = temp;
|
|
if (grew) {
|
|
heapsize *= 2;
|
|
temp =
|
|
bitvector_resize(consflags, 0, heapsize / sizeof(struct cons), 1);
|
|
if (temp == NULL)
|
|
fl_raise(memory_exception_value);
|
|
consflags = (uint32_t *)temp;
|
|
}
|
|
grew = !grew;
|
|
}
|
|
if (curheap > lim) // all data was live
|
|
gc(0);
|
|
}
|
|
|
|
static void grow_stack(void)
|
|
{
|
|
size_t newsz = N_STACK + (N_STACK >> 1);
|
|
value_t *ns = realloc(Stack, newsz * sizeof(value_t));
|
|
if (ns == NULL)
|
|
lerror(MemoryError, "stack overflow");
|
|
Stack = ns;
|
|
N_STACK = newsz;
|
|
}
|
|
|
|
// utils
|
|
// ----------------------------------------------------------------------
|
|
|
|
// apply function with n args on the stack
|
|
static value_t _applyn(uint32_t n)
|
|
{
|
|
value_t f = Stack[SP - n - 1];
|
|
uint32_t saveSP = SP;
|
|
value_t v;
|
|
if (iscbuiltin(f)) {
|
|
v = ((builtin_t *)ptr(f))[3](&Stack[SP - n], n);
|
|
} else if (isfunction(f)) {
|
|
v = apply_cl(n);
|
|
} else if (isbuiltin(f)) {
|
|
value_t tab = symbol_value(builtins_table_sym);
|
|
Stack[SP - n - 1] = vector_elt(tab, uintval(f));
|
|
v = apply_cl(n);
|
|
} else {
|
|
type_error("apply", "function", f);
|
|
}
|
|
SP = saveSP;
|
|
return v;
|
|
}
|
|
|
|
value_t fl_apply(value_t f, value_t l)
|
|
{
|
|
value_t v = l;
|
|
uint32_t n = SP;
|
|
|
|
PUSH(f);
|
|
while (iscons(v)) {
|
|
if (SP >= N_STACK)
|
|
grow_stack();
|
|
PUSH(car_(v));
|
|
v = cdr_(v);
|
|
}
|
|
n = SP - n - 1;
|
|
v = _applyn(n);
|
|
POPN(n + 1);
|
|
return v;
|
|
}
|
|
|
|
value_t fl_applyn(uint32_t n, value_t f, ...)
|
|
{
|
|
va_list ap;
|
|
value_t v;
|
|
size_t i;
|
|
|
|
va_start(ap, f);
|
|
PUSH(f);
|
|
while (SP + n > N_STACK)
|
|
grow_stack();
|
|
for (i = 0; i < n; i++) {
|
|
value_t a = va_arg(ap, value_t);
|
|
PUSH(a);
|
|
}
|
|
v = _applyn(n);
|
|
POPN(n + 1);
|
|
va_end(ap);
|
|
return v;
|
|
}
|
|
|
|
value_t fl_listn(size_t n, ...)
|
|
{
|
|
struct cons *c;
|
|
struct cons *l;
|
|
va_list ap;
|
|
uint32_t si;
|
|
size_t i;
|
|
|
|
si = SP;
|
|
va_start(ap, n);
|
|
while (SP + n > N_STACK)
|
|
grow_stack();
|
|
for (i = 0; i < n; i++) {
|
|
value_t a = va_arg(ap, value_t);
|
|
PUSH(a);
|
|
}
|
|
c = (struct cons *)alloc_words(n * 2);
|
|
l = c;
|
|
for (i = 0; i < n; i++) {
|
|
c->car = Stack[si++];
|
|
c->cdr = tagptr(c + 1, TAG_CONS);
|
|
c++;
|
|
}
|
|
(c - 1)->cdr = NIL;
|
|
|
|
POPN(n);
|
|
va_end(ap);
|
|
return tagptr(l, TAG_CONS);
|
|
}
|
|
|
|
value_t fl_list2(value_t a, value_t b)
|
|
{
|
|
struct cons *c;
|
|
|
|
PUSH(a);
|
|
PUSH(b);
|
|
c = (struct cons *)alloc_words(4);
|
|
b = POP();
|
|
a = POP();
|
|
c[0].car = a;
|
|
c[0].cdr = tagptr(c + 1, TAG_CONS);
|
|
c[1].car = b;
|
|
c[1].cdr = NIL;
|
|
return tagptr(c, TAG_CONS);
|
|
}
|
|
|
|
value_t fl_cons(value_t a, value_t b)
|
|
{
|
|
value_t c;
|
|
|
|
PUSH(a);
|
|
PUSH(b);
|
|
c = mk_cons();
|
|
cdr_(c) = POP();
|
|
car_(c) = POP();
|
|
return c;
|
|
}
|
|
|
|
int fl_isnumber(value_t v)
|
|
{
|
|
struct cprim *c;
|
|
|
|
if (isfixnum(v))
|
|
return 1;
|
|
if (iscprim(v)) {
|
|
c = (struct cprim *)ptr(v);
|
|
return c->type != wchartype;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
// read
|
|
// -----------------------------------------------------------------------
|
|
|
|
#include "read.h"
|
|
|
|
// equal
|
|
// ----------------------------------------------------------------------
|
|
|
|
#include "equal.h"
|
|
|
|
// eval
|
|
// -----------------------------------------------------------------------
|
|
|
|
#define list(a, n) _list((a), (n), 0)
|
|
|
|
static value_t _list(value_t *args, uint32_t nargs, int star)
|
|
{
|
|
struct cons *c;
|
|
uint32_t i;
|
|
value_t v;
|
|
|
|
v = cons_reserve(nargs);
|
|
c = (struct cons *)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 = NIL;
|
|
return v;
|
|
}
|
|
|
|
static value_t copy_list(value_t L)
|
|
{
|
|
value_t *plcons;
|
|
value_t *pL;
|
|
value_t c;
|
|
|
|
if (!iscons(L))
|
|
return NIL;
|
|
PUSH(NIL);
|
|
PUSH(L);
|
|
plcons = &Stack[SP - 2];
|
|
pL = &Stack[SP - 1];
|
|
c = mk_cons();
|
|
PUSH(c); // save first cons
|
|
car_(c) = car_(*pL);
|
|
cdr_(c) = NIL;
|
|
*plcons = c;
|
|
*pL = cdr_(*pL);
|
|
while (iscons(*pL)) {
|
|
c = mk_cons();
|
|
car_(c) = car_(*pL);
|
|
cdr_(c) = 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 v, thunk;
|
|
uint32_t saveSP;
|
|
|
|
saveSP = SP;
|
|
thunk = Stack[SP - 2];
|
|
Stack[SP - 2] = Stack[SP - 1];
|
|
Stack[SP - 1] = thunk;
|
|
{
|
|
FL_TRY { v = apply_cl(0); }
|
|
FL_CATCH
|
|
{
|
|
v = Stack[saveSP - 2];
|
|
PUSH(v);
|
|
PUSH(fl_lasterror);
|
|
v = apply_cl(1);
|
|
}
|
|
}
|
|
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)
|
|
{
|
|
value_t hv;
|
|
uintptr_t x;
|
|
uintptr_t idx;
|
|
uintptr_t n;
|
|
uint32_t ntot;
|
|
value_t v;
|
|
uint32_t extr;
|
|
value_t *args;
|
|
uint32_t nrestargs, i, a;
|
|
value_t s1, s2, s4, s5;
|
|
|
|
extr = nopt + nkw;
|
|
ntot = nreq + extr;
|
|
if (!(args = calloc(extr, sizeof(*args)))) {
|
|
lerror(MemoryError, "out of memory");
|
|
}
|
|
a = 0;
|
|
s1 = Stack[SP - 1];
|
|
s2 = Stack[SP - 2];
|
|
s4 = Stack[SP - 4];
|
|
s5 = Stack[SP - 5];
|
|
if (nargs < nreq)
|
|
lerror(ArgError, "apply: too few arguments");
|
|
for (i = 0; i < extr; i++)
|
|
args[i] = UNBOUND;
|
|
for (i = nreq; i < nargs; i++) {
|
|
v = Stack[bp + i];
|
|
if (issymbol(v) && iskeyword((struct symbol *)ptr(v)))
|
|
break;
|
|
if (a >= nopt)
|
|
goto no_kw;
|
|
args[a++] = v;
|
|
}
|
|
if (i >= nargs)
|
|
goto no_kw;
|
|
// now process keywords
|
|
n = vector_size(kwtable) / 2;
|
|
do {
|
|
i++;
|
|
if (i >= nargs)
|
|
lerrorf(ArgError, "keyword %s requires an argument",
|
|
symbol_name(v));
|
|
hv = fixnum(((struct symbol *)ptr(v))->hash);
|
|
x = 2 * (labs(numval(hv)) % n);
|
|
if (vector_elt(kwtable, x) == v) {
|
|
idx = numval(vector_elt(kwtable, x + 1));
|
|
assert(idx < nkw);
|
|
idx += nopt;
|
|
if (args[idx] == UNBOUND) {
|
|
// if duplicate key, keep first value
|
|
args[idx] = Stack[bp + i];
|
|
}
|
|
} else {
|
|
lerrorf(ArgError, "unsupported keyword %s", symbol_name(v));
|
|
}
|
|
i++;
|
|
if (i >= nargs)
|
|
break;
|
|
v = Stack[bp + i];
|
|
} while (issymbol(v) && iskeyword((struct symbol *)ptr(v)));
|
|
no_kw:
|
|
nrestargs = nargs - i;
|
|
if (!va && nrestargs > 0)
|
|
lerror(ArgError, "apply: too many arguments");
|
|
nargs = ntot + nrestargs;
|
|
if (nrestargs)
|
|
memmove(&Stack[bp + ntot], &Stack[bp + i],
|
|
nrestargs * sizeof(value_t));
|
|
memcpy(&Stack[bp + nreq], args, extr * sizeof(value_t));
|
|
SP = bp + nargs;
|
|
assert(SP < N_STACK - 5);
|
|
PUSH(s5);
|
|
PUSH(s4);
|
|
PUSH(nargs);
|
|
PUSH(s2);
|
|
PUSH(s1);
|
|
curr_frame = SP;
|
|
return nargs;
|
|
}
|
|
|
|
#ifndef bswap_16
|
|
#define bswap_16(x) (((x)&0x00ff) << 8 | ((x)&0xff00) >> 8)
|
|
#endif
|
|
|
|
#ifndef bswap_32
|
|
#ifdef __INTEL_COMPILER
|
|
#define bswap_32(x) _bswap(x)
|
|
#else
|
|
#define bswap_32(x) \
|
|
((((x)&0xff000000) >> 24) | (((x)&0x00ff0000) >> 8) | \
|
|
(((x)&0x0000ff00) << 8) | (((x)&0x000000ff) << 24))
|
|
#endif
|
|
#endif
|
|
|
|
#if __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
|
|
#define GET_INT32(a) \
|
|
((int32_t)((((int32_t)a[0]) << 0) | (((int32_t)a[1]) << 8) | \
|
|
(((int32_t)a[2]) << 16) | (((int32_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) (*(int32_t *)(a) = bswap_32((int32_t)(i)))
|
|
#endif
|
|
|
|
#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
|
|
#define GET_INT32(a) (*(int32_t *)a)
|
|
#define GET_INT16(a) (*(int16_t *)a)
|
|
#define PUT_INT32(a, i) (*(int32_t *)(a) = (int32_t)(i))
|
|
#endif
|
|
|
|
#define SWAP_INT32(a) (*(int32_t *)(a) = bswap_32(*(int32_t *)(a)))
|
|
#define SWAP_INT16(a) (*(int16_t *)(a) = bswap_16(*(int16_t *)(a)))
|
|
|
|
#ifdef USE_COMPUTED_GOTO
|
|
#define OP(x) L_##x:
|
|
#define NEXT_OP goto *vm_labels[*ip++]
|
|
#else
|
|
#define OP(x) case x:
|
|
#define NEXT_OP goto next_op
|
|
#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(uint32_t nargs)
|
|
{
|
|
VM_LABELS;
|
|
VM_APPLY_LABELS;
|
|
uint32_t top_frame = curr_frame;
|
|
// frame variables
|
|
uint32_t n = 0, captured;
|
|
uint32_t bp;
|
|
const uint8_t *ip;
|
|
fixnum_t s, hi;
|
|
|
|
// temporary variables (not necessary to preserve across calls)
|
|
#ifndef USE_COMPUTED_GOTO
|
|
uint32_t op;
|
|
#endif
|
|
uint32_t i;
|
|
struct symbol *sym;
|
|
static struct cons *c;
|
|
static value_t *pv;
|
|
static int64_t accum;
|
|
static value_t func, v, e;
|
|
|
|
apply_cl_top:
|
|
captured = 0;
|
|
func = Stack[SP - nargs - 1];
|
|
ip = cv_data((struct cvalue *)ptr(fn_bcode(func)));
|
|
assert(!ismanaged((uintptr_t)ip));
|
|
while (SP + GET_INT32(ip) > N_STACK) {
|
|
grow_stack();
|
|
}
|
|
ip += 4;
|
|
|
|
bp = SP - nargs;
|
|
PUSH(fn_env(func));
|
|
PUSH(curr_frame);
|
|
PUSH(nargs);
|
|
SP++; // PUSH(0); //ip
|
|
PUSH(0); // captured?
|
|
curr_frame = SP;
|
|
|
|
{
|
|
#ifdef USE_COMPUTED_GOTO
|
|
{
|
|
NEXT_OP;
|
|
#else
|
|
next_op:
|
|
op = *ip++;
|
|
dispatch:
|
|
switch (op) {
|
|
#endif
|
|
OP(OP_ARGC)
|
|
n = *ip++;
|
|
do_argc:
|
|
if (nargs != n) {
|
|
if (nargs > n)
|
|
lerror(ArgError, "apply: too many arguments");
|
|
else
|
|
lerror(ArgError, "apply: too few arguments");
|
|
}
|
|
NEXT_OP;
|
|
OP(OP_VARGC)
|
|
i = *ip++;
|
|
do_vargc:
|
|
s = (fixnum_t)nargs - (fixnum_t)i;
|
|
if (s > 0) {
|
|
v = list(&Stack[bp + i], s);
|
|
Stack[bp + i] = v;
|
|
if (s > 1) {
|
|
Stack[bp + i + 1] = Stack[bp + nargs + 0];
|
|
Stack[bp + i + 2] = Stack[bp + nargs + 1];
|
|
Stack[bp + i + 3] = i + 1;
|
|
// Stack[bp+i+4] = 0;
|
|
Stack[bp + i + 5] = 0;
|
|
SP = bp + i + 6;
|
|
curr_frame = SP;
|
|
}
|
|
} else if (s < 0) {
|
|
lerror(ArgError, "apply: too few arguments");
|
|
} else {
|
|
PUSH(0);
|
|
Stack[SP - 3] = i + 1;
|
|
Stack[SP - 4] = Stack[SP - 5];
|
|
Stack[SP - 5] = Stack[SP - 6];
|
|
Stack[SP - 6] = NIL;
|
|
curr_frame = SP;
|
|
}
|
|
nargs = i + 1;
|
|
NEXT_OP;
|
|
OP(OP_LARGC)
|
|
n = GET_INT32(ip);
|
|
ip += 4;
|
|
goto do_argc;
|
|
OP(OP_LVARGC)
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
goto do_vargc;
|
|
OP(OP_BRBOUND)
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
if (captured)
|
|
v = vector_elt(Stack[bp], i);
|
|
else
|
|
v = Stack[bp + i];
|
|
if (v != UNBOUND)
|
|
PUSH(FL_T);
|
|
else
|
|
PUSH(FL_F);
|
|
NEXT_OP;
|
|
OP(OP_DUP) SP++;
|
|
Stack[SP - 1] = Stack[SP - 2];
|
|
NEXT_OP;
|
|
OP(OP_POP) POPN(1);
|
|
NEXT_OP;
|
|
OP(OP_TCALL)
|
|
n = *ip++; // nargs
|
|
do_tcall:
|
|
func = Stack[SP - n - 1];
|
|
if (tag(func) == TAG_FUNCTION) {
|
|
if (func > (N_BUILTINS << 3)) {
|
|
curr_frame = Stack[curr_frame - 4];
|
|
for (s = -1; s < (fixnum_t)n; s++)
|
|
Stack[bp + s] = Stack[SP - n + s];
|
|
SP = bp + n;
|
|
nargs = n;
|
|
goto apply_cl_top;
|
|
} else {
|
|
i = uintval(func);
|
|
if (i <= OP_ASET) {
|
|
s = builtin_arg_counts[i];
|
|
if (s >= 0)
|
|
argcount(builtin_names[i], n, s);
|
|
else if (s != ANYARGS && (signed)n < -s)
|
|
argcount(builtin_names[i], n, -s);
|
|
// remove function arg
|
|
for (s = SP - n - 1; s < (int)SP - 1; s++)
|
|
Stack[s] = Stack[s + 1];
|
|
SP--;
|
|
#ifdef USE_COMPUTED_GOTO
|
|
if (i == OP_APPLY)
|
|
goto apply_tapply;
|
|
goto *vm_apply_labels[i];
|
|
#else
|
|
switch (i) {
|
|
case OP_LIST:
|
|
goto apply_list;
|
|
case OP_VECTOR:
|
|
goto apply_vector;
|
|
case OP_APPLY:
|
|
goto apply_tapply;
|
|
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:
|
|
op = (uint8_t)i;
|
|
goto dispatch;
|
|
}
|
|
#endif
|
|
}
|
|
}
|
|
} else if (iscbuiltin(func)) {
|
|
s = SP;
|
|
v = ((builtin_t)(((void **)ptr(func))[3]))(&Stack[SP - n], n);
|
|
SP = s - n;
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
}
|
|
type_error("apply", "function", func);
|
|
// WARNING: repeated code ahead
|
|
OP(OP_CALL)
|
|
n = *ip++; // nargs
|
|
do_call:
|
|
func = Stack[SP - n - 1];
|
|
if (tag(func) == TAG_FUNCTION) {
|
|
if (func > (N_BUILTINS << 3)) {
|
|
Stack[curr_frame - 2] = (uintptr_t)ip;
|
|
nargs = n;
|
|
goto apply_cl_top;
|
|
} else {
|
|
i = uintval(func);
|
|
if (i <= OP_ASET) {
|
|
s = builtin_arg_counts[i];
|
|
if (s >= 0)
|
|
argcount(builtin_names[i], n, s);
|
|
else if (s != ANYARGS && (signed)n < -s)
|
|
argcount(builtin_names[i], n, -s);
|
|
// remove function arg
|
|
for (s = SP - n - 1; s < (int)SP - 1; s++)
|
|
Stack[s] = Stack[s + 1];
|
|
SP--;
|
|
#ifdef USE_COMPUTED_GOTO
|
|
goto *vm_apply_labels[i];
|
|
#else
|
|
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:
|
|
op = (uint8_t)i;
|
|
goto dispatch;
|
|
}
|
|
#endif
|
|
}
|
|
}
|
|
} else if (iscbuiltin(func)) {
|
|
s = SP;
|
|
v = ((builtin_t)(((void **)ptr(func))[3]))(&Stack[SP - n], n);
|
|
SP = s - n;
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
}
|
|
type_error("apply", "function", func);
|
|
OP(OP_TCALLL) n = GET_INT32(ip);
|
|
ip += 4;
|
|
goto do_tcall;
|
|
OP(OP_CALLL) n = GET_INT32(ip);
|
|
ip += 4;
|
|
goto do_call;
|
|
OP(OP_JMP) ip += (intptr_t)GET_INT16(ip);
|
|
NEXT_OP;
|
|
OP(OP_BRF)
|
|
v = POP();
|
|
if (v == FL_F)
|
|
ip += (intptr_t)GET_INT16(ip);
|
|
else
|
|
ip += 2;
|
|
NEXT_OP;
|
|
OP(OP_BRT)
|
|
v = POP();
|
|
if (v != FL_F)
|
|
ip += (intptr_t)GET_INT16(ip);
|
|
else
|
|
ip += 2;
|
|
NEXT_OP;
|
|
OP(OP_JMPL) ip += (intptr_t)GET_INT32(ip);
|
|
NEXT_OP;
|
|
OP(OP_BRFL)
|
|
v = POP();
|
|
if (v == FL_F)
|
|
ip += (intptr_t)GET_INT32(ip);
|
|
else
|
|
ip += 4;
|
|
NEXT_OP;
|
|
OP(OP_BRTL)
|
|
v = POP();
|
|
if (v != FL_F)
|
|
ip += (intptr_t)GET_INT32(ip);
|
|
else
|
|
ip += 4;
|
|
NEXT_OP;
|
|
OP(OP_BRNE)
|
|
if (Stack[SP - 2] != Stack[SP - 1])
|
|
ip += (intptr_t)GET_INT16(ip);
|
|
else
|
|
ip += 2;
|
|
POPN(2);
|
|
NEXT_OP;
|
|
OP(OP_BRNEL)
|
|
if (Stack[SP - 2] != Stack[SP - 1])
|
|
ip += (intptr_t)GET_INT32(ip);
|
|
else
|
|
ip += 4;
|
|
POPN(2);
|
|
NEXT_OP;
|
|
OP(OP_BRNN)
|
|
v = POP();
|
|
if (v != NIL)
|
|
ip += (intptr_t)GET_INT16(ip);
|
|
else
|
|
ip += 2;
|
|
NEXT_OP;
|
|
OP(OP_BRNNL)
|
|
v = POP();
|
|
if (v != NIL)
|
|
ip += (intptr_t)GET_INT32(ip);
|
|
else
|
|
ip += 4;
|
|
NEXT_OP;
|
|
OP(OP_BRN)
|
|
v = POP();
|
|
if (v == NIL)
|
|
ip += (intptr_t)GET_INT16(ip);
|
|
else
|
|
ip += 2;
|
|
NEXT_OP;
|
|
OP(OP_BRNL)
|
|
v = POP();
|
|
if (v == NIL)
|
|
ip += (intptr_t)GET_INT32(ip);
|
|
else
|
|
ip += 4;
|
|
NEXT_OP;
|
|
OP(OP_RET)
|
|
v = POP();
|
|
SP = curr_frame;
|
|
curr_frame = Stack[SP - 4];
|
|
if (curr_frame == top_frame)
|
|
return v;
|
|
SP -= (5 + nargs);
|
|
captured = Stack[curr_frame - 1];
|
|
ip = (uint8_t *)Stack[curr_frame - 2];
|
|
nargs = Stack[curr_frame - 3];
|
|
bp = curr_frame - 5 - nargs;
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
|
|
OP(OP_EQ)
|
|
Stack[SP - 2] = ((Stack[SP - 2] == Stack[SP - 1]) ? FL_T : FL_F);
|
|
POPN(1);
|
|
NEXT_OP;
|
|
OP(OP_EQV)
|
|
if (Stack[SP - 2] == Stack[SP - 1]) {
|
|
v = FL_T;
|
|
} else if (!leafp(Stack[SP - 2]) || !leafp(Stack[SP - 1])) {
|
|
v = FL_F;
|
|
} else {
|
|
v = (compare_(Stack[SP - 2], Stack[SP - 1], 1) == 0 ? FL_T
|
|
: FL_F);
|
|
}
|
|
Stack[SP - 2] = v;
|
|
POPN(1);
|
|
NEXT_OP;
|
|
OP(OP_EQUAL)
|
|
if (Stack[SP - 2] == Stack[SP - 1]) {
|
|
v = FL_T;
|
|
} else {
|
|
v = (compare_(Stack[SP - 2], Stack[SP - 1], 1) == 0 ? FL_T
|
|
: FL_F);
|
|
}
|
|
Stack[SP - 2] = v;
|
|
POPN(1);
|
|
NEXT_OP;
|
|
OP(OP_PAIRP)
|
|
Stack[SP - 1] = (iscons(Stack[SP - 1]) ? FL_T : FL_F);
|
|
NEXT_OP;
|
|
OP(OP_ATOMP)
|
|
Stack[SP - 1] = (iscons(Stack[SP - 1]) ? FL_F : FL_T);
|
|
NEXT_OP;
|
|
OP(OP_NOT)
|
|
Stack[SP - 1] = ((Stack[SP - 1] == FL_F) ? FL_T : FL_F);
|
|
NEXT_OP;
|
|
OP(OP_NULLP)
|
|
Stack[SP - 1] = ((Stack[SP - 1] == NIL) ? FL_T : FL_F);
|
|
NEXT_OP;
|
|
OP(OP_BOOLEANP)
|
|
v = Stack[SP - 1];
|
|
Stack[SP - 1] = ((v == FL_T || v == FL_F) ? FL_T : FL_F);
|
|
NEXT_OP;
|
|
OP(OP_SYMBOLP)
|
|
Stack[SP - 1] = (issymbol(Stack[SP - 1]) ? FL_T : FL_F);
|
|
NEXT_OP;
|
|
OP(OP_NUMBERP)
|
|
v = Stack[SP - 1];
|
|
Stack[SP - 1] = (fl_isnumber(v) ? FL_T : FL_F);
|
|
NEXT_OP;
|
|
OP(OP_FIXNUMP)
|
|
Stack[SP - 1] = (isfixnum(Stack[SP - 1]) ? FL_T : FL_F);
|
|
NEXT_OP;
|
|
OP(OP_BOUNDP)
|
|
sym = tosymbol(Stack[SP - 1], "bound?");
|
|
Stack[SP - 1] = ((sym->binding == UNBOUND) ? FL_F : FL_T);
|
|
NEXT_OP;
|
|
OP(OP_BUILTINP)
|
|
v = Stack[SP - 1];
|
|
Stack[SP - 1] = (isbuiltin(v) || iscbuiltin(v)) ? FL_T : FL_F;
|
|
NEXT_OP;
|
|
OP(OP_FUNCTIONP)
|
|
v = Stack[SP - 1];
|
|
Stack[SP - 1] =
|
|
((tag(v) == TAG_FUNCTION &&
|
|
(uintval(v) <= OP_ASET || v > (N_BUILTINS << 3))) ||
|
|
iscbuiltin(v))
|
|
? FL_T
|
|
: FL_F;
|
|
NEXT_OP;
|
|
OP(OP_VECTORP)
|
|
Stack[SP - 1] = (isvector(Stack[SP - 1]) ? FL_T : FL_F);
|
|
NEXT_OP;
|
|
|
|
OP(OP_CONS)
|
|
if (curheap > lim)
|
|
gc(0);
|
|
c = (struct cons *)curheap;
|
|
curheap += sizeof(struct cons);
|
|
c->car = Stack[SP - 2];
|
|
c->cdr = Stack[SP - 1];
|
|
Stack[SP - 2] = tagptr(c, TAG_CONS);
|
|
POPN(1);
|
|
NEXT_OP;
|
|
OP(OP_CAR)
|
|
v = Stack[SP - 1];
|
|
if (!iscons(v))
|
|
type_error("car", "cons", v);
|
|
Stack[SP - 1] = car_(v);
|
|
NEXT_OP;
|
|
OP(OP_CDR)
|
|
v = Stack[SP - 1];
|
|
if (!iscons(v))
|
|
type_error("cdr", "cons", v);
|
|
Stack[SP - 1] = cdr_(v);
|
|
NEXT_OP;
|
|
OP(OP_CADR)
|
|
v = Stack[SP - 1];
|
|
if (!iscons(v))
|
|
type_error("cdr", "cons", v);
|
|
v = cdr_(v);
|
|
if (!iscons(v))
|
|
type_error("car", "cons", v);
|
|
Stack[SP - 1] = car_(v);
|
|
NEXT_OP;
|
|
OP(OP_SETCAR)
|
|
car(Stack[SP - 2]) = Stack[SP - 1];
|
|
POPN(1);
|
|
NEXT_OP;
|
|
OP(OP_SETCDR)
|
|
cdr(Stack[SP - 2]) = Stack[SP - 1];
|
|
POPN(1);
|
|
NEXT_OP;
|
|
OP(OP_LIST)
|
|
n = *ip++;
|
|
apply_list:
|
|
if (n > 0) {
|
|
v = list(&Stack[SP - n], n);
|
|
POPN(n);
|
|
PUSH(v);
|
|
} else {
|
|
PUSH(NIL);
|
|
}
|
|
NEXT_OP;
|
|
|
|
OP(OP_TAPPLY)
|
|
n = *ip++;
|
|
apply_tapply:
|
|
v = POP(); // arglist
|
|
n = SP - (n - 2); // n-2 == # leading arguments not in the list
|
|
while (iscons(v)) {
|
|
if (SP >= N_STACK)
|
|
grow_stack();
|
|
PUSH(car_(v));
|
|
v = cdr_(v);
|
|
}
|
|
n = SP - n;
|
|
goto do_tcall;
|
|
OP(OP_APPLY)
|
|
n = *ip++;
|
|
apply_apply:
|
|
v = POP(); // arglist
|
|
n = SP - (n - 2); // n-2 == # leading arguments not in the list
|
|
while (iscons(v)) {
|
|
if (SP >= N_STACK)
|
|
grow_stack();
|
|
PUSH(car_(v));
|
|
v = cdr_(v);
|
|
}
|
|
n = SP - n;
|
|
goto do_call;
|
|
|
|
OP(OP_ADD)
|
|
n = *ip++;
|
|
apply_add:
|
|
s = 0;
|
|
i = SP - n;
|
|
for (; i < SP; i++) {
|
|
if (isfixnum(Stack[i])) {
|
|
s += numval(Stack[i]);
|
|
if (!fits_fixnum(s)) {
|
|
i++;
|
|
goto add_ovf;
|
|
}
|
|
} else {
|
|
add_ovf:
|
|
v = fl_add_any(&Stack[i], SP - i, s);
|
|
break;
|
|
}
|
|
}
|
|
if (i == SP)
|
|
v = fixnum(s);
|
|
POPN(n);
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_ADD2)
|
|
if (bothfixnums(Stack[SP - 1], Stack[SP - 2])) {
|
|
s = numval(Stack[SP - 1]) + numval(Stack[SP - 2]);
|
|
if (fits_fixnum(s))
|
|
v = fixnum(s);
|
|
else
|
|
v = mk_long(s);
|
|
} else {
|
|
v = fl_add_any(&Stack[SP - 2], 2, 0);
|
|
}
|
|
POPN(1);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
OP(OP_SUB)
|
|
n = *ip++;
|
|
apply_sub:
|
|
if (n == 2)
|
|
goto do_sub2;
|
|
if (n == 1)
|
|
goto do_neg;
|
|
i = SP - n;
|
|
// we need to pass the full arglist on to fl_add_any
|
|
// so it can handle rest args properly
|
|
PUSH(Stack[i]);
|
|
Stack[i] = fixnum(0);
|
|
Stack[i + 1] = fl_neg(fl_add_any(&Stack[i], n, 0));
|
|
Stack[i] = POP();
|
|
v = fl_add_any(&Stack[i], 2, 0);
|
|
POPN(n);
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_NEG)
|
|
do_neg:
|
|
if (isfixnum(Stack[SP - 1])) {
|
|
s = fixnum(-numval(Stack[SP - 1]));
|
|
if (__unlikely(Stack[SP - 1] == (ufixnum_t)s))
|
|
Stack[SP - 1] =
|
|
mk_long(-numval(Stack[SP - 1])); // negate overflows
|
|
else
|
|
Stack[SP - 1] = s;
|
|
} else
|
|
Stack[SP - 1] = fl_neg(Stack[SP - 1]);
|
|
NEXT_OP;
|
|
OP(OP_SUB2)
|
|
do_sub2:
|
|
if (bothfixnums(Stack[SP - 2], Stack[SP - 1])) {
|
|
s = numval(Stack[SP - 2]) - numval(Stack[SP - 1]);
|
|
if (fits_fixnum(s))
|
|
v = fixnum(s);
|
|
else
|
|
v = mk_long(s);
|
|
} else {
|
|
Stack[SP - 1] = fl_neg(Stack[SP - 1]);
|
|
v = fl_add_any(&Stack[SP - 2], 2, 0);
|
|
}
|
|
POPN(1);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
OP(OP_MUL)
|
|
n = *ip++;
|
|
apply_mul:
|
|
accum = 1;
|
|
i = SP - n;
|
|
for (; i < SP; i++) {
|
|
if (isfixnum(Stack[i])) {
|
|
accum *= numval(Stack[i]);
|
|
} else {
|
|
v = fl_mul_any(&Stack[i], SP - i, accum);
|
|
break;
|
|
}
|
|
}
|
|
if (i == SP) {
|
|
if (fits_fixnum(accum))
|
|
v = fixnum(accum);
|
|
else
|
|
v = return_from_int64(accum);
|
|
}
|
|
POPN(n);
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_DIV)
|
|
n = *ip++;
|
|
apply_div:
|
|
i = SP - n;
|
|
if (n == 1) {
|
|
Stack[SP - 1] = fl_div2(fixnum(1), Stack[i]);
|
|
} else {
|
|
if (n > 2) {
|
|
PUSH(Stack[i]);
|
|
Stack[i] = fixnum(1);
|
|
Stack[i + 1] = fl_mul_any(&Stack[i], n, 1);
|
|
Stack[i] = POP();
|
|
}
|
|
v = fl_div2(Stack[i], Stack[i + 1]);
|
|
POPN(n);
|
|
PUSH(v);
|
|
}
|
|
NEXT_OP;
|
|
OP(OP_IDIV)
|
|
v = Stack[SP - 2];
|
|
e = Stack[SP - 1];
|
|
if (bothfixnums(v, e)) {
|
|
if (e == 0)
|
|
DivideByZeroError();
|
|
v = fixnum(numval(v) / numval(e));
|
|
} else
|
|
v = fl_idiv2(v, e);
|
|
POPN(1);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
OP(OP_NUMEQ)
|
|
v = Stack[SP - 2];
|
|
e = Stack[SP - 1];
|
|
if (bothfixnums(v, e))
|
|
v = (v == e) ? FL_T : FL_F;
|
|
else
|
|
v = (!numeric_compare(v, e, 1, 0, "=")) ? FL_T : FL_F;
|
|
POPN(1);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
OP(OP_LT)
|
|
if (bothfixnums(Stack[SP - 2], Stack[SP - 1])) {
|
|
v =
|
|
(numval(Stack[SP - 2]) < numval(Stack[SP - 1])) ? FL_T : FL_F;
|
|
} else {
|
|
v = (numval(fl_compare(Stack[SP - 2], Stack[SP - 1])) < 0)
|
|
? FL_T
|
|
: FL_F;
|
|
}
|
|
POPN(1);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
OP(OP_COMPARE)
|
|
Stack[SP - 2] = compare_(Stack[SP - 2], Stack[SP - 1], 0);
|
|
POPN(1);
|
|
NEXT_OP;
|
|
|
|
OP(OP_VECTOR)
|
|
n = *ip++;
|
|
apply_vector:
|
|
v = alloc_vector(n, 0);
|
|
if (n) {
|
|
memcpy(&vector_elt(v, 0), &Stack[SP - n],
|
|
n * sizeof(value_t));
|
|
POPN(n);
|
|
}
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
|
|
OP(OP_AREF)
|
|
v = Stack[SP - 2];
|
|
if (isvector(v)) {
|
|
e = Stack[SP - 1];
|
|
if (isfixnum(e))
|
|
i = numval(e);
|
|
else
|
|
i = (uint32_t)toulong(e, "aref");
|
|
if ((unsigned)i >= vector_size(v))
|
|
bounds_error("aref", v, e);
|
|
v = vector_elt(v, i);
|
|
} else if (isarray(v)) {
|
|
v = cvalue_array_aref(&Stack[SP - 2]);
|
|
} else {
|
|
type_error("aref", "sequence", v);
|
|
}
|
|
POPN(1);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
OP(OP_ASET)
|
|
e = Stack[SP - 3];
|
|
if (isvector(e)) {
|
|
i = tofixnum(Stack[SP - 2], "aset!");
|
|
if ((unsigned)i >= vector_size(e))
|
|
bounds_error("aset!", v, Stack[SP - 1]);
|
|
vector_elt(e, i) = (v = Stack[SP - 1]);
|
|
} else if (isarray(e)) {
|
|
v = cvalue_array_aset(&Stack[SP - 3]);
|
|
} else {
|
|
type_error("aset!", "sequence", e);
|
|
}
|
|
POPN(2);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
OP(OP_FOR)
|
|
s = tofixnum(Stack[SP - 3], "for");
|
|
hi = tofixnum(Stack[SP - 2], "for");
|
|
// f = Stack[SP-1];
|
|
v = FL_UNSPECIFIED;
|
|
SP += 2;
|
|
n = SP;
|
|
for (; s <= hi; s++) {
|
|
Stack[SP - 2] = Stack[SP - 3];
|
|
Stack[SP - 1] = fixnum(s);
|
|
v = apply_cl(1);
|
|
SP = n;
|
|
}
|
|
POPN(4);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
|
|
OP(OP_LOADT) PUSH(FL_T);
|
|
NEXT_OP;
|
|
OP(OP_LOADF) PUSH(FL_F);
|
|
NEXT_OP;
|
|
OP(OP_LOADNIL) PUSH(NIL);
|
|
NEXT_OP;
|
|
OP(OP_LOAD0) PUSH(fixnum(0));
|
|
NEXT_OP;
|
|
OP(OP_LOAD1) PUSH(fixnum(1));
|
|
NEXT_OP;
|
|
OP(OP_LOADI8) s = (int8_t)*ip++;
|
|
PUSH(fixnum(s));
|
|
NEXT_OP;
|
|
OP(OP_LOADV)
|
|
v = fn_vals(Stack[bp - 1]);
|
|
assert(*ip < vector_size(v));
|
|
v = vector_elt(v, *ip);
|
|
ip++;
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_LOADVL)
|
|
v = fn_vals(Stack[bp - 1]);
|
|
v = vector_elt(v, GET_INT32(ip));
|
|
ip += 4;
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_LOADGL)
|
|
v = fn_vals(Stack[bp - 1]);
|
|
v = vector_elt(v, GET_INT32(ip));
|
|
ip += 4;
|
|
goto do_loadg;
|
|
OP(OP_LOADG)
|
|
v = fn_vals(Stack[bp - 1]);
|
|
assert(*ip < vector_size(v));
|
|
v = vector_elt(v, *ip);
|
|
ip++;
|
|
do_loadg:
|
|
assert(issymbol(v));
|
|
sym = (struct symbol *)ptr(v);
|
|
if (sym->binding == UNBOUND)
|
|
fl_raise(fl_list2(UnboundError, v));
|
|
PUSH(sym->binding);
|
|
NEXT_OP;
|
|
|
|
OP(OP_SETGL)
|
|
v = fn_vals(Stack[bp - 1]);
|
|
v = vector_elt(v, GET_INT32(ip));
|
|
ip += 4;
|
|
goto do_setg;
|
|
OP(OP_SETG)
|
|
v = fn_vals(Stack[bp - 1]);
|
|
assert(*ip < vector_size(v));
|
|
v = vector_elt(v, *ip);
|
|
ip++;
|
|
do_setg:
|
|
assert(issymbol(v));
|
|
sym = (struct symbol *)ptr(v);
|
|
v = Stack[SP - 1];
|
|
if (!isconstant(sym))
|
|
sym->binding = v;
|
|
NEXT_OP;
|
|
|
|
OP(OP_LOADA)
|
|
assert(nargs > 0);
|
|
i = *ip++;
|
|
if (captured) {
|
|
e = Stack[bp];
|
|
assert(isvector(e));
|
|
assert(i < vector_size(e));
|
|
v = vector_elt(e, i);
|
|
} else {
|
|
v = Stack[bp + i];
|
|
}
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_LOADA0)
|
|
if (captured)
|
|
v = vector_elt(Stack[bp], 0);
|
|
else
|
|
v = Stack[bp];
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_LOADA1)
|
|
if (captured)
|
|
v = vector_elt(Stack[bp], 1);
|
|
else
|
|
v = Stack[bp + 1];
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_LOADAL)
|
|
assert(nargs > 0);
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
if (captured)
|
|
v = vector_elt(Stack[bp], i);
|
|
else
|
|
v = Stack[bp + i];
|
|
PUSH(v);
|
|
NEXT_OP;
|
|
OP(OP_SETA)
|
|
assert(nargs > 0);
|
|
v = Stack[SP - 1];
|
|
i = *ip++;
|
|
if (captured) {
|
|
e = Stack[bp];
|
|
assert(isvector(e));
|
|
assert(i < vector_size(e));
|
|
vector_elt(e, i) = v;
|
|
} else {
|
|
Stack[bp + i] = v;
|
|
}
|
|
NEXT_OP;
|
|
OP(OP_SETAL)
|
|
assert(nargs > 0);
|
|
v = Stack[SP - 1];
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
if (captured)
|
|
vector_elt(Stack[bp], i) = v;
|
|
else
|
|
Stack[bp + i] = v;
|
|
NEXT_OP;
|
|
OP(OP_LOADC)
|
|
s = *ip++;
|
|
i = *ip++;
|
|
v = Stack[bp + nargs];
|
|
while (s--)
|
|
v = vector_elt(v, vector_size(v) - 1);
|
|
assert(isvector(v));
|
|
assert(i < vector_size(v));
|
|
PUSH(vector_elt(v, i));
|
|
NEXT_OP;
|
|
OP(OP_SETC)
|
|
s = *ip++;
|
|
i = *ip++;
|
|
v = Stack[bp + nargs];
|
|
while (s--)
|
|
v = vector_elt(v, vector_size(v) - 1);
|
|
assert(isvector(v));
|
|
assert(i < vector_size(v));
|
|
vector_elt(v, i) = Stack[SP - 1];
|
|
NEXT_OP;
|
|
OP(OP_LOADC00)
|
|
PUSH(vector_elt(Stack[bp + nargs], 0));
|
|
NEXT_OP;
|
|
OP(OP_LOADC01)
|
|
PUSH(vector_elt(Stack[bp + nargs], 1));
|
|
NEXT_OP;
|
|
OP(OP_LOADCL)
|
|
s = GET_INT32(ip);
|
|
ip += 4;
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
v = Stack[bp + nargs];
|
|
while (s--)
|
|
v = vector_elt(v, vector_size(v) - 1);
|
|
PUSH(vector_elt(v, i));
|
|
NEXT_OP;
|
|
OP(OP_SETCL)
|
|
s = GET_INT32(ip);
|
|
ip += 4;
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
v = Stack[bp + nargs];
|
|
while (s--)
|
|
v = vector_elt(v, vector_size(v) - 1);
|
|
assert(i < vector_size(v));
|
|
vector_elt(v, i) = Stack[SP - 1];
|
|
NEXT_OP;
|
|
|
|
OP(OP_CLOSURE)
|
|
// build a closure (lambda args body . env)
|
|
if (nargs > 0 && !captured) {
|
|
// save temporary environment to the heap
|
|
n = nargs;
|
|
pv = alloc_words(n + 2);
|
|
PUSH(tagptr(pv, TAG_VECTOR));
|
|
pv[0] = fixnum(n + 1);
|
|
pv++;
|
|
do {
|
|
pv[n] = Stack[bp + n];
|
|
} while (n--);
|
|
// environment representation changed; install
|
|
// the new representation so everybody can see it
|
|
captured = 1;
|
|
Stack[curr_frame - 1] = 1;
|
|
Stack[bp] = Stack[SP - 1];
|
|
} else {
|
|
PUSH(Stack[bp]); // env has already been captured; share
|
|
}
|
|
if (curheap > lim - 2)
|
|
gc(0);
|
|
pv = (value_t *)curheap;
|
|
curheap += (4 * sizeof(value_t));
|
|
e = Stack[SP - 2]; // closure to copy
|
|
assert(isfunction(e));
|
|
pv[0] = ((value_t *)ptr(e))[0];
|
|
pv[1] = ((value_t *)ptr(e))[1];
|
|
pv[2] = Stack[SP - 1]; // env
|
|
pv[3] = ((value_t *)ptr(e))[3];
|
|
POPN(1);
|
|
Stack[SP - 1] = tagptr(pv, TAG_FUNCTION);
|
|
NEXT_OP;
|
|
|
|
OP(OP_TRYCATCH)
|
|
v = do_trycatch();
|
|
POPN(1);
|
|
Stack[SP - 1] = v;
|
|
NEXT_OP;
|
|
|
|
OP(OP_OPTARGS)
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
n = GET_INT32(ip);
|
|
ip += 4;
|
|
if (nargs < i)
|
|
lerror(ArgError, "apply: too few arguments");
|
|
if ((int32_t)n > 0) {
|
|
if (nargs > n)
|
|
lerror(ArgError, "apply: too many arguments");
|
|
} else
|
|
n = -n;
|
|
if (n > nargs) {
|
|
n -= nargs;
|
|
SP += n;
|
|
Stack[SP - 1] = Stack[SP - n - 1];
|
|
Stack[SP - 2] = Stack[SP - n - 2];
|
|
Stack[SP - 3] = nargs + n;
|
|
Stack[SP - 4] = Stack[SP - n - 4];
|
|
Stack[SP - 5] = Stack[SP - n - 5];
|
|
curr_frame = SP;
|
|
for (i = 0; i < n; i++) {
|
|
Stack[bp + nargs + i] = UNBOUND;
|
|
}
|
|
nargs += n;
|
|
}
|
|
NEXT_OP;
|
|
OP(OP_KEYARGS)
|
|
v = fn_vals(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;
|
|
nargs =
|
|
process_keys(v, i, n, labs(s) - (i + n), bp, nargs, s < 0);
|
|
NEXT_OP;
|
|
|
|
#ifndef USE_COMPUTED_GOTO
|
|
default:
|
|
goto dispatch;
|
|
#endif
|
|
}
|
|
}
|
|
#ifdef USE_COMPUTED_GOTO
|
|
return UNBOUND; // not reached
|
|
#else
|
|
goto dispatch;
|
|
#endif
|
|
}
|
|
|
|
static uint32_t compute_maxstack(uint8_t *code, size_t len, int bswap)
|
|
{
|
|
uint8_t *ip = code + 4, *end = code + len;
|
|
uint8_t op;
|
|
uint32_t i, n, sp = 0, maxsp = 0;
|
|
|
|
while (1) {
|
|
if ((int32_t)sp > (int32_t)maxsp)
|
|
maxsp = sp;
|
|
if (ip >= end)
|
|
break;
|
|
op = *ip++;
|
|
switch (op) {
|
|
case OP_ARGC:
|
|
n = *ip++;
|
|
break;
|
|
case OP_VARGC:
|
|
n = *ip++;
|
|
sp += (n + 2);
|
|
break;
|
|
case OP_LARGC:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
n = GET_INT32(ip);
|
|
ip += 4;
|
|
break;
|
|
case OP_LVARGC:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
n = GET_INT32(ip);
|
|
ip += 4;
|
|
sp += (n + 2);
|
|
break;
|
|
case OP_OPTARGS:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
n = abs(GET_INT32(ip));
|
|
ip += 4;
|
|
sp += (n - i);
|
|
break;
|
|
case OP_KEYARGS:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
i = GET_INT32(ip);
|
|
ip += 4;
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
n = GET_INT32(ip);
|
|
ip += 4;
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
n = abs(GET_INT32(ip));
|
|
ip += 4;
|
|
sp += (n - i);
|
|
break;
|
|
case OP_BRBOUND:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
sp++;
|
|
break;
|
|
|
|
case OP_TCALL:
|
|
case OP_CALL:
|
|
n = *ip++; // nargs
|
|
sp -= n;
|
|
break;
|
|
case OP_TCALLL:
|
|
case OP_CALLL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
n = GET_INT32(ip);
|
|
ip += 4;
|
|
sp -= n;
|
|
break;
|
|
case OP_JMP:
|
|
if (bswap)
|
|
SWAP_INT16(ip);
|
|
ip += 2;
|
|
break;
|
|
case OP_JMPL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
break;
|
|
case OP_BRF:
|
|
case OP_BRT:
|
|
if (bswap)
|
|
SWAP_INT16(ip);
|
|
ip += 2;
|
|
sp--;
|
|
break;
|
|
case OP_BRFL:
|
|
case OP_BRTL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
sp--;
|
|
break;
|
|
case OP_BRNE:
|
|
if (bswap)
|
|
SWAP_INT16(ip);
|
|
ip += 2;
|
|
sp -= 2;
|
|
break;
|
|
case OP_BRNEL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
sp -= 2;
|
|
break;
|
|
case OP_BRNN:
|
|
case OP_BRN:
|
|
if (bswap)
|
|
SWAP_INT16(ip);
|
|
ip += 2;
|
|
sp--;
|
|
break;
|
|
case OP_BRNNL:
|
|
case OP_BRNL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
sp--;
|
|
break;
|
|
case OP_RET:
|
|
sp--;
|
|
break;
|
|
|
|
case OP_CONS:
|
|
case OP_SETCAR:
|
|
case OP_SETCDR:
|
|
case OP_POP:
|
|
case OP_EQ:
|
|
case OP_EQV:
|
|
case OP_EQUAL:
|
|
case OP_ADD2:
|
|
case OP_SUB2:
|
|
case OP_IDIV:
|
|
case OP_NUMEQ:
|
|
case OP_LT:
|
|
case OP_COMPARE:
|
|
case OP_AREF:
|
|
case OP_TRYCATCH:
|
|
sp--;
|
|
break;
|
|
|
|
case OP_PAIRP:
|
|
case OP_ATOMP:
|
|
case OP_NOT:
|
|
case OP_NULLP:
|
|
case OP_BOOLEANP:
|
|
case OP_SYMBOLP:
|
|
case OP_NUMBERP:
|
|
case OP_FIXNUMP:
|
|
case OP_BOUNDP:
|
|
case OP_BUILTINP:
|
|
case OP_FUNCTIONP:
|
|
case OP_VECTORP:
|
|
case OP_NOP:
|
|
case OP_CAR:
|
|
case OP_CDR:
|
|
case OP_NEG:
|
|
case OP_CLOSURE:
|
|
break;
|
|
|
|
case OP_TAPPLY:
|
|
case OP_APPLY:
|
|
n = *ip++;
|
|
sp -= (n - 1);
|
|
break;
|
|
|
|
case OP_LIST:
|
|
case OP_ADD:
|
|
case OP_SUB:
|
|
case OP_MUL:
|
|
case OP_DIV:
|
|
case OP_VECTOR:
|
|
n = *ip++;
|
|
sp -= (n - 1);
|
|
break;
|
|
|
|
case OP_ASET:
|
|
sp -= 2;
|
|
break;
|
|
case OP_FOR:
|
|
if (sp + 2 > maxsp)
|
|
maxsp = sp + 2;
|
|
sp -= 2;
|
|
break;
|
|
|
|
case OP_LOADT:
|
|
case OP_LOADF:
|
|
case OP_LOADNIL:
|
|
case OP_LOAD0:
|
|
case OP_LOAD1:
|
|
case OP_LOADA0:
|
|
case OP_LOADA1:
|
|
case OP_LOADC00:
|
|
case OP_LOADC01:
|
|
case OP_DUP:
|
|
sp++;
|
|
break;
|
|
|
|
case OP_LOADI8:
|
|
case OP_LOADV:
|
|
case OP_LOADG:
|
|
case OP_LOADA:
|
|
ip++;
|
|
sp++;
|
|
break;
|
|
case OP_LOADVL:
|
|
case OP_LOADGL:
|
|
case OP_LOADAL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
sp++;
|
|
break;
|
|
|
|
case OP_SETG:
|
|
case OP_SETA:
|
|
ip++;
|
|
break;
|
|
case OP_SETGL:
|
|
case OP_SETAL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
break;
|
|
|
|
case OP_LOADC:
|
|
ip += 2;
|
|
sp++;
|
|
break;
|
|
case OP_SETC:
|
|
ip += 2;
|
|
break;
|
|
case OP_LOADCL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
sp++;
|
|
break;
|
|
case OP_SETCL:
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
if (bswap)
|
|
SWAP_INT32(ip);
|
|
ip += 4;
|
|
break;
|
|
}
|
|
}
|
|
return maxsp + 5;
|
|
}
|
|
|
|
// top = top frame pointer to start at
|
|
static value_t _stacktrace(uint32_t top)
|
|
{
|
|
uint32_t bp, sz;
|
|
value_t v, lst = NIL;
|
|
fl_gc_handle(&lst);
|
|
while (top > 0) {
|
|
sz = Stack[top - 3] + 1;
|
|
bp = top - 5 - sz;
|
|
v = alloc_vector(sz, 0);
|
|
if (Stack[top - 1] /*captured*/) {
|
|
vector_elt(v, 0) = Stack[bp];
|
|
memcpy(&vector_elt(v, 1), &vector_elt(Stack[bp + 1], 0),
|
|
(sz - 1) * sizeof(value_t));
|
|
} else {
|
|
uint32_t i;
|
|
for (i = 0; i < sz; i++) {
|
|
value_t si = 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) = (si == UNBOUND ? FL_UNSPECIFIED : si);
|
|
}
|
|
}
|
|
lst = fl_cons(v, lst);
|
|
top = Stack[top - 4];
|
|
}
|
|
fl_free_gc_handles(1);
|
|
return lst;
|
|
}
|
|
|
|
// builtins
|
|
// -------------------------------------------------------------------
|
|
|
|
void assign_global_builtins(struct builtinspec *b)
|
|
{
|
|
while (b->name != NULL) {
|
|
setc(symbol(b->name), cbuiltin(b->name, b->fptr));
|
|
b++;
|
|
}
|
|
}
|
|
|
|
static value_t fl_function(value_t *args, uint32_t nargs)
|
|
{
|
|
struct cvalue *arr;
|
|
char *data;
|
|
int swap;
|
|
uint32_t ms;
|
|
struct function *fn;
|
|
value_t fv;
|
|
|
|
if (nargs == 1 && issymbol(args[0]))
|
|
return fl_builtin(args, nargs);
|
|
if (nargs < 2 || nargs > 4)
|
|
argcount("function", nargs, 2);
|
|
if (!fl_isstring(args[0]))
|
|
type_error("function", "string", args[0]);
|
|
if (!isvector(args[1]))
|
|
type_error("function", "vector", args[1]);
|
|
arr = (struct cvalue *)ptr(args[0]);
|
|
cv_pin(arr);
|
|
data = cv_data(arr);
|
|
swap = 0;
|
|
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;
|
|
} else {
|
|
#if __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
|
|
swap = 1;
|
|
#endif
|
|
}
|
|
ms = compute_maxstack((uint8_t *)data, cv_len(arr), swap);
|
|
PUT_INT32(data, ms);
|
|
fn = (struct function *)alloc_words(4);
|
|
fv = tagptr(fn, TAG_FUNCTION);
|
|
fn->bcode = args[0];
|
|
fn->vals = args[1];
|
|
fn->env = NIL;
|
|
fn->name = 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 (!issymbol(args[3]))
|
|
type_error("function", "symbol", args[3]);
|
|
fn->name = args[3];
|
|
}
|
|
}
|
|
if (isgensym(fn->name))
|
|
lerror(ArgError, "function: name should not be a gensym");
|
|
}
|
|
return fv;
|
|
}
|
|
|
|
static value_t fl_function_code(value_t *args, uint32_t nargs)
|
|
{
|
|
value_t v;
|
|
|
|
argcount("function:code", nargs, 1);
|
|
v = args[0];
|
|
if (!isclosure(v))
|
|
type_error("function:code", "function", v);
|
|
return fn_bcode(v);
|
|
}
|
|
static value_t fl_function_vals(value_t *args, uint32_t nargs)
|
|
{
|
|
value_t v;
|
|
|
|
argcount("function:vals", nargs, 1);
|
|
v = args[0];
|
|
if (!isclosure(v))
|
|
type_error("function:vals", "function", v);
|
|
return fn_vals(v);
|
|
}
|
|
static value_t fl_function_env(value_t *args, uint32_t nargs)
|
|
{
|
|
value_t v;
|
|
|
|
argcount("function:env", nargs, 1);
|
|
v = args[0];
|
|
if (!isclosure(v))
|
|
type_error("function:env", "function", v);
|
|
return fn_env(v);
|
|
}
|
|
static value_t fl_function_name(value_t *args, uint32_t nargs)
|
|
{
|
|
value_t v;
|
|
|
|
argcount("function:name", nargs, 1);
|
|
v = args[0];
|
|
if (!isclosure(v))
|
|
type_error("function:name", "function", v);
|
|
return fn_name(v);
|
|
}
|
|
|
|
value_t fl_copylist(value_t *args, uint32_t nargs)
|
|
{
|
|
argcount("copy-list", nargs, 1);
|
|
return copy_list(args[0]);
|
|
}
|
|
|
|
value_t fl_append(value_t *args, uint32_t nargs)
|
|
{
|
|
value_t first, lst, lastcons;
|
|
uint32_t i;
|
|
|
|
if (nargs == 0)
|
|
return NIL;
|
|
first = lastcons = NIL;
|
|
fl_gc_handle(&first);
|
|
fl_gc_handle(&lastcons);
|
|
i = 0;
|
|
while (1) {
|
|
lst = args[i++];
|
|
if (i >= nargs)
|
|
break;
|
|
if (iscons(lst)) {
|
|
lst = copy_list(lst);
|
|
if (first == NIL)
|
|
first = lst;
|
|
else
|
|
cdr_(lastcons) = lst;
|
|
lastcons = tagptr((((struct cons *)curheap) - 1), TAG_CONS);
|
|
} else if (lst != NIL) {
|
|
type_error("append", "cons", lst);
|
|
}
|
|
}
|
|
if (first == NIL)
|
|
first = lst;
|
|
else
|
|
cdr_(lastcons) = lst;
|
|
fl_free_gc_handles(2);
|
|
return first;
|
|
}
|
|
|
|
value_t fl_liststar(value_t *args, uint32_t nargs)
|
|
{
|
|
if (nargs == 1)
|
|
return args[0];
|
|
else if (nargs == 0)
|
|
argcount("list*", nargs, 1);
|
|
return _list(args, nargs, 1);
|
|
}
|
|
|
|
value_t fl_stacktrace(value_t *args, uint32_t nargs)
|
|
{
|
|
(void)args;
|
|
argcount("stacktrace", nargs, 0);
|
|
return _stacktrace(fl_throwing_frame ? fl_throwing_frame : curr_frame);
|
|
}
|
|
|
|
value_t fl_map1(value_t *args, uint32_t nargs)
|
|
{
|
|
value_t first, last, v;
|
|
int64_t argSP;
|
|
|
|
if (nargs < 2)
|
|
lerror(ArgError, "map: too few arguments");
|
|
if (!iscons(args[1]))
|
|
return NIL;
|
|
argSP = args - Stack;
|
|
assert(argSP >= 0 && argSP < N_STACK);
|
|
if (nargs == 2) {
|
|
if (SP + 3 > N_STACK)
|
|
grow_stack();
|
|
PUSH(Stack[argSP]);
|
|
PUSH(car_(Stack[argSP + 1]));
|
|
v = _applyn(1);
|
|
PUSH(v);
|
|
v = mk_cons();
|
|
car_(v) = POP();
|
|
cdr_(v) = NIL;
|
|
last = first = v;
|
|
Stack[argSP + 1] = cdr_(Stack[argSP + 1]);
|
|
fl_gc_handle(&first);
|
|
fl_gc_handle(&last);
|
|
while (iscons(Stack[argSP + 1])) {
|
|
Stack[SP - 2] = Stack[argSP];
|
|
Stack[SP - 1] = car_(Stack[argSP + 1]);
|
|
v = _applyn(1);
|
|
PUSH(v);
|
|
v = mk_cons();
|
|
car_(v) = POP();
|
|
cdr_(v) = NIL;
|
|
cdr_(last) = v;
|
|
last = v;
|
|
Stack[argSP + 1] = cdr_(Stack[argSP + 1]);
|
|
}
|
|
POPN(2);
|
|
fl_free_gc_handles(2);
|
|
} else {
|
|
size_t i;
|
|
|
|
while (SP + nargs + 1 > N_STACK)
|
|
grow_stack();
|
|
PUSH(Stack[argSP]);
|
|
for (i = 1; i < nargs; i++) {
|
|
PUSH(car(Stack[argSP + i]));
|
|
Stack[argSP + i] = cdr_(Stack[argSP + i]);
|
|
}
|
|
v = _applyn(nargs - 1);
|
|
POPN(nargs);
|
|
PUSH(v);
|
|
v = mk_cons();
|
|
car_(v) = POP();
|
|
cdr_(v) = NIL;
|
|
last = first = v;
|
|
fl_gc_handle(&first);
|
|
fl_gc_handle(&last);
|
|
while (iscons(Stack[argSP + 1])) {
|
|
PUSH(Stack[argSP]);
|
|
for (i = 1; i < nargs; i++) {
|
|
PUSH(car(Stack[argSP + i]));
|
|
Stack[argSP + i] = cdr_(Stack[argSP + i]);
|
|
}
|
|
v = _applyn(nargs - 1);
|
|
POPN(nargs);
|
|
PUSH(v);
|
|
v = mk_cons();
|
|
car_(v) = POP();
|
|
cdr_(v) = NIL;
|
|
cdr_(last) = v;
|
|
last = v;
|
|
}
|
|
fl_free_gc_handles(2);
|
|
}
|
|
return first;
|
|
}
|
|
|
|
static struct builtinspec core_builtin_info[] = {
|
|
{ "function", fl_function },
|
|
{ "function:code", fl_function_code },
|
|
{ "function:vals", fl_function_vals },
|
|
{ "function:env", fl_function_env },
|
|
{ "function:name", fl_function_name },
|
|
{ "stacktrace", fl_stacktrace },
|
|
{ "gensym", fl_gensym },
|
|
{ "gensym?", fl_gensymp },
|
|
{ "hash", fl_hash },
|
|
{ "copy-list", fl_copylist },
|
|
{ "append", fl_append },
|
|
{ "list*", fl_liststar },
|
|
{ "map", fl_map1 },
|
|
{ NULL, NULL }
|
|
};
|
|
|
|
// initialization
|
|
// -------------------------------------------------------------
|
|
|
|
extern void builtins_init(void);
|
|
extern void comparehash_init(void);
|
|
|
|
static void lisp_init(size_t initial_heapsize)
|
|
{
|
|
char buf[1024];
|
|
char *exename;
|
|
int i;
|
|
|
|
llt_init();
|
|
setlocale(LC_NUMERIC, "C");
|
|
|
|
heapsize = initial_heapsize;
|
|
|
|
fromspace = malloc(heapsize);
|
|
tospace = malloc(heapsize);
|
|
curheap = fromspace;
|
|
lim = curheap + heapsize - sizeof(struct cons);
|
|
consflags = bitvector_new(heapsize / sizeof(struct cons), 1);
|
|
comparehash_init();
|
|
N_STACK = 262144;
|
|
Stack = malloc(N_STACK * sizeof(value_t));
|
|
|
|
FL_NIL = 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);
|
|
LAMBDA = symbol("lambda");
|
|
FUNCTION = symbol("function");
|
|
QUOTE = symbol("quote");
|
|
TRYCATCH = symbol("trycatch");
|
|
BACKQUOTE = symbol("quasiquote");
|
|
COMMA = symbol("unquote");
|
|
COMMAAT = symbol("unquote-splicing");
|
|
COMMADOT = symbol("unquote-nsplicing");
|
|
IOError = symbol("io-error");
|
|
ParseError = symbol("parse-error");
|
|
TypeError = symbol("type-error");
|
|
ArgError = symbol("arg-error");
|
|
UnboundError = symbol("unbound-error");
|
|
KeyError = symbol("key-error");
|
|
MemoryError = symbol("memory-error");
|
|
BoundsError = symbol("bounds-error");
|
|
DivideError = symbol("divide-error");
|
|
EnumerationError = symbol("enumeration-error");
|
|
Error = symbol("error");
|
|
pairsym = symbol("pair");
|
|
symbolsym = symbol("symbol");
|
|
fixnumsym = symbol("fixnum");
|
|
vectorsym = symbol("vector");
|
|
builtinsym = symbol("builtin");
|
|
booleansym = symbol("boolean");
|
|
nullsym = symbol("null");
|
|
definesym = symbol("define");
|
|
defmacrosym = symbol("define-macro");
|
|
forsym = symbol("for");
|
|
setqsym = symbol("set!");
|
|
evalsym = symbol("eval");
|
|
vu8sym = symbol("vu8");
|
|
fnsym = symbol("fn");
|
|
nulsym = symbol("nul");
|
|
alarmsym = symbol("alarm");
|
|
backspacesym = symbol("backspace");
|
|
tabsym = symbol("tab");
|
|
linefeedsym = symbol("linefeed");
|
|
vtabsym = symbol("vtab");
|
|
pagesym = symbol("page");
|
|
returnsym = symbol("return");
|
|
escsym = symbol("esc");
|
|
spacesym = symbol("space");
|
|
deletesym = symbol("delete");
|
|
newlinesym = symbol("newline");
|
|
tsym = symbol("t");
|
|
Tsym = symbol("T");
|
|
fsym = symbol("f");
|
|
Fsym = symbol("F");
|
|
set(printprettysym = symbol("*print-pretty*"), FL_T);
|
|
set(printreadablysym = symbol("*print-readably*"), FL_T);
|
|
set(printwidthsym = symbol("*print-width*"), fixnum(80));
|
|
set(printlengthsym = symbol("*print-length*"), FL_F);
|
|
set(printlevelsym = symbol("*print-level*"), FL_F);
|
|
builtins_table_sym = symbol("*builtins*");
|
|
fl_lasterror = NIL;
|
|
i = 0;
|
|
for (i = OP_EQ; i <= OP_ASET; i++) {
|
|
setc(symbol(builtin_names[i]), builtin(i));
|
|
}
|
|
setc(symbol("eq"), builtin(OP_EQ));
|
|
setc(symbol("procedure?"), builtin(OP_FUNCTIONP));
|
|
setc(symbol("top-level-bound?"), builtin(OP_BOUNDP));
|
|
|
|
set(symbol("*os-name*"), symbol(env_get_os_name()));
|
|
|
|
the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR);
|
|
vector_setsize(the_empty_vector, 0);
|
|
|
|
cvalues_init();
|
|
|
|
exename = get_exename(buf, sizeof(buf));
|
|
if (exename != NULL) {
|
|
path_to_dirname(exename);
|
|
setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename)));
|
|
}
|
|
|
|
memory_exception_value =
|
|
fl_list2(MemoryError, cvalue_static_cstring("out of memory"));
|
|
|
|
assign_global_builtins(core_builtin_info);
|
|
|
|
builtins_init();
|
|
}
|
|
|
|
// top level
|
|
// ------------------------------------------------------------------
|
|
|
|
value_t fl_toplevel_eval(value_t expr)
|
|
{
|
|
return fl_applyn(1, symbol_value(evalsym), expr);
|
|
}
|
|
|
|
void fl_init(size_t initial_heapsize) { lisp_init(initial_heapsize); }
|
|
|
|
int fl_load_boot_image(void)
|
|
{
|
|
value_t e, f;
|
|
int saveSP;
|
|
struct ios *s;
|
|
struct symbol *sym;
|
|
|
|
f = cvalue(iostreamtype, sizeof(struct ios));
|
|
s = value2c(struct ios *, f);
|
|
ios_static_buffer(s, boot_image, boot_image_size);
|
|
PUSH(f);
|
|
saveSP = SP;
|
|
{
|
|
FL_TRY
|
|
{
|
|
while (1) {
|
|
e = fl_read_sexpr(Stack[SP - 1]);
|
|
if (ios_eof(value2c(struct ios *, Stack[SP - 1])))
|
|
break;
|
|
if (isfunction(e)) {
|
|
// stage 0 format: series of thunks
|
|
PUSH(e);
|
|
(void)_applyn(0);
|
|
SP = saveSP;
|
|
} else {
|
|
// stage 1 format: list alternating symbol/value
|
|
while (iscons(e)) {
|
|
sym = tosymbol(car_(e), "bootstrap");
|
|
e = cdr_(e);
|
|
(void)tocons(e, "bootstrap");
|
|
sym->binding = car_(e);
|
|
e = cdr_(e);
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
FL_CATCH
|
|
{
|
|
ios_puts("fatal error during bootstrap:\n", ios_stderr);
|
|
write_defaults_indent(ios_stderr, fl_lasterror);
|
|
ios_putc('\n', ios_stderr);
|
|
return 1;
|
|
}
|
|
}
|
|
ios_close(value2c(struct ios *, Stack[SP - 1]));
|
|
POPN(1);
|
|
return 0;
|
|
}
|