/* xllist.c - xlisp built-in list functions */
/* 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"
struct nsubargs { /* TAA added 7/93 */
LVAL to; /* and ALIST */
LVAL from;
LVAL fcn;
#ifdef KEYARG
LVAL kfcn;
#endif
int tresult;
int expr;
int subst;
};
struct substargs { /* TAA MOD - 7/93 to reduce stack usage */
LVAL to;
LVAL from;
LVAL fcn;
#ifdef KEYARG
LVAL kfcn;
#endif
int tresult;
};
struct sublargs { /* TAA MOD - 7/93 to reduce stack usage */
LVAL alist;
LVAL fcn;
#ifdef KEYARG
LVAL kfcn;
#endif
int tresult;
};
/* forward declarations */
LOCAL LVAL cxr P1H(char *);
LOCAL LVAL nth P1H(int);
LOCAL LVAL subst P2H(LVAL, struct substargs *);
LOCAL LVAL sublis P2H(LVAL, struct sublargs *);
#ifdef KEYARG
LOCAL LVAL assoc P5H(LVAL, LVAL, LVAL, LVAL, int);
LOCAL LVAL membr P5H(LVAL, LVAL, LVAL, LVAL, int);
#else
LOCAL LVAL assoc P4H(LVAL, LVAL, LVAL, int);
LOCAL LVAL membr P4H(LVAL, LVAL, LVAL, int);
#endif
LOCAL LVAL nsub P3H(int, int, int);
LOCAL VOID nsub1 P2H(LVAL *, struct nsubargs *);
LOCAL LVAL map P2H(int, int);
LOCAL LVAL set_op P1H(int);
/* xlcircular -- circular list error */
VOID xlcircular(V)
{
xlfail("circular list");
}
/* xcar - take the car of a cons cell */
LVAL xcar(V)
{
LVAL list;
list = xlgalist();
xllastarg();
return (null(list) ? NIL : car(list));
}
/* xcdr - take the cdr of a cons cell */
LVAL xcdr(V)
{
LVAL list;
list = xlgalist();
xllastarg();
return (null(list) ? NIL : cdr(list));
}
/* cxxr functions */
LVAL xcaar(V) { return (cxr("aa")); }
LVAL xcadr(V) { return (cxr("da")); }
LVAL xcdar(V) { return (cxr("ad")); }
LVAL xcddr(V) { return (cxr("dd")); }
/* cxxxr functions */
LVAL xcaaar(V) { return (cxr("aaa")); }
LVAL xcaadr(V) { return (cxr("daa")); }
LVAL xcadar(V) { return (cxr("ada")); }
LVAL xcaddr(V) { return (cxr("dda")); }
LVAL xcdaar(V) { return (cxr("aad")); }
LVAL xcdadr(V) { return (cxr("dad")); }
LVAL xcddar(V) { return (cxr("add")); }
LVAL xcdddr(V) { return (cxr("ddd")); }
/* cxxxxr functions */
LVAL xcaaaar(V) { return (cxr("aaaa")); }
LVAL xcaaadr(V) { return (cxr("daaa")); }
LVAL xcaadar(V) { return (cxr("adaa")); }
LVAL xcaaddr(V) { return (cxr("ddaa")); }
LVAL xcadaar(V) { return (cxr("aada")); }
LVAL xcadadr(V) { return (cxr("dada")); }
LVAL xcaddar(V) { return (cxr("adda")); }
LVAL xcadddr(V) { return (cxr("ddda")); }
LVAL xcdaaar(V) { return (cxr("aaad")); }
LVAL xcdaadr(V) { return (cxr("daad")); }
LVAL xcdadar(V) { return (cxr("adad")); }
LVAL xcdaddr(V) { return (cxr("ddad")); }
LVAL xcddaar(V) { return (cxr("aadd")); }
LVAL xcddadr(V) { return (cxr("dadd")); }
LVAL xcdddar(V) { return (cxr("addd")); }
LVAL xcddddr(V) { return (cxr("dddd")); }
/* cxr - common car/cdr routine */
LOCAL LVAL cxr P1C(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 && !null(list))
xlfail("bad argument");
/* return the result */
return (list);
}
/* xcons - construct a new list cell */
LVAL xcons(V)
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* construct a new list element */
return (cons(arg1,arg2));
}
/* xlist - built a list of the arguments */
/* Rewritten by TAA for compactness and speed */
LVAL xlist(V)
{
LVAL val;
int i=xlargc;
/* protect a pointer */
xlsave1(val);
/* do the work */
while (i-- > 0)
val = cons(xlargv[i],val);
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xliststar - built a list of the arguments */
/* by TAA */
LVAL xliststar(V)
{
LVAL val;
int i=xlargc;
if (i==0) xltoofew(); /* must have at least one argument */
/* protect a pointer */
xlprot1(val);
/* last argument is list tail */
val = xlargv[--i];
/* do the work */
while (i-- > 0)
val = cons(xlargv[i],val);
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xbutlast -- copy list for all but last n */
/* Added function TAA */
LVAL xbutlast(V)
{
LVAL val,list,last,next;
FIXTYPE n=1,l=0;
/* get argument(s) */
list = xlgalist();
if (moreargs()) {
n = getfixnum(next=xlgafixnum());
if (n<0) xlerror("bad index",next);
xllastarg();
}
/* get length */
for (next=list; consp(next);) {
next=cdr(next);
l++;
if (l > nnodes) xlcircular();
}
/* calc final length */
l-=n;
if (l <= 0) return (NIL); /* nothing left */
/* do the first cons */
val = consa(car(list));
if (l-- == 1) return val;
/* protect a pointer */
xlprot1(val);
/* do remaining conses */
last = val;
while (l-- > 0) {
list = cdr(list);
next = consa(car(list));
rplacd(last,next);
last = next;
}
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xappend - built-in function append */
LVAL xappend(V)
{
LVAL list,last=NIL,next,val;
long n;
/* protect some pointers */
xlsave1(val);
/* append each argument */
if (moreargs()) {
while (xlargc > 1) {
/* check for circular list (Added 5/6/94) */
next = list = nextarg();
for (n = 0; consp(next); next=cdr(next)) {
if (n++ > nnodes) xlcircular(); /*DIRTY, but we loose anyway!*/
}
/* append each element of this list to the result list */
for (; consp(list); list = cdr(list)) {
next = consa(car(list));
if (!null(val)) rplacd(last,next);
else val = next;
last = next;
}
if (!null(list)) xlbadtype(*--xlargv); /*TAA added errormessage*/
}
/* handle the last argument */
if (!null(val)) rplacd(last,nextarg());
else val = nextarg();
}
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xlast - return the last cons of a list */
LVAL xlast(V)
{
LVAL list;
long l=0;
/* get the list */
list = xlgalist();
xllastarg();
/* find the last cons */
if (consp(list)) /* TAA fix */
while (consp(cdr(list))) {
list = cdr(list);
if (l++ > nnodes) xlcircular();
}
/* return the last element */
return (list);
}
/* xmember - built-in function 'member' */
LVAL xmember(V)
{
LVAL x,list,slist,fcn,val;
int tresult;
#ifdef KEYARG
LVAL kfcn;
/* protect some pointers */
xlstkcheck(2);
xlsave(fcn);
xlsave(kfcn);
#else
/* protect some pointers */
xlsave1(fcn);
#endif
/* get the expression to look for and the list */
x = xlgetarg();
slist = list = xlgalist();
xltest(&fcn,&tresult);
#ifdef KEYARG
kfcn = xlkey();
#endif
xllastkey();
/* look for the expression */
for (val = NIL; consp(list); list = cdr(list), slist = cdr(slist)) {
/* do a pair per iteration */
#ifdef KEYARG
if (dotest2(x,car(list),fcn,kfcn) == tresult)
#else
if (dotest2(x,car(list),fcn) == tresult)
#endif
{
val = list;
break;
}
if (!consp(list = cdr(list))) break;
#ifdef KEYARG
if (dotest2(x,car(list),fcn,kfcn) == tresult)
#else
if (dotest2(x,car(list),fcn) == tresult)
#endif
{
val = list;
break;
}
if (list == slist) /* list must be circular, and no match */
xlerror("not a proper list", car (list));
}
/* restore the stack */
#ifdef KEYARG
xlpopn(2);
#else
xlpop();
#endif
/* return the result */
return (val);
}
/* xassoc - built-in function 'assoc' */
LVAL xassoc(V)
{
LVAL x,alist,slist,fcn,pair,val;
int tresult;
#ifdef KEYARG
LVAL kfcn;
/* protect some pointers */
xlstkcheck(2);
xlsave(fcn);
xlsave(kfcn);
#else
/* protect some pointers */
xlsave1(fcn);
#endif
/* get the expression to look for and the association list */
x = xlgetarg();
slist = alist = xlgalist();
xltest(&fcn,&tresult);
#ifdef KEYARG
kfcn = xlkey();
#endif
xllastkey();
/* look for the expression */
for (val = NIL; consp(alist); alist = cdr(alist), slist = cdr(slist)) {
/* do two iterations per loop */
if ((!null(pair = car(alist))) && consp(pair))
#ifdef KEYARG
if (dotest2(x,car(pair),fcn,kfcn) == tresult)
#else
if (dotest2(x,car(pair),fcn) == tresult)
#endif
{
val = pair;
break;
}
if (!consp(alist = cdr(alist))) break;
if ((!null(pair = car(alist))) && consp(pair))
#ifdef KEYARG
if (dotest2(x,car(pair),fcn,kfcn) == tresult)
#else
if (dotest2(x,car(pair),fcn) == tresult)
#endif
{
val = pair;
break;
}
if (slist == alist) break; /* circular alist */
}
/* restore the stack */
#ifdef KEYARG
xlpopn(2);
#else
xlpop();
#endif
/* return result */
return (val);
}
/* xnsubst,xnsublis - destructive versions of subst and sublis */
/* ADDED 7/93 */
LOCAL VOID nsub1 P2C(LVAL *, tree, struct nsubargs *, args)
{
LVAL pair = NULL;
FIXTYPE n=0;
tailrecursion:
#ifdef KEYARG
if (args->subst?
(args->expr?
(dotest2(args->from,*tree,args->fcn,args->kfcn)==args->tresult):
(dotest1(*tree, args->fcn, args->kfcn)==args->tresult)) :
!null(pair=assoc(args->kfcn!=NIL?xlapp1(args->kfcn,*tree):*tree,args->to,args->fcn,NIL,args->tresult)))
#else
if (args->subst?
(args->expr?
(dotest2(args->from,*tree,args->fcn)==args->tresult):
(dotest1(*tree, args->fcn)==args->tresult)) :
!null(pair=assoc(*tree,args->to,args->fcn,args->tresult)))
#endif
{
*tree = (args->subst ? args->to : cdr(pair));
}
else if (consp(*tree)) {
#ifdef STSZ /* This function is a good candidate for stack ov */
stchck();
#endif
nsub1(&car(*tree), args);
tree = &cdr(*tree);
if (++n > nnodes)
xlfail("circular list"); /* only the tip of the iceburg */
goto tailrecursion;
}
else return;
}
LOCAL LVAL nsub P3C(int, subst, int, tresult, int, expr)
{
struct nsubargs args;
LVAL tree;
/* protect some pointers */
#ifdef KEYARG
xlstkcheck(2);
xlsave(args.fcn);
xlsave(args.kfcn);
#else
xlsave1(args.fcn);
#endif
args.subst = subst;
args.tresult = tresult;
args.expr = expr;
if (expr) { /* get the expressions and the tree */
args.to = xlgetarg();
if (subst) args.from = xlgetarg();
tree = xlgetarg();
xltest(&args.fcn, &args.tresult);
}
else {
/* get the result expression, the function and the tree */
args.to = xlgetarg();
args.fcn = xlgetarg();
tree = xlgetarg();
}
#ifdef KEYARG
args.kfcn = xlkey();
#endif
xllastkey();
nsub1(&tree, &args);
#ifdef KEYARG
xlpopn(2);
#else
xlpop();
#endif
return (tree);
}
LVAL xnsubst(V) { return nsub(TRUE, TRUE, TRUE);}
LVAL xnsubstif(V) { return nsub(TRUE, TRUE, FALSE); }
LVAL xnsubstifnot(V) { return nsub(TRUE, FALSE, FALSE); }
LVAL xnsublis(V) { return nsub(FALSE, TRUE, TRUE);}
/* xsubst - substitute one expression for another */
LVAL xsubst(V)
{
struct substargs args;
LVAL expr;
/* protect some pointers */
#ifdef KEYARG
xlstkcheck(2);
xlsave(args.fcn);
xlsave(args.kfcn);
#else
xlsave1(args.fcn);
#endif
/* get the to value, the from value and the expression */
args.to = xlgetarg();
args.from = xlgetarg();
expr = xlgetarg();
xltest(&args.fcn,&args.tresult);
#ifdef KEYARG
args.kfcn = xlkey();
#endif
xllastkey();
/* do the substitution */
expr = subst(expr,&args);
/* restore the stack */
#ifdef KEYARG
xlpopn(2);
#else
xlpop();
#endif
/* return the result */
return (expr);
}
/* subst - substitute one expression for another */
LOCAL LVAL subst P2C(LVAL, expr, struct substargs *, args)
{
LVAL carval,cdrval;
#ifdef KEYARG
if (dotest2(args->from,expr,args->fcn,args->kfcn) == args->tresult)
#else
if (dotest2(args->from,expr,args->fcn) == args->tresult)
#endif
return (args->to);
else if (consp(expr)) {
#ifdef STSZ /* This function is a good candidate for stack ov */
stchck();
#endif
xlsave1(carval);
carval = subst(car(expr),args);
cdrval = subst(cdr(expr),args);
xlpop();
/* the following TAA mod makes subst like COMMON LISP */
if ((carval == car(expr)) && (cdrval == cdr(expr)))
return expr; /* no change */
else
return (cons(carval,cdrval));
}
else
return (expr);
}
/* xsublis - substitute using an association list */
LVAL xsublis(V)
{
struct sublargs args;
LVAL expr;
/* protect some pointers */
#ifdef KEYARG
xlstkcheck(2);
xlsave(args.fcn);
xlsave(args.kfcn);
#else
xlsave1(args.fcn);
#endif
/* get the assocation list and the expression */
args.alist = xlgalist();
expr = xlgetarg();
xltest(&args.fcn,&args.tresult);
#ifdef KEYARG
args.kfcn = xlkey();
#endif
xllastkey();
/* do the substitution */
expr = sublis(expr,&args);
/* restore the stack */
#ifdef KEYARG
xlpopn(2);
#else
xlpop();
#endif
/* return the result */
return (expr);
}
/* sublis - substitute using an association list */
LOCAL LVAL sublis P2C(LVAL, expr, struct sublargs *, args)
{
LVAL carval,cdrval,pair;
#ifdef KEYARG
if (!null(pair = assoc(args->kfcn!=NIL?
xlapp1(args->kfcn,expr):
expr,
args->alist,
args->fcn,
NIL,
args->tresult)))
#else
if (!null(pair = assoc(expr,args->alist,args->fcn,args->tresult)))
#endif
return (cdr(pair));
else if (consp(expr)) {
#ifdef STSZ /* This function is a good candidate for stack ov */
stchck();
#endif
xlsave1(carval);
carval = sublis(car(expr),args);
cdrval = sublis(cdr(expr),args);
xlpop();
/* TAA MOD for making like common lisp */
if ((car(expr) == carval) && (cdr(expr) == cdrval))
return (expr);
else
return (cons(carval,cdrval));
}
else
return (expr);
}
/* assoc - find a pair in an association list */
#ifdef KEYARG
LOCAL LVAL assoc P5C(LVAL, expr, LVAL, alist, LVAL, fcn, LVAL, kfcn, int, tresult)
#else
LOCAL LVAL assoc P4C(LVAL, expr, LVAL, alist, LVAL, fcn, int, tresult)
#endif
{
LVAL pair;
for (; consp(alist); alist = cdr(alist))
if ((!null((pair = car(alist)))) && consp(pair))
#ifdef KEYARG
if (dotest2(expr,car(pair),fcn,kfcn) == tresult)
#else
if (dotest2(expr,car(pair),fcn) == tresult)
#endif
return (pair);
return (NIL);
}
/* xnth - return the nth element of a list */
LVAL xnth(V)
{
return (nth(TRUE));
}
/* xnthcdr - return the nth cdr of a list */
LVAL xnthcdr(V)
{
return (nth(FALSE));
}
/* nth - internal nth function */
LOCAL LVAL nth P1C(int, carflag)
{
LVAL list,num;
FIXTYPE n;
/* get n and the list */
num = xlgafixnum();
/* list = xlgacons(); */
list = xlgalist(); /* TAA fix */
xllastarg();
/* make sure the number isn't negative */
if ((n = getfixnum(num)) < 0)
xlfail("bad argument");
/* find the nth element */
while (consp(list) && --n >= 0)
list = cdr(list);
/* return the list beginning at the nth element */
return (carflag && consp(list) ? car(list) : list);
}
/* xlength - return the length of a list or string */
LVAL xlength(V)
{
FIXTYPE n = 0;
LVAL arg;
/* get the list or string */
arg = xlgetarg();
xllastarg();
/* find the length of a list */
if (listp(arg))
for (n = 0; consp(arg);) {
arg = cdr(arg);
n++;
if (n > nnodes) xlcircular(); /*DIRTY, but we loose anyway!*/
}
/* find the length of a string */
else if (stringp(arg))
n = (FIXTYPE)getslength(arg);
/* find the length of a typed vector */
else if (tvecp(arg))
n = (FIXTYPE)gettvecsize(arg);
/* find the length of a vector */
else if (vectorp(arg))
n = (FIXTYPE)getsize(arg);
/* otherwise, bad argument type */
else
xlbadtype(arg);
/* return the length */
return (cvfixnum(n));
}
/* xlistlength -- return the length of a list */
LVAL xlistlength(V)
{
FIXTYPE n = 0;
LVAL arg, sarg;
/* get the list */
arg = sarg = xlgalist();
xllastarg();
while (consp(arg)) {
arg = cdr(arg);
if (!consp(arg)) { n++; break; }
if (sarg == arg) return NIL; /* circular list */
arg = cdr(arg);
sarg = cdr(sarg);
n += 2;
}
/* return the length */
return (cvfixnum(n));
}
/* map - internal mapping function */
#define CONCAT 2 /* third choice for valflag */
LOCAL LVAL map P2C(int, carflag, int, valflag)
{
FRAMEP newfp;
LVAL fun,lists,val,last,p,x,y;
int argc;
long n=0, nmax=nnodes;
/* 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 */
argc = 1;
for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
argc++;
rplacd(last,cons(xlgalist(),NIL));
}
/* loop through each of the argument lists */
for (;;) {
if (n++ > nmax) xlcircular();
/* build an argument list from the sublists */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)argc));
for (x = lists; (consp(x)) && (consp(y = car(x))); x = cdr(x)) {
pusharg(carflag ? car(y) : y);
rplaca(x,cdr(y));
}
/* quit if any of the lists were empty */
if (!null(x)) {
xlsp = newfp;
break;
}
/* apply the function to the arguments */
xlfp = newfp;
switch (valflag) {
case CONCAT:
p = xlapply(argc);
if (!null(p)) {
if (!consp(p)) xlerror("non-list to concatenate", p);
if (null(val)) val = p;
else rplacd(last, p);
while (consp(cdr(p))) p = cdr(p); /* find end--no circular check */
last = p;
}
break;
case TRUE:
p = consa(xlapply(argc));
if (!null(val)) rplacd(last,p);
else val = p;
last = p;
break;
case FALSE:
xlapply(argc);
break;
}
}
/* restore the stack */
xlpopn(3);
/* return the last test expression value */
return (val);
}
/* xmapc - built-in function 'mapc' */
LVAL xmapc(V)
{
return (map(TRUE,FALSE));
}
/* xmapcar - built-in function 'mapcar' */
LVAL xmapcar(V)
{
return (map(TRUE,TRUE));
}
/* xmapl - built-in function 'mapl' */
LVAL xmapl(V)
{
return (map(FALSE,FALSE));
}
/* xmaplist - built-in function 'maplist' */
LVAL xmaplist(V)
{
return (map(FALSE,TRUE));
}
/* xmapcan - built-in function 'mapcan' */
LVAL xmapcan(V)
{
return (map(TRUE,CONCAT));
}
/* xmapcon - built-in function 'mapcon' */
LVAL xmapcon(V)
{
return (map(FALSE,CONCAT));
}
/* xrplca - replace the car of a list node */
LVAL xrplca(V)
{
LVAL list,newcar;
/* get the list and the new car */
list = xlgacons();
newcar = xlgetarg();
xllastarg();
/* replace the car */
rplaca(list,newcar);
/* return the list node that was modified */
return (list);
}
/* xrplcd - replace the cdr of a list node */
LVAL xrplcd(V)
{
LVAL list,newcdr;
/* get the list and the new cdr */
list = xlgacons();
newcdr = xlgetarg();
xllastarg();
/* replace the cdr */
rplacd(list,newcdr);
/* return the list node that was modified */
return (list);
}
/* xnconc - destructively append lists */
LVAL xnconc(V)
{
LVAL next,last=NIL,val=NIL;
long l; /* TAA MOD */
/* concatenate each argument */
if (moreargs()) {
while (xlargc > 1) {
/* TAA mod -- give error message if not a list */
if ((!null(next = nextarg())) && consp(next)) {
/* concatenate this list to the result list */
if (!null(val)) rplacd(last,next);
else val = next;
/* find the end of the list */
l = 0;
while (consp(cdr(next))) {
next = cdr(next);
if (l++ > nnodes) xlcircular();
}
last = next;
}
else if (!null(next)) xlbadtype(*--xlargv); /* TAA -- oops! */
}
/* handle the last argument */
if (!null(val)) rplacd(last,nextarg());
else val = nextarg();
}
/* return the list */
return (val);
}
/* xsort - built-in function 'sort' */
LOCAL LVAL xlmergesort P3C(LVAL, list, LVAL, sortfcn, LVAL, sortkey)
{
/* Strategy: divide into two parts, (recurse) to sort each, then
merge them together */
LVAL left, right;
/* less than 2 cells needn't be sorted */
if (!(consp(list) && consp(cdr(list))))
return list;
xlstkcheck(5); /* Only two are used at recursion */
xlprotect(left);
xlprotect(right);
/* Find the center of the list */
{
unsigned i=0;
LVAL temp = NULL;
left = right = list;
while (consp(list) && consp(list=cdr(list))) {
list = cdr(list);
right = cdr(temp=right);
if ((i += 2) > /*MAXSLEN*/ nnodes) xltoolong();
}
rplacd(temp, NIL); /* split left and right parts */
}
left = xlmergesort(left, sortfcn, sortkey);
right = xlmergesort(right, sortfcn, sortkey);
{
LVAL result, resultt = NULL, leftarg, rightarg;
xlsave(leftarg);
xlsave(rightarg);
xlsave(result); /* set to NIL */
leftarg = null(sortkey) ? car(left) : xlapp1(sortkey, car(left));
rightarg = null(sortkey) ? car(right) : xlapp1(sortkey, car(right));
while (TRUE) {
if (!dotest2(leftarg, rightarg, sortfcn, NIL) &&
dotest2(rightarg, leftarg, sortfcn, NIL)) {
/* right is smaller */
if (null(result)) {
result = resultt = right;
}
else {
rplacd(resultt, right);
resultt = right;
}
right = cdr(right);
if (null(right)) { /* finished the merge */
rplacd(resultt, left);
break;
}
rightarg=null(sortkey) ? car(right) : xlapp1(sortkey,car(right));
}
else { /* left is smaller */
if (null(result)) {
result = resultt = left;
}
else {
rplacd(resultt, left);
resultt = left;
}
left = cdr(left);
if (null(left)) { /* finished the merge */
rplacd(resultt, right);
break;
}
leftarg=null(sortkey) ? car(left) : xlapp1(sortkey,car(left));
}
}
xlpopn(5);
return result;
}
}
LVAL xsort()
{
LVAL list, sortfcn;
/* protect some pointers */
LVAL sortkey;
xlstkcheck(3);
xlsave(sortkey);
xlsave(list);
xlsave(sortfcn);
/* get the list to sort and the comparison function */
list = xlgetarg();
sortfcn = xlgetarg();
sortkey = xlkey();
xllastkey();
/* sort the list */
if (!null(list)) switch (ntype(list)) {
case DARRAY:
case VECTOR:
case TVEC:
case STRING:
{
LVAL etype = gettvecetype(list);
list = coerce_to_list(list);
list = xlmergesort(list, sortfcn, sortkey);
list = coerce_to_tvec(list, etype);
break;
}
case CONS:
list = xlmergesort(list, sortfcn, sortkey);
break;
default: xlbadtype(list);
}
/* restore the stack and return the sorted list */
xlpopn(3);
return (list);
}
/* These functions have the following copyright notice: */
/* XLISP-STAT 2.0 Copyright (c) 1988, by Luke Tierney */
/* All Rights Reserved */
/* Permission is granted for unrestricted non-commercial use */
/* membr - internal MEMBER for set functions TAA */
#ifdef KEYARG
LOCAL LVAL membr P5C(LVAL, expr, LVAL, list, LVAL, fcn, LVAL, kfcn, int, tresult)
{
xlprot1(expr);
if (!null(kfcn)) expr = xlapp1(kfcn,expr);
for (; consp(list); list = cdr(list))
if (dotest2(expr,car(list),fcn,kfcn) == tresult) {
xlpop();
return (list);
}
xlpop();
return (NIL);
}
#else
LOCAL LVAL membr P4C(LVAL, expr, LVAL, list, LVAL, fcn, int, tresult)
LVAL expr,list,fcn; int tresult;
{
for (; consp(list); list = cdr(list))
if (dotest2(expr,car(list),fcn) == tresult)
return (list);
return (NIL);
}
#endif
/* Common Lisp ADJOIN function */
LVAL xadjoin(V)
{
LVAL x, list, fcn;
int tresult;
#ifdef KEYARG
LVAL kfcn;
/* protect some pointers */
xlstkcheck(2);
xlsave(fcn);
xlsave(kfcn);
#else
xlsave1(fcn);
#endif
/* get the lists and key arguements, if any */
x = xlgetarg();
list = xlgalist();
xltest(&fcn,&tresult);
#ifdef KEYARG
kfcn = xlkey();
#endif
xllastkey();
#ifdef KEYARG
if (null(membr(x,list,fcn,kfcn,tresult))) list = cons(x,list) ;
xlpopn(2);
#else
if (null(membr(x,list,fcn,tresult))) list = cons(x,list) ;
xlpop();
#endif
return list;
}
LOCAL LVAL set_op P1C(int, which)
{
LVAL x, list1, list2, result, fcn;
int tresult;
#ifdef KEYARG
LVAL kfcn;
/* protect some pointers */
xlstkcheck(3);
xlsave(kfcn);
#else
/* protect some pointers */
xlstkcheck(2);
#endif
xlsave(fcn);
xlsave(result);
/* get the lists and key arguements, if any */
list1 = xlgalist();
list2 = xlgalist();
xltest(&fcn,&tresult);
#ifdef KEYARG
kfcn = xlkey();
#endif
xllastkey();
switch(which) {
case 'U':
for (result = list1; consp(list2); list2 = cdr(list2)) {
x = car(list2);
#ifdef KEYARG
if (null(membr(x,list1,fcn,kfcn,tresult)))
#else
if (null(membr(x,list1,fcn,tresult)))
#endif
result = cons(x, result);
}
break;
case 'I':
for (result = NIL; consp(list2); list2 = cdr(list2)) {
x = car(list2);
#ifdef KEYARG
if (!null(membr(x,list1,fcn,kfcn,tresult)))
#else
if (!null(membr(x,list1,fcn,tresult)))
#endif
result = cons(x, result);
}
break;
case 'D':
for (result = NIL; consp(list1); list1 = cdr(list1)) {
x = car(list1);
#ifdef KEYARG
if (null(membr(x,list2,fcn,kfcn,tresult)))
#else
if (null(membr(x,list2,fcn,tresult)))
#endif
result = cons(x, result);
}
break;
case 'S':
for (result = s_true; consp(list1); list1 = cdr(list1)) {
x = car(list1);
#ifdef KEYARG
if (null(membr(x,list2,fcn,kfcn,tresult)))
#else
if (null(membr(x,list2,fcn,tresult)))
#endif
{
result = NIL;
break;
}
}
break;
}
#ifdef KEYARG
xlpopn(3);
#else
xlpopn(2);
#endif
return(result);
}
LVAL xunion(V) { return(set_op('U')); }
LVAL xintersection(V) { return(set_op('I')); }
LVAL xset_difference(V) { return(set_op('D')); }
LVAL xsubsetp(V) { return(set_op('S')); }
/* HASH TABLES ARE IMPLEMENTED AS STRUCTS, WITHOUT ACCESSING FCNS */
#ifdef HASHFCNS
/* The hash tables have been modified to allow fast EQ, EQL and EQUAL
hashing by using addresses in the hash function. Since addresses are
not preserved accross save/restores, xlimage and dlimage use uflags to
mark hash tables for rehashing on the next access. (xlimage and
dlimage set uflags to TRUE for any STRUCT. If a proper hashtable type
is introduced, this should be changed.) In addition, the
:REHASH-THRESHOLD and :REHASH-SIZE keywords are now supported and hash
tables are resized when new entries are added that push the count over
the threshold. To simplify resizing, the hash table is now a fixed
size structure that contains its data as a vector in one of its slots.
The count is also maintained in a slot.
*/
#define HTABSIZE 6
#define HTAB_REHASH_THRESHOLD 0.8
#define HTAB_REHASH_SIZE 1.3
#define MAXHTABSIZE MAXSLEN
#define hashtablep(x) (structp(x) && (getelement(x,0) == a_hashtable))
#define xlgahashtable() (testarg(typearg(hashtablep)))
#define hashtablerehash(x) nuflags(x)
#define sethashtablerehash(x,y) setnuflags(x,y)
#define hashtablesize(x) getsize(hashtabledata(x))
#define hashtablefun(x) getelement(x,1)
#define sethashtablefun(x,fun) setelement(x,1,fun)
#define hashtablecount(x) getfixnum(getelement(x,2))
#define sethashtablecount(x,n) setelement(x,2,cvfixnum((FIXTYPE)n))
#define hashtabledata(x) getelement(x,3)
#define sethashtabledata(x,d) setelement(x,3,d)
#define hashtablerhthresh(x) getelement(x,4)
#define sethashtablerhthresh(x,v) setelement(x,4,v)
#define hashtablerhsize(x) getelement(x,5)
#define sethashtablerhsize(x,v) setelement(x,5,v)
#define hashtablelist(x,i) getelement(hashtabledata(x),(i))
#define sethashtablelist(x,i,v) setelement(hashtabledata(x),(i),v)
LOCAL VOID rehash_hashdata P3H(LVAL, LVAL, LVAL);
LOCAL VOID rehash_hashtable P1H(LVAL);
LOCAL unsigned FIXTYPE eqlhash P1H(LVAL);
LOCAL unsigned FIXTYPE equalhash P1H(LVAL);
LOCAL int hthash P3H(LVAL, int, LVAL);
LOCAL VOID rehash_hashdata P3C(LVAL, old, LVAL, new, LVAL, fun)
{
LVAL next;
int i, j, oldsize, newsize;
oldsize = getsize(old);
newsize = getsize(new);
for (i = 0; i < oldsize; i++) {
for (next = getelement(old, i); consp(next); next = cdr(next)) {
j = hthash(car(car(next)), newsize, fun);
setelement(new, j, cons(car(next), getelement(new, j)));
}
}
}
LOCAL VOID rehash_hashtable P1C(LVAL, table)
{
LVAL new;
xlsave1(new);
new = newvector((int) hashtablesize(table));
rehash_hashdata(hashtabledata(table), new, hashtablefun(table));
sethashtabledata(table, new);
sethashtablerehash(table, FALSE);
xlpop();
}
LOCAL unsigned FIXTYPE eqlhash P1C(LVAL, x)
{
union {FIXTYPE i; FLOTYPE j; unsigned FIXTYPE k;} swizzle;
unsigned FIXTYPE temp;
switch (ntype(x)) {
case FIXNUM:
swizzle.i = getfixnum(x);
return swizzle.k;
#ifdef BIGNUMS
case RATIO:
return (eqlhash(getnumer(x)) << 2) ^ eqlhash(getdenom(x));
case BIGNUM:
{
int i, n;
n = getbignumsize(x) + 1;
for (i = 0, temp = 0; i < n; i++)
temp += (unsigned)getbignumarray(x)[i];
return temp;
}
#endif
case FLONUM:
swizzle.j = getflonum(x);
return swizzle.k;
case COMPLEX:
return (eqlhash(getreal(x)) << 2) ^ eqlhash(getimag(x));
default:
return (unsigned FIXTYPE) CVPTR(x);
}
}
LOCAL unsigned FIXTYPE equalhash P1C(LVAL, x)
{
unsigned FIXTYPE temp;
temp = 0;
hashloop:
switch (ntype(x)) {
case STRING:
{
char *str = getstring(x);
while (*str != 0)
temp = (temp << 2) ^ *str++;
return temp;
}
case CONS:
temp = (temp << 2) ^ equalhash(car(x));
x = cdr(x);
goto hashloop;
default:
return (temp << 2) ^ eqlhash(x);
}
}
LOCAL int hthash P3C(LVAL, x, int, len, LVAL, fun)
{
if (fun == getfunction(s_eq))
return (int) (CVPTR(x) % len);
else if (fun == getfunction(s_eql))
return (int) (eqlhash(x) % len);
else if (fun == getfunction(s_equal))
return (int) (equalhash(x) % len);
else
return xlhash(x, len);
}
/* Hash table functions from Ken Whedbee */
LVAL xmakehash(V) /* rewritten by TAA */
{
LVAL size, testfcn, result, temp;
double rhthresh, rhsize;
FIXTYPE len = 0;
if (xlgetkeyarg(k_size,&size)) {
if (!fixp(size) || (len=getfixnum(size)) < 1)
xlbadtype(size);
}
else len = 31;
if (len % 2 == 0) len++;
if (len < 1) xlfail("size out of bounds"); /**** check MAXSLEN */
if (!xlgetkeyarg(k_test,&testfcn)) testfcn = getfunction(s_eql);
if (symbolp(testfcn) && fboundp(testfcn)) testfcn = getfunction(testfcn);
if (!xlgetkeyarg(k_rhthresh, &temp)) temp = NIL;
if (floatp(temp) && getflonum(temp) > 0.0 && getflonum(temp) < 1.0)
rhthresh = getflonum(temp);
else
rhthresh = HTAB_REHASH_THRESHOLD;
if (!xlgetkeyarg(k_rhsize, &temp)) temp = NIL;
if (fixp(temp) && getfixnum(temp) > 0)
rhsize = ((double) getfixnum(temp) + len) / len;
else if (floatp(temp) && getflonum(temp) > 1.0)
rhsize = getflonum(temp);
else
rhsize = HTAB_REHASH_SIZE;
xllastkey();
xlprot1(testfcn);
xlsave1(result);
result = newstruct(a_hashtable,HTABSIZE-1);
sethashtablerehash(result, FALSE);
sethashtablefun(result, testfcn);
sethashtablecount(result,0);
sethashtabledata(result,newvector((int)len));
sethashtablerhthresh(result, cvflonum((FLOTYPE) rhthresh));
sethashtablerhsize(result, cvflonum((FLOTYPE) rhsize));
xlpopn(2);
return result;
}
LVAL xgethash(V)
{
LVAL alist,val,key,fun,table,def=NIL;
key = xlgetarg();
table = xlgahashtable();
if (moreargs()) {
def = xlgetarg();
xllastarg();
}
if (hashtablerehash(table))
rehash_hashtable(table);
fun = hashtablefun(table);
alist = hashtablelist(table, hthash(key,(int)hashtablesize(table),fun));
#ifdef KEYARG
val = assoc(key,alist,fun,NIL,TRUE);
#else
val = assoc(key,alist,fun,TRUE);
#endif
/* return result */
#ifdef MULVALS
xlnumresults = 2;
if (null(val)) {
xlresults[0] = def;
xlresults[1] = NIL;
}
else {
xlresults[0] = cdr(val);
xlresults[1] = s_true;
}
return(xlresults[0]);
#else
return (null(val) ? def : cdr(val));
#endif /* MULVALS */
}
LVAL xremhash(V)
/* By TAA -- can't use assoc here*/
{
LVAL alist,key,fun,table,last;
int idx;
key = xlgetarg();
table = xlgahashtable();
xllastarg();
if (hashtablerehash(table))
rehash_hashtable(table);
fun = hashtablefun(table);
idx = hthash(key,(int)hashtablesize(table),fun);
alist = hashtablelist(table,idx);
if (null(alist))
return NIL;
#ifdef KEYARG
else if (dotest2(key,car(car(alist)),fun,NIL)==TRUE)
#else
else if (dotest2(key,car(car(alist)),fun)==TRUE)
#endif
{
sethashtablelist(table,idx,cdr(alist)); /* matches first element */
sethashtablecount(table,hashtablecount(table)-1);
return s_true;
}
else {
last = alist;
alist = cdr(alist);
while (consp(alist)) {
#ifdef KEYARG
if (dotest2(key,car(car(alist)),fun,NIL)==TRUE)
#else
if (dotest2(key,car(car(alist)),fun)==TRUE)
#endif
{
rplacd(last,cdr(alist));
sethashtablecount(table,hashtablecount(table)-1);
return s_true;
}
last = alist;
alist = cdr(alist);
}
}
return NIL;
}
VOID xlsetgethash P3C(LVAL, key, LVAL, table, LVAL, value)
{
LVAL alist,fun,oldval;
int idx;
if (! hashtablep(table))
xlbadtype(table);
if (hashtablerehash(table))
rehash_hashtable(table);
fun = hashtablefun(table);
idx = hthash(key,(int)hashtablesize(table),fun);
alist = hashtablelist(table,idx);
#ifdef KEYARG
if (!null(oldval = assoc(key,alist,fun,NIL,TRUE)))
#else
if (!null(oldval = assoc(key,alist,fun,TRUE)))
#endif
rplacd(oldval,value);
else {
LVAL new, data, temp;
double rhthresh, rhsize;
int size, newsize;
temp = hashtablerhthresh(table);
if (floatp(temp) && getflonum(temp) > 0.0 && getflonum(temp) < 1.0)
rhthresh = getflonum(temp);
else
rhthresh = HTAB_REHASH_THRESHOLD;
temp = hashtablerhsize(table);
if (floatp(temp) && getflonum(temp) > 1.0)
rhsize = getflonum(temp);
else
rhsize = HTAB_REHASH_SIZE;
alist = cons(cons(key,value),alist);
sethashtablelist(table,idx,alist);
sethashtablecount(table,hashtablecount(table)+1);
if (hashtablecount(table) > rhthresh * hashtablesize(table)) {
size = hashtablesize(table);
newsize = (int) (rhsize * (size + 1));
if (newsize % 2 == 0) newsize++;
if (newsize < 0) xlfail("bad rehash size");
if (size < newsize && newsize < MAXHTABSIZE) {
xlsave1(new);
new = newvector(newsize);
data = hashtabledata(table);
rehash_hashdata(data, new, fun);
sethashtabledata(table, new);
xlpop();
}
}
}
}
/* function clrhash TAA */
LVAL xclrhash(V)
{
LVAL table;
int i;
table = xlgahashtable();
xllastarg();
for (i = hashtablesize(table)-1; i >= 0; i--)
sethashtablelist(table,i,NIL);
sethashtablecount(table,0);
return (table);
}
/* function hash-table-count TAA */
LVAL xhashcount(V)
{
LVAL table;
table = xlgahashtable();
xllastarg();
return (cvfixnum((FIXTYPE) hashtablecount(table)));
}
/* function maphash TAA */
LVAL xmaphash(V)
{
FRAMEP newfp;
LVAL fun, table, arg, element;
int i;
fun = xlgetarg();
table = xlgahashtable();
xllastarg();
xlstkcheck(3);
xlprotect(fun);
xlprotect(table);
xlsave(element);
for (i = hashtablesize(table)-1; i >= 0; i--)
for (element=hashtablelist(table,i); consp(element);) {
arg = car(element);
element = cdr(element); /* in case element is deleted */
newfp =xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE) 2));
pusharg(car(arg));
pusharg(cdr(arg));
xlfp = newfp;
xlapply(2);
}
xlpopn(3);
return (NIL);
}
LVAL xhashtablep(V)
{
LVAL x;
x = xlgetarg();
xllastarg();
return(hashtablep(x) ? s_true : NIL);
}
LVAL xhashtablefun(V)
{
LVAL x, fun;
x = xlgahashtable();
xllastarg();
fun = hashtablefun(x);
if (fun == getfunction(s_eq))
return(s_eq);
else if (fun == getfunction(s_eql))
return(s_eql);
else if (fun == getfunction(s_equal))
return(s_equal);
else
return(fun);
}
LVAL xhashtablesize(V)
{
LVAL x;
x = xlgahashtable();
xllastarg();
return(cvfixnum((FIXTYPE) hashtablesize(x)));
}
LVAL xhashtablerhthresh(V)
{
LVAL x;
x = xlgahashtable();
xllastarg();
return(hashtablerhthresh(x));
}
LVAL xhashtablerhsize(V)
{
LVAL x;
x = xlgahashtable();
xllastarg();
return(hashtablerhsize(x));
}
#endif
/* Internal version of MAKE-LIST */
LVAL mklist P2C(int, n, LVAL, elem)
{
LVAL result;
xlsave1(result);
for (result = NIL; n > 0; n--)
result = cons(elem, result);
xlpop();
return(result);
}
/* Common Lisp MAKE-LIST function */
LVAL xmklist(V)
{
int n;
LVAL elem = NIL;
n = getfixnum(xlgafixnum());
xlgetkeyarg(k_initelem, &elem);
xllastkey();
return(mklist(n, elem));
}
#ifdef DODO
int geteqhash P3C(LVAL, key, LVAL, table, LVAL *, pval)
{
LVAL alist, pair;
int hindex;
if (hashtablerehash(table))
rehash_hashtable(table);
hindex = (int) (CVPTR(key) % hashtablesize(table));
alist = hashtablelist(table, hindex);
for (; consp(alist); alist = cdr(alist)) {
if (consp(pair = car(alist)) && car(pair) == key) {
*pval = cdr(pair);
return(TRUE);
}
}
return(FALSE);
}
#endif /* DODO */
syntax highlighted by Code2HTML, v. 0.9.1