ecl/src/c/list.d

/*
    list.d -- List manipulating routines.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi.
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

    ECL is free software; you can redistribute it and/or
    modify it under the terms of the GNU Library General Public
    License as published by the Free Software Foundation; either
    version 2 of the License, or (at your option) any later version.

    See file '../Copyright' for full details.
*/

#include "ecl.h"
#include "ecl-inl.h"

struct cl_test {
	bool (*test_c_function)(struct cl_test *, cl_object);
	cl_object (*key_c_function)(struct cl_test *, cl_object);
	cl_object test_function;
	cl_object item_compared;
	cl_object key_function;
};

static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree);
static void nsubst(struct cl_test *t, cl_object new_obj, cl_object *tree);
static cl_object sublis(struct cl_test *t, cl_object alist, cl_object tree);
static void nsublis(struct cl_test *t, cl_object alist, cl_object *treep);

#define TEST(t,k) ((t)->test_c_function)((t),(k))

static bool
test_compare(struct cl_test *t, cl_object x)
{
	cl_object outcome = funcall(3, t->test_function, t->item_compared,
				    (t->key_c_function)(t, x));
	return (outcome != Cnil);
}

static bool
test_compare_not(struct cl_test *t, cl_object x)
{
	cl_object outcome = funcall(3, t->test_function, t->item_compared,
				    (t->key_c_function)(t, x));
	return (outcome == Cnil);
}

static bool
test_eql(struct cl_test *t, cl_object x)
{
	return eql(t->item_compared, (t->key_c_function)(t, x));
}

static cl_object
key_function(struct cl_test *t, cl_object x)
{
	return funcall(2, t->key_function, x);
}

static cl_object
key_identity(struct cl_test *t, cl_object x)
{
	return x;
}

static void
setupTEST(struct cl_test *t, cl_object item, cl_object test,
	  cl_object test_not, cl_object key)
{
	t->item_compared = item;
	if (test != Cnil) {
		if (test_not != Cnil)
		    FEerror("Both :TEST and :TEST-NOT are specified.", 0);
		t->test_function = test;
		t->test_c_function = test_compare;
	} else if (test_not != Cnil) {
		t->test_function = test_not;
		t->test_c_function = test_compare_not;
	} else {
		t->test_c_function = test_eql;
	}
	if (key != Cnil) {
		t->key_function = key;
		t->key_c_function = key_function;
	} else {
		t->key_c_function = key_identity;
	}
}

cl_object
cl_car(cl_object x)
{
	if (Null(x))
		return1(x);
	if (CONSP(x))
		return1(CAR(x));
	FEtype_error_list(x);
}

cl_object
cl_cdr(cl_object x)
{
	if (Null(x))
		return1(x);
	if (CONSP(x))
		return1(CDR(x));
	FEtype_error_list(x);
}

@(defun list (&rest args)
	cl_object list = Cnil, z;
@
	if (narg-- != 0) {
		list = z = CONS(cl_va_arg(args), Cnil);
		while (narg-- > 0) 
			z = CDR(z) = CONS(cl_va_arg(args), Cnil);
		}
	@(return list)
@)

@(defun list* (&rest args)
	cl_object p = Cnil, *z=&p;
@
	if (narg == 0)
		FEwrong_num_arguments(@'list*');
	while (--narg > 0)
		z = &CDR( *z = CONS(cl_va_arg(args), Cnil));
	*z = cl_va_arg(args);
	@(return p)
@)

static void
copy_list_to(cl_object x, cl_object **z)
{
	cl_object *y;

	y = *z;
	loop_for_in(x) {
		y = &CDR(*y = CONS(CAR(x), Cnil));
	} end_loop_for_in;
	*z = y;
}

@(defun append (&rest rest)
	cl_object x, *lastcdr;
@
	if (narg == 0)
		x = Cnil;
	else {
		lastcdr = &x;
		while (narg-- > 1)
			copy_list_to(cl_va_arg(rest), &lastcdr);
		*lastcdr = cl_va_arg(rest);
	}
	@(return x)
@)

cl_object
append(cl_object x, cl_object y)
{
	cl_object w, *z;

	z = &w;
	copy_list_to(x, &z);
	*z = y;
	return(w);
}

/* Open coded CARs and CDRs */
#define car(foo) \
	(void)foo; \
	if (x != Cnil) { \
	   if (CONSP(x)) \
	     x = x->cons.car; \
	   else \
	     goto E; \
	}
#define cdr(foo) \
	(void)foo; \
	if (x != Cnil) { \
	   if (CONSP(x)) \
	     x = x->cons.cdr; \
	   else \
	     goto E; \
	}
#define defcxr(name, arg, code) \
cl_object cl_##name(cl_object foo) { \
	cl_object arg = foo; \
	code; return1(x); \
E:	FEtype_error_list(arg);}

defcxr(caar, x, car(car(x)))
defcxr(cadr, x, car(cdr(x)))
defcxr(cdar, x, cdr(car(x)))
defcxr(cddr, x, cdr(cdr(x)))
defcxr(caaar, x, car(car(car(x))))
defcxr(caadr, x, car(car(cdr(x))))
defcxr(cadar, x, car(cdr(car(x))))
defcxr(caddr, x, car(cdr(cdr(x))))
defcxr(cdaar, x, cdr(car(car(x))))
defcxr(cdadr, x, cdr(car(cdr(x))))
defcxr(cddar, x, cdr(cdr(car(x))))
defcxr(cdddr, x, cdr(cdr(cdr(x))))
defcxr(caaaar, x, car(car(car(car(x)))))
defcxr(caaadr, x, car(car(car(cdr(x)))))
defcxr(caadar, x, car(car(cdr(car(x)))))
defcxr(caaddr, x, car(car(cdr(cdr(x)))))
defcxr(cadaar, x, car(cdr(car(car(x)))))
defcxr(cadadr, x, car(cdr(car(cdr(x)))))
defcxr(caddar, x, car(cdr(cdr(car(x)))))
defcxr(cadddr, x, car(cdr(cdr(cdr(x)))))
defcxr(cdaaar, x, cdr(car(car(car(x)))))
defcxr(cdaadr, x, cdr(car(car(cdr(x)))))
defcxr(cdadar, x, cdr(car(cdr(car(x)))))
defcxr(cdaddr, x, cdr(car(cdr(cdr(x)))))
defcxr(cddaar, x, cdr(cdr(car(car(x)))))
defcxr(cddadr, x, cdr(cdr(car(cdr(x)))))
defcxr(cdddar, x, cdr(cdr(cdr(car(x)))))
defcxr(cddddr, x, cdr(cdr(cdr(cdr(x)))))
#undef car
#undef cdr

#define LENTH(n) (cl_object x) {\
	return1(nth(n, x));\
}
cl_object @fifth	LENTH(4)
cl_object @sixth	LENTH(5)
cl_object @seventh	LENTH(6)
cl_object @eighth	LENTH(7)
cl_object @ninth	LENTH(8)
cl_object @tenth	LENTH(9)
#undef LENTH

static bool
tree_equal(struct cl_test *t, cl_object x, cl_object y)
{
BEGIN:
	if (CONSP(x)) {
		if (CONSP(y)) {
			if (tree_equal(t, CAR(x), CAR(y))) {
				x = CDR(x);
				y = CDR(y);
				goto BEGIN;
			} else {
				return(FALSE);
			}
		} else {
			return(FALSE);
		}
	} else {
		t->item_compared = x;
		if (TEST(t, y))
			return(TRUE);
		else
			return(FALSE);
	}
}

@(defun tree_equal (x y &key test test_not)
	struct cl_test t;
@
	setupTEST(&t, Cnil, test, test_not, Cnil);
	@(return (tree_equal(&t, x, y)? Ct : Cnil))
@)

cl_object
cl_endp(cl_object x)
{
	if (Null(x))
		@(return Ct)
	if (CONSP(x))
		@(return Cnil)
	FEtype_error_list(x);
}

bool
endp(cl_object x)
{
	if (CONSP(x))
		return(FALSE);
	if (Null(x))
		return(TRUE);
	FEtype_error_list(x);
}

cl_object
cl_list_length(cl_object x)
{
	cl_fixnum n;
	cl_object fast, slow;

	/* INV: A list's length always fits in a fixnum */
	fast = slow = x;
	for (n = 0; CONSP(fast); n++, fast = CDR(fast)) {
		if (n & 1) {
			/* Circular list? */
			if (slow == fast) return Cnil;
			slow = CDR(slow);
		}
	}
	if (fast != Cnil)
		FEtype_error_proper_list(x);
	@(return MAKE_FIXNUM(n));
}

cl_object
cl_nth(cl_object n, cl_object x)
{
	@(return nth(fixint(n), x))
}

cl_object
nth(cl_fixnum n, cl_object x)
{
	if (n < 0)
		FEtype_error_index(x, MAKE_FIXNUM(n));
	/* INV: No need to check for circularity since we visit
	   at most `n' conses */
	for (; n > 0 && CONSP(x); n--)
		x = CDR(x);
	if (x == Cnil)
		return Cnil;
	if (CONSP(x))
		return CAR(x);
	FEtype_error_list(x);
}

cl_object
cl_nthcdr(cl_object n, cl_object x)
{
	@(return nthcdr(fixint(n), x))
}

cl_object
nthcdr(cl_fixnum n, cl_object x)
{
	if (n < 0)
		FEtype_error_index(x, MAKE_FIXNUM(n));
	while (n-- > 0 && !endp(x))
		x = CDR(x);
	return(x);
}

@(defun last (l &optional (k MAKE_FIXNUM(1)))
	cl_object r;
	cl_fixnum n;
@
	n = fixnnint(k);
	r = l;
	loop_for_on(l) {
		if (n) n--; else r = CDR(r);
	} end_loop_for_on;
	@(return r)
@)

@(defun make_list (size &key initial_element &aux x)
	cl_fixnum i;
@
	/* INV: fixnnint() signals a type-error if SIZE is not a integer >=0 */
	i = fixnnint(size);
	while (i-- > 0)
		x = CONS(initial_element, x);
	@(return x)
@)

cl_object
cl_copy_list(cl_object x)
{
	cl_object copy;
	cl_object *y = &copy;

	loop_for_on(x) {
		y = &CDR(*y = CONS(CAR(x), Cnil));
	} end_loop_for_on;
	*y = x;
	@(return copy);
}

cl_object
cl_copy_alist(cl_object x)
{
	cl_object copy;
	cl_object *y = &copy;

	loop_for_in(x) {
		cl_object pair = CAR(x);
		if (CONSP(pair))
			pair = CONS(CAR(pair), CDR(pair));
		*y = CONS(pair, Cnil);
		y = &CDR(*y);
	} end_loop_for_in;
	*y = x;
	@(return copy);
}

static cl_object
do_copy_tree(cl_object x)
{
	if (ATOM(x))
		return x;
	return CONS(do_copy_tree(CAR(x)), do_copy_tree(CDR(x)));
}

cl_object
cl_copy_tree(cl_object x)
{
	@(return do_copy_tree(x))
}

cl_object
cl_revappend(cl_object x, cl_object y)
{
	loop_for_in(x) {
		y = CONS(CAR(x),y);
	} end_loop_for_in;
	@(return y)
}

@(defun nconc (&rest lists)
	cl_object x, l,*lastcdr;
@	
	if (narg < 1)
		@(return Cnil)
	lastcdr = &x;
	while (narg-- > 1) {
		*lastcdr = l = cl_va_arg(lists);
		loop_for_on(l) {
			lastcdr = &CDR(l);
		} end_loop_for_on;
	}
	*lastcdr = cl_va_arg(lists);
	@(return x)
@)

cl_object
nconc(cl_object l, cl_object y)
{
	cl_object x = l, x1;

	if (x == Cnil)
		return y;
	/* INV: This loop is run at least once */
	loop_for_on(x) {
		x1 = x;
	} end_loop_for_on;
	CDR(x1) = y;
	return l;
}

cl_object
cl_nreconc(cl_object l, cl_object y)
{
	cl_object x, z;
	/* INV: when a circular list is "reconc'ed", the pointer ends
	   up at the beginning of the original list, hence we need no
	   slow pointer */
	for (x = l; CONSP(x); ) {
		z = x;
		x = CDR(x);
		if (x == l) FEcircular_list(l);
		CDR(z) = y;
		y = z;
	}
	if (x != Cnil)
		FEtype_error_proper_list(l);
	@(return y)
}

/* CONTINUE HERE!!!! */
@(defun butlast (lis &optional (nn MAKE_FIXNUM(1)))
	cl_object r, res = Cnil, *fill = &res;
	cl_fixnum delay;
@
	/* INV: No list has more than MOST_POSITIVE_FIXNUM elements */
	if (type_of(nn) == t_bignum)
		@(return Cnil)
	/* INV: fixnnint() signas a type-error if NN is not an integer >=0 */
	delay = fixnnint(nn);
	r = lis;
	loop_for_on(lis) {
		if (delay)
			delay--;
		else {
			fill = &CDR(*fill = CONS(CAR(r), Cnil));
			r = CDR(r);
		}
	} end_loop_for_on;
	@(return res)
@)

@(defun nbutlast (lis &optional (nn MAKE_FIXNUM(1)))
	cl_fixnum delay;
	cl_object x, r;
@
	/* INV: No list has more than MOST_POSITIVE_FIXNUM elements */
	if (type_of(nn) == t_bignum)
		@(return Cnil)
	/* INV: fixnnint() signas a type-error if NN is not an integer >=0 */
	/* We add 1 because at the end `r' must point to the
	   cons that must be modified */
	delay = fixnnint(nn)+1;
	r = x = lis;
	loop_for_on(x) {
		if (delay) delay--; else r = CDR(r);
	} end_loop_for_on;
	if (delay > 0)
		/* nn > length(lis) */
		lis = Cnil;
	else
		CDR(r) = Cnil;
	@(return lis)
@)

cl_object
cl_ldiff(cl_object x, cl_object y)
{
	cl_object res = Cnil, *fill = &res;

	loop_for_on(x) {
		if (eql(x, y))
			@(return res)
		else
			fill = &CDR(*fill = CONS(CAR(x), Cnil));
	} end_loop_for_on;
	/* INV: At the end of a loop_for_on(x), x has the CDR of the last cons
	   in the list. When Y was not a member of the list, LDIFF must set
	   this value in the output, because it produces an exact copy of the
	   dotted list. */
	if (!eql(x, y))
		*fill = x;
	@(return res)
}

cl_object
cl_rplaca(cl_object x, cl_object v)
{
	assert_type_cons(x);
	CAR(x) = v;
	@(return x)
}

cl_object
cl_rplacd(cl_object x, cl_object v)
{
	assert_type_cons(x);
	CDR(x) = v;
	@(return x)
}

@(defun subst (new_obj old_obj tree &key test test_not key)
	struct cl_test t;
@
	setupTEST(&t, old_obj, test, test_not, key);
	@(return subst(&t, new_obj, tree))
@)


/*
	Subst(new, tree) returns
	the result of substituting new in tree.
*/
static cl_object
subst(struct cl_test *t, cl_object new_obj, cl_object tree)
{
	if (TEST(t, tree)) {
		return new_obj;
	} else if (CONSP(tree)) {
		return CONS(subst(t, new_obj, CAR(tree)),
			    subst(t, new_obj, CDR(tree)));
	} else {
		return tree;
	}
}

@(defun nsubst (new_obj old_obj tree &key test test_not key)
	struct cl_test t;
@
	setupTEST(&t, old_obj, test, test_not, key);
	nsubst(&t, new_obj, &tree);
	@(return tree)
@)

/*
	Nsubst(new, treep) stores
	the result of nsubstituting new in *treep
	to *treep.
*/
static void
nsubst(struct cl_test *t, cl_object new_obj, cl_object *treep)
{
	if (TEST(t, *treep)) {
		*treep = new_obj;
	} else if (CONSP(*treep)) {
		nsubst(t, new_obj, &CAR(*treep));
		nsubst(t, new_obj, &CDR(*treep));
	}
}

@(defun sublis (alist tree &key test test_not key)
	struct cl_test t;
@
	setupTEST(&t, Cnil, test, test_not, key);
	tree = sublis(&t, alist, tree);
	@(return tree)
@)

/*
	Sublis(alist, tree) returns
	result of substituting tree by alist.
*/
static cl_object
sublis(struct cl_test *t, cl_object alist, cl_object tree)
{
	cl_object x = alist;
	struct cl_test local_t = *t;
	local_t.key_c_function = key_identity;
	local_t.item_compared = (t->key_c_function)(t, tree);
	loop_for_in(x) {
		cl_object node = CAR(x);
		if (TEST(&local_t, cl_car(node))) {
			return CDR(node);
		}
	} end_loop_for_in;
	if (CONSP(tree)) {
		return CONS(sublis(t, alist, CAR(tree)),
			    sublis(t, alist, CDR(tree)));
	} else {
		return tree;
	}
}

@(defun nsublis (alist tree &key test test_not key)
	struct cl_test t;
@
	setupTEST(&t, Cnil, test, test_not, key);
	nsublis(&t, alist, &tree);
	@(return tree)
@)

/*
	Nsublis(alist, treep) stores
	the result of substiting *treep by alist
	to *treep.
*/
static void
nsublis(struct cl_test *t, cl_object alist, cl_object *treep)
{
	cl_object x = alist;
	struct cl_test local_t = *t;
	local_t.key_c_function = key_identity;
	local_t.item_compared = (t->key_c_function)(t, *treep);
	loop_for_in(x) {
		cl_object node = CAR(x);
		if (TEST(&local_t, cl_car(node))) {
			*treep = CDR(node);
			return;
		}
	} end_loop_for_in;
	if (CONSP(*treep)) {
		nsublis(t, alist, &CAR(*treep));
		nsublis(t, alist, &CDR(*treep));
	}
}

@(defun member (item list &key test test_not key)
	struct cl_test t;
@
	setupTEST(&t, item, test, test_not, key);
	loop_for_in(list) {
		if (TEST(&t, CAR(list)))
			break;
	} end_loop_for_in;
	@(return list)
@)

bool
member_eq(cl_object x, cl_object l)
{
	loop_for_in(l) {
		if (x == CAR(l))
			return(TRUE);
	} end_loop_for_in;
	return(FALSE);
}

cl_object
si_memq(cl_object x, cl_object l)
{
	loop_for_in(l) {
		if (x == CAR(l))
			@(return l)
	} end_loop_for_in;
	@(return Cnil)
}

/* Added for use by the compiler, instead of open coding them. Beppe */
cl_object
memql(cl_object x, cl_object l)
{
	loop_for_in(l) {
		if (eql(x, CAR(l)))
			return(l);
	} end_loop_for_in;
	return(Cnil);
}

cl_object
member(cl_object x, cl_object l)
{
	loop_for_in(l) {
		if (equal(x, CAR(l)))
			return(l);
	} end_loop_for_in;
	return(Cnil);
}
/* End of addition. Beppe */

cl_object
si_member1(cl_object item, cl_object list, cl_object test, cl_object test_not, cl_object key)
{
	struct cl_test t;

	if (key != Cnil)
		item = funcall(2, key, item);
	setupTEST(&t, item, test, test_not, key);
	loop_for_in(list) {
		if (TEST(&t, CAR(list)))
			break;
	} end_loop_for_in;
	@(return list)
}

cl_object
cl_tailp(cl_object y, cl_object x)
{
	loop_for_on(x) {
		if (eql(x, y))
			@(return Ct)
	} end_loop_for_on;
	return cl_eql(x, y);
}

@(defun adjoin (item list &key test test_not key)
	cl_object output;
@
	if (narg < 2)
		FEwrong_num_arguments(@'adjoin');
	output = @si::member1(item, list, test, test_not, key);
	if (Null(output))
		output = CONS(item, list);
	else
		output = list;
	@(return output)
@)

cl_object
cl_cons(cl_object x, cl_object y)
{
	@(return CONS(x, y))
}

cl_object
cl_acons(cl_object x, cl_object y, cl_object z)
{
	@(return CONS(CONS(x, y), z))
}

@(defun pairlis (keys data &optional a_list)
	cl_object k, d;
@
	k = keys;
	d = data;
	loop_for_in(k) {
		if (endp(d))
			goto error;
		a_list = CONS(CONS(CAR(k), CAR(d)), a_list);
		d = CDR(d);
	} end_loop_for_in;
	if (!endp(d))
error:	    FEerror("The keys ~S and the data ~S are not of the same length",
		    2, keys, data);
	@(return a_list)
@)


@(defun assoc (item a_list &key test test_not key)
	struct cl_test t;
@
	setupTEST(&t, item, test, test_not, key);
	loop_for_in(a_list) {
		cl_object pair = CAR(a_list);
		if (Null(pair)) {
			;
		} else if (ATOM(pair)) {
			FEtype_error_alist(pair);
		} else if (TEST(&t, CAAR(a_list))) {
			a_list = CAR(a_list);
			break;
		}
	} end_loop_for_in;
	@(return a_list)
@)

@(defun rassoc (item a_list &key test test_not key)
	struct cl_test t;
@
	setupTEST(&t, item, test, test_not, key);
	loop_for_in(a_list) {
		cl_object pair = CAR(a_list);
		if (Null(pair)) {
			;
		} else if (ATOM(pair)) {
			FEtype_error_alist(pair);
		} else if (TEST(&t, CDAR(a_list))) {
				a_list = CAR(a_list);
				break;
			}
	} end_loop_for_in;
	@(return a_list)
@)

void
ecl_delete_eq(cl_object x, cl_object *lp)
{
	for (;  CONSP(*lp);  lp = &CDR((*lp)))
		if (CAR((*lp)) == x) {
			*lp = CDR((*lp));
			return;
		}
}

cl_object
ecl_remove_eq(cl_object x, cl_object l)
{
	l = cl_copy_list(l);
	ecl_delete_eq(x, &l);
	return l;
}

/* Added for use by the compiler, instead of open coding them. Beppe */
cl_object
assq(cl_object x, cl_object l)
{
	loop_for_in(l) {
		if (x == CAAR(l))
			return(CAR(l));
	} end_loop_for_in;
	return(Cnil);
}

cl_object
assql(cl_object x, cl_object l)
{
	loop_for_in(l) {
		if (eql(x, CAAR(l)))
			return(CAR(l));
	} end_loop_for_in;
	return(Cnil);
}

cl_object
assoc(cl_object x, cl_object l)
{
	loop_for_in(l) {
		if (equal(x, CAAR(l)))
			return(CAR(l));
	} end_loop_for_in;
	return(Cnil);
}

cl_object
assqlp(cl_object x, cl_object l)
{
	loop_for_in(l) {
		if (equalp(x, CAR(CAR(l))))
			return(CAR(l));
	} end_loop_for_in;
	return(Cnil);
}
/* End of addition. Beppe */