ref: b76bbe37247399331e39bfbbef8724bb2520065d
dir: /femtolisp/flisp.c/
/*
femtoLisp
a minimal interpreter for a minimal lisp dialect
this lisp dialect uses lexical scope and self-evaluating lambda.
it supports 30-bit integers, symbols, conses, and full macros.
it is case-sensitive.
it features a simple compacting copying garbage collector.
it uses a Scheme-style evaluation rule where any expression may appear in
head position as long as it evaluates to a function.
it uses Scheme-style varargs (dotted formal argument lists)
lambdas can have only 1 body expression; use (progn ...) for multiple
expressions. this is due to the closure representation
(lambda args body . env)
This is a fork of femtoLisp with advanced reading and printing facilities:
* circular structure can be printed and read
* #. read macro for eval-when-read and correctly printing builtins
* read macros for backquote
* symbol character-escaping printer
* new print algorithm
1. traverse & tag all conses to be printed. when you encounter a cons
that is already tagged, add it to a table to give it a #n# index
2. untag a cons when printing it. if cons is in the table, print
"#n=" before it in the car, " . #n=" in the cdr. if cons is in the
table but already untagged, print #n# in car or " . #n#" in the cdr.
* read macros for #n# and #n= using the same kind of table
* also need a table of read labels to translate from input indexes to
normalized indexes (0 for first label, 1 for next, etc.)
* read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
The value of this extra complexity, and what makes this fork worthy of
the femtoLisp brand, is that the interpreter is fully "closed" in the
sense that all representable values can be read and printed.
This is a fully fleshed-out lisp built up from femtoLisp. It has all the
remaining features needed to be taken seriously:
* vectors
* exceptions
* gensyms (can be usefully read back in, too)
* #| multiline comments |#
* generic compare function
* cvalues system providing C data types and a C FFI
* constructor notation for nicely printing arbitrary values
* cyclic equal
* strings
- hash tables
by Jeff Bezanson
Public Domain
*/
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <setjmp.h>
#include <stdarg.h>
#include <assert.h>
#include <ctype.h>
#include <wctype.h>
#include <sys/types.h>
#include <locale.h>
#include <limits.h>
#include <errno.h>
#include "llt.h"
#include "flisp.h"
static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda",
"trycatch", "progn",
"eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
"builtinp", "vectorp", "fixnump", "equal",
"cons", "car", "cdr", "rplaca", "rplacd",
"eval", "apply", "set", "prog1", "raise",
"+", "-", "*", "/", "<", "~", "&", "!", "$",
"vector", "aref", "aset", "length", "assoc", "compare" };
static char *stack_bottom;
#define PROCESS_STACK_SIZE (2*1024*1024)
#define N_STACK 98304
value_t Stack[N_STACK];
u_int32_t SP = 0;
value_t NIL, T, LAMBDA, QUOTE, VECTOR, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
static value_t eval_sexpr(value_t e, value_t *penv, int tail);
static value_t *alloc_words(int n);
static value_t relocate(value_t v);
static void do_print(FILE *f, value_t v, int princ);
typedef struct _readstate_t {
ptrhash_t backrefs;
ptrhash_t gensyms;
struct _readstate_t *prev;
} readstate_t;
static readstate_t *readstate = NULL;
static void free_readstate(readstate_t *rs)
{
ptrhash_free(&rs->backrefs);
ptrhash_free(&rs->gensyms);
}
static unsigned char *fromspace;
static unsigned char *tospace;
static unsigned char *curheap;
static unsigned char *lim;
static u_int32_t heapsize = 256*1024;//bytes
static u_int32_t *consflags;
static u_int32_t printlabel;
// error utilities ------------------------------------------------------------
// saved execution state for an unwind target
typedef struct _ectx_t {
jmp_buf buf;
u_int32_t sp;
readstate_t *rdst;
struct _ectx_t *prev;
} exception_context_t;
static exception_context_t *ctx = NULL;
static value_t lasterror;
static char lerrorbuf[512];
#define FL_TRY \
exception_context_t _ctx; int l__tr, l__ca; \
_ctx.sp=SP; _ctx.rdst=readstate; _ctx.prev=ctx; \
ctx = &_ctx; \
if (!setjmp(_ctx.buf)) \
for (l__tr=1; l__tr; l__tr=0, (void)(ctx->prev && (ctx=ctx->prev)))
#define FL_CATCH \
else \
for (l__ca=1; l__ca; l__ca=0, lerrorbuf[0]='\0', lasterror=NIL)
void raise(value_t e)
{
if (e != lasterror) {
lasterror = e;
lerrorbuf[0] = '\0'; // overwriting exception; clear error buf
}
// unwind read state
while (readstate != ctx->rdst) {
free_readstate(readstate);
readstate = readstate->prev;
}
SP = ctx->sp;
exception_context_t *thisctx = ctx;
if (ctx->prev) // don't throw past toplevel
ctx = ctx->prev;
longjmp(thisctx->buf, 1);
}
void lerror(value_t e, char *format, ...)
{
va_list args;
va_start(args, format);
vsnprintf(lerrorbuf, sizeof(lerrorbuf), format, args);
va_end(args);
lasterror = e;
raise(e);
}
void type_error(char *fname, char *expected, value_t got)
{
raise(listn(4, TypeError, symbol(fname), symbol(expected), got));
}
void bounds_error(char *fname, value_t arr, value_t ind)
{
lerror(listn(3, BoundsError, arr, ind), "%s: index out of bounds", fname);
}
// safe cast operators --------------------------------------------------------
#define SAFECAST_OP(type,ctype,cnvt) \
ctype to##type(value_t v, char *fname) \
{ \
if (is##type(v)) \
return (ctype)cnvt(v); \
type_error(fname, #type, v); \
return (ctype)0; \
}
SAFECAST_OP(cons, cons_t*, ptr)
SAFECAST_OP(symbol,symbol_t*,ptr)
SAFECAST_OP(fixnum,fixnum_t, numval)
SAFECAST_OP(cvalue,cvalue_t*,ptr)
SAFECAST_OP(string,char*, cvalue_data)
// symbol table ---------------------------------------------------------------
symbol_t *symtab = NULL;
static symbol_t *mk_symbol(char *str)
{
symbol_t *sym;
sym = (symbol_t*)malloc(sizeof(symbol_t) - sizeof(void*) + strlen(str)+1);
sym->left = sym->right = NULL;
sym->binding = UNBOUND;
sym->syntax = 0;
strcpy(&sym->name[0], str);
return sym;
}
static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
{
int x;
while(*ptree != NULL) {
x = strcmp(str, (*ptree)->name);
if (x == 0)
return ptree;
if (x < 0)
ptree = &(*ptree)->left;
else
ptree = &(*ptree)->right;
}
return ptree;
}
value_t symbol(char *str)
{
symbol_t **pnode;
pnode = symtab_lookup(&symtab, str);
if (*pnode == NULL)
*pnode = mk_symbol(str);
return tagptr(*pnode, TAG_SYM);
}
typedef struct {
value_t binding; // global value binding
value_t syntax; // syntax environment entry
void *dlcache; // dlsym address
u_int32_t id;
} gensym_t;
static u_int32_t _gensym_ctr=0;
// two static buffers for gensym printing so there can be two
// gensym names available at a time, mostly for compare()
static char gsname[2][16];
static int gsnameno=0;
value_t gensym(value_t *args, u_int32_t nargs)
{
(void)args;
(void)nargs;
gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
gs->id = _gensym_ctr++;
gs->binding = UNBOUND;
gs->syntax = 0;
return tagptr(gs, TAG_SYM);
}
value_t fl_gensym()
{
return gensym(NULL, 0);
}
static char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g)
{
size_t i=n-1;
nbuf[i--] = '\0';
do {
nbuf[i--] = '0' + g%10;
g/=10;
} while (g && i);
nbuf[i] = 'g';
return &nbuf[i];
}
char *symbol_name(value_t v)
{
if (ismanaged(v)) {
gensym_t *gs = (gensym_t*)ptr(v);
gsnameno = 1-gsnameno;
return snprintf_gensym_id(gsname[gsnameno], sizeof(gsname[0]), gs->id);
}
return ((symbol_t*)ptr(v))->name;
}
// conses ---------------------------------------------------------------------
void gc(int mustgrow);
static value_t mk_cons(void)
{
cons_t *c;
if (curheap > lim)
gc(0);
c = (cons_t*)curheap;
curheap += sizeof(cons_t);
return tagptr(c, TAG_CONS);
}
static value_t *alloc_words(int n)
{
value_t *first;
// the minimum allocation is a 2-word block
if (n < 2) n = 2;
if ((value_t*)curheap > ((value_t*)lim)+2-n) {
gc(0);
while ((value_t*)curheap > ((value_t*)lim)+2-n) {
gc(1);
}
}
first = (value_t*)curheap;
curheap += (n*sizeof(value_t));
return first;
}
// allocate n consecutive conses
#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
#define ismarked(c) bitvector_get(consflags, cons_index(c))
#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
value_t alloc_vector(size_t n, int init)
{
value_t *c = alloc_words(n+1);
value_t v = tagptr(c, TAG_BUILTIN);
vector_setsize(v, n);
if (init) {
unsigned int i;
for(i=0; i < n; i++)
vector_elt(v, i) = NIL;
}
return v;
}
// print ----------------------------------------------------------------------
static int isnumtok(char *tok, value_t *pval);
static int symchar(char c);
#include "print.c"
// cvalues --------------------------------------------------------------------
#include "cvalues.c"
// collector ------------------------------------------------------------------
static value_t relocate(value_t v)
{
value_t a, d, nc, first, *pcdr;
if (isfixnum(v))
return(v);
else if (iscons(v)) {
// iterative implementation allows arbitrarily long cons chains
pcdr = &first;
do {
if ((a=car_(v)) == UNBOUND) {
*pcdr = cdr_(v);
return first;
}
*pcdr = nc = mk_cons();
d = cdr_(v);
car_(v) = UNBOUND; cdr_(v) = nc;
car_(nc) = relocate(a);
pcdr = &cdr_(nc);
v = d;
} while (iscons(v));
*pcdr = (d==NIL) ? NIL : relocate(d);
return first;
}
else if (isvectorish(v)) {
if (discriminateAsVector(v)) {
// 0-length vectors secretly have space for a first element
if (vector_elt(v,0) == UNBOUND)
return vector_elt(v,-1);
size_t i, newsz, sz = vector_size(v);
newsz = sz;
if (vector_elt(v,-1) & 0x1)
newsz += vector_grow_amt(sz);
nc = alloc_vector(newsz, 0);
a = vector_elt(v,0);
vector_elt(v,0) = UNBOUND;
vector_elt(v,-1) = nc;
i = 0;
if (sz > 0) {
vector_elt(nc,0) = relocate(a); i++;
for(; i < sz; i++)
vector_elt(nc,i) = relocate(vector_elt(v,i));
}
for(; i < newsz; i++)
vector_elt(nc,i) = NIL;
return nc;
}
else {
return cvalue_relocate(v);
}
}
else if (ismanaged(v)) {
assert(issymbol(v));
gensym_t *gs = (gensym_t*)ptr(v);
if (gs->id == 0xffffffff)
return gs->binding;
gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
*ng = *gs;
gs->id = 0xffffffff;
nc = tagptr(ng, TAG_SYM);
gs->binding = nc;
if (ng->binding != UNBOUND)
ng->binding = relocate(ng->binding);
return nc;
}
return v;
}
static void trace_globals(symbol_t *root)
{
while (root != NULL) {
root->binding = relocate(root->binding);
if (iscons(root->syntax))
root->syntax = relocate(root->syntax);
trace_globals(root->left);
root = root->right;
}
}
void gc(int mustgrow)
{
static int grew = 0;
void *temp;
u_int32_t i;
readstate_t *rs;
curheap = tospace;
lim = curheap+heapsize-sizeof(cons_t);
for (i=0; i < SP; i++)
Stack[i] = relocate(Stack[i]);
trace_globals(symtab);
rs = readstate;
while (rs) {
for(i=0; i < rs->backrefs.size; i++)
rs->backrefs.table[i] = (void*)relocate((value_t)rs->backrefs.table[i]);
for(i=0; i < rs->gensyms.size; i++)
rs->gensyms.table[i] = (void*)relocate((value_t)rs->gensyms.table[i]);
rs = rs->prev;
}
lasterror = relocate(lasterror);
#ifdef VERBOSEGC
printf("gc found %d/%d live conses\n",
(curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
#endif
temp = tospace;
tospace = fromspace;
fromspace = temp;
// if we're using > 80% of the space, resize tospace so we have
// more space to fill next time. if we grew tospace last time,
// grow the other half of the heap this time to catch up.
if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {
temp = realloc(tospace, grew ? heapsize : heapsize*2);
if (temp == NULL)
lerror(MemoryError, "out of memory");
tospace = temp;
if (!grew) {
heapsize*=2;
}
else {
temp = bitvector_resize(consflags, heapsize/sizeof(cons_t), 1);
if (temp == NULL)
lerror(MemoryError, "out of memory");
consflags = (u_int32_t*)temp;
}
grew = !grew;
}
if (curheap > lim) // all data was live
gc(0);
}
// utils ----------------------------------------------------------------------
value_t apply(value_t f, value_t l)
{
PUSH(f);
PUSH(l);
value_t e = cons_reserve(5);
value_t x = e;
car_(e) = builtin(F_APPLY);
cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e);
// TODO: consider quoting this if it's a lambda expression
car_(e) = Stack[SP-2];
cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e);
car_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS);
cdr_(e) = NIL;
e = car_(e);
car_(e) = QUOTE;
cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e);
car_(e) = Stack[SP-1];
cdr_(e) = NIL;
POPN(2);
return toplevel_eval(x);
}
value_t listn(size_t n, ...)
{
va_list ap;
va_start(ap, n);
u_int32_t si = SP;
size_t i;
for(i=0; i < n; i++) {
value_t a = va_arg(ap, value_t);
PUSH(a);
}
cons_t *c = (cons_t*)alloc_words(n*2);
cons_t *l = c;
for(i=0; i < n; i++) {
c->car = Stack[si++];
c->cdr = tagptr(c+1, TAG_CONS);
c++;
}
(c-1)->cdr = NIL;
POPN(n);
va_end(ap);
return tagptr(l, TAG_CONS);
}
value_t list2(value_t a, value_t b)
{
PUSH(a);
PUSH(b);
cons_t *c = (cons_t*)alloc_words(4);
b = POP();
a = POP();
c[0].car = a;
c[0].cdr = tagptr(c+1, TAG_CONS);
c[1].car = b;
c[1].cdr = NIL;
return tagptr(c, TAG_CONS);
}
value_t fl_cons(value_t a, value_t b)
{
PUSH(a);
PUSH(b);
value_t c = mk_cons();
cdr_(c) = POP();
car_(c) = POP();
return c;
}
// NOTE: this is NOT an efficient operation. it is only used by the
// reader; vectors should not generally be resized.
// vector_grow requires at least 1 and up to 3 garbage collections!
static value_t vector_grow(value_t v)
{
size_t s = vector_size(v);
size_t d = vector_grow_amt(s);
PUSH(v);
// first allocate enough space to guarantee the heap will be big enough
// for the new vector
alloc_words(d);
// setting low bit of vector's size acts as a flag to the collector
// to grow this vector as it is relocated
((size_t*)ptr(Stack[SP-1]))[0] |= 0x1;
gc(0);
return POP();
}
extern value_t compare(value_t a, value_t b);
int isnumber(value_t v)
{
return (isfixnum(v) ||
(iscvalue(v) &&
valid_numtype(cv_numtype((cvalue_t*)ptr(v)))));
}
// read -----------------------------------------------------------------------
#include "read.c"
// eval -----------------------------------------------------------------------
// return a cons element of v whose car is item
static value_t assoc(value_t item, value_t v)
{
value_t bind;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == item)
return bind;
v = cdr_(v);
}
return NIL;
}
#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0))
#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1))
#define tail_eval(xpr) do { SP = saveSP; \
if (tag(xpr)<0x2) { return (xpr); } \
else { e=(xpr); goto eval_top; } } while (0)
static value_t do_trycatch(value_t expr, value_t *penv)
{
value_t v;
FL_TRY {
v = eval(expr);
}
FL_CATCH {
v = cdr_(Stack[SP-1]);
if (!iscons(v)) {
v = NIL; // 1-argument form
}
else {
Stack[SP-1] = car_(v);
value_t quoted = list2(QUOTE, lasterror);
expr = list2(Stack[SP-1], quoted);
v = eval(expr);
}
}
return v;
}
/* stack setup on entry:
n n+1 ...
+-----+-----+-----+-----+-----+-----+-----+-----+
| LL | VAL | VAL | CLO | | | | |
+-----+-----+-----+-----+-----+-----+-----+-----+
^ ^
| |
penv SP (who knows where)
where LL is the lambda list, CLO is a closed-up environment vector
(which can be empty, i.e. NIL). An environment vector is just a copy
of the stack from LL through CLO.
There might be zero values, in which case LL is NIL.
if tail==1, you are allowed (indeed encouraged) to overwrite this
environment, otherwise you have to put any new environment on the top
of the stack.
*/
static value_t eval_sexpr(value_t e, value_t *penv, int tail)
{
value_t f, v, *pv, *argsyms, *body, *lenv;
cons_t *c;
symbol_t *sym;
u_int32_t saveSP, envsz;
int i, nargs, noeval=0;
fixnum_t s;
cvalue_t *cv;
int64_t accum;
eval_top:
if (issymbol(e)) {
sym = (symbol_t*)ptr(e);
if (sym->syntax == TAG_CONST) return sym->binding;
while (1) {
v = *penv++;
while (iscons(v)) {
if (car_(v)==e) return *penv;
v = cdr_(v); penv++;
}
if (v == e) return *penv; // dotted list
if (v != NIL) penv++;
if (*penv == NIL)
break;
penv = &vector_elt(*penv, 0);
}
if ((v = sym->binding) == UNBOUND)
raise(list2(UnboundError, e));
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
lerror(MemoryError, "eval: stack overflow");
saveSP = SP;
v = car_(e);
PUSH(cdr_(e));
if (tag(v)<0x2) f=v;
else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax)) {
// handle special syntax forms
if (isspecial(f))
goto apply_special;
else if (f == TAG_CONST)
f = ((symbol_t*)ptr(v))->binding;
else
noeval = 2;
}
else f = eval(v);
v = Stack[saveSP];
if (tag(f) == TAG_BUILTIN) {
// handle builtin function
// evaluate argument list, placing arguments on stack
while (iscons(v)) {
v = eval(car_(v));
PUSH(v);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_builtin:
nargs = SP - saveSP - 1;
apply_special:
switch (uintval(f)) {
// special forms
case F_QUOTE:
if (!iscons(Stack[saveSP]))
lerror(ArgError, "quote: expected argument");
v = car_(Stack[saveSP]);
break;
case F_LAMBDA:
// build a closure (lambda args body . env)
if (*penv != NIL) {
// save temporary environment to the heap
lenv = penv;
//envsz = saveSP - (penv - &Stack[0]);
envsz = 2;
v = *penv;
while (iscons(v)) {
envsz++;
v = cdr_(v);
}
if (v != NIL) envsz++;
pv = alloc_words(envsz + 1);
PUSH(tagptr(pv, TAG_BUILTIN));
pv[0] = envsz<<2;
pv++;
while (envsz--)
*pv++ = *penv++;
// environment representation changed; install
// the new representation so everybody can see it
lenv[0] = NIL;
lenv[1] = Stack[SP-1];
}
else {
PUSH(penv[1]); // env has already been captured; share
}
c = (cons_t*)ptr(v=cons_reserve(3));
c->car = LAMBDA;
c->cdr = tagptr(c+1, TAG_CONS); c++;
c->car = car(Stack[saveSP]); //argsyms
c->cdr = tagptr(c+1, TAG_CONS); c++;
c->car = car(cdr_(Stack[saveSP])); //body
c->cdr = Stack[SP-1]; //env
break;
case F_IF:
v = car(Stack[saveSP]);
if (eval(v) != NIL)
v = car(cdr_(Stack[saveSP]));
else
v = car(cdr(cdr_(Stack[saveSP])));
tail_eval(v);
break;
case F_COND:
pv = &Stack[saveSP]; v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car);
if (v != NIL) {
*pv = cdr_(car_(*pv));
// evaluate body forms
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv));
*pv = cdr_(*pv);
}
tail_eval(car_(*pv));
}
break;
}
*pv = cdr_(*pv);
}
break;
case F_AND:
pv = &Stack[saveSP]; v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv))) == NIL) {
SP = saveSP; return NIL;
}
*pv = cdr_(*pv);
}
tail_eval(car_(*pv));
}
break;
case F_OR:
pv = &Stack[saveSP]; v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv))) != NIL) {
SP = saveSP; return v;
}
*pv = cdr_(*pv);
}
tail_eval(car_(*pv));
}
break;
case F_WHILE:
PUSH(cdr(Stack[saveSP]));
body = &Stack[SP-1];
PUSH(*body);
Stack[saveSP] = car_(Stack[saveSP]);
value_t *cond = &Stack[saveSP];
PUSH(NIL);
pv = &Stack[SP-1];
while (eval(*cond) != NIL) {
*body = Stack[SP-2];
while (iscons(*body)) {
*pv = eval(car_(*body));
*body = cdr_(*body);
}
}
v = *pv;
break;
case F_PROGN:
// return last arg
pv = &Stack[saveSP]; v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv));
*pv = cdr_(*pv);
}
tail_eval(car_(*pv));
}
break;
case F_TRYCATCH:
v = do_trycatch(car(Stack[saveSP]), penv);
break;
// ordinary functions
case F_SET:
argcount("set", nargs, 2);
e = Stack[SP-2];
while (1) {
v = *penv++;
while (iscons(v)) {
if (car_(v)==e) {
*penv = Stack[SP-1];
SP=saveSP;
return *penv;
}
v = cdr_(v); penv++;
}
if (v == e) {
*penv = Stack[SP-1];
SP=saveSP;
return *penv;
}
if (v != NIL) penv++;
if (*penv == NIL)
break;
penv = &vector_elt(*penv, 0);
}
sym = tosymbol(e, "set");
v = Stack[SP-1];
if (sym->syntax != TAG_CONST)
sym->binding = v;
break;
case F_BOUNDP:
argcount("boundp", nargs, 1);
sym = tosymbol(Stack[SP-1], "boundp");
v = (sym->binding == UNBOUND) ? NIL : T;
break;
case F_EQ:
argcount("eq", nargs, 2);
v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
break;
case F_CONS:
argcount("cons", nargs, 2);
if (curheap > lim)
gc(0);
c = (cons_t*)curheap;
curheap += sizeof(cons_t);
c->car = Stack[SP-2];
c->cdr = Stack[SP-1];
v = tagptr(c, TAG_CONS);
break;
case F_CAR:
argcount("car", nargs, 1);
v = car(Stack[SP-1]);
break;
case F_CDR:
argcount("cdr", nargs, 1);
v = cdr(Stack[SP-1]);
break;
case F_RPLACA:
argcount("rplaca", nargs, 2);
car(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_RPLACD:
argcount("rplacd", nargs, 2);
cdr(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_VECTOR:
v = alloc_vector(nargs, 0);
memcpy(&vector_elt(v,0), &Stack[saveSP+1], nargs*sizeof(value_t));
break;
case F_LENGTH:
argcount("length", nargs, 1);
if (isvectorish(Stack[SP-1])) {
if (discriminateAsVector(Stack[SP-1])) {
v = fixnum(vector_size(Stack[SP-1]));
break;
}
else {
cv = (cvalue_t*)ptr(Stack[SP-1]);
v = cv_type(cv);
if (iscons(v) && car_(v) == arraysym) {
v = size_wrap(cvalue_arraylen(Stack[SP-1]));
break;
}
else if (v == charsym) {
v = fixnum(1);
break;
}
else if (v == wcharsym) {
v = fixnum(u8_charlen(*(wchar_t*)cv_data(cv)));
break;
}
}
}
else if (Stack[SP-1] == NIL) {
v = fixnum(0); break;
}
else if (iscons(Stack[SP-1])) {
v = fixnum(llength(Stack[SP-1])); break;
}
type_error("length", "sequence", Stack[SP-1]);
break;
case F_AREF:
argcount("aref", nargs, 2);
v = Stack[SP-2];
i = tofixnum(Stack[SP-1], "aref");
if (isvector(v)) {
if ((unsigned)i >= vector_size(v))
bounds_error("aref", v, Stack[SP-1]);
v = vector_elt(v, i);
}
else {
// TODO other sequence types?
type_error("aref", "sequence", v);
}
break;
case F_ASET:
argcount("aset", nargs, 3);
e = Stack[SP-3];
i = tofixnum(Stack[SP-2], "aset");
if (isvector(e)) {
if ((unsigned)i >= vector_size(e))
bounds_error("aref", v, Stack[SP-1]);
vector_elt(e, i) = (v=Stack[SP-1]);
}
else {
type_error("aset", "sequence", e);
}
break;
case F_ATOM:
argcount("atom", nargs, 1);
v = ((!iscons(Stack[SP-1])) ? T : NIL);
break;
case F_CONSP:
argcount("consp", nargs, 1);
v = (iscons(Stack[SP-1]) ? T : NIL);
break;
case F_SYMBOLP:
argcount("symbolp", nargs, 1);
v = ((issymbol(Stack[SP-1])) ? T : NIL);
break;
case F_NUMBERP:
argcount("numberp", nargs, 1);
v = ((isfixnum(Stack[SP-1]) ||
(iscvalue(Stack[SP-1]) &&
valid_numtype(cv_numtype((cvalue_t*)ptr(Stack[SP-1]))) ))
? T : NIL);
break;
case F_FIXNUMP:
argcount("fixnump", nargs, 1);
v = ((isfixnum(Stack[SP-1])) ? T : NIL);
break;
case F_BUILTINP:
argcount("builtinp", nargs, 1);
v = (isbuiltin(Stack[SP-1]) ||
(iscvalue(Stack[SP-1]) &&
((cvalue_t*)ptr(Stack[SP-1]))->flags.islispfunction))? T:NIL;
break;
case F_VECTORP:
argcount("vectorp", nargs, 1);
v = ((isvector(Stack[SP-1])) ? T : NIL);
break;
case F_NOT:
argcount("not", nargs, 1);
v = ((Stack[SP-1] == NIL) ? T : NIL);
break;
case F_ADD:
s = 0;
for (i=saveSP+1; i < (int)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);
SP = saveSP;
return v;
}
}
v = fixnum(s);
break;
case F_SUB:
if (nargs < 1) lerror(ArgError, "-: too few arguments");
i = saveSP+1;
if (nargs == 1) {
if (isfixnum(Stack[i]))
v = fixnum(-numval(Stack[i]));
else
v = fl_neg(Stack[i]);
break;
}
if (nargs == 2) {
if (bothfixnums(Stack[i], Stack[i+1])) {
s = numval(Stack[i]) - numval(Stack[i+1]);
if (fits_fixnum(s)) {
v = fixnum(s);
break;
}
Stack[i+1] = fixnum(-numval(Stack[i+1]));
}
else {
Stack[i+1] = fl_neg(Stack[i+1]);
}
}
else {
Stack[i+1] = fl_neg(fl_add_any(&Stack[i+1], nargs-1, 0));
}
v = fl_add_any(&Stack[i], 2, 0);
break;
case F_MUL:
accum = 1;
for (i=saveSP+1; i < (int)SP; i++) {
if (isfixnum(Stack[i])) {
accum *= numval(Stack[i]);
}
else {
v = fl_mul_any(&Stack[i], SP-i, accum);
SP = saveSP;
return v;
}
}
if (fits_fixnum(accum))
v = fixnum(accum);
else
v = return_from_int64(accum);
break;
case F_DIV:
if (nargs < 1) lerror(ArgError, "/: too few arguments");
i = saveSP+1;
if (nargs == 1) {
v = fl_div2(fixnum(1), Stack[i]);
}
else {
if (nargs > 2)
Stack[i+1] = fl_mul_any(&Stack[i+1], nargs-1, 1);
v = fl_div2(Stack[i], Stack[i+1]);
}
break;
case F_BNOT:
argcount("~", nargs, 1);
if (isfixnum(Stack[SP-1]))
v = fixnum(~numval(Stack[SP-1]));
else
v = fl_bitwise_not(Stack[SP-1]);
break;
case F_BAND:
argcount("&", nargs, 2);
if (bothfixnums(Stack[SP-1], Stack[SP-2]))
v = Stack[SP-1] & Stack[SP-2];
else
v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 0, "&");
break;
case F_BOR:
argcount("!", nargs, 2);
if (bothfixnums(Stack[SP-1], Stack[SP-2]))
v = Stack[SP-1] | Stack[SP-2];
else
v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 1, "!");
break;
case F_BXOR:
argcount("$", nargs, 2);
if (bothfixnums(Stack[SP-1], Stack[SP-2]))
v = fixnum(numval(Stack[SP-1]) ^ numval(Stack[SP-2]));
else
v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$");
break;
case F_COMPARE:
argcount("compare", nargs, 2);
v = compare(Stack[SP-2], Stack[SP-1]);
break;
case F_LT:
argcount("<", nargs, 2);
if (bothfixnums(Stack[SP-2], Stack[SP-1])) {
v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
}
else {
v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? T : NIL;
}
break;
case F_EQUAL:
argcount("equal", nargs, 2);
if (!((Stack[SP-2] | Stack[SP-1])&0x1)) {
v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL;
}
else {
v = (compare(Stack[SP-2], Stack[SP-1])==0) ? T : NIL;
}
break;
case F_EVAL:
argcount("eval", nargs, 1);
v = Stack[SP-1];
if (tag(v)<0x2) { SP=saveSP; return v; }
if (tail) {
penv[0] = NIL;
penv[1] = NIL;
//envsz = 0;
SP = (u_int32_t)(penv-&Stack[0]) + 2;
e=v;
goto eval_top;
}
else {
PUSH(NIL);
PUSH(NIL);
v = eval_sexpr(v, &Stack[SP-2], 1);
}
break;
case F_RAISE:
argcount("raise", nargs, 1);
raise(Stack[SP-1]);
break;
case F_PROG1:
// return first arg
if (nargs < 1) lerror(ArgError, "prog1: too few arguments");
v = Stack[saveSP+1];
break;
case F_ASSOC:
argcount("assoc", nargs, 2);
v = assoc(Stack[SP-2], Stack[SP-1]);
break;
case F_APPLY:
argcount("apply", nargs, 2);
v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
f = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args
if (tag(f) == TAG_BUILTIN) {
assert(!isspecial(f));
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
v = cdr_(v);
}
goto apply_builtin;
}
noeval = 1;
goto apply_lambda;
default:
cv = (cvalue_t*)ptr(f);
if (!discriminateAsVector(f) && cv->flags.islispfunction) {
v = ((guestfunc_t)cv->data)(&Stack[saveSP+1], nargs);
}
else {
goto apply_lambda; // trigger type error
}
}
SP = saveSP;
return v;
}
apply_lambda:
if (iscons(f)) {
// apply lambda expression
f = cdr_(f);
PUSH(f);
PUSH(car(f)); // arglist
argsyms = &Stack[SP-1];
// build a calling environment for the lambda
// the environment is the argument binds on top of the captured
// environment
if (noeval) {
while (iscons(v)) {
// bind args
if (!iscons(*argsyms)) {
if (*argsyms == NIL)
lerror(ArgError, "apply: too many arguments");
break;
}
PUSH(car_(v));
*argsyms = cdr_(*argsyms);
v = cdr_(v);
}
if (*argsyms != NIL && issymbol(*argsyms))
PUSH(v);
}
else {
while (iscons(v)) {
// bind args
if (!iscons(*argsyms)) {
if (*argsyms == NIL)
lerror(ArgError, "apply: too many arguments");
break;
}
v = eval(car_(v));
PUSH(v);
*argsyms = cdr_(*argsyms);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
if (*argsyms != NIL && issymbol(*argsyms)) {
PUSH(NIL);
// this version uses collective allocation. about 7-10%
// faster for lists with > 2 elements, but uses more
// stack space
i = SP;
while (iscons(Stack[saveSP])) {
v = car_(Stack[saveSP]);
v = eval(v);
PUSH(v);
Stack[saveSP] = cdr_(Stack[saveSP]);
}
nargs = SP-i;
if (nargs) {
Stack[i-1] = cons_reserve(nargs);
c = (cons_t*)ptr(Stack[i-1]);
for(; i < (int)SP; i++) {
c->car = Stack[i];
c->cdr = tagptr(c+1, TAG_CONS);
c++;
}
(c-1)->cdr = Stack[saveSP];
POPN(nargs);
}
}
}
if (iscons(*argsyms)) {
lerror(ArgError, "apply: too few arguments");
}
*argsyms = car_(Stack[saveSP+1]);
f = cdr_(Stack[saveSP+1]);
PUSH(cdr(f));
e = car_(f);
// macro: evaluate expansion in the calling environment
if (noeval == 2) {
if (tag(e)<0x2) ;
else e = eval_sexpr(e, argsyms, 1);
SP = saveSP;
if (tag(e)<0x2) return(e);
noeval = 0;
goto eval_top;
}
else {
if (tag(e)<0x2) { SP=saveSP; return(e); }
if (tail) {
noeval = 0;
// ok to overwrite environment
s = SP - saveSP - 2;
for(i=0; i < s; i++)
penv[i] = argsyms[i];
SP = (u_int32_t)((penv+s) - &Stack[0]);
//envsz = s;
goto eval_top;
}
else {
v = eval_sexpr(e, argsyms, 1);
SP = saveSP;
return v;
}
}
// not reached
}
type_error("apply", "function", f);
return NIL;
}
// initialization -------------------------------------------------------------
extern void builtins_init();
void lisp_init(void)
{
int i;
llt_init();
fromspace = malloc(heapsize);
tospace = malloc(heapsize);
curheap = fromspace;
lim = curheap+heapsize-sizeof(cons_t);
consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
ptrhash_new(&printconses, 32);
NIL = symbol("nil"); setc(NIL, NIL);
T = symbol("T"); setc(T, T);
LAMBDA = symbol("lambda");
QUOTE = symbol("quote");
VECTOR = symbol("vector");
TRYCATCH = symbol("trycatch");
BACKQUOTE = symbol("backquote");
COMMA = symbol("*comma*");
COMMAAT = symbol("*comma-at*");
COMMADOT = symbol("*comma-dot*");
IOError = symbol("io-error");
ParseError = symbol("parse-error");
TypeError = symbol("type-error");
ArgError = symbol("arg-error");
UnboundError = symbol("unbound-error");
MemoryError = symbol("memory-error");
BoundsError = symbol("bounds-error");
DivideError = symbol("divide-error");
Error = symbol("error");
conssym = symbol("cons");
symbolsym = symbol("symbol");
fixnumsym = symbol("fixnum");
vectorsym = symbol("vector");
builtinsym = symbol("builtin");
lasterror = NIL;
lerrorbuf[0] = '\0';
i = 0;
while (isspecial(builtin(i))) {
((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
i++;
}
for (; i < N_BUILTINS; i++) {
setc(symbol(builtin_names[i]), builtin(i));
}
#ifdef LINUX
set(symbol("os.name"), symbol("linux"));
#elif defined(WIN32) || defined(WIN64)
set(symbol("os.name"), symbol("win32"));
#elif defined(MACOSX)
set(symbol("os.name"), symbol("macos"));
#else
set(symbol("os.name"), symbol("unknown"));
#endif
cvalues_init();
set(symbol("gensym"), guestfunc(gensym));
builtins_init();
}
// repl -----------------------------------------------------------------------
value_t toplevel_eval(value_t expr)
{
value_t v;
u_int32_t saveSP = SP;
PUSH(NIL);
PUSH(NIL);
v = topeval(expr, &Stack[SP-2]);
SP = saveSP;
return v;
}
static void print_toplevel_exception()
{
if (iscons(lasterror) && car_(lasterror) == TypeError &&
llength(lasterror) == 4) {
fprintf(stderr, "type-error: ");
print(stderr, car_(cdr_(lasterror)), 1);
fprintf(stderr, ": expected ");
print(stderr, car_(cdr_(cdr_(lasterror))), 1);
fprintf(stderr, ", got ");
print(stderr, car_(cdr_(cdr_(cdr_(lasterror)))), 0);
}
else if (iscons(lasterror) && car_(lasterror) == UnboundError &&
iscons(cdr_(lasterror))) {
fprintf(stderr, "unbound-error: eval: variable %s has no value",
(symbol_name(car_(cdr_(lasterror)))));
}
else if (iscons(lasterror) && car_(lasterror) == Error) {
value_t v = cdr_(lasterror);
fprintf(stderr, "error: ");
while (iscons(v)) {
print(stderr, car_(v), 1);
v = cdr_(v);
}
}
else {
if (lasterror != NIL) {
if (!lerrorbuf[0])
fprintf(stderr, "*** Unhandled exception: ");
print(stderr, lasterror, 0);
if (lerrorbuf[0])
fprintf(stderr, ": ");
}
}
if (lerrorbuf[0])
fprintf(stderr, "%s", lerrorbuf);
}
value_t load_file(char *fname)
{
value_t volatile e, v=NIL;
FILE * volatile f = fopen(fname, "r");
if (f == NULL) lerror(IOError, "file \"%s\" not found", fname);
FL_TRY {
while (1) {
e = read_sexpr(f);
//print(stdout,e,0); printf("\n");
if (feof(f)) break;
v = toplevel_eval(e);
}
}
FL_CATCH {
fclose(f);
size_t msglen = strlen(lerrorbuf);
snprintf(&lerrorbuf[msglen], sizeof(lerrorbuf)-msglen,
"\nin file \"%s\"", fname);
lerrorbuf[sizeof(lerrorbuf)-1] = '\0';
raise(lasterror);
}
fclose(f);
return v;
}
static value_t argv_list(int argc, char *argv[])
{
int i;
PUSH(NIL);
if (argc > 1) { argc--; argv++; }
for(i=argc-1; i >= 0; i--)
Stack[SP-1] = fl_cons(cvalue_pinned_cstring(argv[i]), Stack[SP-1]);
return POP();
}
int locale_is_utf8;
int main(int argc, char *argv[])
{
value_t v;
locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, ""));
stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
lisp_init();
set(symbol("argv"), argv_list(argc, argv));
FL_TRY {
// install toplevel exception handler
}
FL_CATCH {
print_toplevel_exception();
lerrorbuf[0] = '\0';
lasterror = NIL;
fprintf(stderr, "\n\n");
goto repl;
}
load_file("system.lsp");
if (argc > 1) { load_file(argv[1]); return 0; }
printf("; _ \n");
printf("; |_ _ _ |_ _ | . _ _\n");
printf("; | (-||||_(_)|__|_)|_)\n");
printf(";-------------------|----------------------------------------------------------\n\n");
repl:
while (1) {
printf("> ");
v = read_sexpr(stdin);
if (feof(stdin)) break;
print(stdout, v=toplevel_eval(v), 0);
set(symbol("that"), v);
printf("\n\n");
}
printf("\n");
return 0;
}