ref: 672558d30fdfffa9f3ede3c7b671d28285407437
parent: b9a1be78a090a3d57e6da9b10a247c8292726068
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Tue Apr 14 20:12:01 EDT 2009
bytecode vm is now working, off by default various bug fixes language changes: • constant symbols no longer shadow everything • eval* removed • vararg lists always allocated on entry, dotted argument lists not preserved new applyn() entry point
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -129,7 +129,7 @@
return symbol(cvalue_data(args[0]));
}
-extern value_t LAMBDA;
+extern value_t LAMBDA, COMPILEDLAMBDA;
static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
{@@ -142,7 +142,8 @@
sym->syntax = 0;
}
else {- if (!iscons(args[1]) || car_(args[1])!=LAMBDA)
+ if (!iscons(args[1]) || (car_(args[1])!=LAMBDA &&
+ car_(args[1])!=COMPILEDLAMBDA))
type_error("set-syntax!", "function", args[1]);sym->syntax = args[1];
}
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -8,13 +8,14 @@
(define Instructions
(make-enum-table
- [:nop :dup :pop :call :jmp :brf :brt :jmp.l :brf.l :brt.l :ret
+ [:nop :dup :pop :call :tcall :jmp :brf :brt :jmp.l :brf.l :brt.l :ret
+ :tapply
:eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol?
:number? :bound? :pair? :builtin? :vector? :fixnum?
:cons :list :car :cdr :set-car! :set-cdr!
- :eval :eval* :apply
+ :eval :apply
:+ :- :* :/ :< :compare
@@ -24,7 +25,7 @@
:loadg :loada :loadc :loadg.l
:setg :seta :setc :setg.l
- :closure :trycatch :tcall :tapply :argc :vargc]))
+ :closure :trycatch :argc :vargc]))
(define arg-counts
(table :eq? 2 :eqv? 2
@@ -37,10 +38,9 @@
:cons 2 :car 1
:cdr 1 :set-car! 2
:set-cdr! 2 :eval 1
- :eval* 1 :apply 2
- :< 2 :for 3
- :compare 2 :aref 2
- :aset! 3))
+ :apply 2 :< 2
+ :for 3 :compare 2
+ :aref 2 :aset! 3))
(define 1/Instructions (table.invert Instructions))
@@ -181,11 +181,11 @@
`(closed ,lev ,i))
(lookup-sym s
(cdr env)
- (if (null? curr) lev (+ lev 1))
+ (if (or arg? (null? curr)) lev (+ lev 1))
#f)))))
(define (compile-sym g env s Is)
- (let ((loc (lookup-sym s env -1 #t)))
+ (let ((loc (lookup-sym s env 0 #t)))
(case (car loc)
(arg (emit g (aref Is 0) (cadr loc)))
(closed (emit g (aref Is 1) (cadr loc) (caddr loc)))
@@ -199,13 +199,13 @@
(cond-clauses->if (cdr form)))
(define (cond-clauses->if lst)
(if (atom? lst)
- lst
- (let ((clause (car lst)))
- (if (eq? (car clause) 'else)
- (cons 'begin (cdr clause))
- `(if ,(car clause)
- ,(cons 'begin (cdr clause))
- ,(cond-clauses->if (cdr lst)))))))
+ #f
+ (let ((clause (car lst)))
+ (if (eq? (car clause) 'else)
+ (cons 'begin (cdr clause))
+ `(if ,(car clause)
+ ,(cons 'begin (cdr clause))
+ ,(cond-clauses->if (cdr lst)))))))
(define (compile-if g env tail? x)
(let ((elsel (make-label g))
@@ -241,11 +241,12 @@
(define (compile-while g env cond body)
(let ((top (make-label g))
(end (make-label g)))
+ (compile-in g env #f #f)
(mark-label g top)
(compile-in g env #f cond)
(emit g :brf end)
- (compile-in g env #f body)
(emit g :pop)
+ (compile-in g env #f body)
(emit g :jmp top)
(mark-label g end)))
@@ -365,12 +366,12 @@
(cond (compile-in g env tail? (cond->if x)))
(if (compile-if g env tail? x))
(begin (compile-begin g env tail? (cdr x)))
- (prog1 (compile-prog1 g env tail? x))
+ (prog1 (compile-prog1 g env x))
(lambda (begin (emit g :loadv (compile-f env x))
(emit g :closure)))
(and (compile-and g env tail? (cdr x)))
(or (compile-or g env tail? (cdr x)))
- (while (compile-while g env (cadr x) (caddr x)))
+ (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
(set! (compile-in g env #f (caddr x))
(compile-sym g env (cadr x) [:seta :setc :setg]))
(trycatch (compile-in g env #f `(lambda () ,(cadr x)))
@@ -383,13 +384,14 @@
(args (cadr f)))
(if (null? (lastcdr args))
(emit g :argc (length args))
- (emit g :vargc (length args)))
+ (emit g :vargc (if (atom? args) 0 (length args))))
(compile-in g (cons (to-proper args) env) #t (caddr f))
(emit g :ret)
`(compiled-lambda ,args ,(bytecode g))))
-(define (compile x)
- (bytecode (compile-in (make-code-emitter) () #t x)))
+(define (compile f) (compile-f () f))
+
+(define (compile-thunk expr) (compile `(lambda () ,expr)))
(define (ref-uint32-LE a i)
(+ (ash (aref a (+ i 0)) 0)
--- a/femtolisp/cps.lsp
+++ b/femtolisp/cps.lsp
@@ -8,7 +8,7 @@
(cond-clauses->if (cdr form)))
(define (cond-clauses->if lst)
(if (atom? lst)
- lst
+ #f
(let ((clause (car lst)))
`(if ,(car clause)
,(cond-body (cdr clause))
@@ -22,13 +22,13 @@
,(begin->cps (cdr forms) k)))))))
(define-macro (lambda/cc args body)
- `(set-car! (lambda ,args ,body) 'lambda/cc))
+ `(cons 'lambda/cc (lambda ,args ,body)))
; a utility used at run time to dispatch a call with or without
; the continuation argument, depending on the function
(define (funcall/cc f k . args)
(if (and (pair? f) (eq (car f) 'lambda/cc))
- (apply f (cons k args))
+ (apply (cdr f) (cons k args))
(k (apply f args))))
(define *funcall/cc-names*
(list->vector
@@ -38,7 +38,7 @@
(let ((name (aref *funcall/cc-names* (length args))))
`(define (,name f k ,@args)
(if (and (pair? f) (eq (car f) 'lambda/cc))
- (f k ,@args)
+ ((cdr f) k ,@args)
(k (f ,@args))))))
(def-funcall/cc-n ())
(def-funcall/cc-n (a0))
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -55,7 +55,7 @@
static char *builtin_names[] =
{ // special forms"quote", "cond", "if", "and", "or", "while", "lambda",
- "trycatch", "%apply", "set!", "prog1", "begin",
+ "trycatch", "%apply", "%applyn", "set!", "prog1", "begin",
// predicates
"eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
@@ -65,7 +65,7 @@
"cons", "list", "car", "cdr", "set-car!", "set-cdr!",
// execution
- "eval", "eval*", "apply",
+ "eval", "apply",
// arithmetic
"+", "-", "*", "/", "<", "compare",
@@ -96,7 +96,7 @@
value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym;
-static value_t eval_sexpr(value_t e, value_t *penv, int tail);
+static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz);
static value_t apply_cl(uint32_t nargs);
static value_t *alloc_words(int n);
static value_t relocate(value_t v);
@@ -467,7 +467,7 @@
}
}
-static value_t special_apply_form;
+static value_t special_apply_form, special_applyn_form;
static value_t apply1_args;
static value_t memory_exception_value;
@@ -502,6 +502,7 @@
}
lasterror = relocate(lasterror);
special_apply_form = relocate(special_apply_form);
+ special_applyn_form = relocate(special_applyn_form);
apply1_args = relocate(apply1_args);
memory_exception_value = relocate(memory_exception_value);
@@ -551,10 +552,31 @@
value_t apply1(value_t f, value_t a0)
{- car_(apply1_args) = a0;
- return apply(f, apply1_args);
+ PUSH(f);
+ PUSH(a0);
+ PUSH(fixnum(1));
+ value_t v = toplevel_eval(special_applyn_form);
+ POPN(3);
+ return v;
}
+value_t applyn(uint32_t n, value_t f, ...)
+{+ va_list ap;
+ va_start(ap, f);
+ size_t i;
+
+ PUSH(f);
+ for(i=0; i < n; i++) {+ value_t a = va_arg(ap, value_t);
+ PUSH(a);
+ }
+ PUSH(fixnum(n));
+ value_t v = toplevel_eval(special_applyn_form);
+ POPN(n+2);
+ return v;
+}
+
value_t listn(size_t n, ...)
{va_list ap;
@@ -634,23 +656,21 @@
// eval -----------------------------------------------------------------------
/*
- take the final cdr as an argument so the list builtin can give
- the same result as (lambda x x).
-
- however, there is still one interesting difference.
+ there is one interesting difference between this and (lambda x x).
(eq a (apply list a)) is always false for nonempty a, while
(eq a (apply (lambda x x) a)) is always true. the justification for this
is that a vararg lambda often needs to recur by applying itself to the
tail of its argument list, so copying the list would be unacceptable.
*/
-static void list(value_t *pv, uint32_t nargs, value_t *plastcdr)
+static value_t list(value_t *args, uint32_t nargs)
{cons_t *c;
uint32_t i;
- *pv = cons_reserve(nargs);
- c = (cons_t*)ptr(*pv);
- for(i=SP-nargs; i < SP; i++) {- c->car = Stack[i];
+ value_t v;
+ v = cons_reserve(nargs);
+ c = (cons_t*)ptr(v);
+ for(i=0; i < nargs; i++) {+ c->car = args[i];
c->cdr = tagptr(c+1, TAG_CONS);
c++;
}
@@ -657,17 +677,18 @@
if (nargs > MAX_ARGS)
(c-2)->cdr = (c-1)->car;
else
- (c-1)->cdr = *plastcdr;
+ (c-1)->cdr = NIL;
+ return v;
}
-#define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0))
-#define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1))
+#define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0,envsz))
+#define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1,2))
#define tail_eval(xpr) do { \ if (selfevaluating(xpr)) { SP=saveSP; return (xpr); } \ else { e=(xpr); goto eval_top; } } while (0)/* eval a list of expressions, giving a list of the results */
-static value_t evlis(value_t *pv, value_t *penv)
+static value_t evlis(value_t *pv, value_t *penv, uint32_t envsz)
{PUSH(NIL);
PUSH(NIL);
@@ -680,7 +701,7 @@
v = mk_cons();
car_(v) = Stack[SP-1];
cdr_(v) = NIL;
- (void)POP();
+ POPN(1);
if (*rest == NIL)
Stack[SP-2] = v;
else
@@ -688,7 +709,7 @@
*rest = v;
v = *pv = cdr_(*pv);
}
- (void)POP();
+ POPN(1);
return POP();
}
@@ -698,7 +719,7 @@
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)
+static value_t new_stackseg(value_t e, value_t *penv, int tail, uint32_t envsz)
{stackseg_t s;
@@ -713,7 +734,7 @@
value_t v = NIL;
int err = 0;
FL_TRY {- v = eval_sexpr(e, penv, tail);
+ v = eval_sexpr(e, penv, tail, envsz);
}
FL_CATCH {err = 1;
@@ -727,7 +748,7 @@
return v;
}
-static value_t do_trycatch(value_t expr, value_t *penv)
+static value_t do_trycatch(value_t expr, value_t *penv, uint32_t envsz)
{value_t v;
@@ -748,6 +769,23 @@
return v;
}
+static value_t do_trycatch2()
+{+ value_t v;
+ value_t thunk = Stack[SP-2];
+ Stack[SP-2] = Stack[SP-1];
+ Stack[SP-1] = thunk;
+
+ FL_TRY {+ v = apply_cl(0);
+ }
+ FL_CATCH {+ Stack[SP-1] = lasterror;
+ v = apply_cl(1);
+ }
+ return v;
+}
+
/* stack setup on entry:
n n+1 ...
+-----+-----+-----+-----+-----+-----+-----+-----+
@@ -764,12 +802,12 @@
penv[-1] tells you the environment size, from LL through CLO, as a fixnum.
*/
-static value_t eval_sexpr(value_t e, value_t *penv, int tail)
+static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
{value_t f, v, *pv, *lenv;
cons_t *c;
symbol_t *sym;
- uint32_t saveSP, bp, envsz, nargs;
+ uint32_t saveSP, bp, nargs;
int i, noeval=0;
fixnum_t s, lo, hi;
int64_t accum;
@@ -783,7 +821,6 @@
eval_top:
if (issymbol(e)) {sym = (symbol_t*)ptr(e);
- if (sym->syntax == TAG_CONST) { SP=saveSP; return sym->binding; } while (1) {v = *penv++;
while (iscons(v)) {@@ -803,7 +840,7 @@
return v;
}
if (__unlikely(SP >= (N_STACK-MAX_ARGS-4))) {- v = new_stackseg(e, penv, tail);
+ v = new_stackseg(e, penv, tail, envsz);
SP = saveSP;
return v;
}
@@ -811,15 +848,13 @@
v = car_(e);
PUSH(cdr_(e));
if (selfevaluating(v)) f=v;
- else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax)) {+ else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax) && f!=TAG_CONST) {// handle special syntax forms
if (isspecial(f))
goto apply_special;
- else if (f == TAG_CONST)
- f = ((symbol_t*)ptr(v))->binding;
else {- noeval = 2;
PUSH(f);
+ noeval = 2;
v = Stack[bp];
goto move_args;
}
@@ -830,7 +865,7 @@
// evaluate argument list, placing arguments on stack
while (iscons(v)) { if (SP-bp-2 == MAX_ARGS) {- v = evlis(&Stack[bp], penv);
+ v = evlis(&Stack[bp], penv, envsz);
PUSH(v);
break;
}
@@ -885,7 +920,6 @@
if (*penv != NIL) {// save temporary environment to the heap
lenv = penv;
- envsz = numval(penv[-1]);
pv = alloc_words(envsz + 1);
PUSH(tagptr(pv, TAG_VECTOR));
pv[0] = fixnum(envsz);
@@ -1019,7 +1053,7 @@
v = POP();
break;
case F_TRYCATCH:
- v = do_trycatch(car(Stack[bp]), penv);
+ v = do_trycatch(car(Stack[bp]), penv, envsz);
break;
// ordinary functions
@@ -1043,11 +1077,10 @@
v = tagptr(c, TAG_CONS);
break;
case F_LIST:
- if (nargs) {- Stack[bp] = v;
- list(&v, nargs, &Stack[bp]);
- }
- // else v is already set to the final cdr, which is the result
+ if (nargs)
+ v = list(&Stack[SP-nargs], nargs);
+ else
+ v = NIL;
break;
case F_CAR:
argcount("car", nargs, 1);@@ -1296,15 +1329,14 @@
argcount("eval", nargs, 1);e = Stack[SP-1];
if (selfevaluating(e)) { SP=saveSP; return e; }+ envsz = 2;
if (tail) {assert((ulong_t)(penv-Stack)<N_STACK);
- penv[-1] = fixnum(2);
penv[0] = NIL;
penv[1] = NIL;
SP = (penv-Stack) + 2;
}
else {- PUSH(fixnum(2));
PUSH(NIL);
PUSH(NIL);
tail = 1;
@@ -1311,12 +1343,6 @@
penv = &Stack[SP-2];
}
goto eval_top;
- case F_EVALSTAR:
- argcount("eval*", nargs, 1);- e = Stack[SP-1];
- if (selfevaluating(e)) { SP=saveSP; return e; }- POPN(3);
- goto eval_top;
case F_FOR:
argcount("for", nargs, 3);lo = tofixnum(Stack[SP-3], "for");
@@ -1323,25 +1349,32 @@
hi = tofixnum(Stack[SP-2], "for");
f = Stack[SP-1];
v = car(cdr(f));
- if (!iscons(v) || !iscons(cdr_(cdr_(f))) || cdr_(v) != NIL)
+ if (!iscons(v) || !iscons(cdr_(cdr_(f))) || cdr_(v) != NIL ||
+ car_(f) != LAMBDA)
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
+ SP += 3; // make space
Stack[SP-1] = cdr_(cdr_(f)); // cloenv
v = FL_F;
for(s=lo; s <= hi; s++) {- f = Stack[SP-5];
+ f = Stack[SP-4];
Stack[SP-3] = car_(f); // lambda list
Stack[SP-2] = fixnum(s); // argument value
v = car_(cdr_(f));
- if (!selfevaluating(v)) v = eval_sexpr(v, &Stack[SP-3], 0);
+ if (!selfevaluating(v)) v = eval_sexpr(v, &Stack[SP-3], 0, 3);
}
break;
+ case F_SPECIAL_APPLYN:
+ POPN(4);
+ v = POP();
+ nargs = numval(v);
+ bp = SP-nargs-2;
+ f = Stack[bp+1];
+ goto do_apply;
case F_SPECIAL_APPLY:
- f = Stack[bp-5];
- v = Stack[bp-4];
+ f = Stack[bp-4];
+ v = Stack[bp-3];
PUSH(f);
PUSH(v);
nargs = 2;
@@ -1348,7 +1381,7 @@
// falls through!!
case F_APPLY:
argcount("apply", nargs, 2);- v = Stack[bp] = Stack[SP-1]; // second arg is new arglist
+ v = Stack[SP-1]; // second arg is new arglist
f = Stack[bp+1] = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args
move_args:
@@ -1373,11 +1406,19 @@
return v;
}
f = Stack[bp+1];
+ assert(SP > bp+1);
if (__likely(iscons(f))) { if (car_(f) == COMPILEDLAMBDA) {- v = apply_cl(nargs);
- SP = saveSP;
- return v;
+ e = apply_cl(nargs);
+ if (noeval == 2) {+ if (selfevaluating(e)) { SP=saveSP; return(e); }+ noeval = 0;
+ goto eval_top;
+ }
+ else {+ SP = saveSP;
+ return e;
+ }
}
// apply lambda expression
f = Stack[bp+1] = cdr_(f);
@@ -1397,7 +1438,7 @@
else {v = NIL;
if (i > 0) {- list(&v, i, &NIL);
+ v = list(&Stack[SP-i], i);
if (nargs > MAX_ARGS) {c = (cons_t*)curheap;
(c-2)->cdr = (c-1)->car;
@@ -1412,12 +1453,10 @@
if (selfevaluating(e)) { SP=saveSP; return(e); }PUSH(cdr_(f)); // add closed environment
Stack[bp+1] = car_(Stack[bp+1]); // put lambda list
- envsz = SP - bp - 1;
if (noeval == 2) {// macro: evaluate body in lambda environment
- Stack[bp] = fixnum(envsz);
- e = eval_sexpr(e, &Stack[bp+1], 1);
+ e = eval_sexpr(e, &Stack[bp+1], 1, SP - bp - 1);
if (selfevaluating(e)) { SP=saveSP; return(e); }noeval = 0;
// macro: evaluate expansion in calling environment
@@ -1424,9 +1463,9 @@
goto eval_top;
}
else {+ envsz = SP - bp - 1;
if (tail) {// ok to overwrite environment
- penv[-1] = fixnum(envsz);
for(i=0; i < (int)envsz; i++)
penv[i] = Stack[bp+1+i];
SP = (penv-Stack)+envsz;
@@ -1433,7 +1472,6 @@
goto eval_top;
}
else {- Stack[bp] = fixnum(envsz);
penv = &Stack[bp+1];
tail = 1;
goto eval_top;
@@ -1460,6 +1498,7 @@
- check arg counts
- allocate vararg array
- push closed env, set up new environment
+ - restore SP
** need 'copyenv' instruction that moves env to heap, installs
heap version as the current env, and pushes the result vector.
@@ -1469,8 +1508,8 @@
*/
static value_t apply_cl(uint32_t nargs)
{- uint32_t i, n, ip, bp, envsz;
- fixnum_t s;
+ uint32_t i, n, ip, bp, envsz, saveSP=SP;
+ fixnum_t s, lo, hi;
int64_t accum;
uint8_t op, *code;
value_t func, v, bcode, x, e, ftl;
@@ -1480,34 +1519,15 @@
apply_cl_top:
func = Stack[SP-nargs-1];
+ assert(iscons(func));
+ assert(iscons(cdr_(func)));
+ assert(iscons(cdr_(cdr_(func))));
ftl = cdr_(cdr_(func));
bcode = car_(ftl);
code = cv_data((cvalue_t*)ptr(car_(bcode)));
- i = code[1];
- if (nargs < i)
+ assert(!ismanaged((uptrint_t)code));
+ if (nargs < code[1])
lerror(ArgError, "apply: too few arguments");
- if (code[0] == OP_VARGC) {- s = (fixnum_t)nargs - (fixnum_t)i;
- v = NIL;
- if (s > 0) {- list(&v, s, &NIL);
- if (nargs > MAX_ARGS) {- c = (cons_t*)curheap;
- (c-2)->cdr = (c-1)->car;
- }
- // reload movable pointers
- func = Stack[SP-nargs-1];
- ftl = cdr_(cdr_(func));
- bcode = car_(ftl);
- code = cv_data((cvalue_t*)ptr(car_(bcode)));
- }
- Stack[SP-s] = v;
- SP -= (s-1);
- nargs = i+1;
- }
- else if (nargs > i) {- lerror(ArgError, "apply: too many arguments");
- }
bp = SP-nargs;
x = cdr_(ftl); // cloenv
@@ -1514,16 +1534,48 @@
Stack[bp-1] = car_(cdr_(func)); // lambda list
penv = &Stack[bp-1];
PUSH(x);
+ // must keep a reference to the bcode object while executing it
+ PUSH(bcode);
PUSH(cdr_(bcode));
pvals = &Stack[SP-1];
- ip = 2;
+ ip = 0;
while (1) {op = code[ip++];
+ dispatch:
switch (op) {+ case OP_ARGC:
+ if (nargs > code[ip++]) {+ lerror(ArgError, "apply: too many arguments");
+ }
+ break;
+ case OP_VARGC:
+ i = code[ip++];
+ s = (fixnum_t)nargs - (fixnum_t)i;
+ v = NIL;
+ if (s > 0) {+ v = list(&Stack[bp+i], s);
+ if (nargs > MAX_ARGS) {+ c = (cons_t*)curheap;
+ (c-2)->cdr = (c-1)->car;
+ }
+ Stack[bp+i] = v;
+ Stack[bp+i+1] = Stack[bp+nargs];
+ Stack[bp+i+2] = Stack[bp+nargs+1];
+ Stack[bp+i+3] = Stack[bp+nargs+2];
+ }
+ else {+ PUSH(NIL);
+ Stack[SP-1] = Stack[SP-2];
+ Stack[SP-2] = Stack[SP-3];
+ Stack[SP-3] = Stack[SP-4];
+ Stack[SP-4] = NIL;
+ }
+ nargs = i+1;
+ break;
case OP_NOP: break;
case OP_DUP: v = Stack[SP-1]; PUSH(v); break;
- case OP_POP: (void)POP(); break;
+ case OP_POP: POPN(1); break;
case OP_TCALL:
case OP_CALL:
i = code[ip++]; // nargs
@@ -1534,9 +1586,13 @@
if (uintval(func) > N_BUILTINS) {v = ((builtin_t)ptr(func))(&Stack[SP-i], i);
}
+ else {+ PUSH(fixnum(i));
+ v = toplevel_eval(special_applyn_form);
+ }
}
- else {- if (iscons(func) && car_(func) == COMPILEDLAMBDA) {+ else if (iscons(func)) {+ if (car_(func) == COMPILEDLAMBDA) { if (op == OP_TCALL) {for(s=-1; s < (fixnum_t)i; s++)
Stack[bp+s] = Stack[SP-i+s];
@@ -1548,7 +1604,14 @@
v = apply_cl(i);
}
}
+ else {+ PUSH(fixnum(i));
+ v = toplevel_eval(special_applyn_form);
+ }
}
+ else {+ type_error("apply", "function", func);+ }
SP = s-i-1;
PUSH(v);
break;
@@ -1574,11 +1637,11 @@
if (v != FL_F) ip = *(uint32_t*)&code[ip];
else ip += 4;
break;
- case OP_RET: v = POP(); return v;
+ case OP_RET: v = POP(); SP = saveSP; return v;
case OP_EQ:
Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
- POP(); break;
+ POPN(1); break;
case OP_EQV:
if (Stack[SP-2] == Stack[SP-1]) {v = FL_T;
@@ -1590,7 +1653,7 @@
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
FL_T : FL_F;
}
- Stack[SP-2] = v; POP();
+ Stack[SP-2] = v; POPN(1);
break;
case OP_EQUAL:
if (Stack[SP-2] == Stack[SP-1]) {@@ -1603,7 +1666,7 @@
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
FL_T : FL_F;
}
- Stack[SP-2] = v; POP();
+ Stack[SP-2] = v; POPN(1);
break;
case OP_PAIRP:
Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); break;
@@ -1643,7 +1706,7 @@
c->car = Stack[SP-2];
c->cdr = Stack[SP-1];
Stack[SP-2] = tagptr(c, TAG_CONS);
- POP(); break;
+ POPN(1); break;
case OP_CAR:
c = tocons(Stack[SP-1], "car");
Stack[SP-1] = c->car;
@@ -1654,13 +1717,16 @@
break;
case OP_SETCAR:
car(Stack[SP-2]) = Stack[SP-1];
- POP(); break;
+ POPN(1); break;
case OP_SETCDR:
cdr(Stack[SP-2]) = Stack[SP-1];
- POP(); break;
+ POPN(1); break;
case OP_LIST:
i = code[ip++];
- list(&v, i, &NIL);
+ if (i > 0)
+ v = list(&Stack[SP-i], i);
+ else
+ v = NIL;
POPN(i);
PUSH(v);
break;
@@ -1668,7 +1734,6 @@
v = toplevel_eval(POP());
PUSH(v);
break;
- case OP_EVALSTAR:
case OP_TAPPLY:
case OP_APPLY:
@@ -1691,7 +1756,7 @@
n = code[ip++];
i = SP-n;
if (n > MAX_ARGS) goto add_ovf;
- for (; i < (int)SP; i++) {+ for (; i < SP; i++) { if (__likely(isfixnum(Stack[i]))) {s += numval(Stack[i]);
if (__unlikely(!fits_fixnum(s))) {@@ -1725,7 +1790,7 @@
if (__likely(bothfixnums(Stack[i], Stack[i+1]))) {s = numval(Stack[i]) - numval(Stack[i+1]);
if (__likely(fits_fixnum(s))) {- POP();
+ POPN(1);
Stack[SP-1] = fixnum(s);
break;
}
@@ -1752,7 +1817,7 @@
n = code[ip++];
i = SP-n;
if (n > MAX_ARGS) goto mul_ovf;
- for (; i < (int)SP; i++) {+ for (; i < SP; i++) { if (__likely(isfixnum(Stack[i]))) {accum *= numval(Stack[i]);
}
@@ -1798,12 +1863,12 @@
v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ?
FL_T : FL_F;
}
- POP();
+ POPN(1);
Stack[SP-1] = v;
break;
case OP_COMPARE:
Stack[SP-2] = compare(Stack[SP-2], Stack[SP-1]);
- POP();
+ POPN(1);
break;
case OP_VECTOR:
@@ -1841,7 +1906,7 @@
else { type_error("aref", "sequence", v);}
- POP();
+ POPN(1);
Stack[SP-1] = v;
break;
case OP_ASET:
@@ -1862,6 +1927,19 @@
Stack[SP-1] = v;
break;
case OP_FOR:
+ lo = tofixnum(Stack[SP-3], "for");
+ hi = tofixnum(Stack[SP-2], "for");
+ //f = Stack[SP-1];
+ v = FL_F;
+ SP += 2;
+ for(s=lo; s <= hi; s++) {+ Stack[SP-2] = Stack[SP-3];
+ Stack[SP-1] = fixnum(s);
+ v = apply_cl(1);
+ }
+ POPN(4);
+ Stack[SP-1] = v;
+ break;
case OP_LOADT: PUSH(FL_T); break;
case OP_LOADF: PUSH(FL_F); break;
@@ -1869,19 +1947,22 @@
case OP_LOAD0: PUSH(fixnum(0)); break;
case OP_LOAD1: PUSH(fixnum(1)); break;
case OP_LOADV:
+ assert(code[ip] < vector_size(*pvals));
v = vector_elt(*pvals, code[ip]); ip++;
PUSH(v);
break;
case OP_LOADVL:
- v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4;
+ v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4;
PUSH(v);
break;
case OP_LOADGL:
- v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4;
+ v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4;
goto do_loadg;
case OP_LOADG:
+ assert(code[ip] < vector_size(*pvals));
v = vector_elt(*pvals, code[ip]); ip++;
do_loadg:
+ assert(issymbol(v));
sym = (symbol_t*)ptr(v);
if (sym->binding == UNBOUND)
raise(list2(UnboundError, v));
@@ -1889,11 +1970,13 @@
break;
case OP_SETGL:
- v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4;
+ v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4;
goto do_setg;
case OP_SETG:
+ assert(code[ip] < vector_size(*pvals));
v = vector_elt(*pvals, code[ip]); ip++;
do_setg:
+ assert(issymbol(v));
sym = (symbol_t*)ptr(v);
v = Stack[SP-1];
if (sym->syntax != TAG_CONST)
@@ -1901,20 +1984,32 @@
break;
case OP_LOADA:
+ assert(nargs > 0);
i = code[ip++];
- if (penv[0] == NIL)
+ if (penv[0] == NIL) {+ assert(isvector(penv[1]));
+ assert(i+1 < vector_size(penv[1]));
v = vector_elt(penv[1], i+1);
- else
+ }
+ else {+ assert(bp+i < SP);
v = Stack[bp+i];
+ }
PUSH(v);
break;
case OP_SETA:
+ assert(nargs > 0);
v = Stack[SP-1];
i = code[ip++];
- if (penv[0] == NIL)
+ if (penv[0] == NIL) {+ assert(isvector(penv[1]));
+ assert(i+1 < vector_size(penv[1]));
vector_elt(penv[1], i+1) = v;
- else
+ }
+ else {+ assert(bp+i < SP);
Stack[bp+i] = v;
+ }
break;
case OP_LOADC:
case OP_SETC:
@@ -1932,6 +2027,8 @@
}
while (s--)
v = vector_elt(v, vector_size(v)-1);
+ assert(isvector(v));
+ assert(i < vector_size(v));
if (op == OP_SETC)
vector_elt(v, i) = Stack[SP-1];
else
@@ -1969,11 +2066,14 @@
//if (!iscons(e=cdr_(e))) goto notpair;
c->car = car_(e); //body
c->cdr = Stack[SP-1]; //env
- POP();
+ POPN(1);
Stack[SP-1] = v;
break;
case OP_TRYCATCH:
+ v = do_trycatch2();
+ POPN(1);
+ Stack[SP-1] = v;
break;
}
}
@@ -2049,10 +2149,11 @@
set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));lasterror = NIL;
special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL);
+ special_applyn_form = fl_cons(builtin(F_SPECIAL_APPLYN), NIL);
apply1_args = fl_cons(NIL, NIL);
i = 0;
while (isspecial(builtin(i))) {- if (i != F_SPECIAL_APPLY)
+ if (i != F_SPECIAL_APPLY && i != F_SPECIAL_APPLYN)
((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
i++;
}
@@ -2096,7 +2197,6 @@
{value_t v;
uint32_t saveSP = SP;
- PUSH(fixnum(2));
PUSH(NIL);
PUSH(NIL);
v = topeval(expr, &Stack[SP-2]);
@@ -2111,7 +2211,7 @@
for(i=argc-1; i >= 0; i--) {PUSH(cvalue_static_cstring(argv[i]));
Stack[SP-2] = fl_cons(Stack[SP-1], Stack[SP-2]);
- (void)POP();
+ POPN(1);
}
return POP();
}
@@ -2149,7 +2249,7 @@
v = toplevel_eval(e);
}
ios_close(value2c(ios_t*,Stack[SP-1]));
- (void)POP();
+ POPN(1);
PUSH(symbol_value(symbol("__start")));PUSH(argv_list(argc, argv));
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -117,7 +117,7 @@
enum {// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
- F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROG1, F_BEGIN,
+ F_TRYCATCH, F_SPECIAL_APPLY, F_SPECIAL_APPLYN, F_SETQ, F_PROG1, F_BEGIN,
// functions
F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
@@ -124,7 +124,7 @@
F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP,
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
- F_EVAL, F_EVALSTAR, F_APPLY,
+ F_EVAL, F_APPLY,
F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_COMPARE,
F_VECTOR, F_AREF, F_ASET, F_FOR,
@@ -141,6 +141,7 @@
value_t toplevel_eval(value_t expr);
value_t apply(value_t f, value_t l);
value_t apply1(value_t f, value_t a0);
+value_t applyn(uint32_t n, value_t f, ...);
value_t load_file(char *fname);
/* object model manipulation */
--- /dev/null
+++ b/femtolisp/opcodes.h
@@ -1,0 +1,26 @@
+#ifndef __OPCODES_H_
+#define __OPCODES_H_
+
+enum {+ OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT,
+ OP_JMPL, OP_BRFL, OP_BRTL, OP_RET, OP_TAPPLY,
+
+ OP_EQ, OP_EQV, OP_EQUAL, OP_ATOMP, OP_NOT, OP_NULLP, OP_BOOLEANP,
+ OP_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP,
+ OP_FIXNUMP,
+
+ OP_CONS, OP_LIST, OP_CAR, OP_CDR, OP_SETCAR, OP_SETCDR,
+ OP_EVAL, OP_APPLY,
+
+ OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_LT, OP_COMPARE,
+
+ OP_VECTOR, OP_AREF, OP_ASET, OP_FOR,
+
+ OP_LOADT, OP_LOADF, OP_LOADNIL, OP_LOAD0, OP_LOAD1, OP_LOADV, OP_LOADVL,
+ OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL, OP_SETG, OP_SETA, OP_SETC,
+ OP_SETGL,
+
+ OP_CLOSURE, OP_TRYCATCH, OP_ARGC, OP_VARGC
+};
+
+#endif
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -105,7 +105,8 @@
(define (char? x) (eq? (typeof x) 'wchar))
(define (function? x)
(or (builtin? x)
- (and (pair? x) (eq (car x) 'lambda))))
+ (and (pair? x) (or (eq (car x) 'lambda)
+ (eq (car x) 'compiled-lambda)))))
(define procedure? function?)
(define (caar x) (car (car x)))
@@ -642,6 +643,8 @@
(define (expand x) (macroexpand x))
+(define (load-process x) (eval (expand x)))
+
(define (load filename)
(let ((F (file filename :read)))
(trycatch
@@ -649,15 +652,18 @@
(if (not (io.eof? F))
(next (read F)
prev
- (eval (expand E)))
+ (load-process E))
(begin (io.close F)
; evaluate last form in almost-tail position
- (eval (expand E)))))
+ (load-process E))))
(lambda (e)
(begin
(io.close F)
(raise `(load-error ,filename ,e)))))))
+;(load (string *install-dir* *directory-separator* "compiler.lsp"))
+;(define (load-process x) ((compile-thunk (expand x))))
+
(define *banner* (string.tail "
; _
; |_ _ _ |_ _ | . _ _
@@ -679,7 +685,7 @@
#t))))
(define (reploop)
(when (trycatch (and (prompt) (newline))
- print-exception)
+ (lambda (e) (print-exception e)))
(begin (newline)
(reploop))))
(reploop)
--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -168,7 +168,6 @@
value_t fl_table_foldl(value_t *args, uint32_t nargs)
{ argcount("table.foldl", nargs, 3);- PUSH(listn(3, NIL, NIL, NIL));
htable_t *h = totable(args[2], "table.foldl");
size_t i, n = h->size;
void **table = h->table;
@@ -175,11 +174,10 @@
value_t c;
for(i=0; i < n; i+=2) { if (table[i+1] != HT_NOTFOUND) {- c = Stack[SP-1];
- car_(c) = (value_t)table[i];
- car_(cdr_(c)) = (value_t)table[i+1];
- car_(cdr_(cdr_(c))) = args[1];
- args[1] = apply(args[0], c);
+ args[1] = applyn(3, args[0],
+ (value_t)table[i],
+ (value_t)table[i+1],
+ args[1]);
// reload pointer
h = (htable_t*)cv_data((cvalue_t*)ptr(args[2]));
if (h->size != n)
@@ -187,7 +185,6 @@
table = h->table;
}
}
- (void)POP();
return args[1];
}
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1012,3 +1012,20 @@
struct _fltype_t *artype; // (array this)
int marked;
} fltype_t;
+
+-----------------------------------------------------------------------------
+
+new evaluator todo:
+
+- need builtin = to handle nans properly, fix equal? on nans
+- builtin quasi-opaque function type
+ fields: signature, maxstack, bcode, vals, cloenv
+ function->vector
+- make (for ...) a special form
+- trycatch should require 2nd arg to be a lambda expression
+- maxstack calculation, replace Stack with C stack, alloca
+ - stack traces and better debugging support
+- lambda lifting
+- let optimization
+- have macroexpand use its own global syntax table
+- be able to create/load an image file