ref: 41504aa58b24afadb1d50a39de173e6fa308c248
dir: /tiny/lispf.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)
lispf is a fork that provides an #ifdef FLOAT option to use single-precision
floating point numbers instead of integers, albeit with even less precision
than usual---only 21 significant mantissa bits!
it is now also being used to test a tail-recursive evaluator.
by Jeff Bezanson
Public Domain
*/
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <setjmp.h>
#include <stdarg.h>
#include <ctype.h>
#include <sys/types.h>
typedef u_int32_t value_t;
#ifdef FLOAT
typedef float number_t;
#else
typedef int32_t number_t;
#endif
typedef struct {
value_t car;
value_t cdr;
} cons_t;
typedef struct _symbol_t {
value_t binding; // global value binding
value_t constant; // constant binding (used only for builtins)
struct _symbol_t *left;
struct _symbol_t *right;
char name[1];
} symbol_t;
#define TAG_NUM 0x0
#define TAG_BUILTIN 0x1
#define TAG_SYM 0x2
#define TAG_CONS 0x3
#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
#define tag(x) ((x)&0x3)
#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
#define tagptr(p,t) (((value_t)(p)) | (t))
#ifdef FLOAT
#define number(x) ((*(value_t*)&(x))&~0x3)
#define numval(x) (*(number_t*)&(x))
#define NUM_FORMAT "%f"
extern float strtof(const char *nptr, char **endptr);
#define strtonum(s, e) strtof(s, e)
#else
#define number(x) ((value_t)((x)<<2))
#define numval(x) (((number_t)(x))>>2)
#define NUM_FORMAT "%d"
#define strtonum(s, e) strtol(s, e, 10)
#endif
#define intval(x) (((int)(x))>>2)
#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
#define iscons(x) (tag(x) == TAG_CONS)
#define issymbol(x) (tag(x) == TAG_SYM)
#define isnumber(x) (tag(x) == TAG_NUM)
#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
// functions ending in _ are unsafe, faster versions
#define car_(v) (((cons_t*)ptr(v))->car)
#define cdr_(v) (((cons_t*)ptr(v))->cdr)
#define car(v) (tocons((v),"car")->car)
#define cdr(v) (tocons((v),"cdr")->cdr)
#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
F_PROGN,
// functions
F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
};
#define isspecial(v) (intval(v) <= (int)F_PROGN)
static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",
"progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
"set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp" };
static char *stack_bottom;
#define PROCESS_STACK_SIZE (2*1024*1024)
#define N_STACK 49152
static value_t Stack[N_STACK];
static u_int32_t SP = 0;
#define PUSH(v) (Stack[SP++] = (v))
#define POP() (Stack[--SP])
#define POPN(n) (SP-=(n))
value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
value_t read_sexpr(FILE *f);
void print(FILE *f, value_t v);
value_t eval_sexpr(value_t e, value_t *penv);
value_t load_file(char *fname);
// error utilities ------------------------------------------------------------
jmp_buf toplevel;
void lerror(char *format, ...)
{
va_list args;
va_start(args, format);
vfprintf(stderr, format, args);
va_end(args);
longjmp(toplevel, 1);
}
void type_error(char *fname, char *expected, value_t got)
{
fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
print(stderr, got); lerror("\n");
}
// 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(number,number_t, numval)
// symbol table ---------------------------------------------------------------
static symbol_t *symtab = NULL;
static symbol_t *mk_symbol(char *str)
{
symbol_t *sym;
sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
sym->left = sym->right = NULL;
sym->constant = sym->binding = UNBOUND;
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);
}
// initialization -------------------------------------------------------------
static unsigned char *fromspace;
static unsigned char *tospace;
static unsigned char *curheap;
static unsigned char *lim;
static u_int32_t heapsize = 64*1024;//bytes
void lisp_init(void)
{
int i;
fromspace = malloc(heapsize);
tospace = malloc(heapsize);
curheap = fromspace;
lim = curheap+heapsize-sizeof(cons_t);
NIL = symbol("nil"); setc(NIL, NIL);
T = symbol("t"); setc(T, T);
LAMBDA = symbol("lambda");
MACRO = symbol("macro");
LABEL = symbol("label");
QUOTE = symbol("quote");
for (i=0; i < (int)N_BUILTINS; i++)
setc(symbol(builtin_names[i]), builtin(i));
setc(symbol("princ"), builtin(F_PRINT));
}
// conses ---------------------------------------------------------------------
void gc(void);
static value_t mk_cons(void)
{
cons_t *c;
if (curheap > lim)
gc();
c = (cons_t*)curheap;
curheap += sizeof(cons_t);
return tagptr(c, TAG_CONS);
}
static value_t cons_(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar; cdr_(c) = *pcdr;
return c;
}
value_t *cons(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar; cdr_(c) = *pcdr;
PUSH(c);
return &Stack[SP-1];
}
// collector ------------------------------------------------------------------
static value_t relocate(value_t v)
{
value_t a, d, nc;
if (!iscons(v))
return v;
if (car_(v) == UNBOUND)
return cdr_(v);
nc = mk_cons(); car_(nc) = NIL;
a = car_(v); d = cdr_(v);
car_(v) = UNBOUND; cdr_(v) = nc;
car_(nc) = relocate(a);
cdr_(nc) = relocate(d);
return nc;
}
static void trace_globals(symbol_t *root)
{
while (root != NULL) {
root->binding = relocate(root->binding);
trace_globals(root->left);
root = root->right;
}
}
void gc(void)
{
static int grew = 0;
unsigned char *temp;
u_int32_t i;
curheap = tospace;
lim = curheap+heapsize-sizeof(cons_t);
for (i=0; i < SP; i++)
Stack[i] = relocate(Stack[i]);
trace_globals(symtab);
#ifdef VERBOSEGC
printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);
#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))) {
temp = realloc(tospace, grew ? heapsize : heapsize*2);
if (temp == NULL)
lerror("out of memory\n");
tospace = temp;
if (!grew)
heapsize*=2;
grew = !grew;
}
if (curheap > lim) // all data was live
gc();
}
// read -----------------------------------------------------------------------
enum {
TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
};
static int symchar(char c)
{
static char *special = "()';\\|";
return (!isspace(c) && !strchr(special, c));
}
static u_int32_t toktype = TOK_NONE;
static value_t tokval;
static char buf[256];
static char nextchar(FILE *f)
{
char c;
int ch;
do {
ch = fgetc(f);
if (ch == EOF)
return 0;
c = (char)ch;
if (c == ';') {
// single-line comment
do {
ch = fgetc(f);
if (ch == EOF)
return 0;
} while ((char)ch != '\n');
c = (char)ch;
}
} while (isspace(c));
return c;
}
static void take(void)
{
toktype = TOK_NONE;
}
static void accumchar(char c, int *pi)
{
buf[(*pi)++] = c;
if (*pi >= (int)(sizeof(buf)-1))
lerror("read: error: token too long\n");
}
static int read_token(FILE *f, char c)
{
int i=0, ch, escaped=0;
ungetc(c, f);
while (1) {
ch = fgetc(f);
if (ch == EOF)
goto terminate;
c = (char)ch;
if (c == '|') {
escaped = !escaped;
}
else if (c == '\\') {
ch = fgetc(f);
if (ch == EOF)
goto terminate;
accumchar((char)ch, &i);
}
else if (!escaped && !symchar(c)) {
break;
}
else {
accumchar(c, &i);
}
}
ungetc(c, f);
terminate:
buf[i++] = '\0';
return i;
}
static u_int32_t peek(FILE *f)
{
char c, *end;
number_t x;
if (toktype != TOK_NONE)
return toktype;
c = nextchar(f);
if (feof(f)) return TOK_NONE;
if (c == '(') {
toktype = TOK_OPEN;
}
else if (c == ')') {
toktype = TOK_CLOSE;
}
else if (c == '\'') {
toktype = TOK_QUOTE;
}
else if (isdigit(c) || c=='-') {
read_token(f, c);
if (buf[0] == '-' && !isdigit(buf[1])) {
toktype = TOK_SYM;
tokval = symbol(buf);
}
else {
x = strtonum(buf, &end);
if (*end != '\0')
lerror("read: error: invalid constant\n");
toktype = TOK_NUM;
tokval = number(x);
}
}
else {
read_token(f, c);
if (!strcmp(buf, ".")) {
toktype = TOK_DOT;
}
else {
toktype = TOK_SYM;
tokval = symbol(buf);
}
}
return toktype;
}
// build a list of conses. this is complicated by the fact that all conses
// can move whenever a new cons is allocated. we have to refer to every cons
// through a handle to a relocatable pointer (i.e. a pointer on the stack).
static void read_list(FILE *f, value_t *pval)
{
value_t c, *pc;
u_int32_t t;
PUSH(NIL);
pc = &Stack[SP-1]; // to keep track of current cons cell
t = peek(f);
while (t != TOK_CLOSE) {
if (feof(f))
lerror("read: error: unexpected end of input\n");
c = mk_cons(); car_(c) = cdr_(c) = NIL;
if (iscons(*pc))
cdr_(*pc) = c;
else
*pval = c;
*pc = c;
c = read_sexpr(f); // must be on separate lines due to undefined
car_(*pc) = c; // evaluation order
t = peek(f);
if (t == TOK_DOT) {
take();
c = read_sexpr(f);
cdr_(*pc) = c;
t = peek(f);
if (feof(f))
lerror("read: error: unexpected end of input\n");
if (t != TOK_CLOSE)
lerror("read: error: expected ')'\n");
}
}
take();
POP();
}
value_t read_sexpr(FILE *f)
{
value_t v;
switch (peek(f)) {
case TOK_CLOSE:
take();
lerror("read: error: unexpected ')'\n");
case TOK_DOT:
take();
lerror("read: error: unexpected '.'\n");
case TOK_SYM:
case TOK_NUM:
take();
return tokval;
case TOK_QUOTE:
take();
v = read_sexpr(f);
PUSH(v);
v = cons_("E, cons(&Stack[SP-1], &NIL));
POPN(2);
return v;
case TOK_OPEN:
take();
PUSH(NIL);
read_list(f, &Stack[SP-1]);
return POP();
}
return NIL;
}
// print ----------------------------------------------------------------------
void print(FILE *f, value_t v)
{
value_t cd;
switch (tag(v)) {
case TAG_NUM: fprintf(f, NUM_FORMAT, numval(v)); break;
case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
builtin_names[intval(v)]); break;
case TAG_CONS:
fprintf(f, "(");
while (1) {
print(f, car_(v));
cd = cdr_(v);
if (!iscons(cd)) {
if (cd != NIL) {
fprintf(f, " . ");
print(f, cd);
}
fprintf(f, ")");
break;
}
fprintf(f, " ");
v = cd;
}
break;
}
}
// eval -----------------------------------------------------------------------
static inline void argcount(char *fname, int nargs, int c)
{
if (nargs != c)
lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");
}
#define eval(e, penv) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv))
#define tail_eval(xpr, env) do { SP = saveSP; \
if (tag(xpr)<0x2) { return (xpr); } \
else { e=(xpr); *penv=(env); goto eval_top; } } while (0)
value_t eval_sexpr(value_t e, value_t *penv)
{
value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
value_t *rest;
cons_t *c;
symbol_t *sym;
u_int32_t saveSP;
int i, nargs, noeval=0;
number_t s, n;
eval_top:
if (issymbol(e)) {
sym = (symbol_t*)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e)
return cdr_(bind);
v = cdr_(v);
}
if ((v = sym->binding) == UNBOUND)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
PUSH(*penv);
f = eval(car_(e), penv);
*penv = Stack[saveSP+1];
if (isbuiltin(f)) {
// handle builtin function
if (!isspecial(f)) {
// evaluate argument list, placing arguments on stack
v = Stack[saveSP] = cdr_(Stack[saveSP]);
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
}
apply_builtin:
nargs = SP - saveSP - 2;
switch (intval(f)) {
// special forms
case F_QUOTE:
v = cdr_(Stack[saveSP]);
if (!iscons(v))
lerror("quote: error: expected argument\n");
v = car_(v);
break;
case F_MACRO:
case F_LAMBDA:
v = Stack[saveSP];
if (*penv != NIL) {
// build a closure (lambda args body . env)
v = cdr_(v);
PUSH(car(v));
argsyms = &Stack[SP-1];
PUSH(car(cdr_(v)));
body = &Stack[SP-1];
v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
cons(argsyms, cons(body, penv)));
}
break;
case F_LABEL:
v = Stack[saveSP];
if (*penv != NIL) {
v = cdr_(v);
PUSH(car(v)); // name
pv = &Stack[SP-1];
PUSH(car(cdr_(v))); // function
body = &Stack[SP-1];
*body = eval(*body, penv); // evaluate lambda
v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
}
break;
case F_IF:
v = car(cdr_(Stack[saveSP]));
if (eval(v, penv) != NIL)
v = car(cdr_(cdr_(Stack[saveSP])));
else
v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
tail_eval(v, Stack[saveSP+1]);
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car, penv);
*penv = Stack[saveSP+1];
if (v != NIL) {
*pv = cdr_(car_(*pv));
// evaluate body forms
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
}
*pv = cdr_(*pv);
}
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) == NIL) {
SP = saveSP; return NIL;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) != NIL) {
SP = saveSP; return v;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_WHILE:
PUSH(car(cdr(cdr_(Stack[saveSP]))));
body = &Stack[SP-1];
Stack[saveSP] = car_(cdr_(Stack[saveSP]));
value_t *cond = &Stack[saveSP];
PUSH(NIL); pv = &Stack[SP-1];
while (eval(*cond, penv) != NIL) {
*penv = Stack[saveSP+1];
*pv = eval(*body, penv);
*penv = Stack[saveSP+1];
}
v = *pv;
break;
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
// ordinary functions
case F_SET:
argcount("set", nargs, 2);
e = Stack[SP-2];
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e) {
cdr_(bind) = (v=Stack[SP-1]);
SP=saveSP; return v;
}
v = cdr_(v);
}
tosymbol(e, "set")->binding = (v=Stack[SP-1]);
break;
case F_BOUNDP:
argcount("boundp", nargs, 1);
if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
v = NIL;
else
v = 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);
v = mk_cons();
car_(v) = Stack[SP-2];
cdr_(v) = Stack[SP-1];
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_ATOM:
argcount("atom", 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 = ((isnumber(Stack[SP-1])) ? T : NIL);
break;
case F_ADD:
s = 0;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "+");
s += n;
}
v = number(s);
break;
case F_SUB:
if (nargs < 1)
lerror("-: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "-");
s -= n;
}
v = number(s);
break;
case F_MUL:
s = 1;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "*");
s *= n;
}
v = number(s);
break;
case F_DIV:
if (nargs < 1)
lerror("/: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "/");
if (n == 0)
lerror("/: error: division by zero\n");
s /= n;
}
v = number(s);
break;
case F_LT:
argcount("<", nargs, 2);
if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
v = T;
else
v = NIL;
break;
case F_NOT:
argcount("not", nargs, 1);
v = ((Stack[SP-1] == NIL) ? T : NIL);
break;
case F_EVAL:
argcount("eval", nargs, 1);
v = Stack[SP-1];
tail_eval(v, NIL);
break;
case F_PRINT:
for (i=saveSP+2; i < (int)SP; i++)
print(stdout, v=Stack[i]);
break;
case F_READ:
argcount("read", nargs, 0);
v = read_sexpr(stdin);
break;
case F_LOAD:
argcount("load", nargs, 1);
v = load_file(tosymbol(Stack[SP-1], "load")->name);
break;
case F_PROG1:
// return first arg
if (nargs < 1)
lerror("prog1: error: too few arguments\n");
v = Stack[saveSP+2];
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 (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
v = cdr_(v);
}
goto apply_builtin;
}
noeval = 1;
goto apply_lambda;
}
SP = saveSP;
return v;
}
else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
if (iscons(f)) {
headsym = car_(f);
if (headsym == LABEL) {
// (label name (lambda ...)) behaves the same as the lambda
// alone, except with name bound to the whole label expression
labl = f;
f = car(cdr(cdr_(labl)));
headsym = car(f);
}
// apply lambda or macro expression
PUSH(cdr(cdr(cdr_(f))));
lenv = &Stack[SP-1];
PUSH(car_(cdr_(f)));
argsyms = &Stack[SP-1];
PUSH(car_(cdr_(cdr_(f))));
body = &Stack[SP-1];
if (labl) {
// add label binding to environment
PUSH(labl);
PUSH(car_(cdr_(labl)));
*lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
POPN(3);
v = Stack[saveSP]; // refetch arglist
}
if (headsym == MACRO)
noeval = 1;
else if (headsym != LAMBDA)
lerror("apply: error: head must be lambda, macro, or label\n");
// build a calling environment for the lambda
// the environment is the argument binds on top of the captured
// environment
while (iscons(v)) {
// bind args
if (!iscons(*argsyms)) {
if (*argsyms == NIL)
lerror("apply: error: too many arguments\n");
break;
}
asym = car_(*argsyms);
if (!issymbol(asym))
lerror("apply: error: formal argument not a symbol\n");
v = car_(v);
if (!noeval) {
v = eval(v, penv);
*penv = Stack[saveSP+1];
}
PUSH(v);
*lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
POPN(2);
*argsyms = cdr_(*argsyms);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
if (*argsyms != NIL) {
if (issymbol(*argsyms)) {
if (noeval) {
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
}
else {
PUSH(NIL);
PUSH(NIL);
rest = &Stack[SP-1];
// build list of rest arguments
// we have to build it forwards, which is tricky
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = cons_(&Stack[SP-1], &NIL);
POP();
if (iscons(*rest))
cdr_(*rest) = v;
else
Stack[SP-2] = v;
*rest = v;
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
*lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
}
}
else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
noeval = 0;
// macro: evaluate expansion in the calling environment
if (headsym == MACRO) {
SP = saveSP;
PUSH(*lenv);
lenv = &Stack[SP-1];
v = eval(*body, lenv);
tail_eval(v, *penv);
}
else {
tail_eval(*body, *lenv);
}
// not reached
}
type_error("apply", "function", f);
return NIL;
}
// repl -----------------------------------------------------------------------
static char *infile = NULL;
value_t toplevel_eval(value_t expr)
{
value_t v;
PUSH(NIL);
v = eval(expr, &Stack[SP-1]);
POP();
return v;
}
value_t load_file(char *fname)
{
value_t e, v=NIL;
char *lastfile = infile;
FILE *f = fopen(fname, "r");
infile = fname;
if (f == NULL) lerror("file not found\n");
while (1) {
e = read_sexpr(f);
if (feof(f)) break;
v = toplevel_eval(e);
}
infile = lastfile;
fclose(f);
return v;
}
int main(int argc, char* argv[])
{
value_t v;
stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
lisp_init();
if (setjmp(toplevel)) {
SP = 0;
fprintf(stderr, "\n");
if (infile) {
fprintf(stderr, "error loading file \"%s\"\n", infile);
infile = NULL;
}
goto repl;
}
load_file("system.lsp");
if (argc > 1) { load_file(argv[1]); return 0; }
printf("Welcome to femtoLisp ----------------------------------------------------------\n");
repl:
while (1) {
printf("> ");
v = read_sexpr(stdin);
if (feof(stdin)) break;
print(stdout, v=toplevel_eval(v));
set(symbol("that"), v);
printf("\n\n");
}
return 0;
}