/* 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 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 (C) 2008 Distributed under the Common Public License v1.0 */ #include #include #include #include #include #include #include #include #include #include #include #include #include "llt.h" #include "flisp.h" static char *builtin_names[] = { "quote", "cond", "if", "and", "or", "while", "lambda", "trycatch", "%apply", "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", "for" }; 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, 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; value_t defunsym, defmacrosym, forsym, labelsym, printprettysym; static value_t eval_sexpr(value_t e, uint32_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; // 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_aligned(sizeof(symbol_t)-sizeof(void*) + strlen(str)+1, 8); 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; if (n < 2) n = 2; // the minimum allocation is a 2-word block n = ALIGN(n, 2); // only allocate multiples of 2 words 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_VECTOR); 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 (isvector(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 if (iscvalue(v)) { 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; } } static value_t special_apply_form; 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); special_apply_form = relocate(special_apply_form); #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_aligned(tospace, grew ? heapsize : heapsize*2, 16); 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); return toplevel_eval(special_apply_form); } 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) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0)) #define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1)) #define tail_eval(xpr) do { SP = saveSP; \ if (selfevaluating(xpr)) { return (xpr); } \ else { e=(xpr); goto eval_top; } } while (0) static value_t do_trycatch(value_t expr, uint32_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. Stack[penv-1] is the size of the whole environment (as a fixnum) 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, uint32_t penv, int tail) { value_t f, v, *pv, *argsyms, *body; cons_t *c; symbol_t *sym; uint32_t saveSP, envsz, lenv; int i, nargs, noeval=0; fixnum_t s, lo, hi; cvalue_t *cv; int64_t accum; eval_top: if (issymbol(e)) { sym = (symbol_t*)ptr(e); if (sym->syntax == TAG_CONST) return sym->binding; pv = &Stack[penv]; while (1) { v = *pv++; while (iscons(v)) { if (car_(v)==e) return *pv; v = cdr_(v); pv++; } if (v == e) return *pv; // dotted list if (v != NIL) pv++; if (*pv == NIL) break; pv = &vector_elt(*pv, 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 (selfevaluating(v)) 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 (isbuiltinish(f)) { // 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 (Stack[penv] != NIL) { // save temporary environment to the heap lenv = penv; envsz = numval(Stack[penv-1]); pv = alloc_words(envsz + 1); PUSH(tagptr(pv, TAG_VECTOR)); pv[0] = fixnum(envsz); pv++; while (envsz--) *pv++ = Stack[penv++]; // environment representation changed; install // the new representation so everybody can see it Stack[lenv] = NIL; Stack[lenv+1] = Stack[SP-1]; } else { PUSH(Stack[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]; pv = &Stack[penv]; while (1) { v = *pv++; while (iscons(v)) { if (car_(v)==e) { *pv = Stack[SP-1]; SP=saveSP; return *pv; } v = cdr_(v); pv++; } if (v == e) { *pv = Stack[SP-1]; SP=saveSP; return *pv; } if (v != NIL) pv++; if (*pv == NIL) break; pv = &vector_elt(*pv, 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 (isvector(Stack[SP-1])) { v = fixnum(vector_size(Stack[SP-1])); break; } else if (iscvalue(Stack[SP-1])) { 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 = (isbuiltinish(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 (eq_comparable(Stack[SP-2],Stack[SP-1])) { 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 (selfevaluating(v)) { SP=saveSP; return v; } if (tail) { Stack[penv-1] = fixnum(2); Stack[penv] = NIL; Stack[penv+1] = NIL; SP = penv + 2; e=v; goto eval_top; } else { PUSH(fixnum(2)); PUSH(NIL); PUSH(NIL); v = eval_sexpr(v, 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_FOR: argcount("for", nargs, 3); lo = tofixnum(Stack[SP-3], "for"); hi = tofixnum(Stack[SP-2], "for"); f = Stack[SP-1]; v = car(cdr(f)); if (!iscons(v) || !iscons(cdr_(cdr_(f))) || cdr_(v) != NIL) lerror(ArgError, "for: expected 1 argument lambda"); f = cdr_(f); PUSH(f); // save function cdr SP += 4; // make space Stack[SP-4] = fixnum(3); // env size Stack[SP-1] = cdr_(cdr_(f)); // cloenv v = NIL; for(s=lo; s <= hi; s++) { f = Stack[SP-5]; Stack[SP-3] = car_(f); // lambda list Stack[SP-2] = fixnum(s); // argument value v = eval_sexpr(car_(cdr_(f)), SP-3, 0); } break; case F_SPECIAL_APPLY: v = Stack[saveSP-4]; f = Stack[saveSP-5]; PUSH(f); PUSH(v); nargs = 2; // falls through!! 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 (isbuiltinish(f)) { 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: // a guest function is a cvalue tagged as a builtin cv = (cvalue_t*)ptr(f); if (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(Stack[saveSP]); // 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"); } f = cdr_(Stack[saveSP+1]); e = car(f); if (selfevaluating(e)) { SP=saveSP; return(e); } PUSH(cdr_(f)); // add closed environment *argsyms = car_(Stack[saveSP+1]); // put lambda list if (noeval == 2) { // macro: evaluate body in lambda environment Stack[saveSP+1] = fixnum(SP-saveSP-2); e = eval_sexpr(e, saveSP+2, 1); SP = saveSP; if (selfevaluating(e)) return(e); noeval = 0; // macro: evaluate expansion in calling environment goto eval_top; } else { envsz = SP - saveSP - 2; if (tail) { noeval = 0; // ok to overwrite environment for(i=0; i < (int)envsz; i++) Stack[penv+i] = Stack[saveSP+2+i]; SP = penv+envsz; Stack[penv-1] = fixnum(envsz); goto eval_top; } else { Stack[saveSP+1] = fixnum(envsz); v = eval_sexpr(e, saveSP+2, 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_aligned(heapsize, 16); tospace = malloc_aligned(heapsize, 16); 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"); 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"); defunsym = symbol("defun"); defmacrosym = symbol("defmacro"); forsym = symbol("for"); labelsym = symbol("label"); set(printprettysym=symbol("*print-pretty*"), T); lasterror = NIL; lerrorbuf[0] = '\0'; special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL); i = 0; while (isspecial(builtin(i))) { if (i != F_SPECIAL_APPLY) ((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(fixnum(2)); PUSH(NIL); PUSH(NIL); v = topeval(expr, 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; }