/* xllist.c - xlisp built-in list functions */
/*		Copyright (c) 1985, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

#include "xlisp.h"

/* forward declarations */
#ifdef ANSI
LVAL cxr(char *adstr);
LVAL nth(int charflag);
LVAL assoc(LVAL expr, LVAL alist, LVAL fcn, int tresult);
LVAL subst(LVAL to, LVAL from, LVAL expr, LVAL fcn, int tresult);
LVAL sublis(LVAL alist, LVAL expr, LVAL fcn, int tresult);
LVAL map(int carflag, int valflag);
void splitlist(LVAL pivot,LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn);
#ifndef COMMONLISP
int dotest1(LVAL arg, LVAL fun);
#endif
#else
FORWARD LVAL cxr();
FORWARD LVAL nth(),assoc();
FORWARD LVAL subst(),sublis(),map();
FORWARD VOID splitlist();
#endif

/* xcar - take the car of a cons cell */
LVAL xcar()
{
	LVAL list;
	list = xlgalist();
	xllastarg();
	return (list ? car(list) : NIL);
}

/* xcdr - take the cdr of a cons cell */
LVAL xcdr()
{
	LVAL list;
	list = xlgalist();
	xllastarg();
	return (list ? cdr(list) : NIL);
}

/* cxxr functions */
LVAL xcaar() { return (cxr("aa")); }
LVAL xcadr() { return (cxr("da")); }
LVAL xcdar() { return (cxr("ad")); }
LVAL xcddr() { return (cxr("dd")); }

/* cxxxr functions */
LVAL xcaaar() { return (cxr("aaa")); }
LVAL xcaadr() { return (cxr("daa")); }
LVAL xcadar() { return (cxr("ada")); }
LVAL xcaddr() { return (cxr("dda")); }
LVAL xcdaar() { return (cxr("aad")); }
LVAL xcdadr() { return (cxr("dad")); }
LVAL xcddar() { return (cxr("add")); }
LVAL xcdddr() { return (cxr("ddd")); }

/* cxxxxr functions */
LVAL xcaaaar() { return (cxr("aaaa")); }
LVAL xcaaadr() { return (cxr("daaa")); }
LVAL xcaadar() { return (cxr("adaa")); }
LVAL xcaaddr() { return (cxr("ddaa")); }
LVAL xcadaar() { return (cxr("aada")); }
LVAL xcadadr() { return (cxr("dada")); }
LVAL xcaddar() { return (cxr("adda")); }
LVAL xcadddr() { return (cxr("ddda")); }
LVAL xcdaaar() { return (cxr("aaad")); }
LVAL xcdaadr() { return (cxr("daad")); }
LVAL xcdadar() { return (cxr("adad")); }
LVAL xcdaddr() { return (cxr("ddad")); }
LVAL xcddaar() { return (cxr("aadd")); }
LVAL xcddadr() { return (cxr("dadd")); }
LVAL xcdddar() { return (cxr("addd")); }
LVAL xcddddr() { return (cxr("dddd")); }

/* cxr - common car/cdr routine */
LOCAL LVAL cxr(adstr)
  char *adstr;
{
	LVAL list;

	/* get the list */
	list = xlgalist();
		
	xllastarg();

	/* perform the car/cdr operations */
	while (*adstr && consp(list))
		list = (*adstr++ == 'a' ? car(list) : cdr(list));

	/* make sure the operation succeeded */
	if (*adstr && list)
		xlfail("bad argument");

	/* return the result */
	return (list);
}

/* xcons - construct a new list cell */
LVAL xcons()
{
	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 */
LVAL xlist()
{
	LVAL last,next,val;

	/* protect some pointers */
	xlsave1(val);

	/* add each argument to the list */
#if 0	/* old code */
	for (val = NIL; moreargs(); ) {

		/* append this argument to the end of the list */
		next = consa(nextarg());
		if (val) rplacd(last,next);
		else val = next;
		last = next;
	}
#else /* new code with tighter inner loop TAA mod */
	if (moreargs()) {
		last = val = consa(nextarg());
		while (moreargs()) {
			next = consa(nextarg());
			rplacd(last,next);
			last = next;
		}
	}
#endif
	/* restore the stack */
	xlpop();

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

/* xappend - built-in function append */
LVAL xappend()
{
	LVAL list,last,next,val;

	/* protect some pointers */
	xlsave1(val);

	/* append each argument */
	if (moreargs()) {
		while (xlargc > 1) {

			/* append each element of this list to the result list */
			for (list = nextarg(); consp(list); list = cdr(list)) {
				next = consa(car(list));
				if (val) rplacd(last,next);
				else val = next;
				last = next;
			}
			if (list != NIL) xlbadtype(*--xlargv);	/*TAA added errormessage*/
		}

		/* handle the last argument */
		if (val) rplacd(last,nextarg());
		else val = nextarg();
	}

	/* restore the stack */
	xlpop();

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


#ifndef COMMONLISP

/* xreverse - built-in function reverse */
LVAL xreverse()
{
	LVAL list,val;

	/* protect some pointers */
	xlsave1(val);

	/* get the list to reverse */
	list = xlgalist();
	xllastarg();

	/* append each element to the head of the result list */
	for (val = NIL; consp(list); list = cdr(list))
		val = cons(car(list),val);

	/* restore the stack */
	xlpop();

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

#endif

/* xlast - return the last cons of a list */
LVAL xlast()
{
	LVAL list;

	/* get the list */
	list = xlgalist();
	xllastarg();

	/* find the last cons */
	if (consp(list))			/* TAA fix */
		while (consp(cdr(list))) list = cdr(list);

	/* return the last element */
	return (list);
}

/* xmember - built-in function 'member' */
LVAL xmember()
{
	LVAL x,list,fcn,val;
	int tresult;

	/* protect some pointers */
	xlsave1(fcn);

	/* get the expression to look for and the list */
	x = xlgetarg();
	list = xlgalist();
	xltest(&fcn,&tresult);

	/* look for the expression */
	for (val = NIL; consp(list); list = cdr(list))
		if (dotest2(x,car(list),fcn) == tresult) {
			val = list;
			break;
		}

	/* restore the stack */
	xlpop();

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

/* xassoc - built-in function 'assoc' */
LVAL xassoc()
{
	LVAL x,alist,fcn,pair,val;
	int tresult;

	/* protect some pointers */
	xlsave1(fcn);

	/* get the expression to look for and the association list */
	x = xlgetarg();
	alist = xlgalist();
	xltest(&fcn,&tresult);

	/* look for the expression */
	for (val = NIL; consp(alist); alist = cdr(alist))
		if (((pair = car(alist)) != 0) && consp(pair))
			if (dotest2(x,car(pair),fcn) == tresult) {
				val = pair;
				break;
			}

	/* restore the stack */
	xlpop();

	/* return result */
	return (val);
}

/* xsubst - substitute one expression for another */
LVAL xsubst()
{
	LVAL to,from,expr,fcn,val;
	int tresult;

	/* protect some pointers */
	xlsave1(fcn);

	/* get the to value, the from value and the expression */
	to = xlgetarg();
	from = xlgetarg();
	expr = xlgetarg();
	xltest(&fcn,&tresult);

	/* do the substitution */
	val = subst(to,from,expr,fcn,tresult);

	/* restore the stack */
	xlpop();

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

/* subst - substitute one expression for another */
LOCAL LVAL subst(to,from,expr,fcn,tresult)
  LVAL to,from,expr,fcn; int tresult;
{
	LVAL carval,cdrval;

	if (dotest2(expr,from,fcn) == tresult)
		return (to);
	else if (consp(expr)) {
		xlsave1(carval);
		carval = subst(to,from,car(expr),fcn,tresult);
		cdrval = subst(to,from,cdr(expr),fcn,tresult);
		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()
{
	LVAL alist,expr,fcn,val;
	int tresult;

	/* protect some pointers */
	xlsave1(fcn);

	/* get the assocation list and the expression */
	alist = xlgalist();
	expr = xlgetarg();
	xltest(&fcn,&tresult);

	/* do the substitution */
	val = sublis(alist,expr,fcn,tresult);

	/* restore the stack */
	xlpop();

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

/* sublis - substitute using an association list */
LOCAL LVAL sublis(alist,expr,fcn,tresult)
  LVAL alist,expr,fcn; int tresult;
{
	LVAL carval,cdrval,pair;

	if ((pair = assoc(expr,alist,fcn,tresult)) != 0)
		return (cdr(pair));
	else if (consp(expr)) {
		xlsave1(carval);
		carval = sublis(alist,car(expr),fcn,tresult);
		cdrval = sublis(alist,cdr(expr),fcn,tresult);
		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 */
LOCAL LVAL assoc(expr,alist,fcn,tresult)
  LVAL expr,alist,fcn; int tresult;
{
	LVAL pair;

	for (; consp(alist); alist = cdr(alist))
		if (((pair = car(alist)) != 0) && consp(pair))
			if (dotest2(expr,car(pair),fcn) == tresult)
				return (pair);
	return (NIL);
}

#ifndef COMMONLISP
/* xremove - built-in function 'remove' */
LVAL xremove()
{
	LVAL x,list,fcn,val,last,next;
	int tresult;

	/* protect some pointers */
	xlstkcheck(2);
	xlsave(fcn);
	xlsave(val);

	/* get the expression to remove and the list */
	x = xlgetarg();
	list = xlgalist();
	xltest(&fcn,&tresult);

	/* remove matches */
	for (; consp(list); list = cdr(list))

		/* check to see if this element should be deleted */
		if (dotest2(x,car(list),fcn) != tresult) {
			next = consa(car(list));
			if (val) rplacd(last,next);
			else val = next;
			last = next;
		}

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

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

#ifdef ADDEDTAA
/* xcountif - built-in function 'count-if	  TAA MOD addition */
LVAL xcountif()
{
	int counter=0;
	LVAL list, fcn;

	xlsave1(fcn);
		
	/* get the arguments */
	fcn = xlgetarg();
	list = xlgalist();
	xllastarg();

	/* examine arg and count */
	for (; consp(list); list = cdr(list))
		if (dotest1(car(list),fcn)) counter++;

	xlpop();

	return (cvfixnum(counter));
}

/* xfindif - built-in function 'find-if'	TAA MOD */
LVAL xfindif()
{
	LVAL list, fcn;

	xlsave1(fcn);

	fcn = xlgetarg();
	list = xlgalist();
	xllastarg();

	for (; consp(list); list = cdr(list))
		if (dotest1(car(list), fcn)) {
			xlpop();
			return (car(list));
		};

	xlpop();
	return (NIL);
}
#endif

/* remif - common code for 'remove-if' and 'remove-if-not' */
#ifdef ANSI
static LVAL remif(int tresult)
#else
LOCAL LVAL remif(tresult)
  int tresult;
#endif
{
	LVAL list,fcn,val,last,next;

	/* protect some pointers */
	xlstkcheck(2);
	xlsave(fcn);
	xlsave(val);

	/* get the expression to remove and the list */
	fcn = xlgetarg();
	list = xlgalist();
	xllastarg();

	/* remove matches */
	for (; consp(list); list = cdr(list))

		/* check to see if this element should be deleted */
		if (dotest1(car(list),fcn) != tresult) {
			next = consa(car(list));
			if (val) rplacd(last,next);
			else val = next;
			last = next;
		}

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

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

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

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

#ifndef COMMONLISP
/* dotest1 - call a test function with one argument */
LOCAL int dotest1(arg,fun)
  LVAL arg,fun;
{
	LVAL *newfp;

	/* create the new call frame */
	newfp = xlsp;
	pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
	pusharg(fun);
	pusharg(cvfixnum((FIXTYPE)1));
	pusharg(arg);
	xlfp = newfp;

	/* return the result of applying the test function */
	return (xlapply(1) != NIL);

}
#endif

/* dotest2 - call a test function with two arguments */
int dotest2(arg1,arg2,fun)
  LVAL arg1,arg2,fun;
{
	LVAL *newfp;

	/* create the new call frame */
	newfp = xlsp;
	pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
	pusharg(fun);
	pusharg(cvfixnum((FIXTYPE)2));
	pusharg(arg1);
	pusharg(arg2);
	xlfp = newfp;

	/* return the result of applying the test function */
	return (xlapply(2) != NIL);

}

/* xnth - return the nth element of a list */
LVAL xnth()
{
	return (nth(TRUE));
}

/* xnthcdr - return the nth cdr of a list */
LVAL xnthcdr()
{
	return (nth(FALSE));
}

/* nth - internal nth function */
LOCAL LVAL nth(carflag)
  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()
{
	FIXTYPE n;
	LVAL arg;

	/* get the list or string */
	arg = xlgetarg();
	xllastarg();

	/* find the length of a list */
	if (listp(arg))
		for (n = 0; consp(arg); n++)
			arg = cdr(arg);

	/* find the length of a string */
	else if (stringp(arg))
		n = (FIXTYPE)getslength(arg)-1;

	/* 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));
}

/* xmapc - built-in function 'mapc' */
LVAL xmapc()
{
	return (map(TRUE,FALSE));
}

/* xmapcar - built-in function 'mapcar' */
LVAL xmapcar()
{
	return (map(TRUE,TRUE));
}

/* xmapl - built-in function 'mapl' */
LVAL xmapl()
{
	return (map(FALSE,FALSE));
}

/* xmaplist - built-in function 'maplist' */
LVAL xmaplist()
{
	return (map(FALSE,TRUE));
}

/* map - internal mapping function */
LOCAL LVAL map(carflag,valflag)
  int carflag,valflag;
{
	LVAL *newfp,fun,lists,val,last,p,x,y;
	int argc;

	/* protect some pointers */
	xlstkcheck(3);
	xlsave(fun);
	xlsave(lists);
	xlsave(val);

	/* get the function to apply and the first list */
	fun = xlgetarg();
	lists = xlgalist();

	/* initialize the result list */
	val = (valflag ? NIL : lists);

	/* build a list of argument lists */
	for (lists = last = consa(lists); moreargs(); last = cdr(last))
		rplacd(last,cons(xlgalist(),NIL));

	/* loop through each of the argument lists */
	for (;;) {

		/* build an argument list from the sublists */
		newfp = xlsp;
		pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
		pusharg(fun);
		pusharg(NIL);
		argc = 0;
		for (x = lists; x && ((y = car(x)) != 0) && consp(y); x = cdr(x)) {
			pusharg(carflag ? car(y) : y);
			rplaca(x,cdr(y));
			++argc;
		}

		/* quit if any of the lists were empty */
		if (x) {
			xlsp = newfp;
			break;
		}

		/* apply the function to the arguments */
		newfp[2] = cvfixnum((FIXTYPE)argc);
		xlfp = newfp;
		if (valflag) {
			p = consa(xlapply(argc));
			if (val) rplacd(last,p);
			else val = p;
			last = p;
		}
		else
			xlapply(argc);
	}

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

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

/* xrplca - replace the car of a list node */
LVAL xrplca()
{
	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()
{
	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()
{
	LVAL next,last,val;

	/* initialize */
	val = NIL;
	
	/* concatenate each argument */
	if (moreargs()) {
		while (xlargc > 1) {

			/* TAA mod -- give error message if not a list */
			if (((next = nextarg()) != NIL) && consp(next)) {

				/* concatenate this list to the result list */
				if (val) rplacd(last,next);
				else val = next;

				/* find the end of the list */
				while (consp(cdr(next)))
					next = cdr(next);
				last = next;
			}
			else if (next != NIL) xlbadtype(*--xlargv); /* TAA -- oops! */
		}

		/* handle the last argument */
		if (val) rplacd(last,nextarg());
		else val = nextarg();
	}

	/* return the list */
	return (val);
}
#ifndef COMMONLISP
/* xdelete - built-in function 'delete' */
LVAL xdelete()
{
	LVAL x,list,fcn,last,val;
	int tresult;

	/* protect some pointers */
	xlsave1(fcn);

	/* get the expression to delete and the list */
	x = xlgetarg();
	list = xlgalist();
	xltest(&fcn,&tresult);

	/* delete leading matches */
	while (consp(list)) {
		if (dotest2(x,car(list),fcn) != tresult)
			break;
		list = cdr(list);
	}
	val = last = list;

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

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

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

			/* check to see if this element should be deleted */
			if (dotest2(x,car(list),fcn) == tresult)
				rplacd(last,cdr(list));
			else
				last = list;

			/* move to the next element */
			list = cdr(list);
		}
	}

	/* restore the stack */
	xlpop();

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

/* delif - common routine for 'delete-if' and 'delete-if-not' */
#ifdef ANSI
static LVAL delif(int tresult)
#else
LOCAL LVAL delif(tresult)
  int tresult;
#endif
{
	LVAL list,fcn,last,val;

	/* protect some pointers */
	xlsave1(fcn);

	/* get the expression to delete and the list */
	fcn = xlgetarg();
	list = xlgalist();
	xllastarg();

	/* delete leading matches */
	while (consp(list)) {
		if (dotest1(car(list),fcn) != tresult)
			break;
		list = cdr(list);
	}
	val = last = list;

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

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

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

			/* check to see if this element should be deleted */
			if (dotest1(car(list),fcn) == tresult)
				rplacd(last,cdr(list));
			else
				last = list;

			/* move to the next element */
			list = cdr(list);
		}
	}

	/* restore the stack */
	xlpop();

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

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

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


/*
	This sorting algorithm is based on a Modula-2 sort written by
	Richie Bielak and published in the February 1988 issue of
	"Computer Language" magazine in a letter to the editor.
*/


/* gluelists - glue the smaller and larger lists with the pivot */
#ifdef ANSI
static LVAL gluelists(LVAL smaller, LVAL pivot, LVAL larger)
#else
LOCAL LVAL gluelists(smaller,pivot,larger)
  LVAL smaller,pivot,larger;
#endif
{
	LVAL last;
	
	/* larger always goes after the pivot */
	rplacd(pivot,larger);

	/* if the smaller list is empty, we're done */
	if (null(smaller))
		return (pivot);

	/* append the smaller to the front of the resulting list */
	for (last = smaller; consp(cdr(last)); last = cdr(last))
		;
	rplacd(last,pivot);
	return (smaller);
}

/* sortlist - sort a list using quicksort */
#ifdef ANSI
static LVAL sortlist(LVAL list, LVAL fcn)
#else
LOCAL LVAL sortlist(list,fcn)
  LVAL list,fcn;
#endif
{
	LVAL smaller,pivot,larger;
	
	/* protect some pointers */
	xlstkcheck(3)
	xlsave(smaller);
	xlsave(pivot);
	xlsave(larger);
	
	/* lists with zero or one element are already sorted */
	if (consp(list) && consp(cdr(list))) {
		pivot = list; list = cdr(list);
		splitlist(pivot,list,&smaller,&larger,fcn);
		smaller = sortlist(smaller,fcn);
		larger = sortlist(larger,fcn);
		list = gluelists(smaller,pivot,larger);
	}

	/* cleanup the stack and return the sorted list */
	xlpopn(3);
	return (list);
}

/* splitlist - split the list around the pivot */
LOCAL VOID splitlist(pivot,list,psmaller,plarger,fcn)
  LVAL pivot,list,*psmaller,*plarger,fcn;
{
	LVAL next;
	
	/* initialize the result lists */
	*psmaller = *plarger = NIL;
	
	/* In case of garbage collection TAA Mod thanx to Neal Holtz */
	xlstkcheck(2);
	xlprotect(list);
	xlsave(next);

	/* split the list */
	for (; consp(list); list = next) {
		next = cdr(list);
		if (dotest2(car(list),car(pivot),fcn)) {
			rplacd(list,*psmaller);
			*psmaller = list;
		}
		else {
			rplacd(list,*plarger);
			*plarger = list;
		}
	}

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

/* xsort - built-in function 'sort' */
LVAL xsort()
{
	LVAL list,fcn;

	/* protect some pointers */
	xlstkcheck(2);
	xlsave(list);
	xlsave(fcn);

	/* get the list to sort and the comparison function */
	list = xlgalist();
	fcn = xlgetarg();
	xllastarg();

	/* sort the list */
	list = sortlist(list,fcn);

	/* restore the stack and return the sorted list */
	xlpopn(2);
	return (list);
}