/* clisnew - initialize a new class */
LVAL clisnew(void)
{
LVAL self,ivars,cvars,super;
int n;
/* get self, the ivars, cvars and superclass */
self = xlgaobject();
ivars = xlgalist();
cvars = (moreargs() ? xlgalist() : NIL);
super = (moreargs() ? xlgaobject() : object);
xllastarg();
/* store the instance and class variable lists and the superclass */
setivar(self,IVARS,ivars);
setivar(self,CVARS,cvars);
setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
setivar(self,SUPERCLASS,super);
/* compute the instance variable count */
n = listlength(ivars);
setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
n += getivcnt(super,IVARTOTAL);
setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
/* return the new class object */
return (self);
}
/* xendp - is this the end of a list? */
LVAL xendp(void)
{
LVAL arg;
arg = xlgalist();
xllastarg();
return (null(arg) ? s_true : NIL);
}
/* xcdr - built-in function 'cdr' */
LVAL xcdr()
{
LVAL arg;
arg = xlgalist();
xllastarg();
return (arg ? cdr(arg) : NIL);
}
/* xsort - built-in function 'sort' */
LVAL xsort(void)
{
LVAL sortlist();
LVAL list,fcn;
/* protect some pointers */
xlstkcheck(2);
xlsave(list);
xlsave(fcn);
/* get the list to sort and the comparison function */
list = xlgalist();
fcn = xlgetarg();
xllastarg();
/* sort the list */
list = sortlist(list,fcn);
if (list && (ntype(list) == FREE_NODE)) {
stdputstr("error in sort 2");
}
/* restore the stack and return the sorted list */
xlpopn(2);
return (list);
}
LVAL Native_Throw()
{
LVAL pXData, pXDests;
TVeosErr iErr;
#ifndef OPTIMAL
if (!KERNEL_INIT)
Native_TrapErr(NATIVE_NOKERNEL, nil);
#endif
/** get dests argument **/
pXDests = xlgalist();
/** get data argument **/
pXData = xlgetarg();
#ifndef OPTIMAL
xllastarg();
#endif
iErr = Native_DoThrow(pXDests, pXData);
return(iErr == VEOS_SUCCESS ? true : NIL);
} /* Native_Throw */
/* remif - common code for 'remove-if' and 'remove-if-not' */
LOCAL LVAL remif(int tresult)
{
LVAL list,fcn,val,last=NULL,next;
/* protect some pointers */
xlstkcheck(2);
xlsave(fcn);
xlsave(val);
/* get the expression to remove and the list */
fcn = xlgetarg();
list = xlgalist();
xllastarg();
/* remove matches */
for (; consp(list); list = cdr(list))
/* check to see if this element should be deleted */
if (dotest1(car(list),fcn) != tresult) {
next = consa(car(list));
if (val) rplacd(last,next);
else val = next;
last = next;
}
/* restore the stack */
xlpopn(2);
/* return the updated list */
return (val);
}
/* xmember - built-in function 'member' */
LVAL xmember(void)
{
LVAL x,list,fcn,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the list */
x = xlgetarg();
list = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(list); list = cdr(list))
if (dotest2(x,car(list),fcn) == tresult) {
val = list;
break;
}
/* restore the stack */
xlpop();
/* return the result */
return (val);
}
/* xcdr - take the cdr of a cons cell */
LVAL xcdr(void)
{
LVAL list;
list = xlgalist();
xllastarg();
return (list ? cdr(list) : NIL);
}
/* xassoc - built-in function 'assoc' */
LVAL xassoc(void)
{
LVAL x,alist,fcn,pair,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the association list */
x = xlgetarg();
alist = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest2(x,car(pair),fcn) == tresult) {
val = pair;
break;
}
/* restore the stack */
xlpop();
/* return result */
return (val);
}
/* xcar - built-in function 'car' */
LVAL xcar()
{
LVAL list;
list = xlgalist();
xllastarg();
return (list ? car(list) : NIL);
}
/* 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)));
}
/* clanswer - define a method for answering a message */
LVAL clanswer(void)
{
LVAL self,msg,fargs,code,mptr;
/* message symbol, formal argument list and code */
self = xlgaobject();
msg = xlgasymbol();
fargs = xlgalist();
code = xlgalist();
xllastarg();
/* make a new message list entry */
mptr = entermsg(self,msg);
/* setup the message node */
xlprot1(fargs);
fargs = cons(s_self,fargs); /* add 'self' as the first argument */
rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL));
xlpop();
/* return the object */
return (self);
}
/* xlast - return the last cons of a list */
LVAL xlast(void)
{
LVAL list;
/* get the list */
list = xlgalist();
xllastarg();
/* find the last cons */
while (consp(list) && cdr(list))
list = cdr(list);
/* return the last element */
return (list);
}
/* xdelete - built-in function 'delete' */
LVAL xdelete(void)
{
LVAL x,list,fcn,last,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to delete and the list */
x = xlgetarg();
list = xlgalist();
xltest(&fcn,&tresult);
/* delete leading matches */
while (consp(list)) {
if (dotest2(x,car(list),fcn) != tresult)
break;
list = cdr(list);
}
val = last = list;
/* delete embedded matches */
if (consp(list)) {
/* skip the first non-matching element */
list = cdr(list);
/* look for embedded matches */
while (consp(list)) {
/* check to see if this element should be deleted */
if (dotest2(x,car(list),fcn) == tresult)
rplacd(last,cdr(list));
else
last = list;
/* move to the next element */
list = cdr(list);
}
}
/* restore the stack */
xlpop();
/* return the updated list */
return (val);
}
/* xevalhook - eval hook function */
LVAL xevalhook(void)
{
LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
/* protect some pointers */
xlstkcheck(3);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(newenv);
/* get the expression, the new hook functions and the environment */
expr = xlgetarg();
newehook = xlgetarg();
newahook = xlgetarg();
newenv = (moreargs() ? xlgalist() : NIL);
xllastarg();
/* bind *evalhook* and *applyhook* to the hook functions */
olddenv = xldenv;
xldbind(s_evalhook,newehook);
xldbind(s_applyhook,newahook);
/* establish the environment for the hook function */
if (newenv) {
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = car(newenv);
xlfenv = cdr(newenv);
}
/* evaluate the expression (bypassing *evalhook*) */
val = xlxeval(expr);
/* restore the old environment */
xlunbind(olddenv);
if (newenv) {
xlenv = oldenv;
xlfenv = oldfenv;
}
/* restore the stack */
xlpopn(3);
/* return the result */
return (val);
}
/* cxr - common car/cdr routine */
LOCAL LVAL cxr(char *adstr)
{
LVAL list;
/* get the list */
list = xlgalist();
xllastarg();
/* perform the car/cdr operations */
while (*adstr && consp(list))
list = (*adstr++ == 'a' ? car(list) : cdr(list));
/* make sure the operation succeeded */
if (*adstr && list)
xlfail("bad argument");
/* return the result */
return (list);
}
/* xreverse - built-in function reverse */
LVAL xreverse(void)
{
LVAL list,val;
/* protect some pointers */
xlsave1(val);
/* get the list to reverse */
list = xlgalist();
xllastarg();
/* append each element to the head of the result list */
for (val = NIL; consp(list); list = cdr(list))
val = cons(car(list),val);
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xsublis - substitute using an association list */
LVAL xsublis(void)
{
LVAL alist,expr,fcn,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the assocation list and the expression */
alist = xlgalist();
expr = xlgetarg();
xltest(&fcn,&tresult);
/* do the substitution */
val = sublis(alist,expr,fcn,tresult);
/* restore the stack */
xlpop();
/* return the result */
return (val);
}
/* 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);
}