/* xlseq.c - xlisp sequence functions */
/* Written by Thomas Almy, based on code:
Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* this is part of the COMMON LISP extension: */
/* (elt seq index) -- generic sequence reference function */
/* (map type fcn seq1 [seq2 ...]) -- generic sequence mapping function */
/* type is one of cons, array, string, or nil */
/* (some fcn seq1 [seq2 ...]) -- apply fcn until non-nil */
/* also every notany and notevery */
/* (concatenate type seq1 [seq2 ...]) -- sequence concatenation function */
/* type is one of cons, array, or string. */
/* (search seq1 seq1 &key :test :test-not :start1 :end1 :start2 :end2) --
generic sequence searching function. */
/* subseq reverse remove remove-if remove-if-not delete delete-if
delete-if-not -- rewritten to allow all sequence types */
/* Position, position-if, position-if-not, count, count-if, count-if-not,
find, find-if, find-if-not */
/* the keyword arguments :start and :end are now valid for the remove, delete,
find position and count functions */
/* the keyword argument :key is also valid where appropriate */
/* The author, Tom Almy, appologizes for using "goto" several places in
this code. */
/**** should add :FROM-END to countif, xsearch, xreduce */
/* Function prototypes */
LOCAL VOID getseqbounds P5H(unsigned *, unsigned *, unsigned, LVAL, LVAL);
LOCAL LVAL map P1H(int);
LOCAL LVAL xlmapwhile P1H(int);
LOCAL LVAL remif P3H(int, int, int);
LOCAL LVAL substituteif P3H(int, int, int);
LOCAL LVAL xlkitchensink P3H(int, int, int);
LOCAL unsigned calclength(V);
LOCAL LVAL cattovector P1H(LVAL);
LOCAL LVAL cattocons(V);
#define getlength(x) (listp(x) ? llength(x) : gettvecsize(x))
LOCAL VOID getseqbounds P5C(unsigned *, start,
unsigned *, end,
unsigned, length,
LVAL, startkey,
LVAL, endkey)
{
LVAL arg;
FIXTYPE temp;
if (xlgkfixnum(startkey,&arg)) {
temp = getfixnum(arg);
if (temp < 0 || temp > (FIXTYPE)length ) goto rangeError;
*start = (unsigned)temp;
}
else *start = 0;
if (xlgetkeyarg(endkey, &arg) && !null(arg)) {
if (!fixp(arg)) xlbadtype(arg);
temp = getfixnum(arg);
if (temp < (FIXTYPE)*start || temp > (FIXTYPE)length) goto rangeError;
*end = (unsigned)temp;
}
else *end = length;
return;
/* else there is a range error */
rangeError:
xlerror("range error",arg);
}
/* xelt - sequence reference function */
LVAL xelt(V)
{
LVAL seq,index;
FIXTYPE i;
/* get the sequence and the index */
seq = xlgetarg();
index = xlgafixnum(); i = getfixnum(index);
if (i < 0) goto badindex;
xllastarg();
if (listp(seq)) { /* do like nth, but check for in range */
/* find the ith element */
while (consp(seq)) {
if (i-- == 0) return (car(seq));
seq = cdr(seq);
}
goto badindex; /* end of list reached first */
}
switch (ntype(seq)) {
case VECTOR:
case STRING:
case TVEC:
if (i >= (FIXTYPE)gettvecsize(seq)) goto badindex;
return (gettvecelement(seq,(int)i));
default:
xlbadtype(seq);
}
badindex:
xlerror("index out of bounds",index);
return (NIL); /* eliminate warnings */
}
LOCAL LVAL map P1C(int, into)
{
FRAMEP newfp;
LVAL fun, lists, val, last = NULL, x, y, etype = NULL;
unsigned len, rlen, temp, i;
int argc, typ = 0;
/* protect some pointers */
xlstkcheck(3);
xlsave(fun);
xlsave(lists);
xlsave(val);
/* get the type of resultant, and resultant for map-into */
val = xlgetarg();
if (null(val))
typ = 0; /* return nothing */
else {
if (into) {
switch (ntype(val)) {
case SYMBOL:
if (! null(val))
xlbadtype(val);
typ = CONS;
break;
case CONS: typ = CONS; break;
case VECTOR: typ = VECTOR; break;
case STRING: typ = STRING; break;
case TVEC: typ = TVEC; break;
default: xlbadtype(val);
}
}
else {
if ((typ = xlcvttype(val)) != CONS &&
typ != STRING && typ != VECTOR &&
typ != DARRAY) {
xlerror("invalid result type", val);
}
if (typ == STRING) etype = a_char;
else if (consp(val) && consp(cdr(val))) /* very superficial check! */
etype = car(cdr(val));
else etype = s_true;
}
}
/* get the function to apply and argument sequences */
fun = xlgetarg();
/* Initialization code bug fixed, Luke Tierney 3/94 */
if (into) { /* MAP-INTO */
len = getlength(val);
if (moreargs()) { /* handle first argument */
x = xlgaseq();
if ((temp = getlength(x)) < len) len = temp;
argc = 1;
lists = last = consa(x);
}
else {
lists = NIL;
argc = 0;
}
}
else { /* MAP */
val = NIL;
lists = xlgaseq();
len = getlength(lists);
lists = last = consa(lists);
argc = 1;
}
/* build a list of argument lists */
for (; moreargs(); last = cdr(last)) {
x = xlgaseq();
if ((temp = getlength(x)) < len) len = temp;
argc++;
rplacd(last,(consa(x)));
}
if (into) {
rlen = getlength(val);
if (rlen < len) len = rlen;
}
else if (typ != 0) {
/* initialize the result list */
switch (typ) {
case DARRAY:
case VECTOR:
case STRING:
case TVEC:
val = mktvec(len, etype);
break;
default:
val = mklist(len, NIL);
break;
}
}
else val = NIL;
/* loop through each of the argument lists */
for (i=0,last=val;i<len;i++) {
/* 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) ; x = cdr(x)) {
y = car(x);
switch (ntype(y)) {
case CONS:
pusharg(car(y));
rplaca(x,cdr(y));
break;
case VECTOR:
case STRING:
case TVEC:
pusharg(gettvecelement(y,i));
break;
}
}
/* apply the function to the arguments */
xlfp = newfp;
x = xlapply(argc);
switch (typ) {
case CONS:
rplaca(last, x);
last = cdr(last);
break;
case DARRAY:
case VECTOR:
case STRING:
case TVEC:
settvecelement(val,i,x);
break;
}
}
/* restore the stack */
xlpopn(3);
/* return the last test expression value */
return (val);
}
/* xmap -- map function */
LVAL xmap(V) {return map(FALSE);}
LVAL xmapinto(V) {return map(TRUE);}
/* every, some, notany, notevery */
#define EVERY 0
#define SOME 1
#define NOTEVERY 2
#define NOTANY 3
LOCAL LVAL xlmapwhile P1C(int, cond)
{
int exitcond;
FRAMEP newfp;
LVAL fun, lists, val, last, x, y;
unsigned len,temp,i;
int argc;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(lists);
/* get the function to apply and argument sequences */
fun = xlgetarg();
lists = xlgaseq();
len = getlength(lists);
argc = 1;
/* build a list of argument lists */
for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
val = xlgaseq();
if ((temp = getlength(val)) < len) len = temp;
argc++;
rplacd(last,(cons(val,NIL)));
}
switch (cond) {
case SOME:
case NOTANY:
exitcond = TRUE;
val = NIL;
break;
case EVERY:
case NOTEVERY:
exitcond = FALSE;
val = s_true;
break;
default: /* to keep compiler happy */
exitcond = FALSE;
val = NIL;
}
/* loop through each of the argument lists */
for (i=0;i<len;i++) {
/* 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); x = cdr(x)) {
y = car(x);
switch (ntype(y)) {
case CONS:
pusharg(car(y));
rplaca(x,cdr(y));
break;
case VECTOR:
case STRING:
case TVEC:
pusharg(gettvecelement(y,i));
break;
}
}
/* apply the function to the arguments */
xlfp = newfp;
val = xlapply(argc);
if (null(val) ^ exitcond) break;
}
if ((cond == NOTANY) | (cond == NOTEVERY))
val = (null(val) ? s_true : NIL);
/* restore the stack */
xlpopn(2);
/* return the last test expression value */
return (val);
}
LVAL xevery(V)
{
return xlmapwhile(EVERY);
}
LVAL xsome(V)
{
return xlmapwhile(SOME);
}
LVAL xnotany(V)
{
return xlmapwhile(NOTANY);
}
LVAL xnotevery(V)
{
return xlmapwhile(NOTEVERY);
}
/* xconcatenate - concatenate a bunch of sequences */
/* replaces (and extends) strcat, now a macro */
LOCAL unsigned calclength(V)
{
LVAL tmp;
FRAMEP saveargv;
int saveargc;
long len;
/* save the argument list */
saveargv = xlargv;
saveargc = xlargc;
/* find the length of the new string or vector */
for (len = 0; moreargs(); ) {
tmp = xlgaseq();
len += getlength(tmp);
/****if (len>MAXSLEN) xltoolong();*/ /*check for overflow*/
}
/* restore the argument list */
xlargv = saveargv;
xlargc = saveargc;
return (unsigned)len;
}
LOCAL LVAL cattovector P1C(LVAL, etype)
{
LVAL tmp,val;
unsigned len,i, j;
/* find resulting length -- also validates argument types */
len = calclength();
/* protect the result */
xlsave1(val);
/* create the result vector */
val = mktvec(len, etype);
/* combine the vectors */
for (j = 0; moreargs();) {
tmp = nextarg();
if (!null(tmp)) switch (ntype(tmp)) {
case VECTOR:
case STRING:
case TVEC:
len = gettvecsize(tmp);
for (i = 0; i < len; i++, j++)
settvecelement(val, j, gettvecelement(tmp,i));
break;
case CONS:
for (; consp(tmp); tmp = cdr(tmp), j++)
settvecelement(val, j, car(tmp));
break;
}
}
xlpop();
/* return the new vector */
return (val);
}
LOCAL LVAL cattocons(V)
{
LVAL val,tmp,next,last=NIL;
unsigned len,i;
long n;
xlsave1(val); /* protect against GC */
/* combine the lists */
while (moreargs()) {
tmp = nextarg();
if (!null(tmp))
switch (ntype(tmp)) {
case CONS:
/* check for circular list (Added 5/6/94) */
next = tmp;
for (n = 0; consp(next); next=cdr(next)) {
if (n++ > nnodes)
xlcircular(); /*DIRTY, but we loose anyway!*/
}
while (consp(tmp)) {
next = consa(car(tmp));
if (!null(val)) rplacd(last,next);
else val = next;
last = next;
tmp = cdr(tmp);
}
break;
case VECTOR:
case STRING:
case TVEC:
len = gettvecsize(tmp);
for (i = 0; i < len; i++) {
next = consa(gettvecelement(tmp,i));
if (!null(val)) rplacd(last,next);
else val = next;
last = next;
}
break;
default:
xlbadtype(tmp); break; /* need default because no precheck*/
}
}
xlpop();
return (val);
}
LVAL xconcatenate(V)
{
LVAL type, etype;
switch (xlcvttype(type = xlgetarg())) { /* target type of data */
case CONS:
return cattocons();
case STRING:
return cattovector(a_char);
case DARRAY:
case VECTOR:
case TVEC:
if (consp(type) && consp(cdr(type))) /* very superficial check! */
etype = car(cdr(type));
else etype = s_true;
return cattovector(etype);
default:
xlerror("invalid result type", type);
return (NIL); /* avoid warning */
}
}
/* xsubseq - return a subsequence -- new version */
LVAL xsubseq(V)
{
unsigned start,end=0,len,esize;
FIXTYPE temp;
int srctype;
LVAL src,dst;
LVAL next,last=NIL;
/* get sequence */
src = xlgaseq();
if (listp(src)) srctype = CONS;
else srctype=ntype(src);
/* get length */
len = getlength(src);
/* get the starting position */
dst = xlgafixnum(); temp = getfixnum(dst);
if (temp < 0 || temp > len)
xlerror("sequence index out of bounds",dst);
start = (unsigned) temp;
/* get the ending position */
if (moreargs()) {
dst = nextarg();
if (null(dst)) end = len;
else if (fixp(dst)) {
temp = getfixnum(dst);
if (temp < start || temp > len)
xlerror("sequence index out of bounds",dst);
end = (unsigned) temp;
}
else xlbadtype(dst);
}
else
end = len;
xllastarg();
len = end - start;
switch (srctype) { /* do the subsequencing */
case STRING:
dst = newstring(len);
MEMCPY(getstring(dst), getstring(src)+start, len);
dst->n_string[len] = 0;
break;
case VECTOR:
dst = newvector(len);
MEMCPY(dst->n_vdata, &src->n_vdata[start], sizeof(LVAL)*len);
break;
case TVEC:
dst = mktvec(len, gettvecetype(src));
esize = gettveceltsize(src);
MEMCPY(gettvecdata(dst),
((char *) gettvecdata(src)) + start * esize,
esize * len);
break;
case CONS:
xlsave1(dst);
while (start--) src = cdr(src);
while (len--) {
next = consa(car(src));
if (!null(dst)) rplacd(last,next);
else dst = next;
last = next;
src = cdr(src);
}
xlpop();
break;
}
/* return the substring */
return (dst);
}
/* xnreverse -- built-in function nreverse (destructive reverse) */
LVAL xlnreverse P1C(LVAL, seq)
{
LVAL val;
if (null(seq)) return (NIL); /* empty argument */
switch (ntype(seq)) {
case CONS:
val = NIL;
while (consp(seq)) {
LVAL next = cdr(seq);
rplacd(seq,val);
val = seq;
seq = next;
}
break;
case DARRAY:
seq = getdarraydata(seq);
/* drop through */
case VECTOR:
case STRING:
case TVEC:
{
int esize, qstep;
char *p, *q;
esize = gettveceltsize(seq);
p = (char *) gettvecdata(seq);
q = p + (gettvecsize(seq) - 1) * esize;
qstep = 2 * esize;
while (p < q) {
char *pp = p + esize;
while (p < pp) {
int ival = *p;
*p++ = *q;
*q++ = ival;
}
q -= qstep;
}
val = seq;
}
break;
default:
val = xlbadtype(seq);
break;
}
/* return the sequence */
return (val);
}
LVAL xnreverse(V)
{
LVAL seq;
/* get the sequence to reverse */
seq = xlgaseq();
xllastarg();
return xlnreverse(seq);
}
/* xreverse - built-in function reverse -- new version */
LVAL xreverse(V)
{
LVAL seq,val;
unsigned i,len;
/* get the sequence to reverse */
seq = xlgetarg();
xllastarg();
if (null(seq)) return (NIL); /* empty argument */
switch (ntype(seq)) {
case CONS:
/* protect pointer */
xlsave1(val);
/* append each element to the head of the result list */
for (val = NIL; consp(seq); seq = cdr(seq))
val = cons(car(seq),val);
/* restore the stack */
xlpop();
break;
case VECTOR:
len = getsize(seq);
val = newvector(len);
for (i = 0; i < len; i++)
setelement(val,i,getelement(seq,len-i-1));
break;
case STRING:
len = getslength(seq);
val = newstring(len);
for (i = 0; i < len; i++)
val->n_string[i] = seq->n_string[len-i-1];
val->n_string[len] = 0;
break;
case TVEC:
{
int esize;
char *p, *q;
len = gettvecsize(seq);
val = mktvec(len, gettvecetype(seq));
esize = gettveceltsize(seq);
p = (char *) gettvecdata(val);
q = ((char *) gettvecdata(seq)) + (len - 1) * esize;
for (i = 0; i < len; i++, p += esize, q -= esize)
MEMCPY(p, q, esize);
break;
}
default:
xlbadtype(seq); break;
}
/* return the sequence */
return (val);
}
/* remif - common code for remove and delete functions */
#define remtest(x,elt,fcn,kfcn) \
((expr?dotest2(x,elt,fcn,kfcn):dotest1(elt,fcn,kfcn)) == tresult)
LOCAL LVAL remif P3C(int, tresult, int, expr, int, destruct)
{
LVAL x,seq,fcn,last,val,elt;
long i,j,l;
unsigned start,end;
int esize;
LVAL kfcn;
int fromend=FALSE; /* process from the end */
FIXTYPE count=-1;
if (expr) {
/* get the expression to delete and the sequence */
x = xlgetarg();
seq = xlgaseq();
xltest(&fcn,&tresult);
}
else {
/* get the function and the sequence */
fcn = xlgetarg();
seq = xlgaseq();
x = NIL; /* to keep compiler happy */
}
getseqbounds(&start,&end,getlength(seq),k_start,k_end);
if (xlgetkeyarg(k_fromend, &val) && !null(val)) fromend=TRUE;
if (xlgetkeyarg(k_count, &val)) {
if (!null(val)) {
if (!fixp(val)) xlbadtype(val);
count = getfixnum(val);
if (count < 0) count = 0;
}
}
if (count <= 0) fromend=FALSE; /* save some time */
kfcn = xlkey();
xllastkey();
if (null(seq)) return NIL;
/* protect some pointers */
xlstkcheck(4);
xlsave1(val);
xlprotect(seq);
xlprotect(kfcn);
xlprotect(fcn);
/* delete matches */
switch (ntype(seq)) {
case CONS:
if (! destruct) seq = copylist(seq);
if (fromend) {
unsigned temp;
seq = xlnreverse(seq);
l = getlength(seq);
temp = l - end;
end = l - start;
start = temp;
}
end -= start;
/* delete leading matches, only if start is 0 */
if (start == 0) {
while (consp(seq) && end > 0) {
end--;
if (count == 0 || ! remtest(x,car(seq),fcn,kfcn))
break;
seq = cdr(seq);
count--;
}
}
val = last = seq;
/* delete embedded matches */
if (consp(seq) && end > 0) {
/* skip the first non-matching element, start == 0 */
if (start == 0) seq = cdr(seq);
/* skip first elements if start > 0, correct "last" */
for (; consp(seq) && start-- > 0; last = seq, seq = cdr(seq));
/* look for embedded matches */
for (; consp(seq) && end-- > 0; seq = cdr(seq)) {
/* check to see if this element should be deleted */
if (count != 0) {
if (remtest(x,car(seq),fcn,kfcn)) {
rplacd(last,cdr(seq));
count--;
}
else last = seq;
}
}
}
if (fromend) val = xlnreverse(val);
break;
case VECTOR:
case STRING:
case TVEC:
l = gettvecsize(seq);
esize = gettveceltsize(seq);
if (end > l) end = l;
if (! destruct) seq = copyvector(seq);
xlsave1(elt); /* just to be safe for typed arrays -- prob. not needed */
if (fromend) {
for (i = j = l - 1; i != -1; i--) {
elt = gettvecelement(seq,i);
if (i < start || i >= end || /* copy if out of range */
count == (FIXTYPE)(j-i) || ! remtest(x,elt,fcn,kfcn)) {
if (i != j) settvecelement(seq,j,elt);
j--;
}
}
if (++j != 0) { /* need new, shorter result -- too bad */
fcn = seq; /* save value in protected cell */
l -= j; /* new length */
seq = mktvec(l, gettvecetype(seq));
MEMCPY(gettvecdata(seq), ((char *) gettvecdata(fcn)) + j * esize,
l * esize);
}
}
else {
for (i = j = 0; i < l; i++) {
elt = gettvecelement(seq, i);
if (i < start || i >= end || /* copy if out of range */
count == (FIXTYPE)(i-j) || ! remtest(x,elt,fcn,kfcn)) {
if (i != j) settvecelement(seq,j,elt);
j++;
}
}
if (l != j) { /* need new, shorter result -- too bad */
fcn = seq; /* save value in protected cell */
seq = mktvec(j, gettvecetype(seq));
MEMCPY(gettvecdata(seq), gettvecdata(fcn), j * esize);
}
}
xlpop();
val = seq;
break;
default:
xlbadtype(seq); break;
}
/* restore the stack */
xlpopn(4);
/* return the updated sequence */
return (val);
}
/* xremif - built-in function 'remove-if' -- enhanced version */
LVAL xremif(V)
{
return (remif(TRUE,FALSE,FALSE));
}
/* xremifnot - built-in function 'remove-if-not' -- enhanced version */
LVAL xremifnot(V)
{
return (remif(FALSE,FALSE,FALSE));
}
/* xremove - built-in function 'remove' -- enhanced version */
LVAL xremove(V)
{
return (remif(TRUE,TRUE,FALSE));
}
/* xdelif - built-in function 'delete-if' -- enhanced version */
LVAL xdelif(V)
{
return (remif(TRUE,FALSE,TRUE));
}
/* xdelifnot - built-in function 'delete-if-not' -- enhanced version */
LVAL xdelifnot(V)
{
return (remif(FALSE,FALSE,TRUE));
}
/* xdelete - built-in function 'delete' -- enhanced version */
LVAL xdelete(V)
{
return (remif(TRUE,TRUE,TRUE));
}
#ifdef SUBSTITUTE
#define subtest(x,y,fcn,kfcn) \
((expr?dotest2(x,y,fcn,kfcn):dotest1(y,fcn,kfcn)) == tresult)
/* substituteif - common code for 'substitute*' functions */
LOCAL LVAL substituteif P3C(int, tresult, int, expr, int, destruct)
{
LVAL x,seq,fcn,val,next,repl;
long i,l;
unsigned start,end;
LVAL kfcn;
int fromend=FALSE; /* process from the end */
FIXTYPE count=-1;
repl = xlgetarg(); /* replacement expression */
if (expr) {
/* get the expression to substitute and the sequence */
x = xlgetarg();
seq = xlgaseq();
xltest(&fcn,&tresult);
}
else {
/* get the function and the sequence */
fcn = xlgetarg();
seq = xlgaseq();
x = NIL; /* to keep compiler happy */
}
getseqbounds(&start,&end,getlength(seq),k_start,k_end);
if (xlgetkeyarg(k_fromend, &val) && !null(val)) fromend=TRUE;
if (xlgetkeyarg(k_count, &val)) {
if (!null(val)) {
if (!fixp(val)) xlbadtype(val);
count = getfixnum(val);
if (count < 0) count = 0;
}
}
kfcn = xlkey();
xllastkey();
if (null(seq) || count == 0) return seq;
/* protect some pointers */
xlstkcheck(4);
xlprotect(seq);
xlprotect(kfcn);
xlprotect(fcn);
xlsave(val);
/* substitute matches */
switch (ntype(seq)) {
case CONS:
if (destruct)
val = seq;
else
seq = val = copylist(seq);
if (fromend) {
unsigned temp;
seq = val = xlnreverse(seq);
l = getlength(seq);
temp = l - end;
end = l - start;
start = temp;
}
end -= start;
/* skip first elements if start > 0 */
for (; consp(seq) && start-- > 0; seq = cdr(seq));
/* look for embedded matches */
for (; consp(seq) && end-- > 0 && count != 0; seq = cdr(seq)) {
/* check to see if this element should be replaced */
if (subtest(x,car(seq),fcn,kfcn)) {
rplaca(seq, repl);
count--;
}
}
if (fromend) val = xlnreverse(val);
break;
case VECTOR:
case STRING:
case TVEC:
l = gettvecsize(seq);
if (end > l) end = l;
val = destruct ? seq : copyvector(seq);
xlsave1(next);
i = fromend ? end : ((int) start) - 1;
while ((count != 0) && (fromend ? i-- > start : ++i < end)) {
next = gettvecelement(val, i);
if (subtest(x,next,fcn,kfcn)) {
settvecelement(val, i, repl);
count--;
}
}
xlpop();
break;
default:
xlbadtype(seq); break;
}
/* restore the stack */
xlpopn(4);
/* return the updated sequence */
return (val);
}
/* xsubstituteif - built-in function 'substitute-if' -- enhanced version */
LVAL xsubstituteif(V)
{
return (substituteif(TRUE,FALSE,FALSE));
}
/* xsubstituteifnot - built-in function 'substitute-if-not' -- enhanced version */
LVAL xsubstituteifnot(V)
{
return (substituteif(FALSE,FALSE,FALSE));
}
/* xsubstitute - built-in function 'substitute' -- enhanced version */
LVAL xsubstitute(V)
{
return (substituteif(TRUE,TRUE,FALSE));
}
/* xnsubstituteif - built-in function 'nsubstitute-if' -- enhanced version */
LVAL xnsubstituteif(V)
{
return (substituteif(TRUE,FALSE,TRUE));
}
/* xnsubstituteifnot - built-in function 'nsubstitute-if-not' -- enhanced version */
LVAL xnsubstituteifnot(V)
{
return (substituteif(FALSE,FALSE,TRUE));
}
/* xnsubstitute - built-in function 'nsubstitute' -- enhanced version */
LVAL xnsubstitute(V)
{
return (substituteif(TRUE,TRUE,TRUE));
}
#endif
#ifdef POSFCNS
/* TAA MOD -- This is a rewrite done 6/93 to incorporate missing variations */
#define CNTFCN 0 /* three different function types */
#define FNDFCN 1
#define POSFCN 2
/* This is the test expression for all cases */
#ifdef KEYARG
#define bigtest(i) ((expr?dotest2(x,i,fcn,kfcn):dotest1(i,fcn,kfcn)) == tresult)
#else
#define bigtest(i) ((expr?dotest2(x,i,fcn):dotest1(i,fcn)) == tresult)
#endif
/* count*, position*, and find* are all done by the following function */
LOCAL LVAL xlkitchensink P3C(int, ftype, int, tresult, int, expr)
{
LVAL seq, fcn; /* sequence and function */
LVAL x; /* expression (when expr is TRUE) */
unsigned start, end; /* start and end positions */
unsigned counter=0; /* for CNTFCN */
int count; /* for POSFCN */
LVAL val; /* for FNDFCN */
int fromend, i;
#ifdef KEYARG
LVAL kfcn;
#endif
if (expr) {
x = xlgetarg(); /* get expression */
seq = xlgaseq(); /* get sequence */
xltest(&fcn, &tresult); /* get test function and invert from keyargs*/
}
else {
fcn = xlgetarg(); /* get function */
seq = xlgaseq(); /* get sequence */
x = NIL; /* to keep compiler happy */
}
getseqbounds(&start,&end,getlength(seq),k_start,k_end);
#ifdef KEYARG
kfcn = xlkey(); /* get :key keyword arg */
#endif
if (xlgetkeyarg(k_fromend, &val) && !null(val))
fromend = TRUE;
else
fromend = FALSE;
xllastkey();
if (null(seq)) /* nothing to do, return default result */
return (ftype==CNTFCN ? cvfixnum((FIXTYPE)0) : NIL);
#ifdef KEYARG
xlstkcheck(4);
xlprotect(kfcn);
#else
xlstkcheck(3);
#endif
xlprotect(fcn);
xlprotect(seq);
xlsave(val);
count = (fromend) ? end - 1 : start;
/* examine arg and count */
switch (ntype(seq)) {
case CONS:
end -= start;
for (; consp(seq) && start-- > 0; seq = cdr(seq)) ;
if (fromend) {
val = seq;
for (seq = NIL, i = 0; i < end; i++, val = cdr(val))
seq = cons(car(val), seq);
}
for (; end-- > 0; seq = cdr(seq)) {
val = car(seq);
if (bigtest(val)) {
if (ftype==CNTFCN) counter++;
else goto fin;
}
if (fromend) count--;
else count++;
}
break;
case VECTOR:
case STRING:
case TVEC:
if (fromend) {
for (; count >= (int) start; count--) {
val = gettvecelement(seq, count);
if (bigtest(val)) {
if (ftype==CNTFCN) counter++;
else goto fin;
}
}
}
else {
for (; count < end; count++) {
val = gettvecelement(seq, count);
if (bigtest(val)) {
if (ftype==CNTFCN) counter++;
else goto fin;
}
}
}
break;
default:
xlbadtype(seq); break;
}
#ifdef KEYARG
xlpopn(4);
#else
xlpopn(3);
#endif
return (ftype==CNTFCN ? cvfixnum((FIXTYPE)counter) : NIL);
fin:
#ifdef KEYARG
xlpopn(4);
#else
xlpopn(3);
#endif
return (ftype==POSFCN ? cvfixnum((FIXTYPE)count) : val);
}
/* nine different functions are done by xlkitchensink */
LVAL xcount(V) { /* count */
return(xlkitchensink(CNTFCN,TRUE,TRUE));
}
LVAL xcountif(V) { /* count-if */
return(xlkitchensink(CNTFCN,TRUE,FALSE));
}
LVAL xcountifnot(V) { /* count-if-not */
return(xlkitchensink(CNTFCN,FALSE,FALSE));
}
LVAL xposition(V) { /* position */
return(xlkitchensink(POSFCN,TRUE,TRUE));
}
LVAL xpositionif(V) { /* position-if */
return(xlkitchensink(POSFCN,TRUE,FALSE));
}
LVAL xpositionifnot(V) { /* position-if-not */
return(xlkitchensink(POSFCN,FALSE,FALSE));
}
LVAL xfind(V) { /* find */
return(xlkitchensink(FNDFCN,TRUE,TRUE));
}
LVAL xfindif(V) { /* find-if */
return(xlkitchensink(FNDFCN,TRUE,FALSE));
}
LVAL xfindifnot(V) { /* find-if-not */
return(xlkitchensink(FNDFCN,FALSE,FALSE));
}
#endif
#ifdef SRCHFCN
/* xsearch -- search function */
LVAL xsearch(V)
{
LVAL seq1, seq2, fcn, temp1, temp2, elt1, elt2;
unsigned start1, start2, end1, end2, len1, len2;
unsigned i,j;
int tresult,typ1, typ2;
#ifdef KEYARG
LVAL kfcn;
#endif
/* get the sequences */
seq1 = xlgaseq();
len1 = getlength(seq1);
seq2 = xlgaseq();
len2 = getlength(seq2);
/* test/test-not args? */
xltest(&fcn,&tresult);
/* check for start/end keys */
getseqbounds(&start1,&end1,len1,k_1start,k_1end);
getseqbounds(&start2,&end2,len2,k_2start,k_2end);
#ifdef KEYARG
kfcn = xlkey();
#endif
xllastkey();
/* calculate the true final search string location that needs to
be checked (end2) */
if (end2 - start2 < end1 - start1 /* nothing to compare */
|| end2 - start2 == 0)
return (NIL);
len1 = end1 - start1; /* calc lengths of sequences to test */
end2 -= len1; /* we don't need to compare with start loc
beyond this value */
typ1 = ntype(seq1);
typ2 = ntype(seq2);
#ifdef KEYARG
xlstkcheck(4);
xlprotect(kfcn);
#else
xlstkcheck(3);
#endif
xlprotect(fcn);
xlsave(elt1);
xlsave(elt2);
if (typ1 == CONS) { /* skip leading section of sequence 1 if a cons */
j = start1;
while (j--) seq1 = cdr(seq1);
}
if (typ2 == CONS) { /* second string is cons */
i = start2; /* skip leading section of string 2 */
while (start2--) seq2 = cdr(seq2);
for (;i<=end2;i++) {
temp2 = seq2;
if (typ1 == CONS) {
temp1 = seq1;
for (j = start1; j < end1; j++) {
#ifdef KEYARG
if (dotest2s(car(temp1),car(temp2),fcn,kfcn) != tresult)
goto next1;
#else
if (dotest2(car(temp1),car(temp2),fcn) != tresult)
goto next1;
#endif
temp1 = cdr(temp1);
temp2 = cdr(temp2);
}
}
else {
for (j = start1; j < end1; j++) {
elt1 = gettvecelement(seq1, j);
#ifdef KEYARG
if (dotest2s(elt1, car(temp2), fcn, kfcn) !=tresult)
#else
if (dotest2(elt1, car(temp2), fcn)!=tresult)
#endif
goto next1;
temp2 = cdr(temp2);
}
}
#ifdef KEYARG
xlpopn(4);
#else
xlpopn(3);
#endif
return cvfixnum(i);
next1: /* continue */
seq2 = cdr(seq2);
}
}
else
for (i = start2; i <= end2 ; i++) { /* second string is array/string */
if (typ1 == CONS) {
temp1 = seq1;
for (j = 0; j < len1; j++) {
elt2 = gettvecelement(seq2, i+j);
#ifdef KEYARG
if (dotest2s(car(temp1), elt2, fcn,kfcn) != tresult)
#else
if (dotest2(car(temp1), elt2, fcn) != tresult)
#endif
goto next2;
temp1 = cdr(temp1);
}
}
else
for (j=start1; j < end1; j++) {
elt1 = gettvecelement(seq1,j);
elt2 = gettvecelement(seq2,i+j-start1);
#ifdef KEYARG
if (dotest2s(elt1, elt2, fcn, kfcn) != tresult)
#else
if (dotest2(elt1, elt2, fcn) != tresult)
#endif
goto next2;
}
#ifdef KEYARG
xlpopn(4);
#else
xlpopn(3);
#endif
return cvfixnum(i);
next2:; /* continue */
}
#ifdef KEYARG
xlpopn(4);
#else
xlpopn(3);
#endif
return (NIL); /*no match*/
}
#endif
/* The following is based on code with the following copyright message: */
/* XLISP-STAT 2.0 Copyright (c) 1988, by Luke Tierney */
/* All Rights Reserved */
/* Permission is granted for unrestricted non-commercial use */
/* Extended by Tom Almy to put in a single C function, allow :start and
:end keywords, correctly handle case of null(seq), and case where
sequence is a string */
/* Common Lisp REDUCE function */
LVAL xreduce(V)
{
LVAL fcn, seq, initial_value;
LVAL next, args, result;
int has_init;
unsigned start, end;
fcn = xlgetarg();
seq = xlgaseq();
has_init = xlgetkeyarg(k_ivalue, &initial_value);
getseqbounds(&start, &end, getlength(seq), k_start, k_end);
xllastkey();
/* protect some pointers */
xlstkcheck(4);
xlsave(next);
xlsave(args);
xlsave(result);
xlprotect(fcn);
args = cons(NIL, cons(NIL,NIL));
if (null(seq) || start==end) {
result = has_init ? initial_value : xlapply(pushargs(fcn, NIL));
}
else switch (ntype(seq)) {
case CONS:
end -= start;
while (start-- > 0) seq = cdr(seq); /* skip to start */
next = seq;
if (has_init) result = initial_value;
else {
result = car(next);
next = cdr(next);
end--;
}
for (; end-- > 0; next = cdr(next)) {
rplaca(args, result);
rplaca(cdr(args), car(next));
result = xlapply(pushargs(fcn, args));
}
break;
case VECTOR:
case STRING:
case TVEC:
if (has_init)
result = initial_value;
else {
result = gettvecelement(seq, start);
start++;
}
for (; start < end; start++) {
rplaca(args, result);
rplaca(cdr(args), gettvecelement(seq, start));
result = xlapply(pushargs(fcn, args));
}
break;
default:
xlbadtype(seq);
}
/* restore the stack frame */
xlpopn(4);
return(result);
}
/* Common Lisp REMOVE-DUPLICATES function */
/* by Tom Almy */
/* unlike xllist.c version, this one works on all sequences and
allows the :start and :end keywords. */
LVAL xremove_duplicates(V)
{
LVAL seq,fcn,val,next,tmp,item;
LVAL last=NULL,vstart=NIL;
unsigned i,j,l,k;
unsigned start,end,esize;
int tresult, fromend;
#ifdef KEYARG
LVAL kfcn;
#endif
/* get the sequence */
seq = xlgaseq();
/* get any optional args */
xltest(&fcn,&tresult);
getseqbounds(&start,&end,getlength(seq),k_start,k_end);
#ifdef KEYARG
kfcn = xlkey();
#endif
if (xlgetkeyarg(k_fromend, &tmp) && !null(tmp))
fromend = TRUE;
else
fromend = FALSE;
xllastkey();
if (null(seq)) return NIL;
/* protect some pointers */
#ifdef KEYARG
xlstkcheck(5);
xlprotect(kfcn);
#else
xlstkcheck(4);
#endif
xlsave(item);
xlsave(tmp);
xlprotect(fcn);
xlsave(val);
/* remove matches */
switch (ntype(seq)) {
case CONS:
end -= start; /* length of valid subsequence */
while (start-- > 0) { /* copy leading part intact */
next = consa(car(seq));
if (!null(val)) rplacd(last,next);
else val=next;
last= next;
}
if (fromend) {
for (; end-- > 0; seq = cdr(seq)) {
/* check to see if this element should be deleted */
item = car(seq);
#ifdef KEYARG
if (!null(kfcn)) item = xlapp1(kfcn,item);
for (tmp=vstart; consp(tmp); tmp = cdr(tmp))
if (dotest2(item,car(tmp),fcn,kfcn)==tresult)
goto cons_noxfer_fromend;
#else
for (tmp=vstart; consp(tmp); tmp = cdr(tmp))
if (dotest2(item,car(tmp),fcn)==tresult)
goto cons_noxfer_fromend;
#endif
next = consa(car(seq));
if (!null(val)) rplacd(last,next);
else val = next;
last = next;
if (null(vstart)) vstart = next;
cons_noxfer_fromend:;
}
}
else {
for (; end-- > 1; seq = cdr(seq)) {
/* check to see if this element should be deleted */
item = car(seq);
#ifdef KEYARG
if (!null(kfcn)) item = xlapp1(kfcn,item);
for (l=end,tmp=cdr(seq); l-- >0; tmp = cdr(tmp))
if (dotest2(item,car(tmp),fcn,kfcn)==tresult)
goto cons_noxfer;
#else
for (l=end,tmp=cdr(seq); l-- >0; tmp = cdr(tmp))
if (dotest2(item,car(tmp),fcn)==tresult)
goto cons_noxfer;
#endif
next = consa(car(seq));
if (!null(val)) rplacd(last,next);
else val = next;
last = next;
cons_noxfer:;
}
}
/* now copy to end */
while (consp(seq)) {
next = consa(car(seq));
if (!null(val)) rplacd(last,next);
else val = next;
last = next;
seq = cdr(seq);
}
break;
case VECTOR:
case STRING:
case TVEC:
val = mktvec(l=gettvecsize(seq), gettvecetype(seq));
esize = gettveceltsize(seq);
if (start>0)
MEMCPY(gettvecdata(val), gettvecdata(seq),start * esize);
for (i=j=start; i < end; i++) {
item = gettvecelement(seq,i);
#ifdef KEYARG
if (!null(kfcn)) item = xlapp1(kfcn,item);
if (fromend) {
for (k=start; k<j; k++) {
tmp = gettvecelement(seq,k);
if (dotest2(item,tmp,fcn,kfcn)==tresult)
goto vector_noxfer;
}
}
else {
for (k=i+1; k<end; k++) {
tmp = gettvecelement(seq,k);
if (dotest2(item,tmp,fcn,kfcn)==tresult)
goto vector_noxfer;
}
}
#else
if (fromend) {
for (k=start; k<j; k++) {
tmp = gettvecelement(seq,k);
if (dotest2(item,tmp,fcn)==tresult)
goto vector_noxfer;
}
}
else {
for (k=i+1; k<end; k++) {
tmp = gettvecelement(seq,k);
if (dotest2(item,tmp,fcn)==tresult)
goto vector_noxfer;
}
}
#endif
settvecelement(val,j++,item);
vector_noxfer:;
}
if (l-end > 0) { /* elements at end to copy */
MEMCPY(((char *) gettvecdata(val)) + j * esize,
((char *) gettvecdata(seq)) + end * esize,
(l - end) * esize);
j += l - end;
}
if (l != j) { /* need new, shorter result -- too bad */
fcn = val; /* save value in protected cell */
val = mktvec(j, gettvecetype(seq));
MEMCPY(gettvecdata(val), gettvecdata(fcn), j * esize);
}
break;
default:
xlbadtype(seq); break;
}
/* restore the stack */
#ifdef KEYARG
xlpopn(5);
#else
xlpopn(4);
#endif
/* return the updated sequence */
return (val);
}
/* Common Lisp COPY-SEQ function */
LVAL xcopyseq(V)
{
LVAL x;
x = xlgaseq();
xllastarg();
if (listp(x)) return(copylist(x));
else return(copyvector(x));
}
LVAL xreplace(V)
{
LVAL seq1, seq2;
unsigned start1, start2, end1, end2, len1, len2;
/* get the sequences */
seq1 = xlgaseq();
len1 = getlength(seq1);
seq2 = xlgaseq();
len2 = getlength(seq2);
/* check for start/end keys */
getseqbounds(&start1,&end1,len1,k_1start,k_1end);
getseqbounds(&start2,&end2,len2,k_2start,k_2end);
xlreplace(seq1, seq2, start1, end1, start2, end2);
return seq1;
}
syntax highlighted by Code2HTML, v. 0.9.1