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

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
This commit is contained in:
JeffBezanson 2009-04-15 00:12:01 +00:00
parent b9a1be78a0
commit 672558d30f
9 changed files with 313 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
femtolisp/builtins.c
View File

@ -129,7 +129,7 @@ static value_t fl_intern(value_t *args, u_int32_t nargs)
return symbol(cvalue_data(args[0])); 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) static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
{ {
@ -142,7 +142,8 @@ static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
sym->syntax = 0; sym->syntax = 0;
} }
else { 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]); type_error("set-syntax!", "function", args[1]);
sym->syntax = args[1]; sym->syntax = args[1];
} }

46
femtolisp/compiler.lsp
View File

@ -8,13 +8,14 @@
(define Instructions (define Instructions
(make-enum-table (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? :eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol?
:number? :bound? :pair? :builtin? :vector? :fixnum? :number? :bound? :pair? :builtin? :vector? :fixnum?
:cons :list :car :cdr :set-car! :set-cdr! :cons :list :car :cdr :set-car! :set-cdr!
:eval :eval* :apply :eval :apply
:+ :- :* :/ :< :compare :+ :- :* :/ :< :compare
@ -24,7 +25,7 @@
:loadg :loada :loadc :loadg.l :loadg :loada :loadc :loadg.l
:setg :seta :setc :setg.l :setg :seta :setc :setg.l
:closure :trycatch :tcall :tapply :argc :vargc])) :closure :trycatch :argc :vargc]))
(define arg-counts (define arg-counts
(table :eq? 2 :eqv? 2 (table :eq? 2 :eqv? 2
@ -37,10 +38,9 @@
:cons 2 :car 1 :cons 2 :car 1
:cdr 1 :set-car! 2 :cdr 1 :set-car! 2
:set-cdr! 2 :eval 1 :set-cdr! 2 :eval 1
:eval* 1 :apply 2 :apply 2 :< 2
:< 2 :for 3 :for 3 :compare 2
:compare 2 :aref 2 :aref 2 :aset! 3))
:aset! 3))
(define 1/Instructions (table.invert Instructions)) (define 1/Instructions (table.invert Instructions))
@ -181,11 +181,11 @@
`(closed ,lev ,i)) `(closed ,lev ,i))
(lookup-sym s (lookup-sym s
(cdr env) (cdr env)
(if (null? curr) lev (+ lev 1)) (if (or arg? (null? curr)) lev (+ lev 1))
#f))))) #f)))))
(define (compile-sym g env s Is) (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) (case (car loc)
(arg (emit g (aref Is 0) (cadr loc))) (arg (emit g (aref Is 0) (cadr loc)))
(closed (emit g (aref Is 1) (cadr loc) (caddr loc))) (closed (emit g (aref Is 1) (cadr loc) (caddr loc)))
@ -199,13 +199,13 @@
(cond-clauses->if (cdr form))) (cond-clauses->if (cdr form)))
(define (cond-clauses->if lst) (define (cond-clauses->if lst)
(if (atom? lst) (if (atom? lst)
lst #f
(let ((clause (car lst))) (let ((clause (car lst)))
(if (eq? (car clause) 'else) (if (eq? (car clause) 'else)
(cons 'begin (cdr clause)) (cons 'begin (cdr clause))
`(if ,(car clause) `(if ,(car clause)
,(cons 'begin (cdr clause)) ,(cons 'begin (cdr clause))
,(cond-clauses->if (cdr lst))))))) ,(cond-clauses->if (cdr lst)))))))
(define (compile-if g env tail? x) (define (compile-if g env tail? x)
(let ((elsel (make-label g)) (let ((elsel (make-label g))
@ -241,11 +241,12 @@
(define (compile-while g env cond body) (define (compile-while g env cond body)
(let ((top (make-label g)) (let ((top (make-label g))
(end (make-label g))) (end (make-label g)))
(compile-in g env #f #f)
(mark-label g top) (mark-label g top)
(compile-in g env #f cond) (compile-in g env #f cond)
(emit g :brf end) (emit g :brf end)
(compile-in g env #f body)
(emit g :pop) (emit g :pop)
(compile-in g env #f body)
(emit g :jmp top) (emit g :jmp top)
(mark-label g end))) (mark-label g end)))
@ -365,12 +366,12 @@
(cond (compile-in g env tail? (cond->if x))) (cond (compile-in g env tail? (cond->if x)))
(if (compile-if g env tail? x)) (if (compile-if g env tail? x))
(begin (compile-begin g env tail? (cdr 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)) (lambda (begin (emit g :loadv (compile-f env x))
(emit g :closure))) (emit g :closure)))
(and (compile-and g env tail? (cdr x))) (and (compile-and g env tail? (cdr x)))
(or (compile-or 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)) (set! (compile-in g env #f (caddr x))
(compile-sym g env (cadr x) [:seta :setc :setg])) (compile-sym g env (cadr x) [:seta :setc :setg]))
(trycatch (compile-in g env #f `(lambda () ,(cadr x))) (trycatch (compile-in g env #f `(lambda () ,(cadr x)))
@ -383,13 +384,14 @@
(args (cadr f))) (args (cadr f)))
(if (null? (lastcdr args)) (if (null? (lastcdr args))
(emit g :argc (length 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)) (compile-in g (cons (to-proper args) env) #t (caddr f))
(emit g :ret) (emit g :ret)
`(compiled-lambda ,args ,(bytecode g)))) `(compiled-lambda ,args ,(bytecode g))))
(define (compile x) (define (compile f) (compile-f () f))
(bytecode (compile-in (make-code-emitter) () #t x)))
(define (compile-thunk expr) (compile `(lambda () ,expr)))
(define (ref-uint32-LE a i) (define (ref-uint32-LE a i)
(+ (ash (aref a (+ i 0)) 0) (+ (ash (aref a (+ i 0)) 0)

8
femtolisp/cps.lsp
View File

@ -8,7 +8,7 @@
(cond-clauses->if (cdr form))) (cond-clauses->if (cdr form)))
(define (cond-clauses->if lst) (define (cond-clauses->if lst)
(if (atom? lst) (if (atom? lst)
lst #f
(let ((clause (car lst))) (let ((clause (car lst)))
`(if ,(car clause) `(if ,(car clause)
,(cond-body (cdr clause)) ,(cond-body (cdr clause))
@ -22,13 +22,13 @@
,(begin->cps (cdr forms) k))))))) ,(begin->cps (cdr forms) k)))))))
(define-macro (lambda/cc args body) (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 ; a utility used at run time to dispatch a call with or without
; the continuation argument, depending on the function ; the continuation argument, depending on the function
(define (funcall/cc f k . args) (define (funcall/cc f k . args)
(if (and (pair? f) (eq (car f) 'lambda/cc)) (if (and (pair? f) (eq (car f) 'lambda/cc))
(apply f (cons k args)) (apply (cdr f) (cons k args))
(k (apply f args)))) (k (apply f args))))
(define *funcall/cc-names* (define *funcall/cc-names*
(list->vector (list->vector
@ -38,7 +38,7 @@
(let ((name (aref *funcall/cc-names* (length args)))) (let ((name (aref *funcall/cc-names* (length args))))
`(define (,name f k ,@args) `(define (,name f k ,@args)
(if (and (pair? f) (eq (car f) 'lambda/cc)) (if (and (pair? f) (eq (car f) 'lambda/cc))
(f k ,@args) ((cdr f) k ,@args)
(k (f ,@args)))))) (k (f ,@args))))))
(def-funcall/cc-n ()) (def-funcall/cc-n ())
(def-funcall/cc-n (a0)) (def-funcall/cc-n (a0))

344
femtolisp/flisp.c
View File

@ -55,7 +55,7 @@
static char *builtin_names[] = static char *builtin_names[] =
{ // special forms { // special forms
"quote", "cond", "if", "and", "or", "while", "lambda", "quote", "cond", "if", "and", "or", "while", "lambda",
"trycatch", "%apply", "set!", "prog1", "begin", "trycatch", "%apply", "%applyn", "set!", "prog1", "begin",
// predicates // predicates
"eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?", "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
@ -65,7 +65,7 @@ static char *builtin_names[] =
"cons", "list", "car", "cdr", "set-car!", "set-cdr!", "cons", "list", "car", "cdr", "set-car!", "set-cdr!",
// execution // execution
"eval", "eval*", "apply", "eval", "apply",
// arithmetic // arithmetic
"+", "-", "*", "/", "<", "compare", "+", "-", "*", "/", "<", "compare",
@ -96,7 +96,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, 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 apply_cl(uint32_t nargs);
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);
@ -467,7 +467,7 @@ static void trace_globals(symbol_t *root)
} }
} }
static value_t special_apply_form; static value_t special_apply_form, special_applyn_form;
static value_t apply1_args; static value_t apply1_args;
static value_t memory_exception_value; static value_t memory_exception_value;
@ -502,6 +502,7 @@ void gc(int mustgrow)
} }
lasterror = relocate(lasterror); lasterror = relocate(lasterror);
special_apply_form = relocate(special_apply_form); special_apply_form = relocate(special_apply_form);
special_applyn_form = relocate(special_applyn_form);
apply1_args = relocate(apply1_args); apply1_args = relocate(apply1_args);
memory_exception_value = relocate(memory_exception_value); memory_exception_value = relocate(memory_exception_value);
@ -551,8 +552,29 @@ value_t apply(value_t f, value_t l)
value_t apply1(value_t f, value_t a0) value_t apply1(value_t f, value_t a0)
{ {
car_(apply1_args) = a0; PUSH(f);
return apply(f, apply1_args); 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, ...) value_t listn(size_t n, ...)
@ -634,40 +656,39 @@ int isnumber(value_t v)
// eval ----------------------------------------------------------------------- // eval -----------------------------------------------------------------------
/* /*
take the final cdr as an argument so the list builtin can give there is one interesting difference between this and (lambda x x).
the same result as (lambda x x).
however, there is still one interesting difference.
(eq a (apply list a)) is always false for nonempty a, while (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 (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 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. 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; cons_t *c;
uint32_t i; uint32_t i;
*pv = cons_reserve(nargs); value_t v;
c = (cons_t*)ptr(*pv); v = cons_reserve(nargs);
for(i=SP-nargs; i < SP; i++) { c = (cons_t*)ptr(v);
c->car = Stack[i]; for(i=0; i < nargs; i++) {
c->car = args[i];
c->cdr = tagptr(c+1, TAG_CONS); c->cdr = tagptr(c+1, TAG_CONS);
c++; c++;
} }
if (nargs > MAX_ARGS) if (nargs > MAX_ARGS)
(c-2)->cdr = (c-1)->car; (c-2)->cdr = (c-1)->car;
else else
(c-1)->cdr = *plastcdr; (c-1)->cdr = NIL;
return v;
} }
#define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0)) #define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0,envsz))
#define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1)) #define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1,2))
#define tail_eval(xpr) do { \ #define tail_eval(xpr) do { \
if (selfevaluating(xpr)) { SP=saveSP; return (xpr); } \ if (selfevaluating(xpr)) { SP=saveSP; return (xpr); } \
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, value_t *penv) static value_t evlis(value_t *pv, value_t *penv, uint32_t envsz)
{ {
PUSH(NIL); PUSH(NIL);
PUSH(NIL); PUSH(NIL);
@ -680,7 +701,7 @@ static value_t evlis(value_t *pv, value_t *penv)
v = mk_cons(); v = mk_cons();
car_(v) = Stack[SP-1]; car_(v) = Stack[SP-1];
cdr_(v) = NIL; cdr_(v) = NIL;
(void)POP(); POPN(1);
if (*rest == NIL) if (*rest == NIL)
Stack[SP-2] = v; Stack[SP-2] = v;
else else
@ -688,7 +709,7 @@ static value_t evlis(value_t *pv, value_t *penv)
*rest = v; *rest = v;
v = *pv = cdr_(*pv); v = *pv = cdr_(*pv);
} }
(void)POP(); POPN(1);
return POP(); return POP();
} }
@ -698,7 +719,7 @@ static value_t evlis(value_t *pv, value_t *penv)
is active until this function returns. Any return past this function is active until this function returns. Any return past this function
must free the new segment. 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; stackseg_t s;
@ -713,7 +734,7 @@ static value_t new_stackseg(value_t e, value_t *penv, int tail)
value_t v = NIL; value_t v = NIL;
int err = 0; int err = 0;
FL_TRY { FL_TRY {
v = eval_sexpr(e, penv, tail); v = eval_sexpr(e, penv, tail, envsz);
} }
FL_CATCH { FL_CATCH {
err = 1; err = 1;
@ -727,7 +748,7 @@ static value_t new_stackseg(value_t e, value_t *penv, int tail)
return v; 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; value_t v;
@ -748,6 +769,23 @@ static value_t do_trycatch(value_t expr, value_t *penv)
return v; 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: /* stack setup on entry:
n n+1 ... n n+1 ...
+-----+-----+-----+-----+-----+-----+-----+-----+ +-----+-----+-----+-----+-----+-----+-----+-----+
@ -764,12 +802,12 @@ static value_t do_trycatch(value_t expr, value_t *penv)
penv[-1] tells you the environment size, from LL through CLO, as a fixnum. 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; value_t f, v, *pv, *lenv;
cons_t *c; cons_t *c;
symbol_t *sym; symbol_t *sym;
uint32_t saveSP, bp, envsz, nargs; uint32_t saveSP, bp, nargs;
int i, noeval=0; int i, noeval=0;
fixnum_t s, lo, hi; fixnum_t s, lo, hi;
int64_t accum; int64_t accum;
@ -783,7 +821,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
eval_top: eval_top:
if (issymbol(e)) { if (issymbol(e)) {
sym = (symbol_t*)ptr(e); sym = (symbol_t*)ptr(e);
if (sym->syntax == TAG_CONST) { SP=saveSP; return sym->binding; }
while (1) { while (1) {
v = *penv++; v = *penv++;
while (iscons(v)) { while (iscons(v)) {
@ -803,7 +840,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
return v; return v;
} }
if (__unlikely(SP >= (N_STACK-MAX_ARGS-4))) { if (__unlikely(SP >= (N_STACK-MAX_ARGS-4))) {
v = new_stackseg(e, penv, tail); v = new_stackseg(e, penv, tail, envsz);
SP = saveSP; SP = saveSP;
return v; return v;
} }
@ -811,15 +848,13 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
v = car_(e); v = car_(e);
PUSH(cdr_(e)); PUSH(cdr_(e));
if (selfevaluating(v)) f=v; 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 // handle special syntax forms
if (isspecial(f)) if (isspecial(f))
goto apply_special; goto apply_special;
else if (f == TAG_CONST)
f = ((symbol_t*)ptr(v))->binding;
else { else {
noeval = 2;
PUSH(f); PUSH(f);
noeval = 2;
v = Stack[bp]; v = Stack[bp];
goto move_args; goto move_args;
} }
@ -830,7 +865,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
// evaluate argument list, placing arguments on stack // evaluate argument list, placing arguments on stack
while (iscons(v)) { while (iscons(v)) {
if (SP-bp-2 == MAX_ARGS) { if (SP-bp-2 == MAX_ARGS) {
v = evlis(&Stack[bp], penv); v = evlis(&Stack[bp], penv, envsz);
PUSH(v); PUSH(v);
break; break;
} }
@ -885,7 +920,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
if (*penv != NIL) { if (*penv != NIL) {
// save temporary environment to the heap // save temporary environment to the heap
lenv = penv; lenv = penv;
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);
@ -1019,7 +1053,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
v = POP(); v = POP();
break; break;
case F_TRYCATCH: case F_TRYCATCH:
v = do_trycatch(car(Stack[bp]), penv); v = do_trycatch(car(Stack[bp]), penv, envsz);
break; break;
// ordinary functions // ordinary functions
@ -1043,11 +1077,10 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
v = tagptr(c, TAG_CONS); v = tagptr(c, TAG_CONS);
break; break;
case F_LIST: case F_LIST:
if (nargs) { if (nargs)
Stack[bp] = v; v = list(&Stack[SP-nargs], nargs);
list(&v, nargs, &Stack[bp]); else
} v = NIL;
// else v is already set to the final cdr, which is the result
break; break;
case F_CAR: case F_CAR:
argcount("car", nargs, 1); argcount("car", nargs, 1);
@ -1296,59 +1329,59 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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; }
envsz = 2;
if (tail) { if (tail) {
assert((ulong_t)(penv-Stack)<N_STACK); assert((ulong_t)(penv-Stack)<N_STACK);
penv[-1] = fixnum(2);
penv[0] = NIL; penv[0] = NIL;
penv[1] = NIL; penv[1] = NIL;
SP = (penv-Stack) + 2; SP = (penv-Stack) + 2;
} }
else { else {
PUSH(fixnum(2));
PUSH(NIL); PUSH(NIL);
PUSH(NIL); PUSH(NIL);
tail = 1; tail = 1;
penv = &Stack[SP-2]; penv = &Stack[SP-2];
} }
goto eval_top; 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: case F_FOR:
argcount("for", nargs, 3); argcount("for", nargs, 3);
lo = tofixnum(Stack[SP-3], "for"); lo = tofixnum(Stack[SP-3], "for");
hi = tofixnum(Stack[SP-2], "for"); hi = tofixnum(Stack[SP-2], "for");
f = Stack[SP-1]; f = Stack[SP-1];
v = car(cdr(f)); 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"); lerror(ArgError, "for: expected 1 argument lambda");
f = cdr_(f); f = cdr_(f);
PUSH(f); // save function cdr PUSH(f); // save function cdr
SP += 4; // make space SP += 3; // make space
Stack[SP-4] = fixnum(3); // env size
Stack[SP-1] = cdr_(cdr_(f)); // cloenv Stack[SP-1] = cdr_(cdr_(f)); // cloenv
v = FL_F; v = FL_F;
for(s=lo; s <= hi; s++) { for(s=lo; s <= hi; s++) {
f = Stack[SP-5]; f = Stack[SP-4];
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, &Stack[SP-3], 0); if (!selfevaluating(v)) v = eval_sexpr(v, &Stack[SP-3], 0, 3);
} }
break; 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: case F_SPECIAL_APPLY:
f = Stack[bp-5]; f = Stack[bp-4];
v = Stack[bp-4]; v = Stack[bp-3];
PUSH(f); PUSH(f);
PUSH(v); PUSH(v);
nargs = 2; nargs = 2;
// falls through!! // falls through!!
case F_APPLY: case F_APPLY:
argcount("apply", nargs, 2); 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 f = Stack[bp+1] = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args POPN(2); // pop apply's args
move_args: move_args:
@ -1373,11 +1406,19 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
return v; return v;
} }
f = Stack[bp+1]; f = Stack[bp+1];
assert(SP > bp+1);
if (__likely(iscons(f))) { if (__likely(iscons(f))) {
if (car_(f) == COMPILEDLAMBDA) { if (car_(f) == COMPILEDLAMBDA) {
v = apply_cl(nargs); e = apply_cl(nargs);
SP = saveSP; if (noeval == 2) {
return v; if (selfevaluating(e)) { SP=saveSP; return(e); }
noeval = 0;
goto eval_top;
}
else {
SP = saveSP;
return e;
}
} }
// apply lambda expression // apply lambda expression
f = Stack[bp+1] = cdr_(f); f = Stack[bp+1] = cdr_(f);
@ -1397,7 +1438,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
else { else {
v = NIL; v = NIL;
if (i > 0) { if (i > 0) {
list(&v, i, &NIL); v = list(&Stack[SP-i], i);
if (nargs > MAX_ARGS) { if (nargs > MAX_ARGS) {
c = (cons_t*)curheap; c = (cons_t*)curheap;
(c-2)->cdr = (c-1)->car; (c-2)->cdr = (c-1)->car;
@ -1412,28 +1453,25 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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
Stack[bp+1] = car_(Stack[bp+1]); // put lambda list Stack[bp+1] = car_(Stack[bp+1]); // put lambda list
envsz = SP - bp - 1;
if (noeval == 2) { if (noeval == 2) {
// macro: evaluate body in lambda environment // macro: evaluate body in lambda environment
Stack[bp] = fixnum(envsz); e = eval_sexpr(e, &Stack[bp+1], 1, SP - bp - 1);
e = eval_sexpr(e, &Stack[bp+1], 1);
if (selfevaluating(e)) { SP=saveSP; return(e); } if (selfevaluating(e)) { SP=saveSP; return(e); }
noeval = 0; noeval = 0;
// macro: evaluate expansion in calling environment // macro: evaluate expansion in calling environment
goto eval_top; goto eval_top;
} }
else { else {
envsz = SP - bp - 1;
if (tail) { if (tail) {
// 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++)
penv[i] = Stack[bp+1+i]; penv[i] = Stack[bp+1+i];
SP = (penv-Stack)+envsz; SP = (penv-Stack)+envsz;
goto eval_top; goto eval_top;
} }
else { else {
Stack[bp] = fixnum(envsz);
penv = &Stack[bp+1]; penv = &Stack[bp+1];
tail = 1; tail = 1;
goto eval_top; goto eval_top;
@ -1460,6 +1498,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
- check arg counts - check arg counts
- allocate vararg array - allocate vararg array
- push closed env, set up new environment - push closed env, set up new environment
- restore SP
** need 'copyenv' instruction that moves env to heap, installs ** need 'copyenv' instruction that moves env to heap, installs
heap version as the current env, and pushes the result vector. heap version as the current env, and pushes the result vector.
@ -1469,8 +1508,8 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
*/ */
static value_t apply_cl(uint32_t nargs) static value_t apply_cl(uint32_t nargs)
{ {
uint32_t i, n, ip, bp, envsz; uint32_t i, n, ip, bp, envsz, saveSP=SP;
fixnum_t s; fixnum_t s, lo, hi;
int64_t accum; int64_t accum;
uint8_t op, *code; uint8_t op, *code;
value_t func, v, bcode, x, e, ftl; value_t func, v, bcode, x, e, ftl;
@ -1480,50 +1519,63 @@ static value_t apply_cl(uint32_t nargs)
apply_cl_top: apply_cl_top:
func = Stack[SP-nargs-1]; func = Stack[SP-nargs-1];
assert(iscons(func));
assert(iscons(cdr_(func)));
assert(iscons(cdr_(cdr_(func))));
ftl = cdr_(cdr_(func)); ftl = cdr_(cdr_(func));
bcode = car_(ftl); bcode = car_(ftl);
code = cv_data((cvalue_t*)ptr(car_(bcode))); code = cv_data((cvalue_t*)ptr(car_(bcode)));
i = code[1]; assert(!ismanaged((uptrint_t)code));
if (nargs < i) if (nargs < code[1])
lerror(ArgError, "apply: too few arguments"); 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; bp = SP-nargs;
x = cdr_(ftl); // cloenv x = cdr_(ftl); // cloenv
Stack[bp-1] = car_(cdr_(func)); // lambda list Stack[bp-1] = car_(cdr_(func)); // lambda list
penv = &Stack[bp-1]; penv = &Stack[bp-1];
PUSH(x); PUSH(x);
// must keep a reference to the bcode object while executing it
PUSH(bcode);
PUSH(cdr_(bcode)); PUSH(cdr_(bcode));
pvals = &Stack[SP-1]; pvals = &Stack[SP-1];
ip = 2; ip = 0;
while (1) { while (1) {
op = code[ip++]; op = code[ip++];
dispatch:
switch (op) { 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_NOP: break;
case OP_DUP: v = Stack[SP-1]; PUSH(v); 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_TCALL:
case OP_CALL: case OP_CALL:
i = code[ip++]; // nargs i = code[ip++]; // nargs
@ -1534,9 +1586,13 @@ static value_t apply_cl(uint32_t nargs)
if (uintval(func) > N_BUILTINS) { if (uintval(func) > N_BUILTINS) {
v = ((builtin_t)ptr(func))(&Stack[SP-i], i); v = ((builtin_t)ptr(func))(&Stack[SP-i], i);
} }
else {
PUSH(fixnum(i));
v = toplevel_eval(special_applyn_form);
}
} }
else { else if (iscons(func)) {
if (iscons(func) && car_(func) == COMPILEDLAMBDA) { if (car_(func) == COMPILEDLAMBDA) {
if (op == OP_TCALL) { if (op == OP_TCALL) {
for(s=-1; s < (fixnum_t)i; s++) for(s=-1; s < (fixnum_t)i; s++)
Stack[bp+s] = Stack[SP-i+s]; Stack[bp+s] = Stack[SP-i+s];
@ -1548,6 +1604,13 @@ static value_t apply_cl(uint32_t nargs)
v = apply_cl(i); v = apply_cl(i);
} }
} }
else {
PUSH(fixnum(i));
v = toplevel_eval(special_applyn_form);
}
}
else {
type_error("apply", "function", func);
} }
SP = s-i-1; SP = s-i-1;
PUSH(v); PUSH(v);
@ -1574,11 +1637,11 @@ static value_t apply_cl(uint32_t nargs)
if (v != FL_F) ip = *(uint32_t*)&code[ip]; if (v != FL_F) ip = *(uint32_t*)&code[ip];
else ip += 4; else ip += 4;
break; break;
case OP_RET: v = POP(); return v; case OP_RET: v = POP(); SP = saveSP; return v;
case OP_EQ: case OP_EQ:
Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F); Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
POP(); break; POPN(1); break;
case OP_EQV: case OP_EQV:
if (Stack[SP-2] == Stack[SP-1]) { if (Stack[SP-2] == Stack[SP-1]) {
v = FL_T; v = FL_T;
@ -1590,7 +1653,7 @@ static value_t apply_cl(uint32_t nargs)
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
FL_T : FL_F; FL_T : FL_F;
} }
Stack[SP-2] = v; POP(); Stack[SP-2] = v; POPN(1);
break; break;
case OP_EQUAL: case OP_EQUAL:
if (Stack[SP-2] == Stack[SP-1]) { if (Stack[SP-2] == Stack[SP-1]) {
@ -1603,7 +1666,7 @@ static value_t apply_cl(uint32_t nargs)
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
FL_T : FL_F; FL_T : FL_F;
} }
Stack[SP-2] = v; POP(); Stack[SP-2] = v; POPN(1);
break; break;
case OP_PAIRP: case OP_PAIRP:
Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); break; Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); break;
@ -1643,7 +1706,7 @@ static value_t apply_cl(uint32_t nargs)
c->car = Stack[SP-2]; c->car = Stack[SP-2];
c->cdr = Stack[SP-1]; c->cdr = Stack[SP-1];
Stack[SP-2] = tagptr(c, TAG_CONS); Stack[SP-2] = tagptr(c, TAG_CONS);
POP(); break; POPN(1); break;
case OP_CAR: case OP_CAR:
c = tocons(Stack[SP-1], "car"); c = tocons(Stack[SP-1], "car");
Stack[SP-1] = c->car; Stack[SP-1] = c->car;
@ -1654,13 +1717,16 @@ static value_t apply_cl(uint32_t nargs)
break; break;
case OP_SETCAR: case OP_SETCAR:
car(Stack[SP-2]) = Stack[SP-1]; car(Stack[SP-2]) = Stack[SP-1];
POP(); break; POPN(1); break;
case OP_SETCDR: case OP_SETCDR:
cdr(Stack[SP-2]) = Stack[SP-1]; cdr(Stack[SP-2]) = Stack[SP-1];
POP(); break; POPN(1); break;
case OP_LIST: case OP_LIST:
i = code[ip++]; i = code[ip++];
list(&v, i, &NIL); if (i > 0)
v = list(&Stack[SP-i], i);
else
v = NIL;
POPN(i); POPN(i);
PUSH(v); PUSH(v);
break; break;
@ -1668,7 +1734,6 @@ static value_t apply_cl(uint32_t nargs)
v = toplevel_eval(POP()); v = toplevel_eval(POP());
PUSH(v); PUSH(v);
break; break;
case OP_EVALSTAR:
case OP_TAPPLY: case OP_TAPPLY:
case OP_APPLY: case OP_APPLY:
@ -1691,7 +1756,7 @@ static value_t apply_cl(uint32_t nargs)
n = code[ip++]; n = code[ip++];
i = SP-n; i = SP-n;
if (n > MAX_ARGS) goto add_ovf; if (n > MAX_ARGS) goto add_ovf;
for (; i < (int)SP; i++) { for (; i < SP; i++) {
if (__likely(isfixnum(Stack[i]))) { if (__likely(isfixnum(Stack[i]))) {
s += numval(Stack[i]); s += numval(Stack[i]);
if (__unlikely(!fits_fixnum(s))) { if (__unlikely(!fits_fixnum(s))) {
@ -1725,7 +1790,7 @@ static value_t apply_cl(uint32_t nargs)
if (__likely(bothfixnums(Stack[i], Stack[i+1]))) { if (__likely(bothfixnums(Stack[i], Stack[i+1]))) {
s = numval(Stack[i]) - numval(Stack[i+1]); s = numval(Stack[i]) - numval(Stack[i+1]);
if (__likely(fits_fixnum(s))) { if (__likely(fits_fixnum(s))) {
POP(); POPN(1);
Stack[SP-1] = fixnum(s); Stack[SP-1] = fixnum(s);
break; break;
} }
@ -1752,7 +1817,7 @@ static value_t apply_cl(uint32_t nargs)
n = code[ip++]; n = code[ip++];
i = SP-n; i = SP-n;
if (n > MAX_ARGS) goto mul_ovf; if (n > MAX_ARGS) goto mul_ovf;
for (; i < (int)SP; i++) { for (; i < SP; i++) {
if (__likely(isfixnum(Stack[i]))) { if (__likely(isfixnum(Stack[i]))) {
accum *= numval(Stack[i]); accum *= numval(Stack[i]);
} }
@ -1798,12 +1863,12 @@ static value_t apply_cl(uint32_t nargs)
v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ?
FL_T : FL_F; FL_T : FL_F;
} }
POP(); POPN(1);
Stack[SP-1] = v; Stack[SP-1] = v;
break; break;
case OP_COMPARE: case OP_COMPARE:
Stack[SP-2] = compare(Stack[SP-2], Stack[SP-1]); Stack[SP-2] = compare(Stack[SP-2], Stack[SP-1]);
POP(); POPN(1);
break; break;
case OP_VECTOR: case OP_VECTOR:
@ -1841,7 +1906,7 @@ static value_t apply_cl(uint32_t nargs)
else { else {
type_error("aref", "sequence", v); type_error("aref", "sequence", v);
} }
POP(); POPN(1);
Stack[SP-1] = v; Stack[SP-1] = v;
break; break;
case OP_ASET: case OP_ASET:
@ -1862,6 +1927,19 @@ static value_t apply_cl(uint32_t nargs)
Stack[SP-1] = v; Stack[SP-1] = v;
break; break;
case OP_FOR: 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_LOADT: PUSH(FL_T); break;
case OP_LOADF: PUSH(FL_F); break; case OP_LOADF: PUSH(FL_F); break;
@ -1869,19 +1947,22 @@ static value_t apply_cl(uint32_t nargs)
case OP_LOAD0: PUSH(fixnum(0)); break; case OP_LOAD0: PUSH(fixnum(0)); break;
case OP_LOAD1: PUSH(fixnum(1)); break; case OP_LOAD1: PUSH(fixnum(1)); break;
case OP_LOADV: case OP_LOADV:
assert(code[ip] < vector_size(*pvals));
v = vector_elt(*pvals, code[ip]); ip++; v = vector_elt(*pvals, code[ip]); ip++;
PUSH(v); PUSH(v);
break; break;
case OP_LOADVL: 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); PUSH(v);
break; break;
case OP_LOADGL: 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; goto do_loadg;
case OP_LOADG: case OP_LOADG:
assert(code[ip] < vector_size(*pvals));
v = vector_elt(*pvals, code[ip]); ip++; v = vector_elt(*pvals, code[ip]); ip++;
do_loadg: do_loadg:
assert(issymbol(v));
sym = (symbol_t*)ptr(v); sym = (symbol_t*)ptr(v);
if (sym->binding == UNBOUND) if (sym->binding == UNBOUND)
raise(list2(UnboundError, v)); raise(list2(UnboundError, v));
@ -1889,11 +1970,13 @@ static value_t apply_cl(uint32_t nargs)
break; break;
case OP_SETGL: 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; goto do_setg;
case OP_SETG: case OP_SETG:
assert(code[ip] < vector_size(*pvals));
v = vector_elt(*pvals, code[ip]); ip++; v = vector_elt(*pvals, code[ip]); ip++;
do_setg: do_setg:
assert(issymbol(v));
sym = (symbol_t*)ptr(v); sym = (symbol_t*)ptr(v);
v = Stack[SP-1]; v = Stack[SP-1];
if (sym->syntax != TAG_CONST) if (sym->syntax != TAG_CONST)
@ -1901,20 +1984,32 @@ static value_t apply_cl(uint32_t nargs)
break; break;
case OP_LOADA: case OP_LOADA:
assert(nargs > 0);
i = code[ip++]; 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); v = vector_elt(penv[1], i+1);
else }
else {
assert(bp+i < SP);
v = Stack[bp+i]; v = Stack[bp+i];
}
PUSH(v); PUSH(v);
break; break;
case OP_SETA: case OP_SETA:
assert(nargs > 0);
v = Stack[SP-1]; v = Stack[SP-1];
i = code[ip++]; 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; vector_elt(penv[1], i+1) = v;
else }
else {
assert(bp+i < SP);
Stack[bp+i] = v; Stack[bp+i] = v;
}
break; break;
case OP_LOADC: case OP_LOADC:
case OP_SETC: case OP_SETC:
@ -1932,6 +2027,8 @@ static value_t apply_cl(uint32_t nargs)
} }
while (s--) while (s--)
v = vector_elt(v, vector_size(v)-1); v = vector_elt(v, vector_size(v)-1);
assert(isvector(v));
assert(i < vector_size(v));
if (op == OP_SETC) if (op == OP_SETC)
vector_elt(v, i) = Stack[SP-1]; vector_elt(v, i) = Stack[SP-1];
else else
@ -1969,11 +2066,14 @@ static value_t apply_cl(uint32_t nargs)
//if (!iscons(e=cdr_(e))) goto notpair; //if (!iscons(e=cdr_(e))) goto notpair;
c->car = car_(e); //body c->car = car_(e); //body
c->cdr = Stack[SP-1]; //env c->cdr = Stack[SP-1]; //env
POP(); POPN(1);
Stack[SP-1] = v; Stack[SP-1] = v;
break; break;
case OP_TRYCATCH: case OP_TRYCATCH:
v = do_trycatch2();
POPN(1);
Stack[SP-1] = v;
break; break;
} }
} }
@ -2049,10 +2149,11 @@ static void lisp_init(void)
set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH)); set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
lasterror = NIL; lasterror = NIL;
special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), 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); apply1_args = fl_cons(NIL, NIL);
i = 0; i = 0;
while (isspecial(builtin(i))) { 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); ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
i++; i++;
} }
@ -2096,7 +2197,6 @@ 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, &Stack[SP-2]); v = topeval(expr, &Stack[SP-2]);
@ -2111,7 +2211,7 @@ static value_t argv_list(int argc, char *argv[])
for(i=argc-1; i >= 0; i--) { for(i=argc-1; i >= 0; i--) {
PUSH(cvalue_static_cstring(argv[i])); PUSH(cvalue_static_cstring(argv[i]));
Stack[SP-2] = fl_cons(Stack[SP-1], Stack[SP-2]); Stack[SP-2] = fl_cons(Stack[SP-1], Stack[SP-2]);
(void)POP(); POPN(1);
} }
return POP(); return POP();
} }
@ -2149,7 +2249,7 @@ int main(int argc, char *argv[])
v = toplevel_eval(e); v = toplevel_eval(e);
} }
ios_close(value2c(ios_t*,Stack[SP-1])); ios_close(value2c(ios_t*,Stack[SP-1]));
(void)POP(); POPN(1);
PUSH(symbol_value(symbol("__start"))); PUSH(symbol_value(symbol("__start")));
PUSH(argv_list(argc, argv)); PUSH(argv_list(argc, argv));

5
femtolisp/flisp.h
View File

@ -117,14 +117,14 @@ extern uint32_t SP;
enum { enum {
// special forms // special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, 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 // functions
F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP, F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP, 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_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_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_COMPARE,
F_VECTOR, F_AREF, F_ASET, F_FOR, F_VECTOR, F_AREF, F_ASET, F_FOR,
@ -141,6 +141,7 @@ void print(ios_t *f, value_t v, int princ);
value_t toplevel_eval(value_t expr); value_t toplevel_eval(value_t expr);
value_t apply(value_t f, value_t l); value_t apply(value_t f, value_t l);
value_t apply1(value_t f, value_t a0); value_t apply1(value_t f, value_t a0);
value_t applyn(uint32_t n, value_t f, ...);
value_t load_file(char *fname); value_t load_file(char *fname);
/* object model manipulation */ /* object model manipulation */

26
femtolisp/opcodes.h Normal file
View File

@ -0,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

14
femtolisp/system.lsp
View File

@ -105,7 +105,8 @@
(define (char? x) (eq? (typeof x) 'wchar)) (define (char? x) (eq? (typeof x) 'wchar))
(define (function? x) (define (function? x)
(or (builtin? 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 procedure? function?)
(define (caar x) (car (car x))) (define (caar x) (car (car x)))
@ -642,6 +643,8 @@
(define (expand x) (macroexpand x)) (define (expand x) (macroexpand x))
(define (load-process x) (eval (expand x)))
(define (load filename) (define (load filename)
(let ((F (file filename :read))) (let ((F (file filename :read)))
(trycatch (trycatch
@ -649,15 +652,18 @@
(if (not (io.eof? F)) (if (not (io.eof? F))
(next (read F) (next (read F)
prev prev
(eval (expand E))) (load-process E))
(begin (io.close F) (begin (io.close F)
; evaluate last form in almost-tail position ; evaluate last form in almost-tail position
(eval (expand E))))) (load-process E))))
(lambda (e) (lambda (e)
(begin (begin
(io.close F) (io.close F)
(raise `(load-error ,filename ,e))))))) (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 " (define *banner* (string.tail "
; _ ; _
; |_ _ _ |_ _ | . _ _ ; |_ _ _ |_ _ | . _ _
@ -679,7 +685,7 @@
#t)))) #t))))
(define (reploop) (define (reploop)
(when (trycatch (and (prompt) (newline)) (when (trycatch (and (prompt) (newline))
print-exception) (lambda (e) (print-exception e)))
(begin (newline) (begin (newline)
(reploop)))) (reploop))))
(reploop) (reploop)

11
femtolisp/table.c
View File

@ -168,18 +168,16 @@ value_t fl_table_del(value_t *args, uint32_t nargs)
value_t fl_table_foldl(value_t *args, uint32_t nargs) value_t fl_table_foldl(value_t *args, uint32_t nargs)
{ {
argcount("table.foldl", nargs, 3); argcount("table.foldl", nargs, 3);
PUSH(listn(3, NIL, NIL, NIL));
htable_t *h = totable(args[2], "table.foldl"); htable_t *h = totable(args[2], "table.foldl");
size_t i, n = h->size; size_t i, n = h->size;
void **table = h->table; void **table = h->table;
value_t c; value_t c;
for(i=0; i < n; i+=2) { for(i=0; i < n; i+=2) {
if (table[i+1] != HT_NOTFOUND) { if (table[i+1] != HT_NOTFOUND) {
c = Stack[SP-1]; args[1] = applyn(3, args[0],
car_(c) = (value_t)table[i]; (value_t)table[i],
car_(cdr_(c)) = (value_t)table[i+1]; (value_t)table[i+1],
car_(cdr_(cdr_(c))) = args[1]; args[1]);
args[1] = apply(args[0], c);
// reload pointer // reload pointer
h = (htable_t*)cv_data((cvalue_t*)ptr(args[2])); h = (htable_t*)cv_data((cvalue_t*)ptr(args[2]));
if (h->size != n) if (h->size != n)
@ -187,7 +185,6 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs)
table = h->table; table = h->table;
} }
} }
(void)POP();
return args[1]; return args[1];
} }

17
femtolisp/todo
View File

@ -1012,3 +1012,20 @@ typedef struct _fltype_t {
struct _fltype_t *artype; // (array this) struct _fltype_t *artype; // (array this)
int marked; int marked;
} fltype_t; } 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