/* 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"
#include <string.h>

#ifdef COMMONLISP

/* external variables */
extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
extern LVAL true;

/* 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. */
/* (position-if pred seq) -- returns position of first match */
/* (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 */
/* find-if count-if -- previous Common Lisp extension, rewritten to allow
   all sequence types */
/* the keyword arguments :start and :end are now valid for the remove, delete,
   find position and count functions */


/* The author, Tom Almy, appologizes for using "goto" several places in
   this code. */

#define MAXSIZE ((unsigned)-1)	/* the maximum unsigned integer value */

#ifdef ANSI
static void getseqbounds(unsigned *start, unsigned *end, unsigned length, 
					     LVAL *startkey, LVAL *endkey)
#else
LOCAL VOID getseqbounds(start,end,length,startkey,endkey)
unsigned *start, *end, length;
LVAL *startkey, *endkey;
#endif
{
	LVAL arg;
	FIXTYPE temp;

	if (xlgkfixnum(*startkey,&arg)) {
		temp = (long)getfixnum(arg);
		if (temp < 0 || temp > length ) goto rangeError;
		*start = (unsigned)temp;
	}
	else *start = 0;
	
	if (xlgetkeyarg(*endkey, &arg) && arg != NIL) {
		if (!fixp(arg)) xlbadtype(arg);
		temp = (long)getfixnum(arg);
		if (temp < *start  || temp > length) goto rangeError;
		*end = (unsigned)temp;	
	}
	else *end = length;
	
	return;
	/* else there is a range error */
	
rangeError:
	xlerror("range error",arg);
}
		


/* dotest1 - call a test function with one argument */
/* this function was in xllist.c */
#ifdef ANSI
static int dotest1(LVAL arg, LVAL fun)
#else
LOCAL int dotest1(arg,fun)
  LVAL arg,fun;
#endif
{
    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);

}


/* xelt - sequence reference function */
LVAL xelt()
{
    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 */
	}
		

	if (ntype(seq) == STRING) {	
		if (i >= getslength(seq)-1) goto badindex;
		return (cvchar(getstringch(seq,i)));
	}
	
	if (ntype(seq)!=VECTOR) xlbadtype(seq);	/* type must be array */

    /* range check the index */
    if (i >= getsize(seq)) goto badindex;

    /* return the array element */
    return (getelement(seq,(int)i));
	
badindex:
	xlerror("index out of bounds",index);
	return (NIL);	/* eliminate warnings */
}


/* xmap -- map function */

#ifdef ANSI
static unsigned getlength(LVAL seq)
#else
LOCAL unsigned getlength(seq)
LVAL seq;
#endif
{
	unsigned len;
	
	if (seq == NIL) return 0;
	
	switch (ntype(seq)) {
		case STRING: 
			return (unsigned)(getslength(seq) - 1);
		case VECTOR: 
			return (unsigned)(getsize(seq));
		case CONS: 
			len = 0;
			while (consp(seq)) {
				len++;
				seq = cdr(seq);
			}
			return len;
		default: 
			xlbadtype(seq);
			return (0); /* ha ha */
		}
}


LVAL xmap()
{
	LVAL *newfp, fun, lists, val, last, x, y;
	unsigned len,temp, i;
	int argc, typ;
	
	/* protect some pointers */
    xlstkcheck(3);
    xlsave(fun);
    xlsave(lists);
    xlsave(val);

	/* get the type of resultant */
	if ((last = xlgetarg()) == NIL) {	/* nothing is returned */
		typ = 0;
	}
	else if ((typ = xlcvttype(last)) != CONS && 
				typ != STRING && typ != VECTOR) {
		xlerror("invalid result type", last);
	}
	
	/* get the function to apply and argument sequences */
	fun = xlgetarg();
	val = NIL;
	lists = xlgetarg();
	len = getlength(lists);
	argc = 1;

	/* check for invalid result size (actually only needed when 16bit ints)*/
	if (((int)len)<0 && (typ==STRING || typ==VECTOR)) {
		xlerror("too long",last);
	}

	/* build a list of argument lists */
	for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
		val = xlgetarg();
		if ((temp = getlength(val)) < len) len = temp;
		argc++;
		rplacd(last,(cons(val,NIL)));
	}
	
	/* initialize the result list */
	switch (typ) {
		case VECTOR: val = newvector(len); break;
		case STRING: val = newstring(len+1); break;
		default:	val = NIL; break;
	}
	
	
    /* 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(NIL);
		for (x = lists; x != NIL ; x = cdr(x)) {
			y = car(x);
			switch (ntype(y)) {
				case CONS: 
					pusharg(car(y));
					rplaca(x,cdr(y));
					break;
				case VECTOR:
					pusharg(getelement(y,i));
					break;
				case STRING:
					pusharg(cvchar(getstringch(y,i)));
					break;
			}
		}

		/* apply the function to the arguments */
		newfp[2] = cvfixnum((FIXTYPE)argc);
		xlfp = newfp;
		x = xlapply(argc);
		
		switch (typ) {
			case CONS:
				y = consa(x);
				if (val) rplacd(last,y);
				else val = y;
				last = y;
				break;
			case VECTOR:
				setelement(val,i,x);
				break;
			case STRING:
				if (!charp(x)) 
					xlerror("map function returned non-character",x);
				val->n_string[i] = getchcode(x);
				break;
		}
			
	}

    /* restore the stack */
    xlpopn(3);

    /* return the last test expression value */
    return (val);
	}


/* every, some, notany, notevery */

#define EVERY 0
#define SOME 1
#define NOTEVERY 2
#define NOTANY 3

#ifdef ANSI
static LVAL xlmapwhile(int cond)
#else
LOCAL LVAL xlmapwhile(cond)
int cond;
#endif
{
	int exitcond;
	LVAL *newfp, 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 = xlgetarg();
	len = getlength(lists);
	argc = 1;

	/* build a list of argument lists */
	for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
		val = xlgetarg();
		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 = true;
			break;
	}


    /* 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(NIL);
		for (x = lists; x != NIL ; x = cdr(x)) {
			y = car(x);
			switch (ntype(y)) {
				case CONS: 
					pusharg(car(y));
					rplaca(x,cdr(y));
					break;
				case VECTOR:
					pusharg(getelement(y,i));
					break;
				case STRING:
					pusharg(cvchar(getstringch(y,i)));
					break;
			}
		}

		/* apply the function to the arguments */
		newfp[2] = cvfixnum((FIXTYPE)argc);
		xlfp = newfp;
		val = xlapply(argc);
		if ((val == NIL) ^ exitcond) break;
	}

	if ((cond == NOTANY) | (cond == NOTEVERY)) {
		if (val == NIL)  
			val = true;
		else 
			val = NIL;
	}
	

    /* restore the stack */
    xlpopn(2);

    /* return the last test expression value */
    return (val);
	}


LVAL xevery()
{
	return xlmapwhile(EVERY);
}

LVAL xsome()
{
	return xlmapwhile(SOME);
}

LVAL xnotany()
{
	return xlmapwhile(NOTANY);
}

LVAL xnotevery()
{
	return xlmapwhile(NOTEVERY);
}

/* xconcatenate - concatenate a bunch of sequences */
/* replaces (and extends) strcat, now a macro */
#ifdef ANSI
static int calclength(void)
#else
LOCAL int calclength()
#endif
{
	LVAL tmp, *saveargv;
	int saveargc;
	int len;

    /* save the argument list */
    saveargv = xlargv;
    saveargc = xlargc;

    /* find the length of the new string or vector */
    for (len = 0; moreargs(); ) {
		tmp = xlgetarg();
		len += getlength(tmp);

		if (len < 0) xlerror("too long",tmp);  /*trick to check for overflow*/
    }

    /* restore the argument list */
    xlargv = saveargv;
    xlargc = saveargc;

	return len;
}


#ifdef ANSI
static LVAL cattostring(void)
#else
LOCAL LVAL cattostring()
#endif
{
	LVAL tmp,temp,val;
    char *str;
    int len,i;
	
	/* find resulting length -- also validates argument types */
	len = calclength();

    /* create the result string */
    val = newstring(len+1);
    str = getstring(val);

    /* combine the strings */
    while (moreargs()) {
		tmp = nextarg();
		if (tmp != NIL) switch (ntype(tmp)) {
			case STRING: 
				len = getslength(tmp)-1;
				memcpy((char *)str, (char *)getstring(tmp), len);
				str += len;
				break;
			case VECTOR:
				len = getsize(tmp);
				for (i = 0; i < len; i++) {
					temp = getelement(tmp,i);
					if (!charp(temp)) goto failed;
					*str++ = getchcode(temp);
				}
				break;
			case CONS:
				while (consp(tmp)) {
					temp = car(tmp);
					if (!charp(temp)) goto failed;
					*str++ = getchcode(temp);
					tmp = cdr(tmp);
				}
				break;
		}
	}

	*str = 0;	/* delimit string (why, I don't know!) */

    /* return the new string */
    return (val);

failed:
	xlerror("cannot make into string", tmp);
	return (NIL);	/* avoid warning message */
}

#ifdef ANSI
static LVAL cattovector(void)
#else
LOCAL LVAL cattovector()
#endif
{
	LVAL tmp,val;
    LVAL *vect;
    int len,i;
	
	/* find resulting length -- also validates argument types */
	len = calclength();

    /* create the result vector */
    val = newvector(len);
    vect = &val->n_vdata[0];

    /* combine the vectors */
    while (moreargs()) {
		tmp = nextarg();
		if (tmp != NIL) switch (ntype(tmp)) {
			case VECTOR: 
				len = getsize(tmp);
				memcpy(vect, &getelement(tmp,0), len*sizeof(LVAL));
				vect += len;
				break;
			case STRING:
				len = getslength(tmp)-1;
				for (i = 0; i < len; i++) {
					*vect++ = cvchar(getstringch(tmp,i));
				}
				break;
			case CONS:
				while (consp(tmp)) {
					*vect++ = car(tmp);
					tmp = cdr(tmp);
				}
				break;
		}
	}

    /* return the new vector */
    return (val);
}

#ifdef ANSI
static LVAL cattocons(void)
#else
LOCAL LVAL cattocons()
#endif
{
	LVAL val,tmp,next,last=NIL;
	int len,i;
	
	xlsave1(val);		/* protect against GC */
	
    /* combine the lists */
    while (moreargs()) {
		tmp = nextarg();
		if (tmp != NIL) switch (ntype(tmp)) {
			case CONS:
				while (consp(tmp)) {
					next = consa(car(tmp));
					if (val) rplacd(last,next);
					else val = next;
					last = next;
					tmp = cdr(tmp);
				}
				break;
			case VECTOR:
				len = getsize(tmp);
				for (i = 0; i<len; i++) {
					next = consa(getelement(tmp,i));
					if (val) rplacd(last,next);
					else val = next;
					last = next;
				}
				break;
			case STRING:
				len = getslength(tmp) - 1;
				for (i = 0; i < len; i++) {
					next = consa(cvchar(getstringch(tmp,i)));
					if (val) rplacd(last,next);
					else val = next;
					last = next;
				}
				break;
			default: 
				xlbadtype(tmp); break; /* need default because no precheck*/
		}
	}
	
	xlpop();
	
	return (val);

}
	

LVAL xconcatenate()
{
    LVAL tmp;
	
	switch (xlcvttype(tmp = xlgetarg())) {	/* target type of data */
		case CONS:		return cattocons();
		case STRING:	return cattostring();			
		case VECTOR:	return cattovector();
		default:		xlerror("invalid result type", tmp);
						return (NIL);	/* avoid warning */
	}
}

/* xsubseq - return a subsequence -- new version */

LVAL xsubseq()
{
	unsigned start,end,len;
	FIXTYPE temp;
	int srctype;
	LVAL src,dst;
	LVAL next,last=NIL;

    /* get sequence */
	src = xlgetarg();
	if (listp(src)) srctype = CONS;
	else srctype=ntype(src);

	
	/* get length */
	switch (srctype) {
		case STRING:
			len = getslength(src) - 1;
			break;
		case VECTOR:
			len = getsize(src);
			break;
		case CONS:
			dst = src;	/* use dst as temporary */
			len = 0;
			while (consp(dst)) {len++; dst = cdr(dst);}
			break;
		default:
			xlbadtype(src);
	}

    /* get the starting position */
    dst = xlgafixnum(); temp = (int)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 (dst == NIL) end = len;
		else if (fixp(dst)) {
			temp = (int)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+1);
			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 CONS:
			xlsave1(dst);
			while (start--) src = cdr(src);
			while (len--) {
				next = consa(car(src));
				if (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 xnreverse()
{
    LVAL seq,val,next;
	unsigned int i,j;
	int ival;

    /* get the sequence to reverse */
    seq = xlgetarg();
    xllastarg();

	if (seq == NIL) return (NIL);	/* empty argument */
	
	switch (ntype(seq)) {
		case CONS:
			val = NIL;
			while (consp(seq)) {
				next = cdr(seq);
				rplacd(seq,val);
				val = seq;
				seq = next;
			}
			break;
		case VECTOR:
			for (i = 0, j = getlength(seq)-1; i < j; i++, j--) {
				val = getelement(seq,i);
				setelement(seq,i,getelement(seq,j));
				setelement(seq,j,val);
			}
			return seq;
			break;
		case STRING:
			for (i = 0, j=getslength(seq)-2 ; i < j; i++, j--) {
				ival = seq->n_string[i];
				seq->n_string[i] = seq->n_string[j];
				seq->n_string[j] = ival;
			}
			return seq;
			break;
		default: 
			xlbadtype(seq); break;
	}

    /* return the sequence */
    return (val);
}

/* xreverse - built-in function reverse -- new version */
LVAL xreverse()
{
    LVAL seq,val;
	int i,len;

    /* get the sequence to reverse */
    seq = xlgetarg();
    xllastarg();

	if (seq == NIL) 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) - 1;
			val = newstring(len+1);
			for (i = 0; i < len; i++)
				val->n_string[i] = seq->n_string[len-i-1];
			val->n_string[len] = 0;
			break;
		default: 
			xlbadtype(seq); break;
	}

    /* return the sequence */
    return (val);
}


/* remif - common code for 'remove', 'remove-if', and 'remove-if-not' */
#ifdef ANSI
static LVAL remif(int tresult, int expr)
#else
LOCAL LVAL remif(tresult,expr)
  int tresult,expr;
#endif
{
    LVAL x,seq,fcn,val,last,next;
	unsigned i,j,l;
	unsigned start,end;

	if (expr) {
	    /* get the expression to remove and the sequence */
		x = xlgetarg();
		seq = xlgetarg();
		xltest(&fcn,&tresult);
	}
	else {
		/* get the function and the sequence */
		fcn = xlgetarg();
		seq = xlgetarg();
/*		xllastarg(); */
	}

	if (seq == NIL) return NIL;

	getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
	
    /* protect some pointers */
    xlstkcheck(2);
    xlprotect(fcn);
    xlsave(val);

    /* remove matches */
	
	switch (ntype(seq)) {
		case CONS:
			for (; consp(seq); seq = cdr(seq)) {
				long s=start, l=end-start;
				/* check to see if this element should be deleted */
				/* force copy if count, as specified by end, is exhausted */
				if (s-- > 0 || l-- <= 0 || 
					(expr?dotest2(x,car(seq),fcn)
					:dotest1(car(seq),fcn)) != tresult) {
					next = consa(car(seq));
					if (val) rplacd(last,next);
					else val = next;
					last = next;
				}
			}
			break;
		case VECTOR:
			val = newvector(l=getlength(seq));
			for (i=j=0; i < l; i++) {
				if (i < start || i >= end ||	/* copy if out of range */
					(expr?dotest2(x,getelement(seq,i),fcn)
					:dotest1(getelement(seq,i),fcn)) != tresult) {
					setelement(val,j++,getelement(seq,i));
				}
			}
			if (l != j) { /* need new, shorter result -- too bad */
				fcn = val; /* save value in protected cell */
				val = newvector(j);
				memcpy(val->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
			}
			break;
		case STRING:
			l = getslength(seq)-1;
			val = newstring(l+1);
			for (i=j=0; i < l; i++) {
				if (i < start || i >= end ||	/* copy if out of range */
					(expr?dotest2(x,cvchar(getstringch(seq,i)),fcn)
					:dotest1(cvchar(getstringch(seq,i)),fcn)) != tresult) {
					val->n_string[j++] = seq->n_string[i];
				}
			}
			if (l != j) { /* need new, shorter result -- too bad */
				fcn = val; /* save value in protected cell */
				val = newstring(j+1);
				memcpy(val->n_string, fcn->n_string, j*sizeof(char));
				val->n_string[j] = 0;
			}
			break;
		default:
			xlbadtype(seq); break;
	}
		
			
    /* restore the stack */
    xlpopn(2);

    /* return the updated sequence */
    return (val);
}

/* xremif - built-in function 'remove-if' -- enhanced version */
LVAL xremif()
{
    return (remif(TRUE,FALSE));
}

/* xremifnot - built-in function 'remove-if-not' -- enhanced version */
LVAL xremifnot()
{
    return (remif(FALSE,FALSE));
}

/* xremove - built-in function 'remove' -- enhanced version */

LVAL xremove()
{
	return (remif(TRUE,TRUE));
}


/* delif - common code for 'delete', 'delete-if', and 'delete-if-not' */
#ifdef ANSI
static LVAL delif(int tresult, int expr)
#else
LOCAL LVAL delif(tresult,expr)
  int tresult,expr;
#endif
{
    LVAL x,seq,fcn,last,val;
	unsigned i,j,l;
	unsigned start,end;

	if (expr) {
	    /* get the expression to delete and the sequence */
		x = xlgetarg();
		seq = xlgetarg();
		xltest(&fcn,&tresult);
	}
	else {
		/* get the function and the sequence */
		fcn = xlgetarg();
		seq = xlgetarg();
/*		xllastarg(); */
	}

	if (seq == NIL) return NIL;

	getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);

	/* protect a pointer */
    xlstkcheck(1);
    xlprotect(fcn);


    /* delete matches */
	
	switch (ntype(seq)) {
		case CONS:
			end -= start; /* gives length */
			/* delete leading matches */
			while (consp(seq)) {
				if (start-- > 0 || (expr?dotest2(x,car(seq),fcn)
					:dotest1(car(seq),fcn)) != tresult)
					break;
				seq = cdr(seq);
			}
			val = last = seq;

			/* delete embedded matches */
			if (consp(seq)) {

				/* skip the first non-matching element */
				seq = cdr(seq);

				for (;consp(seq) && start-- > 0;seq=cdr(seq));

				/* look for embedded matches */
				while (consp(seq)) {

					/* check to see if this element should be deleted */
					if (end-- > 0 &&
						(expr?dotest2(x,car(seq),fcn)
					:dotest1(car(seq),fcn)) == tresult)
						rplacd(last,cdr(seq));
					else
						last = seq;

					/* move to the next element */
					seq = cdr(seq);
				}
			}
			break;
		case VECTOR:
			l = getlength(seq);
			for (i=j=0; i < l; i++) {
				if (i < start || i >= end ||	/* copy if out of range */
					(expr?dotest2(x,getelement(seq,i),fcn)
					:dotest1(getelement(seq,i),fcn)) != tresult) {
					if (i != j) setelement(seq,j,getelement(seq,i));
					j++;
				}
			}
			if (l != j) { /* need new, shorter result -- too bad */
				fcn = seq; /* save value in protected cell */
				seq = newvector(j);
				memcpy(seq->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
			}
			val = seq;
			break;
		case STRING:
			l = getslength(seq)-1;
			for (i=j=0; i < l; i++) {
				if (i < start || i >= end ||	/* copy if out of range */
				    (expr?dotest2(x,cvchar(getstringch(seq,i)),fcn)
					:dotest1(cvchar(getstringch(seq,i)),fcn)) != tresult) {
					if (i != j) seq->n_string[j] = seq->n_string[i];
					j++;
				}
			}
			if (l != j) { /* need new, shorter result -- too bad */
				fcn = seq; /* save value in protected cell */
				seq = newstring(j+1);
				memcpy(seq->n_string, fcn->n_string, j*sizeof(char));
				seq->n_string[j] = 0;
			}
			val = seq;
			break;
		default:
			xlbadtype(seq); break;
	}
		
			
    /* restore the stack */
    xlpop();

    /* return the updated sequence */
    return (val);
}

/* xdelif - built-in function 'delete-if' -- enhanced version */
LVAL xdelif()
{
    return (delif(TRUE,FALSE));
}

/* xdelifnot - built-in function 'delete-if-not' -- enhanced version */
LVAL xdelifnot()
{
    return (delif(FALSE,FALSE));
}

/* xdelete - built-in function 'delete' -- enhanced version */

LVAL xdelete()
{
	return (delif(TRUE,TRUE));
}

#ifdef ADDEDTAA
/* xcountif - built-in function 'count-if     TAA MOD addition */
LVAL xcountif()
{
	unsigned counter=0;
	unsigned i,l;
	unsigned start,end;
	LVAL seq, fcn;

	
	/* get the arguments */
	fcn = xlgetarg();
	seq = xlgetarg();
/*	xllastarg(); */

	if (seq == NIL) return (cvfixnum((FIXTYPE)0));

	getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);

	xlstkcheck(1);
	xlprotect(fcn);

	/* examine arg and count */
	switch (ntype(seq)) {
		case CONS:
			end -= start;
			for (; consp(seq) && start-- > 0; seq = cdr(seq));
			for (; consp(seq); seq = cdr(seq))
				if (end-- > 0 && dotest1(car(seq),fcn)) counter++;
			break;
		case VECTOR:
			l = getlength(seq);
			if (end < l) l = end;
			for (i=start; i < l; i++)
				if (dotest1(getelement(seq,i),fcn)) counter++;
			break;
		case STRING:
			l = getslength(seq)-1;
			if (end < l) l = end;
			for (i=start; i < l; i++)
				if (dotest1(cvchar(getstringch(seq,i)),fcn)) counter++;
			break;
		default:
			xlbadtype(seq); break;
	}

	xlpop();

	return (cvfixnum((FIXTYPE)counter));
}

/* xfindif - built-in function 'find-if'    TAA MOD */
LVAL xfindif()
{
	LVAL seq, fcn, val;
	unsigned start,end;
	unsigned i,l;
	
	fcn = xlgetarg();
	seq = xlgetarg();
/*	xllastarg(); */
	
	if (seq == NIL) return NIL;

	getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);

	xlstkcheck(1);
	xlprotect(fcn);

	switch (ntype(seq)) {
		case CONS:
			end -= start;
			for (; consp(seq) && start-- > 0; seq = cdr(seq));
			for (; consp(seq); seq = cdr(seq)) {
				if (end-- > 0 && dotest1(val=car(seq), fcn)) goto fin;
			}
			break;
		case VECTOR:
			l = getlength(seq);
			if (end < l) l = end;
			for (i=start; i < l; i++)
				if (dotest1(val=getelement(seq,i),fcn)) goto fin;
			break;
		case STRING:
			l = getslength(seq)-1;
			if (end < l) l = end;
			for (i=start; i < l; i++)
				if (dotest1(val=cvchar(getstringch(seq,i)),fcn)) goto fin;
			break;
		default:
			xlbadtype(seq); break;
	}

	val = NIL;	/* not found */
	
fin:
	xlpop();
	return (val);
}

/* xpositionif - built-in function 'position-if'    TAA MOD */
LVAL xpositionif()
{
	LVAL seq, fcn;
	unsigned start,end;
	unsigned count;
	unsigned i,l;
	
	fcn = xlgetarg();
	seq = xlgetarg();
/*	xllastarg(); */
	
	if (seq == NIL) return NIL;

	getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);

	xlstkcheck(1);
	xlprotect(fcn);

	switch (ntype(seq)) {
		case CONS:
			end -= start;
			count = start;
			for (; consp(seq) && start-- > 0; seq = cdr(seq));
			for (; consp(seq); seq = cdr(seq)) {
				if ((end-- > 0) && dotest1(car(seq), fcn)) goto fin;
				count++;
			}
			break;
		case VECTOR:
			l = getlength(seq);
			if (end < l) l = end;
			for (i=start; i < l; i++)
				if (dotest1(getelement(seq,i),fcn)) {
					count = i;
					goto fin;
				}
			break;
		case STRING:
			l = getslength(seq)-1;
			if (end < l) l = end;
			for (i=start; i < l; i++)
				if (dotest1(cvchar(getstringch(seq,i)),fcn)) {
					count = i;
					goto fin;
				}
			break;
		default:
			xlbadtype(seq); break;
	}

	xlpop();	/* not found */
	return(NIL);

fin:			/* found */
	xlpop();
	return (cvfixnum((FIXTYPE)count));
}
#endif

/* xsearch -- search function */

LVAL xsearch()
{
	LVAL seq1, seq2, fcn, temp1, temp2;
	unsigned start1, start2, end1, end2, len1, len2;
	unsigned i,j;
	int tresult,typ1, typ2;
	
	/* get the sequences */
	seq1 = xlgetarg();	
	len1 = getlength(seq1);
	seq2 = xlgetarg();
	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);
	
	if (end2 - 1 - (end1 - start1) > len2) {
		end2 = len2 + 1 + (end1 - start1);
		if (end2 < start2) end2 = start2;
	}
	
	len1 = end1 - start1;	/* calc lengths of sequences to test */

	typ1 = ntype(seq1);
	typ2 = ntype(seq2);
	
	xlstkcheck(1);
	xlprotect(fcn);

	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++) {
					if (dotest2(car(temp1),car(temp2),fcn) != tresult)
						goto next1;
					temp1 = cdr(temp1);
					temp2 = cdr(temp2);
				}
			}
			else {
				for (j = start1; j < end1; j++) {
					if (dotest2(typ1 == VECTOR ? getelement(seq1,j) :
						cvchar(getstringch(seq1,j)), car(temp2), fcn) != tresult)
						goto next1;
					temp2 = cdr(temp2);
				}
			}
			xlpop();
			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++) {
				if (dotest2(car(temp1), 
						    typ2 == VECTOR ? getelement(seq2,i+j) 
								           : cvchar(getstringch(seq2,i+j)),
							fcn) != tresult)
					goto next2;
				temp1 = cdr(temp1);
			}
		}
		else for (j=start1; j < end1; j++) {
			if (dotest2(typ1 == VECTOR ? getelement(seq1,j) : cvchar(getstringch(seq1,j)),
				typ2 == VECTOR ? getelement(seq2,i+j-start1) : cvchar(getstringch(seq2,i+j-start1)), fcn) != tresult)
					goto next2;
		}
		xlpop();
		return cvfixnum(i);
		next2:; /* continue */
	}
	
	xlpop();
	return (NIL);	/*no match*/

}


#endif