/* xleval - xlisp evaluator */
/* Copyright (c) 1989, by David Michael Betz. */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution. */
#include "xlisp.h"
/* macro to check for lambda list keywords */
#define iskey(s) ((s) == lk_optional \
|| (s) == lk_rest \
|| (s) == lk_key \
|| (s) == lk_aux \
|| (s) == lk_allow_other_keys \
|| (s) == lk_whole \
|| (s) == lk_body \
|| (s) == lk_environment)
/* macros to handle tracing */
#define trenter(sym,argc,argv) {if (!null(sym)) doenter(sym,argc,argv);}
#define trexit(sym,val) {if (!null(sym)) doexit(sym,val);}
/* local forward declarations */
LOCAL LVAL xlbadfunction P1H(LVAL);
LOCAL VOID badarglist(V);
/*LOCAL*/ VOID doenter P3H(LVAL, int, FRAMEP);
/*LOCAL*/ VOID doexit P2H(LVAL, LVAL);
LOCAL LVAL evalhook P1H(LVAL);
LOCAL LVAL evform P1H(LVAL);
LOCAL LVAL evfun P3H(LVAL, int, FRAMEP);
LOCAL int evpushargs P2H(LVAL, LVAL);
LOCAL int member P2H(LVAL, LVAL);
#ifndef XLISP_STAT
LOCAL LVAL member2 P3H(LVAL, LVAL, LVAL);
#endif /* XLISP_STAT */
#ifdef APPLYHOOK
LOCAL LVAL applyhook P2H(LVAL, LVAL);
#endif
#ifdef CONDITIONS
LOCAL VOID xlcondunbound P2H(LVAL, LVAL);
#endif /* CONDITIONS */
LOCAL LVAL xlbadfunction P1C(LVAL, arg)
{
return xlerror("bad function",arg);
}
/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
LVAL xleval P1C(LVAL, expr)
{
/* check for control codes */
if (--xlsample <= 0) {
xlsample = SAMPLE;
oscheck();
}
/* check for *evalhook* */
if (!null(getvalue(s_evalhook)))
return (evalhook(expr));
/* dispatch on the node type */
switch (ntype(expr)) {
case CONS:
return (evform(expr));
#ifdef BYTECODE
case BCODE:
return (BC_evform(expr));
#endif /* BYTECODE */
case SYMBOL:
#ifdef MULVALS
xlnumresults = 1;
return (xlresults[0] = xlgetvalue(expr));
#else
return (xlgetvalue(expr));
#endif /* MULVALS */
default:
#ifdef MULVALS
xlnumresults = 1;
return (xlresults[0] = expr);
#else
return (expr);
#endif /* MULVALS */
}
}
/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
LVAL xlxeval P1C(LVAL, expr)
{
/* dispatch on node type */
switch (ntype(expr)) {
case CONS:
return (evform(expr));
#ifdef BYTECODE
case BCODE:
return (BC_evform(expr));
#endif /* BYTECODE */
case SYMBOL:
#ifdef MULVALS
xlnumresults = 1;
return (xlresults[0] = xlgetvalue(expr));
#else
return (xlgetvalue(expr));
#endif /* MULVALS */
default:
#ifdef MULVALS
xlnumresults = 1;
return (xlresults[0] = expr);
#else
return (expr);
#endif /* MULVALS */
}
}
/* xlapply - apply a function to arguments (already on the stack) */
LVAL xlapply P1C(int, argc)
{
LVAL fun,val;
/* get the function */
fun = xlfp[1];
/* get the functional value of symbols */
if (symbolp(fun)) {
while ((val = getfunction(fun)) == s_unbound)
xlfunbound(fun);
fun = xlfp[1] = val;
}
/* check for nil */
if (null(fun))
xlbadfunction(fun);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR: {
FRAMEP oldargv;
int oldargc;
oldargc = xlargc;
oldargv = xlargv;
xlargc = argc;
xlargv = xlfp + 3;
val = (*getsubr(fun))();
#ifdef MULVALS
if (! mulvalp(fun)) {
xlnumresults = 1;
xlresults[0] = val;
}
#endif /* MULVALS */
xlargc = oldargc;
xlargv = oldargv;
break;
}
case CONS:
if (!consp(cdr(fun)))
xlbadfunction(fun);
if (car(fun) == s_lambda)
fun = xlfp[1] /* TAA fix (vanNiekerk) */
= xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
else
xlbadfunction(fun);
/**** fall through into the next case ****/
case CLOSURE:
if (gettype(fun) != s_lambda)
xlbadfunction(fun);
val = evfun(fun,argc,xlfp+3);
break;
#ifdef BYTECODE
case BCCLOSURE:
if (getbcctype(fun) != s_lambda)
xlbadfunction(fun);
val = BC_evfun(fun,argc,xlfp+3);
break;
#endif /* BYTECODE */
default:
xlbadfunction(fun);
val = NIL; /* to keep compiler happy */
}
/* remove the call frame */
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
/* return the function value */
return (val);
}
/* evform - evaluate a form */
LOCAL LVAL evform P1C(LVAL, form)
{
LVAL fun,args,val;
LVAL tracing=NIL;
FRAMEP argv;
int argc;
LVAL **oldst = xlstack, oform = form; /**** remove after debugging */
#ifdef STSZ
/* Debugging -- print system and eval stack remaining at each invocation */
/* fprintf(stderr, "%d/%d ",STACKREPORT(argc), xlstack-xlstkbase); */
/* check the stack */
stchck();
#endif
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
/* get the function and the argument list */
fun = car(form);
args = cdr(form);
/* get the functional value of symbols */
if (symbolp(fun)) {
if (!null(getvalue(s_tracelist)) && member(fun,getvalue(s_tracelist)))
tracing = fun;
fun = xlgetfunction(fun);
}
/* check for nil */
if (null(fun))
xlbadfunction(NIL);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
#ifdef APPLYHOOK
/* check for *applyhook* */
if (!null(getvalue(s_applyhook))) {
val = (applyhook(fun,args));
break;
}
#endif
argv = xlargv;
argc = xlargc;
xlargc = evpushargs(fun,args);
xlargv = xlfp + 3;
trenter(tracing,xlargc,xlargv);
val = (*getsubr(fun))();
#ifdef MULVALS
if (! mulvalp(fun)) {
xlnumresults = 1;
xlresults[0] = val;
}
#endif /* MULVALS */
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case FSUBR:
argv = xlargv;
argc = xlargc;
xlargc = pushargs(fun,args);
xlargv = xlfp + 3;
val = (*getsubr(fun))();
#ifdef MULVALS
if (! mulvalp(fun)) {
xlnumresults = 1;
xlresults[0] = val;
}
#endif /* MULVALS */
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case CONS:
if (!consp(cdr(fun)))
xlbadfunction(fun);
if ((/* type = */ car(fun)) == s_lambda)
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
else
xlbadfunction(fun);
/**** fall through into the next case ****/
case CLOSURE:
if (gettype(fun) == s_lambda) {
#ifdef APPLYHOOK
/* check for *applyhook* */
if (!null(getvalue(s_applyhook))) {
val = (applyhook(fun,args));
break;
}
#endif
argc = evpushargs(fun,args);
argv = xlfp + 3;
trenter(tracing,argc,argv);
val = evfun(fun,argc,argv);
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
}
else {
LVAL tmp = form;
macroexpand(fun,args,&tmp);
fun = tmp;
if (!null(getvalue(s_dispmacros)) && consp(fun)) {
/* substitute back into original fcn */
rplaca(form, car(fun));
rplacd(form, cdr(fun));
}
val = xleval(fun);
}
break;
#ifdef BYTECODE
case BCCLOSURE:
if (getbcctype(fun) == s_lambda) {
#ifdef APPLYHOOK
/* check for *applyhook* */
if (!null(getvalue(s_applyhook))) {
val = (applyhook(fun,args));
break;
}
#endif
argc = evpushargs(fun,args);
argv = xlfp + 3;
trenter(tracing,argc,argv);
val = BC_evfun(fun,argc,argv);
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
}
else {
LVAL tmp = form;
macroexpand(fun,args,&tmp);
fun = tmp;
if (!null(getvalue(s_dispmacros)) && consp(fun)) {
/* substitute back into original fcn */
rplaca(form, car(fun));
rplacd(form, cdr(fun));
}
val = xleval(fun);
}
break;
#endif /* BYTECODE */
default:
xlbadfunction(fun);
val = NIL; /* to keep compiler happy */
}
/* restore the stack */
xlpopn(2);
if (oldst != xlstack) { /**** remove after debugging */
stdputstr("stack messup - ");
stdprint(oform);
}
/* return the result value */
return (val);
}
/* xlexpandmacros - expand macros in a form */
LVAL xlexpandmacros P1C(LVAL, form)
{
LVAL fun,args;
/* protect some pointers */
xlstkcheck(3);
xlprotect(form);
xlsave(fun);
xlsave(args);
/* expand until the form isn't a macro call */
while (consp(form)) {
fun = car(form); /* get the macro name */
args = cdr(form); /* get the arguments */
if (! symbolp(fun) || (fun = xlxgetfunction(fun)) == s_unbound)
break;
if (!macroexpand(fun,args,&form))
break;
}
/* restore the stack and return the expansion */
xlpopn(3);
return (form);
}
/* macroexpand - expand a macro call */
/* assumes form is passed as *pval */
int macroexpand P3C(LVAL, fun, LVAL, args, LVAL *, pval)
{
FRAMEP argv;
int argc;
LVAL tmp1, tmp2;
/* make sure it's really a macro call */
#ifdef BYTECODE
if (! (bcclosurep(fun) && getbcctype(fun) == s_macro)
&& ! (closurep(fun) && gettype(fun) == s_macro))
return (FALSE);
#else
if (! (closurep(fun) && gettype(fun) == s_macro))
return (FALSE);
#endif
/* call the expansion function */
/* modified for CL-compliant form of expansion function */
xlstkcheck(2);
xlsave(tmp1);
xlsave(tmp2);
#ifdef OLDMACROS
tmp1 = cons(xlenv,xlfenv);
tmp2 = copylist(*pval);
tmp2 = cons(tmp2,args);
#else
tmp1 = copylist(*pval);
tmp2 = cons(xlenv,xlfenv);
tmp2 = consa(tmp2);
#endif /* OLDMACROS */
argc = pushargs(fun,cons(tmp1, tmp2));
xlpopn(2);
argv = xlfp + 3;
#ifdef BYTECODE
if (bcclosurep(fun))
*pval = BC_evfun(fun,argc,argv);
else
*pval = evfun(fun,argc,argv);
#else
*pval = evfun(fun,argc,argv);
#endif /* BYTECODE */
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
return (TRUE);
}
/* evalhook - call the evalhook function */
LOCAL LVAL evalhook P1C(LVAL, expr)
{
FRAMEP newfp;
LVAL olddenv,val;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(getvalue(s_evalhook));
pusharg(cvfixnum((FIXTYPE)2));
pusharg(expr);
pusharg(cons(xlenv,xlfenv));
xlfp = newfp;
/* rebind the hook functions to nil */
olddenv = xldenv;
xldbind(s_evalhook,NIL);
xldbind(s_applyhook,NIL);
/* call the hook function */
val = xlapply(2);
/* unbind the symbols */
xlunbind(olddenv);
/* return the value */
return (val);
}
#ifdef APPLYHOOK
/* applyhook - call the applyhook function */
LOCAL LVAL applyhook P2C(LVAL, fun, LVAL, args)
{
FRAMEP newfp;
LVAL olddenv,val,last,next;
xlsave1(val); /* protect against GC */
if (consp(args)) { /* build argument list -- if there are any */
/* we will pass evaluated arguments, with hooks enabled */
/* so argument evaluation will be hooked too */
val = last = consa(xleval(car(args)));
args = cdr(args);
while (consp(args)) { /* handle any more in loop */
next = consa(xleval(car(args)));
rplacd(last,next);
last = next;
args = cdr(args);
}
}
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(getvalue(s_applyhook));
pusharg(cvfixnum((FIXTYPE)2));
pusharg(fun);
pusharg(val);
xlfp = newfp;
/* rebind hook functions to NIL */
olddenv = xldenv;
xldbind(s_evalhook,NIL);
xldbind(s_applyhook,NIL);
/* call the hook function */
val = xlapply(2);
/* unbind the symbols */
xlunbind(olddenv);
/* return the value */
return (val);
}
#endif
/* evpushargs - evaluate and push a list of arguments */
LOCAL int evpushargs P2C(LVAL, fun, LVAL, args)
{
FRAMEP newfp;
int argc;
/* protect the argument list */
xlprot1(args);
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(NIL); /* will be argc */
/* evaluate and push each argument */
for (argc = 0; consp(args); args = cdr(args), ++argc)
pusharg(xleval(car(args)));
/* establish the new stack frame */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
/* restore the stack */
xlpop();
/* return the number of arguments */
return (argc);
}
/* pushargs - push a list of arguments */
int pushargs P2C(LVAL, fun, LVAL, args)
{
FRAMEP newfp;
int argc;
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(NIL); /* will be argc */
/* push each argument */
for (argc = 0; consp(args); args = cdr(args), ++argc)
pusharg(car(args));
/* establish the new stack frame */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
/* return the number of arguments */
return (argc);
}
/* makearglist - make a list of the remaining arguments */
LVAL makearglist P2C(int, argc, LVAL *, argv)
{
LVAL list,this,last;
xlsave1(list);
for (last = NIL; --argc >= 0; last = this) {
this = cons(*argv++,NIL);
if (!null(last)) rplacd(last,this);
else list = this;
last = this;
}
xlpop();
return (list);
}
/* evfun - evaluate a function */
LOCAL LVAL evfun P3C(LVAL, fun, int, argc, FRAMEP, argv)
{
LVAL oldenv,oldfenv,cptr,val;
LVAL olddenv=xldenv;
CONTEXT cntxt;
/* protect some pointers */
xlstkcheck(3);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(cptr);
/* create a new environment frame */
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = xlframe(getenvi(fun));
xlfenv = getfenv(fun);
/* bind the formal parameters */
xlabind(fun,argc,argv);
/* setup the implicit block */
if (!null(getname(fun)))
xlbegin(&cntxt,CF_RETURN,getname(fun));
/* execute the block */
#ifdef CRAYCC
if (null(getname(fun))) goto noname;
if (XL_SETJMP(cntxt.c_jmpbuf))
val = xlvalue;
else {
noname:
#else
if (!null(getname(fun)) && XL_SETJMP(cntxt.c_jmpbuf))
val = xlvalue;
else {
#endif /* CRAYCC */
#ifdef LEXBIND
if (!null(getname(fun)))
xlbindtag(&cntxt,getname(fun),xlenv);
#endif
#ifdef MULVALS
xlnumresults = 1;
xlresults[0] = NIL;
#endif /* MULVALS */
for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr)) {
/* check for control codes */
if (--xlsample <= 0) {
xlsample = SAMPLE;
oscheck();
}
val = car(cptr);
/* check for *evalhook* */
if (!null(getvalue(s_evalhook))) {
val = evalhook(val);
continue;
}
/* dispatch on the node type */
switch (ntype(val)) {
case CONS:
val = evform(val);
break;
#ifdef MULVALS
case SYMBOL:
val = xlgetvalue(val);
/* fall through */
default:
xlnumresults = 1;
xlresults[0] = val;
break;
#else
case SYMBOL:
val = xlgetvalue(val);
break;
default: /* nothing */
break;
#endif /* MULVALS */
}
}
}
/* finish the block context */
if (!null(getname(fun)))
xlend(&cntxt);
/* restore the environment */
xlenv = oldenv;
xlfenv = oldfenv;
xlunbind(olddenv);
/* restore the stack */
xlpopn(3);
/* return the result value */
return (val);
}
/* xlclose - create a function closure */
LVAL xlclose P6C(LVAL, name, LVAL, type, LVAL, fargs, LVAL, body, LVAL, env, LVAL, fenv)
{
LVAL closure,key=NULL,arg,def,svar,new,last;
#ifndef PACKAGES
char keyname[STRMAX+2];
#endif /* PACKAGES */
LVAL wholesym=NULL,envsym=NULL;
int destruct = FALSE;
/* protect some pointers */
xlsave1(closure);
xlprot1(fargs);
/* create the closure object */
closure = newclosure(name,type,env,fenv);
setlambda(closure,fargs);
setbody(closure,body);
/* check for &whole and &environment in macros */
if (type == s_macro) {
LVAL next, last;
fargs = copylist(fargs);
envsym = s_unbound;
/* check for &whole argument */
if (consp(fargs) && car(fargs) == lk_whole) {
fargs = cdr(fargs);
if (consp(fargs) && (!null(arg = car(fargs))) &&
symbolp(arg) && !iskey(arg))
wholesym = arg;
else
badarglist();
fargs = cdr(fargs);
}
else {
wholesym = s_unbound;
envsym = s_unbound;
}
/* check for &environment argument */
for (next = fargs, last = NIL;
consp(next);
last = next, next = cdr(next)) {
if (car(next) == lk_environment) {
if (consp(cdr(next)) && (!null(arg = car(cdr(next)))) &&
symbolp(arg) && !iskey(arg))
envsym = arg;
else
badarglist();
if (null(last))
fargs = cdr(cdr(fargs));
else
rplacd(last, cdr(cdr(next)));
break;
}
}
/* replace &body by &rest */
for (next = fargs; consp(next); next = cdr(next))
if (car(next) == lk_body)
rplaca(next, lk_rest);
/* replace dotted list by &rest */
for (next = fargs, last = NIL;
consp(next);
last = next, next = cdr(next));
if (consp(last) && ! null(arg = cdr(last))) {
if (symbolp(arg) && !iskey(arg))
rplacd(last, cons(lk_rest, cons(arg, NIL)));
else
badarglist();
}
/* check for destructuring */
for (next = fargs; consp(next) && !iskey(car(next)); next = cdr(next))
if (consp(car(next))) {
if (fboundp(s_destructbind)) {
destruct = TRUE;
break;
}
else
xlfail("destructuring macro arglists not supported yet");
}
if (destruct) {
LVAL sym;
xlsave1(sym);
sym = xlmakesym("R");
setbody(closure,
consa(cons(s_destructbind, cons(fargs, cons(sym, body)))));
fargs = cons(lk_rest, consa(sym));
xlpop();
}
setlambda(closure, fargs);
}
/* handle each required argument */
last = NIL;
while (consp(fargs) && (!null(arg = car(fargs))) && !iskey(arg)) {
/* make sure the argument is a symbol */
if (!symbolp(arg))
badarglist();
/* create a new argument list entry */
new = cons(arg,NIL);
/* link it into the required argument list */
if (!null(last))
rplacd(last,new);
else
setargs(closure,new);
last = new;
/* move the formal argument list pointer ahead */
fargs = cdr(fargs);
}
if (type == s_macro)
setargs(closure,cons(envsym,cons(wholesym,getargs(closure))));
/* check for the '&optional' keyword */
if (consp(fargs) && car(fargs) == lk_optional) {
fargs = cdr(fargs);
/* handle each optional argument */
last = NIL;
while (consp(fargs) && (!null(arg = car(fargs))) && !iskey(arg)) {
/* get the default expression and specified-p variable */
def = svar = NIL;
if (consp(arg)) {
if (!null(def = cdr(arg)))
if (consp(def)) {
if (!null(svar = cdr(def)))
if (consp(svar)) {
svar = car(svar);
if (!symbolp(svar))
badarglist();
}
else
badarglist();
def = car(def);
}
else
badarglist();
arg = car(arg);
}
/* make sure the argument is a symbol */
if (!symbolp(arg))
badarglist();
/* create a fully expanded optional expression */
new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);
/* link it into the optional argument list */
if (!null(last))
rplacd(last,new);
else
setoargs(closure,new);
last = new;
/* move the formal argument list pointer ahead */
fargs = cdr(fargs);
}
}
/* check for the '&rest' keyword */
if (consp(fargs)
&& (car(fargs) == lk_rest
|| (type == s_macro && car(fargs) == lk_body))) {
fargs = cdr(fargs);
/* get the &rest argument */
if (consp(fargs) && (!null((arg = car(fargs)))) && !iskey(arg) && symbolp(arg))
setrest(closure,arg);
else
badarglist();
/* move the formal argument list pointer ahead */
fargs = cdr(fargs);
}
/* check for the '&key' keyword */
if (consp(fargs) && car(fargs) == lk_key) {
fargs = cdr(fargs);
/* handle each key argument */
last = NIL;
while (consp(fargs) && (!null(arg = car(fargs))) && !iskey(arg)) {
/* get the default expression and specified-p variable */
def = svar = NIL;
if (consp(arg)) {
if (!null(def = cdr(arg)))
if (consp(def)) {
if (!null(svar = cdr(def)))
if (consp(svar)) {
svar = car(svar);
if (!symbolp(svar))
badarglist();
}
else
badarglist();
def = car(def);
}
else
badarglist();
arg = car(arg);
}
/* get the keyword and the variable */
if (consp(arg)) {
key = car(arg);
if (!symbolp(key))
badarglist();
if (!null(arg = cdr(arg)))
if (consp(arg))
arg = car(arg);
else
badarglist();
}
else if (symbolp(arg)) {
#ifdef PACKAGES
key = xlintern(getstring(getpname(arg)), xlkeypack);
#else
strcpy(keyname,":");
STRCAT(keyname,getstring(getpname(arg)));
key = xlenter(keyname);
#endif /* PACKAGES */
}
/* make sure the argument is a symbol */
if (!symbolp(arg))
badarglist();
/* create a fully expanded key expression */
new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);
/* link it into the optional argument list */
if (!null(last))
rplacd(last,new);
else
setkargs(closure,new);
last = new;
/* move the formal argument list pointer ahead */
fargs = cdr(fargs);
}
}
/* check for the '&allow-other-keys' keyword */
if (consp(fargs) && car(fargs) == lk_allow_other_keys) {
/* save marker that other keys are allowed */
setkargs(closure,cons(lk_allow_other_keys,getkargs(closure)));
fargs = cdr(fargs);
}
/* check for the '&aux' keyword */
if (consp(fargs) && car(fargs) == lk_aux) {
fargs = cdr(fargs);
/* handle each aux argument */
last = NIL;
while (consp(fargs) && (!null(arg = car(fargs))) && !iskey(arg)) {
/* get the initial value */
def = NIL;
if (consp(arg)) {
if (!null(def = cdr(arg)))
if (consp(def))
def = car(def);
else
badarglist();
arg = car(arg);
}
/* make sure the argument is a symbol */
if (!symbolp(arg))
badarglist();
/* create a fully expanded aux expression */
new = cons(cons(arg,cons(def,NIL)),NIL);
/* link it into the aux argument list */
if (!null(last))
rplacd(last,new);
else
setaargs(closure,new);
last = new;
/* move the formal argument list pointer ahead */
fargs = cdr(fargs);
}
}
/* make sure this is the end of the formal argument list */
if (!null(fargs))
badarglist();
/* restore the stack */
xlpopn(2);
#ifndef OLDMACROS
/* now if it is a macro fix it up to be CL-compliant */
if (type == s_macro) {
LVAL wsym, esym, fun, tmp;
xlstkcheck(5);
xlprotect(closure);
xlsave(wsym);
xlsave(esym);
xlsave(fun);
xlsave(tmp);
esym = car(getargs(closure));
wsym = car(cdr(getargs(closure)));
if (esym == s_unbound) esym = xlmakesym("E");
if (wsym == s_unbound) wsym = xlmakesym("W");
if (destruct) {
tmp = cdr(cdr(car(getbody(closure))));
rplaca(tmp, cons(s_cdr, consa(wsym)));
}
else {
fun = cons(s_lambda, cons(getlambda(closure), getbody(closure)));
fun = cons(s_function, consa(fun));
tmp = cons(s_apply, cons(fun, consa(cons(s_cdr, consa(wsym)))));
setbody(closure, consa(tmp));
}
setargs(closure, cons(wsym, consa(esym)));
setlambda(closure, cons(wsym, consa(esym)));
setoargs(closure, NIL);
setrest(closure, NIL);
setkargs(closure, NIL);
setaargs(closure, NIL);
xlpopn(5);
}
#endif /* OLDMACROS */
/* return the new closure */
return (closure);
}
/* xlabind - bind the arguments for a function */
VOID xlabind P3C(LVAL, fun, int, argc, LVAL *, argv)
{
LVAL *kargv,fargs,key,arg,def,svar,p;
int keycount=0;
int rargc,kargc;
/* protect some pointers */
xlsave1(def);
/* bind each required argument */
for (fargs = getargs(fun); consp(fargs); fargs = cdr(fargs)) {
/* make sure there is an actual argument */
if (--argc < 0)
xltoofew();
if (constantp(car(fargs))) xlnoassign(car(fargs));
/* bind the formal variable to the argument value */
xlbind(car(fargs),*argv++);
}
/* bind each optional argument */
for (fargs = getoargs(fun); consp(fargs); fargs = cdr(fargs)) {
/* get argument, default and specified-p variable */
p = car(fargs);
arg = car(p); p = cdr(p);
def = car(p); p = cdr(p);
svar = car(p);
if (constantp(arg)) xlnoassign(arg);
if ((!null(svar)) && constantp(svar)) xlnoassign(svar);
/* bind the formal variable to the argument value */
if (argc > 0) {
argc--;
xlbind(arg,*argv++);
if (!null(svar)) xlbind(svar, s_true);
}
/* bind the formal variable to the default value */
else {
if (!null(def)) def = xleval(def);
xlbind(arg,def);
if (!null(svar)) xlbind(svar,NIL);
}
}
/* save the count of the &rest of the argument list */
rargc = argc;
/* handle '&rest' argument */
if (!null(arg = getrest(fun))) {
if (constantp(arg)) xlnoassign(arg);
def = makearglist(argc,argv);
xlbind(arg,def);
argc = 0;
}
/* handle '&key' arguments */
if (!null(fargs = getkargs(fun))) {
if (rargc & 1) /* TAA Mod added check -- 9/93 */
xlfail( "keyword value missing");
if (car(fargs) == lk_allow_other_keys)
fargs = cdr(fargs); /* toss marker */
else
keycount = (rargc+1)/2; /* number of keyword arguments */
for (; consp(fargs); fargs = cdr(fargs)) {
/* get keyword, argument, default and specified-p variable */
p = car(fargs);
key = car(p); p = cdr(p);
arg = car(p); p = cdr(p);
def = car(p); p = cdr(p);
svar = car(p);
if (constantp(arg)) xlnoassign(arg);
if (!null(svar) && constantp(svar)) xlnoassign(svar);
/* look for the keyword in the actual argument list */
for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
if (*kargv == key)
break;
/* bind the formal variable to the argument value */
if (kargc >= 0) {
keycount--;
xlbind(arg,*++kargv);
if (!null(svar)) xlbind(svar, s_true);
/* "delete" any duplicate arguments TAA Added 9/93 */
for (;(kargc -= 2) >= 0 ; kargv++)
if (*++kargv == key) keycount--;
}
/* bind the formal variable to the default value */
else {
if (!null(def)) def = xleval(def);
xlbind(arg,def);
if (!null(svar)) xlbind(svar,NIL);
}
}
if (keycount > 0 && !null(getvalue(s_strict_keywords))) {
/* some keyword args were left over, and ! &allow-other-keys */
for (kargv = argv, kargc = rargc; kargc > 0; kargc -= 2, kargv += 2)
if (kargv[0] == k_allow_other_keys && !null(kargv[1]))
break;
if (kargc == 0)
xlfail("too many or invalid keyword arguments");
}
argc = 0;
}
/* check for the '&aux' keyword */
for (fargs = getaargs(fun); consp(fargs); fargs = cdr(fargs)) {
/* get argument and default */
p = car(fargs);
arg = car(p); p = cdr(p);
def = car(p);
if (constantp(arg)) xlnoassign(arg);
/* bind the auxiliary variable to the initial value */
if (!null(def)) def = xleval(def);
xlbind(arg,def);
}
/* make sure there aren't too many arguments */
if (argc > 0)
xltoomany();
/* restore the stack */
xlpop();
}
#ifndef XLISP_STAT
/* evmethod - evaluate a method */
LVAL evmethod(obj,msgcls,message)
LVAL obj,msgcls,message;
{
LVAL oldenv,oldfenv,cptr,name,val;
LVAL olddenv=xldenv;
LVAL tracing = NIL;
CONTEXT cntxt;
/* protect some pointers */
xlstkcheck(3);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(cptr);
/* create an 'object' stack entry and a new environment frame */
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = cons(cons(obj,msgcls),getenvi(cdr(message)));
xlenv = xlframe(xlenv);
xlfenv = getfenv(cdr(message));
/* bind the formal parameters */
xlabind(cdr(message),xlargc,xlargv);
/* check for and start tracing TAA 9/1/96 */
if (!null(getvalue(s_tracelist)) &&
(tracing = member2(msgcls, car(message), getvalue(s_tracelist))) != NIL) {
trenter(tracing,xlargc,xlargv);
}
/* setup the implicit block */
if (!null(name = getname(cdr(message))))
xlbegin(&cntxt,CF_RETURN,name);
/* execute the block */
if (!null(name) && XL_SETJMP(cntxt.c_jmpbuf))
val = xlvalue;
else {
#ifdef LEXBIND
if (!null(name))
xlbindtag(&cntxt,name,xlenv);
#endif
#ifdef MULVALS
xlnumresults = 1;
xlresults[0] = NIL;
#endif /* MULVALS */
for (val = NIL, cptr = getbody(cdr(message)); consp(cptr); cptr = cdr(cptr))
val = xleval(car(cptr));
}
/* finish the block context */
if (!null(name))
xlend(&cntxt);
/* end tracing */
trexit(tracing, val);
/* restore the environment */
xlenv = oldenv;
xlfenv = oldfenv;
xlunbind(olddenv);
/* restore the stack */
xlpopn(3);
/* return the result value */
return (val);
}
#endif /* XLISP_STAT */
/* doenter - print trace information on function entry */
/* LOCAL VOID doenter(sym,argc,argv) *//* made global for method tracing */
VOID doenter P3C(LVAL, sym, int, argc, FRAMEP, argv)
{
int i;
LVAL olddenv;
/* indent to the current trace level */
for (i = 0; i < xltrcindent; ++i)
trcputstr(" ");
++xltrcindent;
/* rebind tracelist during printing - L. Tierney */
olddenv = xldenv;
xldbind(s_tracelist,NIL);
/* display the function call */
if (consp(sym)) {
sprintf(buf,"Entering: %s,%s, Argument list: (",
getstring(getivar(car(sym), PNAME)),
getstring(getpname(car(cdr(sym)))));
}
else
sprintf(buf,"Entering: %s, Argument list: (",
getstring(getpname(sym)));
trcputstr(buf);
while (--argc >= 0) {
trcprin1(*argv++);
if (argc) trcputstr(" ");
}
trcputstr(")\n");
/* unbind the symbols - L. Tierney */
xlunbind(olddenv);
}
/* doexit - print trace information for function/macro exit */
/* LOCAL VOID doexit(sym,val) *//* made global for method tracing */
VOID doexit P2C(LVAL, sym, LVAL, val)
{
#ifdef MULVALS
extern int xltrcindent;
int i, n;
LVAL olddenv, *oldsp;
/* indent to the current trace level */
--xltrcindent;
for (i = 0; i < xltrcindent; ++i)
trcputstr(" ");
/* rebind tracelist during printing - L. Tierney */
olddenv = xldenv;
xldbind(s_tracelist,NIL);
/* save the results on the stack */
oldsp = xlsp;
n = xlnumresults;
for (i = 0; i < n; i++)
pusharg(xlresults[i]);
/* display the function values */
switch (n) {
case 0:
sprintf(buf,"Exiting: %s, No values. ",
getstring(getpname(consp(sym)?car(cdr(sym)):sym)));
break;
case 1:
sprintf(buf,"Exiting: %s, Value: ",
getstring(getpname(consp(sym)?car(cdr(sym)):sym)));
break;
default:
sprintf(buf,"Exiting: %s, Values: ",
getstring(getpname(consp(sym)?car(cdr(sym)):sym)));
}
trcputstr(buf);
for (i = 0; i < n; i++) {
trcprin1(oldsp[i]);
if (i < n - 1) trcputstr(" ");
}
trcputstr("\n");
/* restore the results and the stack */
for (i = 0; i < n; i++)
xlresults[i] = oldsp[i];
xlnumresults = n;
xlsp = oldsp;
/* unbind the symbols - L. Tierney */
xlunbind(olddenv);
#else
int i;
LVAL olddenv;
/* indent to the current trace level */
--xltrcindent;
for (i = 0; i < xltrcindent; ++i)
trcputstr(" ");
/* rebind tracelist during printing - L. Tierney */
olddenv = xldenv;
xldbind(s_tracelist,NIL);
/* display the function value */
sprintf(buf,"Exiting: %s, Value: ",
getstring(getpname(consp(sym)?car(cdr(sym)):sym)));
trcputstr(buf);
trcprin1(val);
trcputstr("\n");
/* unbind the symbols - L. Tierney */
xlunbind(olddenv);
#endif /* MULVALS */
}
/* member - is 'x' a member of 'list'? */
LOCAL int member P2C(LVAL, x, LVAL, list)
{
for (; consp(list); list = cdr(list))
if (x == car(list))
return (TRUE);
return (FALSE);
}
#ifndef XLISP_STAT
/* member2 - is '(x y)' a member of 'list'? */
LOCAL LVAL member2(x, y,list)
LVAL x, y, list;
{
LVAL cl;
for (; consp(list); list = cdr(list))
if (consp((cl=car(list))) && x == car(cl) && y == car(cdr(cl)))
return (cl);
return (NIL);
}
#endif /* XLISP_STAT */
/* xlunbound - signal an unbound variable error */
VOID xlunbound P1C(LVAL, sym)
{
#ifdef CONDITIONS
if (! null(getvalue(s_condition_hook)))
xlcondunbound(s_unboundvar, sym);
else
#endif /* CONDITIONS */
xlcerror("try evaluating symbol again","unbound variable",sym);
}
/* xlfunbound - signal an unbound function error */
VOID xlfunbound P1C(LVAL, sym)
{
#ifdef CONDITIONS
if (! null(getvalue(s_condition_hook)))
xlcondunbound(s_unboundfun, sym);
else
#endif /* CONDITIONS */
xlcerror("try evaluating symbol again","unbound function",sym);
}
/* xlstkoverflow - signal a stack overflow error */
VOID xlstkoverflow(V)
{
xlabort("evaluation stack overflow");
}
/* xlargstkoverflow - signal an argument stack overflow error */
VOID xlargstkoverflow(V)
{
xlabort("argument stack overflow");
}
/* badarglist - report a bad argument list error */
LOCAL VOID badarglist(V)
{
xlfail("bad formal argument list");
}
#ifdef CONDITIONS
LOCAL VOID xlcondunbound P2C(LVAL, type, LVAL, sym)
{
FRAMEP newfp, fp;
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(getvalue(s_condition_hook));
pusharg(cvfixnum((FIXTYPE) 7));
pusharg(s_cerror);
fp = null(xlfp[0]) ? xlfp : xlfp - getfixnum(*xlfp);
pusharg(null(fp[0]) ? NIL : cvfixnum((FIXTYPE) (fp - xlargstkbase)));
pusharg(cons(xlenv,xlfenv));
pusharg(cvstring("Try evaluating the symbol ~*~s again."));
pusharg(type);
pusharg(k_name);
pusharg(sym);
/* establish the new stack frame */
xlfp = newfp;
/* apply the function */
xlapply(7);
}
#endif /* CONDITIONS */
syntax highlighted by Code2HTML, v. 0.9.1