984 lines
28 KiB
C
984 lines
28 KiB
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)
|
|
|
|
by Jeff Bezanson
|
|
Public Domain
|
|
*/
|
|
|
|
#include <ctype.h>
|
|
#include <inttypes.h>
|
|
#include <setjmp.h>
|
|
#include <stdarg.h>
|
|
#include <stdint.h>
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
|
|
#ifdef __LP64__
|
|
#define NUM_FORMAT "%" PRId64
|
|
typedef uint64_t value_t;
|
|
typedef int64_t number_t;
|
|
#else
|
|
#define NUM_FORMAT "%" PRId32
|
|
typedef uint32_t value_t;
|
|
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))
|
|
#define number(x) ((value_t)((x)<<2))
|
|
#define numval(x) (((number_t)(x))>>2)
|
|
#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 uint32_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 uint32_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();
|
|
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;
|
|
uint32_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 uint32_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 uint32_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 = strtol(buf, &end, 10);
|
|
if (*end != '\0')
|
|
lerror("read: error: invalid integer 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;
|
|
uint32_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, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env))
|
|
|
|
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;
|
|
uint32_t saveSP;
|
|
int i, nargs, noeval=0;
|
|
number_t s, n;
|
|
|
|
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);
|
|
f = eval(car_(e), penv);
|
|
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);
|
|
PUSH(v);
|
|
v = Stack[saveSP] = cdr_(Stack[saveSP]);
|
|
}
|
|
}
|
|
apply_builtin:
|
|
nargs = SP - saveSP - 1;
|
|
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]))));
|
|
v = eval(v, penv);
|
|
break;
|
|
case F_COND:
|
|
Stack[saveSP] = cdr_(Stack[saveSP]);
|
|
pv = &Stack[saveSP]; v = NIL;
|
|
while (iscons(*pv)) {
|
|
c = tocons(car_(*pv), "cond");
|
|
if ((v=eval(c->car, penv)) != NIL) {
|
|
*pv = cdr_(car_(*pv));
|
|
// evaluate body forms
|
|
while (iscons(*pv)) {
|
|
v = eval(car_(*pv), penv);
|
|
*pv = cdr_(*pv);
|
|
}
|
|
break;
|
|
}
|
|
*pv = cdr_(*pv);
|
|
}
|
|
break;
|
|
case F_AND:
|
|
Stack[saveSP] = cdr_(Stack[saveSP]);
|
|
pv = &Stack[saveSP]; v = T;
|
|
while (iscons(*pv)) {
|
|
if ((v=eval(car_(*pv), penv)) == NIL)
|
|
break;
|
|
*pv = cdr_(*pv);
|
|
}
|
|
break;
|
|
case F_OR:
|
|
Stack[saveSP] = cdr_(Stack[saveSP]);
|
|
pv = &Stack[saveSP]; v = NIL;
|
|
while (iscons(*pv)) {
|
|
if ((v=eval(car_(*pv), penv)) != NIL)
|
|
break;
|
|
*pv = cdr_(*pv);
|
|
}
|
|
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)
|
|
*pv = eval(*body, penv);
|
|
v = *pv;
|
|
break;
|
|
case F_PROGN:
|
|
// return last arg
|
|
Stack[saveSP] = cdr_(Stack[saveSP]);
|
|
pv = &Stack[saveSP]; v = NIL;
|
|
while (iscons(*pv)) {
|
|
v = eval(car_(*pv), penv);
|
|
*pv = cdr_(*pv);
|
|
}
|
|
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+1; 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+1;
|
|
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+1; 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+1;
|
|
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 = eval(Stack[SP-1], &NIL);
|
|
break;
|
|
case F_PRINT:
|
|
for (i=saveSP+1; 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+1];
|
|
break;
|
|
case F_APPLY:
|
|
// unpack a list onto the stack
|
|
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)]);
|
|
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);
|
|
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);
|
|
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");
|
|
}
|
|
}
|
|
SP = saveSP; // free temporary stack space
|
|
PUSH(*lenv); // preserve environment on stack
|
|
lenv = &Stack[SP-1];
|
|
v = eval(*body, lenv);
|
|
POP();
|
|
// macro: evaluate expansion in the calling environment
|
|
if (headsym == MACRO)
|
|
return eval(v, penv);
|
|
return v;
|
|
}
|
|
type_error("apply", "function", f);
|
|
return NIL;
|
|
}
|
|
|
|
// repl -----------------------------------------------------------------------
|
|
|
|
static char *infile = NULL;
|
|
|
|
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 = eval(e, &NIL);
|
|
}
|
|
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=eval(v, &NIL));
|
|
set(symbol("that"), v);
|
|
printf("\n\n");
|
|
}
|
|
return 0;
|
|
}
|