lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

adding the ability to heap-allocate extentions to the value stack, 

so recursion depth is limited only by the process stack limit.

reorganizing evaluator so the same code is used for evaluating
and pushing arguments for both builtin functions and lambdas.
for now this is slower, but it was done in preparation for
Things To Come.

adding list-head

implementing the calling convention for long argument lists in
bytecode compiler. arguments are broken down into a nest of
list and nconc calls.
also implementing vararg builtins.
This commit is contained in:
JeffBezanson 2009-04-01 04:31:49 +00:00
parent 2ddbac400a
commit 43e8d1fbf0
6 changed files with 242 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
femtolisp/compiler.lsp
View File

@ -104,7 +104,8 @@
(io.write bcode (uint32 nxt)) (io.write bcode (uint32 nxt))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loada :seta :call :loadv :loadg :setg :popn) ((:loada :seta :call :loadv :loadg :setg :popn
:list :+ :- :* :/ :vector)
(io.write bcode (uint8 nxt)) (io.write bcode (uint8 nxt))
(set! i (+ i 1))) (set! i (+ i 1)))
@ -254,15 +255,45 @@
(compile-or g (cdr forms) env) (compile-or g (cdr forms) env)
(mark-label g end))))) (mark-label g end)))))
;; TODO support long argument lists (define MAX_ARGS 127)
(define (compile-args g lst env)
(define (list-part- l n i subl acc)
(cond ((atom? l) (if (> i 0)
(cons (nreverse subl) acc)
acc))
((>= i n) (list-part- l n 0 () (cons (nreverse subl) acc)))
(else (list-part- (cdr l) n (+ 1 i) (cons (car l) subl) acc))))
(define (list-partition l n)
(if (<= n 0)
(error "list-partition: invalid count")
(nreverse (list-part- l n 0 () ()))))
(define (length> lst n)
(cond ((< n 0) lst)
((= n 0) (and (pair? lst) lst))
((null? lst) (< n 0))
(else (length> (cdr lst) (- n 1)))))
(define (just-compile-args g lst env)
(for-each (lambda (a) (for-each (lambda (a)
(compile-in g a env)) (compile-in g a env))
lst)) lst))
(define (compile-arglist g lst env)
(let ((argtail (length> lst MAX_ARGS)))
(if argtail
(begin (just-compile-args g (list-head lst MAX_ARGS) env)
(let ((rest
(cons nconc
(map (lambda (l) (cons list l))
(list-partition argtail MAX_ARGS)))))
(compile-in g rest env))
(+ MAX_ARGS 1))
(begin (just-compile-args g lst env)
(length lst)))))
(define (compile-app g x env) (define (compile-app g x env)
(let ((head (car x)) (let ((head (car x)))
(nargs (length (cdr x))))
(let ((head (let ((head
(if (and (symbol? head) (if (and (symbol? head)
(not (in-env? head env)) (not (in-env? head env))
@ -275,10 +306,12 @@
(builtin->instruction head)))) (builtin->instruction head))))
(if (not b) (if (not b)
(compile-in g head env)) (compile-in g head env))
(compile-args g (cdr x) env) (let ((nargs (compile-arglist g (cdr x) env)))
(if b ;; TODO check arg count (if b ;; TODO check arg count
(emit g b) (if (memq b '(:list :+ :- :* :/ :vector))
(emit g :call nargs)))))) (emit g b nargs)
(emit g b))
(emit g :call nargs)))))))
(define (compile-in g x env) (define (compile-in g x env)
(cond ((symbol? x) (compile-sym g x env [:loada :loadc :loadg])) (cond ((symbol? x) (compile-sym g x env [:loada :loadc :loadg]))
@ -300,7 +333,7 @@
(emit g :closure))) (emit g :closure)))
(and (compile-and g (cdr x) env)) (and (compile-and g (cdr x) env))
(or (compile-or g (cdr x) env)) (or (compile-or g (cdr x) env))
(while (compile-while g (car x) (cadr x) env)) (while (compile-while g (cadr x) (caddr x) env))
(set! (compile-in g (caddr x) env) (set! (compile-in g (caddr x) env)
(compile-sym g (cadr x) env [:seta :setc :setg])) (compile-sym g (cadr x) env [:seta :setc :setg]))
(trycatch (compile-in g `(lambda () ,(cadr x)) env) (trycatch (compile-in g `(lambda () ,(cadr x)) env)
@ -315,7 +348,7 @@
`(compiled-lambda ,(cadr f) ,(bytecode g)))) `(compiled-lambda ,(cadr f) ,(bytecode g))))
(define (compile x) (define (compile x)
(compile-in (make-code-emitter) x ())) (bytecode (compile-in (make-code-emitter) x ())))
(define (ref-uint32-LE a i) (define (ref-uint32-LE a i)
(+ (ash (aref a (+ i 0)) 0) (+ (ash (aref a (+ i 0)) 0)
@ -359,7 +392,7 @@
(print-val (aref vals (aref code i))) (print-val (aref vals (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loada :seta :call :popn) ((:loada :seta :call :popn :list :+ :- :* :/ :vector)
(princ (number->string (aref code i))) (princ (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
@ -379,6 +412,6 @@
(else #f)))))))) (else #f))))))))
(define (disassemble b) (disassemble- b 0)) (define (disassemble b) (disassemble- b 0) (newline))
#t #t

286
femtolisp/flisp.c
View File

@ -73,10 +73,20 @@ static char *builtin_names[] =
"vector", "aref", "aset!", "length", "for", "vector", "aref", "aset!", "length", "for",
"", "", "" }; "", "", "" };
#define N_STACK 131072 #define N_STACK 262144
value_t Stack[N_STACK]; value_t StaticStack[N_STACK];
value_t *Stack = StaticStack;
uint32_t SP = 0; uint32_t SP = 0;
typedef struct _stackseg_t {
value_t *Stack;
uint32_t SP;
struct _stackseg_t *prev;
} stackseg_t;
stackseg_t stackseg0 = { StaticStack, 0, NULL };
stackseg_t *current_stack_seg = &stackseg0;
value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH; value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
@ -85,7 +95,7 @@ value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym; value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym; value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym;
static value_t eval_sexpr(value_t e, uint32_t penv, int tail); static value_t eval_sexpr(value_t e, value_t *penv, int tail);
static value_t *alloc_words(int n); static value_t *alloc_words(int n);
static value_t relocate(value_t v); static value_t relocate(value_t v);
@ -465,12 +475,18 @@ void gc(int mustgrow)
void *temp; void *temp;
uint32_t i; uint32_t i;
readstate_t *rs; readstate_t *rs;
stackseg_t *ss;
curheap = tospace; curheap = tospace;
lim = curheap+heapsize-sizeof(cons_t); lim = curheap+heapsize-sizeof(cons_t);
for (i=0; i < SP; i++) ss = current_stack_seg;
Stack[i] = relocate(Stack[i]); ss->SP = SP;
while (ss) {
for (i=0; i < ss->SP; i++)
ss->Stack[i] = relocate(ss->Stack[i]);
ss = ss->prev;
}
trace_globals(symtab); trace_globals(symtab);
relocate_typetable(); relocate_typetable();
rs = readstate; rs = readstate;
@ -640,7 +656,6 @@ static void list(value_t *pv, uint32_t nargs, value_t *plastcdr)
(c-2)->cdr = (c-1)->car; (c-2)->cdr = (c-1)->car;
else else
(c-1)->cdr = *plastcdr; (c-1)->cdr = *plastcdr;
POPN(nargs);
} }
#define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0)) #define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0))
@ -650,7 +665,7 @@ static void list(value_t *pv, uint32_t nargs, value_t *plastcdr)
else { e=(xpr); goto eval_top; } } while (0) else { e=(xpr); goto eval_top; } } while (0)
/* eval a list of expressions, giving a list of the results */ /* eval a list of expressions, giving a list of the results */
static value_t evlis(value_t *pv, uint32_t penv) static value_t evlis(value_t *pv, value_t *penv)
{ {
PUSH(NIL); PUSH(NIL);
PUSH(NIL); PUSH(NIL);
@ -675,7 +690,42 @@ static value_t evlis(value_t *pv, uint32_t penv)
return POP(); return POP();
} }
static value_t do_trycatch(value_t expr, uint32_t penv) /*
If we start to run out of space on the lisp value stack, we allocate
a new stack array and put it on the top of the chain. The new stack
is active until this function returns. Any return past this function
must free the new segment.
*/
static value_t new_stackseg(value_t e, value_t *penv, int tail)
{
stackseg_t s;
s.prev = current_stack_seg;
s.Stack = (value_t*)malloc(N_STACK * sizeof(value_t));
if (s.Stack == NULL)
lerror(MemoryError, "eval: stack overflow");
current_stack_seg->SP = SP;
current_stack_seg = &s;
SP = 0;
Stack = s.Stack;
value_t v = NIL;
int err = 0;
FL_TRY {
v = eval_sexpr(e, penv, tail);
}
FL_CATCH {
err = 1;
v = lasterror;
}
free(s.Stack);
current_stack_seg = s.prev;
SP = current_stack_seg->SP;
Stack = current_stack_seg->Stack;
if (err) raise(v);
return v;
}
static value_t do_trycatch(value_t expr, value_t *penv)
{ {
value_t v; value_t v;
@ -710,18 +760,14 @@ static value_t do_trycatch(value_t expr, uint32_t penv)
of the stack from LL through CLO. of the stack from LL through CLO.
There might be zero values, in which case LL is NIL. There might be zero values, in which case LL is NIL.
Stack[penv-1] is the size of the whole environment (as a fixnum) penv[-1] tells you the environment size, from LL through CLO, 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) static value_t eval_sexpr(value_t e, value_t *penv, int tail)
{ {
value_t f, v, *pv, *argsyms, *body; value_t f, v, *pv, *lenv;
cons_t *c; cons_t *c;
symbol_t *sym; symbol_t *sym;
uint32_t saveSP, envsz, lenv, nargs; uint32_t saveSP, envsz, nargs;
int i, noeval=0; int i, noeval=0;
fixnum_t s, lo, hi; fixnum_t s, lo, hi;
cvalue_t *cv; cvalue_t *cv;
@ -731,26 +777,25 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
if (issymbol(e)) { if (issymbol(e)) {
sym = (symbol_t*)ptr(e); sym = (symbol_t*)ptr(e);
if (sym->syntax == TAG_CONST) return sym->binding; if (sym->syntax == TAG_CONST) return sym->binding;
pv = &Stack[penv];
while (1) { while (1) {
v = *pv++; v = *penv++;
while (iscons(v)) { while (iscons(v)) {
if (car_(v)==e) return *pv; if (car_(v)==e) return *penv;
v = cdr_(v); pv++; v = cdr_(v); penv++;
} }
if (v != NIL) { if (v != NIL) {
if (v == e) return *pv; // dotted list if (v == e) return *penv; // dotted list
pv++; penv++;
} }
if (*pv == NIL) break; if (*penv == NIL) break;
pv = &vector_elt(*pv, 0); penv = &vector_elt(*penv, 0);
} }
if (__unlikely((v = sym->binding) == UNBOUND)) if (__unlikely((v = sym->binding) == UNBOUND))
raise(list2(UnboundError, e)); raise(list2(UnboundError, e));
return v; return v;
} }
if (__unlikely(SP >= (N_STACK-MAX_ARGS))) if (__unlikely(SP >= (N_STACK-MAX_ARGS-4)))
lerror(MemoryError, "eval: stack overflow"); return new_stackseg(e, penv, tail);
saveSP = SP; saveSP = SP;
v = car_(e); v = car_(e);
PUSH(cdr_(e)); PUSH(cdr_(e));
@ -761,16 +806,19 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
goto apply_special; goto apply_special;
else if (f == TAG_CONST) else if (f == TAG_CONST)
f = ((symbol_t*)ptr(v))->binding; f = ((symbol_t*)ptr(v))->binding;
else else {
noeval = 2; noeval = 2;
PUSH(f);
v = Stack[saveSP];
goto move_args;
}
} }
else f = eval(v); else f = eval(v);
PUSH(f);
v = Stack[saveSP]; v = Stack[saveSP];
if (isbuiltinish(f)) {
// handle builtin function
// evaluate argument list, placing arguments on stack // evaluate argument list, placing arguments on stack
while (iscons(v)) { while (iscons(v)) {
if (SP-saveSP-1 == MAX_ARGS) { if (SP-saveSP-2 == MAX_ARGS) {
v = evlis(&Stack[saveSP], penv); v = evlis(&Stack[saveSP], penv);
PUSH(v); PUSH(v);
break; break;
@ -780,8 +828,10 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
PUSH(v); PUSH(v);
v = Stack[saveSP] = cdr_(Stack[saveSP]); v = Stack[saveSP] = cdr_(Stack[saveSP]);
} }
apply_builtin: do_apply:
nargs = SP - saveSP - 1; nargs = SP - saveSP - 2;
if (isbuiltinish(f)) {
// handle builtin function
apply_special: apply_special:
switch (uintval(f)) { switch (uintval(f)) {
// special forms // special forms
@ -794,27 +844,26 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
e = car(Stack[saveSP]); e = car(Stack[saveSP]);
v = car(cdr_(Stack[saveSP])); v = car(cdr_(Stack[saveSP]));
v = eval(v); v = eval(v);
pv = &Stack[penv];
while (1) { while (1) {
f = *pv++; f = *penv++;
while (iscons(f)) { while (iscons(f)) {
if (car_(f)==e) { if (car_(f)==e) {
*pv = v; *penv = v;
SP = saveSP; SP = saveSP;
return v; return v;
} }
f = cdr_(f); pv++; f = cdr_(f); penv++;
} }
if (f != NIL) { if (f != NIL) {
if (f == e) { if (f == e) {
*pv = v; *penv = v;
SP = saveSP; SP = saveSP;
return v; return v;
} }
pv++; penv++;
} }
if (*pv == NIL) break; if (*penv == NIL) break;
pv = &vector_elt(*pv, 0); penv = &vector_elt(*penv, 0);
} }
sym = tosymbol(e, "set!"); sym = tosymbol(e, "set!");
if (sym->syntax != TAG_CONST) if (sym->syntax != TAG_CONST)
@ -822,23 +871,23 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_LAMBDA: case F_LAMBDA:
// build a closure (lambda args body . env) // build a closure (lambda args body . env)
if (Stack[penv] != NIL) { if (*penv != NIL) {
// save temporary environment to the heap // save temporary environment to the heap
lenv = penv; lenv = penv;
envsz = numval(Stack[penv-1]); envsz = numval(penv[-1]);
pv = alloc_words(envsz + 1); pv = alloc_words(envsz + 1);
PUSH(tagptr(pv, TAG_VECTOR)); PUSH(tagptr(pv, TAG_VECTOR));
pv[0] = fixnum(envsz); pv[0] = fixnum(envsz);
pv++; pv++;
while (envsz--) while (envsz--)
*pv++ = Stack[penv++]; *pv++ = *penv++;
// environment representation changed; install // environment representation changed; install
// the new representation so everybody can see it // the new representation so everybody can see it
Stack[lenv] = NIL; lenv[0] = NIL;
Stack[lenv+1] = Stack[SP-1]; lenv[1] = Stack[SP-1];
} }
else { else {
PUSH(Stack[penv+1]); // env has already been captured; share PUSH(penv[1]); // env has already been captured; share
} }
c = (cons_t*)ptr(v=cons_reserve(3)); c = (cons_t*)ptr(v=cons_reserve(3));
e = Stack[saveSP]; e = Stack[saveSP];
@ -917,17 +966,17 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_WHILE: case F_WHILE:
PUSH(cdr(Stack[saveSP])); PUSH(cdr(Stack[saveSP]));
body = &Stack[SP-1]; lenv = &Stack[SP-1];
PUSH(*body); PUSH(*lenv);
Stack[saveSP] = car_(Stack[saveSP]); Stack[saveSP] = car_(Stack[saveSP]);
value_t *cond = &Stack[saveSP]; value_t *cond = &Stack[saveSP];
PUSH(FL_F); PUSH(FL_F);
pv = &Stack[SP-1]; pv = &Stack[SP-1];
while (eval(*cond) != FL_F) { while (eval(*cond) != FL_F) {
*body = Stack[SP-2]; *lenv = Stack[SP-2];
while (iscons(*body)) { while (iscons(*lenv)) {
*pv = eval(car_(*body)); *pv = eval(car_(*lenv));
*body = cdr_(*body); *lenv = cdr_(*lenv);
} }
} }
v = *pv; v = *pv;
@ -1016,7 +1065,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
else i = 0; else i = 0;
v = alloc_vector(nargs+i, 0); v = alloc_vector(nargs+i, 0);
memcpy(&vector_elt(v,0), &Stack[saveSP+1], nargs*sizeof(value_t)); memcpy(&vector_elt(v,0), &Stack[saveSP+2], nargs*sizeof(value_t));
if (i > 0) { if (i > 0) {
e = Stack[SP-1]; e = Stack[SP-1];
while (iscons(e)) { while (iscons(e)) {
@ -1136,7 +1185,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_ADD: case F_ADD:
s = 0; s = 0;
i = saveSP+1; i = saveSP+2;
if (nargs > MAX_ARGS) goto add_ovf; if (nargs > MAX_ARGS) goto add_ovf;
for (; i < (int)SP; i++) { for (; i < (int)SP; i++) {
if (__likely(isfixnum(Stack[i]))) { if (__likely(isfixnum(Stack[i]))) {
@ -1157,7 +1206,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_SUB: case F_SUB:
if (__unlikely(nargs < 1)) lerror(ArgError, "-: too few arguments"); if (__unlikely(nargs < 1)) lerror(ArgError, "-: too few arguments");
i = saveSP+1; i = saveSP+2;
if (nargs == 1) { if (nargs == 1) {
if (__likely(isfixnum(Stack[i]))) if (__likely(isfixnum(Stack[i])))
v = fixnum(-numval(Stack[i])); v = fixnum(-numval(Stack[i]));
@ -1190,7 +1239,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_MUL: case F_MUL:
accum = 1; accum = 1;
i = saveSP+1; i = saveSP+2;
if (nargs > MAX_ARGS) goto mul_ovf; if (nargs > MAX_ARGS) goto mul_ovf;
for (; i < (int)SP; i++) { for (; i < (int)SP; i++) {
if (__likely(isfixnum(Stack[i]))) { if (__likely(isfixnum(Stack[i]))) {
@ -1210,7 +1259,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_DIV: case F_DIV:
if (__unlikely(nargs < 1)) lerror(ArgError, "/: too few arguments"); if (__unlikely(nargs < 1)) lerror(ArgError, "/: too few arguments");
i = saveSP+1; i = saveSP+2;
if (nargs == 1) { if (nargs == 1) {
v = fl_div2(fixnum(1), Stack[i]); v = fl_div2(fixnum(1), Stack[i]);
} }
@ -1276,25 +1325,25 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
v = Stack[SP-1]; v = Stack[SP-1];
if (selfevaluating(v)) { SP=saveSP; return v; } if (selfevaluating(v)) { SP=saveSP; return v; }
if (tail) { if (tail) {
Stack[penv-1] = fixnum(2); assert((ulong_t)(penv-Stack)<N_STACK);
Stack[penv] = NIL; penv[-1] = fixnum(2);
Stack[penv+1] = NIL; penv[0] = NIL;
SP = penv + 2; penv[1] = NIL;
SP = (penv-Stack) + 2;
e=v; e=v;
goto eval_top; goto eval_top;
} }
else { else {
PUSH(fixnum(2));
PUSH(NIL); PUSH(NIL);
PUSH(NIL); PUSH(NIL);
v = eval_sexpr(v, SP-2, 1); v = eval_sexpr(v, &Stack[SP-2], 1);
} }
break; break;
case F_EVALSTAR: case F_EVALSTAR:
argcount("eval*", nargs, 1); argcount("eval*", nargs, 1);
e = Stack[SP-1]; e = Stack[SP-1];
if (selfevaluating(e)) { SP=saveSP; return e; } if (selfevaluating(e)) { SP=saveSP; return e; }
SP = penv+2; POPN(3);
goto eval_top; goto eval_top;
case F_FOR: case F_FOR:
argcount("for", nargs, 3); argcount("for", nargs, 3);
@ -1315,12 +1364,12 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
Stack[SP-3] = car_(f); // lambda list Stack[SP-3] = car_(f); // lambda list
Stack[SP-2] = fixnum(s); // argument value Stack[SP-2] = fixnum(s); // argument value
v = car_(cdr_(f)); v = car_(cdr_(f));
if (!selfevaluating(v)) v = eval_sexpr(v, SP-3, 0); if (!selfevaluating(v)) v = eval_sexpr(v, &Stack[SP-3], 0);
} }
break; break;
case F_SPECIAL_APPLY: case F_SPECIAL_APPLY:
v = Stack[saveSP-4]; f = Stack[saveSP-4];
f = Stack[saveSP-5]; v = Stack[saveSP-3];
PUSH(f); PUSH(f);
PUSH(v); PUSH(v);
nargs = 2; nargs = 2;
@ -1328,104 +1377,72 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
case F_APPLY: case F_APPLY:
argcount("apply", nargs, 2); argcount("apply", nargs, 2);
v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
f = Stack[SP-2]; // first arg is new function f = Stack[saveSP+1] = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args POPN(2); // pop apply's args
if (isbuiltinish(f)) { move_args:
assert(!isspecial(f));
// unpack arglist onto the stack
while (iscons(v)) { while (iscons(v)) {
if (SP-saveSP-1 == MAX_ARGS) { if (SP-saveSP-2 == MAX_ARGS) {
PUSH(v); PUSH(v);
break; break;
} }
PUSH(car_(v)); PUSH(car_(v));
v = cdr_(v); v = cdr_(v);
} }
goto apply_builtin; goto do_apply;
}
noeval = 1;
goto apply_lambda;
case F_TRUE: case F_TRUE:
case F_FALSE: case F_FALSE:
case F_NIL: case F_NIL:
goto apply_type_error; goto apply_type_error;
default: default:
// function pointer tagged as a builtin // function pointer tagged as a builtin
v = ((builtin_t)ptr(f))(&Stack[saveSP+1], nargs); v = ((builtin_t)ptr(f))(&Stack[saveSP+2], nargs);
} }
SP = saveSP; SP = saveSP;
return v; return v;
} }
apply_lambda:
if (__likely(iscons(f))) { if (__likely(iscons(f))) {
// apply lambda expression // apply lambda expression
f = cdr_(f); f = Stack[saveSP+1];
PUSH(f); f = Stack[saveSP+1] = cdr_(f);
if (!iscons(f)) goto notpair; if (!iscons(f)) goto notpair;
PUSH(car_(f)); // arglist v = car_(f); // arglist
argsyms = &Stack[SP-1]; i = nargs;
// build a calling environment for the lambda
// the environment is the argument binds on top of the captured
// environment
if (noeval) {
while (iscons(v)) { while (iscons(v)) {
// bind args if (i == 0)
if (!iscons(*argsyms)) { lerror(ArgError, "apply: too few arguments");
if (__unlikely(*argsyms == NIL)) i--;
lerror(ArgError, "apply: too many arguments");
break;
}
PUSH(car_(v));
*argsyms = cdr_(*argsyms);
v = cdr_(v); v = cdr_(v);
} }
if (*argsyms != NIL && issymbol(*argsyms)) if (v == NIL) {
PUSH(v); if (i > 0)
lerror(ArgError, "apply: too many arguments");
} }
else { else {
while (iscons(v)) { if (i > 0) {
// bind args list(&v, i, &NIL);
if (!iscons(*argsyms)) { if (nargs > MAX_ARGS) {
if (__unlikely(*argsyms == NIL)) c = (cons_t*)curheap;
lerror(ArgError, "apply: too many arguments"); (c-2)->cdr = (c-1)->car;
break;
} }
v = car_(v); Stack[SP-i] = v;
v = eval(v); SP -= (i-1);
PUSH(v);
*argsyms = cdr_(*argsyms);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
} }
if (*argsyms != NIL && issymbol(*argsyms)) { else {
PUSH(Stack[saveSP]); 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]);
} }
if (SP > (uint32_t)i)
list(&Stack[i-1], SP-i, &Stack[saveSP]);
}
}
if (__unlikely(iscons(*argsyms))) {
lerror(ArgError, "apply: too few arguments");
} }
f = cdr_(Stack[saveSP+1]); f = cdr_(Stack[saveSP+1]);
if (!iscons(f)) goto notpair; if (!iscons(f)) goto notpair;
e = car_(f); e = car_(f);
if (selfevaluating(e)) { SP=saveSP; return(e); } if (selfevaluating(e)) { SP=saveSP; return(e); }
PUSH(cdr_(f)); // add closed environment PUSH(cdr_(f)); // add closed environment
*argsyms = car_(Stack[saveSP+1]); // put lambda list Stack[saveSP+1] = car_(Stack[saveSP+1]); // put lambda list
envsz = SP - saveSP - 1;
if (noeval == 2) { if (noeval == 2) {
// macro: evaluate body in lambda environment // macro: evaluate body in lambda environment
Stack[saveSP+1] = fixnum(SP-saveSP-2); Stack[saveSP] = fixnum(envsz);
e = eval_sexpr(e, saveSP+2, 1); e = eval_sexpr(e, &Stack[saveSP+1], 1);
SP = saveSP; SP = saveSP;
if (selfevaluating(e)) return(e); if (selfevaluating(e)) return(e);
noeval = 0; noeval = 0;
@ -1433,19 +1450,17 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
goto eval_top; goto eval_top;
} }
else { else {
envsz = SP - saveSP - 2;
if (tail) { if (tail) {
noeval = 0;
// ok to overwrite environment // ok to overwrite environment
penv[-1] = fixnum(envsz);
for(i=0; i < (int)envsz; i++) for(i=0; i < (int)envsz; i++)
Stack[penv+i] = Stack[saveSP+2+i]; penv[i] = Stack[saveSP+1+i];
SP = penv+envsz; SP = (penv-Stack)+envsz;
Stack[penv-1] = fixnum(envsz);
goto eval_top; goto eval_top;
} }
else { else {
Stack[saveSP+1] = fixnum(envsz); Stack[saveSP] = fixnum(envsz);
v = eval_sexpr(e, saveSP+2, 1); v = eval_sexpr(e, &Stack[saveSP+1], 1);
SP = saveSP; SP = saveSP;
return v; return v;
} }
@ -1575,10 +1590,9 @@ value_t toplevel_eval(value_t expr)
{ {
value_t v; value_t v;
uint32_t saveSP = SP; uint32_t saveSP = SP;
PUSH(fixnum(2));
PUSH(NIL); PUSH(NIL);
PUSH(NIL); PUSH(NIL);
v = topeval(expr, SP-2); v = topeval(expr, &Stack[SP-2]);
SP = saveSP; SP = saveSP;
return v; return v;
} }

2
femtolisp/flisp.h
View File

@ -93,7 +93,7 @@ typedef struct _symbol_t {
(((unsigned char*)ptr(v)) < fromspace+heapsize)) (((unsigned char*)ptr(v)) < fromspace+heapsize))
#define isgensym(x) (issymbol(x) && ismanaged(x)) #define isgensym(x) (issymbol(x) && ismanaged(x))
extern value_t Stack[]; extern value_t *Stack;
extern uint32_t SP; extern uint32_t SP;
#define PUSH(v) (Stack[SP++] = (v)) #define PUSH(v) (Stack[SP++] = (v))
#define POP() (Stack[--SP]) #define POP() (Stack[--SP])

7
femtolisp/system.lsp
View File

@ -135,6 +135,11 @@
(nthcdr (cdr lst) (- n 1)))) (nthcdr (cdr lst) (- n 1))))
(define list-tail nthcdr) (define list-tail nthcdr)
(define (list-head lst n)
(if (<= n 0) ()
(cons (car lst)
(list-head (cdr lst) (- n 1)))))
(define (list-ref lst n) (define (list-ref lst n)
(car (nthcdr lst n))) (car (nthcdr lst n)))
@ -482,7 +487,7 @@
(define (print . args) (apply io.print (cons *output-stream* args))) (define (print . args) (apply io.print (cons *output-stream* args)))
(define (princ . args) (apply io.princ (cons *output-stream* args))) (define (princ . args) (apply io.princ (cons *output-stream* args)))
(define (newline) (princ *linefeed*)) (define (newline) (princ *linefeed*) #t)
(define (display x) (princ x) #t) (define (display x) (princ x) #t)
(define (println . args) (prog1 (apply print args) (newline))) (define (println . args) (prog1 (apply print args) (newline)))

4
femtolisp/todo
View File

@ -151,8 +151,8 @@ bugs:
- (setf (car x) y) doesn't return y - (setf (car x) y) doesn't return y
* reader needs to check errno in isnumtok * reader needs to check errno in isnumtok
* prettyprint size measuring is not utf-8 correct * prettyprint size measuring is not utf-8 correct
- stack is too limited. possibly allocate user frames with alloca so the * stack is too limited.
only limit is the process stack size. . add extra heap-allocated stack segments as needed.
* argument list length is too limited. * argument list length is too limited.
need to fix it for: +,-,*,/,&,|,$,list,vector,apply,string,array need to fix it for: +,-,*,/,&,|,$,list,vector,apply,string,array
. for builtins, make Nth argument list of rest args . for builtins, make Nth argument list of rest args

19
femtolisp/torture.scm Normal file
View File

@ -0,0 +1,19 @@
(define (big n)
(if (<= n 0)
0
`(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
(define nst `(display ,(big 100000)))
(display (eval nst))
(newline)
(define (f x)
(begin (display x)
(newline)
(f (+ x 1))
0))
(define longg (cons '+ (map (lambda (x) 1) (iota 1000000))))
(display (eval longg))
(newline)