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.*

;;; NOTES:

;;   1) For each generic sequence function, there is a * version which takes
;;      all arguments positionally and there are -LIST and -VECTOR versions
;;      FOR USE BY THE COMPILER when the type of sequence is known at compile
;;      time. Thus there is DELETE*, DELETE-LIST and DELETE-VECTOR.
 
;;   2) The notations LR and RL denote Left-to-Right and Right-to-Left respectively.

;;   3) FIND returns two values, the item found and its position. It is
;;      possibly an error that FIND did not return position since searching
;;      a sequence for nil will not return a definitive answer.

;;   4) Non-destructive generic functions postpone consing until it is required.
;;      [except when the sequence is a list, :from-end is t and :count is non-nil -- in this case
;;      a new list is created and is possibly EQUAL to the original.] Thus if
;;      no item satisfies the test, the resultant sequence is usually EQ to the 
;;      original sequence.

;;   5) We use ATOM instead of ENDP to test for the end of a loop since it often
;;      happens on the Lispm that lists terminate with a dotted pair.

;;   6) DEUS EX MACHINA: to construct a list of items a1,... aN (computed according
;;      to some recipe) in a left-to-right fashion:
;;        (let* ((new-list nil)
;;               (loc  (locf new-list)))   ;; or loc <- (cons nil nil) and return (cdr loc)
;;            loop 
;;               aI <- some computation
;;               (rplacd loc (setq loc (cons aI nil))))
;;          new-list)
;;      Initially loc is a locative to new-list so the after the first time the RPLACD is executed,
;;      new-list will point to (a1) as will loc. The next time, new-list will point to
;;      (a1 a2) and loc to (a2) , etc.

;;   n) the Spice implementation influenced ours.




(Defun COPY-ARRAY-BELOW-INDEX (array index len)
;1; make a new vector of length <len> and copy the contents of <array> from 0 to <index>-1*
  (LET ((new-vector (INTERNAL-MAKE-VECTOR len (ARRAY-TYPE array))))
    (COPY-ARRAY-PORTION array 0 index new-vector 0 index)
    new-vector))

(Defun COPY-LIST-BELOW-INDEX (list index new-list-location)
1;; given a list and a pointer to a new list, this procedure copies the first <index> 
;; conses of <list> into new-list-location which is returned updated.*
  (DO ((i 0 (1+ i))
       (z list (cdr z)))
      ((OR (= i index) (ATOM z)) new-list-location)
    (RPLACD new-list-location (SETQ new-list-location (CONS (CAR z) nil)))))

1;;;;; DELETE , DELETE-IF , DELETE-IF-NOT*

;1; the Left-to-Right method for list deletion*
(eval-when (compile)
  (Defmacro WITH-DELETE-LIST-LR-BINDINGS(&BODY body)
1;; the first item of the list to be tested is (cadr traversing-cons)*

    `(LET* ((starter-list (LOCF list))
	    (traversing-cons (NTHCDR start starter-list)))  
       (PROGN . ,body)
       (CDR starter-list)))    ;; the value returned by DELETE[-IF|-IF-NOT]-LIST-LR-MACRO

  (Defmacro DELETE-LIST-LR-BODY(loopvar pred)
1;; generate code to search portion of list between <start> (inclusive) and <end> (exclusive).
;; exit when either <count> drops to 0 or <loopcnt> reaches <end>. Note there is no need to test
;; for the end of the list since <end> is always <= length of list.*

    `(DO ((,loopvar (CDR traversing-cons) (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt end))
       (COND (,pred
	      (RPLACD traversing-cons (CDR ,loopvar))
	      (WHEN (ZEROP (DECF count)) (RETURN)))
	     (T (SETQ traversing-cons ,loopvar)))))

  (Defmacro DELETE-LIST-LR-MACRO ()
    `(WITH-DELETE-LIST-LR-BINDINGS
       (COND (key
	      (IF test-not 
		  (DELETE-LIST-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
		  (DELETE-LIST-LR-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
	     (test-not (DELETE-LIST-LR-BODY z (NOT (FUNCALL test-not item (CAR z)))))
	     (t (DELETE-LIST-LR-BODY z (FUNCALL test item (CAR z)))))))

  (Defmacro DELETE-IF-LIST-LR-MACRO ()
    `(WITH-DELETE-LIST-LR-BINDINGS
       (IF key (DELETE-LIST-LR-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
	   (DELETE-LIST-LR-BODY z (FUNCALL pred (CAR z))))))

  (Defmacro DELETE-IF-NOT-LIST-LR-MACRO ()
    `(WITH-DELETE-LIST-LR-BINDINGS
       (IF key (DELETE-LIST-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
	   (DELETE-LIST-LR-BODY z (NOT (FUNCALL pred (CAR z)))))))
)

;1; the Right-to-Left method for list deletion involves transforming the*
;1; original call to one involving the Left-to-Right method by reversing the*
;1; list. Thus DELETE-List could be written*
;1;*
;;(Defun DELETE-LIST (item list &OPTIONAL test count key test-not start end from-end)
;;  (WITH-DELETE-LIST-BINDINGS
;;    (IF (AND from-end (plusp count)) 
;;	(NREVERSE-LIST
;;	  (DELETE-LIST item (NREVERSE-list list) key test test-not (- len end) (- len start) count))
;;	(DELETE-LIST-LR-MACRO))))
;1;*
;1; Now use standard recursion removal techniques to get rid of the recursive call to*
;1; DELETE-LIST*

(eval-when (compile)
  (Defmacro WITH-DELETE-LIST-BINDINGS (&BODY body)
    `(LET* ((start (IF start (MAX 0 start) 0))
	    (len   (LENGTH list))
	    (end   (IF end (MIN end len) len))
	    (count (OR count -1)))
       (IF (ZEROP count) list . ,body)))
)
  
(Defun DELETE-LIST (item list &OPTIONAL (test #'EQL) count key test-not start end from-end)
;1; the method for DELETE with a list argument*
  (LET (from-end-for-real)
    (WITH-DELETE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (NREVERSE-list list) 
	       from-end-for-real t))
      (LET ((result (DELETE-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(Defun DELETE-IF-LIST (pred list &OPTIONAL count key start end from-end)
;1; the method for DELETE-IF with a list argument*
  (LET (from-end-for-real)
    (WITH-DELETE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (NREVERSE-list list) 
	       from-end-for-real t))
      (LET ((result (DELETE-IF-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(Defun DELETE-IF-NOT-LIST (pred list &OPTIONAL count key start end from-end)
;1; the method for DELETE-IF-NOT with a list argument*
  (LET (from-end-for-real)
    (WITH-DELETE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (NREVERSE-list list) 
	       from-end-for-real t))
      (LET ((result (DELETE-IF-NOT-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))


(eval-when (compile)
  (Defmacro WITH-DELETE-VECTOR-BINDINGS (&BODY body)
    `(LET* ((len    (LENGTH vector))
	    (start  (IF start (MAX start 0) 0))
	    (end    (IF end (MIN end len) len))
	    (count  (OR count -1)))
       (IF (ZEROP count) vector . ,body)))

  (Defmacro WITH-DELETE-VECTOR-LR-BINDINGS (&BODY body)
1;; generate code to search portion of vector between <start> (inclusive) and <end> (exclusive).
;; exit when either <count> drops to 0 or <loopcnt> reaches <end>. <shift-index> is initialized
;; to <start> and varies with <start> until some item "satifies the test". From that point on,
;; <shift-index> points to the index of the next entry in vector to be overwritten. The search
;; loop returns the index of the next entry to be scanned. When nothing satisfies the test, we will
;; have <shift-index>=<next-unscanned-index>. Else <shift-index> < <next-unscanned-index>*

    `(LET* ((shift-index start)
	    (next-unscanned-index (PROGN . ,body)))
       (WHEN (< shift-index next-unscanned-index)  ;; if this condition is met, then something has been deleted- shift
	 (DELETE-VECTOR-LR-COPY-FINAL-SEGMENT-AND-TRIM))
       vector))      ;; the value returned by DELETE[-IF|-IF-NOT]-VECTOR-LR-MACRO

  (Defmacro DELETE-VECTOR-LR-BODY (loopvar pred)
    `(DO ((,loopvar start (1+ ,loopvar)))   ;; scan active segment
	 ((>= ,loopvar end) ,loopvar)
       (IF ,pred 
	   (WHEN (ZEROP (DECF count)) (RETURN (1+ ,loopvar)))
	   ;;else item doesn't pass test!  If a move is in progress, then move contents at <loopvar> to <shift-index>
	   (UNLESS (= ,loopvar shift-index)
	     (SETF (AREF vector shift-index) (AREF vector ,loopvar)))
	   (INCF shift-index))))
  
  (Defmacro DELETE-VECTOR-LR-COPY-FINAL-SEGMENT-AND-TRIM ()
    `(DO ((i next-unscanned-index (1+ i)))
	 ((>= i len) 
	  (WHEN (< shift-index len) (ADJUST-VECTOR vector shift-index)))
       (SETF (AREF vector shift-index) (AREF vector i))
       (INCF shift-index)))


  (Defmacro DELETE-VECTOR-LR-MACRO ()
    `(WITH-DELETE-VECTOR-LR-BINDINGS
       (COND (key
	      (If test-not
		  (DELETE-VECTOR-LR-BODY i (NOT (FUNCALL test-not item (FUNCALL key (AREF vector i)))))
		  (DELETE-VECTOR-LR-BODY i (FUNCALL test item (FUNCALL key (AREF vector i))))))
	     (test-not
	      (DELETE-VECTOR-LR-BODY i (NOT (FUNCALL test-not item (AREF vector i)))))
	     (t
	      (DELETE-VECTOR-LR-BODY i (FUNCALL test item (AREF vector i)))))))

  (Defmacro DELETE-IF-VECTOR-LR-MACRO ()
    `(WITH-DELETE-VECTOR-LR-BINDINGS
       (IF key 
	   (DELETE-VECTOR-LR-BODY i (FUNCALL pred (FUNCALL key (AREF vector i))))
	   (DELETE-VECTOR-LR-BODY i (FUNCALL pred (AREF vector i))))))

  (Defmacro DELETE-IF-NOT-VECTOR-LR-MACRO ()
    `(WITH-DELETE-VECTOR-LR-BINDINGS
	  (IF key 
	      (DELETE-VECTOR-LR-BODY i (NOT (FUNCALL pred (FUNCALL key (AREF vector i)))))
	      (DELETE-VECTOR-LR-BODY i (NOT (FUNCALL pred (AREF vector i)))))))
  )

(Defun DELETE-VECTOR (item vector &OPTIONAL (test #'EQL) count key test-not start end from-end)
;1; the method for DELETE with a vector argument*
  (LET (from-end-for-real)
    (WITH-DELETE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (NREVERSE-vector vector) 
	       from-end-for-real t))
      (LET ((result (DELETE-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun DELETE-IF-VECTOR (pred vector &OPTIONAL count key start end from-end)
;1; the method for DELETE-IF with a *VECTOR1 argument*
  (LET (from-end-for-real)
    (WITH-DELETE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       VECTOR (NREVERSE-VECTOR VECTOR) 
	       from-end-for-real t))
      (LET ((result (DELETE-IF-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun DELETE-IF-NOT-VECTOR (pred vector &OPTIONAL count key start end from-end)
;1; the method for DELETE-IF-NOT with a vector argument*
  (LET (from-end-for-real)
    (WITH-DELETE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (NREVERSE-vector vector) 
	       from-end-for-real t))
      (LET ((result (DELETE-IF-NOT-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))



(Defun DELETE-IF* (predicate sequence &OPTIONAL count key start end from-end)
  (IF (ARRAYP sequence)
      (DELETE-IF-VECTOR predicate sequence count key start end from-end)
      (DELETE-IF-LIST predicate sequence count key start end from-end)))

(Defun DELETE-IF (predicate sequence &KEY key start end count from-end)
  1"Return SEQUENCE, destructively modified so that elements satisfying PREDICATE are omitted"*
  (DELETE-IF* predicate sequence count key start end from-end))

(Defun DELETE-IF-NOT* (predicate sequence &OPTIONAL count key start end from-end)
  (IF (ARRAYP sequence)
      (DELETE-IF-NOT-VECTOR  predicate sequence count key start end from-end)
      (DELETE-IF-NOT-LIST predicate sequence count key start end from-end)))

(Defun DELETE-IF-NOT (predicate sequence &KEY key start end count from-end)
  1"Like DELETE-IF but deletes elements which do not satisfy PREDICATE."*
  (DELETE-IF-NOT* predicate sequence count key start end from-end))

(Defun DELETE* (item sequence &OPTIONAL (test #'EQL) count key test-not start end from-end)
  (IF (ARRAYP sequence)
      (DELETE-VECTOR item sequence test count key test-not start end from-end)
      (DELETE-LIST item sequence test count key test-not start end from-end)))

(Defun DELETE (item sequence &KEY key (test #'EQL) test-not start end count from-end)
  1"Return SEQUENCE, destructively modified so that elements matching ITEM are omitted."*
  (DELETE* item sequence test count key test-not start end from-end))


(eval-when (compile)
  (Defmacro WITH-DELETE-LIST-SIMPLE-BINDINGS(&BODY body)
    `(LET* ((starter-list (LOCF list))
	    (traversing-cons starter-list)
	    (count (OR count -1)))
       (unless (ZEROP count) . ,body)
       (CDR starter-list)))
  
  (Defmacro DELETE-LIST-SIMPLE-BODY(loopvar pred)
    `(DO ((,loopvar (CDR traversing-cons) (CDR ,loopvar)))
	 ((ATOM ,loopvar))  ;; use ATOM instead of ENDP in case of dotted-list
       (COND (,pred
	      (RPLACD traversing-cons (CDR ,loopvar))
	      (WHEN (ZEROP (DECF count)) (RETURN)))
	     (T (SETQ traversing-cons ,loopvar)))))
  )

(Defun DELETE-LIST-EQ (item list &OPTIONAL count)
  (WITH-DELETE-LIST-SIMPLE-BINDINGS (DELETE-LIST-SIMPLE-BODY z (EQ (CAR z) item))))

(Defun DELETE-LIST-EQUAL (item list &OPTIONAL count)
  (WITH-DELETE-LIST-SIMPLE-BINDINGS (DELETE-LIST-SIMPLE-BODY z (EQUAL (CAR z) item))))

(Defun DELETE-LIST-EQL (item list &OPTIONAL count)
  (WITH-DELETE-LIST-SIMPLE-BINDINGS (DELETE-LIST-SIMPLE-BODY z (EQL (CAR z) item))))

;; ZETALISP compatibility -- some of the following functions can be DEFF'ed1 later !*

(Defun global:DELQ (ITEM LIST &OPTIONAL (\#TIMES -1))
  1"destructively remove some or all occurrences of ITEM from LIST.
If #TIMES is specified, it is a number saying how many occurrences to remove.
You must do (SETQ FOO (DELQ X FOO)) to make sure FOO changes,
in case the first element of FOO is X."*
  (DELETE-LIST-EQ item list \#times))

(Defun global:DELETE (ITEM LIST &OPTIONAL (\#TIMES -1))
  1"Alter LIST so that elements EQUAL to ITEM are no longer present.
If the third argument is a positive number, only the first that many
elements that are EQUAL to ITEM are eliminated.
The alteration is done by changing cdr pointers."*
  (DELETE-LIST-EQUAL item list \#times))

(Defun global:DEL (PRED ITEM LIST &OPTIONAL (\#TIMES -1))
  1"Alter LIST so that elements matching ITEM using PRED are no longer present.
If the third argument is a positive number,
only the first that many elements that match are eliminated.
The alteration is done by changing cdr pointers.
The args passed to PRED are ITEM followed by the element of LIST."*
  (DELETE-LIST item list pred \#times))

(Defun global:DEL-IF-NOT (PRED LIST)
  1"Destructively remove all elements of LIST that don't satisfy PRED."*
  (DELETE-IF-NOT-LIST pred list))

(Defun global:DEL-IF (PRED LIST)
  1"Destructively remove all elements of LIST that satisfy PRED."*
  (DELETE-IF-LIST pred list))

1;;; REMOVE , REMOVE-IF , REMOVE-IF-NOT*

(eval-when (compile)
1;; in the LR case, search the portion of the list from <start> (inclusive) to <end> (exclusive).
;; When the first item which passes the test is encountered, a new list is created which consists
;; of all elements of the original up to but not including the item. Thereafter, elements not
;; satisfying the test are appended to the rear of the new list. When scanning terminates, either
;; because index reaches <end> or <count> drops to zero, the rest of the original list is appended to
;; the rear of the new one.*

  (Defmacro WITH-REMOVE-LIST-LR-BINDINGS(&BODY body)
    `(LET* ((new-list nil)
	    (loc nil)
	    (rest (PROGN . ,body)))
       (IF loc      ;; use <loc> instead of <new-list> since the latter can be nil
	   (PROGN
	     (WHEN rest (RPLACD loc rest))
	     new-list)
	   list)))
  
  (Defmacro REMOVE-LIST-LR-BODY(loopvar pred)
    `(DO ((,loopvar (NTHCDR start list) (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt end) ,loopvar)    ;; returns the un-scanned portion of <list>
       (COND (,pred
	      (UNLESS loc
		(SETQ loc (COPY-LIST-BELOW-INDEX list loopcnt (LOCF new-list))))
	      (WHEN (ZEROP (DECF count)) (RETURN (CDR ,loopvar))))
	     (T 
	      (WHEN loc (RPLACD loc (SETQ loc (CONS (CAR ,loopvar) nil))))))))
  
  (Defmacro REMOVE-LIST-LR-MACRO ()
    `(WITH-REMOVE-LIST-LR-BINDINGS
       (COND (key
	      (IF test-not 
		  (REMOVE-LIST-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
		  (REMOVE-LIST-LR-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
	     (test-not 
	      (REMOVE-LIST-LR-BODY z (NOT (FUNCALL test-not item (CAR z)))))
	     (t 
	      (REMOVE-LIST-LR-BODY z (FUNCALL test item (CAR z)))))))
  
  (Defmacro REMOVE-IF-LIST-LR-MACRO ()
    `(WITH-REMOVE-LIST-LR-BINDINGS
       (IF key (REMOVE-LIST-LR-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
	   (REMOVE-LIST-LR-BODY z (FUNCALL pred (CAR z))))))
  
  (Defmacro REMOVE-IF-NOT-LIST-LR-MACRO ()
    `(WITH-REMOVE-LIST-LR-BINDINGS
       (IF key (REMOVE-LIST-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
	   (REMOVE-LIST-LR-BODY z (NOT (FUNCALL pred (CAR z)))))))
  )

(eval-when (compile)
  (Defmacro WITH-REMOVE-LIST-BINDINGS (&BODY body)
    `(LET* ((start (IF start (MAX 0 start) 0))
	    (len   (LENGTH list))
	    (end   (IF end (MIN end len) len))
	    (count (OR count -1)))
       (IF (ZEROP count) list . ,body)))
)

(Defun REMOVE-LIST (item list &OPTIONAL (test #'EQL) count key test-not start end from-end)
;1; the method for REMOVE with a list argument*
  (LET (from-end-for-real)
    (WITH-REMOVE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (REVERSE-list list)  ;1; cons a new list*
	       from-end-for-real t))
      (LET ((result (REMOVE-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(Defun REMOVE-IF-LIST (pred list &OPTIONAL count key start end from-end)
;1; the method for REMOVE-IF-LIST with a list argument*
  (LET (from-end-for-real)
    (WITH-REMOVE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (REVERSE-list list)  ;1; cons a new list*
	       from-end-for-real t))
      (LET ((result (REMOVE-IF-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(Defun REMOVE-IF-NOT-LIST (pred list &OPTIONAL count key start end from-end)
;1; the method for REMOVE-IF-NOT-LIST with a list argument*
  (LET (from-end-for-real)
    (WITH-REMOVE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (REVERSE-list list)  ;1; cons a new list*
	       from-end-for-real t))
      (LET ((result (REMOVE-IF-NOT-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(eval-when (compile)
1;; in the LR case, search the portion of the vector from <start> (inclusive) to <end> (exclusive).
;; When the first item which passes the test is encountered, a new vector is created which consists
;; of all elements of the original up to but not including the item. Thereafter, elements not
;; satisfying the test are inserted at <new-vector-index> in the new vector. When scanning terminates, either
;; because index reaches <end> or <count> drops to zero, the rest of the original vector is copied to the
;; new vector starting at <new-vector-index>.*

  (Defmacro WITH-REMOVE-VECTOR-BINDINGS (&BODY body)
    `(LET* ((len    (LENGTH vector))
	    (start  (IF start (MAX start 0) 0))
	    (end    (IF end (MIN end len) len))
	    (count  (OR count -1))
	    (new-vector nil)
	    (new-vector-index nil))
       (IF (ZEROP count) vector . ,body)))

  (Defmacro WITH-REMOVE-VECTOR-LR-BINDINGS (&BODY body)
    `(LET ((vector-index (PROGN . ,body)))
       (WHEN new-vector-index
	 (LET ((new-vector-length (+ new-vector-index (- len vector-index))))
	   (COPY-ARRAY-PORTION vector vector-index len new-vector new-vector-index new-vector-length)
	   (ADJUST-VECTOR new-vector new-vector-length)
	   ))
       (OR new-vector vector)
       ))
  
  (Defmacro REMOVE-VECTOR-LR-BODY (loopvar pred)
    `(DO ((,loopvar start (1+ ,loopvar)))
	 ((>= ,loopvar end) ,loopvar)    ;;return latest value of loopvar
       (COND (,pred 
	      (UNLESS new-vector
		(SETQ new-vector (COPY-ARRAY-BELOW-INDEX vector ,loopvar (1- len))
		      new-vector-index ,loopvar))
	      (WHEN (ZEROP (DECF count)) (RETURN (1+ ,loopvar))))
	     (T
	      (WHEN new-vector
		(SETF (AREF new-vector new-vector-index) (AREF vector ,loopvar))
		(INCF new-vector-index))))))

  (Defmacro REMOVE-VECTOR-LR-MACRO ()
    `(WITH-REMOVE-VECTOR-LR-BINDINGS
	  (COND (key
		 (If test-not
		     (REMOVE-VECTOR-LR-BODY i (NOT (FUNCALL test-not item (FUNCALL key (AREF vector i)))))
		     (REMOVE-VECTOR-LR-BODY i (FUNCALL test item (FUNCALL key (AREF vector i))))))
		(test-not
		 (REMOVE-VECTOR-LR-BODY i (NOT (FUNCALL test-not item (AREF vector i)))))
		(t
		 (REMOVE-VECTOR-LR-BODY i (FUNCALL test item (AREF vector i)))))))

  (Defmacro REMOVE-IF-VECTOR-LR-MACRO ()
    `(WITH-REMOVE-VECTOR-LR-BINDINGS
	  (IF key 
	      (REMOVE-VECTOR-LR-BODY i (FUNCALL pred (FUNCALL key (AREF vector i))))
	      (REMOVE-VECTOR-LR-BODY i (FUNCALL pred (AREF vector i))))))

  (Defmacro REMOVE-IF-NOT-VECTOR-LR-MACRO ()
    `(WITH-REMOVE-VECTOR-LR-BINDINGS
	  (IF key 
	      (REMOVE-VECTOR-LR-BODY i (NOT (FUNCALL pred (FUNCALL key (AREF vector i)))))
	      (REMOVE-VECTOR-LR-BODY i (NOT (FUNCALL pred (AREF vector i)))))))

)

(Defun REMOVE-VECTOR (item vector &OPTIONAL (test #'EQL) count key test-not start end from-end)
;1; the method for REMOVE with a vector argument*
  (LET (from-end-for-real)
    (WITH-REMOVE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (REVERSE-vector vector)  ;1; cons a new vector*
	       from-end-for-real t))
      (LET ((result (REMOVE-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun REMOVE-IF-VECTOR (pred vector &OPTIONAL count key start end from-end)
;1; the method for REMOVE-IF-VECTOR with a vector argument*
  (LET (from-end-for-real)
    (WITH-REMOVE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (REVERSE-vector vector)  ;1; cons a new vector*
	       from-end-for-real t))
      (LET ((result (REMOVE-IF-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun REMOVE-IF-NOT-VECTOR (pred vector &OPTIONAL count key start end from-end)
;1; the method for REMOVE-IF-NOT-VECTOR with a vector argument*
  (LET (from-end-for-real)
    (WITH-REMOVE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (REVERSE-vector vector)  ;1; cons a new vector*
	       from-end-for-real t))
      (LET ((result (REMOVE-IF-NOT-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))


(Defun REMOVE-IF* (predicate sequence &OPTIONAL count key start end from-end)
  (IF (ARRAYP sequence)
      (REMOVE-IF-VECTOR predicate sequence count key start end from-end)
      (REMOVE-IF-LIST predicate sequence count key start end from-end)))

(Defun REMOVE-IF (predicate sequence &KEY key start end count from-end)
1  "Remove items in <sequence> satisfying <predicate>, copying structure
as necessary to avoid modifying <sequence>."*
  (REMOVE-IF* predicate sequence count key start end from-end))

(Defun REMOVE-IF-NOT* (predicate sequence &OPTIONAL count key start end from-end)
  (IF (ARRAYP sequence)
      (REMOVE-IF-NOT-VECTOR  predicate sequence count key start end from-end)
      (REMOVE-IF-NOT-LIST predicate sequence count key start end from-end)))

(Defun REMOVE-IF-NOT (predicate sequence &KEY key start end count from-end)
1  "Remove items in <sequence> not satisfying <predicate>, copying structure
as necessary to avoid modifying <sequence>."*
  (REMOVE-IF-NOT* predicate sequence count key start end from-end))

(Defun REMOVE* (item sequence &OPTIONAL (test #'EQL) count key test-not start end from-end)
  (IF (ARRAYP sequence)
      (REMOVE-VECTOR item sequence test count key test-not start end from-end)
      (REMOVE-LIST item sequence test count key test-not start end from-end)))

(Defun REMOVE (item sequence &KEY key (test #'EQL) test-not start end count from-end)
1  "Remove items in <sequence> that match <item>, copying structure
as necessary to avoid modifying <sequence>."*
  (REMOVE* item sequence test count key test-not start end from-end))


(eval-when (compile)
  (Defmacro WITH-REMLIST-SIMPLE-BINDINGS(&BODY body)
    `(LET* ((result nil)
	    (loc nil)
	    (count (OR count -1))
	    (rest (UNLESS (ZEROP count) . ,body)))
       (IF loc 
	   (PROGN 
	     (RPLACD loc rest)
	     result)
	   list)))
  
  (Defmacro REMLIST-SIMPLE-BODY(loopvar pred)
    `(DO ((,loopvar list (CDR ,loopvar))
	  (loopcnt 0 (1+ loopcnt)))
	 ((ATOM ,loopvar) ,loopvar)
       (COND (,pred
	      (UNLESS loc
		(SETQ loc (COPY-LIST-BELOW-INDEX list loopcnt (LOCF result))))
	      (WHEN (ZEROP (DECF count)) (RETURN (CDR ,loopvar))))
	     (T 
	      (WHEN loc
		(RPLACD loc (SETQ loc (CONS (CAR ,loopvar) nil))))))))
  )

(Defun REMOVE-LIST-EQ (item list &OPTIONAL count)
  (WITH-REMLIST-SIMPLE-BINDINGS (REMLIST-SIMPLE-BODY z (EQ item (CAR z)))))

(Defun REMOVE-LIST-EQUAL (item list &OPTIONAL count)
  (WITH-REMLIST-SIMPLE-BINDINGS (REMLIST-SIMPLE-BODY z (EQUAL item (CAR z)))))

(Defun REMOVE-LIST-EQL (item list &OPTIONAL count)
  (WITH-REMLIST-SIMPLE-BINDINGS (REMLIST-SIMPLE-BODY z (EQL item (CAR z)))))

1;; zetalisp compatibility -- note rem-if and rem-if-not are not like their del-if and del-if-not counterparts*

;This copies only as much as it needs to in order to avoid bashing the original list
(Defun global:REM (PRED ITEM LIST &OPTIONAL (TIMES -1))
  1"Return a list like LIST except that elements matching ITEM using PRED are missing.
TIMES controls how many such elements are missing;
after that many have been eliminated, the rest are left alone.
The arguments passed to PRED are ITEM followed by the element of LIST."*
  (REMOVE-LIST item list pred times))

;This copies only as much as it needs to in order to avoid bashing the original list
(Defun global:REMQ (ITEM LIST &OPTIONAL (TIMES -1))
  1"Return a list like LIST except that elements EQ to ITEM are missing.
TIMES controls how many such elements are missing;
after that many have been eliminated, the rest are left alone."*
  (REMOVE-LIST-EQ item list times))

;This copies only as much as it needs to in order to avoid bashing the original list
(DEFUN global:REMOVE (ITEM LIST &OPTIONAL (TIMES -1))
  1"Return a list like LIST except that elements EQUAL to ITEM are missing.
TIMES controls how many such elements are missing;
after that many have been eliminated, the rest are left alone."*
  (REMOVE-LIST-EQ item list times))

1;;; DELETE-DUPLICATES *
(eval-when (compile)					  

  (Defmacro WITH-DELDUP-LIST-BINDINGS (&BODY body)
    `(LET* ((start (IF start (MAX 0 start) 0))
	    (len   (LENGTH list))
	    (end   (IF end (MIN end len) len)))
       (PROGN . ,body)))

1;; in LR procesing, the list is scanned from <start> (inclusive) to <end> (exclusive). For
;; each pass through the loop, the loop variable has the form (item . rest) where <rest>
;; denotes the rest of the list and <item> the current item to be tested. If (MEMBER <item> <rest>),
;; then the first <item> is deleted from the list.*

  (Defmacro WITH-DELDUP-LIST-LR-BINDINGS(&BODY body)
    `(LET* ((starter-list (LOCF list))
	    (traversing-cons (NTHCDR start starter-list)))
       (PROGN . ,body)
       (CDR starter-list)))
  
  (Defmacro DELDUP-LIST-LR-BODY(loopvar inloopvar pred)
    `(DO ((,loopvar (CDR traversing-cons) (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt (1- end)))
       (COND 
	 ((DO ((,inloopvar (CDR ,loopvar) (CDR ,inloopvar))
	       (inloopcnt  (1+ loopcnt)   (1+ inloopcnt)))
	      ((>= inloopcnt end) nil)
	    (WHEN ,pred (RETURN t)))
	  (RPLACD traversing-cons (CDR ,loopvar)))
	 (T (SETQ traversing-cons ,loopvar)))))

  (Defmacro DELETE-DUPLICATES-LIST-LR-MACRO ()
    `(WITH-DELDUP-LIST-LR-BINDINGS
       (COND (key
	      (IF test-not 
		  (DELDUP-LIST-LR-BODY z u 
				       (NOT (FUNCALL test-not 
						     (FUNCALL key (CAR z))
						     (FUNCALL key (CAR u)))))
		  (DELDUP-LIST-LR-BODY z u
				       (FUNCALL test 
						(FUNCALL key (CAR z))
						(FUNCALL key (CAR u))))))

	     (test-not 
	      (DELDUP-LIST-LR-BODY z u (NOT (FUNCALL test-not (CAR z) (CAR u)))))
	     (t 
	      (DELDUP-LIST-LR-BODY z u (FUNCALL test (CAR z) (CAR u)))))))
)

(Defun DELETE-DUPLICATES-LIST (list &OPTIONAL (test #'EQL) key test-not start end from-end)
;1; the method for DELETE-DUPLICATES with a list argument*
  (LET (from-end-for-real)
    (WITH-DELDUP-LIST-BINDINGS
      (WHEN from-end
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (NREVERSE-list list) 
	       from-end-for-real t))
      (LET ((result (DELETE-DUPLICATES-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(eval-when (compile)
  (Defmacro WITH-DELDUP-VECTOR-BINDINGS (&BODY body)
    `(LET* ((len    (LENGTH vector))
	    (start  (IF start (MAX start 0) 0))
	    (end    (IF end (MIN end len) len)))
       (PROGN . ,body)))
  
1;; in LR procesing, the vector is scanned from <start> (inclusive) to <end> (exclusive). Introduce
;; an index named <shift-index> which varies with the loop index i until ,for some i , vector[i]
;; appears in vector[i+1,...end-1]. From this point on, <shift-index> points to the index of the next 
;; entry in vector to be overwritten. The search loop exits when i reaches <end>. If <shift-index> =
;; <end> nothing has been deleted. Otherwise it is necessary to shift any remaining entries down starting
;; at <shift-index>.*
  
  (Defmacro WITH-DELDUP-VECTOR-LR-BINDINGS (&BODY body)
    `(LET ((shift-index start))
       (PROGN . ,body)
       (WHEN (< shift-index end)  ;; if this condition is met, then something has been deleted- shift
	 (DELDUP-LR-COPY-FINAL-SEGMENT-AND-TRIM))
       vector))
  
  (Defmacro DELDUP-VECTOR-LR-BODY (out-index in-index pred)
    `(DO ((,out-index start (1+ ,out-index)))   ;; scan active segment
	 ((>= ,out-index end))
       (UNLESS (DO ((,in-index (1+ ,out-index) (1+ ,in-index)))  ;; the DO is essentially a MEMBER for vectors
		   ((>= ,in-index end) nil)   ;; stay in subsequence boundary
		 (WHEN ,pred (RETURN t)))
	 (UNLESS (= ,out-index shift-index)
	   (SETF (AREF vector shift-index) (AREF vector ,out-index)))
	 (INCF shift-index))))
  
  (Defmacro DELDUP-LR-COPY-FINAL-SEGMENT-AND-TRIM ()
    `(DO ((i end (1+ i)))
	 ((>= i len) 
	  (WHEN (< shift-index len) (ADJUST-VECTOR vector shift-index)))
       (SETF (AREF vector shift-index) (AREF vector i))
       (INCF shift-index)))

  (Defmacro DELETE-DUPLICATES-VECTOR-LR-MACRO()
    `(WITH-DELDUP-VECTOR-LR-BINDINGS 
	  (COND (key
		 (If test-not
		     (DELDUP-VECTOR-LR-BODY m n 
				     (NOT (FUNCALL test-not
						   (FUNCALL key (AREF vector m))
						   (FUNCALL key (AREF vector n)))))
		     (DELDUP-VECTOR-LR-BODY m n 
				       (FUNCALL test 
						(FUNCALL key (AREF vector m)) 
						(FUNCALL key (AREF vector n))))))
		(test-not
		 (DELDUP-VECTOR-LR-BODY m n (NOT (FUNCALL test-not (AREF vector m) (AREF vector n)))))
		(t
		 (DELDUP-VECTOR-LR-BODY m n
				   (FUNCALL test (AREF vector m) (AREF vector n)))))))
  )

(Defun DELETE-DUPLICATES-VECTOR (vector &OPTIONAL test key test-not start end from-end)
;1; the method for DELETE-DUPLICATES with a vector argument*
  (LET (from-end-for-real)
    (WITH-DELDUP-VECTOR-BINDINGS
      (WHEN from-end
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (NREVERSE-vector vector) 
	       from-end-for-real t))
      (LET ((result (DELETE-DUPLICATES-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))


(Defun DELETE-DUPLICATES* (sequence &OPTIONAL (test #'EQL) key test-not start end from-end)
  (IF (ARRAYP sequence)
      (DELETE-DUPLICATES-VECTOR sequence test key test-not start end from-end)
      (DELETE-DUPLICATES-LIST sequence test key test-not start end from-end)))

(Defun DELETE-DUPLICATES (sequence &KEY key (test #'EQL) test-not start end from-end)
  1"Return SEQUENCE, destructively modified by removing duplicate items"*
  (DELETE-DUPLICATES* sequence test key test-not start end from-end))

1;; REMOVE-DUPLICATES *
(eval-when (compile)					  
  (Defmacro WITH-REMDUP-LIST-BINDINGS (&BODY body)
    `(LET* ((start (IF start (MAX 0 start) 0))
	    (len   (LENGTH list))
	    (end   (IF end (MIN end len) len)))
       (PROGN . ,body)))
;; LR processing is similar to REMOVE

  (Defmacro WITH-REMDUP-LIST-LR-BINDINGS(&BODY body)
    `(LET* ((new-list nil)(loc nil)(rest (PROGN . ,body)))
       (IF loc
	   (PROGN
	     (WHEN rest (RPLACD loc rest))
	     new-list)
	   list)))
  
  (Defmacro REMDUP-LIST-LR-BODY(loopvar inloopvar pred)
    `(DO ((,loopvar (NTHCDR start list) (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt (1- end)) ,loopvar)  ;; return whatever is left of the list
       (COND ((DO ((,inloopvar (CDR ,loopvar) (CDR ,inloopvar))
		   (inloopcnt  (1+ loopcnt)   (1+ inloopcnt)))
		  ((>= inloopcnt end) nil)
		(WHEN ,pred (RETURN t)))
	      (UNLESS loc
		(SETQ loc (COPY-LIST-BELOW-INDEX list loopcnt (LOCF new-list)))))
	     (T (WHEN loc (RPLACD loc (SETQ loc (CONS (CAR ,loopvar) nil))))))))
  
  (Defmacro REMOVE-DUPLICATES-LIST-LR-MACRO ()
    `(WITH-REMDUP-LIST-LR-BINDINGS
       (COND (key
	      (IF test-not 
		  (REMDUP-LIST-LR-BODY z u
				       (NOT (FUNCALL test-not 
						     (FUNCALL key (CAR z))
						     (FUNCALL key (CAR u)))))
		  (REMDUP-LIST-LR-BODY z u
				       (FUNCALL test 
						(FUNCALL key (CAR z))
						(FUNCALL key (CAR u))))))
	     (test-not 
	      (REMDUP-LIST-LR-BODY z u (NOT (FUNCALL test-not (CAR z) (CAR u)))))
	     (t 
	      (REMDUP-LIST-LR-BODY z u (FUNCALL test (CAR z) (CAR u)))))))

)

(Defun REMOVE-DUPLICATES-LIST (list &OPTIONAL (test #'EQL) key test-not start end from-end)
;1; the method for REMOVE with a list argument*
  (LET (from-end-for-real)
    (WITH-REMDUP-LIST-BINDINGS
      (WHEN from-end
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (REVERSE-list list)  ;1; cons a new list*
	       from-end-for-real t))
      (LET ((result (REMOVE-DUPLICATES-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))


(eval-when (compile)
  (Defmacro WITH-REMDUP-VECTOR-BINDINGS (&BODY body)
    `(LET* ((len    (LENGTH vector))
	    (start  (IF start (MAX start 0) 0))
	    (end    (IF end (MIN end len) len))
	    (new-vector nil)
	    (new-vector-index nil))
       (PROGN . ,body)))
  
  (Defmacro WITH-REMDUP-VECTOR-LR-BINDINGS (&BODY body)
    `(LET ((vector-index (PROGN . ,body)))
       (WHEN new-vector-index
	 (LET ((new-vector-length (+ new-vector-index (- len vector-index))))
	   (COPY-ARRAY-PORTION vector vector-index len new-vector new-vector-index new-vector-length)
	   (ADJUST-VECTOR new-vector new-vector-length)
	   ))
       (OR new-vector vector)
       ))
  
  (Defmacro REMDUP-VECTOR-LR-BODY (out-index in-index pred)
    `(DO ((,out-index start (1+ ,out-index)))   ;; scan active segment
	 ((>= ,out-index end) ,out-index)
       (COND ((DO ((,in-index (1+ ,out-index) (1+ ,in-index)))   ;; the DO is essentially MEMBER for arrays
		   ((>= ,in-index end) nil)
		 (WHEN ,pred (RETURN t)))

	      (UNLESS new-vector
		(SETQ new-vector (COPY-ARRAY-BELOW-INDEX vector ,out-index (1- len))
		      new-vector-index ,out-index)))
	     (T
	      (WHEN new-vector
		(SETF (AREF new-vector new-vector-index) (AREF vector ,out-index))
		(INCF new-vector-index))))))

  (Defmacro REMOVE-DUPLICATES-VECTOR-LR-MACRO ()
    `(WITH-REMDUP-VECTOR-LR-BINDINGS
	  (COND (key
		 (If test-not
		     (REMDUP-VECTOR-LR-BODY m n 
					    (NOT (FUNCALL test-not
							  (FUNCALL key (AREF vector m))
							  (FUNCALL key (AREF vector n)))))
		     (REMDUP-VECTOR-LR-BODY m n 
					      (FUNCALL test 
						       (FUNCALL key (AREF vector m)) 
						       (FUNCALL key (AREF vector n))))))
		(test-not
		 (REMDUP-VECTOR-LR-BODY m n (NOT (FUNCALL test-not (AREF vector m) (AREF vector n)))))
		(t
		 (REMDUP-VECTOR-LR-BODY m n
					  (FUNCALL test (AREF vector m) (AREF vector n)))))))
  )


(Defun REMOVE-DUPLICATES-VECTOR (vector &OPTIONAL (test #'EQL) key test-not start end from-end)
;1; the method for REMOVE with a vector argument*
  (LET (from-end-for-real)
    (WITH-REMDUP-VECTOR-BINDINGS
      (WHEN from-end
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (REVERSE-vector vector)  ;1; cons a new vector*
	       from-end-for-real t))
      (LET ((result (REMOVE-DUPLICATES-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun REMOVE-DUPLICATES* (sequence &OPTIONAL (test #'EQL) key test-not start end from-end)
  (IF (ARRAYP sequence)
      (REMOVE-DUPLICATES-VECTOR sequence test key test-not start end from-end)
      (REMOVE-DUPLICATES-LIST sequence test key test-not start end from-end)))

;;;PHD Changed documentation string.
(Defun REMOVE-DUPLICATES (sequence &KEY key (test #'EQL) test-not start end from-end)
  2" remove duplicate items from <sequence>,
copying structure as necessary to avoid modifying <sequence>."*
  (REMOVE-DUPLICATES* sequence test key test-not start end from-end))

1;; FIND  FIND-IF and FIND-IF-NOT*

(eval-when (compile)
1;; in LR processing, the leftmost item satisfying the test is returned. The search loop
;; is exited immediately upon finding such an item.*

  (Defmacro WITH-FIND-LIST-BINDINGS (&BODY body)
    `(LET* (thing-found
	    pos
	    (start (IF start (MAX 0 start) 0))
	    (len   (LENGTH list))
	    (end   (IF end (MIN end len) len))
	    (list  (NTHCDR start list)))
       (PROGN . ,body)
       (VALUES thing-found pos)))

  (Defmacro FIND-LIST-LR-BODY (loopvar pred)
    `(DO ((,loopvar list (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt end))
       (WHEN ,pred 
	 (SETQ thing-found (CAR ,loopvar) 
	       pos loopcnt)
	 (RETURN))
       ))
  
  (Defmacro FIND-LIST-LR-MACRO ()
    `(COND (key
	    (IF test-not 
		(Find-LIST-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
		(Find-LIST-LR-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
	   (test-not 
	    (Find-LIST-LR-BODY z (NOT (FUNCALL test-not item (CAR z)))))
	   (t 
	    (Find-LIST-LR-BODY z (FUNCALL test item (CAR z))))))
  
  (Defmacro FIND-IF-LIST-LR-MACRO ()
    `(IF key 
	 (Find-LIST-LR-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
	 (Find-LIST-LR-BODY z (FUNCALL pred (CAR z)))))
  
  (Defmacro FIND-IF-NOT-LIST-LR-MACRO ()
    `(IF key 
	 (Find-LIST-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
	 (Find-LIST-LR-BODY z (NOT (FUNCALL pred (CAR z))))))
  )

(eval-when (compile)
;; in RL processing, the rightmost item satisfying the test is sought. The list, however,
;; is searched left-to-right and instead of exiting when finding the item, we simply record
;; the item and its position. The values returned then correspond to the rightmost such item
;; in the list.

  (Defmacro FIND-LIST-RL-BODY (loopvar pred)
    `(DO ((,loopvar list (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt end))
       (WHEN ,pred 
	 (SETQ thing-found (CAR ,loopvar)
	       pos loopcnt) 
	 )))

  (Defmacro FIND-LIST-RL-MACRO ()
    `(COND (key
	    (IF test-not 
		(Find-LIST-RL-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
		(Find-LIST-RL-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
	   (test-not 
	    (Find-LIST-RL-BODY z (NOT (FUNCALL test-not item (CAR z)))))
	   (t
	    (Find-LIST-RL-BODY z (FUNCALL test item (CAR z))))))
  
  (Defmacro FIND-IF-LIST-RL-MACRO ()
    `(IF key 
	 (Find-LIST-RL-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
	 (Find-LIST-RL-BODY z (FUNCALL pred (CAR z)))))
  
  (Defmacro FIND-IF-NOT-LIST-RL-MACRO ()
    `(IF key 
	 (Find-LIST-RL-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
	 (Find-LIST-RL-BODY z (NOT (FUNCALL pred (CAR z))))))
  )

(Defun FIND-LIST (item list &OPTIONAL (test #'EQL) key test-not start end from-end)
  (WITH-Find-LIST-BINDINGS
    (IF from-end (FIND-LIST-RL-MACRO) (FIND-LIST-LR-MACRO))))

(Defun FIND-IF-LIST (pred list &OPTIONAL key start end from-end)
  (WITH-FIND-LIST-BINDINGS
    (IF from-end (FIND-IF-LIST-RL-MACRO) (FIND-IF-LIST-LR-MACRO))))

(Defun FIND-IF-NOT-LIST (pred list &OPTIONAL key start end from-end)
  (WITH-FIND-LIST-BINDINGS
    (IF from-end (FIND-IF-NOT-LIST-RL-MACRO)(FIND-IF-NOT-LIST-LR-MACRO))))


(eval-when (compile)
  (Defmacro WITH-FIND-VECTOR-BINDINGS (&BODY body)
    `(LET* (thing-found
	    pos
	    (start (IF start (MAX 0 start) 0))
	    (len   (LENGTH vector))
	    (end   (IF end (MIN end len) len)))
       (PROGN . ,body)
       (VALUES thing-found pos)))
  
  (Defmacro FIND-VECTOR-LR-BODY (loopvar pred)
    `(DO ((,loopvar start (1+ ,loopvar)))
	 ((>= ,loopvar end))
       (WHEN ,pred 
	 (SETQ thing-found (AREF vector ,loopvar)
	       pos ,loopvar) 
	 (RETURN))
	 ))
  
  (Defmacro FIND-VECTOR-LR-MACRO ()
    `(COND (key
	    (IF test-not 
		(FIND-VECTOR-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (AREF vector Z)))))
		(FIND-VECTOR-LR-BODY z (FUNCALL test item (FUNCALL key (AREF vector Z))))))
	   (test-not 
	    (FIND-VECTOR-LR-BODY z (NOT (FUNCALL test-not item (AREF vector Z)))))
	   (t 
	    (FIND-VECTOR-LR-BODY z (FUNCALL test item (AREF vector Z))))))
  
  (Defmacro FIND-IF-VECTOR-LR-MACRO ()
    `(IF key 
	 (FIND-VECTOR-LR-BODY z (FUNCALL pred (FUNCALL key (AREF vector Z))))
	 (FIND-VECTOR-LR-BODY z (FUNCALL pred (AREF vector Z)))))
  
  (Defmacro FIND-IF-NOT-VECTOR-LR-MACRO ()
    `(IF key 
	 (FIND-VECTOR-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (AREF vector Z)))))
	 (FIND-VECTOR-LR-BODY z (NOT (FUNCALL pred (AREF vector Z))))))
  )

(eval-when(compile)

  (Defmacro FIND-VECTOR-RL-BODY (loopvar pred)
    `(DO ((,loopvar (1- end) (1- ,loopvar)))
	 ((< ,loopvar start))
       (WHEN ,pred 
	 (SETQ thing-found (aref vector ,loopvar)
	       pos ,loopvar)
	 (RETURN))
       ))
  
  (Defmacro FIND-VECTOR-RL-MACRO ()
    `(COND (key
	    (IF test-not 
		(FIND-VECTOR-RL-BODY z (NOT (FUNCALL test-not item (FUNCALL key (AREF vector Z)))))
		(FIND-VECTOR-RL-BODY z (FUNCALL test item (FUNCALL key (AREF vector Z))))))
	   (test-not 
	    (FIND-VECTOR-RL-BODY z (NOT (FUNCALL test-not item (AREF vector Z)))))
	   (t
	    (FIND-VECTOR-RL-BODY z (FUNCALL test item (AREF vector Z))))))
  
  (Defmacro FIND-IF-VECTOR-RL-MACRO ()
    `(IF key 
	 (FIND-VECTOR-RL-BODY z (FUNCALL pred (FUNCALL key (AREF vector Z))))
	 (FIND-VECTOR-RL-BODY z (FUNCALL pred (AREF vector Z)))))
  
  (Defmacro FIND-IF-NOT-VECTOR-RL-MACRO ()
    `(IF key 
	 (FIND-VECTOR-RL-BODY z (NOT (FUNCALL pred (FUNCALL key (AREF vector Z)))))
	 (FIND-VECTOR-RL-BODY z (NOT (FUNCALL pred (AREF vector Z))))))
  )


(Defun FIND-VECTOR (item vector &OPTIONAL (test #'EQL) key test-not start end from-end)
  (WITH-Find-VECTOR-BINDINGS
    (IF from-end 
	(FIND-VECTOR-RL-MACRO)
	(FIND-VECTOR-LR-MACRO))))

(Defun FIND-IF-VECTOR (pred vector &OPTIONAL key start end from-end)
  (WITH-FIND-VECTOR-BINDINGS
    (IF from-end 
	(FIND-IF-VECTOR-RL-MACRO)
	(FIND-IF-VECTOR-LR-MACRO))))

(Defun FIND-IF-NOT-VECTOR (pred vector &OPTIONAL key start end from-end)
  (WITH-FIND-VECTOR-BINDINGS
    (IF from-end 
	(FIND-IF-NOT-VECTOR-RL-MACRO)
	(FIND-IF-NOT-VECTOR-LR-MACRO))))

(Defun FIND* (item sequence &OPTIONAL (test #'EQL) key test-not start end from-end)
  (IF (ARRAYP sequence)
      (FIND-VECTOR item sequence test key test-not start end from-end)
      (FIND-LIST item sequence test key test-not start end from-end)))

(Defun FIND (item sequence &KEY key (test #'EQL) test-not start end from-end)
  "Return first element of SEQUENCE that matches ITEM. Also returns the position
 of the item."
  (FIND* item sequence test key test-not start end from-end))

(Defun FIND-IF* (predicate sequence &OPTIONAL key start end from-end)
  (IF (ARRAYP sequence)
      (FIND-IF-VECTOR predicate sequence key start end from-end)
      (FIND-IF-LIST predicate sequence key start end from-end)))

(Defun FIND-IF (predicate sequence &KEY key start end from-end)
  "Return the first element of SEQUENCE that satisfies PREDICATE"
  (FIND-IF* predicate sequence key start end from-end))

(Defun FIND-IF-NOT* (predicate sequence &OPTIONAL key start end from-end)
  (IF (ARRAYP sequence)
      (FIND-IF-NOT-VECTOR predicate sequence key start end from-end)
      (FIND-IF-NOT-LIST predicate sequence key start end from-end)))

(Defun FIND-IF-NOT (predicate sequence &KEY key start end from-end)
  "Return the first element of SEQUENCE that doesn't satisfy PREDICATE"
  (FIND-IF-NOT* predicate sequence key start end from-end))

1;; POSITION*

(Defun POSITION* (item sequence &OPTIONAL (test #'EQL) key test-not start end from-end)
  (MULTIPLE-VALUE-BIND (thing pos)
      (IF (ARRAYP sequence)
	  (FIND-VECTOR item sequence test key test-not start end from-end)
	  (FIND-LIST item sequence test key test-not start end from-end))
    (DECLARE (IGNORE thing))
    pos))

(Defun POSITION (item sequence &KEY key (test #'EQL) test-not start end from-end)
  "returns the position of ITEM in SEQUENCE. It is usually better
to use FIND which returns the ITEM and the position"
  (POSITION* item sequence test key test-not start end from-end))

(Defun POSITION-IF* (predicate sequence &OPTIONAL key start end from-end)
  (MULTIPLE-VALUE-BIND (thing pos)
      (IF (ARRAYP sequence)
	  (FIND-IF-VECTOR predicate sequence key start end from-end)
	  (FIND-IF-LIST predicate sequence key start end from-end))
    (DECLARE (IGNORE thing))
    pos))

(Defun POSITION-IF (predicate sequence &KEY key start end from-end)
  "returns the position of the first item in SEQUENCE which matches PREDICATE"
  (POSITION-IF* predicate sequence key start end from-end))

(Defun POSITION-IF-NOT* (predicate sequence &OPTIONAL key start end from-end)
  (MULTIPLE-VALUE-BIND (thing pos)
      (IF (ARRAYP sequence)
	  (FIND-IF-NOT-VECTOR predicate sequence key start end from-end)
	  (FIND-IF-NOT-LIST predicate sequence key start end from-end))
    (DECLARE (IGNORE thing))
    pos))

(Defun POSITION-IF-NOT (predicate sequence &KEY key start end from-end)
  "returns the position of the first item in SEQUENCE which doesn't match PREDICATE"
  (POSITION-IF-NOT* predicate sequence key start end from-end))


1;;; NSUBSTITUTE , NSUBSTITUTE-IF and NSUBSTITUTE-IF-NOT*
(eval-when (compile)

  (Defmacro WITH-NSUBSTITUTE-LIST-BINDINGS (&BODY body)
    `(LET* ((start (IF start (MAX 0 start) 0))
	    (len   (LENGTH list))
	    (end   (IF end (MIN end len) len))
	    (count (OR count -1)))
       (IF (ZEROP count) list . ,body)))

  (Defmacro WITH-NSUBSTITUTE-LIST-LR-BINDINGS(&BODY body)
    `(LET ((nlist (NTHCDR start list)))
       (PROGN . ,body)
       list))
  
  (Defmacro NSUBSTITUTE-LIST-LR-BODY(loopvar pred)
    `(DO ((,loopvar nlist (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt end))
       (WHEN ,pred
	 (RPLACA ,loopvar new-item)
	 (WHEN (ZEROP (DECF count)) (RETURN)))))

  (Defmacro NSUBSTITUTE-LIST-LR-MACRO ()
    `(WITH-NSUBSTITUTE-LIST-LR-BINDINGS
       (COND (key
	      (IF test-not 
		  (NSUBSTITUTE-LIST-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
		  (NSUBSTITUTE-LIST-LR-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
	     (test-not 
	      (NSUBSTITUTE-LIST-LR-BODY z (NOT (FUNCALL test-not item (CAR z)))))
	     (t 
	      (NSUBSTITUTE-LIST-LR-BODY z (FUNCALL test item (CAR z)))))))

  (Defmacro NSUBSTITUTE-IF-LIST-LR-MACRO ()
    `(WITH-NSUBSTITUTE-LIST-LR-BINDINGS
       (IF key 
	   (NSUBSTITUTE-LIST-LR-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
	   (NSUBSTITUTE-LIST-LR-BODY z (FUNCALL pred (CAR z))))))

  (Defmacro NSUBSTITUTE-IF-NOT-LIST-LR-MACRO ()
    `(WITH-NSUBSTITUTE-LIST-LR-BINDINGS
       (IF key 
	   (NSUBSTITUTE-LIST-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
	   (NSUBSTITUTE-LIST-LR-BODY z (NOT (FUNCALL pred (CAR z)))))))
)

(Defun NSUBSTITUTE-LIST  (new-item item list &OPTIONAL (test #'EQL) count key test-not start end from-end)
;1; the method for NSUBSTITUTE with a list argument*
  (LET (from-end-for-real)
    (WITH-DELETE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (NREVERSE-list list) 
	       from-end-for-real t))
      (LET ((result (NSUBSTITUTE-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(Defun NSUBSTITUTE-IF-LIST  (new-item pred list &OPTIONAL count key start end from-end)
;1; the method for NSUBSTITUTE-IF with a list argument*
  (LET (from-end-for-real)
    (WITH-DELETE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (NREVERSE-list list) 
	       from-end-for-real t))
      (LET ((result (NSUBSTITUTE-IF-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(Defun NSUBSTITUTE-IF-NOT-LIST  (new-item pred list &OPTIONAL count key start end from-end)
;1; the method for NSUBSTITUTE-IF-NOT with a list argument*
  (LET (from-end-for-real)
    (WITH-DELETE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (NREVERSE-list list) 
	       from-end-for-real t))
      (LET ((result (NSUBSTITUTE-IF-NOT-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))


(eval-when (compile)

  (Defmacro NSUBSTITUTE-VECTOR-LR-BODY (loopvar pred)
    `(DO ((,loopvar start (1+ ,loopvar)))
	 ((>= ,loopvar end) vector)
       (WHEN ,pred 
	 (SETF (AREF vector ,loopvar) new-item)
	 (WHEN (ZEROP (DECF count)) (RETURN vector)))))
  
  (Defmacro NSUBSTITUTE-VECTOR-LR-MACRO ()
    `(COND (key
	    (IF test-not 
		(NSUBSTITUTE-VECTOR-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (AREF vector Z)))))
		(NSUBSTITUTE-VECTOR-LR-BODY z (FUNCALL test item (FUNCALL key (AREF vector Z))))))
	   (test-not 
	    (NSUBSTITUTE-VECTOR-LR-BODY z (NOT (FUNCALL test-not item (AREF vector Z)))))
	   (t 
	    (NSUBSTITUTE-VECTOR-LR-BODY z (FUNCALL test item (AREF vector Z))))))
  
  (Defmacro NSUBSTITUTE-IF-VECTOR-LR-MACRO ()
    `(IF key 
	 (NSUBSTITUTE-VECTOR-LR-BODY z (FUNCALL pred (FUNCALL key (AREF vector Z))))
	 (NSUBSTITUTE-VECTOR-LR-BODY z (FUNCALL pred (AREF vector Z)))))
  
  (Defmacro NSUBSTITUTE-IF-NOT-VECTOR-LR-MACRO ()
    `(IF key 
	 (NSUBSTITUTE-VECTOR-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (AREF vector Z)))))
	 (NSUBSTITUTE-VECTOR-LR-BODY z (NOT (FUNCALL pred (AREF vector Z))))))
  )


(Defun NSUBSTITUTE-VECTOR  (new-item item vector &OPTIONAL (test #'EQL) count key test-not start end from-end)
;1; the method for NSUBSTITUTE with a vector argument*
  (LET (from-end-for-real)
    (WITH-DELETE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (NREVERSE-vector vector) 
	       from-end-for-real t))
      (LET ((result (NSUBSTITUTE-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun NSUBSTITUTE-IF-VECTOR  (new-item pred vector &OPTIONAL count key start end from-end)
;1; the method for NSUBSTITUTE-IF with a vector argument*
  (LET (from-end-for-real)
    (WITH-DELETE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (NREVERSE-vector vector) 
	       from-end-for-real t))
      (LET ((result (NSUBSTITUTE-IF-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun NSUBSTITUTE-IF-NOT-VECTOR  (new-item pred vector &OPTIONAL count key start end from-end)
;1; the method for NSUBSTITUTE-IF-NOT with a vector argument*
  (LET (from-end-for-real)
    (WITH-DELETE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (NREVERSE-vector vector) 
	       from-end-for-real t))
      (LET ((result (NSUBSTITUTE-IF-NOT-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))



(Defun NSUBSTITUTE* (new-item item sequence &OPTIONAL (test #'EQL) count key test-not start end from-end)
  (IF (ARRAYP sequence)
      (NSUBSTITUTE-VECTOR new-item item sequence test count key test-not start end from-end)
      (NSUBSTITUTE-LIST new-item item sequence test count key test-not start end from-end)))

(Defun NSUBSTITUTE (new-item item sequence &KEY key (test #'EQL) test-not start end count from-end)
  1"2Destructively replace items matching <item> with <new-item>**"
  (NSUBSTITUTE* new-item item sequence test count key test-not start end from-end))

(Defun NSUBSTITUTE-IF* (new-item predicate sequence &OPTIONAL count key start end from-end)
  (IF (ARRAYP sequence)
      (NSUBSTITUTE-IF-VECTOR new-item predicate sequence count key start end from-end)
      (NSUBSTITUTE-IF-LIST new-item predicate sequence count key start end from-end)))

(Defun NSUBSTITUTE-IF (new-item predicate sequence &KEY key start end count from-end)
  1"2Destructively replace items satisfying >predicate> with <new-item>**"
  (NSUBSTITUTE-IF* new-item predicate sequence count key start end from-end))

(Defun NSUBSTITUTE-IF-NOT* (new-item predicate sequence &OPTIONAL count key start end from-end)
  (IF (ARRAYP sequence)
      (NSUBSTITUTE-IF-NOT-VECTOR new-item predicate sequence count key start end from-end)
      (NSUBSTITUTE-IF-NOT-LIST new-item predicate sequence count key start end from-end)))

(Defun NSUBSTITUTE-IF-NOT (new-item predicate sequence &KEY key start end count from-end)
  1"2Destructively replace items not satisfying <predicate> with <new-item>**" 
  (NSUBSTITUTE-IF-NOT* new-item predicate sequence count key start end from-end))

1;;; SUBSTITUTE , SUBSTITUTE-IF and SUBSTITUTE-IF-NOT*
(eval-when (compile)

  (Defmacro WITH-SUBSTITUTE-LIST-BINDINGS (&BODY body)
    `(LET* ((start (IF start (MAX 0 start) 0))
	    (len   (LENGTH list))
	    (end   (IF end (MIN end len) len))
	    (count (OR count -1)))
       (IF (ZEROP count) list . ,body)))

  (Defmacro WITH-SUBSTITUTE-LIST-LR-BINDINGS(&BODY body)
    `(LET* ((new-list nil)(loc nil)(rest (PROGN . ,body)))
       (IF loc
	   (PROGN
	     (WHEN rest (RPLACD loc rest))
	     new-list)
	   list)))
  
  (Defmacro SUBSTITUTE-LIST-LR-BODY(loopvar pred)
    `(DO ((,loopvar (NTHCDR start list) (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt end) ,loopvar)
       (COND (,pred
	      (UNLESS loc
		(SETQ loc (COPY-LIST-BELOW-INDEX list loopcnt (LOCF new-list))))
	      (RPLACD loc (SETQ loc (CONS new-item nil)))
	      (WHEN (ZEROP (DECF count)) (RETURN (CDR ,loopvar))))
	     (t
	      (WHEN loc
		(RPLACD loc (SETQ loc (CONS (CAR ,loopvar) nil))))))))

  (Defmacro SUBSTITUTE-LIST-LR-MACRO ()
    `(WITH-SUBSTITUTE-LIST-LR-BINDINGS
       (COND (key
	      (IF test-not 
		  (SUBSTITUTE-LIST-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
		  (SUBSTITUTE-LIST-LR-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
	     (test-not 
	      (SUBSTITUTE-LIST-LR-BODY z (NOT (FUNCALL test-not item (CAR z)))))
	     (t
	      (SUBSTITUTE-LIST-LR-BODY z (FUNCALL test item (CAR z)))))))

  (Defmacro SUBSTITUTE-IF-LIST-LR-MACRO ()
    `(WITH-SUBSTITUTE-LIST-LR-BINDINGS
       (IF key 
	   (SUBSTITUTE-LIST-LR-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
	   (SUBSTITUTE-LIST-LR-BODY z (FUNCALL pred (CAR z))))))

  (Defmacro SUBSTITUTE-IF-NOT-LIST-LR-MACRO ()
    `(WITH-SUBSTITUTE-LIST-LR-BINDINGS
       (IF key 
	   (SUBSTITUTE-LIST-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
	   (SUBSTITUTE-LIST-LR-BODY z (NOT (FUNCALL pred (CAR z)))))))
)

(Defun SUBSTITUTE-LIST (new-item item list &OPTIONAL (test #'EQL) count key test-not start end from-end)
;1; the method for SUBSTITUTE with a list argument*
  (LET (from-end-for-real)
    (WITH-SUBSTITUTE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (REVERSE-list list)  ;1; cons a new list*
	       from-end-for-real t))
      (LET ((result (SUBSTITUTE-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(Defun SUBSTITUTE-IF-LIST (new-item pred list &OPTIONAL count key start end from-end)
;1; the method for SUBSTITUTE-IF with a list argument*
  (LET (from-end-for-real)
    (WITH-SUBSTITUTE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (REVERSE-list list)  ;1; cons a new list*
	       from-end-for-real t))
      (LET ((result (SUBSTITUTE-IF-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(Defun SUBSTITUTE-IF-NOT-LIST (new-item pred list &OPTIONAL count key start end from-end)
;1; the method for SUBSTITUTE-IF-NOT with a list argument*
  (LET (from-end-for-real)
    (WITH-SUBSTITUTE-LIST-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       list (REVERSE-list list)  ;1; cons a new list*
	       from-end-for-real t))
      (LET ((result (SUBSTITUTE-IF-NOT-LIST-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-list result) result)))))

(eval-when (compile)
  (Defmacro WITH-SUBSTITUTE-VECTOR-BINDINGS (&BODY body)
    `(LET* ((start (IF start (MAX 0 start) 0))
	    (len   (LENGTH vector))
	    (end   (IF end (MIN end len) len))
	    (count (OR count -1))
	    (new-vector nil))
       (IF (ZEROP count) vector . ,body)))
  
  (Defmacro WITH-SUBSTITUTE-VECTOR-LR-BINDINGS (&BODY body)
    `(LET ((vector-index (PROGN . ,body)))
       (WHEN (AND new-vector (< vector-index len))
	 (COPY-ARRAY-PORTION vector vector-index len new-vector vector-index len))
       (OR new-vector vector)))

  (Defmacro SUBSTITUTE-VECTOR-LR-BODY (loopvar pred)
    `(DO ((,loopvar start (1+ ,loopvar)))
	 ((>= ,loopvar end) ,loopvar)  ;; return index to next entry
       (COND (,pred 
	      (UNLESS new-vector
		(SETQ new-vector (COPY-ARRAY-BELOW-INDEX vector ,loopvar len)))
	      (SETF (AREF new-vector ,loopvar) new-item)
	      (WHEN (ZEROP (DECF count)) (RETURN (1+ ,loopvar))))
	     (T 
	      (WHEN new-vector
		(SETF (AREF new-vector ,loopvar) (AREF vector ,loopvar)))))))
  
  (Defmacro SUBSTITUTE-VECTOR-LR-MACRO ()
    `(WITH-SUBSTITUTE-VECTOR-LR-BINDINGS
       (COND (key
	      (IF test-not 
		  (SUBSTITUTE-VECTOR-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (AREF vector Z)))))
		  (SUBSTITUTE-VECTOR-LR-BODY z (FUNCALL test item (FUNCALL key (AREF vector Z))))))
	     (test-not 
	      (SUBSTITUTE-VECTOR-LR-BODY z (NOT (FUNCALL test-not item (AREF vector Z)))))
	     (t 
	      (SUBSTITUTE-VECTOR-LR-BODY z (FUNCALL test item (AREF vector Z)))))))
  
  (Defmacro SUBSTITUTE-IF-VECTOR-LR-MACRO ()
    `(WITH-SUBSTITUTE-VECTOR-LR-BINDINGS
       (IF key 
	   (SUBSTITUTE-VECTOR-LR-BODY z (FUNCALL pred (FUNCALL key (AREF vector Z))))
	   (SUBSTITUTE-VECTOR-LR-BODY z (FUNCALL pred (AREF vector Z))))))
    
  (Defmacro SUBSTITUTE-IF-NOT-VECTOR-LR-MACRO ()
    `(WITH-SUBSTITUTE-VECTOR-LR-BINDINGS
       (IF key 
	   (SUBSTITUTE-VECTOR-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (AREF vector Z)))))
	   (SUBSTITUTE-VECTOR-LR-BODY z (NOT (FUNCALL pred (AREF vector Z)))))))
    )

(Defun SUBSTITUTE-VECTOR (new-item item vector &OPTIONAL (test #'EQL) count key test-not start end from-end)
;1; the method for SUBSTITUTE with a vector argument*
  (LET (from-end-for-real)
    (WITH-SUBSTITUTE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (REVERSE-vector vector)  ;1; cons a new vector*
	       from-end-for-real t))
      (LET ((result (SUBSTITUTE-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun SUBSTITUTE-IF-VECTOR (new-item pred vector &OPTIONAL count key start end from-end)
;1; the method for SUBSTITUTE-IF with a vector argument*
  (LET (from-end-for-real)
    (WITH-SUBSTITUTE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (REVERSE-vector vector)  ;1; cons a new vector*
	       from-end-for-real t))
      (LET ((result (SUBSTITUTE-IF-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun SUBSTITUTE-IF-NOT-VECTOR (new-item pred vector &OPTIONAL count key start end from-end)
;1; the method for SUBSTITUTE-IF-NOT with a vector argument*
  (LET (from-end-for-real)
    (WITH-SUBSTITUTE-VECTOR-BINDINGS
      (WHEN (AND from-end (plusp count))
	(PSETQ start (- len end) 
	       end (- len start) 
	       vector (REVERSE-vector vector)  ;1; cons a new vector*
	       from-end-for-real t))
      (LET ((result (SUBSTITUTE-IF-NOT-VECTOR-LR-MACRO))) ;1; apply lr method*
	(IF from-end-for-real (NREVERSE-vector result) result)))))

(Defun SUBSTITUTE* (new-item item sequence &OPTIONAL (test #'EQL) count key test-not start end from-end)
  (IF (ARRAYP sequence)
      (SUBSTITUTE-VECTOR new-item item sequence test count key test-not start end from-end)
      (SUBSTITUTE-LIST new-item item sequence test count key test-not start end from-end)))

(Defun SUBSTITUTE (new-item item sequence &KEY key (test #'EQL) test-not start end count from-end)
1  "Replace items in <sequence> that match <item> with <new-item>, 
copying structure as necessary to avoid modifying <sequence>."*
  (SUBSTITUTE* new-item item sequence test count key test-not start end from-end))

(Defun SUBSTITUTE-IF* (new-item predicate sequence &OPTIONAL count key start end from-end)
  (IF (ARRAYP sequence)
      (SUBSTITUTE-IF-VECTOR new-item predicate sequence count key start end from-end)
      (SUBSTITUTE-IF-LIST new-item predicate sequence count key start end from-end)))

(Defun SUBSTITUTE-IF (new-item predicate sequence &KEY key start end count from-end)
1  "Replace items in <sequence> satisfying <predicate> with <new-item>,
copying structure as necessary to avoid modifying <sequence>."  *
  (SUBSTITUTE-IF* new-item predicate sequence count key start end from-end))

(Defun SUBSTITUTE-IF-NOT* (new-item predicate sequence &OPTIONAL count key start end from-end)
  (IF (ARRAYP sequence)
      (SUBSTITUTE-IF-NOT-VECTOR new-item predicate sequence count key start end from-end)
      (SUBSTITUTE-IF-NOT-LIST new-item predicate sequence count key start end from-end)))

(Defun SUBSTITUTE-IF-NOT (new-item predicate sequence &KEY key start end count from-end)
1  "Replace items in <sequence> not satisfying <predicate> with <new-item>,
copying structure as necessary to avoid modifying <sequence>."  *
  (SUBSTITUTE-IF-NOT* new-item predicate sequence count key start end from-end))

1;;; COUNT , COUNT-IF and COUNT-IF-NOT*
(eval-when (compile)
;; in LR processing, the leftmost item satisfying the test is returned. The search loop
;; is exited immediately upon finding such an item.

  (Defmacro WITH-COUNT-LIST-BINDINGS (&BODY body)
    `(LET* ((count 0)
	    (start (IF start (MAX 0 start) 0))
	    (len   (LENGTH list))
	    (end   (IF end (MIN end len) len))
	    (list  (NTHCDR start list)))
       (PROGN . ,body)
       count))

  (Defmacro COUNT-LIST-BODY (loopvar pred)
    `(DO ((,loopvar list (CDR ,loopvar))
	  (loopcnt start (1+ loopcnt)))
	 ((>= loopcnt end))
       (WHEN ,pred (INCF count))))
)
  
(Defun COUNT-LIST (item list &OPTIONAL (test #'EQL) key test-not start end from-end)
  (DECLARE (IGNORE from-end))
  (WITH-COUNT-LIST-BINDINGS
    (COND (key
	   (IF test-not 
	       (COUNT-LIST-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
	       (COUNT-LIST-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
	  (test-not 
	   (COUNT-LIST-BODY z (NOT (FUNCALL test-not item (CAR z)))))
	  (t 
	   (COUNT-LIST-BODY z (FUNCALL test item (CAR z)))))))

(Defun COUNT-IF-LIST (pred list &OPTIONAL key start end from-end)
  (DECLARE (IGNORE from-end))
  (WITH-COUNT-LIST-BINDINGS
    (IF key (COUNT-LIST-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
	(COUNT-LIST-BODY z (FUNCALL pred (CAR z))))))

(Defun COUNT-IF-NOT-LIST(pred list &OPTIONAL key start end from-end)
  (DECLARE (IGNORE from-end))
  (WITH-COUNT-LIST-BINDINGS
    (IF key (COUNT-LIST-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
	(COUNT-LIST-BODY z (NOT (FUNCALL pred (CAR z)))))))

(eval-when (compile)
  (Defmacro WITH-COUNT-VECTOR-BINDINGS (&BODY body)
    `(LET* ((count 0)
	    (start (IF start (MAX 0 start) 0))
	    (len   (LENGTH vector))
	    (end   (IF end (MIN end len) len)))
       (PROGN . ,body)
       count))
  
  (Defmacro COUNT-VECTOR-BODY (loopvar pred)
    `(DO ((,loopvar start (1+ ,loopvar)))
	 ((>= ,loopvar end))
       (WHEN ,pred (INCF count))))
)
  
(Defun COUNT-VECTOR (item vector &OPTIONAL (test #'EQL) key test-not start end from-end)
  (DECLARE (IGNORE from-end))
  (WITH-COUNT-VECTOR-BINDINGS
    (COND (key
	   (IF test-not 
	       (COUNT-VECTOR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (AREF vector Z)))))
	       (COUNT-VECTOR-BODY z (FUNCALL test item (FUNCALL key (AREF vector Z))))))
	  (test-not 
	   (COUNT-VECTOR-BODY z (NOT (FUNCALL test-not item (AREF vector Z)))))
	  (t 
	   (COUNT-VECTOR-BODY z (FUNCALL test item (AREF vector Z)))))))
  
(Defun COUNT-IF-VECTOR (pred vector &OPTIONAL key start end from-end)
  (DECLARE (IGNORE from-end))
  (WITH-COUNT-VECTOR-BINDINGS
    (IF key 
	(COUNT-VECTOR-BODY z (FUNCALL pred (FUNCALL key (AREF vector Z))))
	(COUNT-VECTOR-BODY z (FUNCALL pred (AREF vector Z))))))
  
(Defun COUNT-IF-NOT-VECTOR (pred vector &OPTIONAL key start end from-end)
  (DECLARE (IGNORE from-end))
  (WITH-COUNT-VECTOR-BINDINGS
    (IF key 
	 (COUNT-VECTOR-BODY z (NOT (FUNCALL pred (FUNCALL key (AREF vector Z)))))
	 (COUNT-VECTOR-BODY z (NOT (FUNCALL pred (AREF vector Z)))))))



(Defun COUNT*(item sequence &OPTIONAL (test #'EQL) key test-not start end from-end)
  (DECLARE (IGNORE from-end))
  (IF (ARRAYP sequence)
      (COUNT-VECTOR item sequence test key test-not start end)
      (COUNT-LIST item sequence test key test-not start end)))

;;  5/2/89 DNG - Added doc strings [SPR 4677]
(Defun COUNT(item sequence &KEY key (test #'EQL) test-not start end from-end)
  "Returns the number of elements of SEQUENCE that match ITEM."
  (DECLARE (IGNORE from-end) (INLINE COUNT*))
  (COUNT* item sequence test key test-not start end))

(Defun COUNT-IF*(pred sequence &OPTIONAL key start end from-end)
  (DECLARE (IGNORE from-end))
  (IF (ARRAYP sequence)
      (COUNT-IF-VECTOR pred sequence key start end)
      (COUNT-IF-LIST pred sequence key start end)))

(Defun COUNT-IF(pred sequence &KEY key start end from-end)
  "Tests each element of SEQUENCE with PREDICATE and counts how many times
PREDICATE returns a true value.  This number is returned."
  (DECLARE (IGNORE from-end) (INLINE COUNT-IF*))
  (COUNT-IF* pred sequence key start end))

(Defun COUNT-IF-NOT*(pred sequence &OPTIONAL key start end from-end)
  (DECLARE (IGNORE from-end))
  (IF (ARRAYP sequence)
      (COUNT-IF-NOT-VECTOR pred sequence key start end)
      (COUNT-IF-NOT-LIST pred sequence key start end)))

(Defun COUNT-IF-NOT(pred sequence &KEY key start end from-end)
    "Tests each element of SEQUENCE with PREDICATE and counts how many times
PREDICATE returns NIL.  This number is returned."
  (DECLARE (IGNORE from-end)(INLINE COUNT-IF-NOT*))
  (COUNT-IF-NOT* pred sequence key start end))