1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-


;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

;1;; NOTES:*
;1;;  1) The implementation follows that of the sequence functions. Each keyword*
;1;;     function foo has a "*" version which takes the same arguments but positionally*
;1;;     instead of keyword fashion. There is also a "-test" version, which offers the*
;1;;     function with only a test option. And finally there is a stripped down version*
;1;;     which takes only required options (and #'EQL) for a test-function.*

;;; Edit History
;;;------------------------------------------------------------------------------------
;;; 07-17-87  AB  Sys 3-49.  Fixed a bunch of doc strings.  [SPRs 5202, 5574]
;;; 05-12-88  RJF sys 4-62.  Fixed set-exclusive-or to stop destructively changing of the
;;;                          lists in some cases
;;; 05-05-89  DNG	     Speed up UNION with :TEST #'EQ.

(Defun CAR-LOCATION (cons)
  (CHECK-ARG cons CONSP "2a cons"*)
  (%MAKE-POINTER DTP-LOCATIVE cons))

(Defun TREE-EQUAL (x y &KEY test test-not)
  1"Compare two lists or trees recursively for matching structure and leaves.
TEST or TEST-NOT is a function to compare leaves (non-lists) with:
if TEST-NOT is specified, leaves match if that function returns NIL;
if TEST is specified, leaves match if that function returns T.
If no test is specified, EQL is used."*
  (COND ((OR (EQ TEST 'EQ) (EQ TEST #'EQ))
	 (OR (EQ X Y) (TREE-EQUAL-EQ X Y)))
	((OR (EQ TEST 'EQL) (EQ TEST #'EQL)
	     (AND (NULL TEST) (NULL TEST-NOT)))
	 (TREE-EQUAL-EQL X Y))
	(T (TREE-EQUAL-1 X Y (OR TEST-NOT TEST) (NOT (NULL TEST-NOT))))))

(Defun TREE-EQUAL-1 (X Y PRED INVERTP)
  (DO ((XTAIL X (CDR XTAIL))
       (YTAIL Y (CDR YTAIL)))
      (())
    (IF (ATOM XTAIL)
	(RETURN (AND (ATOM YTAIL)
		     (EQ INVERTP (NOT (FUNCALL PRED XTAIL YTAIL))))))
    (IF (ATOM YTAIL) (RETURN NIL))
    (IF (NOT (TREE-EQUAL-1 (CAR XTAIL) (CAR YTAIL) PRED INVERTP))
	(RETURN NIL))))

(Defun TREE-EQUAL-EQL (X Y)
  (DO ((XTAIL X (CDR XTAIL))
       (YTAIL Y (CDR YTAIL)))
      (())
    (IF (ATOM XTAIL)
	(RETURN (AND (ATOM YTAIL) (EQL XTAIL YTAIL))))
    (IF (ATOM YTAIL) (RETURN NIL))
    (IF (AND (NOT (EQL (CAR XTAIL) (CAR YTAIL)))
	     (NOT (TREE-EQUAL-EQL (CAR XTAIL) (CAR YTAIL))))
	(RETURN NIL))))

(Defun TREE-EQUAL-EQ (X Y)
  (DO ((XTAIL X (CDR XTAIL))
       (YTAIL Y (CDR YTAIL)))
      (())
    (IF (ATOM XTAIL)
	(RETURN (AND (ATOM YTAIL) (EQ XTAIL YTAIL))))
    (IF (ATOM YTAIL) (RETURN NIL))
    (IF (AND (NEQ (CAR XTAIL) (CAR YTAIL))
	     (NOT (TREE-EQUAL-EQ (CAR XTAIL) (CAR YTAIL))))
	(RETURN NIL))))

(Defun LIST-LENGTH (LIST)
1  "Return the length of LIST, or NIL if LIST is circular."*
  (DO ((n 0 (+ n 2))
       (y list (CDDR y))
       (x list (CDR x)))
      (())
    (WHEN (ATOM y) (RETURN N))
    (WHEN (ATOM (CDR y)) (RETURN (1+ n)))
    (WHEN (AND (EQ x y) (PLUSP n)) (RETURN nil))))

(Defun MAKE-LIST (length &KEY area initial-element)
  1"Create a list LENGTH long. :AREA keyword says where, :INITIAL-ELEMENT sets each element."*

  (%MAKE-LIST initial-element area length))

(Defun CIRCULAR-LIST (&REST ARGS &AUX TEM)
  1"Return a circular list whose elements are ARGS (over and over again)."*
  (WHEN ARGS
    (SETQ TEM (COPYLIST* ARGS))
    (RPLACD (LAST TEM) TEM)
    TEM))

;;PHD 1/16/86 Fixed Append so it cdr-code the resulted list.
(defun append (&rest lists)
  "Append any number of lists.
The value is a list whose elements are those of the argument lists, in order."
  (prog (total-length
	 argp
	 val
	 valp)
    (cond
      ((atom lists) (return ()))
      ((atom (cdr lists)) (return (car lists))))
    (setq total-length 0)
    ;; Accumulate length of args we must copy
    (do ((argp lists (cdr argp)))
	((atom (cdr argp))
	 ;; Plus one more if the last arg is not NIL.
	 ;; But if all are NIL so far, leave it 0 as signal to COND that follows.
	 (and (car argp) (not (zerop total-length)) (setq total-length (1+ total-length))))
	 ;; Verify that all args (except perhaps the last) are lists.
      (or (consp (car argp)) (null (car argp))
	 (let ((arg (car argp)))
	   (check-arg arg (or (consp arg) (null arg)) "a list" ':list)
	   (setf (car argp) arg)))
      (setq total-length (+ total-length (length (car argp)))))
    (cond
      ((zerop total-length) (return (car (last lists)))))
    (setq valp (setq val (make-list  total-length)))
    (setq argp lists)
    l2
    (cond
      ((null (cdr argp))
       ;; When we reach the last arg, if it's NIL, we are done.
       (or (car argp) (return val))
       ;; Otherwise, stick in a pointer to the last arg,
       ;; and then change it from an element to a cdr.
       (rplaca valp (car argp))
       (let ((inhibit-scheduling-flag t))
	 (%p-store-cdr-code-offset cdr-error valp 0)
	 (%p-store-cdr-code-offset cdr-normal  valp -1))
       (return val)))
    (do ((arglp (car argp) (cdr arglp)))
	((atom arglp)
	 (setq argp (cdr argp))
	 (go l2))
      (rplaca valp (car arglp))
      (setq valp (cdr valp)))))

;;;(Defun APPEND (&REST lists)
;;;  1"Appends any number of lists. All arguments , save possibly for the last, must*
;;;1be lists while the last can be any Lisp object. All arguments except for the last*
;;;1are copied. See also CONCATENATE, which appends and copies all arguments, and COPY-LIST,*
;;;1which copies its argument."*

;;;  (LET* ((new-list nil)
;;;	 (ptr (LOCF new-list)))
;;;    (DO ((rest lists (CDR rest)))
;;;	((ENDP (CDR rest))
;;;	 (RPLACD ptr (CAR rest))
;;;	 new-list)
;;;      (CHECK-TYPE (CAR rest) list "a list")
;;;      (DOLIST (x (CAR rest))
;;;	 (RPLACD ptr (SETQ ptr (CONS x nil)))))))

(Defun *APPEND (l1 l2)
  (if (atom l1 )
      l2
    (PROG* ((result (make-list (LENGTH l1)))
	    (temp result))
	loop					;8 instructions in the inner loop
	   (SETF (CAR temp) (POP l1))
	   (COND ((CONSP (CDR temp))
		  (POP temp)
		  (GO loop))
		 (t (RPLACD temp l2)
		    (RETURN result))))))



;1; note:the procedures for copy-list and zlc:copylist are identical. Do not use DEFF*
;1; since both are used in the minimal kernel.*

(Defun COPY-LIST (list &OPTIONAL IGNORE)
  1"Copy top level of list structure.  Dotted pair termination of list will be copied"*
  (DECLARE (INLINE COPY-LIST))
  (IF (ATOM list) list				;Might be NIL
      (do* ((newlist (MAKE-LIST (LENGTH list)))
	    (l1 list)
	    (l2 newlist))
	   (())
	(rplaca l2 (car l1))
	(pop l1)
	(when (atom l1)
	      (WHEN l1
		    (RPLACD l2 l1))
	      (RETURN newlist))			; return the list
	(pop l2))))


(Defun ZLC:COPYLIST (list &OPTIONAL ignore)
  1"Copy top level of list structure.  Dotted pair termination of list will be copied"*
  (DECLARE (INLINE COPY-LIST))
  (COPY-LIST list))

(Defun COPYLIST* (LIST )
  1"Like COPY*-1LIST but never cdr-codes the last pair of the list."*
  (IF (ATOM list) list				;Might be NIL
      (LET* ((len (LENGTH list))
	     (newlist (MAKE-LIST (1+ len))))
	(DO ((l1 list (CDR l1))
	     (l2 newlist (CDR l2)))
	    ((ATOM l1)
	     (RPLACA l2 l1)
	     (WITHOUT-INTERRUPTS
	       1(%P-STORE-CDR-CODE-OFFSET CDR-ERROR l2 0)*
	       1(%P-STORE-CDR-CODE-OFFSET CDR-NORMAL l2 -1)*)
;; TGC	       (%P-DPB-OFFSET CDR-ERROR %%Q-CDR-CODE l2 0)
;; TGC	       (%P-DPB-OFFSET CDR-NORMAL %%Q-CDR-CODE l2 -1))
	     newlist)				; return the list
	  (RPLACA l2 (CAR l1))))))



(Defun COPY-ALIST (al)
  1"Copy top two levels of list structure.  Dotted pair termination of list will be copied"*
  (IF (ATOM al)
      al
      (SETQ AL (COPY-LIST al))	1;recopy the top level.*
      (DO ((p al (CDR p)))
	  ((ATOM p) al)
	(WHEN (CONSP (CAR p))			1;then recopy the assoc cells.*
	  (RPLACA p (CONS (CAAR p) (CDAR p)))))))

;1; older version of copy-alist -- eventually flush from the minimal kernel*

(Defun ZLC:COPYALIST (AL &OPTIONAL (DEFAULT-CONS-AREA DEFAULT-CONS-AREA))
  "Copy top two levels of list structure.  Dotted pair termination of list will be copied"
  (COND ((ATOM AL) AL)
	(T (SETQ AL (COPY-LIST al))   ;RECOPY THE TOP LEVEL.
	   (DO ((P AL (CDR P)))
	       ((ATOM P) AL)
	     (COND ((CONSP (CAR P))		  ;THEN RECOPY THE ASSOC CELLS.
		    (RPLACA P (CONS (CAAR P) (CDAR P)))))))))

1;;; (SUBST NIL NIL ...) WAS such an ugly language idiom...*
;1;; the following definition is not as nice as*
;1;;  (*Defun1 copy-tree (tree)*
;1;;    (if (atom tree) tree (cons (copy-tree (car tree)) (copy-tree (cdr tree)))))*
;1;; but is more efficient*


(Defun COPY-TREE (tree)
  1"Copy list structure to all levels, creating a maximally cdr-coded structure. All
cons cells in the tree are copied, but non-list cells are not copied."*
  (declare (inline copy-list))
  (IF (ATOM tree) tree
      (LET ((newtree (COPY-LIST tree)))
	(DO ((x newtree (CDR x)))
	    ((ATOM x) newtree)
	  (SETF (CAR x) (COPY-TREE (CAR x)))))))

;1; older version of copy-tree -- eventually flush from the minimal kernel*

(Defun ZLC:COPYTREE (TREE &OPTIONAL (DEFAULT-CONS-AREA DEFAULT-CONS-AREA))
  "Copy list structure to all levels, creating a maximally cdr-coded structure."
  (IF (ATOM TREE)
      TREE
    (LET ((NEWTREE (COPY-LIST TREE)))
      (DO ((L NEWTREE (CDR L)))
	  ((ATOM L))
	(SETF (CAR L) (COPY-TREE (CAR L))))
      NEWTREE)))

(Defun REVAPPEND (list starting-tail)
  "2Functionally equivalent to (APPEND (REVERSE list) starting-tail) except more efficient
in use of storage."*
  (DO ((rest list (CDR rest))
       (newlist starting-tail (CONS (CAR rest) newlist)))
      ((ATOM rest) newlist)))

;1; The spice version below is slightly more readable(?).*
;1;   *(Defun NRECONC (list tail)
;1;   *  (DO ((x (CDR list) (IF (ATOM x) x (CDR x)))
;1;   *       (y list x)
;1;   *       (z tail y))
;1;   *      ((ATOM y) z)
;1;    *    (RPLACD y z)))

(Defun NRECONC (list tail)
  "2Functionally equivalent to (NCONC (NREVERSE list) tail) and LIST is destroyed"*
  (PROG () 
     A   (AND (ATOM list) (RETURN tail))
	(SETQ list (PROG1 (CDR list) (RPLACD list tail) (SETQ tail list)))
	(GO A)))

(Defun NCONC (&REST lists)
  1"Concatenate an arbitrary number of LISTS, say x1,...,xN, together by destructively modifying the tail 
of each list xI to point to next list xI+1."*
  (DO  ((rest lists (CDR rest)))1  ;; find first cons in <lists>*
       ((ENDP rest) rest)
    (WHEN (CONSP (CAR rest))
      (LET ((last (LAST (CAR rest))))
	(DO* ((x (CDR rest) (CDR x))
	      (next (CAR x) (CAR x)))
	     ((ENDP (CDR x))
	      (RPLACD last next)1   ;; plug the last item of <lists> into the result even if it is not a cons*
	      (RETURN-FROM NCONC (CAR rest)))
	  (WHEN (CONSP next)
	    (RPLACD last next)
	    (SETQ last (LAST next))))))))

(Defun *NCONC (list1 list2)
  (IF (ATOM list1) list2
      (RPLACD (LAST list1) list2)
      list1))


(Defun BUTLAST (list &OPTIONAL (n 1))
1  "Return a list which has all the elements of 2<*list2>* except the last2 <n> (default 1)"**
  (FIRSTN (MAX 0 (- (LENGTH list) n)) list))

(Defun NBUTLAST (LIST &OPTIONAL (N 1))
1  "Modify 2<*list2> to remove its last <n> elements"**
  (LET ((newlen (- (LENGTH list) n)))
    (IF (<= newlen 0)
	nil
      (SETF (NTHCDR newlen list) nil)
      list)))

1;FIRSTN of a number and a list returns the first that many elements of the list.
;If the list isn't that long, it is extended with NILs.  Like Take in APL.*
(Defun FIRSTN (n list)
1  "Return a list containing the first N elements of LIST."*
  (LET ((new-list (MAKE-LIST n)))
    (DO ((list list (CDR list))
	 (nlist new-list (CDR nlist)))
	((OR (ENDP list) (ENDP nlist)) new-list)
      (RPLACA nlist (CAR list)))))

;1;LDIFF as in Interlisp:  applied to (A B C D E) and (D E), it returns (A B C).*
(Defun LDIFF (list tail)
1  "Return a copy of the part of LIST that precedes TAIL.
If TAIL is not a link in LIST, a copy of all of LIST is returned."*

  (LET* ((result nil)         ;; see DEUS EX MACHINA in "sequences2"
	 (loc (LOCF result)))
    (DO ((x list (CDR x)))
	((OR (ATOM x) (EQ x tail)) result)
      (RPLACD loc (SETQ loc (CONS (CAR x) nil))))))

(Defun TAILP (TAIL LIST)
  1"Return non-NIL if TAIL can be reached from LIST by cdr'ing."*
  (DO ((x list (CDR x)))
      ((ENDP x) nil)
    (WHEN (EQ TAIL x)   ;1; use eq to perform address comparison*
      (RETURN T))))

(Defun NLEFT (N L &OPTIONAL TAIL)
  "If TAIL is a link in the list L, back up N cdrs from TAIL.
The value is a link in the list L, which, if cdr'd N times, gives TAIL.
If TAIL is NIL, the values is the last N elements of L.
If TAIL is not a link in L, or L is too short, the value is NIL."
  (DO ((L1 L (CDR L1))
       (L2 (NTHCDR N L) (CDR L2)))
      ((EQ L2 TAIL) L1)
    (AND (NULL L2) (RETURN NIL))))


(eval-when (compile)
  (Defmacro MEMBER-TEMPLATE (x list test)
    `(DO ((,x ,list (CDR ,x)))
	 ((ENDP ,x) nil)
       (WHEN ,test (RETURN ,x))))
)

(Defun MEMBER-TEST (item list test)
;1; specialization for MEMBER when the keyword TEST is used*
  (MEMBER-TEMPLATE x list (FUNCALL test item (CAR x))))

(Defun MEMBER-EQUAL (item list)
;1; specialization for MEMBER when the keyword TEST is used specifying EQUAL*
  (MEMBER-TEMPLATE x list (EQUAL (CAR x) item)))

(Defun MEMBER-EQL (item list)
;1; specialization for MEMBER when the keyword TEST is used specifying EQL and by default*
  (MEMBER-TEMPLATE x list (EQL (CAR x) item)))

(Defun MEMBER-EQUALP (item list)
;1; specialization for MEMBER when the keyword TEST is used specifying EQUALP *
  (MEMBER-TEMPLATE x list (EQUALP (CAR x) item)))

(Defun MEMBER* (item list &OPTIONAL (test #'EQL) key test-not)
  (DECLARE (INLINE MEMBER*))
  (IF key 
      (IF test-not 
	  (MEMBER-TEMPLATE x list (NOT (FUNCALL test-not item (FUNCALL key (CAR x)))))
	  (MEMBER-TEMPLATE x list (FUNCALL test item (FUNCALL key (CAR x)))))
      (IF test-not 
	  (MEMBER-TEMPLATE x list (NOT (FUNCALL test-not item (CAR x))))
	  (MEMBER-TEMPLATE x list (FUNCALL test item (CAR x))))))

(Defun MEMBER (item list &KEY key (test #'EQL) test-not)
  1"Return a tail of LIST whose car is the first element of LIST that matches ITEM.*
  1KEY, if non-NIL, is a function applied to each element to get the
object to match against.  If KEY is NIL, the element itself is used.*
  1TEST is a function passed ITEM and the element (or its key).*  1There is a match 
if TEST returns non-NIL.  TEST defaults to EQL.*
  1Alternatively, pass TEST-NOT, a function to return NIL when there is a match."*
  (DECLARE (INLINE MEMBER*))
  (MEMBER* item list test key test-not))


(Defun zlc:MEMBER (ITEM IN-LIST)
  "Return non-NIL if IN-LIST has an element EQUAL to ITEM.
The value is actually the link of IN-LIST whose CAR is that element."
  (MEMBER-TEMPLATE x in-list (EQUAL (CAR x) item)))

(Defun MEMBER-IF* (predicate list &OPTIONAL key)
  (IF key 
      (MEMBER-TEMPLATE x list (FUNCALL predicate (FUNCALL key (CAR x))))
      (MEMBER-TEMPLATE x list (FUNCALL predicate (CAR x)))))

(Defun MEMBER-IF (predicate list &KEY key)
1  "Return a tail of 2<*list2>* whose car is the first element of 2<*list2>* that satisfies 2<*predicate2>*."*
  (DECLARE (INLINE MEMBER-IF*))
  (MEMBER-IF* predicate list key))

(Defun MEMBER-IF-NOT* (predicate list &OPTIONAL key)
  (IF key 
      (MEMBER-TEMPLATE x list (NOT (FUNCALL predicate (FUNCALL key (CAR x)))))
      (MEMBER-TEMPLATE x list (NOT (FUNCALL predicate (CAR x))))))

(Defun MEMBER-IF-NOT (predicate list &KEY key)
1  "Return a tail of LIST whose car is the first element that doesn't satisfy PREDICATE."*
  (DECLARE (INLINE MEMBER-IF-NOT*))
  (MEMBER-IF-NOT* predicate list key))


;;; Association List support

(DEFSUBST ACONS (key datum alist)
  1"Add a new element (key . datum) to alist.
   Equivalent to (CONS (CONS KEY DATUM) ALIST)."*
  (CONS (CONS key datum) alist))

(Defun PAIRLIS (keys data &OPTIONAL starting-alist)
1  "(NCONC (MAPCAR 'CONS KEYS DATA) STARTING-ALIST)"*
  (NCONC (MAPCAR #'(lambda (x y) (CONS x y)) keys data) starting-alist))

(eval-when(compile) 
  (Defmacro ASSOC-TEMPLATE (x list test)
    `(DOLIST (,x ,list)
       ;1; the test (when (and x (...  is necessary in cases where*
	;1; nil appears in the alist and is the item sought. For then assoc*
	;1; will seek a pair whose car is nil.*
       (AND ,test ,x (RETURN ,x))))
)

(Defun ASSOC-TEST(item alist test)
;1; specialization for ASSOC for keyword TEST*
  (ASSOC-TEMPLATE pair alist (FUNCALL test item (CAR pair))))

(Defun ASSOC-EQUAL(item alist)
;1; specialization for ASSOC when TEST is EQUAL *
  (ASSOC-TEMPLATE pair alist (EQUAL item (CAR pair))))

(Defun ASSOC-EQL (item alist)
;1; specialization for ASSOC when TEST is EQL or by default *
  (ASSOC-TEMPLATE pair alist (EQL item (CAR pair))))

(Defun ASSOC-EQUALP (item alist)
;1; specialization for ASSOC when TEST is EQUALP *
  (ASSOC-TEMPLATE pair alist (EQUALP item (CAR pair))))

(Defun ASSOC-TESTNOT (item alist test-not)
  (ASSOC-TEMPLATE pair alist (NOT (FUNCALL test-not item (CAR pair)))))

;;PAD 4/3/87 Add :key arg (Steele, p. 280) SPR 3917 CR:PHD
(Defun ASSOC (item alist &KEY key (test #'EQL) test-not)
  "2Returns the first cons in ALIST whose car matches ITEM according to1 TEST*
or NIL if there is no match. * 2By default TEST is EQL. * 2Otherwise TEST
is a predicate which is given the car of a cons and ITEM and returns non-NIL if
they match and NIL otherwise. * 1Alternatively2 one can use TEST-NOT*, which2 should 
return NIL** 2for a match."*
  (if key
      (IF test-not    ;; check :test-not since :test has a default value
	  (ASSOC-TEMPLATE pair alist (NOT (FUNCALL test-not item (funcall key (CAR pair)))))
	  (ASSOC-TEMPLATE pair alist (FUNCALL test item (funcall key (CAR pair)))))
      (IF test-not    ;; check :test-not since :test has a default value
	  (ASSOC-TEMPLATE pair alist (NOT (FUNCALL test-not item (CAR pair))))
	  (ASSOC-TEMPLATE pair alist (FUNCALL test item (CAR pair))))))


(Defun ASSOC-IF (predicate alist)
1  "Returns the first element of 2<a*list2>* whose car satisfies 2<*predicate2>*, or NIL if none."*
  (ASSOC-TEMPLATE x alist (FUNCALL predicate (CAR x))))

(Defun ASSOC-IF-NOT (predicate alist)
1  "Returns the first element of 2<alist>* whose car does not satisfy 2<*predicate2>*, or NIL if none."*
  (ASSOC-TEMPLATE x alist (NOT (FUNCALL predicate (CAR x)))))

(Defun RASSOC-EQUAL(item alist) 
;1; specialization for RASSOC when TEST is EQUAL*
  (ASSOC-TEMPLATE pair alist (EQUAL item (CDR pair))))

(DEFUN RASSOC-TEST(item alist test) 
;1; specialization for RASSOC for keyword TEST*
  (ASSOC-TEMPLATE pair alist (FUNCALL test item (CDR pair))))

(DEFUN RASSOC-TESTNOT(item alist test) 
;1; specialization for RASSOC for keyword TEST-NOT*
  (ASSOC-TEMPLATE pair alist (NOT (FUNCALL test item (CDR pair)))))

;;;;;;;;;;;;;; DEFINE ZLC:RASSQ and SYS:RASSQ -- don't use DEFF -- both are needed in the cold load
(Defun ZLC:RASSQ (item alist) 
;1; specialization for RASSOC when TEST is EQ*
  (ASSOC-TEMPLATE pair alist (EQ item (CDR pair))))

(Defun SYS:RASSQ (item alist) 
;1; specialization for RASSOC when TEST is EQ*
  (ASSOC-TEMPLATE pair alist (EQ item (CDR pair))))

(Defun RASSOC-EQL (item alist)
;1; specialization for RASSOC when TEST is EQL or by default *
  (ASSOC-TEMPLATE pair alist (EQL item (CDR pair))))

(Defun RASSOC-EQUALP (item alist)
;1; specialization for RASSOC when TEST is EQUALP *
  (ASSOC-TEMPLATE pair alist (EQUALP item (CDR pair))))


;;PAD 4/3/87 Add :key arg (Steele, p. 281) SPR 3917 CR:PHD
(Defun RASSOC (item Alist &KEY key (test #'EQL) test-not)
  1"Returns the first cons in ALIST whose cdr matches ITEM according to TEST
or NIL if there is no match.  By default TEST is EQL.  Otherwise TEST
is a predicate which is given the cdr of a cons and ITEM and returns non-NIL if
they match and NIL otherwise.  Alternatively one can use TEST-NOT, which should 
return NIL for a match."*
  (if key
      (IF test-not  ;1; check :test-not since :test is defaulted*
	  (ASSOC-TEMPLATE pair alist (NOT (FUNCALL test item (funcall key (CDR pair)))))
	  (ASSOC-TEMPLATE pair alist (FUNCALL test item (funcall key (CDR pair)))))  
      (IF test-not  ;1; check :test-not since :test is defaulted*
	  (ASSOC-TEMPLATE pair alist (NOT (FUNCALL test item (CDR pair))))
	  (ASSOC-TEMPLATE pair alist (FUNCALL test item (CDR pair))))))

(Defun RASSOC-IF (predicate alist)
1  "Returns the first element of <alist> whose cdr satisfies <predicate>, or NIL if none."*
  (ASSOC-TEMPLATE x alist (FUNCALL predicate (CDR x))))

(Defun RASSOC-IF-NOT (predicate alist)
1  "Returns the first element of 2<alist>* whose cdr does not satisfy 2<*predicate2>*, or NIL if none."*
  (ASSOC-TEMPLATE x alist (NOT (FUNCALL predicate (CDR x)))))


(Defun ASSQ-CAREFUL (KEY IN-LIST)
  "Like ASSQ, but elements of IN-LIST that are not lists are just ignored (no error)."
  (PROG NIL 
    L	(COND ((ATOM IN-LIST) (RETURN NIL))
              ((ATOM (CAR IN-LIST)))
              ((EQ KEY (CAAR IN-LIST))
               (RETURN (CAR IN-LIST))))
    	(SETQ IN-LIST (CDR IN-LIST))
        (GO L)))

(Defun ASSOC-CAREFUL (KEY IN-LIST)
  "Like ASSOC, but elements of IN-LIST that are not lists are just ignored (no error)."
  (PROG NIL 
    L	(COND ((ATOM IN-LIST) (RETURN NIL))
              ((ATOM (CAR IN-LIST)))
              ((EQUAL KEY (CAAR IN-LIST))
               (RETURN (CAR IN-LIST))))
    	(SETQ IN-LIST (CDR IN-LIST))
        (GO L)))

(eval-when (compile)
  (Defmacro ADJOIN-TEMPLATE (x list new-list test)
    `(DOLIST (,x ,list ,new-list)
       (WHEN ,test (RETURN ,list))))
)

(Defun ADJOIN-TEST (item list test)
  (ADJOIN-TEMPLATE x list (CONS item list) (FUNCALL test item x)))

(Defun ADJOIN* (item list &OPTIONAL (test #'EQL) key test-not)
  (COND (key 
	 (IF test-not
	     (ADJOIN-TEMPLATE x list (CONS item list) (NOT (FUNCALL test-not (FUNCALL key item) (FUNCALL key x))))
	     (ADJOIN-TEMPLATE x list (CONS item list) (FUNCALL test (FUNCALL key item) (FUNCALL key x)))))
	(test-not (ADJOIN-TEMPLATE x list (CONS item list) (NOT (FUNCALL test-not item x))))
	(t (ADJOIN-TEMPLATE x list (CONS item list) (FUNCALL test item x)))))

(Defun ADJOIN (item list &KEY key (test #'EQL) test-not)
  1"Adds ITEM to LIST provided no item of the list matches ITEM.  By default,
the matching test is EQL.  If TEST is not NIL, then it should be a function
which, given ITEM and an element from LIST , returns non-NIL if ITEM matches 
the element and NIL otherwise.  Alternatively, pass TEST-NOT which returns 
NIL when there is a match.  If KEY is non-NIL, then it is a funcion applied to
ITEM as well as to each LIST element before they are compared with TEST or 
TEST-NOT."*
  (ADJOIN* item list test key test-not))

(eval-when (compile) 
  (Defmacro SUBST-TEMPLATE (procedure-name test-form new old tree &REST args)
;1; generate code for subst*
    `(COND (,test-form ,new)
	   ((ATOM ,tree) ,tree)
	   (t 
	    (LET ((new-left-subtree (,procedure-name ,new ,old (CAR ,tree) . ,args))
		  (new-right-subtree (,procedure-name ,new ,old (CDR ,tree) . ,args)))
	      (IF (AND (EQL new-left-subtree (CAR ,tree))
		       (EQL new-right-subtree (CDR ,tree)))
		  ,tree
		  (CONS new-left-subtree new-right-subtree))))))
  )
(Defun SUBST-EQUAL (new old tree)
  (SUBST-TEMPLATE SUBST-EQUAL (EQUAL tree old) new old tree))

(Defun SUBST-EQL (new old tree)
  (SUBST-TEMPLATE SUBST-EQL (EQL tree old) new old tree))

(Defun SUBST* (new old tree &OPTIONAL (test #'EQL) key test-not)
  (COND (key
	 (IF test-not 
	     (SUBST-TEMPLATE SUBST* (NOT (FUNCALL test-not (FUNCALL key tree) old)) new old tree test key test-not)
	     (SUBST-TEMPLATE SUBST* (FUNCALL test (FUNCALL key tree) old) new old tree test key)))
	(test-not (SUBST-TEMPLATE SUBST* (NOT (FUNCALL test-not tree old)) new old tree test key test-not))
	(t (SUBST-TEMPLATE SUBST* (FUNCALL test tree old) new old tree test key))))

(Defun SUBST (new old tree &KEY key (test #'EQL) test-not)
  "2Essentially substitute <new> for <old> in <tree> which is a tree of conses.
 Each CONS and ATOM in <tree> is tested against <old>. When there is a match,
<new> is substituted for <old>. Consing is performed only as needed and <tree>
is unaltered by the invocation.*"
  (SUBST* new old tree test key test-not))

(Defun SUBST-IF* (new predicate tree &OPTIONAL key)
  (IF key (SUBST-TEMPLATE SUBST-IF* (FUNCALL predicate (FUNCALL key tree)) new predicate tree key)
      (SUBST-TEMPLATE SUBST-IF* (FUNCALL predicate tree) new predicate tree)))

(Defun SUBST-IF (new predicate tree &KEY key)
  "2Essentially substitute <new> for each ATOM or CONS in <tree> which satisfies
<predicate>. Consing is performed only as needed and <tree> is unaltered.*"
  (SUBST-IF* new predicate tree key))

(Defun SUBST-IF-NOT* (new predicate tree &OPTIONAL key)
  (IF key (SUBST-TEMPLATE SUBST-IF-NOT* (NOT (FUNCALL predicate (FUNCALL key tree))) new predicate tree key)
      (SUBST-TEMPLATE SUBST-IF-NOT* (NOT (FUNCALL predicate tree)) new predicate tree)))

(Defun SUBST-IF-NOT (new predicate tree &KEY key)
  "2Essentially substitute <new> for each ATOM or CONS in <tree> which doesn't satisfy
<predicate>. Consing is performed only as needed and <tree> is unaltered.*"
  (SUBST-IF-NOT* new predicate tree key))

(eval-when (compile)
  (Defmacro NSUBST-TEMPLATE (procedure-name test-form new old tree &REST args)
;1; generate code for nsubst*
    `(COND (,test-form ,new)
	   ((ATOM ,tree) ,tree)
	   (t 
	    (LET ((new-left-subtree (,procedure-name ,new ,old (CAR ,tree) . ,args))
		  (new-right-subtree (,procedure-name ,new ,old (CDR ,tree) . ,args)))
	      (UNLESS (EQL new-left-subtree (CAR ,tree))
		(SETF (CAR ,tree) new-left-subtree))
	      (UNLESS (EQL new-right-subtree (CDR ,tree))
		(SETF (CDR ,tree) new-right-subtree))
	      ,tree))))
  )

(Defun NSUBST* (new old tree &OPTIONAL (test #'EQL) key test-not)
  (COND (key
	 (IF test-not 
	     (NSUBST-TEMPLATE NSUBST* (NOT (FUNCALL test-not (FUNCALL key tree) old)) new old tree test key test-not)
	     (NSUBST-TEMPLATE NSUBST* (FUNCALL test (FUNCALL key tree) old) new old tree test key)))
	(test-not (NSUBST-TEMPLATE NSUBST* (NOT (FUNCALL test-not tree old)) new old tree test key test-not))
	(t (NSUBST-TEMPLATE NSUBST* (FUNCALL test tree old) new old tree test key))))

(Defun NSUBST (new old tree &KEY key (test #'EQL) test-not)
  "2Essentially substitute <new> for <old> in <tree> which is a tree of conses.
 Each CONS and ATOM in <tree> is tested against <old>. When there is a match,
<new> is substituted for <old>.  <tree> is altered by the invocation.*"
  (NSUBST* new old tree test key test-not))

(Defun NSUBST-IF* (new predicate tree &OPTIONAL key)
;1; specialization for nsubst-if when KEY is not used*
  (IF key (NSUBST-TEMPLATE NSUBST-IF* (FUNCALL predicate (FUNCALL key tree)) new predicate tree key)
      (NSUBST-TEMPLATE NSUBST-IF* (FUNCALL predicate tree) new predicate tree)))

(Defun NSUBST-IF (new predicate tree &KEY key)
  "2Essentially substitute <new> for each ATOM or CONS in <tree> which satisfies
<predicate>. <tree> can be destroyed.*"
  (NSUBST-IF* new predicate tree key))

(Defun NSUBST-IF-NOT* (new predicate tree &OPTIONAL key)
  (IF key (NSUBST-TEMPLATE NSUBST-IF-NOT* (NOT (FUNCALL predicate (FUNCALL key tree))) new predicate tree key)
      (NSUBST-TEMPLATE NSUBST-IF-NOT* (NOT (FUNCALL predicate tree)) new predicate tree)))

(Defun NSUBST-IF-NOT (new predicate tree &KEY key)
  "2Essentially substitute <new> for each ATOM or CONS in <tree> which doesn't satisfy
<predicate>.  <tree> can be destroyed.*"
  (NSUBST-IF-NOT* new predicate tree key))

(eval-when (compile) 

  (Defmacro SUBLIS-TEMPLATE (pair test-form alist tree &REST args)
;1; generate code for subst*
    `(LET (result-pair)
       (COND ((SETQ result-pair (ASSOC-TEMPLATE ,pair ,alist ,test-form))
	      (CDR result-pair))
	     ((ATOM ,tree) ,tree)
	     (t 
	      (LET ((new-left-subtree (SUBLIS* ,alist (CAR ,tree) . ,args))
		    (new-right-subtree (SUBLIS* ,alist (CDR ,tree) . ,args)))
		(IF (AND (EQL new-left-subtree (CAR ,tree))
			 (EQL new-right-subtree (CDR ,tree)))
		    ,tree
		    (CONS new-left-subtree new-right-subtree)))))))
  )

(Defun SUBLIS* (alist tree &OPTIONAL (test #'EQL) key test-not)
  (COND (key
	 (IF test-not 
	     (SUBLIS-TEMPLATE pair (NOT (FUNCALL test-not (FUNCALL key tree) (CAR pair))) alist tree test key test-not)
	     (SUBLIS-TEMPLATE pair (FUNCALL test (FUNCALL key tree) (CAR pair)) alist tree test key)))
	(test-not (SUBLIS-TEMPLATE pair (NOT (FUNCALL test-not tree (CAR pair))) alist tree test key test-not))
	(t (SUBLIS-TEMPLATE pair (FUNCALL test tree (CAR pair)) alist tree test key))))

(Defun SUBLIS (alist tree &KEY key (test #'EQL) test-not)
  1"Make multiple replacements in TREE, copying structure as needed.
ALIST specifies the replacements; each element's car is something to replace,
and the cdr is what to replace it with.
Each atom or subtree found anywhere in TREE is compared against each
object to be replaced. "*
  (SUBLIS* alist tree test key test-not))

(eval-when (compile) 

  (Defmacro NSUBLIS-TEMPLATE (pair test-form alist tree &REST args)
;1; generate code for subst*
    `(LET (result-pair)
       (COND ((SETQ result-pair (ASSOC-TEMPLATE ,pair ,alist ,test-form))
	      (CDR result-pair))
	     ((ATOM ,tree) ,tree)
	     (t 
	      (LET ((new-left-subtree (NSUBLIS* ,alist (CAR ,tree) . ,args))
		    (new-right-subtree (NSUBLIS* ,alist (CDR ,tree) . ,args)))
		(UNLESS (EQL new-left-subtree (CAR ,tree))
		  (SETF (CAR ,tree) new-left-subtree))
		(UNLESS (EQL new-right-subtree (CDR ,tree))
		  (SETF (CDR ,tree) new-right-subtree))
		,tree)))))
  )

(Defun NSUBLIS* (alist tree &OPTIONAL (test #'EQL) key test-not)
  (COND (key
	 (IF test-not 
	     (NSUBLIS-TEMPLATE pair (NOT (FUNCALL test-not (FUNCALL key tree) (CAR pair))) alist tree test key test-not)
	     (NSUBLIS-TEMPLATE pair (FUNCALL test (FUNCALL key tree) (CAR pair)) alist tree test key)))
	(test-not (NSUBLIS-TEMPLATE pair (NOT (FUNCALL test-not tree (CAR pair))) alist tree test key test-not))
	(t (NSUBLIS-TEMPLATE pair (FUNCALL test tree (CAR pair)) alist tree test key))))

(Defun NSUBLIS (alist tree &KEY key (test #'EQL) test-not)
  1"Structure-modifying version of SUBLIS.  Same as SUBLIS except modifies structure of TREE."*
  (NSUBLIS* alist tree test key test-not))

1;; set functions -- *
;;
;; INTERSECTION could be defined as:
;;(defun intersection (list1 list2 &rest options &key key test test-not)
;;  (remove-if-not #'(lambda (x) (apply #'member x list2 options)) list1))
;;
;; The following optimizes the above and isn't all that slow:

(Defun INTERSECTION* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (REMOVE-IF-NOT #'(LAMBDA (x) (MEMBER* x list2 test key test-not)) (The List list1) :key key))

(Defun INTERSECTION(list1 list2 &KEY (test #'EQL) key  test-not)
  1"Return the intersection of LIST1 and LIST2, regarded as sets, i.e. return the
list of elements common to both sets.
If neither list has duplicate elements, then neither does the value."*
  (INTERSECTION* list1 list2 test key test-not))

(Defun NINTERSECTION* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (DELETE-IF-NOT #'(LAMBDA (x) (MEMBER* x list2 test key test-not)) (The List list1) :key key))

(Defun NINTERSECTION(list1 list2 &KEY key (test #'EQL) test-not)
  1"Return the intersection of LIST1 and LIST2, regarded as sets, i.e. return the
list of elements common to both sets.
If neither list has duplicate elements, then neither does the value.
The first of lists can be destroyed."*
  (NINTERSECTION* list1 list2 test key test-not))

;; SET-DIFFERENCE could be defined as:
;;(defun setdif (list1 list2 &rest options &key key test test-not)
;;  (remove-if #'(lambda (x) (apply #'member x list2 options)) list1))

(Defun SET-DIFFERENCE* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (REMOVE-IF #'(LAMBDA (x) (MEMBER* x list2 test key test-not)) (The List list1) :key key))

(Defun SET-DIFFERENCE(list1 list2 &KEY key (test #'EQL) test-not)
  1"Create a list consisting all of items in LIST1 not appearing in LIST2."*
  (SET-DIFFERENCE* list1 list2 test key test-not))

(Defun NSET-DIFFERENCE* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (DELETE-IF #'(LAMBDA (x) (MEMBER* x list2 test key test-not)) (The List list1) :key key))

(Defun NSET-DIFFERENCE (list1 list2 &key  key (test #'EQL) test-not)
  1"Remove from LIST1 every item it has in common with LIST2.  LIST1 may be destroyed."*
  (NSET-DIFFERENCE* list1 list2 test key test-not))


;; UNION could be defined as:
;;  (defun uni (list1 list2 &rest options &key key test test-not)
;;   (nconc (apply #'setdif list1 list2 options) list2))

(Defmacro UNION-TEMPLATE (pred)
  `(DO* ((x list1 (CDR x))
	 (new-list nil)
	 (loc (LOCF new-list )))
	((ATOM x)
	 (RPLACD loc list2)
	 new-list)
     (UNLESS ,pred
       (RPLACD loc (SETQ loc (CONS (CAR x) nil))))))

;;  5/05/89 DNG - Add special case for :TEST #EQ, which makes it twice as 
;;		fast.  This is used a lot by both Flavors and TICLOS.
(Defun UNION* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (IF (NULL list2)
      list1
    (IF key
	(UNION-TEMPLATE (MEMBER* (FUNCALL key (CAR x)) list2 test key test-not))
      (if (eq test #'eq)
	  (UNION-TEMPLATE (ZLC:MEMQ (CAR x) list2))
	(UNION-TEMPLATE (MEMBER* (CAR x) list2 test key test-not))))))

(Defun UNION (list1 list2 &KEY key (test #'EQL) test-not)
  1"Create and return the union of LIST1 and LIST2, regarded as sets, i.e. return the
list of elements contained in either set.
If neither list has duplicate elements, then neither does the value."*
  (UNION* list1 list2 test key test-not))

(Defmacro NUNION-TEMPLATE (pred)
  `(DO* ((x list1 (CDR x))
	 (result (LOCF list1))
	 (next-splice result))
	((ATOM x) 
	 (RPLACD next-splice list2)
	 (CDR result))
     (IF ,pred
	 (RPLACD next-splice (CDR x))
	 (SETQ next-splice (CDR next-splice)))))

(Defun NUNION* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (IF (NULL list2)
      list1
      (IF key
	  (NUNION-TEMPLATE (MEMBER* (FUNCALL key (CAR x)) list2 test key test-not))
	  (NUNION-TEMPLATE (MEMBER* (CAR x) list2 test key test-not)))))

(Defun NUNION (list1 list2 &KEY key (test #'EQL) test-not)
  1"Return the union of LIST1 and LIST2, regarded as sets, i.e. return the
list of elements contained in either set.
If neither list has duplicate elements, then neither does the value.
Both lists can be destroyed."*
  (NUNION* list1 list2 test key test-not))

;; in this one, a copy of one of the lists must be made since the list arguments can be
;; mutilated (consider common elements)
(Defun NSET-EXCLUSIVE-OR* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (NCONC 
    (DELETE-IF #'(LAMBDA (x) (MEMBER* x list2 test key test-not)) (The List (COPY-LIST list1)) :key key)
    (DELETE-IF #'(LAMBDA (x) (MEMBER* x list1
				      ;; must reverse arguments
				      #'(lambda (x y) (funcall test y x))
				      key test-not)) (The List list2) :key key)))

(Defun NSET-EXCLUSIVE-OR (list1 list2 &KEY key (test #'EQL) test-not)
 "Return a list consisting of elements in LIST1 and not in LIST2 plus those in LIST2
and not in LIST1.  Both arguments lists may be destroyed."
  (NSET-EXCLUSIVE-OR* list1 list2 test key test-not))

;;;(Defun SET-EXCLUSIVE-OR* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
;;;  (NCONC 
;;;    (REMOVE-IF #'(LAMBDA (x) (MEMBER* x list2 test key test-not)) (The List list1) :key key)
;;;    (REMOVE-IF #'(LAMBDA (x) (MEMBER* x list1
;;;				      ;; must reverse arguments
;;;				      #'(lambda (x y) (funcall test y x))
;;;				      key test-not)) (The List list2) :key key)))

(Defun SET-EXCLUSIVE-OR* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (let ((first-seq (REMOVE-IF #'(LAMBDA (x) (MEMBER* x list2 test key test-not)) (The List list1) :key key))
	(second-seq (REMOVE-IF #'(LAMBDA (x) (MEMBER* x list1
				      ;; must reverse arguments
				      #'(lambda (x y) (funcall test y x))
				      key test-not)) (The List list2) :key key)))
    (if (eq first-seq list1)
	(append first-seq second-seq)
	(nconc first-seq second-seq))))

(Defun SET-EXCLUSIVE-OR (list1 list2 &KEY key (test #'EQL) test-not)
  "Create and return a list consisting of elements in LIST1 and not in LIST2 plus those in LIST2
and not in LIST1."
  (SET-EXCLUSIVE-OR* list1 list2 test key test-not))


;; subsetp could be defined as
;; (defun sub (list1 list2 &rest options &key key test test-not)
;;  (every #'(lambda (x) (apply #'member x list2 options)) list1))

(Defun SUBSETP* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (DOLIST (x list1 t)
    (UNLESS (MEMBER* x list2 test key test-not)
      (RETURN nil))))

(Defun SUBSETP (list1 list2 &KEY key (test #'EQL) test-not)
  "T if every element of LIST1 matches some element of LIST2."
  (SUBSETP* list1 list2 test key test-not))
 

;;;PHD 3/10/87 Lisp definition of these functions (they used to be microcoded).

(defun nth-safe (n l)
  (let ((i 0))
    (loop
      (cond
	((atom l) (return nil))
	((= i n) (return (car l)))
	(t (setf l (cdr l)
		 i (1+ i)))))))

(defun nthcdr-safe (n l)
  (let ((i 0))
    (loop
      (cond
	((= i n) (return l))
	((atom l) (return nil))
	(t (setf l (cdr l)
		 i (1+ i)))))))