/* evform - evaluate a form */
LOCAL NODE *evform(NODE *expr)
{
NODE ***oldstk,*fun __HEAPIFY,*args __HEAPIFY,*env,*val,*type;
val = 0; //BUG: uninitialized variable is used if xlfail returns
/* create a stack frame */
oldstk = xlsave2(&fun,&args);
/* get the function and the argument list */
fun = car(expr);
args = cdr(expr);
/* evaluate the first expression */
if ((fun = xleval(fun)) == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun) || fsubrp(fun)) {
if (subrp(fun))
args = xlevlist(args);
val = (*getsubr(fun))(args);
}
else if (consp(fun)) {
if (consp(car(fun))) {
env = cdr(fun);
fun = car(fun);
}
else
env = xlenv;
if ((type = car(fun)) == s_lambda) {
args = xlevlist(args);
val = evfun(fun,args,env);
}
else if (type == s_macro) {
args = evfun(fun,args,env);
val = xleval(args);
}
else
xlfail("bad function type");
}
else if (objectp(fun))
val = xlsend(fun,args);
else
xlfail("bad function");
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xlapply - apply a function to a list of arguments */
NODE *xlapply(NODE *fun,NODE *args)
{
NODE *env,*val;
val = 0; //BUG: uninitialized variable is used if xlfail returns
/* check for a null function */
if (fun == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun))
val = (*getsubr(fun))(args);
else if (consp(fun)) {
if (consp(car(fun))) {
env = cdr(fun);
fun = car(fun);
}
else
env = xlenv;
if (car(fun) != s_lambda)
xlfail("bad function type");
val = evfun(fun,args,env);
}
else
xlfail("bad function");
/* return the result value */
return (val);
}
/* macroexpand - expand a macro call */
int macroexpand(LVAL fun, LVAL args, LVAL *pval)
{
LVAL *argv;
int argc;
/* make sure it's really a macro call */
if (!closurep(fun) || gettype(fun) != s_macro)
return (FALSE);
/* call the expansion function */
argc = pushargs(fun,args);
argv = xlfp + 3;
*pval = evfun(fun,argc,argv);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
return (TRUE);
}
/* xlapply - apply a function to arguments (already on the stack) */
LVAL xlapply(int argc)
{
LVAL *oldargv,fun,val;
LVAL funname;
LVAL old_profile_fixnum = profile_fixnum;
FIXTYPE *old_profile_count_ptr = profile_count_ptr;
int oldargc;
/* get the function */
fun = xlfp[1];
/* get the functional value of symbols */
if (symbolp(fun)) {
funname = fun; /* save it */
while ((val = getfunction(fun)) == s_unbound)
xlfunbound(fun);
fun = xlfp[1] = val;
if (profile_flag && atomp(funname)) {
LVAL profile_prop = findprop(funname, s_profile);
if (null(profile_prop)) {
/* make a new fixnum, don't use cvfixnum because
it would return shared pointer to zero, but we
are going to modify this integer in place --
dangerous but efficient.
*/
profile_fixnum = newnode(FIXNUM);
profile_fixnum->n_fixnum = 0;
setplist(funname, cons(s_profile,
cons(profile_fixnum,
getplist(funname))));
setvalue(s_profile, cons(funname, getvalue(s_profile)));
} else profile_fixnum = car(profile_prop);
profile_count_ptr = &getfixnum(profile_fixnum);
}
}
/* check for nil */
if (null(fun))
xlerror("bad function",fun);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
oldargc = xlargc;
oldargv = xlargv;
xlargc = argc;
xlargv = xlfp + 3;
val = (*getsubr(fun))();
xlargc = oldargc;
xlargv = oldargv;
break;
case CONS:
if (!consp(cdr(fun)))
xlerror("bad function",fun);
if (car(fun) == s_lambda) {
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
} else
xlerror("bad function",fun);
/**** fall through into the next case ****/
case CLOSURE:
if (gettype(fun) != s_lambda)
xlerror("bad function",fun);
val = evfun(fun,argc,xlfp+3);
break;
default:
xlerror("bad function",fun);
}
/* restore original profile counting state */
profile_fixnum = old_profile_fixnum;
profile_count_ptr = old_profile_count_ptr;
/* remove the call frame */
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
/* return the function value */
return (val);
}
/* evform - evaluate a form */
LOCAL LVAL evform(LVAL form)
{
LVAL fun,args,val,type;
LVAL tracing=NIL;
LVAL *argv;
LVAL old_profile_fixnum = profile_fixnum;
FIXTYPE *old_profile_count_ptr = profile_count_ptr;
LVAL funname;
int argc;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
(*profile_count_ptr)++; /* increment profile counter */
/* get the function and the argument list */
fun = car(form);
args = cdr(form);
funname = fun;
/* get the functional value of symbols */
if (symbolp(fun)) {
if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
tracing = fun;
fun = xlgetfunction(fun);
}
/* check for nil */
if (null(fun))
xlerror("bad function",NIL);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
argv = xlargv;
argc = xlargc;
xlargc = evpushargs(fun,args);
xlargv = xlfp + 3;
trenter(tracing,xlargc,xlargv);
val = (*getsubr(fun))();
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))();
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case CONS:
if (!consp(cdr(fun)))
xlerror("bad function",fun);
if ((type = car(fun)) == s_lambda)
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
else
xlerror("bad function",fun);
/**** fall through into the next case ****/
case CLOSURE:
/* do profiling */
if (profile_flag && atomp(funname)) {
LVAL profile_prop = findprop(funname, s_profile);
if (null(profile_prop)) {
/* make a new fixnum, don't use cvfixnum because
it would return shared pointer to zero, but we
are going to modify this integer in place --
dangerous but efficient.
*/
profile_fixnum = newnode(FIXNUM);
profile_fixnum->n_fixnum = 0;
setplist(funname, cons(s_profile,
cons(profile_fixnum,
getplist(funname))));
setvalue(s_profile, cons(funname, getvalue(s_profile)));
} else profile_fixnum = car(profile_prop);
profile_count_ptr = &getfixnum(profile_fixnum);
}
if (gettype(fun) == s_lambda) {
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 {
macroexpand(fun,args,&fun);
val = xleval(fun);
}
profile_fixnum = old_profile_fixnum;
profile_count_ptr = old_profile_count_ptr;
break;
default:
xlerror("bad function",fun);
}
/* restore the stack */
xlpopn(2);
/* return the result value */
return (val);
}