/src/list.d
D | 1943 lines | 1419 code | 136 blank | 388 comment | 201 complexity | 2304a816024b159a46a4ac6926c1aae6 MD5 | raw file
Possible License(s): LGPL-2.0, GPL-2.0, BSD-3-Clause
Large files files are truncated, but you can click here to view the full file
- /*
- * List functions for CLISP
- * Bruno Haible 1990-2005
- * Marcus Daniels 8.4.1994
- * Sam Steingold 1999-2008
- * German comments and names translated into English: Reini Urban 2008-01
- */
- #include "lispbibl.c"
- /* (PROG1 (CONS STACK_1 STACK_0) skipSTACK(2))
- removes 2 objects from STACK
- can trigger GC */
- local inline maygc object cons_from_stack (void)
- {
- var object ret = allocate_cons();
- Cdr(ret) = popSTACK();
- Car(ret) = popSTACK();
- return ret;
- }
- /* UP: Copies a list
- copy_list(list)
- > list: List
- < result: Copy of the list
- can trigger GC */
- global maygc object copy_list (object old_list) {
- /* Method: (copy-list l) = (mapcar #'identity l), mapcar forwards */
- if (atomp(old_list))
- return old_list;
- else { /* List with at least one element */
- var object run;
- pushSTACK(old_list);
- {
- var object new_list = allocate_cons();
- run = STACK_0; /* run runs through the old list */
- Car(new_list) = Car(run);
- STACK_0 = new_list;
- pushSTACK(new_list);
- }
- /* Loop: STACK_1 is the whole copy, STACK_0 = LAST of it, */
- /* run = the correspondend Cons of the original list. */
- while ( run=Cdr(run), consp(run) ) {
- /* one more Cons */
- pushSTACK(run); /* save run */
- var object new_cons = allocate_cons(); /* allocate new Cons */
- run = popSTACK(); /* run back */
- Cdr(STACK_0) = new_cons; /* and put as CDR of the LAST */
- Car(new_cons) = Car(run); /* copy CAR */
- STACK_0 = new_cons; /* this is now the new LAST */
- }
- Cdr(popSTACK()) = run; /* keep same (CDR (LAST old_list)) */
- return popSTACK();
- }
- }
- /* UP: Reverses a list by copying
- reverse(list)
- > list: List (x1 ... xm)
- < result: reversed List (xm ... x1)
- can trigger GC */
- global maygc object reverse (object list) {
- pushSTACK(list); pushSTACK(NIL);
- while (!endp(list)) {
- /* Here is for r=1,...,m: */
- /* STACK_0 = (xr-1 ... x1), list = (xr ... xm) */
- STACK_1 = Cdr(list);
- /* Here is for r=1,...,m: */
- /* STACK_0 = (xr-1 ... x1), STACK_1 = (xr+1 ... xm) */
- pushSTACK(Car(list));
- {
- var object new_cons = allocate_cons();
- Car(new_cons) = popSTACK(); /* = xr */
- Cdr(new_cons) = STACK_0; /* = (xr-1 ... x1) */
- STACK_0 = new_cons; /* = (xr ... x1) */
- }
- list = STACK_1; /* list := (xr+1 ... xm) */
- }
- list = popSTACK(); skipSTACK(1); return list;
- }
- #if 0
- /* another possibility: */
- global object reverse (object list) {
- pushSTACK(list); pushSTACK(NIL);
- while (mconsp(STACK_1)) {
- var object new_cons = allocate_cons();
- var object old_cons = STACK_1;
- STACK_1 = Cdr(old_cons);
- Car(new_cons) = Car(old_cons);
- Cdr(new_cons) = STACK_0;
- STACK_0 = new_cons;
- }
- list = popSTACK(); skipSTACK(1); return list;
- }
- #endif
- /* UP: get the list length and the last atom
- > obj: object
- < len: list length
- < last: the last atom */
- global uintL llength1 (object list, object* last) {
- var uintL count = 0;
- while (consp(list)) {
- count++; list=Cdr(list);
- }
- if (last) *last = list;
- return count;
- }
- /* UP: Constructs a list with exactly len elements.
- make_list(len)
- > STACK_0: Initial value for all elements
- > uintL len: wanted list length
- < result: List with len elements
- can trigger GC */
- global maygc object make_list (uintL len) {
- pushSTACK(NIL);
- while (len--) {
- /* STACK_0 = old list, STACK_1 = initial value */
- var object new_cons = allocate_cons();
- Car(new_cons) = STACK_1; Cdr(new_cons) = STACK_0;
- STACK_0 = new_cons;
- }
- return popSTACK();
- }
- /* UP: Reverses a list in-place, destructively.
- nreverse(list)
- > list: List (x1 ... xm)
- < result: List (xm ... x1), EQ to the old */
- global object nreverse (object list) {
- /* Algorithm:
- (lambda (L)
- (cond ((atom L) L)
- ((atom (cdr L)) L)
- ((atom (cddr L)) (rotatef (car L) (cadr L)) L)
- (t (let ((L1 (cdr L)))
- (do ((L3 L1 (cdr L3))
- (L2 nil (rplacd L3 L2)))
- ((atom (cdr L3))
- (setf (cdr L) L2)
- (setf (cdr L1) L3)
- (rotatef (car L) (car L3))))
- L)))) */
- if (consp(list)) { /* (atom L) -> L */
- var object list3 = Cdr(list); /* L3 := (cdr L) */
- if (!endp(list3)) { /* (atom (cdr L)) -> L */
- if (!endp(Cdr(list3))) {
- var object list1 = list3; /* Begin with L1 = L3 = (cdr L) */
- var object list2 = NIL; /* and L2 = NIL */
- do {
- var object h = Cdr(list3); /* save (cdr L3), */
- Cdr(list3) = list2; /* replace by L2, */
- list2 = list3; /* L2 := old L3 */
- list3 = h; /* L3 := old (cdr L3) */
- } while (!endp(Cdr(list3))); /* (atom (cdr L3)) -> end */
- /* L3 is the last and L2 the last but one list Cons. */
- Cdr(list) = list2; /* (setf (cdr L) L2) */
- Cdr(list1) = list3; /* (setf (cdr L1) L3) */
- }
- /* exchange (car list) and (car list3): */
- var object h = Car(list);
- Car(list) = Car(list3);
- Car(list3) = h;
- }
- }
- return list;
- }
- /* UP: A0 := (nreconc A0 A1)
- nreconc(list,obj)
- > list: List
- > obj: Object
- < result: (nreconc A0 A1) */
- global object nreconc (object list, object obj) {
- if (!endp(list)) { /* (atom L) -> L */
- var object list3 = Cdr(list); /* L3 := (cdr L) */
- if (!endp(list3)) { /* (atom (cdr L)) -> L */
- if (!endp(Cdr(list3))) {
- var object list1 = list3; /* Begin with L1 = L3 = (cdr L) */
- var object list2 = NIL; /* and L2 = NIL */
- do {
- var object h = Cdr(list3); /* save (cdr L3), */
- Cdr(list3) = list2; /* replace by L2, */
- list2 = list3; /* L2 := old L3 */
- list3 = h; /* L3 := old (cdr L3) */
- } while (!endp(Cdr(list3))); /* (atom (cdr L3)) -> end */
- /* L3 is the last and L2 the last but one list Cons. */
- Cdr(list) = list2; /* (setf (cdr L) L2) */
- Cdr(list1) = list3; /* (setf (cdr L1) L3) */
- }
- /* exchange (car list) and (car list3): */
- {
- var object h = Car(list);
- Car(list) = Car(list3);
- Car(list3) = h;
- }
- Cdr(list3) = obj; /* (setf (cdr L3) O) */
- } else {
- Cdr(list) = obj;
- }
- return list;
- } else
- return obj;
- }
- /* UP: Construct (delete obj (the list list) :test #'EQ)
- deleteq(list,obj)
- Remove from list all elements EQ to obj.
- > obj: to be removed element
- > list: List
- < result: modified List */
- global object deleteq (object list, object obj) {
- var object list1 = list;
- var object list2 = list;
- while (!atomp(list2)) {
- /* Here is either list1=list2=list or (cdr list1) = list2. */
- if (eq(Car(list2),obj))
- /* Remove (car list2): */
- if (eq(list2,list)) {
- /* Still at the start of the list */
- list2 = list1 = list = Cdr(list2);
- } else {
- /* advanced the start of the list */
- Cdr(list1) = list2 = Cdr(list2);
- }
- else {
- /* Remove nothing, advance: */
- list1 = list2; list2 = Cdr(list2);
- }
- }
- return list;
- }
- /* UP: Returns (car obj), with type check */
- local object car (object obj) {
- if (consp(obj))
- return Car(obj);
- else if (nullp(obj))
- return obj;
- else
- error_list(obj);
- }
- /* UP: Returns (cdr obj), with type check */
- local object cdr (object obj) {
- if (consp(obj))
- return Cdr(obj);
- else if (nullp(obj))
- return obj;
- else
- error_list(obj);
- }
- LISPFUNNR(car,1)
- { /* (CAR list), CLTL p. 262 */
- VALUES1(car(popSTACK()));
- }
- LISPFUNNR(cdr,1)
- { /* (CDR list), CLTL p. 262 */
- VALUES1(cdr(popSTACK()));
- }
- LISPFUNNR(caar,1)
- { /* (CAAR list), CLTL p. 263 */
- VALUES1(car(car(popSTACK())));
- }
- LISPFUNNR(cadr,1)
- { /* (CADR list), CLTL p. 263 */
- VALUES1(car(cdr(popSTACK())));
- }
- LISPFUNNR(cdar,1)
- { /* (CDAR list), CLTL p. 263 */
- VALUES1(cdr(car(popSTACK())));
- }
- LISPFUNNR(cddr,1)
- { /* (CDDR list), CLTL p. 263 */
- VALUES1(cdr(cdr(popSTACK())));
- }
- LISPFUNNR(caaar,1)
- { /* (CAAAR list), CLTL p. 263 */
- VALUES1(car(car(car(popSTACK()))));
- }
- LISPFUNNR(caadr,1)
- { /* (CAADR list), CLTL p. 263 */
- VALUES1(car(car(cdr(popSTACK()))));
- }
- LISPFUNNR(cadar,1)
- { /* (CADAR list), CLTL p. 263 */
- VALUES1(car(cdr(car(popSTACK()))));
- }
- LISPFUNNR(caddr,1)
- { /* (CADDR list), CLTL p. 263 */
- VALUES1(car(cdr(cdr(popSTACK()))));
- }
- LISPFUNNR(cdaar,1)
- { /* (CDAAR list), CLTL p. 263 */
- VALUES1(cdr(car(car(popSTACK()))));
- }
- LISPFUNNR(cdadr,1)
- { /* (CDADR list), CLTL p. 263 */
- VALUES1(cdr(car(cdr(popSTACK()))));
- }
- LISPFUNNR(cddar,1)
- { /* (CDDAR list), CLTL p. 263 */
- VALUES1(cdr(cdr(car(popSTACK()))));
- }
- LISPFUNNR(cdddr,1)
- { /* (CDDDR list), CLTL p. 263 */
- VALUES1(cdr(cdr(cdr(popSTACK()))));
- }
- LISPFUNNR(caaaar,1)
- { /* (CAAAAR list), CLTL p. 263 */
- VALUES1(car(car(car(car(popSTACK())))));
- }
- LISPFUNNR(caaadr,1)
- { /* (CAAADR list), CLTL p. 263 */
- VALUES1(car(car(car(cdr(popSTACK())))));
- }
- LISPFUNNR(caadar,1)
- { /* (CAADAR list), CLTL p. 263 */
- VALUES1(car(car(cdr(car(popSTACK())))));
- }
- LISPFUNNR(caaddr,1)
- { /* (CAADDR list), CLTL p. 263 */
- VALUES1(car(car(cdr(cdr(popSTACK())))));
- }
- LISPFUNNR(cadaar,1)
- { /* (CADAAR list), CLTL p. 263 */
- VALUES1(car(cdr(car(car(popSTACK())))));
- }
- LISPFUNNR(cadadr,1)
- { /* (CADADR list), CLTL p. 263 */
- VALUES1(car(cdr(car(cdr(popSTACK())))));
- }
- LISPFUNNR(caddar,1)
- { /* (CADDAR list), CLTL p. 263 */
- VALUES1(car(cdr(cdr(car(popSTACK())))));
- }
- LISPFUNNR(cadddr,1)
- { /* (CADDDR list), CLTL p. 263 */
- VALUES1(car(cdr(cdr(cdr(popSTACK())))));
- }
- LISPFUNNR(cdaaar,1)
- { /* (CDAAAR list), CLTL p. 263 */
- VALUES1(cdr(car(car(car(popSTACK())))));
- }
- LISPFUNNR(cdaadr,1)
- { /* (CDAADR list), CLTL p. 263 */
- VALUES1(cdr(car(car(cdr(popSTACK())))));
- }
- LISPFUNNR(cdadar,1)
- { /* (CDADAR list), CLTL p. 263 */
- VALUES1(cdr(car(cdr(car(popSTACK())))));
- }
- LISPFUNNR(cdaddr,1)
- { /* (CDADDR list), CLTL p. 263 */
- VALUES1(cdr(car(cdr(cdr(popSTACK())))));
- }
- LISPFUNNR(cddaar,1)
- { /* (CDDAAR list), CLTL p. 263 */
- VALUES1(cdr(cdr(car(car(popSTACK())))));
- }
- LISPFUNNR(cddadr,1)
- { /* (CDDADR list), CLTL p. 263 */
- VALUES1(cdr(cdr(car(cdr(popSTACK())))));
- }
- LISPFUNNR(cdddar,1)
- { /* (CDDDAR list), CLTL p. 263 */
- VALUES1(cdr(cdr(cdr(car(popSTACK())))));
- }
- LISPFUNNR(cddddr,1)
- { /* (CDDDDR list), CLTL p. 263 */
- VALUES1(cdr(cdr(cdr(cdr(popSTACK())))));
- }
- LISPFUN(cons,seclass_no_se,2,0,norest,nokey,0,NIL)
- { /* (CONS obj1 obj2), CLTL p. 264 */
- VALUES1(cons_from_stack());
- }
- /* UP: Tests the equality of two trees.
- tree_equal(stackptr,pcall_test,arg1,arg2)
- > arg1,arg2: two trees
- > stackptr: Pointer to the stack
- > A5: Adress of a test function, which compares arg1 and arg2 and may access
- the :TEST/:TEST-NOT arguments in *(stackptr+1).L resp.
- *(stackprt+0).L
- < result: true if equal, otherwise false
- can trigger GC */
- local maygc bool tree_equal (const gcv_object_t* stackptr, funarg_t* pcall_test,
- object arg1, object arg2) {
- start:
- if (atomp(arg1))
- if (atomp(arg2))
- /* arg1 and arg2 both are atoms */
- return pcall_test(stackptr,arg1,arg2);
- else
- return false;
- else
- if (atomp(arg2))
- return false;
- else {
- /* arg1 and arg2 both are Cons */
- check_STACK(); check_SP();
- pushSTACK(Cdr(arg1)); pushSTACK(Cdr(arg2));
- if (tree_equal(stackptr,pcall_test,Car(arg1),Car(arg2))) { /* recursive on CARs */
- /* if equal, compare tail-recursively the CDRs */
- arg2 = popSTACK(); arg1 = popSTACK(); goto start;
- } else {
- skipSTACK(2); return false;
- }
- }
- }
- LISPFUN(tree_equal,seclass_default,2,0,norest,key,2, (kw(test),kw(test_not)) )
- { /* (TREE-EQUAL x y :test :test-not), CLTL p. 264 */
- var gcv_object_t* stackptr = &STACK_0;
- /* check :TEST/:TEST-NOT arguments: */
- var funarg_t* pcall_test = check_test_args(stackptr);
- VALUES_IF(tree_equal(stackptr,pcall_test,STACK_3,STACK_2));
- skipSTACK(4);
- }
- /* UP: check whether OBJ ends a proper list
- endp(obj)
- > obj: object
- < result: true if obj is the list end NIL,
- false if obj is a Cons.
- error otherwise */
- global bool endp (object obj) {
- if (consp(obj))
- return false;
- else if (nullp(obj))
- return true;
- else
- error_proper_list_dotted(TheSubr(subr_self)->name,obj);
- }
- LISPFUNNF(endp,1)
- { /* (ENDP object), CLTL p. 264 */
- VALUES_IF(endp(popSTACK()));
- }
- /* Finds the length of a possibly circular or dotted list.
- list_length(list,&dotted)
- > list: an object
- < result: the length (integer >= 0, or NIL for circular lists)
- < dotted: if non-circular, the last atom, i.e., the indicator whether the list
- is dotted
- can trigger GC */
- global maygc object list_length (object list, object *dottedp) {
- /* (defun list-length (list)
- (do ((n 0 (+ n 2))
- (fast list (cddr fast))
- (slow list (cdr slow)))
- (nil)
- (when (endp fast) (return n))
- (when (endp (cdr fast)) (return (1+ n)))
- (when (eq (cdr fast) slow) (return nil))))
- (see CLtL p 265) */
- var object fast = list;
- var object slow = fast;
- var uintL n = 0;
- while (consp(fast)) {
- fast = Cdr(fast); n++;
- if (atomp(fast))
- break;
- if (eq(fast,slow))
- return NIL;
- fast = Cdr(fast); n++;
- slow = Cdr(slow);
- }
- pushSTACK(fast);
- var object len = UL_to_I(n);
- *dottedp = popSTACK();
- return len;
- }
- LISPFUNNR(list_length,1)
- { /* (LIST-LENGTH list), CLTL p. 265 */
- var object tail = NIL;
- var object len = list_length(popSTACK(),&tail);
- if (nullp(tail))
- VALUES1(len);
- else
- error_proper_list_dotted(S(list_length),tail);
- }
- LISPFUNNR(list_length_dotted,1)
- { /* traverses the list just once, otherwise equivalent to
- (defun list-length-dotted (l)
- (let ((ll (list-length l)))
- (when ll (values ll (cdr (last l)))))) */
- var object tail = NIL;
- var object len = list_length(popSTACK(),&tail);
- if (nullp(len))
- VALUES1(NIL);
- else
- VALUES2(len,tail);
- }
- LISPFUNNR(list_length_proper,1)
- { /* traverses the list just once, otherwise equivalent to
- (defun list-length-proper (l)
- (if (proper-list-p l)
- (length l)
- (error ...))) */
- var object tail = NIL;
- var object len = list_length(STACK_0,&tail);
- if (!nullp(tail)) error_proper_list_dotted(S(list_length_proper),tail);
- if (nullp(len)) error_proper_list_circular(S(list_length_proper),STACK_0);
- VALUES1(len); skipSTACK(1);
- }
- LISPFUNNR(list_length_in_bounds_p,4)
- { /* (sys::list-length-in-bounds-p obj n m restp) tests whether obj, as a list,
- starts with at least n conses and is either a proper list with < m conses
- or (if restp) has at least m conses or (if not restp) is a proper list with
- exactly m conses. */
- if (!posfixnump(STACK_2)) error_posfixnum(STACK_2);
- if (!posfixnump(STACK_1)) error_posfixnum(STACK_1);
- var object obj = STACK_3;
- var uintV n = posfixnum_to_V(STACK_2);
- var uintV i;
- for (i = n; i > 0; i--) {
- if (!consp(obj)) goto no;
- obj = Cdr(obj);
- }
- { var uintV m = posfixnum_to_V(STACK_1);
- if (m < n) goto no;
- for (i = m-n; i > 0; i--) {
- if (!consp(obj)) {
- if (nullp(obj))
- break;
- else
- goto no;
- }
- obj = Cdr(obj);
- }
- }
- if (nullp(STACK_0) && !nullp(obj))
- goto no;
- VALUES1(T); skipSTACK(4); return;
- no:
- VALUES1(NIL); skipSTACK(4);
- }
- LISPFUN(proper_list_length_in_bounds_p,seclass_read,2,1,norest,nokey,0,NIL)
- { /* (sys::proper-list-length-in-bounds-p obj n) tests whether obj is a
- proper-list with at least n conses.
- (sys::proper-list-length-in-bounds-p obj n m) tests whether obj is a
- proper-list with at least n and at most m conses. */
- if (!posfixnump(STACK_1)) error_posfixnum(STACK_1);
- if (boundp(STACK_0) && !posfixnump(STACK_0)) error_posfixnum(STACK_0);
- var object tail = NIL;
- var object len = list_length(STACK_2,&tail);
- if (nullp(tail) && !nullp(len)) {
- var uintL l = I_to_UL(len);
- if ((posfixnum_to_V(STACK_1) <= l)
- && (!boundp(STACK_0) || (l <= posfixnum_to_V(STACK_0))))
- VALUES1(T);
- else
- VALUES1(NIL);
- } else
- VALUES1(NIL);
- skipSTACK(3);
- }
- /* proper_list_p(obj)
- returns true if obj is a proper list, i.e. a list which is neither dotted
- nor circular, i.e. a list which ends in NIL. */
- global bool proper_list_p (object obj) {
- var object fast = obj;
- var object slow = fast;
- while (consp(fast)) {
- fast = Cdr(fast);
- if (atomp(fast))
- break;
- if (eq(fast,slow))
- return false;
- fast = Cdr(fast);
- slow = Cdr(slow);
- }
- return nullp(fast);
- }
- /* We cannot have lists longer than 1<<32 for RAM reasons
- but we must accept arbitrary positive integers in NTH, LAST &c.
- Here we truncate large integers to ~0.
- can trigger GC */
- local maygc uintL get_integer_truncate (object number) {
- /* for speed, handle the most common case first */
- if (posfixnump(number)) {
- #if (intVsize>intLsize)
- if (posfixnum_to_V(number) >= vbitm(intLsize))
- return ~(uintL)0; /* most-positive-uintL */
- #endif
- return posfixnum_to_V(number);
- }
- number = check_pos_integer(number);
- if (uint32_p(number)) return I_to_UL(number);
- return ~(uintL)0; /* most-positive-uintL */
- }
- LISPFUNNR(nth,2)
- { /* (NTH integer list), CLTL p. 265 */
- var uintL count = get_integer_truncate(STACK_1);
- var object list = STACK_0;
- while (count--) { list = cdr(list); } /* count CDRs */
- VALUES1(car(list)); /* one CAR */
- skipSTACK(2);
- }
- LISPFUNNR(first,1)
- { /* (FIRST list), CLTL p. 266 */
- VALUES1(car(popSTACK()));
- }
- LISPFUNNR(second,1)
- { /* (SECOND list), CLTL p. 266 */
- VALUES1(car(cdr(popSTACK())));
- }
- LISPFUNNR(third,1)
- { /* (THIRD list), CLTL p. 266 */
- VALUES1(car(cdr(cdr(popSTACK()))));
- }
- LISPFUNNR(fourth,1)
- { /* (FOURTH list), CLTL p. 266 */
- VALUES1(car(cdr(cdr(cdr(popSTACK())))));
- }
- LISPFUNNR(fifth,1)
- { /* (FIFTH list), CLTL p. 266 */
- VALUES1(car(cdr(cdr(cdr(cdr(popSTACK()))))));
- }
- LISPFUNNR(sixth,1)
- { /* (SIXTH list), CLTL p. 266 */
- VALUES1(car(cdr(cdr(cdr(cdr(cdr(popSTACK())))))));
- }
- LISPFUNNR(seventh,1)
- { /* (SEVENTH list), CLTL p. 266 */
- VALUES1(car(cdr(cdr(cdr(cdr(cdr(cdr(popSTACK()))))))));
- }
- LISPFUNNR(eighth,1)
- { /* (EIGHTH list), CLTL p. 266 */
- VALUES1(car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(popSTACK())))))))));
- }
- LISPFUNNR(ninth,1)
- { /* (NINTH list), CLTL p. 266 */
- VALUES1(car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(popSTACK()))))))))));
- }
- LISPFUNNR(tenth,1)
- { /* (TENTH list), CLTL p. 266 */
- VALUES1(car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(popSTACK())))))))))));
- }
- LISPFUNNR(rest,1)
- { /* (REST list), CLTL p. 266 */
- VALUES1(cdr(popSTACK()));
- }
- LISPFUNNR(nthcdr,2)
- { /* (NTHCDR integer list), CLTL p. 267 */
- var uintL count = get_integer_truncate(STACK_1);
- var object list = STACK_0;
- while (count--) {
- if (consp(list))
- /* Walk list. */
- list = Cdr(list);
- else if (nullp(list))
- /* End of list reached. */
- break;
- else
- error_list(list);
- }
- VALUES1(list);
- skipSTACK(2);
- }
- /* (SYS::CONSES-P n object) determines whether the object is a list
- consisting of length n at least. Similar to
- (if (= n 0) t (consp (nthcdr (- n 1) object)))
- except that it is robust against dotted lists, or to
- (if (= n 0) t (and (listp object) (>= (length object) n)))
- except that it is robust against circular and dotted lists. */
- LISPFUNNR(conses_p,2) {
- var uintL count = get_integer_truncate(STACK_1);
- var object list = STACK_0;
- value1 = T;
- if (count > 0) {
- if (atomp(list))
- value1 = NIL;
- else
- for (; --count > 0;) {
- list = Cdr(list);
- if (atomp(list)) {
- value1 = NIL;
- break;
- }
- }
- }
- mv_count=1;
- skipSTACK(2);
- }
- /* Get a replacement for the circular list
- can trigger GC */
- local maygc object replace_circular_list (object list) {
- dynamic_bind(S(print_circle),T);
- pushSTACK(NIL); /* no PLACE */
- pushSTACK(list); pushSTACK(TheSubr(subr_self)->name);
- check_value(error_condition,GETTEXT("~S: ~S is a circular list"));
- dynamic_unbind(S(print_circle));
- return value1;
- }
- LISPFUN(last,seclass_read,1,1,norest,nokey,0,NIL)
- { /* (LAST list [n]), CLtL2 p. 416-417, dpANS p. 14-34
- (defun last (list &optional (n 1))
- (check-type n (integer 0 *))
- (check-type list list)
- (do ((l list (cdr l))
- (r list)
- (i 0 (+ i 1)))
- ((atom l) r)
- (when (>= i n) (pop r)))) */
- var object intarg = popSTACK();
- /* check optional integer argument: */
- var uintL count = (boundp(intarg) ? get_integer_truncate(intarg) : 1);
- var object list = check_list(popSTACK());
- /* Optimisation of the two most common cases count=1 and count=0: */
- switch (count) {
- case 0: { last_0_restart:
- var object slow = list;
- while (consp(list)) {
- list = Cdr(list);
- if (atomp(list)) break;
- if (eq(list,slow)) {
- list = check_list(replace_circular_list(list));
- goto last_0_restart;
- }
- list = Cdr(list);
- slow = Cdr(slow);
- }
- } break;
- case 1: { last_1_restart:
- var object list2;
- var object slow = list;
- if (consp(list)) {
- while (1) {
- /* list is a Cons. */
- list2 = Cdr(list); if (atomp(list2)) break; list = list2;
- if (eq(list,slow)) {
- list = check_list(replace_circular_list(list));
- goto last_1_restart;
- }
- list2 = Cdr(list); if (atomp(list2)) break; list = list2;
- slow = Cdr(slow);
- }
- }
- }
- break;
- default: { last_default_restart:
- var object list2 = list;
- var object slow = list;
- var uintL ii = count;
- do {
- if (atomp(list2))
- goto done;
- list2 = Cdr(list2);
- } while (--ii);
- while (consp(list2)) {
- list2 = Cdr(list2); list = Cdr(list); if (atomp(list2)) break;
- if (eq(list,slow)) {
- list = check_list(replace_circular_list(list));
- goto last_default_restart;
- }
- list2 = Cdr(list2); list = Cdr(list);
- }
- done: ;
- }
- break;
- }
- VALUES1(list);
- }
- /* UP: Constructs a list with given elements.
- listof(len)
- > uintC len: wanted list length
- > on STACK: len Objects, first at the top
- < result: list of these objects
- removes len elements from the STACK
- changes STACK, can trigger GC */
- global maygc object listof (uintC len) {
- pushSTACK(NIL); /* starting with empty list */
- /* Cons len times the arguments to the front of this list: */
- while (len--) {
- var object new_cons = allocate_cons();
- Cdr(new_cons) = popSTACK();
- Car(new_cons) = STACK_0;
- STACK_0 = new_cons;
- }
- return popSTACK();
- }
- LISPFUN(list,seclass_no_se,0,0,rest,nokey,0,NIL)
- { /* (LIST {object}), CLTL p. 267 */
- VALUES1(listof(argcount));
- }
- LISPFUN(liststar,seclass_no_se,1,0,rest,nokey,0,NIL)
- { /* (LIST* obj1 {object}), CLTL p. 267 */
- /* Former list already on the stack */
- /* Cons the argcount arguments to the front of this list: */
- while (argcount--) {
- var object new_cons = allocate_cons();
- Cdr(new_cons) = popSTACK(); /* next argument before */
- Car(new_cons) = STACK_0;
- STACK_0 = new_cons;
- }
- VALUES1(popSTACK());
- }
- LISPFUN(make_list,seclass_no_se,1,0,norest,key,1, (kw(initial_element)) )
- { /* (MAKE-LIST size :initial-element), CLTL p. 268 */
- if (!boundp(STACK_0)) /* check :initial-element */
- STACK_0 = NIL; /* default :initial-element is NIL */
- VALUES1(make_list(I_to_UL(check_uint32(STACK_1))));
- skipSTACK(2);
- }
- LISPFUN(append,seclass_read,0,0,rest,nokey,0,NIL)
- { /* (APPEND {list}), CLTL p. 268 */
- if (argcount==0) {
- VALUES1(NIL); /* no arguments -> return NIL as result */
- } else {
- /* Append arguments. Run the loop argcount-1 times: */
- while (--argcount) {
- /* STACK_0 = result list from right. */
- /* STACK_1 := (append STACK_1 STACK_0), increase STACK by 1: */
- var object list1;
- {
- var object list2 = popSTACK(); /* result list (from right) */
- list1 = STACK_0; /* Argument to be added to the front */
- STACK_0 = list2; /* stack resulting list */
- }
- /* list1 needs to be a list: */
- if (atomp(list1))
- if (nullp(list1))
- ; /* if list1=NIL: (append nil x) = x, do nothing */
- else
- error_list(list1);
- else {
- /* (append list1 STACK_0), and list1 is a Cons: */
- /* Copy list1 and keep last Cons: */
- var object run;
- pushSTACK(list1);
- {
- var object new_list = allocate_cons();
- run = STACK_0; /* run runs through the old list list1 */
- Car(new_list) = Car(run);
- STACK_0 = new_list;
- pushSTACK(new_list);
- }
- /* Loop: STACK_1 has the full copy, STACK_0 = LAST of it, */
- /* run = the corresponding Cons of the original list list1. */
- while ( run=Cdr(run), !endp(run) ) {
- /* one more Cons */
- pushSTACK(run); /* save run */
- var object new_cons = allocate_cons(); /* allocate new Cons */
- run = popSTACK(); /* put back run */
- Cdr(STACK_0) = new_cons; /* and add as CDR of the LAST */
- Car(new_cons) = Car(run); /* copy CAR */
- STACK_0 = new_cons; /* this is now the new LAST */
- }
- /* Copy ready. STACK_2 = current result list, */
- /* STACK_1 = copy of list1, STACK_0 = LAST of it. */
- run = popSTACK(); /* end of copy */
- list1 = popSTACK(); /* copy finished */
- /*if (!nullp(Cdr(run))) ????
- error_proper_list_dotted(TheSubr(subr_self)->name,Cdr(run));*/
- Cdr(run) = STACK_0; /* add result copy */
- STACK_0 = list1; /* and the is the new result list */
- }
- }
- VALUES1(popSTACK()); /* result list as value */
- }
- }
- LISPFUNNR(copy_list,1)
- { /* (COPY-LIST list), CLTL p. 268 */
- VALUES1(copy_list(check_list(popSTACK())));
- }
- /* UP: Copies an A-list
- copy_alist(alist)
- > alist: A-list
- < result: Copy of the A-list
- can trigger GC */
- local maygc object copy_alist (object alist) {
- /* Algorithm:
- Instead of
- (mapcar #'(lambda (x) (if (consp x) (cons (car x) (cdr x)) x)) l)
- the list is first copied via copy-list, then the conses among the top
- level elements of the copy are replaced with conses with same CAR and CDR. */
- alist = copy_list(alist);
- pushSTACK(alist); /* save result list */
- /* a-list runs through to the result list */
- while (!endp(alist)) {
- if (mconsp(Car(alist))) {
- pushSTACK(alist); /* save a-list */
- var object new_cons = allocate_cons(); /* new Cons */
- alist = popSTACK(); /* a-list back */
- {
- var object old_cons = Car(alist);
- Car(new_cons) = Car(old_cons); Cdr(new_cons) = Cdr(old_cons);
- }
- Car(alist) = new_cons;
- }
- alist = Cdr(alist);
- }
- return popSTACK();
- }
- LISPFUNNR(copy_alist,1) /* (COPY-ALIST alist), CLTL p. 268 */
- { VALUES1(copy_alist(popSTACK())); }
- /* UP: Copies a tree. */
- local object copy_tree (object tree) {
- if (atomp(tree))
- return tree; /* Return atom unchanged */
- else {
- check_STACK(); check_SP();
- pushSTACK(Cdr(tree)); /* Save CDR */
- {
- var object temp = copy_tree(Car(tree)); /* Copy the CAR recursively */
- tree = STACK_0;
- STACK_0 = temp; /* Save CAR copy */
- temp = copy_tree(tree); /* Copy the CDR recursively */
- pushSTACK(temp); /* Save CDR copy */
- }
- return cons_from_stack();
- }
- }
- LISPFUNNR(copy_tree,1) /* (COPY-TREE tree), CLTL p. 269 */
- { VALUES1(copy_tree(popSTACK())); }
- LISPFUNNR(revappend,2)
- { /* (REVAPPEND list object), CLTL p. 269 */
- while (!endp(STACK_1)) {
- var object new_cons = allocate_cons(); /* new Cons */
- Car(new_cons) = Car(STACK_1); Cdr(new_cons) = STACK_0; /* (cons (car list) object) */
- STACK_0 = new_cons; /* This is the new, longer object */
- STACK_1 = Cdr(STACK_1); /* Shorten list */
- }
- VALUES1(popSTACK());
- skipSTACK(1);
- }
- LISPFUN(nconc,seclass_default,0,0,rest,nokey,0,NIL)
- { /* (NCONC {list}), CLTL p. 269 */
- if (argcount==0) {
- VALUES1(NIL); /* no arguments -> return NIL as result */
- } else {
- /* Append arguments. Run the loop for argcount-1 times: */
- while (--argcount) {
- /* STACK_0 = current result list from right. */
- /* STACK_1 := (nconc STACK_1 STACK_0), increase STACK by 1: */
- if (matomp(STACK_1))
- if (nullp(STACK_1)) {
- STACK_1 = STACK_0; skipSTACK(1); /* result list stays, skip argument */
- } else
- error_list(STACK_1);
- else {
- /* Add result list to (cdr (last STACK_1)): */
- var object list1 = STACK_1;
- var object list2;
- while (1) {
- /* Here list1 is a Cons. */
- list2 = Cdr(list1);
- if (atomp(list2))
- break;
- list1 = list2;
- }
- /* list1 is the last Cons of the argument STACK_1 */
- Cdr(list1) = popSTACK(); /* Add current result list */
- /* STACK_0 = new result list */
- }
- }
- VALUES1(popSTACK());
- }
- }
- LISPFUNN(nreconc,2) /* (NRECONC list1 list2), CLTL p. 269 */
- {
- var object list1 = check_list(STACK_1);
- var object list2 = STACK_0; skipSTACK(2);
- VALUES1(nreconc(list1,list2));
- }
- LISPFUNN(list_nreverse,1) /* (SYS::LIST-NREVERSE list) */
- { /* as (NREVERSE list), if list is a list. */
- VALUES1(nreverse(popSTACK()));
- }
- /* check that the argument is a non-circular list and return its length
- can trigger GC */
- local inline maygc uintL check_list_length (gcv_object_t *list_) {
- while(1) {
- /* Give an error if the argument is not a list. (It's stupid to allow
- dotted lists of length > 0 but to forbid dotted lists of length 0,
- but that's how ANSI CL specifies it.) */
- if (!listp(*list_)) *list_ = check_list_replacement(*list_);
- var object dotted_p;
- var object llen = list_length(*list_,&dotted_p);
- if (!nullp(llen)) return I_to_UL(llen);
- *list_ = replace_circular_list(*list_);
- }
- }
- LISPFUN(butlast,seclass_read,1,1,norest,nokey,0,NIL)
- { /* (BUTLAST list [integer]), CLTL p. 271 */
- var object intarg = popSTACK();
- /* check optional integer argument: */
- var uintL count = (boundp(intarg) ? get_integer_truncate(intarg) : 1);
- var uintL len = check_list_length(&STACK_0); /* list length */
- if (len<=count) {
- VALUES1(NIL); skipSTACK(1); /* length(list)<=count -> return NIL */
- } else {
- var uintL new_len = len - count; /* >0 */
- /* Creates a copy of the first new_len conses of the list STACK_0: */
- var object new_list = make_list(new_len); /* allocate new list */
- /* Copy list elements one by one, until new_list is full: */
- var object new_run = new_list; /* runs through the new list */
- var object old_run = popSTACK(); /* runs through the old list */
- do {
- Car(new_run) = Car(old_run);
- old_run = Cdr(old_run); new_run = Cdr(new_run);
- } while (!atomp(new_run));
- VALUES1(new_list);
- }
- }
- LISPFUN(nbutlast,seclass_default,1,1,norest,nokey,0,NIL)
- { /* (NBUTLAST list [integer]), CLTL p. 271 */
- var object intarg = popSTACK();
- /* check optional integer argument: */
- var uintL count = (boundp(intarg) ? get_integer_truncate(intarg) : 1);
- var uintL len = check_list_length(&STACK_0); /* list length */
- if (len<=count) {
- VALUES1(NIL); skipSTACK(1); /* length(list)<=count -> return NIL */
- } else {
- var uintL new_len = len - count; /* >0 */
- var object run = STACK_0; /* runs through the list */
- /* take new_len-1 times the CDR and then set the CDR to NIL: */
- while (--new_len) run = Cdr(run);
- Cdr(run) = NIL;
- VALUES1(popSTACK()); /* return list */
- }
- }
- LISPFUNNR(ldiff,2)
- { /* (LDIFF list sublist), CLTL p. 272 */
- var object sublist = popSTACK();
- /* Search where sublist begins in list: */
- var uintL new_len = 0;
- var bool found_p = false;
- {
- var object listr = STACK_0;
- #ifndef X3J13_175
- while (!((found_p = eql(listr,sublist)) || endp(listr))) {
- listr = Cdr(listr); new_len++;
- }
- #else
- if (!listp(listr))
- error_list(listr);
- while (!((found_p = eql(listr,sublist)) || atomp(listr))) {
- listr = Cdr(listr); new_len++;
- }
- #endif
- }
- /* Return a copy of the first new_len conses of the list STACK_0: */
- var object new_list = make_list(new_len); /* allocate new list */
- /* Copy list elements one by one, until new_list is full: */
- var object new_run = new_list; /* runs through the new list */
- var object old_run = popSTACK(); /* runs through the old list */
- if (consp(new_run)) while (1) { /* loop! */
- Car(new_run) = Car(old_run);
- if (atomp(Cdr(new_run))) {
- if (!found_p)
- Cdr(new_run) = Cdr(old_run);
- break;
- }
- old_run = Cdr(old_run); new_run = Cdr(new_run);
- }
- VALUES1(new_list);
- }
- /* check_cons(obj)
- > obj: an object
- < result: a cons, either the same as obj or a replacement
- can trigger GC */
- local maygc object check_cons_replacement (object obj) {
- do {
- pushSTACK(NIL); /* no PLACE */
- pushSTACK(obj); /* TYPE-ERROR slot DATUM */
- pushSTACK(S(cons)); /* TYPE-ERROR slot EXPECTED-TYPE */
- pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
- check_value(type_error,GETTEXT("~S: ~S is not a pair"));
- obj = value1;
- } while (!consp(obj));
- return obj;
- }
- local inline maygc object check_cons (object obj) {
- if (!consp(obj))
- obj = check_cons_replacement(obj);
- return obj;
- }
- LISPFUNN(rplaca,2) /* (RPLACA cons object), CLTL p. 272 */
- {
- var object arg1 = check_cons(STACK_1);
- var object arg2 = STACK_0;
- skipSTACK(2);
- Car(arg1) = arg2;
- VALUES1(arg1);
- }
- LISPFUNN(prplaca,2) /* (SYS::%RPLACA cons object) */
- { /* like (RPLACA cons object), but return object as value */
- var object arg1 = check_cons(STACK_1);
- var object arg2 = STACK_0;
- skipSTACK(2);
- Car(arg1) = arg2;
- VALUES1(arg2);
- }
- LISPFUNN(rplacd,2) /* (RPLACD cons object), CLTL p. 272 */
- {
- var object arg1 = check_cons(STACK_1);
- var object arg2 = STACK_0;
- skipSTACK(2);
- Cdr(arg1) = arg2;
- VALUES1(arg1);
- }
- LISPFUNN(prplacd,2) /* (SYS::%RPLACD cons object) */
- { /* like (RPLACD cons object), but return object as value */
- var object arg1 = check_cons(STACK_1);
- var object arg2 = STACK_0;
- skipSTACK(2);
- Cdr(arg1) = arg2;
- VALUES1(arg2);
- }
- /* (funcall TESTFUN ...) */
- #define CALL_TEST(p) (*pcall_test)(p,*(p STACKop 3),value1)
- /* UP: Replaces in the tree all elements x, which KEY passes the TESTFUNction,
- by NEW. Construktively (copying).
- subst(tree,stackptr,up_fun)
- > tree: the Tree
- > stackptr: *(stackptr-2) = NEW, *(stackptr-1) = KEY
- > up_fun: TESTFUN = Adress of the test function,
- called with same stackptr and with (KEY x) as argument.
- Returns true or false.
- < result: (evtl. newer) tree
- can trigger GC */
- local maygc object subst (object tree, gcv_object_t* stackptr,
- funarg_t* pcall_test) {
- /* First calculate (KEY tree) and call TESTFUN: */
- pushSTACK(tree); /* save tree */
- funcall_key(*(stackptr STACKop -1),tree); /* (KEY tree) */
- if (CALL_TEST(stackptr)) { /* (funcall TESTFUN ...) */
- /* Test ok */
- skipSTACK(1); return *(stackptr STACKop -2); /* return NEW as value */
- } else /* Test not ok */
- if (matomp(STACK_0)) {
- /* Argument is an atom -> keep it unchanged */
- return popSTACK();
- } else {
- /* Argument is a Cons -> call SUBST recursively: */
- check_STACK(); check_SP();
- /* call recursively for the CDR: */
- var object new_cdr = subst(Cdr(STACK_0),stackptr,pcall_test);
- pushSTACK(new_cdr); /* Save CDR result */
- /* call recursively for the CAR: */
- var object new_car = subst(Car(STACK_1),stackptr,pcall_test);
- if (eq(new_car,Car(STACK_1)) && eq(STACK_0,Cdr(STACK_1))) {
- /* both unchanged */
- skipSTACK(1); /* skip CDR result */
- return popSTACK();
- } else {
- STACK_1 = new_car; /* save CAR result */
- return cons_from_stack();
- }
- }
- }
- LISPFUN(subst,seclass_default,3,0,norest,key,3,
- (kw(test),kw(test_not),kw(key)) )
- { /* (SUBST new old tree :test :test-not :key), CLTL p. 273 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT arguments on STACK_2,STACK_1 */
- pushSTACK(STACK_5); /* newobj */
- /* stack layout: new, old, tree, test, test_not, key, new. */
- VALUES1(subst(STACK_4,&STACK_2,pcall_test)); /* do the substitution */
- skipSTACK(7);
- }
- LISPFUN(subst_if,seclass_default,3,0,norest,key,1, (kw(key)) )
- { /* (SUBST-IF new pred tree :key), CLTL p. 273 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- pushSTACK(STACK_3); /* newobj */
- /* stack layout: new, pred, tree, key, new. */
- VALUES1(subst(STACK_2,&STACK_2,&call_if)); /* do the substitution */
- skipSTACK(5);
- }
- LISPFUN(subst_if_not,seclass_default,3,0,norest,key,1, (kw(key)) )
- { /* (SUBST-IF-NOT new pred tree :key), CLTL p. 273 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- pushSTACK(STACK_3); /* newobj */
- /* stack layout: new, pred, tree, key, new. */
- VALUES1(subst(STACK_2,&STACK_2,&call_if_not)); /* do the substitution */
- skipSTACK(5);
- }
- /* UP: Replaces in the tree all elements x, which KEY passes the TESTFUNction,
- by NEW. Destructively (in-place).
- nsubst(tree,stackptr,up_fun)
- > tree: the Tree
- > stackptr: *(stackptr-2) = NEW, *(stackptr-1) = KEY
- > up_fun: TESTFUN = Adress of the test function,
- called with same stackptr and with (KEY x) as argument.
- Returns true or false.
- < result: same tree CAR
- can trigger GC */
- local maygc object nsubst (object tree, gcv_object_t* stackptr,
- funarg_t* pcall_test) {
- /* First calculate (KEY tree) and call TESTFUN: */
- pushSTACK(tree); /* save tree */
- funcall_key(*(stackptr STACKop -1),tree); /* (KEY tree) */
- if (CALL_TEST(stackptr)) { /* (funcall TESTFUN ...) */
- /* Test ok */
- skipSTACK(1); return *(stackptr STACKop -2); /* NEW as value */
- } else { /* Test not ok */
- if (mconsp(STACK_0)) {
- /* Argument is a Cons -> call NSUBST recursively: */
- check_STACK(); check_SP();
- { /* call recursively for the CDR: */
- var object modified_cdr = nsubst(Cdr(STACK_0),stackptr,pcall_test);
- Cdr(STACK_0) = modified_cdr;
- }
- { /* call recursively for the CAR: */
- var object modified_car = nsubst(Car(STACK_0),stackptr,pcall_test);
- Car(STACK_0) = modified_car;
- }
- }
- return popSTACK(); /* return original tree address */
- }
- }
- LISPFUN(nsubst,seclass_default,3,0,norest,key,3,
- (kw(test),kw(test_not),kw(key)) )
- { /* (NSUBST new old tree :test :test-not :key), CLTL p. 274 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT arguments on STACK_2,STACK_1 */
- pushSTACK(STACK_5); /* newobj */
- /* stack layout: new, old, tree, test, test_not, key, new. */
- VALUES1(nsubst(STACK_4,&STACK_2,pcall_test)); /* do the substitution */
- skipSTACK(7);
- }
- LISPFUN(nsubst_if,seclass_default,3,0,norest,key,1, (kw(key)) )
- { /* (NSUBST-IF new pred tree :key), CLTL p. 274 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- pushSTACK(STACK_3); /* newobj */
- /* stack layout: new, pred, tree, key, new. */
- VALUES1(nsubst(STACK_2,&STACK_2,&call_if)); /* do the substitution */
- skipSTACK(5);
- }
- LISPFUN(nsubst_if_not,seclass_default,3,0,norest,key,1, (kw(key)) )
- { /* (NSUBST-IF-NOT new pred tree :key), CLTL p. 274 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- pushSTACK(STACK_3); /* newobj */
- /* stack layout: new, pred, tree, key, new. */
- VALUES1(nsubst(STACK_2,&STACK_2,&call_if_not)); /* do the substitution */
- skipSTACK(5);
- }
- /* UP: return the first list element, whose CAR passed the TESTFUNction.
- sublis_assoc(stackptr)
- > *(stackptr+3) = alist
- > stackptr: *(stackptr-1) = KEY
- > *(stackptr-3) = TESTFUN = test function, called on each list element
- (u . v) with the same stackptr and with (KEY x) and u as arguments.
- returns true, when the test passes, false otherwise.
- < return: list element (a CONS) or NIL
- can trigger GC */
- local maygc object sublis_assoc (gcv_object_t* stackptr)
- {
- var object alist = *(stackptr STACKop 3);
- pushSTACK(alist); /* save the list ((u . v) ...) */
- while (!endp(STACK_0)) {
- /* How to treat atoms in the list?
- a. One can ignore them.
- b. One can signal an error on them.
- c. One can signal an error only for non-NIL atoms.
- Obviously (b) is best, because it provides the best possible
- error checking. But CLtL2 and CLHS both contain a "note" that
- suggests to some people that atoms are ignored, therefore I
- assume that there is code outside which assumes this behaviour,
- and we must not signal an error on it.
- Note: To other people this note suggests that only NILs are
- ignored, and they suggest (c). This is inconsistent with the
- definition of "association list" in the CLHS glossary and with
- the general use of alists as lookup tables.
- Therefore we implement (a).
- SDS 2003-03-08: I am changing the behavior to (c) because
- it is more in line with the ASSOC behavior */
- var object head = Car(STACK_0);
- if (mconsp(head)) { /* skip atoms in the list */
- /* test whether the 2-argument test function
- *(stackptr-3) (an adress!), called on u and the
- value in *(stackptr-2), returns true: */
- var bool erg = /* 2-argument test function, called on (KEY x) and u */
- (*(funarg_t*)TheMachineCode(*(stackptr STACKop -3)))
- ( stackptr, *(stackptr STACKop -2), Car(head) );
- if (erg) /* test passed ==> return x = (u . v) = (CAR alist) */
- return Car(popSTACK());
- /* test failed */
- } else if (!nullp(head))
- error_list(head);
- STACK_0 = Cdr(STACK_0); /* tail recursion */
- }
- skipSTACK(1); /* forget alist */
- /* reached list end ==> return NIL */
- return NIL;
- }
- /* UP: Replaces in tree all x by its A-LIST representation (by ASSOC):
- x is replaced by the first v, so that (u . v) is a member in ALIST and
- (KEY x) and u pass the TESTFUNction. Constructively (copying).
- sublis(tree,stackptr)
- > tree: the Tree
- > stackptr: *(stackptr-1) = KEY, *(stackptr+3) = ALIST,
- *(stackptr-2) is free for (KEY x)
- < result: (evtl. newer) Tree
- can trigger GC */
- local maygc object sublis (object tree, gcv_object_t* stackptr) {
- /* First calculate (KEY tree) and call ASSOC: */
- pushSTACK(tree); /* save tree */
- funcall_key(*(stackptr STACKop -1),tree); /* (KEY tree) */
- *(stackptr STACKop -2) = value1; /* save for sublis_assoc */
- var object assoc_erg = sublis_assoc(stackptr);
- if (consp(assoc_erg)) { /* Test ok */
- skipSTACK(1); return Cdr(assoc_erg); /* (CDR (ASSOC ...)) as value */
- } else /* Test not ok */
- if (matomp(STACK_0)) {
- /* Argument is an atom -> keep unchanged */
- return popSTACK();
- } else {
- /* Argument is a Cons -> call SUBLIS recursively: */
- check_STACK(); check_SP();
- /* call recursively for the CDR: */
- var object new_cdr = sublis(Cdr(STACK_0),stackptr);
- pushSTACK(new_cdr); /* save CDR result */
- /* call recursively for the CAR: */
- var object new_car = sublis(Car(STACK_1),stackptr);
- if (eq(new_car,Car(STACK_1)) && eq(STACK_0,Cdr(STACK_1))) {
- /* both unchanged */
- skipSTACK(1); /* skip CDR result */
- return popSTACK();
- } else {
- STACK_1 = new_car; /* save CAR result */
- return cons_from_stack();
- }
- }
- }
- LISPFUN(sublis,seclass_default,2,0,norest,key,3,
- (kw(test),kw(test_not),kw(key)) )
- { /* (SUBLIS alist tree :test :test-not :key), CLTL p. 274 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- var gcv_object_t* stackptr = &STACK_1;
- var funarg_t* pcall_test = check_test_args(stackptr); /* Call with :TEST/:TEST-NOT arguments */
- /* on STACK_2,STACK_1 arguments. Returns true or false. */
- if (nullp(STACK_4)) { /* shortcut: nothing to do if alist = () */
- VALUES1(STACK_3);
- skipSTACK(5);
- } else {
- pushSTACK(NIL); /* Dummy */
- pushSTACK(make_machine_code(pcall_test)); /* Testfunction, because of Typeinfo=machine_type GC-safe! */
- /* stack layout: alist, tree, test, test_not, key, dummy, pcall_test. */
- VALUES1(sublis(STACK_5,stackptr)); /* do the substitution */
- skipSTACK(7);
- }
- }
- /* UP: Replaces in tree all x by its A-LIST representation (by ASSOC):
- x is replaced by the first v, so that (u . v) is a member in ALIST and
- (KEY x) and u pass the TESTFUNction. Destructively (in-place).
- sublis(tree,stackptr)
- > tree: the Tree
- > stackptr: *(stackptr-1) = KEY, *(stackptr+3) = ALIST,
- *(stackptr-2) is free for (KEY x)
- < result: same Tree CAR
- can trigger GC */
- local maygc object nsublis (object tree, gcv_object_t* stackptr) {
- /* First calculate (KEY tree) and call ASSOC: */
- pushSTACK(tree); /* save tree */
- funcall_key(*(stackptr STACKop -1),tree); /* (KEY tree) */
- *(stackptr STACKop -2) = value1; /* save for sublis_assoc */
- var object assoc_erg = sublis_assoc(stackptr);
- if (consp(assoc_erg)) { /* Test ok */
- skipSTACK(1); return Cdr(assoc_erg); /* (CDR (ASSOC ...)) as value */
- } else { /* Test not ok */
- if (mconsp(STACK_0)) {
- /* Argument is a Cons -> call NSUBLIS recursively: */
- check_STACK(); check_SP();
- { /* call recursively for the CDR: */
- var object modified_cdr = nsublis(Cdr(STACK_0),stackptr);
- Cdr(STACK_0) = modified_cdr;
- }
- { /* call recursively for the CAR: */
- var object modified_car = nsublis(Car(STACK_0),stackptr);
- Car(STACK_0) = modified_car;
- }
- }
- return popSTACK(); /* return original tree address */
- }
- }
- LISPFUN(nsublis,seclass_default,2,0,norest,key,3,
- (kw(test),kw(test_not),kw(key)) )
- { /* (NSUBLIS alist tree :test :test-not :key), CLTL p. 275 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- var gcv_object_t* stackptr = &STACK_1;
- var funarg_t* pcall_test = check_test_args(stackptr); /* Call with :TEST/:TEST-NOT arguments */
- /* on STACK_2,STACK_1 arguments. Returns true or false. */
- if (nullp(STACK_4)) { /* shortcut: nothing to do if alist = () */
- VALUES1(STACK_3);
- skipSTACK(5);
- } else {
- pushSTACK(NIL); /* Dummy */
- pushSTACK(make_machine_code(pcall_test)); /* Testfunction, because of Typeinfo=machine_type GC-safe! */
- /* Stackaufbau: alist, tree, test, test_not, key, dummy, pcall_test. */
- VALUES1(nsublis(STACK_5,stackptr)); /* do the substitution */
- skipSTACK(7);
- }
- }
- /* UP: find OBJ in LIS: (MEMBER OBJ LIS :TEST #'EQ) */
- global object memq (const object obj, const object lis) {
- var object l = lis;
- while (consp(l)) {
- if (eq(Car(l),obj)) return l;
- l = Cdr(l);
- }
- if (!nullp(l))
- error_proper_list_dotted(TheSubr(subr_self)->name,l);
- return NIL;
- }
- /* (SYS::MEMQ OBJECT LIST) == (MEMBER OBJECT LIST :TEST #'EQ) */
- LISPFUNNR(memq,2) {
- var object lis = popSTACK();
- var object obj = popSTACK();
- VALUES1(memq(obj,lis));
- }
- /* UP: Returns the rest of the list starting with the list element,
- which satisfies the TESTFUNction.
- member(list,stackptr,up_fun)
- > list: List
- > stackptr: *(stackptr-1) = KEY
- > up_fun: TESTFUN = Address of the test function,
- Called with same stackptr and with (KEY x) as argument.
- Returns true or false.
- < result: rest of list
- can trigger GC */
- local maygc object member (object list, gcv_object_t* stackptr,
- funarg_t* pcall_test) {
- while (!endp(list)) {
- pushSTACK(list); /* save rest of list */
- funcall_key(*(stackptr STACKop -1),Car(list)); /* (KEY x) */
- {
- var bool erg = CALL_TEST(stackptr); /* (funcall TESTFUN ...) */
- list = popSTACK();
- if (erg)
- return list; /* Test ok -> list as result */
- }
- /* Test not ok -> call (member ... (cdr list)): */
- list = Cdr(list); /* tail-end-recursively */
- }
- return list; /* NIL as result */
- }
- LISPFUN(member,seclass_default,2,0,norest,key,3,
- (kw(test),kw(test_not),kw(key)) )
- { /* (MEMBER item list :test :test-not :key), CLTL p. 275 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- var funarg_t* pcall_test = check_test_args(&STACK_1); /* :TEST/:TEST-NOT arguments on STACK_2,STACK_1 */
- VALUES1(member(STACK_3,&STACK_1,pcall_test)); /* do the search */
- skipSTACK(5);
- }
- LISPFUN(member_if,seclass_default,2,0,norest,key,1, (kw(key)) )
- { /* (MEMBER-IF pred list :key), CLTL p. 275 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- VALUES1(member(STACK_1,&STACK_1,&call_if)); /* do the search */
- skipSTACK(3);
- }
- LISPFUN(member_if_not,seclass_default,2,0,norest,key,1, (kw(key)) )
- { /* (MEMBER-IF-NOT pred list :key), CLTL p. 275 */
- check_key_arg(&STACK_0); /* :KEY argument on STACK_0 */
- VALUES1(member(STACK_1,&STACK_1,&call_if_not)); /* do the search */
- skipSTACK(3);
- }
- LISPFUNNR(tailp,2) /* (TAILP sublist list), CLTL p. 275 */
- #ifndef X3J13_175
- /* (defun tailp (sublist list)
- (do ((l list (rest l)))
- ((endp l) (null sublist))
- (when (eq l sublist) (return t)))) */
- #else
- /* (defun tailp (sublist list)
- (loop
- (when (eql sublist list) (return t))
- (when (atom list) (return nil))
- (setq list (cdr list)))) */
- #endif
- {
- var object list = popSTACK();
- var object sublist = popSTACK();
- #ifndef X3J13_175
- while (!endp(list)) {
- if (eq(list,sublist))
- goto yes;
- list = Cdr(list);
- }
- if (nullp(sublist))
- goto yes;
- #else
- while (1) {
- if (eql(list,sublist))
- goto yes;
- if (atomp(list))
- break;
- list = Cdr(list);
- }
- #endif
- VALUES1(NIL); return; /* NIL as value */
- yes:
- VALUES1(T); return; /* T as value */
- }
- LISPFUN(adjoin,seclass_defa…
Large files files are truncated, but you can click here to view the full file