/* Internal version of Common Lisp MAP function */
LOCAL LVAL map P4C(LVAL, type, LVAL, fcn, LVAL, args, int, rlen)
{
LVAL nextr, result;
int nargs, i;
/* protect some pointers */
xlstkcheck(2);
xlsave(result);
xlprotect(fcn);
if (rlen < 0) rlen = findmaprlen(args);
if (type == a_vector)
result = newvector(rlen);
else
result = mklist(rlen, NIL);
nargs = llength(args);
for (i = 0, nextr = result; i < rlen; i++) {
pushnextargs(fcn, nargs, args, i);
setnextelement(&nextr, i, xlapply(nargs));
}
/* restore the stack frame */
xlpopn(2);
return(result);
}
/* evalhook - call the evalhook function */
LOCAL LVAL evalhook(LVAL expr)
{
LVAL *newfp,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);
}
/* evalhook - call the evalhook function */
LOCAL NODE *evalhook(NODE *expr)
{
NODE ***oldstk,*ehook __HEAPIFY,*ahook __HEAPIFY,*args __HEAPIFY,*val;
/* create a new stack frame */
oldstk = xlsave3(&ehook,&ahook,&args);
/* make an argument list */
args = consa(expr);
rplacd(args,consa(xlenv));
/* rebind the hook functions to nil */
ehook = getvalue(s_evalhook);
setvalue(s_evalhook,NIL);
ahook = getvalue(s_applyhook);
setvalue(s_applyhook,NIL);
/* call the hook function */
val = xlapply(ehook,args);
/* unbind the symbols */
setvalue(s_evalhook,ehook);
setvalue(s_applyhook,ahook);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* dotest2 - call a test function with two arguments */
int dotest2 P3C(LVAL, arg1, LVAL, arg2, LVAL, fun)
{
FRAMEP newfp;
/* Speedup for default case TAA MOD */
if (fun == getfunction(s_eql))
return (eql(arg1,arg2));
/* Speedup for EQ and EQUAL for hash tables */
if (fun == getfunction(s_eq))
return (arg1 == arg2);
if (fun == getfunction(s_equal))
return (equal(arg1,arg2));
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(arg1);
pusharg(arg2);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(2) != NIL);
}
/* :DO-ACTION Method */
LVAL xsitem_do_action(V)
{
LVAL item, action, result;
item = xsgetmenuitem();
xllastarg();
action = slot_value(item, s_action);
result = (action != NIL) ? xlapply(pushargs(action, NIL)) : NIL;
return(result);
}
/* xapply - the built-in function 'apply' */
LVAL xapply(void)
{
LVAL fun,arglist;
/* get the function and argument list */
fun = xlgetarg();
arglist = xlgalist();
xllastarg();
/* apply the function to the arguments */
return (xlapply(pushargs(fun,arglist)));
}
/* callmacro - call a read macro */
LVAL callmacro(LVAL fptr, int ch)
{
LVAL *newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(cdr(getelement(getvalue(s_rtable),ch)));
pusharg(cvfixnum((FIXTYPE)2));
pusharg(fptr);
pusharg(cvchar(ch));
xlfp = newfp;
return (xlapply(2));
}
/* dotest1 - call a test function with one argument */
int dotest1(LVAL arg, LVAL fun)
{
LVAL *newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)1));
pusharg(arg);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(1) != NIL);
}
/* xlapp1 - apply a function of a single argument */
LVAL xlapp1 P2C(LVAL, fun, LVAL, arg)
{
FRAMEP newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)1));
pusharg(arg);
xlfp = newfp;
/* return the result of applying the function */
return xlapply(1);
}
/* dotest1 - call a test function with one argument */
int dotest1 P3C(LVAL, arg, LVAL, fun, LVAL, kfun)
{
FRAMEP newfp;
if (kfun != NIL) arg = xlapp1(kfun,arg);
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)1));
pusharg(arg);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(1) != NIL);
}
/* xfuncall - the built-in function 'funcall' */
LVAL xfuncall(void)
{
LVAL *newfp;
int argc;
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(xlgetarg());
pusharg(NIL); /* will be argc */
/* push each argument */
for (argc = 0; moreargs(); ++argc)
pusharg(nextarg());
/* establish the new stack frame */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
/* apply the function to the arguments */
return (xlapply(argc));
}
/* map - internal mapping function */
LOCAL LVAL map(int carflag, int valflag)
{
LVAL *newfp,fun,lists,val,last,p,x,y;
int argc;
/* protect some pointers */
xlstkcheck(3);
xlsave(fun);
xlsave(lists);
xlsave(val);
/* get the function to apply and the first list */
fun = xlgetarg();
lists = xlgalist();
/* initialize the result list */
val = (valflag ? NIL : lists);
/* build a list of argument lists */
for (lists = last = consa(lists); moreargs(); last = cdr(last))
rplacd(last,cons(xlgalist(),NIL));
/* loop through each of the argument lists */
for (;;) {
/* build an argument list from the sublists */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(NIL);
argc = 0;
for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
pusharg(carflag ? car(y) : y);
rplaca(x,cdr(y));
++argc;
}
/* quit if any of the lists were empty */
if (x) {
xlsp = newfp;
break;
}
/* apply the function to the arguments */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
if (valflag) {
p = consa(xlapply(argc));
if (val) rplacd(last,p);
else val = p;
last = p;
}
else
xlapply(argc);
}
/* restore the stack */
xlpopn(3);
/* return the last test expression value */
return (val);
}
/* gc - garbage collect (only called here and in xlimage.c) */
void gc(void)
{
register LVAL **p,*ap,tmp;
char buf[STRMAX+1];
LVAL *newfp,fun;
extern LVAL profile_fixnum;
/* print the start of the gc message */
if (s_gcflag && getvalue(s_gcflag)) {
sprintf(buf,"[ gc: total %ld, ",nnodes);
stdputstr(buf);
}
/* mark the fixnum used by profiler */
if (!null(profile_fixnum)) mark(profile_fixnum);
/* mark the obarray, the argument list and the current environment */
if (obarray)
mark(obarray);
if (xlenv)
mark(xlenv);
if (xlfenv)
mark(xlfenv);
if (xldenv)
mark(xldenv);
/* mark the evaluation stack */
for (p = xlstack; p < xlstktop; ++p)
if (tmp = **p)
mark(tmp);
/* mark the argument stack */
for (ap = xlargstkbase; ap < xlsp; ++ap)
if (tmp = *ap)
mark(tmp);
/* sweep memory collecting all unmarked nodes */
sweep();
/* count the gc call */
++gccalls;
/* call the *gc-hook* if necessary */
if (s_gchook && (fun = getvalue(s_gchook))) {
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(cvfixnum((FIXTYPE)nnodes));
pusharg(cvfixnum((FIXTYPE)nfree));
xlfp = newfp;
xlapply(2);
}
/* print the end of the gc message */
if (s_gcflag && getvalue(s_gcflag)) {
sprintf(buf,"%ld free", nfree);
stdputstr(buf);
/* print additional info (e.g. sound blocks in Nyquist) */
print_local_gc_info();
stdputstr(" ]\n");
}
}