conservatory
/
femtolisp
4
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]));
}
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 @@ static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
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];
}

46
femtolisp/compiler.lsp
View File

@ -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)

8
femtolisp/cps.lsp
View File

@ -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))

344
femtolisp/flisp.c
View File

@ -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 @@ static char *builtin_names[] =
"cons", "list", "car", "cdr", "set-car!", "set-cdr!",
// execution
"eval", "eval*", "apply",
"eval", "apply",
// arithmetic
"+", "-", "*", "/", "<", "compare",
@ -96,7 +96,7 @@ value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
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 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 memory_exception_value;
@ -502,6 +502,7 @@ void gc(int mustgrow)
}
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,8 +552,29 @@ value_t apply(value_t f, value_t l)
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, ...)
@ -634,40 +656,39 @@ int isnumber(value_t v)
// 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++;
}
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 @@ static value_t evlis(value_t *pv, value_t *penv)
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 @@ static value_t evlis(value_t *pv, value_t *penv)
*rest = v;
v = *pv = cdr_(*pv);
}
(void)POP();
POPN(1);
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
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 @@ static value_t new_stackseg(value_t e, value_t *penv, int tail)
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 @@ static value_t new_stackseg(value_t e, value_t *penv, int tail)
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 @@ static value_t do_trycatch(value_t expr, value_t *penv)
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 @@ 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.
*/
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
// 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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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,59 +1329,59 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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;
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");
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;
// 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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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,28 +1453,25 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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
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;
goto eval_top;
}
else {
Stack[bp] = fixnum(envsz);
penv = &Stack[bp+1];
tail = 1;
goto eval_top;
@ -1460,6 +1498,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
- 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 eval_sexpr(value_t e, value_t *penv, int tail)
*/
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,50 +1519,63 @@ static value_t apply_cl(uint32_t nargs)
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
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 @@ static value_t apply_cl(uint32_t nargs)
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,6 +1604,13 @@ static value_t apply_cl(uint32_t nargs)
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);
@ -1574,11 +1637,11 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
v = toplevel_eval(POP());
PUSH(v);
break;
case OP_EVALSTAR:
case OP_TAPPLY:
case OP_APPLY:
@ -1691,7 +1756,7 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
else {
type_error("aref", "sequence", v);
}
POP();
POPN(1);
Stack[SP-1] = v;
break;
case OP_ASET:
@ -1862,6 +1927,19 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
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 @@ static value_t apply_cl(uint32_t nargs)
}
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 @@ static value_t apply_cl(uint32_t nargs)
//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 @@ static void lisp_init(void)
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 toplevel_eval(value_t expr)
{
value_t v;
uint32_t saveSP = SP;
PUSH(fixnum(2));
PUSH(NIL);
PUSH(NIL);
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--) {
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 @@ int main(int argc, char *argv[])
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));

5
femtolisp/flisp.h
View File

@ -117,14 +117,14 @@ extern uint32_t SP;
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,
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 @@ void print(ios_t *f, value_t v, int princ);
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 */

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 (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)

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)
{
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;
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 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs)
table = h->table;
}
}
(void)POP();
return args[1];
}

17
femtolisp/todo
View File

@ -1012,3 +1012,20 @@ typedef struct _fltype_t {
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