sources-request@mirror.UUCP (08/13/86)
Submitted by: seismo!utah-cs!b-davis (Brad Davis)
Mod.sources: Volume 6, Issue 107
Archive-name: xlisp1.6/Part01
[ This unpacks, compiles, and runs a couple of the demo programs on
my 4.2BSD Vax750. I have not tried it on a PC. --r$ ]
-------------------------------- Cut Here --------------------------------
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# xlbfun.c
# xlcont.c
# xldbug.c
# xldmem.c
# xleval.c
# This archive created: Mon Jul 14 10:21:31 1986
export PATH; PATH=/bin:$PATH
if test -f 'xlbfun.c'
then
echo shar: will not over-write existing file "'xlbfun.c'"
else
cat << \SHAR_EOF > 'xlbfun.c'
/* xlbfun.c - xlisp basic built-in functions */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern NODE ***xlstack,*xlenv;
extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
extern NODE *s_lambda,*s_macro;
extern NODE *s_comma,*s_comat;
extern NODE *s_unbound;
extern char gsprefix[];
extern int gsnumber;
/* forward declarations */
FORWARD NODE *bquote1();
FORWARD NODE *defun();
FORWARD NODE *makesymbol();
/* xeval - the built-in function 'eval' */
NODE *xeval(args)
NODE *args;
{
NODE ***oldstk,*expr,*val;
/* create a new stack frame */
oldstk = xlsave(&expr,(NODE **)NULL);
/* get the expression to evaluate */
expr = xlarg(&args);
xllastarg(args);
/* evaluate the expression */
val = xleval(expr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression evaluated */
return (val);
}
/* xapply - the built-in function 'apply' */
NODE *xapply(args)
NODE *args;
{
NODE ***oldstk,*fun,*arglist,*val;
/* create a new stack frame */
oldstk = xlsave(&fun,&arglist,(NODE **)NULL);
/* get the function and argument list */
fun = xlarg(&args);
arglist = xlmatch(LIST,&args);
xllastarg(args);
/* if the function is a symbol, get its value */
if (symbolp(fun))
fun = xleval(fun);
/* apply the function to the arguments */
val = xlapply(fun,arglist);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression evaluated */
return (val);
}
/* xfuncall - the built-in function 'funcall' */
NODE *xfuncall(args)
NODE *args;
{
NODE ***oldstk,*fun,*arglist,*val;
/* create a new stack frame */
oldstk = xlsave(&fun,&arglist,(NODE **)NULL);
/* get the function and argument list */
fun = xlarg(&args);
arglist = args;
/* if the function is a symbol, get its value */
if (symbolp(fun))
fun = xleval(fun);
/* apply the function to the arguments */
val = xlapply(fun,arglist);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the expression evaluated */
return (val);
}
/* xquote - built-in function to quote an expression */
NODE *xquote(args)
NODE *args;
{
NODE *val;
/* get the argument */
val = xlarg(&args);
xllastarg(args);
/* return the quoted expression */
return (val);
}
/* xfunction - built-in function to quote a function */
NODE *xfunction(args)
NODE *args;
{
NODE *val;
/* get the argument */
val = xlarg(&args);
xllastarg(args);
/* create a closure for lambda expressions */
if (consp(val) && car(val) == s_lambda)
val = cons(val,xlenv);
/* otherwise, get the value of a symbol */
else if (symbolp(val))
val = xlgetvalue(val);
/* otherwise, its an error */
else
xlerror("not a function",val);
/* return the function */
return (val);
}
/* xlambda - lambda function */
NODE *xlambda(args)
NODE *args;
{
NODE ***oldstk,*fargs,*closure;
/* create a new stack frame */
oldstk = xlsave(&fargs,&closure,(NODE **)NULL);
/* get the formal argument list */
fargs = xlmatch(LIST,&args);
/* create a new function definition */
closure = cons(fargs,args);
closure = cons(s_lambda,closure);
closure = cons(closure,xlenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the closure */
return (closure);
}
/* xbquote - back quote function */
NODE *xbquote(args)
NODE *args;
{
NODE ***oldstk,*expr,*val;
/* create a new stack frame */
oldstk = xlsave(&expr,(NODE **)NULL);
/* get the expression */
expr = xlarg(&args);
xllastarg(args);
/* fill in the template */
val = bquote1(expr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* bquote1 - back quote helper function */
LOCAL NODE *bquote1(expr)
NODE *expr;
{
NODE ***oldstk,*val,*list,*last,*new;
/* handle atoms */
if (atom(expr))
val = expr;
/* handle (comma <expr>) */
else if (car(expr) == s_comma) {
if (atom(cdr(expr)))
xlfail("bad comma expression");
val = xleval(car(cdr(expr)));
}
/* handle ((comma-at <expr>) ... ) */
else if (consp(car(expr)) && car(car(expr)) == s_comat) {
oldstk = xlsave(&list,&val,(NODE **)NULL);
if (atom(cdr(car(expr))))
xlfail("bad comma-at expression");
list = xleval(car(cdr(car(expr))));
for (last = NIL; consp(list); list = cdr(list)) {
new = consa(car(list));
if (last)
rplacd(last,new);
else
val = new;
last = new;
}
if (last)
rplacd(last,bquote1(cdr(expr)));
else
val = bquote1(cdr(expr));
xlstack = oldstk;
}
/* handle any other list */
else {
oldstk = xlsave(&val,(NODE **)NULL);
val = consa(NIL);
rplaca(val,bquote1(car(expr)));
rplacd(val,bquote1(cdr(expr)));
xlstack = oldstk;
}
/* return the result */
return (val);
}
/* xset - built-in function set */
NODE *xset(args)
NODE *args;
{
NODE *sym,*val;
/* get the symbol and new value */
sym = xlmatch(SYM,&args);
val = xlarg(&args);
xllastarg(args);
/* assign the symbol the value of argument 2 and the return value */
setvalue(sym,val);
/* return the result value */
return (val);
}
/* xsetq - built-in function setq */
NODE *xsetq(args)
NODE *args;
{
NODE ***oldstk,*arg,*sym,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,&sym,&val,(NODE **)NULL);
/* initialize */
arg = args;
/* handle each pair of arguments */
while (arg) {
sym = xlmatch(SYM,&arg);
val = xlevarg(&arg);
xlsetvalue(sym,val);
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xsetf - built-in function 'setf' */
NODE *xsetf(args)
NODE *args;
{
NODE ***oldstk,*arg,*place,*value;
/* create a new stack frame */
oldstk = xlsave(&arg,&place,&value,(NODE **)NULL);
/* initialize */
arg = args;
/* handle each pair of arguments */
while (arg) {
/* get place and value */
place = xlarg(&arg);
value = xlevarg(&arg);
/* check the place form */
if (symbolp(place))
xlsetvalue(place,value);
else if (consp(place))
placeform(place,value);
else
xlfail("bad place form");
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (value);
}
/* placeform - handle a place form other than a symbol */
LOCAL placeform(place,value)
NODE *place,*value;
{
NODE ***oldstk,*fun,*arg1,*arg2;
int i;
/* check the function name */
if ((fun = xlmatch(SYM,&place)) == s_get) {
oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
arg1 = xlevmatch(SYM,&place);
arg2 = xlevmatch(SYM,&place);
xllastarg(place);
xlputprop(arg1,value,arg2);
xlstack = oldstk;
}
else if (fun == s_svalue || fun == s_splist) {
oldstk = xlsave(&arg1,(NODE **)NULL);
arg1 = xlevmatch(SYM,&place);
xllastarg(place);
if (fun == s_svalue)
setvalue(arg1,value);
else
setplist(arg1,value);
xlstack = oldstk;
}
else if (fun == s_car || fun == s_cdr) {
oldstk = xlsave(&arg1,(NODE **)NULL);
arg1 = xlevmatch(LIST,&place);
xllastarg(place);
if (consp(arg1))
if (fun == s_car)
rplaca(arg1,value);
else
rplacd(arg1,value);
xlstack = oldstk;
}
else if (fun == s_nth) {
oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
arg1 = xlevmatch(INT,&place);
arg2 = xlevmatch(LIST,&place);
xllastarg(place);
for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
arg2 = cdr(arg2);
if (consp(arg2))
rplaca(arg2,value);
xlstack = oldstk;
}
else if (fun == s_aref) {
oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
arg1 = xlevmatch(VECT,&place);
arg2 = xlevmatch(INT,&place); i = (int)getfixnum(arg2);
xllastarg(place);
if (i < 0 || i >= getsize(arg1))
xlerror("index out of range",arg2);
setelement(arg1,i,value);
xlstack = oldstk;
}
else
xlfail("bad place form");
}
/* xdefun - built-in function 'defun' */
NODE *xdefun(args)
NODE *args;
{
return (defun(args,s_lambda));
}
/* xdefmacro - built-in function 'defmacro' */
NODE *xdefmacro(args)
NODE *args;
{
return (defun(args,s_macro));
}
/* defun - internal function definition routine */
LOCAL NODE *defun(args,type)
NODE *args,*type;
{
NODE ***oldstk,*sym,*fargs,*closure;
/* create a new stack frame */
oldstk = xlsave(&sym,&fargs,&closure,(NODE **)NULL);
/* get the function symbol and formal argument list */
sym = xlmatch(SYM,&args);
fargs = xlmatch(LIST,&args);
/* create a new function definition */
closure = cons(fargs,args);
closure = cons(type,closure);
closure = cons(closure,xlenv);
/* make the symbol point to a new function definition */
xlsetvalue(sym,closure);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the function symbol */
return (sym);
}
/* xgensym - generate a symbol */
NODE *xgensym(args)
NODE *args;
{
char sym[STRMAX+1];
NODE *x;
/* get the prefix or number */
if (args) {
x = xlarg(&args);
switch (ntype(x)) {
case STR:
strcpy(gsprefix,getstring(x));
break;
case INT:
gsnumber = getfixnum(x);
break;
default:
xlerror("bad argument type",x);
}
}
xllastarg(args);
/* create the pname of the new symbol */
sprintf(sym,"%s%d",gsprefix,gsnumber++);
/* make a symbol with this print name */
return (xlmakesym(sym,DYNAMIC));
}
/* xmakesymbol - make a new uninterned symbol */
NODE *xmakesymbol(args)
NODE *args;
{
return (makesymbol(args,FALSE));
}
/* xintern - make a new interned symbol */
NODE *xintern(args)
NODE *args;
{
return (makesymbol(args,TRUE));
}
/* makesymbol - make a new symbol */
LOCAL NODE *makesymbol(args,iflag)
NODE *args; int iflag;
{
NODE ***oldstk,*pname,*val;
char *str;
/* create a new stack frame */
oldstk = xlsave(&pname,(NODE **)NULL);
/* get the print name of the symbol to intern */
pname = xlmatch(STR,&args);
xllastarg(args);
/* make the symbol */
str = getstring(pname);
val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the symbol */
return (val);
}
/* xsymname - get the print name of a symbol */
NODE *xsymname(args)
NODE *args;
{
NODE *sym;
/* get the symbol */
sym = xlmatch(SYM,&args);
xllastarg(args);
/* return the print name */
return (getpname(sym));
}
/* xsymvalue - get the value of a symbol */
NODE *xsymvalue(args)
NODE *args;
{
NODE *sym,*val;
/* get the symbol */
sym = xlmatch(SYM,&args);
xllastarg(args);
/* get the global value */
while ((val = getvalue(sym)) == s_unbound)
xlcerror("try evaluating symbol again","unbound variable",sym);
/* return its value */
return (val);
}
/* xsymplist - get the property list of a symbol */
NODE *xsymplist(args)
NODE *args;
{
NODE *sym;
/* get the symbol */
sym = xlmatch(SYM,&args);
xllastarg(args);
/* return the property list */
return (getplist(sym));
}
/* xget - get the value of a property */
NODE *xget(args)
NODE *args;
{
NODE *sym,*prp;
/* get the symbol and property */
sym = xlmatch(SYM,&args);
prp = xlmatch(SYM,&args);
xllastarg(args);
/* retrieve the property value */
return (xlgetprop(sym,prp));
}
/* xputprop - set the value of a property */
NODE *xputprop(args)
NODE *args;
{
NODE *sym,*val,*prp;
/* get the symbol and property */
sym = xlmatch(SYM,&args);
val = xlarg(&args);
prp = xlmatch(SYM,&args);
xllastarg(args);
/* set the property value */
xlputprop(sym,val,prp);
/* return the value */
return (val);
}
/* xremprop - remove a property value from a property list */
NODE *xremprop(args)
NODE *args;
{
NODE *sym,*prp;
/* get the symbol and property */
sym = xlmatch(SYM,&args);
prp = xlmatch(SYM,&args);
xllastarg(args);
/* remove the property */
xlremprop(sym,prp);
/* return nil */
return (NIL);
}
/* xhash - compute the hash value of a string or symbol */
NODE *xhash(args)
NODE *args;
{
char *str;
NODE *val;
int len;
/* get the string and the table length */
val = xlarg(&args);
len = (int)getfixnum(xlmatch(INT,&args));
xllastarg(args);
/* get the string */
if (symbolp(val))
str = getstring(getpname(val));
else if (stringp(val))
str = getstring(val);
else
xlerror("bad argument type",val);
/* return the hash index */
return (cvfixnum((FIXNUM)hash(str,len)));
}
/* xaref - array reference function */
NODE *xaref(args)
NODE *args;
{
NODE *array,*index;
int i;
/* get the array and the index */
array = xlmatch(VECT,&args);
index = xlmatch(INT,&args); i = (int)getfixnum(index);
xllastarg(args);
/* range check the index */
if (i < 0 || i >= getsize(array))
xlerror("array index out of bounds",index);
/* return the array element */
return (getelement(array,i));
}
/* xmkarray - make a new array */
NODE *xmkarray(args)
NODE *args;
{
int size;
/* get the size of the array */
size = (int)getfixnum(xlmatch(INT,&args));
xllastarg(args);
/* create the array */
return (newvector(size));
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xlcont.c'
then
echo shar: will not over-write existing file "'xlcont.c'"
else
cat << \SHAR_EOF > 'xlcont.c'
/* xlcont - xlisp control built-in functions */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern NODE ***xlstack,*xlenv,*xlvalue;
extern NODE *s_unbound;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *true;
/* external routines */
extern NODE *xlxeval();
/* forward declarations */
FORWARD NODE *let();
FORWARD NODE *prog();
FORWARD NODE *progx();
FORWARD NODE *doloop();
/* xcond - built-in function 'cond' */
NODE *xcond(args)
NODE *args;
{
NODE ***oldstk,*arg,*list,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,&list,(NODE **)NULL);
/* initialize */
arg = args;
/* initialize the return value */
val = NIL;
/* find a predicate that is true */
while (arg) {
/* get the next conditional */
list = xlmatch(LIST,&arg);
/* evaluate the predicate part */
if (val = xlevarg(&list)) {
/* evaluate each expression */
while (list)
val = xlevarg(&list);
/* exit the loop */
break;
}
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* xcase - built-in function 'case' */
NODE *xcase(args)
NODE *args;
{
NODE ***oldstk,*key,*arg,*clause,*list,*val;
/* create a new stack frame */
oldstk = xlsave(&key,&arg,&clause,(NODE **)NULL);
/* initialize */
arg = args;
/* get the key expression */
key = xlevarg(&arg);
/* initialize the return value */
val = NIL;
/* find a case that matches */
while (arg) {
/* get the next case clause */
clause = xlmatch(LIST,&arg);
/* compare the key list against the key */
if ((list = xlarg(&clause)) == true ||
(listp(list) && keypresent(key,list)) ||
eql(key,list)) {
/* evaluate each expression */
while (clause)
val = xlevarg(&clause);
/* exit the loop */
break;
}
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* keypresent - check for the presence of a key in a list */
LOCAL int keypresent(key,list)
NODE *key,*list;
{
for (; consp(list); list = cdr(list))
if (eql(car(list),key))
return (TRUE);
return (FALSE);
}
/* xand - built-in function 'and' */
NODE *xand(args)
NODE *args;
{
NODE ***oldstk,*arg,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,(NODE **)NULL);
/* initialize */
arg = args;
val = true;
/* evaluate each argument */
while (arg)
/* get the next argument */
if ((val = xlevarg(&arg)) == NIL)
break;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xor - built-in function 'or' */
NODE *xor(args)
NODE *args;
{
NODE ***oldstk,*arg,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,(NODE **)NULL);
/* initialize */
arg = args;
val = NIL;
/* evaluate each argument */
while (arg)
if ((val = xlevarg(&arg)))
break;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xif - built-in function 'if' */
NODE *xif(args)
NODE *args;
{
NODE ***oldstk,*testexpr,*thenexpr,*elseexpr,*val;
/* create a new stack frame */
oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,(NODE **)NULL);
/* get the test expression, then clause and else clause */
testexpr = xlarg(&args);
thenexpr = xlarg(&args);
elseexpr = (args ? xlarg(&args) : NIL);
xllastarg(args);
/* evaluate the appropriate clause */
val = xleval(xleval(testexpr) ? thenexpr : elseexpr);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the last value */
return (val);
}
/* xlet - built-in function 'let' */
NODE *xlet(args)
NODE *args;
{
return (let(args,TRUE));
}
/* xletstar - built-in function 'let*' */
NODE *xletstar(args)
NODE *args;
{
return (let(args,FALSE));
}
/* let - common let routine */
LOCAL NODE *let(args,pflag)
NODE *args; int pflag;
{
NODE ***oldstk,*newenv,*arg,*val;
/* create a new stack frame */
oldstk = xlsave(&newenv,&arg,(NODE **)NULL);
/* initialize */
arg = args;
/* create a new environment frame */
newenv = xlframe(xlenv);
/* get the list of bindings and bind the symbols */
if (!pflag) xlenv = newenv;
dobindings(xlmatch(LIST,&arg),newenv);
if (pflag) xlenv = newenv;
/* execute the code */
for (val = NIL; arg; )
val = xlevarg(&arg);
/* unbind the arguments */
xlenv = cdr(xlenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xprog - built-in function 'prog' */
NODE *xprog(args)
NODE *args;
{
return (prog(args,TRUE));
}
/* xprogstar - built-in function 'prog*' */
NODE *xprogstar(args)
NODE *args;
{
return (prog(args,FALSE));
}
/* prog - common prog routine */
LOCAL NODE *prog(args,pflag)
NODE *args; int pflag;
{
NODE ***oldstk,*newenv,*arg,*val;
/* create a new stack frame */
oldstk = xlsave(&newenv,&arg,(NODE **)NULL);
/* initialize */
arg = args;
/* create a new environment frame */
newenv = xlframe(xlenv);
/* get the list of bindings and bind the symbols */
if (!pflag) xlenv = newenv;
dobindings(xlmatch(LIST,&arg),newenv);
if (pflag) xlenv = newenv;
/* execute the code */
tagblock(arg,&val);
/* unbind the arguments */
xlenv = cdr(xlenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xgo - built-in function 'go' */
NODE *xgo(args)
NODE *args;
{
NODE *label;
/* get the target label */
label = xlarg(&args);
xllastarg(args);
/* transfer to the label */
xlgo(label);
}
/* xreturn - built-in function 'return' */
NODE *xreturn(args)
NODE *args;
{
NODE *val;
/* get the return value */
val = (args ? xlarg(&args) : NIL);
xllastarg(args);
/* return from the inner most block */
xlreturn(val);
}
/* xprog1 - built-in function 'prog1' */
NODE *xprog1(args)
NODE *args;
{
return (progx(args,1));
}
/* xprog2 - built-in function 'prog2' */
NODE *xprog2(args)
NODE *args;
{
return (progx(args,2));
}
/* progx - common progx code */
LOCAL NODE *progx(args,n)
NODE *args; int n;
{
NODE ***oldstk,*arg,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,&val,(NODE **)NULL);
/* initialize */
arg = args;
/* evaluate the first n expressions */
while (n--)
val = xlevarg(&arg);
/* evaluate each remaining argument */
while (arg)
xlevarg(&arg);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the last test expression value */
return (val);
}
/* xprogn - built-in function 'progn' */
NODE *xprogn(args)
NODE *args;
{
NODE ***oldstk,*arg,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,(NODE **)NULL);
/* initialize */
arg = args;
/* evaluate each remaining argument */
for (val = NIL; arg; )
val = xlevarg(&arg);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the last test expression value */
return (val);
}
/* xdo - built-in function 'do' */
NODE *xdo(args)
NODE *args;
{
return (doloop(args,TRUE));
}
/* xdostar - built-in function 'do*' */
NODE *xdostar(args)
NODE *args;
{
return (doloop(args,FALSE));
}
/* doloop - common do routine */
LOCAL NODE *doloop(args,pflag)
NODE *args; int pflag;
{
NODE ***oldstk,*newenv,*arg,*blist,*clist,*test,*rval;
int rbreak;
/* create a new stack frame */
oldstk = xlsave(&newenv,&arg,&blist,&clist,&test,(NODE **)NULL);
/* initialize */
arg = args;
/* get the list of bindings */
blist = xlmatch(LIST,&arg);
/* create a new environment frame */
newenv = xlframe(xlenv);
/* bind the symbols */
if (!pflag) xlenv = newenv;
dobindings(blist,newenv);
if (pflag) xlenv = newenv;
/* get the exit test and result forms */
clist = xlmatch(LIST,&arg);
test = xlarg(&clist);
/* execute the loop as long as the test is false */
rbreak = FALSE;
while (xleval(test) == NIL) {
/* execute the body of the loop */
if (tagblock(arg,&rval)) {
rbreak = TRUE;
break;
}
/* update the looping variables */
doupdates(blist,pflag);
}
/* evaluate the result expression */
if (!rbreak)
for (rval = NIL; consp(clist); )
rval = xlevarg(&clist);
/* unbind the arguments */
xlenv = cdr(xlenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (rval);
}
/* xdolist - built-in function 'dolist' */
NODE *xdolist(args)
NODE *args;
{
NODE ***oldstk,*arg,*clist,*sym,*list,*val,*rval;
int rbreak;
/* create a new stack frame */
oldstk = xlsave(&arg,&clist,&sym,&list,&val,(NODE **)NULL);
/* initialize */
arg = args;
/* get the control list (sym list result-expr) */
clist = xlmatch(LIST,&arg);
sym = xlmatch(SYM,&clist);
list = xlevmatch(LIST,&clist);
val = (clist ? xlarg(&clist) : NIL);
/* initialize the local environment */
xlenv = xlframe(xlenv);
xlbind(sym,NIL,xlenv);
/* loop through the list */
rbreak = FALSE;
for (; consp(list); list = cdr(list)) {
/* bind the symbol to the next list element */
xlsetvalue(sym,car(list));
/* execute the loop body */
if (tagblock(arg,&rval)) {
rbreak = TRUE;
break;
}
}
/* evaluate the result expression */
if (!rbreak) {
xlsetvalue(sym,NIL);
rval = xleval(val);
}
/* unbind the arguments */
xlenv = cdr(xlenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (rval);
}
/* xdotimes - built-in function 'dotimes' */
NODE *xdotimes(args)
NODE *args;
{
NODE ***oldstk,*arg,*clist,*sym,*val,*rval;
int rbreak,cnt,i;
/* create a new stack frame */
oldstk = xlsave(&arg,&clist,&sym,&val,(NODE **)NULL);
/* initialize */
arg = args;
/* get the control list (sym list result-expr) */
clist = xlmatch(LIST,&arg);
sym = xlmatch(SYM,&clist);
cnt = getfixnum(xlevmatch(INT,&clist));
val = (clist ? xlarg(&clist) : NIL);
/* initialize the local environment */
xlenv = xlframe(xlenv);
xlbind(sym,NIL,xlenv);
/* loop through for each value from zero to cnt-1 */
rbreak = FALSE;
for (i = 0; i < cnt; i++) {
/* bind the symbol to the next list element */
xlsetvalue(sym,cvfixnum((FIXNUM)i));
/* execute the loop body */
if (tagblock(arg,&rval)) {
rbreak = TRUE;
break;
}
}
/* evaluate the result expression */
if (!rbreak) {
xlsetvalue(sym,cvfixnum((FIXNUM)cnt));
rval = xleval(val);
}
/* unbind the arguments */
xlenv = cdr(xlenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (rval);
}
/* xcatch - built-in function 'catch' */
NODE *xcatch(args)
NODE *args;
{
NODE ***oldstk,*tag,*arg,*val;
CONTEXT cntxt;
/* create a new stack frame */
oldstk = xlsave(&tag,&arg,(NODE **)NULL);
/* initialize */
tag = xlevarg(&args);
arg = args;
val = NIL;
/* establish an execution context */
xlbegin(&cntxt,CF_THROW,tag);
/* check for 'throw' */
if (setjmp(cntxt.c_jmpbuf))
val = xlvalue;
/* otherwise, evaluate the remainder of the arguments */
else {
while (arg)
val = xlevarg(&arg);
}
xlend(&cntxt);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xthrow - built-in function 'throw' */
NODE *xthrow(args)
NODE *args;
{
NODE *tag,*val;
/* get the tag and value */
tag = xlarg(&args);
val = (args ? xlarg(&args) : NIL);
xllastarg(args);
/* throw the tag */
xlthrow(tag,val);
}
/* xerror - built-in function 'error' */
NODE *xerror(args)
NODE *args;
{
char *emsg; NODE *arg;
/* get the error message and the argument */
emsg = getstring(xlmatch(STR,&args));
arg = (args ? xlarg(&args) : s_unbound);
xllastarg(args);
/* signal the error */
xlerror(emsg,arg);
}
/* xcerror - built-in function 'cerror' */
NODE *xcerror(args)
NODE *args;
{
char *cmsg,*emsg; NODE *arg;
/* get the correction message, the error message, and the argument */
cmsg = getstring(xlmatch(STR,&args));
emsg = getstring(xlmatch(STR,&args));
arg = (args ? xlarg(&args) : s_unbound);
xllastarg(args);
/* signal the error */
xlcerror(cmsg,emsg,arg);
/* return nil */
return (NIL);
}
/* xbreak - built-in function 'break' */
NODE *xbreak(args)
NODE *args;
{
char *emsg; NODE *arg;
/* get the error message */
emsg = (args ? getstring(xlmatch(STR,&args)) : "**BREAK**");
arg = (args ? xlarg(&args) : s_unbound);
xllastarg(args);
/* enter the break loop */
xlbreak(emsg,arg);
/* return nil */
return (NIL);
}
/* xcleanup - built-in function 'clean-up' */
NODE *xcleanup(args)
NODE *args;
{
xllastarg(args);
xlcleanup();
}
/* xcontinue - built-in function 'continue' */
NODE *xcontinue(args)
NODE *args;
{
xllastarg(args);
xlcontinue();
}
/* xerrset - built-in function 'errset' */
NODE *xerrset(args)
NODE *args;
{
NODE ***oldstk,*expr,*flag,*val;
CONTEXT cntxt;
/* create a new stack frame */
oldstk = xlsave(&expr,&flag,(NODE **)NULL);
/* get the expression and the print flag */
expr = xlarg(&args);
flag = (args ? xlarg(&args) : true);
xllastarg(args);
/* establish an execution context */
xlbegin(&cntxt,CF_ERROR,flag);
/* check for error */
if (setjmp(cntxt.c_jmpbuf))
val = NIL;
/* otherwise, evaluate the expression */
else {
expr = xleval(expr);
val = consa(expr);
}
xlend(&cntxt);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* xevalhook - eval hook function */
NODE *xevalhook(args)
NODE *args;
{
NODE ***oldstk,*expr,*ehook,*ahook,*env,*newehook,*newahook,*newenv,*val;
/* create a new stack frame */
oldstk = xlsave(&expr,&ehook,&ahook,&env,&newehook,&newahook,&newenv,(NODE **)NULL);
/* get the expression, the new hook functions and the environment */
expr = xlarg(&args);
newehook = xlarg(&args);
newahook = xlarg(&args);
newenv = (args ? xlarg(&args) : xlenv);
xllastarg(args);
/* bind *evalhook* and *applyhook* to the hook functions */
ehook = getvalue(s_evalhook);
setvalue(s_evalhook,newehook);
ahook = getvalue(s_applyhook);
setvalue(s_applyhook,newahook);
env = xlenv;
xlenv = newenv;
/* evaluate the expression (bypassing *evalhook*) */
val = xlxeval(expr);
/* unbind the hook variables */
setvalue(s_evalhook,ehook);
setvalue(s_applyhook,ahook);
xlenv = env;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result */
return (val);
}
/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
LOCAL dobindings(blist,env)
NODE *blist,*env;
{
NODE ***oldstk,*list,*bnd,*sym,*val;
/* create a new stack frame */
oldstk = xlsave(&list,&bnd,&sym,&val,(NODE **)NULL);
/* bind each symbol in the list of bindings */
for (list = blist; consp(list); list = cdr(list)) {
/* get the next binding */
bnd = car(list);
/* handle a symbol */
if (symbolp(bnd)) {
sym = bnd;
val = NIL;
}
/* handle a list of the form (symbol expr) */
else if (consp(bnd)) {
sym = xlmatch(SYM,&bnd);
val = xlevarg(&bnd);
}
else
xlfail("bad binding");
/* bind the value to the symbol */
xlbind(sym,val,env);
}
/* restore the previous stack frame */
xlstack = oldstk;
}
/* doupdates - handle updates for do/do* */
doupdates(blist,pflag)
NODE *blist; int pflag;
{
NODE ***oldstk,*plist,*list,*bnd,*sym,*val;
/* create a new stack frame */
oldstk = xlsave(&plist,&list,&bnd,&sym,&val,(NODE **)NULL);
/* bind each symbol in the list of bindings */
for (list = blist; consp(list); list = cdr(list)) {
/* get the next binding */
bnd = car(list);
/* handle a list of the form (symbol expr) */
if (consp(bnd)) {
sym = xlmatch(SYM,&bnd);
bnd = cdr(bnd);
if (bnd) {
val = xlevarg(&bnd);
if (pflag) {
plist = consd(plist);
rplaca(plist,cons(sym,val));
}
else
xlsetvalue(sym,val);
}
}
}
/* set the values for parallel updates */
for (; plist; plist = cdr(plist))
xlsetvalue(car(car(plist)),cdr(car(plist)));
/* restore the previous stack frame */
xlstack = oldstk;
}
/* tagblock - execute code within a block and tagbody */
int tagblock(code,pval)
NODE *code,**pval;
{
NODE ***oldstk,*arg;
CONTEXT cntxt;
int type,sts;
/* create a new stack frame */
oldstk = xlsave(&arg,(NODE **)NULL);
/* initialize */
arg = code;
/* establish an execution context */
xlbegin(&cntxt,CF_GO|CF_RETURN,arg);
/* check for a 'return' */
if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
*pval = xlvalue;
sts = TRUE;
}
/* otherwise, enter the body */
else {
/* check for a 'go' */
if (type == CF_GO)
arg = xlvalue;
/* evaluate each expression in the body */
while (consp(arg))
if (consp(car(arg)))
xlevarg(&arg);
else
arg = cdr(arg);
/* fell out the bottom of the loop */
*pval = NIL;
sts = FALSE;
}
xlend(&cntxt);
/* restore the previous stack frame */
xlstack = oldstk;
/* return status */
return (sts);
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xldbug.c'
then
echo shar: will not over-write existing file "'xldbug.c'"
else
cat << \SHAR_EOF > 'xldbug.c'
/* xldebug - xlisp debugging support */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern long total;
extern int xldebug;
extern int xltrace;
extern int xlsample;
extern NODE *s_unbound;
extern NODE *s_stdin,*s_stdout;
extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
extern NODE ***xlstack;
extern NODE *true;
extern NODE **trace_stack;
extern char buf[];
/* external routines */
extern char *malloc();
/* forward declarations */
FORWARD NODE *stacktop();
/* xlfail - xlisp error handler */
/*VARARGS*/
xlfail(emsg)
char *emsg;
{
xlerror(emsg,stacktop());
}
/* xlabort - xlisp serious error handler */
xlabort(emsg)
char *emsg;
{
xlsignal(emsg,s_unbound);
}
/* xlbreak - enter a break loop */
xlbreak(emsg,arg)
char *emsg; NODE *arg;
{
breakloop("break",NULL,emsg,arg,TRUE);
}
/* xlerror - handle a fatal error */
xlerror(emsg,arg)
char *emsg; NODE *arg;
{
doerror(NULL,emsg,arg,FALSE);
}
/* xlcerror - handle a recoverable error */
xlcerror(cmsg,emsg,arg)
char *cmsg,*emsg; NODE *arg;
{
doerror(cmsg,emsg,arg,TRUE);
}
/* xlerrprint - print an error message */
xlerrprint(hdr,cmsg,emsg,arg)
char *hdr,*cmsg,*emsg; NODE *arg;
{
sprintf(buf,"%s: %s",hdr,emsg); stdputstr(buf);
if (arg != s_unbound) { stdputstr(" - "); stdprint(arg); }
else xlterpri(getvalue(s_stdout));
if (cmsg) { sprintf(buf,"if continued: %s\n",cmsg); stdputstr(buf); }
}
/* doerror - handle xlisp errors */
LOCAL doerror(cmsg,emsg,arg,cflag)
char *cmsg,*emsg; NODE *arg; int cflag;
{
/* make sure the break loop is enabled */
if (getvalue(s_breakenable) == NIL)
xlsignal(emsg,arg);
/* call the debug read-eval-print loop */
breakloop("error",cmsg,emsg,arg,cflag);
}
/* breakloop - the debug read-eval-print loop */
LOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
char *hdr,*cmsg,*emsg; NODE *arg; int cflag;
{
NODE ***oldstk,*expr,*val;
CONTEXT cntxt;
int type;
/* print the error message */
xlerrprint(hdr,cmsg,emsg,arg);
/* flush the input buffer */
xlflush();
/* do the back trace */
if (getvalue(s_tracenable)) {
val = getvalue(s_tlimit);
xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
}
/* create a new stack frame */
oldstk = xlsave(&expr,(NODE **)NULL);
/* increment the debug level */
xldebug++;
/* debug command processing loop */
xlbegin(&cntxt,CF_ERROR|CF_CLEANUP|CF_CONTINUE,true);
for (type = 0; type == 0; ) {
/* setup the continue trap */
if (type = setjmp(cntxt.c_jmpbuf))
switch (type) {
case CF_ERROR:
xlflush();
type = 0;
continue;
case CF_CLEANUP:
continue;
case CF_CONTINUE:
if (cflag) {
stdputstr("[ continue from break loop ]\n");
continue;
}
else xlabort("this error can't be continued");
}
/* read an expression and check for eof */
if (!xlread(getvalue(s_stdin),&expr,FALSE)) {
type = CF_CLEANUP;
break;
}
/* evaluate the expression */
expr = xleval(expr);
/* print it */
xlprint(getvalue(s_stdout),expr,TRUE);
xlterpri(getvalue(s_stdout));
}
xlend(&cntxt);
/* decrement the debug level */
xldebug--;
/* restore the previous stack frame */
xlstack = oldstk;
/* check for aborting to the previous level */
if (type == CF_CLEANUP) {
stdputstr("[ abort to previous level ]\n");
xlsignal(NULL,NIL);
}
}
/* stacktop - return the top node on the stack */
LOCAL NODE *stacktop()
{
return (xltrace >= 0 && xltrace < TDEPTH ? trace_stack[xltrace] : s_unbound);
}
/* baktrace - do a back trace */
xlbaktrace(n)
int n;
{
int i;
for (i = xltrace; (n < 0 || n--) && i >= 0; i--)
if (i < TDEPTH)
stdprint(trace_stack[i]);
}
/* xldinit - debug initialization routine */
xldinit()
{
if ((trace_stack = (NODE **)malloc(TDEPTH * sizeof(NODE *))) == NULL) {
printf("insufficient memory");
osfinish();
exit(1);
}
total += (long)(TDEPTH * sizeof(NODE *));
xlsample = 0;
xltrace = -1;
xldebug = 0;
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xldmem.c'
then
echo shar: will not over-write existing file "'xldmem.c'"
else
cat << \SHAR_EOF > 'xldmem.c'
/* xldmem - xlisp dynamic memory management routines */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* useful definitions */
#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
/* external variables */
extern NODE ***xlstack,***xlstkbase,***xlstktop;
extern NODE *obarray;
extern NODE *xlenv;
extern long total;
extern int anodes,nnodes,nsegs,nfree,gccalls;
extern struct segment *segs;
extern NODE *fnodes;
extern char buf[];
/* external procedures */
extern char *malloc();
extern char *calloc();
/* forward declarations */
FORWARD NODE *newnode();
FORWARD char *strsave();
FORWARD char *stralloc();
/* cons - construct a new cons node */
NODE *cons(x,y)
NODE *x,*y;
{
NODE *val;
val = newnode(LIST);
rplaca(val,x);
rplacd(val,y);
return (val);
}
/* consa - (cons x nil) */
NODE *consa(x)
NODE *x;
{
NODE *val;
val = newnode(LIST);
rplaca(val,x);
return (val);
}
/* consd - (cons nil x) */
NODE *consd(x)
NODE *x;
{
NODE *val;
val = newnode(LIST);
rplacd(val,x);
return (val);
}
/* cvstring - convert a string to a string node */
NODE *cvstring(str)
char *str;
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,(NODE **)NULL);
val = newnode(STR);
val->n_str = strsave(str);
val->n_strtype = DYNAMIC;
xlstack = oldstk;
return (val);
}
/* cvcstring - convert a constant string to a string node */
NODE *cvcstring(str)
char *str;
{
NODE *val;
val = newnode(STR);
val->n_str = str;
val->n_strtype = STATIC;
return (val);
}
/* cvsymbol - convert a string to a symbol */
NODE *cvsymbol(pname)
char *pname;
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,(NODE **)NULL);
val = newnode(SYM);
val->n_symplist = newnode(LIST);
rplaca(val->n_symplist,cvstring(pname));
xlstack = oldstk;
return (val);
}
/* cvcsymbol - convert a constant string to a symbol */
NODE *cvcsymbol(pname)
char *pname;
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,(NODE **)NULL);
val = newnode(SYM);
val->n_symplist = newnode(LIST);
rplaca(val->n_symplist,cvcstring(pname));
xlstack = oldstk;
return (val);
}
/* cvsubr - convert a function to a subr or fsubr */
NODE *cvsubr(fcn,type)
NODE *(*fcn)(); int type;
{
NODE *val;
val = newnode(type);
val->n_subr = fcn;
return (val);
}
/* cvfile - convert a file pointer to a file */
NODE *cvfile(fp)
FILE *fp;
{
NODE *val;
val = newnode(FPTR);
setfile(val,fp);
setsavech(val,0);
return (val);
}
/* cvfixnum - convert an integer to a fixnum node */
NODE *cvfixnum(n)
FIXNUM n;
{
NODE *val;
val = newnode(INT);
val->n_int = n;
return (val);
}
/* cvflonum - convert a floating point number to a flonum node */
NODE *cvflonum(n)
FLONUM n;
{
NODE *val;
val = newnode(FLOAT);
val->n_float = n;
return (val);
}
/* newstring - allocate and initialize a new string */
NODE *newstring(size)
int size;
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,(NODE **)NULL);
val = newnode(STR);
val->n_str = stralloc(size);
*getstring(val) = 0;
val->n_strtype = DYNAMIC;
xlstack = oldstk;
return (val);
}
/* newobject - allocate and initialize a new object */
NODE *newobject(cls,size)
NODE *cls; int size;
{
NODE *val;
val = newvector(size+1);
setelement(val,0,cls);
val->n_type = OBJ;
return (val);
}
/* newvector - allocate and initialize a new vector node */
NODE *newvector(size)
int size;
{
NODE ***oldstk,*vect;
int bsize;
/* establish a new stack frame */
oldstk = xlsave(&vect,(NODE **)NULL);
/* allocate a vector node and set the size to zero (in case of gc) */
vect = newnode(VECT);
vect->n_vsize = 0;
/* allocate memory for the vector */
bsize = size * sizeof(NODE *);
if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
findmem();
if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
xlfail("insufficient vector space");
}
vect->n_vsize = size;
total += (long) bsize;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new vector */
return (vect);
}
/* newnode - allocate a new node */
LOCAL NODE *newnode(type)
int type;
{
NODE *nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
nfree -= 1;
/* initialize the new node */
nnode->n_type = type;
rplacd(nnode,NIL);
/* return the new node */
return (nnode);
}
/* stralloc - allocate memory for a string adding a byte for the terminator */
LOCAL char *stralloc(size)
int size;
{
char *sptr;
/* allocate memory for the string copy */
if ((sptr = malloc(size+1)) == NULL) {
findmem();
if ((sptr = malloc(size+1)) == NULL)
xlfail("insufficient string space");
}
total += (long) (size+1);
/* return the new string memory */
return (sptr);
}
/* strsave - generate a dynamic copy of a string */
LOCAL char *strsave(str)
char *str;
{
char *sptr;
/* create a new string */
sptr = stralloc(strlen(str));
strcpy(sptr,str);
/* return the new string */
return (sptr);
}
/* strfree - free a string UNUSED
LOCAL strfree(str)
char *str;
{
total -= (long) (strlen(str)+1);
free(str);
}
*/
/* findmem - find more memory by collecting then expanding */
findmem()
{
gc();
if (nfree < anodes)
addseg();
}
/* gc - garbage collect */
gc()
{
NODE ***p;
void mark();
/* mark the obarray and the current environment */
mark(obarray);
mark(xlenv);
/* mark the evaluation stack */
for (p = xlstack; p < xlstktop; )
mark(**p++);
/* sweep memory collecting all unmarked nodes */
sweep();
/* count the gc call */
gccalls++;
}
/* mark - mark all accessible nodes */
void mark(ptr)
NODE *ptr;
{
NODE *this,*prev,*tmp;
/* just return on nil */
if (ptr == NIL)
return;
/* initialize */
prev = NIL;
this = ptr;
/* mark this list */
while (TRUE) {
/* descend as far as we can */
while (TRUE) {
/* check for this node being marked */
if (this->n_flags & MARK)
break;
/* mark it and its descendants */
else {
/* mark the node */
this->n_flags |= MARK;
/* follow the left sublist if there is one */
if (livecar(this)) {
this->n_flags |= LEFT;
tmp = prev;
prev = this;
this = car(prev);
rplaca(prev,tmp);
}
/* otherwise, follow the right sublist if there is one */
else if (livecdr(this)) {
this->n_flags &= ~LEFT;
tmp = prev;
prev = this;
this = cdr(prev);
rplacd(prev,tmp);
}
else
break;
}
}
/* backup to a point where we can continue descending */
while (TRUE) {
/* check for termination condition */
if (prev == NIL)
return;
/* check for coming from the left side */
if (prev->n_flags & LEFT)
if (livecdr(prev)) {
prev->n_flags &= ~LEFT;
tmp = car(prev);
rplaca(prev,this);
this = cdr(prev);
rplacd(prev,tmp);
break;
}
else {
tmp = prev;
prev = car(tmp);
rplaca(tmp,this);
this = tmp;
}
/* otherwise, came from the right side */
else {
tmp = prev;
prev = cdr(tmp);
rplacd(tmp,this);
this = tmp;
}
}
}
}
/* vmark - mark a vector */
vmark(n)
NODE *n;
{
int i;
for (i = 0; i < getsize(n); ++i)
mark(getelement(n,i));
}
/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL sweep()
{
struct segment *seg;
NODE *p;
int n;
/* empty the free list */
fnodes = NIL;
nfree = 0;
/* add all unmarked nodes */
for (seg = segs; seg != NULL; seg = seg->sg_next) {
p = &seg->sg_nodes[0];
for (n = seg->sg_size; n--; p++)
if (!(p->n_flags & MARK)) {
switch (ntype(p)) {
case STR:
if (p->n_strtype == DYNAMIC && p->n_str != NULL) {
total -= (long) (strlen(p->n_str)+1);
free(p->n_str);
}
break;
case FPTR:
if (p->n_fp)
fclose(p->n_fp);
break;
case VECT:
if (p->n_vsize) {
total -= (long) (p->n_vsize * sizeof(NODE **));
free(p->n_vdata);
}
break;
}
p->n_type = FREE;
p->n_flags = 0;
rplaca(p,NIL);
rplacd(p,fnodes);
fnodes = p;
nfree++;
}
else
p->n_flags &= ~(MARK | LEFT);
}
}
/* addseg - add a segment to the available memory */
int addseg()
{
struct segment *newseg;
NODE *p;
int n;
/* check for zero allocation */
if (anodes == 0)
return (FALSE);
/* allocate a new segment */
if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
/* initialize the new segment */
newseg->sg_size = anodes;
newseg->sg_next = segs;
segs = newseg;
/* add each new node to the free list */
p = &newseg->sg_nodes[0];
for (n = anodes; n--; ) {
rplacd(p,fnodes);
fnodes = p++;
}
/* update the statistics */
total += (long) ALLOCSIZE;
nnodes += anodes;
nfree += anodes;
nsegs++;
/* return successfully */
return (TRUE);
}
else
return (FALSE);
}
/* livecar - do we need to follow the car? */
LOCAL int livecar(n)
NODE *n;
{
switch (ntype(n)) {
case OBJ:
case VECT:
vmark(n);
case SUBR:
case FSUBR:
case INT:
case FLOAT:
case STR:
case FPTR:
return (FALSE);
case SYM:
case LIST:
return (car(n) != NIL);
default:
printf("bad node type (%d) found during left scan\n",ntype(n));
osfinish ();
exit(1);
}
/*NOTREACHED*/
}
/* livecdr - do we need to follow the cdr? */
LOCAL int livecdr(n)
NODE *n;
{
switch (ntype(n)) {
case SUBR:
case FSUBR:
case INT:
case FLOAT:
case STR:
case FPTR:
case OBJ:
case VECT:
return (FALSE);
case SYM:
case LIST:
return (cdr(n) != NIL);
default:
printf("bad node type (%d) found during right scan\n",ntype(n));
osfinish ();
exit(1);
}
/*NOTREACHED*/
}
/* stats - print memory statistics */
stats()
{
sprintf(buf,"Nodes: %d\n",nnodes); stdputstr(buf);
sprintf(buf,"Free nodes: %d\n",nfree); stdputstr(buf);
sprintf(buf,"Segments: %d\n",nsegs); stdputstr(buf);
sprintf(buf,"Allocate: %d\n",anodes); stdputstr(buf);
sprintf(buf,"Total: %ld\n",total); stdputstr(buf);
sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
}
/* xlminit - initialize the dynamic memory module */
xlminit()
{
/* initialize our internal variables */
anodes = NNODES;
total = 0L;
nnodes = nsegs = nfree = gccalls = 0;
fnodes = NIL;
segs = NULL;
/* initialize structures that are marked by the collector */
xlenv = obarray = NIL;
/* allocate the evaluation stack */
if ((xlstkbase = (NODE ***)malloc(EDEPTH * sizeof(NODE **))) == NULL) {
printf("insufficient memory");
osfinish ();
exit(1);
}
total += (long)(EDEPTH * sizeof(NODE **));
xlstack = xlstktop = xlstkbase + EDEPTH;
}
SHAR_EOF
fi # end of overwriting check
if test -f 'xleval.c'
then
echo shar: will not over-write existing file "'xleval.c'"
else
cat << \SHAR_EOF > 'xleval.c'
/* xleval - xlisp evaluator */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern int xlsample;
extern NODE ***xlstack,***xlstkbase,*xlenv;
extern NODE *s_lambda,*s_macro;
extern NODE *k_optional,*k_rest,*k_aux;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *s_unbound;
extern NODE *s_stdout;
/* trace variables */
extern NODE **trace_stack;
extern int xltrace;
/* forward declarations */
FORWARD NODE *xlxeval();
FORWARD NODE *evalhook();
FORWARD NODE *evform();
FORWARD NODE *evfun();
/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
NODE *xleval(expr)
NODE *expr;
{
/* check for control codes */
if (--xlsample <= 0) {
xlsample = SAMPLE;
oscheck();
}
/* check for *evalhook* */
if (getvalue(s_evalhook))
return (evalhook(expr));
/* add trace entry */
if (++xltrace < TDEPTH)
trace_stack[xltrace] = expr;
/* check type of value */
if (consp(expr))
expr = evform(expr);
else if (symbolp(expr))
expr = xlgetvalue(expr);
/* remove trace entry */
--xltrace;
/* return the value */
return (expr);
}
/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
NODE *xlxeval(expr)
NODE *expr;
{
/* check type of value */
if (consp(expr))
expr = evform(expr);
else if (symbolp(expr))
expr = xlgetvalue(expr);
/* return the value */
return (expr);
}
/* xlapply - apply a function to a list of arguments */
NODE *xlapply(fun,args)
NODE *fun,*args;
{
NODE *env,*val;
/* check for a null function */
if (fun == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun))
val = (*getsubr(fun))(args);
else if (consp(fun)) {
if (consp(car(fun))) {
env = cdr(fun);
fun = car(fun);
}
else
env = xlenv;
if (car(fun) != s_lambda)
xlfail("bad function type");
val = evfun(fun,args,env);
}
else
xlfail("bad function");
/* return the result value */
return (val);
}
/* evform - evaluate a form */
LOCAL NODE *evform(expr)
NODE *expr;
{
NODE ***oldstk,*fun,*args,*env,*val,*type;
/* create a stack frame */
oldstk = xlsave(&fun,&args,(NODE **)NULL);
/* get the function and the argument list */
fun = car(expr);
args = cdr(expr);
/* evaluate the first expression */
if ((fun = xleval(fun)) == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun) || fsubrp(fun)) {
if (subrp(fun))
args = xlevlist(args);
val = (*getsubr(fun))(args);
}
else if (consp(fun)) {
if (consp(car(fun))) {
env = cdr(fun);
fun = car(fun);
}
else
env = xlenv;
if ((type = car(fun)) == s_lambda) {
args = xlevlist(args);
val = evfun(fun,args,env);
}
else if (type == s_macro) {
args = evfun(fun,args,env);
val = xleval(args);
}
else
xlfail("bad function type");
}
else if (objectp(fun))
val = xlsend(fun,args);
else
xlfail("bad function");
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* evalhook - call the evalhook function */
LOCAL NODE *evalhook(expr)
NODE *expr;
{
NODE ***oldstk,*ehook,*ahook,*args,*val;
/* create a new stack frame */
oldstk = xlsave(&ehook,&ahook,&args,(NODE **)NULL);
/* make an argument list */
args = consa(expr);
rplacd(args,consa(xlenv));
/* rebind the hook functions to nil */
ehook = getvalue(s_evalhook);
setvalue(s_evalhook,NIL);
ahook = getvalue(s_applyhook);
setvalue(s_applyhook,NIL);
/* call the hook function */
val = xlapply(ehook,args);
/* unbind the symbols */
setvalue(s_evalhook,ehook);
setvalue(s_applyhook,ahook);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* xlevlist - evaluate a list of arguments */
NODE *xlevlist(args)
NODE *args;
{
NODE ***oldstk,*src,*dst,*new,*val;
NODE *last = NIL;
/* create a stack frame */
oldstk = xlsave(&src,&dst,(NODE **)NULL);
/* initialize */
src = args;
/* evaluate each argument */
for (val = NIL; src; src = cdr(src)) {
/* check this entry */
if (!consp(src))
xlfail("bad argument list");
/* allocate a new list entry */
new = consa(NIL);
if (val)
rplacd(last,new);
else
val = dst = new;
rplaca(new,xleval(car(src)));
last = new;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new list */
return (val);
}
/* xlunbound - signal an unbound variable error */
xlunbound(sym)
NODE *sym;
{
xlcerror("try evaluating symbol again","unbound variable",sym);
}
/* evfun - evaluate a function */
LOCAL NODE *evfun(fun,args,env)
NODE *fun,*args,*env;
{
NODE ***oldstk,*oldenv,*newenv,*cptr,*fargs,*val;
/* create a stack frame */
oldstk = xlsave(&oldenv,&newenv,&cptr,(NODE **)NULL);
/* skip the function type */
if ((fun = cdr(fun)) == NIL || !consp(fun))
xlfail("bad function definition");
/* get the formal argument list */
if ((fargs = car(fun)) && !consp(fargs))
xlfail("bad formal argument list");
/* create a new environment frame */
newenv = xlframe(env);
oldenv = xlenv;
/* bind the formal parameters */
xlabind(fargs,args,newenv);
xlenv = newenv;
/* execute the code */
for (cptr = cdr(fun); cptr; )
val = xlevarg(&cptr);
/* restore the environment */
xlenv = oldenv;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xlabind - bind the arguments for a function */
xlabind(fargs,aargs,env)
NODE *fargs,*aargs,*env;
{
NODE *arg;
/* evaluate and bind each required argument */
while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
/* bind the formal variable to the argument value */
xlbind(arg,car(aargs),env);
/* move the argument list pointers ahead */
fargs = cdr(fargs);
aargs = cdr(aargs);
}
/* check for the '&optional' keyword */
if (consp(fargs) && car(fargs) == k_optional) {
fargs = cdr(fargs);
/* bind the arguments that were supplied */
while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
/* bind the formal variable to the argument value */
xlbind(arg,car(aargs),env);
/* move the argument list pointers ahead */
fargs = cdr(fargs);
aargs = cdr(aargs);
}
/* bind the rest to nil */
while (consp(fargs) && !iskeyword(arg = car(fargs))) {
/* bind the formal variable to nil */
xlbind(arg,NIL,env);
/* move the argument list pointer ahead */
fargs = cdr(fargs);
}
}
/* check for the '&rest' keyword */
if (consp(fargs) && car(fargs) == k_rest) {
fargs = cdr(fargs);
if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
xlbind(arg,aargs,env);
else
xlfail("symbol missing after &rest");
fargs = cdr(fargs);
aargs = NIL;
}
/* check for the '&aux' keyword */
if (consp(fargs) && car(fargs) == k_aux)
while ((fargs = cdr(fargs)) != NIL && consp(fargs))
xlbind(car(fargs),NIL,env);
/* make sure the correct number of arguments were supplied */
if (fargs != aargs)
xlfail(fargs ? "too few arguments" : "too many arguments");
}
/* iskeyword - check to see if a symbol is a keyword */
LOCAL int iskeyword(sym)
NODE *sym;
{
return (sym == k_optional || sym == k_rest || sym == k_aux);
}
/* xlsave - save nodes on the stack */
/*VARARGS*/
NODE ***xlsave(n)
NODE **n;
{
NODE ***oldstk,***nptr;
/* save the old stack pointer */
oldstk = xlstack;
/* save each node pointer */
for (nptr = &n; *nptr; nptr++) {
if (xlstack <= xlstkbase)
xlabort("evaluation stack overflow");
*--xlstack = *nptr;
**nptr = NIL;
}
/* return the old stack pointer */
return (oldstk);
}
SHAR_EOF
fi # end of overwriting check
# End of shell archive
exit 0