garym@cognos.UUCP (Gary Murphy) (02/27/90)
Posting-number: Volume 10, Issue 91
Submitted-by: garym@cognos.UUCP (Gary Murphy)
Archive-name: xlisp21/part04
#!/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
# xldmem.h
# xleval.c
# This archive created: Sun Feb 18 07:45:24 1990
# By: Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlbfun.c'" '(12891 characters)'
if test -f 'xlbfun.c'
then
echo shar: over-writing existing file "'xlbfun.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlbfun.c'
X/* xlbfun.c - xlisp basic built-in functions */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,true;
Xextern LVAL s_evalhook,s_applyhook;
Xextern LVAL s_car,s_cdr,s_nth,s_get,s_svalue,s_splist,s_aref;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_comma,s_comat;
Xextern LVAL s_unbound;
Xextern char gsprefix[];
Xextern int gsnumber;
X
X/* external routines */
Xextern LVAL xlxeval();
X
X/* forward declarations */
XFORWARD LVAL bquote1();
XFORWARD LVAL defun();
XFORWARD LVAL makesymbol();
X
X/* xeval - the built-in function 'eval' */
XLVAL xeval()
X{
X LVAL expr;
X
X /* get the expression to evaluate */
X expr = xlgetarg();
X xllastarg();
X
X /* evaluate the expression */
X return (xleval(expr));
X}
X
X/* xapply - the built-in function 'apply' */
XLVAL xapply()
X{
X LVAL fun,arglist;
X
X /* get the function and argument list */
X fun = xlgetarg();
X arglist = xlgalist();
X xllastarg();
X
X /* apply the function to the arguments */
X return (xlapply(pushargs(fun,arglist)));
X}
X
X/* xfuncall - the built-in function 'funcall' */
XLVAL xfuncall()
X{
X LVAL *newfp;
X int argc;
X
X /* build a new argument stack frame */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(xlgetarg());
X pusharg(NIL); /* will be argc */
X
X /* push each argument */
X for (argc = 0; moreargs(); ++argc)
X pusharg(nextarg());
X
X /* establish the new stack frame */
X newfp[2] = cvfixnum((FIXTYPE)argc);
X xlfp = newfp;
X
X /* apply the function to the arguments */
X return (xlapply(argc));
X}
X
X/* xmacroexpand - expand a macro call repeatedly */
XLVAL xmacroexpand()
X{
X LVAL form;
X form = xlgetarg();
X xllastarg();
X return (xlexpandmacros(form));
X}
X
X/* x1macroexpand - expand a macro call */
XLVAL x1macroexpand()
X{
X LVAL form,fun,args;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(fun);
X xlsave(args);
X
X /* get the form */
X form = xlgetarg();
X xllastarg();
X
X /* expand until the form isn't a macro call */
X if (consp(form)) {
X fun = car(form); /* get the macro name */
X args = cdr(form); /* get the arguments */
X if (symbolp(fun) && fboundp(fun)) {
X fun = xlgetfunction(fun); /* get the expansion function */
X macroexpand(fun,args,&form);
X }
X }
X
X /* restore the stack and return the expansion */
X xlpopn(2);
X return (form);
X}
X
X/* xatom - is this an atom? */
XLVAL xatom()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (atom(arg) ? true : NIL);
X}
X
X/* xsymbolp - is this an symbol? */
XLVAL xsymbolp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (arg == NIL || symbolp(arg) ? true : NIL);
X}
X
X/* xnumberp - is this a number? */
XLVAL xnumberp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (fixp(arg) || floatp(arg) ? true : NIL);
X}
X
X/* xintegerp - is this an integer? */
XLVAL xintegerp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (fixp(arg) ? true : NIL);
X}
X
X/* xfloatp - is this a float? */
XLVAL xfloatp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (floatp(arg) ? true : NIL);
X}
X
X/* xcharp - is this a character? */
XLVAL xcharp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (charp(arg) ? true : NIL);
X}
X
X/* xstringp - is this a string? */
XLVAL xstringp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (stringp(arg) ? true : NIL);
X}
X
X/* xarrayp - is this an array? */
XLVAL xarrayp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (vectorp(arg) ? true : NIL);
X}
X
X/* xstreamp - is this a stream? */
XLVAL xstreamp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (streamp(arg) || ustreamp(arg) ? true : NIL);
X}
X
X/* xobjectp - is this an object? */
XLVAL xobjectp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (objectp(arg) ? true : NIL);
X}
X
X/* xboundp - is this a value bound to this symbol? */
XLVAL xboundp()
X{
X LVAL sym;
X sym = xlgasymbol();
X xllastarg();
X return (boundp(sym) ? true : NIL);
X}
X
X/* xfboundp - is this a functional value bound to this symbol? */
XLVAL xfboundp()
X{
X LVAL sym;
X sym = xlgasymbol();
X xllastarg();
X return (fboundp(sym) ? true : NIL);
X}
X
X/* xnull - is this null? */
XLVAL xnull()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (null(arg) ? true : NIL);
X}
X
X/* xlistp - is this a list? */
XLVAL xlistp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (listp(arg) ? true : NIL);
X}
X
X/* xendp - is this the end of a list? */
XLVAL xendp()
X{
X LVAL arg;
X arg = xlgalist();
X xllastarg();
X return (null(arg) ? true : NIL);
X}
X
X/* xconsp - is this a cons? */
XLVAL xconsp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (consp(arg) ? true : NIL);
X}
X
X/* xeq - are these equal? */
XLVAL xeq()
X{
X LVAL arg1,arg2;
X
X /* get the two arguments */
X arg1 = xlgetarg();
X arg2 = xlgetarg();
X xllastarg();
X
X /* compare the arguments */
X return (arg1 == arg2 ? true : NIL);
X}
X
X/* xeql - are these equal? */
XLVAL xeql()
X{
X LVAL arg1,arg2;
X
X /* get the two arguments */
X arg1 = xlgetarg();
X arg2 = xlgetarg();
X xllastarg();
X
X /* compare the arguments */
X return (eql(arg1,arg2) ? true : NIL);
X}
X
X/* xequal - are these equal? (recursive) */
XLVAL xequal()
X{
X LVAL arg1,arg2;
X
X /* get the two arguments */
X arg1 = xlgetarg();
X arg2 = xlgetarg();
X xllastarg();
X
X /* compare the arguments */
X return (equal(arg1,arg2) ? true : NIL);
X}
X
X/* xset - built-in function set */
XLVAL xset()
X{
X LVAL sym,val;
X
X /* get the symbol and new value */
X sym = xlgasymbol();
X val = xlgetarg();
X xllastarg();
X
X /* assign the symbol the value of argument 2 and the return value */
X setvalue(sym,val);
X
X /* return the result value */
X return (val);
X}
X
X/* xgensym - generate a symbol */
XLVAL xgensym()
X{
X char sym[STRMAX+11]; /* enough space for prefix and number */
X LVAL x;
X
X /* get the prefix or number */
X if (moreargs()) {
X x = xlgetarg();
X switch (ntype(x)) {
X case SYMBOL:
X x = getpname(x);
X case STRING:
X strncpy(gsprefix,getstring(x),STRMAX);
X gsprefix[STRMAX] = '\0';
X break;
X case FIXNUM:
X gsnumber = getfixnum(x);
X break;
X default:
X xlerror("bad argument type",x);
X }
X }
X xllastarg();
X
X /* create the pname of the new symbol */
X sprintf(sym,"%s%d",gsprefix,gsnumber++);
X
X /* make a symbol with this print name */
X return (xlmakesym(sym));
X}
X
X/* xmakesymbol - make a new uninterned symbol */
XLVAL xmakesymbol()
X{
X return (makesymbol(FALSE));
X}
X
X/* xintern - make a new interned symbol */
XLVAL xintern()
X{
X return (makesymbol(TRUE));
X}
X
X/* makesymbol - make a new symbol */
XLOCAL LVAL makesymbol(iflag)
X int iflag;
X{
X LVAL pname;
X
X /* get the print name of the symbol to intern */
X pname = xlgastring();
X xllastarg();
X
X /* make the symbol */
X return (iflag ? xlenter(getstring(pname))
X : xlmakesym(getstring(pname)));
X}
X
X/* xsymname - get the print name of a symbol */
XLVAL xsymname()
X{
X LVAL sym;
X
X /* get the symbol */
X sym = xlgasymbol();
X xllastarg();
X
X /* return the print name */
X return (getpname(sym));
X}
X
X/* xsymvalue - get the value of a symbol */
XLVAL xsymvalue()
X{
X LVAL sym,val;
X
X /* get the symbol */
X sym = xlgasymbol();
X xllastarg();
X
X /* get the global value */
X while ((val = getvalue(sym)) == s_unbound)
X xlunbound(sym);
X
X /* return its value */
X return (val);
X}
X
X/* xsymfunction - get the functional value of a symbol */
XLVAL xsymfunction()
X{
X LVAL sym,val;
X
X /* get the symbol */
X sym = xlgasymbol();
X xllastarg();
X
X /* get the global value */
X while ((val = getfunction(sym)) == s_unbound)
X xlfunbound(sym);
X
X /* return its value */
X return (val);
X}
X
X/* xsymplist - get the property list of a symbol */
XLVAL xsymplist()
X{
X LVAL sym;
X
X /* get the symbol */
X sym = xlgasymbol();
X xllastarg();
X
X /* return the property list */
X return (getplist(sym));
X}
X
X/* xget - get the value of a property */
XLVAL xget()
X{
X LVAL sym,prp;
X
X /* get the symbol and property */
X sym = xlgasymbol();
X prp = xlgasymbol();
X xllastarg();
X
X /* retrieve the property value */
X return (xlgetprop(sym,prp));
X}
X
X/* xputprop - set the value of a property */
XLVAL xputprop()
X{
X LVAL sym,val,prp;
X
X /* get the symbol and property */
X sym = xlgasymbol();
X val = xlgetarg();
X prp = xlgasymbol();
X xllastarg();
X
X /* set the property value */
X xlputprop(sym,val,prp);
X
X /* return the value */
X return (val);
X}
X
X/* xremprop - remove a property value from a property list */
XLVAL xremprop()
X{
X LVAL sym,prp;
X
X /* get the symbol and property */
X sym = xlgasymbol();
X prp = xlgasymbol();
X xllastarg();
X
X /* remove the property */
X xlremprop(sym,prp);
X
X /* return nil */
X return (NIL);
X}
X
X/* xhash - compute the hash value of a string or symbol */
XLVAL xhash()
X{
X unsigned char *str;
X LVAL len,val;
X int n;
X
X /* get the string and the table length */
X val = xlgetarg();
X len = xlgafixnum(); n = (int)getfixnum(len);
X xllastarg();
X
X /* get the string */
X if (symbolp(val))
X str = getstring(getpname(val));
X else if (stringp(val))
X str = getstring(val);
X else
X xlerror("bad argument type",val);
X
X /* return the hash index */
X return (cvfixnum((FIXTYPE)hash(str,n)));
X}
X
X/* xaref - array reference function */
XLVAL xaref()
X{
X LVAL array,index;
X int i;
X
X /* get the array and the index */
X array = xlgavector();
X index = xlgafixnum(); i = (int)getfixnum(index);
X xllastarg();
X
X /* range check the index */
X if (i < 0 || i >= getsize(array))
X xlerror("array index out of bounds",index);
X
X /* return the array element */
X return (getelement(array,i));
X}
X
X/* xmkarray - make a new array */
XLVAL xmkarray()
X{
X LVAL size;
X int n;
X
X /* get the size of the array */
X size = xlgafixnum() ; n = (int)getfixnum(size);
X xllastarg();
X
X /* create the array */
X return (newvector(n));
X}
X
X/* xvector - make a vector */
XLVAL xvector()
X{
X LVAL val;
X int i;
X
X /* make the vector */
X val = newvector(xlargc);
X
X /* store each argument */
X for (i = 0; moreargs(); ++i)
X setelement(val,i,nextarg());
X xllastarg();
X
X /* return the vector */
X return (val);
X}
X
X/* xerror - special form 'error' */
XLVAL xerror()
X{
X LVAL emsg,arg;
X
X /* get the error message and the argument */
X emsg = xlgastring();
X arg = (moreargs() ? xlgetarg() : s_unbound);
X xllastarg();
X
X /* signal the error */
X xlerror(getstring(emsg),arg);
X}
X
X/* xcerror - special form 'cerror' */
XLVAL xcerror()
X{
X LVAL cmsg,emsg,arg;
X
X /* get the correction message, the error message, and the argument */
X cmsg = xlgastring();
X emsg = xlgastring();
X arg = (moreargs() ? xlgetarg() : s_unbound);
X xllastarg();
X
X /* signal the error */
X xlcerror(getstring(cmsg),getstring(emsg),arg);
X
X /* return nil */
X return (NIL);
X}
X
X/* xbreak - special form 'break' */
XLVAL xbreak()
X{
X LVAL emsg,arg;
X
X /* get the error message */
X emsg = (moreargs() ? xlgastring() : NIL);
X arg = (moreargs() ? xlgetarg() : s_unbound);
X xllastarg();
X
X /* enter the break loop */
X xlbreak((emsg ? getstring(emsg) : (unsigned char *)"**BREAK**"),arg);
X
X /* return nil */
X return (NIL);
X}
X
X/* xcleanup - special form 'clean-up' */
XLVAL xcleanup()
X{
X xllastarg();
X xlcleanup();
X}
X
X/* xtoplevel - special form 'top-level' */
XLVAL xtoplevel()
X{
X xllastarg();
X xltoplevel();
X}
X
X/* xcontinue - special form 'continue' */
XLVAL xcontinue()
X{
X xllastarg();
X xlcontinue();
X}
X
X/* xevalhook - eval hook function */
XLVAL xevalhook()
X{
X LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
X
X /* protect some pointers */
X xlstkcheck(3);
X xlsave(oldenv);
X xlsave(oldfenv);
X xlsave(newenv);
X
X /* get the expression, the new hook functions and the environment */
X expr = xlgetarg();
X newehook = xlgetarg();
X newahook = xlgetarg();
X newenv = (moreargs() ? xlgalist() : NIL);
X xllastarg();
X
X /* bind *evalhook* and *applyhook* to the hook functions */
X olddenv = xldenv;
X xldbind(s_evalhook,newehook);
X xldbind(s_applyhook,newahook);
X
X /* establish the environment for the hook function */
X if (newenv) {
X oldenv = xlenv;
X oldfenv = xlfenv;
X xlenv = car(newenv);
X xlfenv = cdr(newenv);
X }
X
X /* evaluate the expression (bypassing *evalhook*) */
X val = xlxeval(expr);
X
X /* restore the old environment */
X xlunbind(olddenv);
X if (newenv) {
X xlenv = oldenv;
X xlfenv = oldfenv;
X }
X
X /* restore the stack */
X xlpopn(3);
X
X /* return the result */
X return (val);
X}
X
SHAR_EOF
if test 12891 -ne "`wc -c 'xlbfun.c'`"
then
echo shar: error transmitting "'xlbfun.c'" '(should have been 12891 characters)'
fi
echo shar: extracting "'xlcont.c'" '(28157 characters)'
if test -f 'xlcont.c'
then
echo shar: over-writing existing file "'xlcont.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlcont.c'
X/* xlcont - xlisp special forms */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,xlvalue;
Xextern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
Xextern LVAL s_svalue,s_sfunction,s_splist;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_comma,s_comat;
Xextern LVAL s_unbound;
Xextern LVAL true;
X
X/* external routines */
Xextern LVAL makearglist();
X
X/* forward declarations */
XFORWARD LVAL bquote1();
XFORWARD LVAL let();
XFORWARD LVAL flet();
XFORWARD LVAL prog();
XFORWARD LVAL progx();
XFORWARD LVAL doloop();
XFORWARD LVAL evarg();
XFORWARD LVAL match();
XFORWARD LVAL evmatch();
X
X/* dummy node type for a list */
X#define LIST -1
X
X/* xquote - special form 'quote' */
XLVAL xquote()
X{
X LVAL val;
X val = xlgetarg();
X xllastarg();
X return (val);
X}
X
X/* xfunction - special form 'function' */
XLVAL xfunction()
X{
X LVAL val;
X
X /* get the argument */
X val = xlgetarg();
X xllastarg();
X
X /* create a closure for lambda expressions */
X if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
X val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);
X
X /* otherwise, get the value of a symbol */
X else if (symbolp(val))
X val = xlgetfunction(val);
X
X /* otherwise, its an error */
X else
X xlerror("not a function",val);
X
X /* return the function */
X return (val);
X}
X
X/* xbquote - back quote special form */
XLVAL xbquote()
X{
X LVAL expr;
X
X /* get the expression */
X expr = xlgetarg();
X xllastarg();
X
X /* fill in the template */
X return (bquote1(expr));
X}
X
X/* bquote1 - back quote helper function */
XLOCAL LVAL bquote1(expr)
X LVAL expr;
X{
X LVAL val,list,last,new;
X
X /* handle atoms */
X if (atom(expr))
X val = expr;
X
X /* handle (comma <expr>) */
X else if (car(expr) == s_comma) {
X if (atom(cdr(expr)))
X xlfail("bad comma expression");
X val = xleval(car(cdr(expr)));
X }
X
X /* handle ((comma-at <expr>) ... ) */
X else if (consp(car(expr)) && car(car(expr)) == s_comat) {
X xlstkcheck(2);
X xlsave(list);
X xlsave(val);
X if (atom(cdr(car(expr))))
X xlfail("bad comma-at expression");
X list = xleval(car(cdr(car(expr))));
X for (last = NIL; consp(list); list = cdr(list)) {
X new = consa(car(list));
X if (last)
X rplacd(last,new);
X else
X val = new;
X last = new;
X }
X if (last)
X rplacd(last,bquote1(cdr(expr)));
X else
X val = bquote1(cdr(expr));
X xlpopn(2);
X }
X
X /* handle any other list */
X else {
X xlsave1(val);
X val = consa(NIL);
X rplaca(val,bquote1(car(expr)));
X rplacd(val,bquote1(cdr(expr)));
X xlpop();
X }
X
X /* return the result */
X return (val);
X}
X
X/* xlambda - special form 'lambda' */
XLVAL xlambda()
X{
X LVAL fargs,arglist,val;
X
X /* get the formal argument list and function body */
X xlsave1(arglist);
X fargs = xlgalist();
X arglist = makearglist(xlargc,xlargv);
X
X /* create a new function definition */
X val = xlclose(NIL,s_lambda,fargs,arglist,xlenv,xlfenv);
X
X /* restore the stack and return the closure */
X xlpop();
X return (val);
X}
X
X/* xgetlambda - get the lambda expression associated with a closure */
XLVAL xgetlambda()
X{
X LVAL closure;
X closure = xlgaclosure();
X return (cons(gettype(closure),
X cons(getlambda(closure),getbody(closure))));
X}
X
X/* xsetq - special form 'setq' */
XLVAL xsetq()
X{
X LVAL sym,val;
X
X /* handle each pair of arguments */
X for (val = NIL; moreargs(); ) {
X sym = xlgasymbol();
X val = xleval(nextarg());
X xlsetvalue(sym,val);
X }
X
X /* return the result value */
X return (val);
X}
X
X/* xpsetq - special form 'psetq' */
XLVAL xpsetq()
X{
X LVAL plist,sym,val;
X
X /* protect some pointers */
X xlsave1(plist);
X
X /* handle each pair of arguments */
X for (val = NIL; moreargs(); ) {
X sym = xlgasymbol();
X val = xleval(nextarg());
X plist = cons(cons(sym,val),plist);
X }
X
X /* do parallel sets */
X for (; plist; plist = cdr(plist))
X xlsetvalue(car(car(plist)),cdr(car(plist)));
X
X /* restore the stack */
X xlpop();
X
X /* return the result value */
X return (val);
X}
X
X/* xsetf - special form 'setf' */
XLVAL xsetf()
X{
X LVAL place,value;
X
X /* protect some pointers */
X xlsave1(value);
X
X /* handle each pair of arguments */
X while (moreargs()) {
X
X /* get place and value */
X place = xlgetarg();
X value = xleval(nextarg());
X
X /* expand macros in the place form */
X if (consp(place))
X place = xlexpandmacros(place);
X
X /* check the place form */
X if (symbolp(place))
X xlsetvalue(place,value);
X else if (consp(place))
X placeform(place,value);
X else
X xlfail("bad place form");
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the value */
X return (value);
X}
X
X/* placeform - handle a place form other than a symbol */
XLOCAL placeform(place,value)
X LVAL place,value;
X{
X LVAL fun,arg1,arg2;
X int i;
X
X /* check the function name */
X if ((fun = match(SYMBOL,&place)) == s_get) {
X xlstkcheck(2);
X xlsave(arg1);
X xlsave(arg2);
X arg1 = evmatch(SYMBOL,&place);
X arg2 = evmatch(SYMBOL,&place);
X if (place) toomany(place);
X xlputprop(arg1,value,arg2);
X xlpopn(2);
X }
X else if (fun == s_svalue) {
X arg1 = evmatch(SYMBOL,&place);
X if (place) toomany(place);
X setvalue(arg1,value);
X }
X else if (fun == s_sfunction) {
X arg1 = evmatch(SYMBOL,&place);
X if (place) toomany(place);
X setfunction(arg1,value);
X }
X else if (fun == s_splist) {
X arg1 = evmatch(SYMBOL,&place);
X if (place) toomany(place);
X setplist(arg1,value);
X }
X else if (fun == s_car) {
X arg1 = evmatch(CONS,&place);
X if (place) toomany(place);
X rplaca(arg1,value);
X }
X else if (fun == s_cdr) {
X arg1 = evmatch(CONS,&place);
X if (place) toomany(place);
X rplacd(arg1,value);
X }
X else if (fun == s_nth) {
X xlsave1(arg1);
X arg1 = evmatch(FIXNUM,&place);
X arg2 = evmatch(LIST,&place);
X if (place) toomany(place);
X for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
X arg2 = cdr(arg2);
X if (consp(arg2))
X rplaca(arg2,value);
X xlpop();
X }
X else if (fun == s_aref) {
X xlsave1(arg1);
X arg1 = evmatch(VECTOR,&place);
X arg2 = evmatch(FIXNUM,&place); i = (int)getfixnum(arg2);
X if (place) toomany(place);
X if (i < 0 || i >= getsize(arg1))
X xlerror("index out of range",arg2);
X setelement(arg1,i,value);
X xlpop();
X }
X else if (fun = xlgetprop(fun,s_setf))
X setffunction(fun,place,value);
X else
X xlfail("bad place form");
X}
X
X/* setffunction - call a user defined setf function */
XLOCAL setffunction(fun,place,value)
X LVAL fun,place,value;
X{
X LVAL *newfp;
X int argc;
X
X /* create the new call frame */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(fun);
X pusharg(NIL);
X
X /* push the values of all of the place expressions and the new value */
X for (argc = 1; consp(place); place = cdr(place), ++argc)
X pusharg(xleval(car(place)));
X pusharg(value);
X
X /* insert the argument count and establish the call frame */
X newfp[2] = cvfixnum((FIXTYPE)argc);
X xlfp = newfp;
X
X /* apply the function */
X xlapply(argc);
X}
X
X/* xdefun - special form 'defun' */
XLVAL xdefun()
X{
X LVAL sym,fargs,arglist;
X
X /* get the function symbol and formal argument list */
X xlsave1(arglist);
X sym = xlgasymbol();
X fargs = xlgalist();
X arglist = makearglist(xlargc,xlargv);
X
X /* make the symbol point to a new function definition */
X xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));
X
X /* restore the stack and return the function symbol */
X xlpop();
X return (sym);
X}
X
X/* xdefmacro - special form 'defmacro' */
XLVAL xdefmacro()
X{
X LVAL sym,fargs,arglist;
X
X /* get the function symbol and formal argument list */
X xlsave1(arglist);
X sym = xlgasymbol();
X fargs = xlgalist();
X arglist = makearglist(xlargc,xlargv);
X
X /* make the symbol point to a new function definition */
X xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));
X
X /* restore the stack and return the function symbol */
X xlpop();
X return (sym);
X}
X
X/* xcond - special form 'cond' */
XLVAL xcond()
X{
X LVAL list,val;
X
X /* find a predicate that is true */
X for (val = NIL; moreargs(); ) {
X
X /* get the next conditional */
X list = nextarg();
X
X /* evaluate the predicate part */
X if (consp(list) && (val = xleval(car(list)))) {
X
X /* evaluate each expression */
X for (list = cdr(list); consp(list); list = cdr(list))
X val = xleval(car(list));
X
X /* exit the loop */
X break;
X }
X }
X
X /* return the value */
X return (val);
X}
X
X/* xwhen - special form 'when' */
XLVAL xwhen()
X{
X LVAL val;
X
X /* check the test expression */
X if (val = xleval(xlgetarg()))
X while (moreargs())
X val = xleval(nextarg());
X
X /* return the value */
X return (val);
X}
X
X/* xunless - special form 'unless' */
XLVAL xunless()
X{
X LVAL val=NIL;
X
X /* check the test expression */
X if (xleval(xlgetarg()) == NIL)
X while (moreargs())
X val = xleval(nextarg());
X
X /* return the value */
X return (val);
X}
X
X/* xcase - special form 'case' */
XLVAL xcase()
X{
X LVAL key,list,cases,val;
X
X /* protect some pointers */
X xlsave1(key);
X
X /* get the key expression */
X key = xleval(nextarg());
X
X /* find a case that matches */
X for (val = NIL; moreargs(); ) {
X
X /* get the next case clause */
X list = nextarg();
X
X /* make sure this is a valid clause */
X if (consp(list)) {
X
X /* compare the key list against the key */
X if ((cases = car(list)) == true ||
X (listp(cases) && keypresent(key,cases)) ||
X eql(key,cases)) {
X
X /* evaluate each expression */
X for (list = cdr(list); consp(list); list = cdr(list))
X val = xleval(car(list));
X
X /* exit the loop */
X break;
X }
X }
X else
X xlerror("bad case clause",list);
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the value */
X return (val);
X}
X
X/* keypresent - check for the presence of a key in a list */
XLOCAL int keypresent(key,list)
X LVAL key,list;
X{
X for (; consp(list); list = cdr(list))
X if (eql(car(list),key))
X return (TRUE);
X return (FALSE);
X}
X
X/* xand - special form 'and' */
XLVAL xand()
X{
X LVAL val;
X
X /* evaluate each argument */
X for (val = true; moreargs(); )
X if ((val = xleval(nextarg())) == NIL)
X break;
X
X /* return the result value */
X return (val);
X}
X
X/* xor - special form 'or' */
XLVAL xor()
X{
X LVAL val;
X
X /* evaluate each argument */
X for (val = NIL; moreargs(); )
X if ((val = xleval(nextarg())))
X break;
X
X /* return the result value */
X return (val);
X}
X
X/* xif - special form 'if' */
XLVAL xif()
X{
X LVAL testexpr,thenexpr,elseexpr;
X
X /* get the test expression, then clause and else clause */
X testexpr = xlgetarg();
X thenexpr = xlgetarg();
X elseexpr = (moreargs() ? xlgetarg() : NIL);
X xllastarg();
X
X /* evaluate the appropriate clause */
X return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
X}
X
X/* xlet - special form 'let' */
XLVAL xlet()
X{
X return (let(TRUE));
X}
X
X/* xletstar - special form 'let*' */
XLVAL xletstar()
X{
X return (let(FALSE));
X}
X
X/* let - common let routine */
XLOCAL LVAL let(pflag)
X int pflag;
X{
X LVAL newenv,val;
X
X /* protect some pointers */
X xlsave1(newenv);
X
X /* create a new environment frame */
X newenv = xlframe(xlenv);
X
X /* get the list of bindings and bind the symbols */
X if (!pflag) xlenv = newenv;
X dobindings(xlgalist(),newenv);
X if (pflag) xlenv = newenv;
X
X /* execute the code */
X for (val = NIL; moreargs(); )
X val = xleval(nextarg());
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* xflet - built-in function 'flet' */
XLVAL xflet()
X{
X return (flet(s_lambda,TRUE));
X}
X
X/* xlabels - built-in function 'labels' */
XLVAL xlabels()
X{
X return (flet(s_lambda,FALSE));
X}
X
X/* xmacrolet - built-in function 'macrolet' */
XLVAL xmacrolet()
X{
X return (flet(s_macro,TRUE));
X}
X
X/* flet - common flet/labels/macrolet routine */
XLOCAL LVAL flet(type,letflag)
X LVAL type; int letflag;
X{
X LVAL list,bnd,sym,fargs,val;
X
X /* create a new environment frame */
X xlfenv = xlframe(xlfenv);
X
X /* bind each symbol in the list of bindings */
X for (list = xlgalist(); consp(list); list = cdr(list)) {
X
X /* get the next binding */
X bnd = car(list);
X
X /* get the symbol and the function definition */
X sym = match(SYMBOL,&bnd);
X fargs = match(LIST,&bnd);
X val = xlclose(sym,type,fargs,bnd,xlenv,(letflag?cdr(xlfenv):xlfenv));
X
X /* bind the value to the symbol */
X xlfbind(sym,val);
X }
X
X /* execute the code */
X for (val = NIL; moreargs(); )
X val = xleval(nextarg());
X
X /* unbind the arguments */
X xlfenv = cdr(xlfenv);
X
X /* return the result */
X return (val);
X}
X
X/* xprog - special form 'prog' */
XLVAL xprog()
X{
X return (prog(TRUE));
X}
X
X/* xprogstar - special form 'prog*' */
XLVAL xprogstar()
X{
X return (prog(FALSE));
X}
X
X/* prog - common prog routine */
XLOCAL LVAL prog(pflag)
X int pflag;
X{
X LVAL newenv,val;
X CONTEXT cntxt;
X
X /* protect some pointers */
X xlsave1(newenv);
X
X /* create a new environment frame */
X newenv = xlframe(xlenv);
X
X /* establish a new execution context */
X xlbegin(&cntxt,CF_RETURN,NIL);
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X else {
X
X /* get the list of bindings and bind the symbols */
X if (!pflag) xlenv = newenv;
X dobindings(xlgalist(),newenv);
X if (pflag) xlenv = newenv;
X
X /* execute the code */
X tagbody();
X val = NIL;
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X }
X xlend(&cntxt);
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* xgo - special form 'go' */
XLVAL xgo()
X{
X LVAL label;
X
X /* get the target label */
X label = xlgetarg();
X xllastarg();
X
X /* transfer to the label */
X xlgo(label);
X}
X
X/* xreturn - special form 'return' */
XLVAL xreturn()
X{
X LVAL val;
X
X /* get the return value */
X val = (moreargs() ? xleval(nextarg()) : NIL);
X xllastarg();
X
X /* return from the inner most block */
X xlreturn(NIL,val);
X}
X
X/* xrtnfrom - special form 'return-from' */
XLVAL xrtnfrom()
X{
X LVAL name,val;
X
X /* get the return value */
X name = xlgasymbol();
X val = (moreargs() ? xleval(nextarg()) : NIL);
X xllastarg();
X
X /* return from the inner most block */
X xlreturn(name,val);
X}
X
X/* xprog1 - special form 'prog1' */
XLVAL xprog1()
X{
X return (progx(1));
X}
X
X/* xprog2 - special form 'prog2' */
XLVAL xprog2()
X{
X return (progx(2));
X}
X
X/* progx - common progx code */
XLOCAL LVAL progx(n)
X int n;
X{
X LVAL val;
X
X /* protect some pointers */
X xlsave1(val);
X
X /* evaluate the first n expressions */
X while (moreargs() && --n >= 0)
X val = xleval(nextarg());
X
X /* evaluate each remaining argument */
X while (moreargs())
X xleval(nextarg());
X
X /* restore the stack */
X xlpop();
X
X /* return the last test expression value */
X return (val);
X}
X
X/* xprogn - special form 'progn' */
XLVAL xprogn()
X{
X LVAL val;
X
X /* evaluate each expression */
X for (val = NIL; moreargs(); )
X val = xleval(nextarg());
X
X /* return the last test expression value */
X return (val);
X}
X
X/* xprogv - special form 'progv' */
XLVAL xprogv()
X{
X LVAL olddenv,vars,vals,val;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(vars);
X xlsave(vals);
X
X /* get the list of variables and the list of values */
X vars = xlgalist(); vars = xleval(vars);
X vals = xlgalist(); vals = xleval(vals);
X
X /* bind the values to the variables */
X for (olddenv = xldenv; consp(vars); vars = cdr(vars)) {
X if (!symbolp(car(vars)))
X xlerror("expecting a symbol",car(vars));
X if (consp(vals)) {
X xldbind(car(vars),car(vals));
X vals = cdr(vals);
X }
X else
X xldbind(car(vars),s_unbound);
X }
X
X /* evaluate each expression */
X for (val = NIL; moreargs(); )
X val = xleval(nextarg());
X
X /* restore the previous environment and the stack */
X xlunbind(olddenv);
X xlpopn(2);
X
X /* return the last test expression value */
X return (val);
X}
X
X/* xloop - special form 'loop' */
XLVAL xloop()
X{
X LVAL *argv,arg,val;
X CONTEXT cntxt;
X int argc;
X
X /* protect some pointers */
X xlsave1(arg);
X
X /* establish a new execution context */
X xlbegin(&cntxt,CF_RETURN,NIL);
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X else
X for (argv = xlargv, argc = xlargc; ; xlargv = argv, xlargc = argc)
X while (moreargs()) {
X arg = nextarg();
X if (consp(arg))
X xleval(arg);
X }
X xlend(&cntxt);
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* xdo - special form 'do' */
XLVAL xdo()
X{
X return (doloop(TRUE));
X}
X
X/* xdostar - special form 'do*' */
XLVAL xdostar()
X{
X return (doloop(FALSE));
X}
X
X/* doloop - common do routine */
XLOCAL LVAL doloop(pflag)
X int pflag;
X{
X LVAL newenv,*argv,blist,clist,test,val;
X CONTEXT cntxt;
X int argc;
X
X /* protect some pointers */
X xlsave1(newenv);
X
X /* get the list of bindings, the exit test and the result forms */
X blist = xlgalist();
X clist = xlgalist();
X test = (consp(clist) ? car(clist) : NIL);
X argv = xlargv;
X argc = xlargc;
X
X /* create a new environment frame */
X newenv = xlframe(xlenv);
X
X /* establish a new execution context */
X xlbegin(&cntxt,CF_RETURN,NIL);
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X else {
X
X /* bind the symbols */
X if (!pflag) xlenv = newenv;
X dobindings(blist,newenv);
X if (pflag) xlenv = newenv;
X
X /* execute the loop as long as the test is false */
X for (val = NIL; xleval(test) == NIL; doupdates(blist,pflag)) {
X xlargv = argv;
X xlargc = argc;
X tagbody();
X }
X
X /* evaluate the result expression */
X if (consp(clist))
X for (clist = cdr(clist); consp(clist); clist = cdr(clist))
X val = xleval(car(clist));
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X }
X xlend(&cntxt);
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* xdolist - special form 'dolist' */
XLVAL xdolist()
X{
X LVAL list,*argv,clist,sym,val;
X CONTEXT cntxt;
X int argc;
X
X /* protect some pointers */
X xlsave1(list);
X
X /* get the control list (sym list result-expr) */
X clist = xlgalist();
X sym = match(SYMBOL,&clist);
X list = evmatch(LIST,&clist);
X argv = xlargv;
X argc = xlargc;
X
X /* initialize the local environment */
X xlenv = xlframe(xlenv);
X xlbind(sym,NIL);
X
X /* establish a new execution context */
X xlbegin(&cntxt,CF_RETURN,NIL);
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X else {
X
X /* loop through the list */
X for (val = NIL; consp(list); list = cdr(list)) {
X
X /* bind the symbol to the next list element */
X xlsetvalue(sym,car(list));
X
X /* execute the loop body */
X xlargv = argv;
X xlargc = argc;
X tagbody();
X }
X
X /* evaluate the result expression */
X xlsetvalue(sym,NIL);
X val = (consp(clist) ? xleval(car(clist)) : NIL);
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X }
X xlend(&cntxt);
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* xdotimes - special form 'dotimes' */
XLVAL xdotimes()
X{
X LVAL *argv,clist,sym,cnt,val;
X CONTEXT cntxt;
X int argc,n,i;
X
X /* get the control list (sym list result-expr) */
X clist = xlgalist();
X sym = match(SYMBOL,&clist);
X cnt = evmatch(FIXNUM,&clist); n = getfixnum(cnt);
X argv = xlargv;
X argc = xlargc;
X
X /* initialize the local environment */
X xlenv = xlframe(xlenv);
X xlbind(sym,NIL);
X
X /* establish a new execution context */
X xlbegin(&cntxt,CF_RETURN,NIL);
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X else {
X
X /* loop through for each value from zero to n-1 */
X for (val = NIL, i = 0; i < n; ++i) {
X
X /* bind the symbol to the next list element */
X xlsetvalue(sym,cvfixnum((FIXTYPE)i));
X
X /* execute the loop body */
X xlargv = argv;
X xlargc = argc;
X tagbody();
X }
X
X /* evaluate the result expression */
X xlsetvalue(sym,cnt);
X val = (consp(clist) ? xleval(car(clist)) : NIL);
X
X /* unbind the arguments */
X xlenv = cdr(xlenv);
X }
X xlend(&cntxt);
X
X /* return the result */
X return (val);
X}
X
X/* xblock - special form 'block' */
XLVAL xblock()
X{
X LVAL name,val;
X CONTEXT cntxt;
X
X /* get the block name */
X name = xlgetarg();
X if (name && !symbolp(name))
X xlbadtype(name);
X
X /* execute the block */
X xlbegin(&cntxt,CF_RETURN,name);
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X else
X for (val = NIL; moreargs(); )
X val = xleval(nextarg());
X xlend(&cntxt);
X
X /* return the value of the last expression */
X return (val);
X}
X
X/* xtagbody - special form 'tagbody' */
XLVAL xtagbody()
X{
X tagbody();
X return (NIL);
X}
X
X/* xcatch - special form 'catch' */
XLVAL xcatch()
X{
X CONTEXT cntxt;
X LVAL tag,val;
X
X /* protect some pointers */
X xlsave1(tag);
X
X /* get the tag */
X tag = xleval(nextarg());
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_THROW,tag);
X
X /* check for 'throw' */
X if (setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X
X /* otherwise, evaluate the remainder of the arguments */
X else {
X for (val = NIL; moreargs(); )
X val = xleval(nextarg());
X }
X xlend(&cntxt);
X
X /* restore the stack */
X xlpop();
X
X /* return the result */
X return (val);
X}
X
X/* xthrow - special form 'throw' */
XLVAL xthrow()
X{
X LVAL tag,val;
X
X /* get the tag and value */
X tag = xleval(nextarg());
X val = (moreargs() ? xleval(nextarg()) : NIL);
X xllastarg();
X
X /* throw the tag */
X xlthrow(tag,val);
X}
X
X/* xunwindprotect - special form 'unwind-protect' */
XLVAL xunwindprotect()
X{
X extern CONTEXT *xltarget;
X extern int xlmask;
X CONTEXT cntxt,*target;
X int mask,sts;
X LVAL val;
X
X /* protect some pointers */
X xlsave1(val);
X
X /* get the expression to protect */
X val = xlgetarg();
X
X /* evaluate the protected expression */
X xlbegin(&cntxt,CF_UNWIND,NIL);
X if (sts = setjmp(cntxt.c_jmpbuf)) {
X target = xltarget;
X mask = xlmask;
X val = xlvalue;
X }
X else
X val = xleval(val);
X xlend(&cntxt);
X
X /* evaluate the cleanup expressions */
X while (moreargs())
X xleval(nextarg());
X
X /* if unwinding, continue unwinding */
X if (sts)
X xljump(target,mask,val);
X
X /* restore the stack */
X xlpop();
X
X /* return the value of the protected expression */
X return (val);
X}
X
X/* xerrset - special form 'errset' */
XLVAL xerrset()
X{
X LVAL expr,flag,val;
X CONTEXT cntxt;
X
X /* get the expression and the print flag */
X expr = xlgetarg();
X flag = (moreargs() ? xlgetarg() : true);
X xllastarg();
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_ERROR,flag);
X
X /* check for error */
X if (setjmp(cntxt.c_jmpbuf))
X val = NIL;
X
X /* otherwise, evaluate the expression */
X else {
X expr = xleval(expr);
X val = consa(expr);
X }
X xlend(&cntxt);
X
X /* return the result */
X return (val);
X}
X
X/* xtrace - special form 'trace' */
XLVAL xtrace()
X{
X LVAL sym,fun,this;
X
X /* loop through all of the arguments */
X sym = xlenter("*TRACELIST*");
X while (moreargs()) {
X fun = xlgasymbol();
X
X /* check for the function name already being in the list */
X for (this = getvalue(sym); consp(this); this = cdr(this))
X if (car(this) == fun)
X break;
X
X /* add the function name to the list */
X if (null(this))
X setvalue(sym,cons(fun,getvalue(sym)));
X }
X return (getvalue(sym));
X}
X
X/* xuntrace - special form 'untrace' */
XLVAL xuntrace()
X{
X LVAL sym,fun,this,last;
X
X /* loop through all of the arguments */
X sym = xlenter("*TRACELIST*");
X while (moreargs()) {
X fun = xlgasymbol();
X
X /* remove the function name from the list */
X last = NIL;
X for (this = getvalue(sym); consp(this); this = cdr(this)) {
X if (car(this) == fun) {
X if (last)
X rplacd(last,cdr(this));
X else
X setvalue(sym,cdr(this));
X break;
X }
X last = this;
X }
X }
X return (getvalue(sym));
X}
X
X/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
XLOCAL dobindings(list,env)
X LVAL list,env;
X{
X LVAL bnd,sym,val;
X
X /* protect some pointers */
X xlsave1(val);
X
X /* bind each symbol in the list of bindings */
X for (; consp(list); list = cdr(list)) {
X
X /* get the next binding */
X bnd = car(list);
X
X /* handle a symbol */
X if (symbolp(bnd)) {
X sym = bnd;
X val = NIL;
X }
X
X /* handle a list of the form (symbol expr) */
X else if (consp(bnd)) {
X sym = match(SYMBOL,&bnd);
X val = evarg(&bnd);
X }
X else
X xlfail("bad binding");
X
X /* bind the value to the symbol */
X xlpbind(sym,val,env);
X }
X
X /* restore the stack */
X xlpop();
X}
X
X/* doupdates - handle updates for do/do* */
XLOCAL doupdates(list,pflag)
X LVAL list; int pflag;
X{
X LVAL plist,bnd,sym,val;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(plist);
X xlsave(val);
X
X /* bind each symbol in the list of bindings */
X for (; consp(list); list = cdr(list)) {
X
X /* get the next binding */
X bnd = car(list);
X
X /* handle a list of the form (symbol expr) */
X if (consp(bnd)) {
X sym = match(SYMBOL,&bnd);
X bnd = cdr(bnd);
X if (bnd) {
X val = evarg(&bnd);
X if (pflag)
X plist = cons(cons(sym,val),plist);
X else
X xlsetvalue(sym,val);
X }
X }
X }
X
X /* set the values for parallel updates */
X for (; plist; plist = cdr(plist))
X xlsetvalue(car(car(plist)),cdr(car(plist)));
X
X /* restore the stack */
X xlpopn(2);
X}
X
X/* tagbody - execute code within a block and tagbody */
XLOCAL tagbody()
X{
X LVAL *argv,arg;
X CONTEXT cntxt;
X int argc;
X
X /* establish an execution context */
X xlbegin(&cntxt,CF_GO,NIL);
X argc = xlargc;
X argv = xlargv;
X
X /* check for a 'go' */
X if (setjmp(cntxt.c_jmpbuf)) {
X cntxt.c_xlargc = argc;
X cntxt.c_xlargv = argv;
X }
X
X /* execute the body */
X while (moreargs()) {
X arg = nextarg();
X if (consp(arg))
X xleval(arg);
X }
X xlend(&cntxt);
X}
X
X/* match - get an argument and match its type */
XLOCAL LVAL match(type,pargs)
X int type; LVAL *pargs;
X{
X LVAL arg;
X
X /* make sure the argument exists */
X if (!consp(*pargs))
X toofew(*pargs);
X
X /* get the argument value */
X arg = car(*pargs);
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X
X /* check its type */
X if (type == LIST) {
X if (arg && ntype(arg) != CONS)
X xlerror("bad argument type",arg);
X }
X else {
X if (arg == NIL || ntype(arg) != type)
X xlerror("bad argument type",arg);
X }
X
X /* return the argument */
X return (arg);
X}
X
X/* evarg - get the next argument and evaluate it */
XLOCAL LVAL evarg(pargs)
X LVAL *pargs;
X{
X LVAL arg;
X
X /* protect some pointers */
X xlsave1(arg);
X
X /* make sure the argument exists */
X if (!consp(*pargs))
X toofew(*pargs);
X
X /* get the argument value */
X arg = car(*pargs);
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X
X /* evaluate the argument */
X arg = xleval(arg);
X
X /* restore the stack */
X xlpop();
X
X /* return the argument */
X return (arg);
X}
X
X/* evmatch - get an evaluated argument and match its type */
XLOCAL LVAL evmatch(type,pargs)
X int type; LVAL *pargs;
X{
X LVAL arg;
X
X /* protect some pointers */
X xlsave1(arg);
X
X /* make sure the argument exists */
X if (!consp(*pargs))
X toofew(*pargs);
X
X /* get the argument value */
X arg = car(*pargs);
X
X /* move the argument pointer ahead */
X *pargs = cdr(*pargs);
X
X /* evaluate the argument */
X arg = xleval(arg);
X
X /* check its type */
X if (type == LIST) {
X if (arg && ntype(arg) != CONS)
X xlerror("bad argument type",arg);
X }
X else {
X if (arg == NIL || ntype(arg) != type)
X xlerror("bad argument type",arg);
X }
X
X /* restore the stack */
X xlpop();
X
X /* return the argument */
X return (arg);
X}
X
X/* toofew - too few arguments */
XLOCAL toofew(args)
X LVAL args;
X{
X xlerror("too few arguments",args);
X}
X
X/* toomany - too many arguments */
XLOCAL toomany(args)
X LVAL args;
X{
X xlerror("too many arguments",args);
X}
X
SHAR_EOF
if test 28157 -ne "`wc -c 'xlcont.c'`"
then
echo shar: error transmitting "'xlcont.c'" '(should have been 28157 characters)'
fi
echo shar: extracting "'xldbug.c'" '(3992 characters)'
if test -f 'xldbug.c'
then
echo shar: over-writing existing file "'xldbug.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldbug.c'
X/* xldebug - xlisp debugging support */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern int xldebug;
Xextern int xlsample;
Xextern LVAL s_debugio,s_unbound;
Xextern LVAL s_tracenable,s_tlimit,s_breakenable;
Xextern LVAL true;
Xextern char buf[];
X
X/* external routines */
Xextern char *malloc();
X
X/* forward declarations */
XFORWARD LVAL stacktop();
X
X/* xlabort - xlisp serious error handler */
Xxlabort(emsg)
X char *emsg;
X{
X xlsignal(emsg,s_unbound);
X xlerrprint("error",NULL,emsg,s_unbound);
X xlbrklevel();
X}
X
X/* xlbreak - enter a break loop */
Xxlbreak(emsg,arg)
X char *emsg; LVAL arg;
X{
X breakloop("break","return from BREAK",emsg,arg,TRUE);
X}
X
X/* xlfail - xlisp error handler */
Xxlfail(emsg)
X char *emsg;
X{
X xlerror(emsg,s_unbound);
X}
X
X/* xlerror - handle a fatal error */
Xxlerror(emsg,arg)
X char *emsg; LVAL arg;
X{
X if (getvalue(s_breakenable) != NIL)
X breakloop("error",NULL,emsg,arg,FALSE);
X else {
X xlsignal(emsg,arg);
X xlerrprint("error",NULL,emsg,arg);
X xlbrklevel();
X }
X}
X
X/* xlcerror - handle a recoverable error */
Xxlcerror(cmsg,emsg,arg)
X char *cmsg,*emsg; LVAL arg;
X{
X if (getvalue(s_breakenable) != NIL)
X breakloop("error",cmsg,emsg,arg,TRUE);
X else {
X xlsignal(emsg,arg);
X xlerrprint("error",NULL,emsg,arg);
X xlbrklevel();
X }
X}
X
X/* xlerrprint - print an error message */
Xxlerrprint(hdr,cmsg,emsg,arg)
X char *hdr,*cmsg,*emsg; LVAL arg;
X{
X /* print the error message */
X sprintf(buf,"%s: %s",hdr,emsg);
X errputstr(buf);
X
X /* print the argument */
X if (arg != s_unbound) {
X errputstr(" - ");
X errprint(arg);
X }
X
X /* no argument, just end the line */
X else
X errputstr("\n");
X
X /* print the continuation message */
X if (cmsg) {
X sprintf(buf,"if continued: %s\n",cmsg);
X errputstr(buf);
X }
X}
X
X/* breakloop - the debug read-eval-print loop */
XLOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
X char *hdr,*cmsg,*emsg; LVAL arg; int cflag;
X{
X LVAL expr,val;
X CONTEXT cntxt;
X int type;
X
X /* print the error message */
X xlerrprint(hdr,cmsg,emsg,arg);
X
X /* flush the input buffer */
X xlflush();
X
X /* do the back trace */
X if (getvalue(s_tracenable)) {
X val = getvalue(s_tlimit);
X xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
X }
X
X /* protect some pointers */
X xlsave1(expr);
X
X /* increment the debug level */
X ++xldebug;
X
X /* debug command processing loop */
X xlbegin(&cntxt,CF_BRKLEVEL|CF_CLEANUP|CF_CONTINUE,true);
X for (type = 0; type == 0; ) {
X
X /* setup the continue trap */
X if (type = setjmp(cntxt.c_jmpbuf))
X switch (type) {
X case CF_CLEANUP:
X continue;
X case CF_BRKLEVEL:
X type = 0;
X break;
X case CF_CONTINUE:
X if (cflag) {
X dbgputstr("[ continue from break loop ]\n");
X continue;
X }
X else xlabort("this error can't be continued");
X }
X
X /* print a prompt */
X sprintf(buf,"%d> ",xldebug);
X dbgputstr(buf);
X
X /* read an expression and check for eof */
X if (!xlread(getvalue(s_debugio),&expr,FALSE)) {
X type = CF_CLEANUP;
X break;
X }
X
X /* save the input expression */
X xlrdsave(expr);
X
X /* evaluate the expression */
X expr = xleval(expr);
X
X /* save the result */
X xlevsave(expr);
X
X /* print it */
X dbgprint(expr);
X }
X xlend(&cntxt);
X
X /* decrement the debug level */
X --xldebug;
X
X /* restore the stack */
X xlpop();
X
X /* check for aborting to the previous level */
X if (type == CF_CLEANUP)
X xlbrklevel();
X}
X
X/* baktrace - do a back trace */
Xxlbaktrace(n)
X int n;
X{
X LVAL *fp,*p;
X int argc;
X for (fp = xlfp; (n < 0 || n--) && *fp; fp = fp - (int)getfixnum(*fp)) {
X p = fp + 1;
X errputstr("Function: ");
X errprint(*p++);
X if (argc = (int)getfixnum(*p++))
X errputstr("Arguments:\n");
X while (--argc >= 0) {
X errputstr(" ");
X errprint(*p++);
X }
X }
X}
X
X/* xldinit - debug initialization routine */
Xxldinit()
X{
X xlsample = 0;
X xldebug = 0;
X}
X
SHAR_EOF
if test 3992 -ne "`wc -c 'xldbug.c'`"
then
echo shar: error transmitting "'xldbug.c'" '(should have been 3992 characters)'
fi
echo shar: extracting "'xldmem.c'" '(14715 characters)'
if test -f 'xldmem.c'
then
echo shar: over-writing existing file "'xldmem.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldmem.c'
X/* xldmem - xlisp dynamic memory management routines */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* node flags */
X#define MARK 1
X#define LEFT 2
X
X/* macro to compute the size of a segment */
X#define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
X
X/* external variables */
Xextern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
Xextern LVAL xlenv,xlfenv,xldenv;
Xextern char buf[];
X
X/* variables local to xldmem.c and xlimage.c */
XSEGMENT *segs,*lastseg,*fixseg,*charseg;
Xint anodes,nsegs,gccalls;
Xlong nnodes,nfree,total;
XLVAL fnodes;
X
X/* external procedures */
Xextern char *malloc();
Xextern char *calloc();
X
X/* forward declarations */
XFORWARD LVAL newnode();
XFORWARD unsigned char *stralloc();
XFORWARD SEGMENT *newsegment();
X
X/* cons - construct a new cons node */
XLVAL cons(x,y)
X LVAL x,y;
X{
X LVAL nnode;
X
X /* get a free node */
X if ((nnode = fnodes) == NIL) {
X xlstkcheck(2);
X xlprotect(x);
X xlprotect(y);
X findmem();
X if ((nnode = fnodes) == NIL)
X xlabort("insufficient node space");
X xlpop();
X xlpop();
X }
X
X /* unlink the node from the free list */
X fnodes = cdr(nnode);
X --nfree;
X
X /* initialize the new node */
X nnode->n_type = CONS;
X rplaca(nnode,x);
X rplacd(nnode,y);
X
X /* return the new node */
X return (nnode);
X}
X
X/* cvstring - convert a string to a string node */
XLVAL cvstring(str)
X char *str;
X{
X LVAL val;
X xlsave1(val);
X val = newnode(STRING);
X val->n_strlen = strlen(str) + 1;
X val->n_string = stralloc(getslength(val));
X strcpy(getstring(val),str);
X xlpop();
X return (val);
X}
X
X/* newstring - allocate and initialize a new string */
XLVAL newstring(size)
X int size;
X{
X LVAL val;
X xlsave1(val);
X val = newnode(STRING);
X val->n_strlen = size;
X val->n_string = stralloc(getslength(val));
X strcpy(getstring(val),"");
X xlpop();
X return (val);
X}
X
X/* cvsymbol - convert a string to a symbol */
XLVAL cvsymbol(pname)
X char *pname;
X{
X LVAL val;
X xlsave1(val);
X val = newvector(SYMSIZE);
X val->n_type = SYMBOL;
X setvalue(val,s_unbound);
X setfunction(val,s_unbound);
X setpname(val,cvstring(pname));
X xlpop();
X return (val);
X}
X
X/* cvsubr - convert a function to a subr or fsubr */
XLVAL cvsubr(fcn,type,offset)
X LVAL (*fcn)(); int type,offset;
X{
X LVAL val;
X val = newnode(type);
X val->n_subr = fcn;
X val->n_offset = offset;
X return (val);
X}
X
X/* cvfile - convert a file pointer to a stream */
XLVAL cvfile(fp)
X FILE *fp;
X{
X LVAL val;
X val = newnode(STREAM);
X setfile(val,fp);
X setsavech(val,'\0');
X return (val);
X}
X
X/* cvfixnum - convert an integer to a fixnum node */
XLVAL cvfixnum(n)
X FIXTYPE n;
X{
X LVAL val;
X if (n >= SFIXMIN && n <= SFIXMAX)
X return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
X val = newnode(FIXNUM);
X val->n_fixnum = n;
X return (val);
X}
X
X/* cvflonum - convert a floating point number to a flonum node */
XLVAL cvflonum(n)
X FLOTYPE n;
X{
X LVAL val;
X val = newnode(FLONUM);
X val->n_flonum = n;
X return (val);
X}
X
X/* cvchar - convert an integer to a character node */
XLVAL cvchar(n)
X int n;
X{
X if (n >= CHARMIN && n <= CHARMAX)
X return (&charseg->sg_nodes[n-CHARMIN]);
X xlerror("character code out of range",cvfixnum((FIXTYPE)n));
X}
X
X/* newustream - create a new unnamed stream */
XLVAL newustream()
X{
X LVAL val;
X val = newnode(USTREAM);
X sethead(val,NIL);
X settail(val,NIL);
X return (val);
X}
X
X/* newobject - allocate and initialize a new object */
XLVAL newobject(cls,size)
X LVAL cls; int size;
X{
X LVAL val;
X val = newvector(size+1);
X val->n_type = OBJECT;
X setelement(val,0,cls);
X return (val);
X}
X
X/* newclosure - allocate and initialize a new closure */
XLVAL newclosure(name,type,env,fenv)
X LVAL name,type,env,fenv;
X{
X LVAL val;
X val = newvector(CLOSIZE);
X val->n_type = CLOSURE;
X setname(val,name);
X settype(val,type);
X setenv(val,env);
X setfenv(val,fenv);
X return (val);
X}
X
X/* newstruct - allocate and initialize a new structure node */
XLVAL newstruct(type,size)
X LVAL type; int size;
X{
X LVAL val;
X val = newvector(size+1);
X val->n_type = STRUCT;
X setelement(val,0,type);
X return (val);
X}
X
X/* newvector - allocate and initialize a new vector node */
XLVAL newvector(size)
X int size;
X{
X LVAL vect;
X int bsize;
X xlsave1(vect);
X vect = newnode(VECTOR);
X vect->n_vsize = 0;
X if (bsize = size * sizeof(LVAL)) {
X if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
X findmem();
X if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
X xlfail("insufficient vector space");
X }
X vect->n_vsize = size;
X total += (long) bsize;
X }
X xlpop();
X return (vect);
X}
X
X/* newnode - allocate a new node */
XLOCAL LVAL newnode(type)
X int type;
X{
X LVAL nnode;
X
X /* get a free node */
X if ((nnode = fnodes) == NIL) {
X findmem();
X if ((nnode = fnodes) == NIL)
X xlabort("insufficient node space");
X }
X
X /* unlink the node from the free list */
X fnodes = cdr(nnode);
X nfree -= 1L;
X
X /* initialize the new node */
X nnode->n_type = type;
X rplacd(nnode,NIL);
X
X /* return the new node */
X return (nnode);
X}
X
X/* stralloc - allocate memory for a string adding a byte for the terminator */
XLOCAL unsigned char *stralloc(size)
X int size;
X{
X unsigned char *sptr;
X
X /* allocate memory for the string copy */
X if ((sptr = (unsigned char *)malloc(size)) == NULL) {
X gc();
X if ((sptr = (unsigned char *)malloc(size)) == NULL)
X xlfail("insufficient string space");
X }
X total += (long)size;
X
X /* return the new string memory */
X return (sptr);
X}
X
X/* findmem - find more memory by collecting then expanding */
XLOCAL findmem()
X{
X gc();
X if (nfree < (long)anodes)
X addseg();
X}
X
X/* gc - garbage collect (only called here and in xlimage.c) */
Xgc()
X{
X register LVAL **p,*ap,tmp;
X char buf[STRMAX+1];
X LVAL *newfp,fun;
X
X /* print the start of the gc message */
X if (s_gcflag && getvalue(s_gcflag)) {
X sprintf(buf,"[ gc: total %ld, ",nnodes);
X stdputstr(buf);
X }
X
X /* mark the obarray, the argument list and the current environment */
X if (obarray)
X mark(obarray);
X if (xlenv)
X mark(xlenv);
X if (xlfenv)
X mark(xlfenv);
X if (xldenv)
X mark(xldenv);
X
X /* mark the evaluation stack */
X for (p = xlstack; p < xlstktop; ++p)
X if (tmp = **p)
X mark(tmp);
X
X /* mark the argument stack */
X for (ap = xlargstkbase; ap < xlsp; ++ap)
X if (tmp = *ap)
X mark(tmp);
X
X /* sweep memory collecting all unmarked nodes */
X sweep();
X
X /* count the gc call */
X ++gccalls;
X
X /* call the *gc-hook* if necessary */
X if (s_gchook && (fun = getvalue(s_gchook))) {
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(fun);
X pusharg(cvfixnum((FIXTYPE)2));
X pusharg(cvfixnum((FIXTYPE)nnodes));
X pusharg(cvfixnum((FIXTYPE)nfree));
X xlfp = newfp;
X xlapply(2);
X }
X
X /* print the end of the gc message */
X if (s_gcflag && getvalue(s_gcflag)) {
X sprintf(buf,"%ld free ]\n",nfree);
X stdputstr(buf);
X }
X}
X
X/* mark - mark all accessible nodes */
XLOCAL mark(ptr)
X LVAL ptr;
X{
X register LVAL this,prev,tmp;
X int type,i,n;
X
X /* initialize */
X prev = NIL;
X this = ptr;
X
X /* mark this list */
X for (;;) {
X
X /* descend as far as we can */
X while (!(this->n_flags & MARK))
X
X /* check cons and unnamed stream nodes */
X if ((type = ntype(this)) == CONS || type == USTREAM) {
X if (tmp = car(this)) {
X this->n_flags |= MARK|LEFT;
X rplaca(this,prev);
X }
X else if (tmp = cdr(this)) {
X this->n_flags |= MARK;
X rplacd(this,prev);
X }
X else { /* both sides nil */
X this->n_flags |= MARK;
X break;
X }
X prev = this; /* step down the branch */
X this = tmp;
X }
X
X /* mark other node types */
X else {
X this->n_flags |= MARK;
X switch (type) {
X case SYMBOL:
X case OBJECT:
X case VECTOR:
X case CLOSURE:
X case STRUCT:
X for (i = 0, n = getsize(this); --n >= 0; ++i)
X if (tmp = getelement(this,i))
X mark(tmp);
X break;
X }
X break;
X }
X
X /* backup to a point where we can continue descending */
X for (;;)
X
X /* make sure there is a previous node */
X if (prev) {
X if (prev->n_flags & LEFT) { /* came from left side */
X prev->n_flags &= ~LEFT;
X tmp = car(prev);
X rplaca(prev,this);
X if (this = cdr(prev)) {
X rplacd(prev,tmp);
X break;
X }
X }
X else { /* came from right side */
X tmp = cdr(prev);
X rplacd(prev,this);
X }
X this = prev; /* step back up the branch */
X prev = tmp;
X }
X
X /* no previous node, must be done */
X else
X return;
X }
X}
X
X/* sweep - sweep all unmarked nodes and add them to the free list */
XLOCAL sweep()
X{
X SEGMENT *seg;
X LVAL p;
X int n;
X
X /* empty the free list */
X fnodes = NIL;
X nfree = 0L;
X
X /* add all unmarked nodes */
X for (seg = segs; seg; seg = seg->sg_next) {
X if (seg == fixseg) /* don't sweep the fixnum segment */
X continue;
X else if (seg == charseg) /* don't sweep the character segment */
X continue;
X p = &seg->sg_nodes[0];
X for (n = seg->sg_size; --n >= 0; ++p)
X if (!(p->n_flags & MARK)) {
X switch (ntype(p)) {
X case STRING:
X if (getstring(p) != NULL) {
X total -= (long)getslength(p);
X free(getstring(p));
X }
X break;
X case STREAM:
X if (getfile(p))
X osclose(getfile(p));
X break;
X case SYMBOL:
X case OBJECT:
X case VECTOR:
X case CLOSURE:
X case STRUCT:
X if (p->n_vsize) {
X total -= (long) (p->n_vsize * sizeof(LVAL));
X free(p->n_vdata);
X }
X break;
X }
X p->n_type = FREE;
X rplaca(p,NIL);
X rplacd(p,fnodes);
X fnodes = p;
X nfree += 1L;
X }
X else
X p->n_flags &= ~MARK;
X }
X}
X
X/* addseg - add a segment to the available memory */
XLOCAL int addseg()
X{
X SEGMENT *newseg;
X LVAL p;
X int n;
X
X /* allocate the new segment */
X if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
X return (FALSE);
X
X /* add each new node to the free list */
X p = &newseg->sg_nodes[0];
X for (n = anodes; --n >= 0; ++p) {
X rplacd(p,fnodes);
X fnodes = p;
X }
X
X /* return successfully */
X return (TRUE);
X}
X
X/* newsegment - create a new segment (only called here and in xlimage.c) */
XSEGMENT *newsegment(n)
X int n;
X{
X SEGMENT *newseg;
X
X /* allocate the new segment */
X if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
X return (NULL);
X
X /* initialize the new segment */
X newseg->sg_size = n;
X newseg->sg_next = NULL;
X if (segs)
X lastseg->sg_next = newseg;
X else
X segs = newseg;
X lastseg = newseg;
X
X /* update the statistics */
X total += (long)segsize(n);
X nnodes += (long)n;
X nfree += (long)n;
X ++nsegs;
X
X /* return the new segment */
X return (newseg);
X}
X
X/* stats - print memory statistics */
XLOCAL stats()
X{
X sprintf(buf,"Nodes: %ld\n",nnodes); stdputstr(buf);
X sprintf(buf,"Free nodes: %ld\n",nfree); stdputstr(buf);
X sprintf(buf,"Segments: %d\n",nsegs); stdputstr(buf);
X sprintf(buf,"Allocate: %d\n",anodes); stdputstr(buf);
X sprintf(buf,"Total: %ld\n",total); stdputstr(buf);
X sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
X}
X
X/* xgc - xlisp function to force garbage collection */
XLVAL xgc()
X{
X /* make sure there aren't any arguments */
X xllastarg();
X
X /* garbage collect */
X gc();
X
X /* return nil */
X return (NIL);
X}
X
X/* xexpand - xlisp function to force memory expansion */
XLVAL xexpand()
X{
X LVAL num;
X int n,i;
X
X /* get the new number to allocate */
X if (moreargs()) {
X num = xlgafixnum();
X n = getfixnum(num);
X }
X else
X n = 1;
X xllastarg();
X
X /* allocate more segments */
X for (i = 0; i < n; i++)
X if (!addseg())
X break;
X
X /* return the number of segments added */
X return (cvfixnum((FIXTYPE)i));
X}
X
X/* xalloc - xlisp function to set the number of nodes to allocate */
XLVAL xalloc()
X{
X int n,oldn;
X LVAL num;
X
X /* get the new number to allocate */
X num = xlgafixnum();
X n = getfixnum(num);
X
X /* make sure there aren't any more arguments */
X xllastarg();
X
X /* set the new number of nodes to allocate */
X oldn = anodes;
X anodes = n;
X
X /* return the old number */
X return (cvfixnum((FIXTYPE)oldn));
X}
X
X/* xmem - xlisp function to print memory statistics */
XLVAL xmem()
X{
X /* allow one argument for compatiblity with common lisp */
X if (moreargs()) xlgetarg();
X xllastarg();
X
X /* print the statistics */
X stats();
X
X /* return nil */
X return (NIL);
X}
X
X#ifdef SAVERESTORE
X/* xsave - save the memory image */
XLVAL xsave()
X{
X unsigned char *name;
X
X /* get the file name, verbose flag and print flag */
X name = getstring(xlgetfname());
X xllastarg();
X
X /* save the memory image */
X return (xlisave(name) ? true : NIL);
X}
X
X/* xrestore - restore a saved memory image */
XLVAL xrestore()
X{
X extern jmp_buf top_level;
X unsigned char *name;
X
X /* get the file name, verbose flag and print flag */
X name = getstring(xlgetfname());
X xllastarg();
X
X /* restore the saved memory image */
X if (!xlirestore(name))
X return (NIL);
X
X /* return directly to the top level */
X stdputstr("[ returning to the top level ]\n");
X longjmp(top_level,1);
X}
X#endif
X
X/* xlminit - initialize the dynamic memory module */
Xxlminit()
X{
X LVAL p;
X int i;
X
X /* initialize our internal variables */
X segs = lastseg = NULL;
X nnodes = nfree = total = 0L;
X nsegs = gccalls = 0;
X anodes = NNODES;
X fnodes = NIL;
X
X /* allocate the fixnum segment */
X if ((fixseg = newsegment(SFIXSIZE)) == NULL)
X xlfatal("insufficient memory");
X
X /* initialize the fixnum segment */
X p = &fixseg->sg_nodes[0];
X for (i = SFIXMIN; i <= SFIXMAX; ++i) {
X p->n_type = FIXNUM;
X p->n_fixnum = i;
X ++p;
X }
X
X /* allocate the character segment */
X if ((charseg = newsegment(CHARSIZE)) == NULL)
X xlfatal("insufficient memory");
X
X /* initialize the character segment */
X p = &charseg->sg_nodes[0];
X for (i = CHARMIN; i <= CHARMAX; ++i) {
X p->n_type = CHAR;
X p->n_chcode = i;
X ++p;
X }
X
X /* initialize structures that are marked by the collector */
X obarray = xlenv = xlfenv = xldenv = NIL;
X s_gcflag = s_gchook = NIL;
X
X /* allocate the evaluation stack */
X if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
X xlfatal("insufficient memory");
X xlstack = xlstktop = xlstkbase + EDEPTH;
X
X /* allocate the argument stack */
X if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
X xlfatal("insufficient memory");
X xlargstktop = xlargstkbase + ADEPTH;
X xlfp = xlsp = xlargstkbase;
X *xlsp++ = NIL;
X}
X
SHAR_EOF
if test 14715 -ne "`wc -c 'xldmem.c'`"
then
echo shar: error transmitting "'xldmem.c'" '(should have been 14715 characters)'
fi
echo shar: extracting "'xldmem.h'" '(6120 characters)'
if test -f 'xldmem.h'
then
echo shar: over-writing existing file "'xldmem.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldmem.h'
X/* xldmem.h - dynamic memory definitions */
X/* Copyright (c) 1987, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X/* small fixnum range */
X#define SFIXMIN (-128)
X#define SFIXMAX 255
X#define SFIXSIZE 384
X
X/* character range */
X#define CHARMIN 0
X#define CHARMAX 255
X#define CHARSIZE 256
X
X/* new node access macros */
X#define ntype(x) ((x)->n_type)
X
X/* cons access macros */
X#define car(x) ((x)->n_car)
X#define cdr(x) ((x)->n_cdr)
X#define rplaca(x,y) ((x)->n_car = (y))
X#define rplacd(x,y) ((x)->n_cdr = (y))
X
X/* symbol access macros */
X#define getvalue(x) ((x)->n_vdata[0])
X#define setvalue(x,v) ((x)->n_vdata[0] = (v))
X#define getfunction(x) ((x)->n_vdata[1])
X#define setfunction(x,v) ((x)->n_vdata[1] = (v))
X#define getplist(x) ((x)->n_vdata[2])
X#define setplist(x,v) ((x)->n_vdata[2] = (v))
X#define getpname(x) ((x)->n_vdata[3])
X#define setpname(x,v) ((x)->n_vdata[3] = (v))
X#define SYMSIZE 4
X
X/* closure access macros */
X#define getname(x) ((x)->n_vdata[0])
X#define setname(x,v) ((x)->n_vdata[0] = (v))
X#define gettype(x) ((x)->n_vdata[1])
X#define settype(x,v) ((x)->n_vdata[1] = (v))
X#define getargs(x) ((x)->n_vdata[2])
X#define setargs(x,v) ((x)->n_vdata[2] = (v))
X#define getoargs(x) ((x)->n_vdata[3])
X#define setoargs(x,v) ((x)->n_vdata[3] = (v))
X#define getrest(x) ((x)->n_vdata[4])
X#define setrest(x,v) ((x)->n_vdata[4] = (v))
X#define getkargs(x) ((x)->n_vdata[5])
X#define setkargs(x,v) ((x)->n_vdata[5] = (v))
X#define getaargs(x) ((x)->n_vdata[6])
X#define setaargs(x,v) ((x)->n_vdata[6] = (v))
X#define getbody(x) ((x)->n_vdata[7])
X#define setbody(x,v) ((x)->n_vdata[7] = (v))
X#define getenv(x) ((x)->n_vdata[8])
X#define setenv(x,v) ((x)->n_vdata[8] = (v))
X#define getfenv(x) ((x)->n_vdata[9])
X#define setfenv(x,v) ((x)->n_vdata[9] = (v))
X#define getlambda(x) ((x)->n_vdata[10])
X#define setlambda(x,v) ((x)->n_vdata[10] = (v))
X#define CLOSIZE 11
X
X/* vector access macros */
X#define getsize(x) ((x)->n_vsize)
X#define getelement(x,i) ((x)->n_vdata[i])
X#define setelement(x,i,v) ((x)->n_vdata[i] = (v))
X
X/* object access macros */
X#define getclass(x) ((x)->n_vdata[0])
X#define getivar(x,i) ((x)->n_vdata[i+1])
X#define setivar(x,i,v) ((x)->n_vdata[i+1] = (v))
X
X/* subr/fsubr access macros */
X#define getsubr(x) ((x)->n_subr)
X#define getoffset(x) ((x)->n_offset)
X
X/* fixnum/flonum/char access macros */
X#define getfixnum(x) ((x)->n_fixnum)
X#define getflonum(x) ((x)->n_flonum)
X#define getchcode(x) ((x)->n_chcode)
X
X/* string access macros */
X#define getstring(x) ((x)->n_string)
X#define getslength(x) ((x)->n_strlen)
X
X/* file stream access macros */
X#define getfile(x) ((x)->n_fp)
X#define setfile(x,v) ((x)->n_fp = (v))
X#define getsavech(x) ((x)->n_savech)
X#define setsavech(x,v) ((x)->n_savech = (v))
X
X/* unnamed stream access macros */
X#define gethead(x) ((x)->n_car)
X#define sethead(x,v) ((x)->n_car = (v))
X#define gettail(x) ((x)->n_cdr)
X#define settail(x,v) ((x)->n_cdr = (v))
X
X/* node types */
X#define FREE 0
X#define SUBR 1
X#define FSUBR 2
X#define CONS 3
X#define SYMBOL 4
X#define FIXNUM 5
X#define FLONUM 6
X#define STRING 7
X#define OBJECT 8
X#define STREAM 9
X#define VECTOR 10
X#define CLOSURE 11
X#define CHAR 12
X#define USTREAM 13
X#define STRUCT 14
X
X/* subr/fsubr node */
X#define n_subr n_info.n_xsubr.xs_subr
X#define n_offset n_info.n_xsubr.xs_offset
X
X/* cons node */
X#define n_car n_info.n_xcons.xc_car
X#define n_cdr n_info.n_xcons.xc_cdr
X
X/* fixnum node */
X#define n_fixnum n_info.n_xfixnum.xf_fixnum
X
X/* flonum node */
X#define n_flonum n_info.n_xflonum.xf_flonum
X/* character node */
X#define n_chcode n_info.n_xchar.xc_chcode
X
X/* string node */
X#define n_string n_info.n_xstring.xs_string
X#define n_strlen n_info.n_xstring.xs_length
X
X/* stream node */
X#define n_fp n_info.n_xstream.xs_fp
X#define n_savech n_info.n_xstream.xs_savech
X
X/* vector/object node */
X#define n_vsize n_info.n_xvector.xv_size
X#define n_vdata n_info.n_xvector.xv_data
X
X/* node structure */
Xtypedef struct node {
X char n_type; /* type of node */
X char n_flags; /* flag bits */
X union ninfo { /* value */
X struct xsubr { /* subr/fsubr node */
X struct node *(*xs_subr)(); /* function pointer */
X int xs_offset; /* offset into funtab */
X } n_xsubr;
X struct xcons { /* cons node */
X struct node *xc_car; /* the car pointer */
X struct node *xc_cdr; /* the cdr pointer */
X } n_xcons;
X struct xfixnum { /* fixnum node */
X FIXTYPE xf_fixnum; /* fixnum value */
X } n_xfixnum;
X struct xflonum { /* flonum node */
X FLOTYPE xf_flonum; /* flonum value */
X } n_xflonum;
X struct xchar { /* character node */
X int xc_chcode; /* character code */
X } n_xchar;
X struct xstring { /* string node */
X int xs_length; /* string length */
X unsigned char *xs_string; /* string pointer */
X } n_xstring;
X struct xstream { /* stream node */
X FILE *xs_fp; /* the file pointer */
X int xs_savech; /* lookahead character */
X } n_xstream;
X struct xvector { /* vector/object/symbol/structure node */
X int xv_size; /* vector size */
X struct node **xv_data; /* vector data */
X } n_xvector;
X } n_info;
X} *LVAL;
X
X/* memory segment structure definition */
Xtypedef struct segment {
X int sg_size;
X struct segment *sg_next;
X struct node sg_nodes[1];
X} SEGMENT;
X
X/* memory allocation functions */
Xextern LVAL cons(); /* (cons x y) */
Xextern LVAL cvsymbol(); /* convert a string to a symbol */
Xextern LVAL cvstring(); /* convert a string */
Xextern LVAL cvfile(); /* convert a FILE * to a file */
Xextern LVAL cvsubr(); /* convert a function to a subr/fsubr */
Xextern LVAL cvfixnum(); /* convert a fixnum */
Xextern LVAL cvflonum(); /* convert a flonum */
Xextern LVAL cvchar(); /* convert a character */
X
Xextern LVAL newstring(); /* create a new string */
Xextern LVAL newvector(); /* create a new vector */
Xextern LVAL newobject(); /* create a new object */
Xextern LVAL newclosure(); /* create a new closure */
Xextern LVAL newustream(); /* create a new unnamed stream */
Xextern LVAL newstruct(); /* create a new structure */
X
SHAR_EOF
if test 6120 -ne "`wc -c 'xldmem.h'`"
then
echo shar: error transmitting "'xldmem.h'" '(should have been 6120 characters)'
fi
echo shar: extracting "'xleval.c'" '(19240 characters)'
if test -f 'xleval.c'
then
echo shar: over-writing existing file "'xleval.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xleval.c'
X/* xleval - xlisp evaluator */
X/* Copyright (c) 1985, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xlisp.h"
X
X/* macro to check for lambda list keywords */
X#define iskey(s) ((s) == lk_optional \
X || (s) == lk_rest \
X || (s) == lk_key \
X || (s) == lk_aux \
X || (s) == lk_allow_other_keys)
X
X/* macros to handle tracing */
X#define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
X#define trexit(sym,val) {if (sym) doexit(sym,val);}
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
Xextern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
Xextern LVAL s_evalhook,s_applyhook,s_tracelist;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_unbound;
Xextern int xlsample;
Xextern char buf[];
X
X/* forward declarations */
XFORWARD LVAL xlxeval();
XFORWARD LVAL evalhook();
XFORWARD LVAL evform();
XFORWARD LVAL evfun();
X
X/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
XLVAL xleval(expr)
X LVAL expr;
X{
X /* check for control codes */
X if (--xlsample <= 0) {
X xlsample = SAMPLE;
X oscheck();
X }
X
X /* check for *evalhook* */
X if (getvalue(s_evalhook))
X return (evalhook(expr));
X
X /* check for nil */
X if (null(expr))
X return (NIL);
X
X /* dispatch on the node type */
X switch (ntype(expr)) {
X case CONS:
X return (evform(expr));
X case SYMBOL:
X return (xlgetvalue(expr));
X default:
X return (expr);
X }
X}
X
X/* xlevalenv - evaluate an expression in a specified environment */
XLVAL xlevalenv(expr,env,fenv)
X LVAL expr,env,fenv;
X{
X LVAL oldenv,oldfenv,val;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(oldenv);
X xlsave(oldfenv);
X
X /* establish the new environment */
X oldenv = xlenv;
X oldfenv = xlfenv;
X xlenv = env;
X xlfenv = fenv;
X
X /* evaluate the expression */
X val = xleval(expr);
X
X /* restore the environment */
X xlenv = oldenv;
X xlfenv = oldfenv;
X
X /* restore the stack */
X xlpopn(2);
X
X /* return the result value */
X return (val);
X}
X
X/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
XLVAL xlxeval(expr)
X LVAL expr;
X{
X /* check for nil */
X if (null(expr))
X return (NIL);
X
X /* dispatch on node type */
X switch (ntype(expr)) {
X case CONS:
X return (evform(expr));
X case SYMBOL:
X return (xlgetvalue(expr));
X default:
X return (expr);
X }
X}
X
X/* xlapply - apply a function to arguments (already on the stack) */
XLVAL xlapply(argc)
X int argc;
X{
X LVAL *oldargv,fun,val;
X int oldargc;
X
X /* get the function */
X fun = xlfp[1];
X
X /* get the functional value of symbols */
X if (symbolp(fun)) {
X while ((val = getfunction(fun)) == s_unbound)
X xlfunbound(fun);
X fun = xlfp[1] = val;
X }
X
X /* check for nil */
X if (null(fun))
X xlerror("bad function",fun);
X
X /* dispatch on node type */
X switch (ntype(fun)) {
X case SUBR:
X oldargc = xlargc;
X oldargv = xlargv;
X xlargc = argc;
X xlargv = xlfp + 3;
X val = (*getsubr(fun))();
X xlargc = oldargc;
X xlargv = oldargv;
X break;
X case CONS:
X if (!consp(cdr(fun)))
X xlerror("bad function",fun);
X if (car(fun) == s_lambda)
X fun = xlclose(NIL,
X s_lambda,
X car(cdr(fun)),
X cdr(cdr(fun)),
X xlenv,xlfenv);
X else
X xlerror("bad function",fun);
X /**** fall through into the next case ****/
X case CLOSURE:
X if (gettype(fun) != s_lambda)
X xlerror("bad function",fun);
X val = evfun(fun,argc,xlfp+3);
X break;
X default:
X xlerror("bad function",fun);
X }
X
X /* remove the call frame */
X xlsp = xlfp;
X xlfp = xlfp - (int)getfixnum(*xlfp);
X
X /* return the function value */
X return (val);
X}
X
X/* evform - evaluate a form */
XLOCAL LVAL evform(form)
X LVAL form;
X{
X LVAL fun,args,val,type;
X LVAL tracing=NIL;
X LVAL *argv;
X int argc;
X
X /* protect some pointers */
X xlstkcheck(2);
X xlsave(fun);
X xlsave(args);
X
X /* get the function and the argument list */
X fun = car(form);
X args = cdr(form);
X
X /* get the functional value of symbols */
X if (symbolp(fun)) {
X if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
X tracing = fun;
X fun = xlgetfunction(fun);
X }
X
X /* check for nil */
X if (null(fun))
X xlerror("bad function",NIL);
X
X /* dispatch on node type */
X switch (ntype(fun)) {
X case SUBR:
X argv = xlargv;
X argc = xlargc;
X xlargc = evpushargs(fun,args);
X xlargv = xlfp + 3;
X trenter(tracing,xlargc,xlargv);
X val = (*getsubr(fun))();
X trexit(tracing,val);
X xlsp = xlfp;
X xlfp = xlfp - (int)getfixnum(*xlfp);
X xlargv = argv;
X xlargc = argc;
X break;
X case FSUBR:
X argv = xlargv;
X argc = xlargc;
X xlargc = pushargs(fun,args);
X xlargv = xlfp + 3;
X val = (*getsubr(fun))();
X xlsp = xlfp;
X xlfp = xlfp - (int)getfixnum(*xlfp);
X xlargv = argv;
X xlargc = argc;
X break;
X case CONS:
X if (!consp(cdr(fun)))
X xlerror("bad function",fun);
X if ((type = car(fun)) == s_lambda)
X fun = xlclose(NIL,
X s_lambda,
X car(cdr(fun)),
X cdr(cdr(fun)),
X xlenv,xlfenv);
X else
X xlerror("bad function",fun);
X /**** fall through into the next case ****/
X case CLOSURE:
X if (gettype(fun) == s_lambda) {
X argc = evpushargs(fun,args);
X argv = xlfp + 3;
X trenter(tracing,argc,argv);
X val = evfun(fun,argc,argv);
X trexit(tracing,val);
X xlsp = xlfp;
X xlfp = xlfp - (int)getfixnum(*xlfp);
X }
X else {
X macroexpand(fun,args,&fun);
X val = xleval(fun);
X }
X break;
X default:
X xlerror("bad function",fun);
X }
X
X /* restore the stack */
X xlpopn(2);
X
X /* return the result value */
X return (val);
X}
X
X/* xlexpandmacros - expand macros in a form */
XLVAL xlexpandmacros(form)
X LVAL form;
X{
X LVAL fun,args;
X
X /* protect some pointers */
X xlstkcheck(3);
X xlprotect(form);
X xlsave(fun);
X xlsave(args);
X
X /* expand until the form isn't a macro call */
X while (consp(form)) {
X fun = car(form); /* get the macro name */
X args = cdr(form); /* get the arguments */
X if (!symbolp(fun) || !fboundp(fun))
X break;
X fun = xlgetfunction(fun); /* get the expansion function */
X if (!macroexpand(fun,args,&form))
X break;
X }
X
X /* restore the stack and return the expansion */
X xlpopn(3);
X return (form);
X}
X
X/* macroexpand - expand a macro call */
Xint macroexpand(fun,args,pval)
X LVAL fun,args,*pval;
X{
X LVAL *argv;
X int argc;
X
X /* make sure it's really a macro call */
X if (!closurep(fun) || gettype(fun) != s_macro)
X return (FALSE);
X
X /* call the expansion function */
X argc = pushargs(fun,args);
X argv = xlfp + 3;
X *pval = evfun(fun,argc,argv);
X xlsp = xlfp;
X xlfp = xlfp - (int)getfixnum(*xlfp);
X return (TRUE);
X}
X
X/* evalhook - call the evalhook function */
XLOCAL LVAL evalhook(expr)
X LVAL expr;
X{
X LVAL *newfp,olddenv,val;
X
X /* create the new call frame */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(getvalue(s_evalhook));
X pusharg(cvfixnum((FIXTYPE)2));
X pusharg(expr);
X pusharg(cons(xlenv,xlfenv));
X xlfp = newfp;
X
X /* rebind the hook functions to nil */
X olddenv = xldenv;
X xldbind(s_evalhook,NIL);
X xldbind(s_applyhook,NIL);
X
X /* call the hook function */
X val = xlapply(2);
X
X /* unbind the symbols */
X xlunbind(olddenv);
X
X /* return the value */
X return (val);
X}
X
X/* evpushargs - evaluate and push a list of arguments */
XLOCAL int evpushargs(fun,args)
X LVAL fun,args;
X{
X LVAL *newfp;
X int argc;
X
X /* protect the argument list */
X xlprot1(args);
X
X /* build a new argument stack frame */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(fun);
X pusharg(NIL); /* will be argc */
X
X /* evaluate and push each argument */
X for (argc = 0; consp(args); args = cdr(args), ++argc)
X pusharg(xleval(car(args)));
X
X /* establish the new stack frame */
X newfp[2] = cvfixnum((FIXTYPE)argc);
X xlfp = newfp;
X
X /* restore the stack */
X xlpop();
X
X /* return the number of arguments */
X return (argc);
X}
X
X/* pushargs - push a list of arguments */
Xint pushargs(fun,args)
X LVAL fun,args;
X{
X LVAL *newfp;
X int argc;
X
X /* build a new argument stack frame */
X newfp = xlsp;
X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X pusharg(fun);
X pusharg(NIL); /* will be argc */
X
X /* push each argument */
X for (argc = 0; consp(args); args = cdr(args), ++argc)
X pusharg(car(args));
X
X /* establish the new stack frame */
X newfp[2] = cvfixnum((FIXTYPE)argc);
X xlfp = newfp;
X
X /* return the number of arguments */
X return (argc);
X}
X
X/* makearglist - make a list of the remaining arguments */
XLVAL makearglist(argc,argv)
X int argc; LVAL *argv;
X{
X LVAL list,this,last;
X xlsave1(list);
X for (last = NIL; --argc >= 0; last = this) {
X this = cons(*argv++,NIL);
X if (last) rplacd(last,this);
X else list = this;
X last = this;
X }
X xlpop();
X return (list);
X}
X
X/* evfun - evaluate a function */
XLOCAL LVAL evfun(fun,argc,argv)
X LVAL fun; int argc; LVAL *argv;
X{
X LVAL oldenv,oldfenv,cptr,name,val;
X CONTEXT cntxt;
X
X /* protect some pointers */
X xlstkcheck(3);
X xlsave(oldenv);
X xlsave(oldfenv);
X xlsave(cptr);
X
X /* create a new environment frame */
X oldenv = xlenv;
X oldfenv = xlfenv;
X xlenv = xlframe(getenv(fun));
X xlfenv = getfenv(fun);
X
X /* bind the formal parameters */
X xlabind(fun,argc,argv);
X
X /* setup the implicit block */
X if (name = getname(fun))
X xlbegin(&cntxt,CF_RETURN,name);
X
X /* execute the block */
X if (name && setjmp(cntxt.c_jmpbuf))
X val = xlvalue;
X else
X for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
X val = xleval(car(cptr));
X
X /* finish the block context */
X if (name)
X xlend(&cntxt);
X
X /* restore the environment */
X xlenv = oldenv;
X xlfenv = oldfenv;
X
X /* restore the stack */
X xlpopn(3);
X
X /* return the result value */
X return (val);
X}
X
X/* xlclose - create a function closure */
XLVAL xlclose(name,type,fargs,body,env,fenv)
X LVAL name,type,fargs,body,env,fenv;
X{
X LVAL closure,key,arg,def,svar,new,last;
X char keyname[STRMAX+2];
X
X /* protect some pointers */
X xlsave1(closure);
X
X /* create the closure object */
X closure = newclosure(name,type,env,fenv);
X setlambda(closure,fargs);
X setbody(closure,body);
X
X /* handle each required argument */
X last = NIL;
X while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X /* make sure the argument is a symbol */
X if (!symbolp(arg))
X badarglist();
X
X /* create a new argument list entry */
X new = cons(arg,NIL);
X
X /* link it into the required argument list */
X if (last)
X rplacd(last,new);
X else
X setargs(closure,new);
X last = new;
X
X /* move the formal argument list pointer ahead */
X fargs = cdr(fargs);
X }
X
X /* check for the '&optional' keyword */
X if (consp(fargs) && car(fargs) == lk_optional) {
X fargs = cdr(fargs);
X
X /* handle each optional argument */
X last = NIL;
X while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X /* get the default expression and specified-p variable */
X def = svar = NIL;
X if (consp(arg)) {
X if (def = cdr(arg))
X if (consp(def)) {
X if (svar = cdr(def))
X if (consp(svar)) {
X svar = car(svar);
X if (!symbolp(svar))
X badarglist();
X }
X else
X badarglist();
X def = car(def);
X }
X else
X badarglist();
X arg = car(arg);
X }
X
X /* make sure the argument is a symbol */
X if (!symbolp(arg))
X badarglist();
X
X /* create a fully expanded optional expression */
X new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);
X
X /* link it into the optional argument list */
X if (last)
X rplacd(last,new);
X else
X setoargs(closure,new);
X last = new;
X
X /* move the formal argument list pointer ahead */
X fargs = cdr(fargs);
X }
X }
X
X /* check for the '&rest' keyword */
X if (consp(fargs) && car(fargs) == lk_rest) {
X fargs = cdr(fargs);
X
X /* get the &rest argument */
X if (consp(fargs) && (arg = car(fargs)) && !iskey(arg) && symbolp(arg))
X setrest(closure,arg);
X else
X badarglist();
X
X /* move the formal argument list pointer ahead */
X fargs = cdr(fargs);
X }
X
X /* check for the '&key' keyword */
X if (consp(fargs) && car(fargs) == lk_key) {
X fargs = cdr(fargs);
X
X /* handle each key argument */
X last = NIL;
X while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X /* get the default expression and specified-p variable */
X def = svar = NIL;
X if (consp(arg)) {
X if (def = cdr(arg))
X if (consp(def)) {
X if (svar = cdr(def))
X if (consp(svar)) {
X svar = car(svar);
X if (!symbolp(svar))
X badarglist();
X }
X else
X badarglist();
X def = car(def);
X }
X else
X badarglist();
X arg = car(arg);
X }
X
X /* get the keyword and the variable */
X if (consp(arg)) {
X key = car(arg);
X if (!symbolp(key))
X badarglist();
X if (arg = cdr(arg))
X if (consp(arg))
X arg = car(arg);
X else
X badarglist();
X }
X else if (symbolp(arg)) {
X strcpy(keyname,":");
X strcat(keyname,getstring(getpname(arg)));
X key = xlenter(keyname);
X }
X
X /* make sure the argument is a symbol */
X if (!symbolp(arg))
X badarglist();
X
X /* create a fully expanded key expression */
X new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);
X
X /* link it into the optional argument list */
X if (last)
X rplacd(last,new);
X else
X setkargs(closure,new);
X last = new;
X
X /* move the formal argument list pointer ahead */
X fargs = cdr(fargs);
X }
X }
X
X /* check for the '&allow-other-keys' keyword */
X if (consp(fargs) && car(fargs) == lk_allow_other_keys)
X fargs = cdr(fargs); /* this is the default anyway */
X
X /* check for the '&aux' keyword */
X if (consp(fargs) && car(fargs) == lk_aux) {
X fargs = cdr(fargs);
X
X /* handle each aux argument */
X last = NIL;
X while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X /* get the initial value */
X def = NIL;
X if (consp(arg)) {
X if (def = cdr(arg))
X if (consp(def))
X def = car(def);
X else
X badarglist();
X arg = car(arg);
X }
X
X /* make sure the argument is a symbol */
X if (!symbolp(arg))
X badarglist();
X
X /* create a fully expanded aux expression */
X new = cons(cons(arg,cons(def,NIL)),NIL);
X
X /* link it into the aux argument list */
X if (last)
X rplacd(last,new);
X else
X setaargs(closure,new);
X last = new;
X
X /* move the formal argument list pointer ahead */
X fargs = cdr(fargs);
X }
X }
X
X /* make sure this is the end of the formal argument list */
X if (fargs)
X badarglist();
X
X /* restore the stack */
X xlpop();
X
X /* return the new closure */
X return (closure);
X}
X
X/* xlabind - bind the arguments for a function */
Xxlabind(fun,argc,argv)
X LVAL fun; int argc; LVAL *argv;
X{
X LVAL *kargv,fargs,key,arg,def,svar,p;
X int rargc,kargc;
X
X /* protect some pointers */
X xlsave1(def);
X
X /* bind each required argument */
X for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {
X
X /* make sure there is an actual argument */
X if (--argc < 0)
X xlfail("too few arguments");
X
X /* bind the formal variable to the argument value */
X xlbind(car(fargs),*argv++);
X }
X
X /* bind each optional argument */
X for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {
X
X /* get argument, default and specified-p variable */
X p = car(fargs);
X arg = car(p); p = cdr(p);
X def = car(p); p = cdr(p);
X svar = car(p);
X
X /* bind the formal variable to the argument value */
X if (--argc >= 0) {
X xlbind(arg,*argv++);
X if (svar) xlbind(svar,true);
X }
X
X /* bind the formal variable to the default value */
X else {
X if (def) def = xleval(def);
X xlbind(arg,def);
X if (svar) xlbind(svar,NIL);
X }
X }
X
X /* save the count of the &rest of the argument list */
X rargc = argc;
X
X /* handle '&rest' argument */
X if (arg = getrest(fun)) {
X def = makearglist(argc,argv);
X xlbind(arg,def);
X argc = 0;
X }
X
X /* handle '&key' arguments */
X if (fargs = getkargs(fun)) {
X for (; fargs; fargs = cdr(fargs)) {
X
X /* get keyword, argument, default and specified-p variable */
X p = car(fargs);
X key = car(p); p = cdr(p);
X arg = car(p); p = cdr(p);
X def = car(p); p = cdr(p);
X svar = car(p);
X
X /* look for the keyword in the actual argument list */
X for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
X if (*kargv == key)
X break;
X
X /* bind the formal variable to the argument value */
X if (kargc >= 0) {
X xlbind(arg,*++kargv);
X if (svar) xlbind(svar,true);
X }
X
X /* bind the formal variable to the default value */
X else {
X if (def) def = xleval(def);
X xlbind(arg,def);
X if (svar) xlbind(svar,NIL);
X }
X }
X argc = 0;
X }
X
X /* check for the '&aux' keyword */
X for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {
X
X /* get argument and default */
X p = car(fargs);
X arg = car(p); p = cdr(p);
X def = car(p);
X
X /* bind the auxiliary variable to the initial value */
X if (def) def = xleval(def);
X xlbind(arg,def);
X }
X
X /* make sure there aren't too many arguments */
X if (argc > 0)
X xlfail("too many arguments");
X
X /* restore the stack */
X xlpop();
X}
X
X/* doenter - print trace information on function entry */
XLOCAL doenter(sym,argc,argv)
X LVAL sym; int argc; LVAL *argv;
X{
X extern int xltrcindent;
X int i;
X
X /* indent to the current trace level */
X for (i = 0; i < xltrcindent; ++i)
X trcputstr(" ");
X ++xltrcindent;
X
X /* display the function call */
X sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym)));
X trcputstr(buf);
X while (--argc >= 0) {
X trcprin1(*argv++);
X if (argc) trcputstr(" ");
X }
X trcputstr(")\n");
X}
X
X/* doexit - print trace information for function/macro exit */
XLOCAL doexit(sym,val)
X LVAL sym,val;
X{
X extern int xltrcindent;
X int i;
X
X /* indent to the current trace level */
X --xltrcindent;
X for (i = 0; i < xltrcindent; ++i)
X trcputstr(" ");
X
X /* display the function value */
X sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym)));
X trcputstr(buf);
X trcprin1(val);
X trcputstr("\n");
X}
X
X/* member - is 'x' a member of 'list'? */
XLOCAL int member(x,list)
X LVAL x,list;
X{
X for (; consp(list); list = cdr(list))
X if (x == car(list))
X return (TRUE);
X return (FALSE);
X}
X
X/* xlunbound - signal an unbound variable error */
Xxlunbound(sym)
X LVAL sym;
X{
X xlcerror("try evaluating symbol again","unbound variable",sym);
X}
X
X/* xlfunbound - signal an unbound function error */
Xxlfunbound(sym)
X LVAL sym;
X{
X xlcerror("try evaluating symbol again","unbound function",sym);
X}
X
X/* xlstkoverflow - signal a stack overflow error */
Xxlstkoverflow()
X{
X xlabort("evaluation stack overflow");
X}
X
X/* xlargstkoverflow - signal an argument stack overflow error */
Xxlargstkoverflow()
X{
X xlabort("argument stack overflow");
X}
X
X/* badarglist - report a bad argument list error */
XLOCAL badarglist()
X{
X xlfail("bad formal argument list");
X}
SHAR_EOF
if test 19240 -ne "`wc -c 'xleval.c'`"
then
echo shar: error transmitting "'xleval.c'" '(should have been 19240 characters)'
fi
# End of shell archive
exit 0
--
Gary Murphy uunet!mitel!sce!cognos!garym
(garym%cognos.uucp@uunet.uu.net)
(613) 738-1338 x5537 Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc