(FILECREATED "16-Jul-86 01:24:59" {ERIS}<LISPCORE>EVAL>CMLSEQMODIFY.;1 64131
changes to: (FUNCTIONS VECTOR-SUBSTITUTE*)
previous date: " 2-Jul-86 18:08:00" {ERIS}<LISPCORE>LIBRARY>CMLSEQMODIFY.;1)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSEQMODIFYCOMS)
(RPAQQ CMLSEQMODIFYCOMS ((DECLARE: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON))
(FUNCTIONS FILL LIST-FILL LIST-FILL* VECTOR-FILL VECTOR-FILL*)
(FUNCTIONS MUMBLE-REPLACE-FROM-MUMBLE LIST-REPLACE-FROM-LIST
LIST-REPLACE-FROM-MUMBLE MUMBLE-REPLACE-FROM-LIST CL:REPLACE
LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR*
VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*)
(COMS (FUNCTIONS MUMBLE-DELETE MUMBLE-DELETE-FROM-END LIST-DELETE
LIST-DELETE-FROM-END)
(FUNCTIONS NORMAL-MUMBLE-DELETE NORMAL-MUMBLE-DELETE-FROM-END
NORMAL-LIST-DELETE NORMAL-LIST-DELETE-FROM-END CL:DELETE)
(FUNCTIONS IF-MUMBLE-DELETE IF-MUMBLE-DELETE-FROM-END IF-LIST-DELETE
IF-LIST-DELETE-FROM-END DELETE-IF)
(FUNCTIONS IF-NOT-MUMBLE-DELETE IF-NOT-MUMBLE-DELETE-FROM-END
IF-NOT-LIST-DELETE IF-NOT-LIST-DELETE-FROM-END DELETE-IF-NOT))
(COMS (FUNCTIONS MUMBLE-REMOVE-MACRO MUMBLE-REMOVE MUMBLE-REMOVE-FROM-END
LIST-REMOVE-MACRO LIST-REMOVE LIST-REMOVE-FROM-END)
(FUNCTIONS NORMAL-MUMBLE-REMOVE NORMAL-MUMBLE-REMOVE-FROM-END
NORMAL-LIST-REMOVE NORMAL-LIST-REMOVE-FROM-END CL:REMOVE)
(FUNCTIONS IF-MUMBLE-REMOVE IF-MUMBLE-REMOVE-FROM-END IF-LIST-REMOVE
IF-LIST-REMOVE-FROM-END REMOVE-IF)
(FUNCTIONS IF-NOT-MUMBLE-REMOVE IF-NOT-MUMBLE-REMOVE-FROM-END
IF-NOT-LIST-REMOVE IF-NOT-LIST-REMOVE-FROM-END REMOVE-IF-NOT))
(FUNCTIONS LIST-REMOVE-DUPLICATES* VECTOR-REMOVE-DUPLICATES*
REMOVE-DUPLICATES LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*
DELETE-DUPLICATES)
(FUNCTIONS SUBST-DISPATCH LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE
SUBSTITUTE-IF SUBSTITUTE-IF-NOT)
(FUNCTIONS NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NSUBSTITUTE
NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NSUBSTITUTE-IF
NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*
NSUBSTITUTE-IF-NOT)
(PROP FILETYPE CMLSEQMODIFY)))
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD CMLSEQCOMMON)
)
(DEFUN FILL (SEQUENCE ITEM &KEY (START 0)
END &AUX (LENGTH (CL:LENGTH SEQUENCE)))
"Replace the specified elements of SEQUENCE with ITEM."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (LIST-FILL* SEQUENCE ITEM START END)
(VECTOR-FILL* SEQUENCE ITEM START END)))
(DEFMACRO LIST-FILL (SEQUENCE ITEM START END) (BQUOTE (CL:DO ((CURRENT (NTHCDR (\, START)
(\, SEQUENCE))
(CDR CURRENT))
(INDEX (\, START)
(1+ INDEX)))
((OR (ENDP CURRENT)
(>= INDEX (\, END)))
SEQUENCE)
(RPLACA CURRENT (\, ITEM)))))
(DEFUN LIST-FILL* (SEQUENCE ITEM START END) (* raf "17-Dec-85 22:37") (LIST-FILL
SEQUENCE ITEM
START END))
(DEFMACRO VECTOR-FILL (SEQUENCE ITEM START END) (BQUOTE (CL:DO ((INDEX (\, START)
(1+ INDEX)))
((>= INDEX (\, END))
(\, SEQUENCE))
(SETF (AREF (\, SEQUENCE)
INDEX)
(\, ITEM)))))
(DEFUN VECTOR-FILL* (SEQUENCE ITEM START END) (* raf "17-Dec-85 22:37") (VECTOR-FILL
SEQUENCE ITEM
START END))
(DEFMACRO MUMBLE-REPLACE-FROM-MUMBLE NIL (BQUOTE (CL:IF (AND (EQ TARGET-SEQUENCE SOURCE-SEQUENCE)
(> TARGET-START SOURCE-START))
(LET ((NELTS (MIN (- TARGET-END TARGET-START)
(- SOURCE-END SOURCE-START)
)))
(CL:DO ((TARGET-INDEX (+ TARGET-START
NELTS -1)
(1- TARGET-INDEX))
(SOURCE-INDEX (+ SOURCE-START
NELTS -1)
(1- SOURCE-INDEX)))
((< TARGET-INDEX TARGET-START)
TARGET-SEQUENCE)
(SETF (AREF TARGET-SEQUENCE
TARGET-INDEX)
(AREF SOURCE-SEQUENCE
SOURCE-INDEX))))
(CL:DO ((TARGET-INDEX TARGET-START
(1+ TARGET-INDEX))
(SOURCE-INDEX SOURCE-START
(1+ SOURCE-INDEX)))
((OR (>= TARGET-INDEX TARGET-END)
(>= SOURCE-INDEX SOURCE-END))
TARGET-SEQUENCE)
(SETF (AREF TARGET-SEQUENCE
TARGET-INDEX)
(AREF SOURCE-SEQUENCE
SOURCE-INDEX))))))
(DEFMACRO LIST-REPLACE-FROM-LIST NIL (BQUOTE (COND
((AND (EQ TARGET-SEQUENCE SOURCE-SEQUENCE)
(> TARGET-START SOURCE-START))
(LET ((NEW-ELTS (SUBSEQ SOURCE-SEQUENCE SOURCE-START
(+ SOURCE-START
(MIN (- TARGET-END
TARGET-START)
(- SOURCE-END
SOURCE-START))))))
(CL:DO ((N NEW-ELTS (CDR N))
(O (NTHCDR TARGET-START TARGET-SEQUENCE
)
(CDR O)))
((ENDP N)
TARGET-SEQUENCE)
(RPLACA O (CAR N)))))
(T (CL:DO ((TARGET-INDEX TARGET-START (1+
TARGET-INDEX
))
(SOURCE-INDEX SOURCE-START (1+
SOURCE-INDEX
))
(TARGET-SEQUENCE-REF (NTHCDR TARGET-START
TARGET-SEQUENCE
)
(CDR TARGET-SEQUENCE-REF))
(SOURCE-SEQUENCE-REF (NTHCDR SOURCE-START
SOURCE-SEQUENCE
)
(CDR SOURCE-SEQUENCE-REF)))
((OR (>= TARGET-INDEX TARGET-END)
(>= SOURCE-INDEX SOURCE-END)
(NULL TARGET-SEQUENCE-REF)
(NULL SOURCE-SEQUENCE-REF))
TARGET-SEQUENCE)
(RPLACA TARGET-SEQUENCE-REF (CAR
SOURCE-SEQUENCE-REF
)))))))
(DEFMACRO LIST-REPLACE-FROM-MUMBLE NIL (BQUOTE (CL:DO ((TARGET-INDEX TARGET-START (1+ TARGET-INDEX))
(SOURCE-INDEX SOURCE-START (1+ SOURCE-INDEX))
(TARGET-SEQUENCE-REF (NTHCDR TARGET-START
TARGET-SEQUENCE)
(CDR TARGET-SEQUENCE-REF)))
((OR (>= TARGET-INDEX TARGET-END)
(>= SOURCE-INDEX SOURCE-END)
(ENDP TARGET-SEQUENCE-REF))
TARGET-SEQUENCE)
(RPLACA TARGET-SEQUENCE-REF (AREF
SOURCE-SEQUENCE
SOURCE-INDEX)
))))
(DEFMACRO MUMBLE-REPLACE-FROM-LIST NIL (BQUOTE (CL:DO ((TARGET-INDEX TARGET-START (1+ TARGET-INDEX))
(SOURCE-INDEX SOURCE-START (1+ SOURCE-INDEX))
(SOURCE-SEQUENCE (NTHCDR SOURCE-START
SOURCE-SEQUENCE)
(CDR SOURCE-SEQUENCE)))
((OR (>= TARGET-INDEX TARGET-END)
(>= SOURCE-INDEX SOURCE-END)
(ENDP SOURCE-SEQUENCE))
TARGET-SEQUENCE)
(SETF (AREF TARGET-SEQUENCE TARGET-INDEX)
(CAR SOURCE-SEQUENCE)))))
(DEFUN CL:REPLACE (TARGET-SEQUENCE SOURCE-SEQUENCE &KEY ((:START1 TARGET-START)
0)
((:END1 TARGET-END))
((:START2 SOURCE-START)
0)
((:END2 SOURCE-END))
&AUX
(TARGET-LENGTH (CL:LENGTH TARGET-SEQUENCE))
(SOURCE-LENGTH (CL:LENGTH SOURCE-SEQUENCE)))
(* jrb: "23-Apr-86 11:00")
(CL:UNLESS TARGET-END (SETQ TARGET-END TARGET-LENGTH))
(CL:UNLESS SOURCE-END (SETQ SOURCE-END SOURCE-LENGTH))
(CHECK-SUBSEQ TARGET-SEQUENCE TARGET-START TARGET-END TARGET-LENGTH)
(CHECK-SUBSEQ SOURCE-SEQUENCE SOURCE-START SOURCE-END SOURCE-LENGTH)
(SEQ-DISPATCH TARGET-SEQUENCE (SEQ-DISPATCH SOURCE-SEQUENCE (LIST-REPLACE-FROM-LIST)
(LIST-REPLACE-FROM-MUMBLE))
(SEQ-DISPATCH SOURCE-SEQUENCE (MUMBLE-REPLACE-FROM-LIST)
(MUMBLE-REPLACE-FROM-MUMBLE))))
(DEFUN LIST-REPLACE-FROM-LIST* (TARGET-SEQUENCE SOURCE-SEQUENCE TARGET-START TARGET-END SOURCE-START
SOURCE-END) (COND
((NULL TARGET-END)
(SETQ TARGET-END (CL:LENGTH TARGET-SEQUENCE))))
(COND
((NULL SOURCE-END)
(SETQ SOURCE-END (CL:LENGTH SOURCE-SEQUENCE))))
(LIST-REPLACE-FROM-LIST))
(DEFUN LIST-REPLACE-FROM-VECTOR* (TARGET-SEQUENCE SOURCE-SEQUENCE TARGET-START TARGET-END
SOURCE-START SOURCE-END) (COND
((NULL TARGET-END)
(SETQ TARGET-END (CL:LENGTH
TARGET-SEQUENCE
))))
(COND
((NULL SOURCE-END)
(SETQ SOURCE-END (CL:LENGTH
SOURCE-SEQUENCE
))))
(LIST-REPLACE-FROM-MUMBLE))
(DEFUN VECTOR-REPLACE-FROM-LIST* (TARGET-SEQUENCE SOURCE-SEQUENCE TARGET-START TARGET-END
SOURCE-START SOURCE-END) (COND
((NULL TARGET-END)
(SETQ TARGET-END (CL:LENGTH
TARGET-SEQUENCE
))))
(COND
((NULL SOURCE-END)
(SETQ SOURCE-END (CL:LENGTH
SOURCE-SEQUENCE
))))
(MUMBLE-REPLACE-FROM-LIST))
(DEFUN VECTOR-REPLACE-FROM-VECTOR* (TARGET-SEQUENCE SOURCE-SEQUENCE TARGET-START TARGET-END
SOURCE-START SOURCE-END) (COND
((NULL TARGET-END)
(SETQ TARGET-END (CL:LENGTH
TARGET-SEQUENCE
))))
(COND
((NULL SOURCE-END)
(SETQ SOURCE-END (CL:LENGTH
SOURCE-SEQUENCE
))))
(MUMBLE-REPLACE-FROM-MUMBLE))
(DEFMACRO MUMBLE-DELETE (PRED) (BQUOTE (CL:DO ((INDEX START (1+ INDEX))
(JNDEX START)
(NUMBER-ZAPPED 0))
((OR (= INDEX END)
(= NUMBER-ZAPPED COUNT))
(CL:DO ((INDEX INDEX (1+ INDEX))
(JNDEX JNDEX (1+ JNDEX)))
((= INDEX LENGTH)
(SHRINK-VECTOR SEQUENCE JNDEX))
(SETF (AREF SEQUENCE JNDEX)
(AREF SEQUENCE INDEX))))
(SETF (AREF SEQUENCE JNDEX)
(AREF SEQUENCE INDEX))
(CL:IF (\, PRED)
(INCF NUMBER-ZAPPED)
(INCF JNDEX)))))
(DEFMACRO MUMBLE-DELETE-FROM-END (PRED) (BQUOTE (CL:DO ((INDEX (1- END)
(1- INDEX))
(NUMBER-ZAPPED 0)
(LOSERS NIL)
(TERMINUS (1- START)))
((OR (= INDEX TERMINUS)
(= NUMBER-ZAPPED COUNT))
(CL:DO ((LOSERS LOSERS)
(INDEX START (1+ INDEX))
(JNDEX START))
((OR (NULL LOSERS)
(= INDEX END))
(CL:DO ((INDEX INDEX (1+ INDEX))
(JNDEX JNDEX (1+ JNDEX)))
((= INDEX LENGTH)
(SHRINK-VECTOR SEQUENCE JNDEX
))
(SETF (AREF SEQUENCE JNDEX)
(AREF SEQUENCE INDEX))))
(SETF (AREF SEQUENCE JNDEX)
(AREF SEQUENCE INDEX))
(CL:IF (= INDEX (CAR LOSERS))
(CL:POP LOSERS)
(INCF JNDEX))))
(LET ((THIS-ELEMENT (AREF SEQUENCE INDEX)))
(COND
((\, PRED)
(INCF NUMBER-ZAPPED)
(CL:PUSH INDEX LOSERS)))))))
(DEFMACRO LIST-DELETE (PRED) (BQUOTE (LET ((HANDLE (CONS NIL SEQUENCE)))
(CL:DO ((CURRENT (NTHCDR START SEQUENCE)
(CDR CURRENT))
(PREVIOUS (NTHCDR START HANDLE))
(INDEX START (1+ INDEX))
(NUMBER-ZAPPED 0))
((OR (= INDEX END)
(= NUMBER-ZAPPED COUNT))
(CDR HANDLE))
(COND
((\, PRED)
(RPLACD PREVIOUS (CDR CURRENT))
(INCF NUMBER-ZAPPED))
(T (CL:POP PREVIOUS)))))))
(DEFMACRO LIST-DELETE-FROM-END (PRED) (BQUOTE (LET* ((REVERSE (REVERSE SEQUENCE))
(HANDLE (CONS NIL REVERSE)))
(CL:DO ((CURRENT (NTHCDR (- LENGTH END)
REVERSE)
(CDR CURRENT))
(PREVIOUS (NTHCDR (- LENGTH END)
HANDLE))
(INDEX START (1+ INDEX))
(NUMBER-ZAPPED 0))
((OR (= INDEX END)
(= NUMBER-ZAPPED COUNT))
(REVERSE (CDR HANDLE)))
(COND
((\, PRED)
(RPLACD PREVIOUS (CDR CURRENT))
(INCF NUMBER-ZAPPED))
(T (CL:POP PREVIOUS)))))))
(DEFMACRO NORMAL-MUMBLE-DELETE NIL (BQUOTE (MUMBLE-DELETE (CL:IF TEST-NOT
(NOT (FUNCALL TEST-NOT ITEM
(FUNCALL KEY
(AREF SEQUENCE
INDEX))))
(FUNCALL TEST ITEM
(FUNCALL KEY (AREF SEQUENCE
INDEX)))))
))
(DEFMACRO NORMAL-MUMBLE-DELETE-FROM-END NIL (BQUOTE (MUMBLE-DELETE-FROM-END
(CL:IF TEST-NOT (NOT (FUNCALL TEST-NOT ITEM
(FUNCALL KEY
THIS-ELEMENT)
))
(FUNCALL TEST ITEM (FUNCALL KEY
THIS-ELEMENT)))
)))
(DEFMACRO NORMAL-LIST-DELETE NIL (QUOTE (LIST-DELETE (CL:IF TEST-NOT
(NOT (FUNCALL TEST-NOT ITEM
(FUNCALL KEY (CAR CURRENT))))
(FUNCALL TEST ITEM (FUNCALL KEY
(CAR CURRENT)))
))))
(DEFMACRO NORMAL-LIST-DELETE-FROM-END NIL (QUOTE (LIST-DELETE-FROM-END
(CL:IF TEST-NOT (NOT (FUNCALL TEST-NOT ITEM
(FUNCALL KEY
(CAR CURRENT))))
(FUNCALL TEST ITEM (FUNCALL KEY (CAR CURRENT
)))))))
(DEFUN CL:DELETE (ITEM SEQUENCE &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT
(START 0)
END
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE)))
"Returns a sequence formed by destructively removing the specified Item from the given sequence."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (NORMAL-LIST-DELETE-FROM-END)
(NORMAL-LIST-DELETE))
(CL:IF FROM-END (NORMAL-MUMBLE-DELETE-FROM-END)
(NORMAL-MUMBLE-DELETE))))
(DEFMACRO IF-MUMBLE-DELETE NIL (BQUOTE (MUMBLE-DELETE (FUNCALL PREDICATE (FUNCALL KEY
(AREF SEQUENCE INDEX)
)))))
(DEFMACRO IF-MUMBLE-DELETE-FROM-END NIL (BQUOTE (MUMBLE-DELETE-FROM-END (FUNCALL PREDICATE
(FUNCALL KEY
THIS-ELEMENT)))
))
(DEFMACRO IF-LIST-DELETE NIL (QUOTE (LIST-DELETE (FUNCALL PREDICATE (FUNCALL KEY (CAR CURRENT))))))
(DEFMACRO IF-LIST-DELETE-FROM-END NIL (QUOTE (LIST-DELETE-FROM-END (FUNCALL PREDICATE
(FUNCALL KEY (CAR CURRENT))
))))
(DEFUN DELETE-IF (PREDICATE SEQUENCE &KEY FROM-END (START 0)
(KEY (FUNCTION IDENTITY))
END
(COUNT MOST-POSITIVE-FIXNUM)
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) "Returns a sequence formed by destructively removing the elements satisfying the specified predicate from the given sequence."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (IF-LIST-DELETE-FROM-END)
(IF-LIST-DELETE))
(CL:IF FROM-END (IF-MUMBLE-DELETE-FROM-END)
(IF-MUMBLE-DELETE))))
(DEFMACRO IF-NOT-MUMBLE-DELETE NIL (BQUOTE (MUMBLE-DELETE (NOT (FUNCALL PREDICATE
(FUNCALL KEY (AREF SEQUENCE
INDEX)))))))
(DEFMACRO IF-NOT-MUMBLE-DELETE-FROM-END NIL (BQUOTE (MUMBLE-DELETE-FROM-END
(NOT (FUNCALL PREDICATE (FUNCALL KEY
THIS-ELEMENT))))))
(DEFMACRO IF-NOT-LIST-DELETE NIL (QUOTE (LIST-DELETE (FUNCALL PREDICATE (FUNCALL KEY (CAR CURRENT))))
))
(DEFMACRO IF-NOT-LIST-DELETE-FROM-END NIL (QUOTE (LIST-DELETE-FROM-END (FUNCALL PREDICATE
(FUNCALL KEY
(CAR CURRENT))))
))
(DEFUN DELETE-IF-NOT (PREDICATE SEQUENCE &KEY FROM-END (START 0)
END
(KEY (FUNCTION IDENTITY))
(COUNT MOST-POSITIVE-FIXNUM)
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) "Returns a sequence formed by destructively removing the elements not satisfying the specified Predicate from the given Sequence."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (IF-NOT-LIST-DELETE-FROM-END)
(IF-NOT-LIST-DELETE))
(CL:IF FROM-END (IF-NOT-MUMBLE-DELETE-FROM-END)
(IF-NOT-MUMBLE-DELETE))))
(DEFMACRO MUMBLE-REMOVE-MACRO (BUMP LEFT BEGIN FINISH RIGHT PRED)
(BQUOTE (CL:DO ((INDEX (\, BEGIN)
((\, BUMP)
INDEX))
(RESULT (CL:DO ((INDEX (\, LEFT)
((\, BUMP)
INDEX))
(RESULT (MAKE-SEQUENCE-LIKE SEQUENCE LENGTH)))
((= INDEX (\, BEGIN))
RESULT)
(SETF (AREF RESULT INDEX)
(AREF SEQUENCE INDEX))))
(NEW-INDEX (\, BEGIN))
(NUMBER-ZAPPED 0)
(THIS-ELEMENT))
((OR (= INDEX (\, FINISH))
(= NUMBER-ZAPPED COUNT))
(CL:DO ((INDEX INDEX ((\, BUMP)
INDEX))
(NEW-INDEX NEW-INDEX ((\, BUMP)
NEW-INDEX)))
((= INDEX (\, RIGHT))
(SHRINK-VECTOR RESULT NEW-INDEX))
(SETF (AREF RESULT NEW-INDEX)
(AREF SEQUENCE INDEX))))
(LET ((THIS-ELEMENT (AREF SEQUENCE INDEX)))
(COND
((\, PRED)
(SETF (AREF RESULT NEW-INDEX)
THIS-ELEMENT)
(SETQ NEW-INDEX ((\, BUMP)
NEW-INDEX)))
(T (INCF NUMBER-ZAPPED)))))))
(DEFMACRO MUMBLE-REMOVE (PRED) (BQUOTE (MUMBLE-REMOVE-MACRO 1+ 0 START END LENGTH (\, PRED))))
(DEFMACRO MUMBLE-REMOVE-FROM-END (PRED) (BQUOTE (LET ((SEQUENCE (COPY-SEQ SEQUENCE)))
(MUMBLE-DELETE-FROM-END (NOT (\, PRED))))))
(DEFMACRO LIST-REMOVE-MACRO (PRED REVERSE?)
(BQUOTE (LET* ((\,@ (CL:WHEN REVERSE? (QUOTE ((SEQUENCE (REVERSE SEQUENCE))))))
(SPLICE (LIST NIL))
(RESULTS (CL:DO ((INDEX 0 (1+ INDEX))
(BEFORE-START SPLICE))
((= INDEX START)
BEFORE-START)
(SETQ SPLICE (CDR (RPLACD SPLICE (CONS (CL:POP SEQUENCE)
NIL)))))))
(CL:DO ((INDEX START (1+ INDEX))
(THIS-ELEMENT)
(NUMBER-ZAPPED 0))
((OR (= INDEX END)
(= NUMBER-ZAPPED COUNT))
(CL:DO ((INDEX INDEX (1+ INDEX)))
((NULL SEQUENCE)
(\, (CL:IF REVERSE? (QUOTE (REVERSE (CDR RESULTS)))
(QUOTE (CDR RESULTS)))))
(SETQ SPLICE (CDR (RPLACD SPLICE (CONS (CL:POP SEQUENCE)
NIL))))))
(SETQ THIS-ELEMENT (CL:POP SEQUENCE))
(CL:IF (\, PRED)
(SETQ SPLICE (CDR (RPLACD SPLICE (CONS THIS-ELEMENT NIL))))
(INCF NUMBER-ZAPPED))))))
(DEFMACRO LIST-REMOVE (PRED) (BQUOTE (LIST-REMOVE-MACRO (\, PRED)
NIL)))
(DEFMACRO LIST-REMOVE-FROM-END (PRED) (BQUOTE (LIST-REMOVE-MACRO (\, PRED)
T)))
(DEFMACRO NORMAL-MUMBLE-REMOVE NIL (BQUOTE (MUMBLE-REMOVE (CL:IF TEST-NOT (FUNCALL TEST-NOT ITEM
(FUNCALL KEY
THIS-ELEMENT)
)
(NOT (FUNCALL TEST ITEM
(FUNCALL KEY
THIS-ELEMENT)))))
))
(DEFMACRO NORMAL-MUMBLE-REMOVE-FROM-END NIL (BQUOTE (MUMBLE-REMOVE-FROM-END
(CL:IF TEST-NOT (FUNCALL TEST-NOT ITEM
(FUNCALL KEY THIS-ELEMENT
))
(NOT (FUNCALL TEST ITEM (FUNCALL KEY
THIS-ELEMENT
)))))))
(DEFMACRO NORMAL-LIST-REMOVE NIL (BQUOTE (LIST-REMOVE (CL:IF TEST-NOT (FUNCALL TEST-NOT ITEM
(FUNCALL KEY
THIS-ELEMENT))
(NOT (FUNCALL TEST ITEM (FUNCALL KEY
THIS-ELEMENT
)))))))
(DEFMACRO NORMAL-LIST-REMOVE-FROM-END NIL (BQUOTE (LIST-REMOVE-FROM-END
(CL:IF TEST-NOT (FUNCALL TEST-NOT ITEM
(FUNCALL KEY THIS-ELEMENT))
(NOT (FUNCALL TEST ITEM (FUNCALL KEY
THIS-ELEMENT
)))))))
(DEFUN CL:REMOVE (ITEM SEQUENCE &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT
(START 0)
END
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) (* raf " 3-Dec-85 23:31")
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (NORMAL-LIST-REMOVE-FROM-END)
(NORMAL-LIST-REMOVE))
(CL:IF FROM-END (NORMAL-MUMBLE-REMOVE-FROM-END)
(NORMAL-MUMBLE-REMOVE))))
(DEFMACRO IF-MUMBLE-REMOVE NIL (BQUOTE (MUMBLE-REMOVE (NOT (FUNCALL PREDICATE (FUNCALL KEY
THIS-ELEMENT))))
))
(DEFMACRO IF-MUMBLE-REMOVE-FROM-END NIL (BQUOTE (MUMBLE-REMOVE-FROM-END (NOT (FUNCALL PREDICATE
(FUNCALL KEY
THIS-ELEMENT
))))))
(DEFMACRO IF-LIST-REMOVE NIL (BQUOTE (LIST-REMOVE (NOT (FUNCALL PREDICATE (FUNCALL KEY THIS-ELEMENT))
))))
(DEFMACRO IF-LIST-REMOVE-FROM-END NIL (BQUOTE (LIST-REMOVE-FROM-END (NOT (FUNCALL PREDICATE
(FUNCALL KEY
THIS-ELEMENT))
))))
(DEFUN REMOVE-IF (PREDICATE SEQUENCE &KEY FROM-END (START 0)
END
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE)))
"Returns a copy of sequence with elements such that predicate(element) is non-null are removed"
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (IF-LIST-REMOVE-FROM-END)
(IF-LIST-REMOVE))
(CL:IF FROM-END (IF-MUMBLE-REMOVE-FROM-END)
(IF-MUMBLE-REMOVE))))
(DEFMACRO IF-NOT-MUMBLE-REMOVE NIL (BQUOTE (MUMBLE-REMOVE (FUNCALL PREDICATE (FUNCALL KEY
THIS-ELEMENT)))))
(DEFMACRO IF-NOT-MUMBLE-REMOVE-FROM-END NIL (BQUOTE (MUMBLE-REMOVE-FROM-END (FUNCALL PREDICATE
(FUNCALL KEY
THIS-ELEMENT
)))))
(DEFMACRO IF-NOT-LIST-REMOVE NIL (BQUOTE (LIST-REMOVE (FUNCALL PREDICATE (FUNCALL KEY THIS-ELEMENT)))
))
(DEFMACRO IF-NOT-LIST-REMOVE-FROM-END NIL (BQUOTE (LIST-REMOVE-FROM-END (FUNCALL PREDICATE
(FUNCALL KEY
THIS-ELEMENT)))
))
(DEFUN REMOVE-IF-NOT (PREDICATE SEQUENCE &KEY FROM-END (START 0)
END
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE)))
"Returns a copy of sequence with elements such that predicate(element) is null are removed"
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (IF-NOT-LIST-REMOVE-FROM-END)
(IF-NOT-LIST-REMOVE))
(CL:IF FROM-END (IF-NOT-MUMBLE-REMOVE-FROM-END)
(IF-NOT-MUMBLE-REMOVE))))
(DEFUN LIST-REMOVE-DUPLICATES* (LIST TEST TEST-NOT START END KEY FROM-END)
(LET* ((RESULT (LIST NIL))
(SPLICE RESULT)
(CURRENT LIST))
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX START))
(SETQ SPLICE (CDR (RPLACD SPLICE (LIST (CAR CURRENT)))))
(CL:POP CURRENT)) (* "RESULT now holds the head of the list up to, but not including start. SPLICE points to the next cell to be RPLACD'ed. CURRENT is the tail to be processed.")
(CL:DO ((SUBLIST (CDR SPLICE))
(INDEX START (1+ INDEX)))
((OR (AND END (>= INDEX END))
(ENDP CURRENT)))
(CL:UNLESS (CL:IF FROM-END (CL:MEMBER (FUNCALL KEY (CAR CURRENT))
(NTHCDR START (CDR RESULT))
:TEST TEST :TEST-NOT TEST-NOT :KEY KEY)
(CL:DO ((IT (FUNCALL KEY (CAR CURRENT)))
(L (CDR CURRENT)
(CDR L))
(I (1+ INDEX)
(1+ I)))
((OR (ENDP L)
(>= I END))
NIL)
(CL:WHEN (CL:IF TEST-NOT (NOT (FUNCALL TEST-NOT IT
(FUNCALL KEY
(CAR L))))
(FUNCALL TEST IT (FUNCALL KEY (CAR L))))
(RETURN T))))
(SETQ SPLICE (CDR (RPLACD SPLICE (LIST (CAR CURRENT))))))
(CL:POP CURRENT))
(RPLACD SPLICE CURRENT)
(CDR RESULT)))
(DEFUN VECTOR-REMOVE-DUPLICATES* (VECTOR TEST TEST-NOT START END KEY FROM-END &OPTIONAL
(LENGTH (CL:LENGTH VECTOR)))
(DECLARE (TYPE VECTOR VECTOR)) (* raf "17-Dec-85 22:38")
(LET ((RESULT (MAKE-SEQUENCE-LIKE VECTOR LENGTH))
(INDEX 0)
(JNDEX START))
(CL:DO NIL ((= INDEX START))
(SETF (AREF RESULT INDEX)
(AREF VECTOR INDEX))
(INCF INDEX))
(CL:DO NIL ((= INDEX END))
(LET ((ELT (AREF VECTOR INDEX)))
(COND
((NOT (CL:IF FROM-END
(CL:POSITION (FUNCALL KEY ELT)
RESULT :START START :END JNDEX :TEST TEST :TEST-NOT
TEST-NOT :KEY KEY)
(CL:POSITION (FUNCALL KEY ELT)
VECTOR :START (1+ INDEX)
:END END :TEST TEST :TEST-NOT TEST-NOT :KEY KEY)))
(SETF (AREF RESULT JNDEX)
ELT)
(INCF JNDEX))))
(INCF INDEX))
(CL:DO NIL ((= INDEX LENGTH))
(SETF (AREF RESULT JNDEX)
(AREF VECTOR INDEX))
(INCF INDEX)
(INCF JNDEX))
(SHRINK-VECTOR RESULT JNDEX)))
(DEFUN REMOVE-DUPLICATES (SEQUENCE &KEY (TEST (FUNCTION EQL))
TEST-NOT
(START 0)
FROM-END END (KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) "The elements of Sequence are examined, and if any two match, one is discarded. The resulting sequence is returned."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (CL:WHEN SEQUENCE (LIST-REMOVE-DUPLICATES* SEQUENCE TEST TEST-NOT START END
KEY FROM-END))
(VECTOR-REMOVE-DUPLICATES* SEQUENCE TEST TEST-NOT START END KEY FROM-END)))
(DEFUN LIST-DELETE-DUPLICATES* (LIST TEST TEST-NOT KEY FROM-END START END)
(LET ((HANDLE (CONS NIL LIST)))
(CL:DO ((CURRENT (NTHCDR START LIST)
(CDR CURRENT))
(PREVIOUS (NTHCDR START HANDLE))
(INDEX START (1+ INDEX)))
((OR (= INDEX END)
(NULL CURRENT))
(CDR HANDLE))
(CL:IF (CL:DO ((X (CL:IF FROM-END (NTHCDR (1+ START)
HANDLE)
(CDR CURRENT))
(CDR X))
(I (1+ INDEX)
(1+ I)))
((OR (NULL X)
(AND (NOT FROM-END)
(= I END))
(EQ X CURRENT))
NIL)
(CL:WHEN (CL:IF TEST-NOT (NOT (FUNCALL TEST-NOT (FUNCALL KEY
(CAR CURRENT))
(FUNCALL KEY (CAR X))))
(FUNCALL TEST (FUNCALL KEY (CAR CURRENT))
(FUNCALL KEY (CAR X))))
(RETURN T)))
(RPLACD PREVIOUS (CDR CURRENT))
(CL:POP PREVIOUS)))))
(DEFUN VECTOR-DELETE-DUPLICATES* (VECTOR TEST TEST-NOT KEY FROM-END START END &OPTIONAL
(LENGTH (CL:LENGTH VECTOR)))
(DECLARE (TYPE VECTOR VECTOR)) (* raf "17-Dec-85 22:39")
(CL:DO ((INDEX START (1+ INDEX))
(JNDEX START))
((= INDEX END)
(CL:DO ((INDEX INDEX (1+ INDEX))
(JNDEX JNDEX (1+ JNDEX)))
((= INDEX LENGTH)
(SHRINK-VECTOR VECTOR JNDEX)
VECTOR)
(SETF (AREF VECTOR JNDEX)
(AREF VECTOR INDEX))))
(SETF (AREF VECTOR JNDEX)
(AREF VECTOR INDEX))
(CL:UNLESS (CL:POSITION (FUNCALL KEY (AREF VECTOR INDEX))
VECTOR :KEY KEY :TEST TEST :TEST-NOT TEST-NOT :START (CL:IF FROM-END
START
(1+ INDEX))
:END
(CL:IF FROM-END JNDEX END))
(INCF JNDEX))))
(DEFUN DELETE-DUPLICATES (SEQUENCE &KEY (TEST (FUNCTION EQL))
TEST-NOT
(START 0)
FROM-END END (KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) "The elements of Sequence are examined, and if any two match, one is discarded. The resulting sequence, which may be formed by destroying the given sequence, is returned."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SEQ-DISPATCH SEQUENCE (COND
(SEQUENCE (LIST-DELETE-DUPLICATES* SEQUENCE TEST TEST-NOT KEY FROM-END
START END))
(T NIL))
(VECTOR-DELETE-DUPLICATES* SEQUENCE TEST TEST-NOT KEY FROM-END START END)))
(DEFMACRO SUBST-DISPATCH (PRED) (BQUOTE (SEQ-DISPATCH SEQUENCE
(CL:IF FROM-END (REVERSE (LIST-SUBSTITUTE*
(\, PRED)
NEW
(REVERSE SEQUENCE)
(- LENGTH END)
(- LENGTH START)
COUNT KEY TEST TEST-NOT OLD)
)
(LIST-SUBSTITUTE* (\, PRED)
NEW SEQUENCE START END COUNT KEY TEST
TEST-NOT OLD))
(CL:IF FROM-END (VECTOR-SUBSTITUTE* (\, PRED)
NEW SEQUENCE -1 (1- LENGTH)
-1 LENGTH (1- END)
(1- START)
COUNT KEY TEST TEST-NOT OLD)
(VECTOR-SUBSTITUTE* (\, PRED)
NEW SEQUENCE 1 0 LENGTH LENGTH START END
COUNT KEY TEST TEST-NOT OLD)))))
(DEFUN LIST-SUBSTITUTE* (PRED NEW LIST START END COUNT KEY TEST TEST-NOT OLD)
(* kbr: "31-Aug-85 20:01")
(LET* ((RESULT (LIST NIL))
(SPLICE RESULT)
(LIST LIST)) (* " Get a local list for a stepper."
*)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX START))
(SETQ SPLICE (CDR (RPLACD SPLICE (LIST (CAR LIST)))))
(CL:POP LIST)) (*
"SPLICE points to the place to append to, LIST is now the appropriate tail to work on.")
(CL:DO ((INDEX START (1+ INDEX)))
((OR (AND END (= INDEX END))
(ENDP LIST)
(= COUNT 0)))
(LET ((ELT (CL:POP LIST)))
(SETQ SPLICE
(CDR (RPLACD SPLICE
(LIST (COND
((ECASE PRED (NORMAL (CL:IF TEST-NOT
(NOT (FUNCALL TEST-NOT OLD
(FUNCALL KEY ELT))
)
(FUNCALL TEST OLD
(FUNCALL KEY ELT))))
(IF (FUNCALL TEST (FUNCALL KEY ELT)))
(IF-NOT (NOT (FUNCALL TEST (FUNCALL KEY ELT)))))
(DECF COUNT)
NEW)
(T ELT))))))))
(RPLACD SPLICE LIST)
(CDR RESULT)))
(DEFUN VECTOR-SUBSTITUTE* (PRED NEW SEQUENCE INCREMENTER LEFT RIGHT LENGTH START END COUNT KEY TEST
TEST-NOT OLD) (* kbr: "31-Aug-85 20:01")
(LET ((RESULT (MAKE-SEQUENCE-LIKE SEQUENCE LENGTH))
(INDEX LEFT))
(CL:DO NIL ((= INDEX START))
(SETF (AREF RESULT INDEX)
(AREF SEQUENCE INDEX))
(INCF INDEX INCREMENTER))
(CL:DO ((ELT))
((OR (= INDEX END)
(= COUNT 0)))
(SETQ ELT (AREF SEQUENCE INDEX))
(SETF (AREF RESULT INDEX)
(COND
((CASE PRED (NORMAL (CL:IF TEST-NOT (NOT (FUNCALL TEST-NOT OLD
(FUNCALL KEY ELT)))
(FUNCALL TEST OLD (FUNCALL KEY ELT))))
(IF (FUNCALL TEST (FUNCALL KEY ELT)))
(IF-NOT (NOT (FUNCALL TEST (FUNCALL KEY ELT)))))
(DECF COUNT)
NEW)
(T ELT)))
(INCF INDEX INCREMENTER))
(CL:DO NIL ((= INDEX RIGHT))
(SETF (AREF RESULT INDEX)
(AREF SEQUENCE INDEX))
(INCF INDEX INCREMENTER))
RESULT))
(DEFUN SUBSTITUTE (NEW OLD SEQUENCE &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT
(START 0)
(COUNT MOST-POSITIVE-FIXNUM)
END
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(SUBST-DISPATCH (QUOTE NORMAL)))
(DEFUN SUBSTITUTE-IF (NEW TEST SEQUENCE &KEY FROM-END (START 0)
END
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) "Returns a sequence of the same kind as Sequence with the same elements except that all elements satisfying the Test are replaced with New."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(LET (TEST-NOT OLD)
(SUBST-DISPATCH (QUOTE IF))))
(DEFUN SUBSTITUTE-IF-NOT (NEW TEST SEQUENCE &KEY FROM-END (START 0)
END
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) "Returns a sequence of the same kind as Sequence with the same elements except that all elements not satisfying the Test are replaced with New."
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(LET (TEST-NOT OLD)
(SUBST-DISPATCH (QUOTE IF-NOT))))
(DEFUN NLIST-SUBSTITUTE* (NEW OLD SEQUENCE TEST TEST-NOT START END COUNT KEY)
(CL:DO ((LIST (NTHCDR START SEQUENCE)
(CDR LIST))
(INDEX START (1+ INDEX)))
((OR (AND END (= INDEX END))
(ENDP LIST)
(= COUNT 0))
SEQUENCE)
(COND
((CL:IF TEST-NOT (NOT (FUNCALL TEST-NOT OLD (FUNCALL KEY (CAR LIST))))
(FUNCALL TEST OLD (FUNCALL KEY (CAR LIST))))
(RPLACA LIST NEW)
(DECF COUNT)))))
(DEFUN NVECTOR-SUBSTITUTE* (NEW OLD SEQUENCE INCREMENTER TEST TEST-NOT START END COUNT KEY)
(CL:DO ((INDEX START (+ INDEX INCREMENTER)))
((OR (= INDEX END)
(= COUNT 0))
SEQUENCE)
(COND
((CL:IF TEST-NOT (NOT (FUNCALL TEST-NOT OLD (FUNCALL KEY (AREF SEQUENCE INDEX))))
(FUNCALL TEST OLD (FUNCALL KEY (AREF SEQUENCE INDEX))))
(SETF (AREF SEQUENCE INDEX)
NEW)
(DECF COUNT)))))
(DEFUN NSUBSTITUTE (NEW OLD SEQUENCE &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT END (COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
(START 0)
&KEY
(LENGTH (CL:LENGTH SEQUENCE))) (* raf "27-Jan-86 17:31")
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(LET ((INCREMENTER 1))
(CL:WHEN FROM-END (PSETQ START (1- END)
END
(1- START)
INCREMENTER -1))
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (DREVERSE (NLIST-SUBSTITUTE* NEW OLD (DREVERSE
SEQUENCE)
TEST TEST-NOT START END COUNT KEY))
(NLIST-SUBSTITUTE* NEW OLD SEQUENCE TEST TEST-NOT START END
COUNT KEY))
(NVECTOR-SUBSTITUTE* NEW OLD SEQUENCE INCREMENTER TEST TEST-NOT START END COUNT KEY))))
(DEFUN NLIST-SUBSTITUTE-IF* (NEW TEST SEQUENCE START END COUNT KEY)
(CL:DO ((LIST (NTHCDR START SEQUENCE)
(CDR LIST))
(INDEX START (1+ INDEX)))
((OR (AND END (= INDEX END))
(ENDP LIST)
(= COUNT 0))
SEQUENCE)
(COND
((FUNCALL TEST (FUNCALL KEY (CAR LIST)))
(RPLACA LIST NEW)
(DECF COUNT)))))
(DEFUN NVECTOR-SUBSTITUTE-IF* (NEW TEST SEQUENCE INCREMENTER START END COUNT KEY)
(CL:DO ((INDEX START (+ INDEX INCREMENTER)))
((OR (= INDEX END)
(= COUNT 0))
SEQUENCE)
(COND
((FUNCALL TEST (FUNCALL KEY (AREF SEQUENCE INDEX)))
(SETF (AREF SEQUENCE INDEX)
NEW)
(DECF COUNT)))))
(DEFUN NSUBSTITUTE-IF (NEW TEST SEQUENCE &KEY FROM-END (START 0)
END
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) (* raf "27-Jan-86 17:31")
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(LET ((INCREMENTER 1))
(CL:WHEN FROM-END (PSETQ START (1- END)
END
(1- START)
INCREMENTER -1))
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (DREVERSE (NLIST-SUBSTITUTE-IF* NEW TEST (DREVERSE
SEQUENCE)
START END COUNT KEY))
(NLIST-SUBSTITUTE-IF* NEW TEST SEQUENCE START END COUNT KEY))
(NVECTOR-SUBSTITUTE-IF* NEW TEST SEQUENCE INCREMENTER START END COUNT KEY))))
(DEFUN NLIST-SUBSTITUTE-IF-NOT* (NEW TEST SEQUENCE START END COUNT KEY)
(CL:DO ((LIST (NTHCDR START SEQUENCE)
(CDR LIST))
(INDEX START (1+ INDEX)))
((OR (AND END (= INDEX END))
(ENDP LIST)
(= COUNT 0))
SEQUENCE)
(COND
((NOT (FUNCALL TEST (FUNCALL KEY (CAR LIST))))
(RPLACA LIST NEW)
(DECF COUNT)))))
(DEFUN NVECTOR-SUBSTITUTE-IF-NOT* (NEW TEST SEQUENCE INCREMENTER START END COUNT KEY)
(CL:DO ((INDEX START (+ INDEX INCREMENTER)))
((OR (= INDEX END)
(= COUNT 0))
SEQUENCE)
(COND
((NOT (FUNCALL TEST (FUNCALL KEY (AREF SEQUENCE INDEX))))
(SETF (AREF SEQUENCE INDEX)
NEW)
(DECF COUNT)))))
(DEFUN NSUBSTITUTE-IF-NOT (NEW TEST SEQUENCE &KEY FROM-END (START 0)
END
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
&AUX
(LENGTH (CL:LENGTH SEQUENCE)))
(* raf "27-Jan-86 17:31")
(CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(LET ((INCREMENTER 1))
(CL:WHEN FROM-END (PSETQ START (1- END)
END
(1- START)
INCREMENTER -1))
(SEQ-DISPATCH SEQUENCE (CL:IF FROM-END (DREVERSE (NLIST-SUBSTITUTE-IF-NOT* NEW TEST
(DREVERSE SEQUENCE)
START END COUNT KEY))
(NLIST-SUBSTITUTE-IF-NOT* NEW TEST SEQUENCE START END COUNT KEY
))
(NVECTOR-SUBSTITUTE-IF-NOT* NEW TEST SEQUENCE INCREMENTER START END COUNT KEY))))
(PUTPROPS CMLSEQMODIFY FILETYPE COMPILE-FILE)
(PUTPROPS CMLSEQMODIFY COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP