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

changing environment representation to contiguous values 

eliminating built-in label form
This commit is contained in:
JeffBezanson 2008-07-15 01:20:52 +00:00
parent 0d5cb73523
commit b76bbe3724
6 changed files with 158 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
femtolisp/ast/out.lsp
View File

File diff suppressed because one or more lines are too long

12
femtolisp/attic/trash.c
View File

@ -115,3 +115,15 @@ value_t fl_inv(value_t b)
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");
}

201
femtolisp/flisp.c
View File

@ -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 @@ static char *stack_bottom;
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 @@ static value_t assoc(value_t item, value_t v)
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 @@ static value_t do_trycatch(value_t expr, value_t *penv, u_int32_t envend)
/* 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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
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)
break;
penv+=2;
v = *penv++;
while (iscons(v)) {
if (car_(v)==e) return *penv;
v = cdr_(v); penv++;
}
if ((v = sym->binding) == UNBOUND) // 3. global env
if (v == e) return *penv; // dotted list
if (v != NIL) penv++;
if (*penv == NIL)
break;
penv = &vector_elt(*penv, 0);
}
if ((v = sym->binding) == UNBOUND)
raise(list2(UnboundError, e));
return v;
}
@ -696,7 +700,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
}
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
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;
}
else if (*penv == NIL)
v = cdr_(v); penv++;
}
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
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,14 +1190,15 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
}
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
if (noeval) {
while (iscons(v)) {
// bind args
if (!iscons(*argsyms)) {
@ -1199,29 +1206,36 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
lerror(ArgError, "apply: too many arguments");
break;
}
asym = car_(*argsyms);
if (asym==NIL || !issymbol(asym))
lerror(ArgError, "apply: invalid formal argument");
v = car_(v);
if (!noeval) {
v = eval(v);
PUSH(car_(v));
*argsyms = cdr_(*argsyms);
v = cdr_(v);
}
PUSH(asym);
if (*argsyms != NIL && issymbol(*argsyms))
PUSH(v);
}
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) {
if (issymbol(*argsyms)) {
PUSH(*argsyms);
PUSH(Stack[saveSP]);
if (!noeval) {
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])) {
PUSH(eval(car_(Stack[saveSP])));
v = car_(Stack[saveSP]);
v = eval(v);
PUSH(v);
Stack[saveSP] = cdr_(Stack[saveSP]);
}
nargs = SP-i;
@ -1238,16 +1252,18 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
}
}
}
else if (iscons(*argsyms)) {
if (iscons(*argsyms)) {
lerror(ArgError, "apply: too few arguments");
}
}
PUSH(cdr(Stack[saveSP+1])); // add cloenv to new environment
e = car_(Stack[saveSP+1]);
*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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
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 @@ void lisp_init(void)
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 toplevel_eval(value_t expr)
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;
}

2
femtolisp/flisp.h
View File

@ -77,7 +77,7 @@ extern u_int32_t SP;
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,

4
femtolisp/perf.lsp
View File

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

3
femtolisp/system.lsp
View File

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