ref: b76bbe37247399331e39bfbbef8724bb2520065d
parent: 0d5cb7352392ec64f47029db38de6d12707b82ef
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Mon Jul 14 21:20:52 EDT 2008
changing environment representation to contiguous values eliminating built-in label form
--- a/femtolisp/ast/out.lsp
+++ b/femtolisp/ast/out.lsp
@@ -1,3 +1,1 @@
-1201386230.6766149997711182
-(r-expressions (r-call library MASS) (r-call dyn.load "starp.so") (<- ppcommand (lambda (...) (let nil (r-block (r-call .Call "ppcommand" (r-call list r-dotdotdot)))))) (<- ppvcommand (lambda (va) (let nil (r-block (r-call .Call "ppcommand" va))))) (<- ppinvoke ppcommand) (<- pploadconfig (lambda (fileName) (let nil (r-block (r-call .Call "pploadconfig" fileName))))) (<- ppconnect (lambda (numProcs machines) (let ((machines nil) (numProcs nil)) (r-block (when (missing numProcs) (<- numProcs nil)) (when (missing machines) (<- machines nil)) (r-call .Call "ppconnect" (r-call list numProcs machines)))))) (<- ppgetlogpath (lambda nil (let nil (r-block (r-call .Call "ppgetlogpath"))))) (<- ppgetlog (lambda nil (let nil (r-block (r-call .Call "ppgetlog"))))) (<- ppshowdashboard (lambda nil (let nil (r-block (r-call .Call "ppshowdashboard"))))) (<- pphidedashboard (lambda nil (let nil (r-block (r-call .Call "pphidedashboard"))))) (<- revealargs (lambda (dots) (let nil (r-block (r-call .Call "_revealArgs" dots))))) (<- listargs (lambda (...) (let nil (r-block (r-call revealargs (r-call get "...")))))) (<- ppping (lambda nil (let nil (r-block (r-call ppcommand "ppping"))))) (<- ppver (lambda nil (let nil (r-block (r-call ppcommand "pp_ver"))))) (<- STARPDIST "../../../linkdist") (<- STARPPLATFORM "ia32_linux") (r-call .Call "_setstarpdist" STARPDIST) (r-call .Call "_setstarpplat" STARPPLATFORM) (r-call pploadconfig (r-call paste STARPDIST "/config/starpd.properties" (*named* sep ""))) (<- dimdis (lambda (v) (let nil (r-block (if (r-call == (r-call r-index (r-call class v) 1) "dlayoutn") (return (r-call as.numeric (r-call r-index (r-call class v) 2)))) (if (r-call ! (r-call is.null v)) (r-block (for i (r-call : (r-call length v) 1) (if (r-call > (r-call r-aref v i) 1) (return i)))) (r-block (return 1))) (return (r-call length v)))))) (<- is.scalar (lambda (x) (let nil (r-block (&& (|\|\|| (r-call == (r-call mode x) "numeric") (r-call == (r-call mode x) "complex")) (r-call is.null (r-call (r-call .Primitive "dim") x)) (r-call == (r-call length x) 1)))))) (<- p 1) (r-block (ref= #:g0 (r-call c "dlayout" "numeric")) (<- p (r-call class p #:g0)) #:g0) (<- darray (lambda (id shape distribution isreal) (let ((d nil) (distribution nil) (shape nil)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (r-block (ref= #:g1 (r-call append "dlayoutn" (r-call toString distribution) (r-call class shape))) (<- shape (r-call class shape #:g1)) #:g1) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) nil nil)) (r-block (<- d (r-call class d "darray")) "darray") d)))) (<- darraydist (lambda (da) (let nil (r-block (r-call as.numeric (r-call r-aref (r-call class (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2)))))) (<- is.darray (lambda (x) (let nil (r-block (r-call == (r-call r-index (r-call class x) 1) "darray"))))) (<- is.nd (lambda (x) (let nil (r-block (r-call != (r-call length (r-call dim x)) 2))))) (<- is.darraynd (lambda (x) (let nil (r-block (&& (r-call is.darray x) (r-call is.nd x)))))) (<- is.dlayout (lambda (x) (let nil (r-block (r-call any (r-call == (r-call class x) "dlayout")))))) (<- vdim (lambda (x) (let nil (r-block (if (r-call is.vector x) (r-call length x) (r-call dim x)))))) (<- |[[.dlayoutn| (<- |[.dlayoutn| (lambda (dl n) (let ((didi nil) (r nil) (dd nil)) (r-block (<- dd (r-call as.numeric (r-call r-aref (r-call class dl) 2))) (if (r-call == (r-call length n) 1) (r-block (if (r-call == n dd) (r-call * (r-call r-index (r-call as.vector dl) n) p) (r-call r-index (r-call as.vector dl) n))) (r-block (<- r (r-call r-index (r-call as.numeric dl) n)) (<- didi (r-call dimdis r)) (for i (r-call : 1 (r-call length n)) (r-block (if (r-call == (r-call r-aref n i) dd) (r-block (<- didi i) (break))))) (r-block (ref= #:g2 (r-call append "dlayoutn" (r-call toString didi) (r-call class r))) (<- r (r-call class r #:g2)) #:g2) (return r)))))))) (<- print.darray (lambda (d ...) (let ((shs nil) (sh nil)) (r-block (<- sh (r-call as.
\ No newline at end of file
-1201386230.8069550991058350
+'(r-expressions (r-call library MASS) (r-call dyn.load "starp.so") (<- ppcommand (lambda (...) (let nil (r-block (r-call .Call "ppcommand" (r-call list r-dotdotdot)))))) (<- ppvcommand (lambda (va) (let nil (r-block (r-call .Call "ppcommand" va))))) (<- ppinvoke ppcommand) (<- pploadconfig (lambda (fileName) (let nil (r-block (r-call .Call "pploadconfig" fileName))))) (<- ppconnect (lambda (numProcs machines) (let ((machines nil) (numProcs nil)) (r-block (when (missing numProcs) (<- numProcs nil)) (when (missing machines) (<- machines nil)) (r-call .Call "ppconnect" (r-call list numProcs machines)))))) (<- ppgetlogpath (lambda nil (let nil (r-block (r-call .Call "ppgetlogpath"))))) (<- ppgetlog (lambda nil (let nil (r-block (r-call .Call "ppgetlog"))))) (<- ppshowdashboard (lambda nil (let nil (r-block (r-call .Call "ppshowdashboard"))))) (<- pphidedashboard (lambda nil (let nil (r-block (r-call .Call "pphidedashboard"))))) (<- revealargs (lambda (dots) (let nil (r-block (r-call .Call "_revealArgs" dots))))) (<- listargs (lambda (...) (let nil (r-block (r-call revealargs (r-call get "...")))))) (<- ppping (lambda nil (let nil (r-block (r-call ppcommand "ppping"))))) (<- ppver (lambda nil (let nil (r-block (r-call ppcommand "pp_ver"))))) (<- STARPDIST "../../../linkdist") (<- STARPPLATFORM "ia32_linux") (r-call .Call "_setstarpdist" STARPDIST) (r-call .Call "_setstarpplat" STARPPLATFORM) (r-call pploadconfig (r-call paste STARPDIST "/config/starpd.properties" (*named* sep ""))) (<- dimdis (lambda (v) (let nil (r-block (if (r-call == (r-call r-index (r-call class v) 1) "dlayoutn") (return (r-call as.numeric (r-call r-index (r-call class v) 2)))) (if (r-call ! (r-call is.null v)) (r-block (for i (r-call : (r-call length v) 1) (if (r-call > (r-call r-aref v i) 1) (return i)))) (r-block (return 1))) (return (r-call length v)))))) (<- is.scalar (lambda (x) (let nil (r-block (&& (|\|\|| (r-call == (r-call mode x) "numeric") (r-call == (r-call mode x) "complex")) (r-call is.null (r-call (r-call .Primitive "dim") x)) (r-call == (r-call length x) 1)))))) (<- p 1) (r-block (ref= #:g0 (r-call c "dlayout" "numeric")) (<- p (r-call class p #:g0)) #:g0) (<- darray (lambda (id shape distribution isreal) (let ((d nil) (distribution nil) (shape nil)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (r-block (ref= #:g1 (r-call append "dlayoutn" (r-call toString distribution) (r-call class shape))) (<- shape (r-call class shape #:g1)) #:g1) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) nil nil)) (r-block (<- d (r-call class d "darray")) "darray") d)))) (<- darraydist (lambda (da) (let nil (r-block (r-call as.numeric (r-call r-aref (r-call class (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2)))))) (<- is.darray (lambda (x) (let nil (r-block (r-call == (r-call r-index (r-call class x) 1) "darray"))))) (<- is.nd (lambda (x) (let nil (r-block (r-call != (r-call length (r-call dim x)) 2))))) (<- is.darraynd (lambda (x) (let nil (r-block (&& (r-call is.darray x) (r-call is.nd x)))))) (<- is.dlayout (lambda (x) (let nil (r-block (r-call any (r-call == (r-call class x) "dlayout")))))) (<- vdim (lambda (x) (let nil (r-block (if (r-call is.vector x) (r-call length x) (r-call dim x)))))) (<- |[[.dlayoutn| (<- |[.dlayoutn| (lambda (dl n) (let ((didi nil) (r nil) (dd nil)) (r-block (<- dd (r-call as.numeric (r-call r-aref (r-call class dl) 2))) (if (r-call == (r-call length n) 1) (r-block (if (r-call == n dd) (r-call * (r-call r-index (r-call as.vector dl) n) p) (r-call r-index (r-call as.vector dl) n))) (r-block (<- r (r-call r-index (r-call as.numeric dl) n)) (<- didi (r-call dimdis r)) (for i (r-call : 1 (r-call length n)) (r-block (if (r-call == (r-call r-aref n i) dd) (r-block (<- didi i) (break))))) (r-block (ref= #:g2 (r-call append "dlayoutn" (r-call toString didi) (r-call class r))) (<- r (r-call class r #:g2)) #:g2) (return r)))))))) (<- print.darray (lambda (d ...) (let ((shs nil) (sh nil)) (r-block (<- sh (r-call as
\ No newline at end of file
--- a/femtolisp/attic/trash.c
+++ b/femtolisp/attic/trash.c
@@ -115,3 +115,15 @@
inv_error:
lerror(DivideError, "/: division by zero");
}
+
+static void printstack(value_t *penv, uint32_t envsz)
+{+ int i;
+ printf("env=%d, size=%d\n", penv - &Stack[0], envsz);+ for(i=0; i < SP; i++) {+ printf("%d: ", i);+ print(stdout, Stack[i], 0);
+ printf("\n");+ }
+ printf("\n");+}
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -68,7 +68,7 @@
#include "flisp.h"
static char *builtin_names[] =
- { "quote", "cond", "if", "and", "or", "while", "lambda", "label",+ { "quote", "cond", "if", "and", "or", "while", "lambda","trycatch", "progn",
"eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
@@ -84,13 +84,13 @@
value_t Stack[N_STACK];
u_int32_t SP = 0;
-value_t NIL, T, LAMBDA, LABEL, QUOTE, VECTOR, IF, TRYCATCH;
+value_t NIL, T, LAMBDA, QUOTE, VECTOR, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
-static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend);
+static value_t eval_sexpr(value_t e, value_t *penv, int tail);
static value_t *alloc_words(int n);
static value_t relocate(value_t v);
static void do_print(FILE *f, value_t v, int princ);
@@ -608,13 +608,13 @@
return NIL;
}
-#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
-#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
+#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0))
+#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1))
#define tail_eval(xpr) do { SP = saveSP; \ if (tag(xpr)<0x2) { return (xpr); } \ else { e=(xpr); goto eval_top; } } while (0)-static value_t do_trycatch(value_t expr, value_t *penv, u_int32_t envend)
+static value_t do_trycatch(value_t expr, value_t *penv)
{value_t v;
@@ -639,26 +639,27 @@
/* stack setup on entry:
n n+1 ...
+-----+-----+-----+-----+-----+-----+-----+-----+
- | SYM | VAL | SYM | VAL | CLO | | | |
+ | LL | VAL | VAL | CLO | | | | |
+-----+-----+-----+-----+-----+-----+-----+-----+
- ^ ^ ^
- | | |
- penv envend SP (who knows where)
+ ^ ^
+ | |
+ penv SP (who knows where)
- sym is an argument name and val is its binding. CLO is a closed-up
- environment vector (which can be empty, i.e. NIL).
- CLO is always there, but there might be zero SYM/VAL pairs.
+ where LL is the lambda list, CLO is a closed-up environment vector
+ (which can be empty, i.e. NIL). An environment vector is just a copy
+ of the stack from LL through CLO.
+ There might be zero values, in which case LL is NIL.
if tail==1, you are allowed (indeed encouraged) to overwrite this
environment, otherwise you have to put any new environment on the top
of the stack.
*/
-static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
+static value_t eval_sexpr(value_t e, value_t *penv, int tail)
{- value_t f, v, asym, *pv, *argsyms, *body, *lenv, *argenv;
+ value_t f, v, *pv, *argsyms, *body, *lenv;
cons_t *c;
symbol_t *sym;
- u_int32_t saveSP;
+ u_int32_t saveSP, envsz;
int i, nargs, noeval=0;
fixnum_t s;
cvalue_t *cv;
@@ -669,15 +670,18 @@
sym = (symbol_t*)ptr(e);
if (sym->syntax == TAG_CONST) return sym->binding;
while (1) {- if (tag(*penv) == TAG_BUILTIN)
- penv = &vector_elt(*penv, 0);
- if (*penv == e)
- return penv[1];
- else if (*penv == NIL)
+ v = *penv++;
+ while (iscons(v)) {+ if (car_(v)==e) return *penv;
+ v = cdr_(v); penv++;
+ }
+ if (v == e) return *penv; // dotted list
+ if (v != NIL) penv++;
+ if (*penv == NIL)
break;
- penv+=2;
+ penv = &vector_elt(*penv, 0);
}
- if ((v = sym->binding) == UNBOUND) // 3. global env
+ if ((v = sym->binding) == UNBOUND)
raise(list2(UnboundError, e));
return v;
}
@@ -696,7 +700,7 @@
else
noeval = 2;
}
- else f = eval_sexpr(v, penv, 0, envend);
+ else f = eval(v);
v = Stack[saveSP];
if (tag(f) == TAG_BUILTIN) {// handle builtin function
@@ -718,25 +722,30 @@
break;
case F_LAMBDA:
// build a closure (lambda args body . env)
- if (issymbol(*penv) && *penv != NIL) {+ if (*penv != NIL) {// save temporary environment to the heap
- // find out how much space we need
- nargs = ((int)(&Stack[envend] - penv - 1));
lenv = penv;
- pv = alloc_words(nargs + 2);
+ //envsz = saveSP - (penv - &Stack[0]);
+ envsz = 2;
+ v = *penv;
+ while (iscons(v)) {+ envsz++;
+ v = cdr_(v);
+ }
+ if (v != NIL) envsz++;
+ pv = alloc_words(envsz + 1);
PUSH(tagptr(pv, TAG_BUILTIN));
- pv[0] = (nargs+1)<<2;
+ pv[0] = envsz<<2;
pv++;
- while (nargs--)
+ while (envsz--)
*pv++ = *penv++;
- // final element points to existing cloenv
- *pv = Stack[envend-1];
// environment representation changed; install
// the new representation so everybody can see it
- *lenv = Stack[SP-1];
+ lenv[0] = NIL;
+ lenv[1] = Stack[SP-1];
}
else {- PUSH(*penv); // env has already been captured; share
+ PUSH(penv[1]); // env has already been captured; share
}
c = (cons_t*)ptr(v=cons_reserve(3));
c->car = LAMBDA;
@@ -746,22 +755,6 @@
c->car = car(cdr_(Stack[saveSP])); //body
c->cdr = Stack[SP-1]; //env
break;
- case F_LABEL:
- // the syntax of label is (label name (lambda args body))
- // nothing else is guaranteed to work
- PUSH(car(Stack[saveSP]));
- PUSH(car(cdr_(Stack[saveSP])));
- body = &Stack[SP-1];
- *body = eval(*body); // evaluate lambda
- pv = alloc_words(4);
- pv[0] = 3<<2; // vector size 3
- // add [name fn] to front of function's environment
- pv[1] = Stack[SP-2]; // name
- pv[2] = v = *body; // lambda
- f = cdr(cdr(v));
- pv[3] = cdr(f);
- cdr_(f) = tagptr(pv, TAG_BUILTIN);
- break;
case F_IF:
v = car(Stack[saveSP]);
if (eval(v) != NIL)
@@ -843,7 +836,7 @@
}
break;
case F_TRYCATCH:
- v = do_trycatch(car(Stack[saveSP]), penv, envend);
+ v = do_trycatch(car(Stack[saveSP]), penv);
break;
// ordinary functions
@@ -851,15 +844,24 @@
argcount("set", nargs, 2);e = Stack[SP-2];
while (1) {- if (tag(*penv) == TAG_BUILTIN)
- penv = &vector_elt(*penv, 0);
- if (*penv == e) {- penv[1] = Stack[SP-1];
- SP=saveSP; return penv[1];
+ v = *penv++;
+ while (iscons(v)) {+ if (car_(v)==e) {+ *penv = Stack[SP-1];
+ SP=saveSP;
+ return *penv;
+ }
+ v = cdr_(v); penv++;
}
- else if (*penv == NIL)
+ if (v == e) {+ *penv = Stack[SP-1];
+ SP=saveSP;
+ return *penv;
+ }
+ if (v != NIL) penv++;
+ if (*penv == NIL)
break;
- penv+=2;
+ penv = &vector_elt(*penv, 0);
}
sym = tosymbol(e, "set");
v = Stack[SP-1];
@@ -1132,13 +1134,17 @@
v = Stack[SP-1];
if (tag(v)<0x2) { SP=saveSP; return v; } if (tail) {- *penv = NIL;
- envend = SP = (u_int32_t)(penv-&Stack[0]) + 1;
- e=v; goto eval_top;
+ penv[0] = NIL;
+ penv[1] = NIL;
+ //envsz = 0;
+ SP = (u_int32_t)(penv-&Stack[0]) + 2;
+ e=v;
+ goto eval_top;
}
else {PUSH(NIL);
- v = eval_sexpr(v, &Stack[SP-1], 1, SP);
+ PUSH(NIL);
+ v = eval_sexpr(v, &Stack[SP-2], 1);
}
break;
case F_RAISE:
@@ -1184,70 +1190,80 @@
}
apply_lambda:
if (iscons(f)) {- // apply lambda or macro expression
- PUSH(cdr(cdr_(f)));
- PUSH(car_(cdr_(f)));
+ // apply lambda expression
+ f = cdr_(f);
+ PUSH(f);
+ PUSH(car(f)); // arglist
argsyms = &Stack[SP-1];
- argenv = &Stack[SP]; // argument environment starts now
// build a calling environment for the lambda
// the environment is the argument binds on top of the captured
// environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror(ArgError, "apply: too many arguments");
- break;
+ if (noeval) {+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror(ArgError, "apply: too many arguments");
+ break;
+ }
+ PUSH(car_(v));
+ *argsyms = cdr_(*argsyms);
+ v = cdr_(v);
}
- asym = car_(*argsyms);
- if (asym==NIL || !issymbol(asym))
- lerror(ArgError, "apply: invalid formal argument");
- v = car_(v);
- if (!noeval) {- v = eval(v);
- }
- PUSH(asym);
- PUSH(v);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ if (*argsyms != NIL && issymbol(*argsyms))
+ PUSH(v);
}
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- PUSH(*argsyms);
- PUSH(Stack[saveSP]);
- if (!noeval) {- // this version uses collective allocation. about 7-10%
- // faster for lists with > 2 elements, but uses more
- // stack space
- i = SP;
- while (iscons(Stack[saveSP])) {- PUSH(eval(car_(Stack[saveSP])));
- Stack[saveSP] = cdr_(Stack[saveSP]);
+ else {+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror(ArgError, "apply: too many arguments");
+ break;
+ }
+ v = eval(car_(v));
+ PUSH(v);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL && issymbol(*argsyms)) {+ PUSH(NIL);
+ // this version uses collective allocation. about 7-10%
+ // faster for lists with > 2 elements, but uses more
+ // stack space
+ i = SP;
+ while (iscons(Stack[saveSP])) {+ v = car_(Stack[saveSP]);
+ v = eval(v);
+ PUSH(v);
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ nargs = SP-i;
+ if (nargs) {+ Stack[i-1] = cons_reserve(nargs);
+ c = (cons_t*)ptr(Stack[i-1]);
+ for(; i < (int)SP; i++) {+ c->car = Stack[i];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
}
- nargs = SP-i;
- if (nargs) {- Stack[i-1] = cons_reserve(nargs);
- c = (cons_t*)ptr(Stack[i-1]);
- for(; i < (int)SP; i++) {- c->car = Stack[i];
- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- (c-1)->cdr = Stack[saveSP];
- POPN(nargs);
- }
+ (c-1)->cdr = Stack[saveSP];
+ POPN(nargs);
}
}
- else if (iscons(*argsyms)) {- lerror(ArgError, "apply: too few arguments");
- }
}
- PUSH(cdr(Stack[saveSP+1])); // add cloenv to new environment
- e = car_(Stack[saveSP+1]);
+ if (iscons(*argsyms)) {+ lerror(ArgError, "apply: too few arguments");
+ }
+ *argsyms = car_(Stack[saveSP+1]);
+ f = cdr_(Stack[saveSP+1]);
+ PUSH(cdr(f));
+ e = car_(f);
+
// macro: evaluate expansion in the calling environment
if (noeval == 2) {if (tag(e)<0x2) ;
- else e = eval_sexpr(e, argenv, 1, SP);
+ else e = eval_sexpr(e, argsyms, 1);
SP = saveSP;
if (tag(e)<0x2) return(e);
noeval = 0;
@@ -1258,14 +1274,15 @@
if (tail) {noeval = 0;
// ok to overwrite environment
- nargs = (int)(&Stack[SP] - argenv);
- for(i=0; i < nargs; i++)
- penv[i] = argenv[i];
- envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]);
+ s = SP - saveSP - 2;
+ for(i=0; i < s; i++)
+ penv[i] = argsyms[i];
+ SP = (u_int32_t)((penv+s) - &Stack[0]);
+ //envsz = s;
goto eval_top;
}
else {- v = eval_sexpr(e, argenv, 1, SP);
+ v = eval_sexpr(e, argsyms, 1);
SP = saveSP;
return v;
}
@@ -1296,7 +1313,6 @@
NIL = symbol("nil"); setc(NIL, NIL); T = symbol("T"); setc(T, T); LAMBDA = symbol("lambda");- LABEL = symbol("label"); QUOTE = symbol("quote"); VECTOR = symbol("vector"); TRYCATCH = symbol("trycatch");@@ -1351,7 +1367,8 @@
value_t v;
u_int32_t saveSP = SP;
PUSH(NIL);
- v = topeval(expr, &Stack[SP-1]);
+ PUSH(NIL);
+ v = topeval(expr, &Stack[SP-2]);
SP = saveSP;
return v;
}
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -77,7 +77,7 @@
enum {// special forms
- F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_LABEL,
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
F_TRYCATCH, F_PROGN,
// functions
F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP,
--- a/femtolisp/perf.lsp
+++ b/femtolisp/perf.lsp
@@ -15,3 +15,7 @@
(princ "mexpand: ")
(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
+(path.cwd "ast")
+(princ "p-lambda: ")
+(load "rpasses.lsp")
+(path.cwd "..")
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -20,6 +20,9 @@
(list 'set-syntax (list 'quote name)
(list 'lambda args (f-body body)))))
+(defmacro label (name fn)
+ (list (list 'lambda (cons name nil) (list 'setq name fn)) nil))
+
; support both CL defun and Scheme-style define
(defmacro defun (name args . body)
(list 'setq name (list 'lambda args (f-body body))))