(FILECREATED "11-Jun-86 16:13:57" {ERIS}<LISPCORE>LIBRARY>CMLSEQ.;23 152484
changes to: (FUNCTIONS CL:ELT %%SETELT SUBSEQ LIST-SUBSEQ*)
(STRUCTURES INDEX-BOUNDS-ERROR)
(VARS CMLSEQCOMS)
previous date: " 9-Jun-86 20:03:44" {ERIS}<DANIELS>CML>CMLSEQ.;10)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSEQCOMS)
(RPAQQ CMLSEQCOMS ((STRUCTURES INDEX-BOUNDS-ERROR)
(FUNCTIONS SEQ-DISPATCH TYPE-SPECIFIER MAKE-SEQUENCE-LIKE)
(FUNCTIONS CONCATENATE-TO-MUMBLE)
(* "Not used.")
(FNS CL:COERCE LIST-TO-STRING* LIST-TO-BIT-VECTOR* LIST-TO-VECTOR* VECTOR-TO-LIST*
VECTOR-TO-VECTOR* VECTOR-TO-STRING* VECTOR-TO-BIT-VECTOR*
STRING-TO-SIMPLE-STRING* BIT-VECTOR-TO-SIMPLE-BIT-VECTOR*)
(* "Left over.")
(PROP DMACRO CL:EVERY)
(* "Should be an optimizer")
(FUNCTIONS MAKE-SEQUENCE-OF-TYPE)
(COMS (FUNCTIONS CL:ELT %%SETELT)
(SETFS CL:ELT)
(* "Should be removed from CMLSETF"))
(COMS (FUNCTIONS SUBSEQ LIST-SUBSEQ* VECTOR-SUBSEQ*)
(SETFS SUBSEQ)
(* "Should be removed from CMLSETF"))
(FUNCTIONS COPY-SEQ LIST-COPY-SEQ LIST-COPY-SEQ* VECTOR-COPY-SEQ VECTOR-COPY-SEQ*)
(FUNCTIONS CL:LENGTH)
(FUNCTIONS CL:REVERSE LIST-REVERSE-MACRO VECTOR-REVERSE VECTOR-REVERSE*)
(FUNCTIONS CL:NREVERSE LIST-NREVERSE-MACRO LIST-NREVERSE* VECTOR-NREVERSE
VECTOR-NREVERSE*)
(FUNCTIONS MAKE-SEQUENCE)
(FUNCTIONS CONCATENATE CONCATENATE-TO-LIST CONCAT-TO-LIST* CONCAT-TO-SIMPLE*)
(FUNCTIONS ELT-SLICE MAP-FOR-EFFECT MAP-TO-LIST MAP-TO-SIMPLE CL:MAP)
(FUNCTIONS CL:SOME CL:EVERY CL:NOTANY CL:NOTEVERY)
(FUNCTIONS LIST-REDUCE-FROM-END LIST-REDUCE MUMBLE-REDUCE-FROM-END MUMBLE-REDUCE
REDUCE)
(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)
(FUNCTIONS VECTOR-FIND LIST-FIND VECTOR-FIND-IF LIST-FIND-IF VECTOR-FIND-IF-NOT
LIST-FIND-IF-NOT LIST-FIND* VECTOR-FIND* CL:FIND FIND-IF FIND-IF-NOT)
(FUNCTIONS VECTOR-POSITION VECTOR-POSITION-IF LIST-POSITION LIST-POSITION-IF
VECTOR-POSITION-IF-NOT LIST-POSITION-IF-NOT LIST-POSITION* VECTOR-POSITION*
CL:POSITION POSITION-IF POSITION-IF-NOT)
(FUNCTIONS VECTOR-COUNT LIST-COUNT VECTOR-COUNT-IF LIST-COUNT-IF
VECTOR-COUNT-IF-NOT LIST-COUNT-IF-NOT CL:COUNT COUNT-IF COUNT-IF-NOT)
(FUNCTIONS MATCH-VARS MATCHIFY-LIST IF-MISMATCH MUMBLE-MUMBLE-MISMATCH
MUMBLE-LIST-MISMATCH LIST-MUMBLE-MISMATCH LIST-LIST-MISMATCH MISMATCH)
(FUNCTIONS COMPARE-ELEMENTS SEARCH-COMPARE-LIST-LIST SEARCH-COMPARE-LIST-VECTOR
SEARCH-COMPARE-VECTOR-LIST SEARCH-COMPARE-VECTOR-VECTOR SEARCH-COMPARE
LIST-SEARCH VECTOR-SEARCH SEARCH)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* STRING-TO-SIMPLE-STRING*
VECTOR-TO-BIT-VECTOR* VECTOR-TO-STRING* VECTOR-TO-VECTOR*
VECTOR-TO-LIST* LIST-TO-VECTOR* LIST-TO-BIT-VECTOR*
LIST-TO-STRING* CL:COERCE)))))
(DEFINE-CONDITION INDEX-BOUNDS-ERROR CELL-ERROR :REPORT (FORMAT T "Index out of bounds: ~D."
(INDEX-BOUNDS-ERROR-INDEX CONDITION))
INDEX)
(DEFMACRO SEQ-DISPATCH (SEQUENCE LIST-FORM ARRAY-FORM) (BQUOTE (CL:IF (CL:LISTP (\, SEQUENCE))
(\, LIST-FORM)
(\, ARRAY-FORM))))
(DEFMACRO TYPE-SPECIFIER (TYPE) "Returns the broad class of which TYPE is a specific subclass."
(BQUOTE (CL:IF (CL:ATOM (\, TYPE))
(\, TYPE)
(CAR (\, TYPE)))))
(DEFMACRO MAKE-SEQUENCE-LIKE (SEQUENCE LENGTH)
"Returns a sequence of the same type as SEQUENCE and the given LENGTH."
(BQUOTE (MAKE-SEQUENCE-OF-TYPE (TYPE-OF (\, SEQUENCE))
(\, LENGTH))))
(DEFMACRO CONCATENATE-TO-MUMBLE (OUTPUT-TYPE-SPEC SEQUENCES)
(BQUOTE (CL:DO ((SEQS (\, SEQUENCES)
(CDR SEQS))
(TOTAL-LENGTH 0)
(LENGTHS NIL))
((NULL SEQS)
(CL:DO ((SEQUENCES (\, SEQUENCES)
(CDR SEQUENCES))
(LENGTHS LENGTHS (CDR LENGTHS))
(INDEX 0)
(RESULT (MAKE-SEQUENCE-OF-TYPE (\, OUTPUT-TYPE-SPEC)
TOTAL-LENGTH)))
((= INDEX TOTAL-LENGTH)
RESULT)
(LET ((SEQUENCE (CAR SEQUENCES)))
(SEQ-DISPATCH SEQUENCE (CL:DO ((SEQUENCE SEQUENCE (CDR SEQUENCE)))
((CL:ATOM SEQUENCE))
(SETF (AREF RESULT INDEX)
(CAR SEQUENCE))
(INCF INDEX))
(CL:DO ((JNDEX 0 (1+ JNDEX)))
((= JNDEX (CAR LENGTHS)))
(SETF (AREF RESULT INDEX)
(AREF SEQUENCE JNDEX))
(INCF INDEX))))))
(LET ((LENGTH (CL:LENGTH (CAR SEQS))))
(SETQ LENGTHS (NCONC LENGTHS (LIST LENGTH)))
(INCF TOTAL-LENGTH LENGTH)))))
(* "Not used.")
(DEFINEQ
(CL:COERCE
(CL:LAMBDA (OBJECT OUTPUT-TYPE-SPEC) (* amd " 9-Jun-86 17:32")
(COND
((TYPEP OBJECT OUTPUT-TYPE-SPEC)
OBJECT)
((EQ OUTPUT-TYPE-SPEC (QUOTE CHARACTER))
(CHARACTER OBJECT))
((NUMBERP OBJECT)
(CASE OUTPUT-TYPE-SPEC ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
(FLOAT OBJECT))
(COMPLEX (CL:ERROR "Complex numbers not supported in current implementation."))
(T (CL:ERROR "~S can't be converted to type ~S." OBJECT OUTPUT-TYPE-SPEC))))
(T (TYPECASE OBJECT (LIST (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
((SIMPLE-STRING STRING)
(LIST-TO-STRING* OBJECT))
((SIMPLE-BIT-VECTOR BIT-VECTOR)
(LIST-TO-BIT-VECTOR* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(LIST-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(SIMPLE-STRING (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(SIMPLE-BIT-VECTOR (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(SIMPLE-VECTOR (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
((SIMPLE-STRING STRING)
(VECTOR-TO-STRING* OBJECT))
((SIMPLE-BIT-VECTOR BIT-VECTOR)
(VECTOR-TO-BIT-VECTOR* OBJECT))
((VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(STRING (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
(SIMPLE-STRING (STRING-TO-SIMPLE-STRING* OBJECT))
((SIMPLE-VECTOR VECTOR SIMPLE-ARRAY ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(BIT-VECTOR (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
(SIMPLE-BIT-VECTOR (BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(VECTOR (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
((SIMPLE-STRING STRING)
(VECTOR-TO-STRING* OBJECT))
((SIMPLE-BIT-VECTOR BIT-VECTOR)
(VECTOR-TO-BIT-VECTOR* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(T (CL:ERROR "~S is an inappropriate type of object for coerce." OBJECT)))))))
(LIST-TO-STRING*
(CL:LAMBDA (OBJECT) (* raf "17-Dec-85 22:41")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (LIST-LENGTH* OBJECT))
(RESULT (MAKE-STRING CL:LENGTH)))
((= INDEX CL:LENGTH)
RESULT)
(SETF (SCHAR RESULT INDEX)
(pop OBJECT)))))
(LIST-TO-BIT-VECTOR*
(CL:LAMBDA (OBJECT) (* raf "17-Dec-85 22:42")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (LIST-LENGTH* OBJECT))
(RESULT (MAKE-ARRAY CL:LENGTH :ELEMENT-TYPE (QUOTE (MOD 2)))))
((= INDEX CL:LENGTH)
RESULT)
(DECLARE (TYPE FIXNUM CL:LENGTH))
(SETF (SBIT RESULT INDEX)
(pop OBJECT)))))
(LIST-TO-VECTOR*
(CL:LAMBDA (OBJECT TYPE) (* raf "17-Dec-85 22:42")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (LIST-LENGTH* OBJECT))
(RESULT (MAKE-SEQUENCE-OF-TYPE TYPE CL:LENGTH)))
((= INDEX CL:LENGTH)
RESULT)
(SETF (AREF RESULT INDEX)
(pop OBJECT)))))
(VECTOR-TO-LIST*
(CL:LAMBDA (OBJECT)
(LET ((RESULT (LIST NIL))
(CL:LENGTH (CL:LENGTH OBJECT)))
(CL:DO ((INDEX 0 (1+ INDEX))
(SPLICE RESULT (CDR SPLICE)))
((= INDEX CL:LENGTH)
(CDR RESULT))
(RPLACD SPLICE (LIST (AREF OBJECT INDEX)))))))
(VECTOR-TO-VECTOR*
(CL:LAMBDA (OBJECT TYPE) (* raf "17-Dec-85 22:42")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-SEQUENCE-OF-TYPE TYPE CL:LENGTH)))
((= INDEX CL:LENGTH)
RESULT)
(SETF (AREF RESULT INDEX)
(AREF OBJECT INDEX)))))
(VECTOR-TO-STRING*
(CL:LAMBDA (OBJECT) (* raf "17-Dec-85 22:42")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-STRING CL:LENGTH)))
((= INDEX CL:LENGTH)
RESULT)
(SETF (SCHAR RESULT INDEX)
(AREF OBJECT INDEX)))))
(VECTOR-TO-BIT-VECTOR*
(CL:LAMBDA (OBJECT) (* raf "17-Dec-85 22:43")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-ARRAY CL:LENGTH :ELEMENT-TYPE (QUOTE (MOD 2)))))
((= INDEX CL:LENGTH)
RESULT)
(DECLARE (TYPE FIXNUM CL:LENGTH))
(SETF (SBIT RESULT INDEX)
(AREF OBJECT INDEX)))))
(STRING-TO-SIMPLE-STRING*
(CL:LAMBDA (OBJECT) (* raf "18-Dec-85 01:52")
(COND
((SIMPLE-STRING-P OBJECT)
OBJECT)
(T (CL:DO* ((LENGTH (CL:LENGTH OBJECT))
(SIMPLE-STRING (ALLOCSTRING LENGTH))
(I 0 (1+ I)))
((= I LENGTH)
SIMPLE-STRING)
(SETF (AREF OBJECT I)
(AREF SIMPLE-STRING I)))))))
(BIT-VECTOR-TO-SIMPLE-BIT-VECTOR*
(CL:LAMBDA (OBJECT) (* raf "18-Dec-85 01:53")
(COND
((SIMPLE-BIT-VECTOR-P OBJECT)
OBJECT)
(T (CL:DO* ((LENGTH (CL:LENGTH OBJECT))
(SIMPLE-BIT-VECTOR (MAKE-ARRAY LENGTH :ELEMENT-TYPE (QUOTE BIT)))
(I 0 (1+ I)))
((= I LENGTH)
SIMPLE-BIT-VECTOR)
(SETF (AREF OBJECT I)
(AREF SIMPLE-BIT-VECTOR I)))))))
)
(* "Left over.")
(PUTPROPS CL:EVERY DMACRO
(DEFMACRO (FUNCTION &REST LISTS) (LET
((GENSYM (GENSYM))
(TAIL-VARS (for X in LISTS collect (GENSYM))))
(BQUOTE
(LET
(((\, GENSYM)
T))
(CL:DO
((\,@ (for X in LISTS as TAIL-VAR in TAIL-VARS collect
(LIST TAIL-VAR X (BQUOTE
(CDR (\, TAIL-VAR)))))))
((NOT (AND (\,@ TAIL-VARS)))
(\, GENSYM))
(OR
(SETQ
(\, GENSYM)
(AND
(\, GENSYM)
(FUNCALL
(\, FUNCTION)
(\,@ (for X in TAIL-VARS collect
(BQUOTE (CAR (\, X))))))))
(RETURN NIL)))))) )
)
(* "Should be an optimizer")
(DEFUN MAKE-SEQUENCE-OF-TYPE (TYPE LENGTH) (* raf "27-Jan-86 17:30")
(CASE (TYPE-SPECIFIER TYPE)
(LIST (MAKE-LIST LENGTH))
((BIT-VECTOR SIMPLE-BIT-VECTOR)
(MAKE-ARRAY LENGTH :ELEMENT-TYPE (QUOTE (MOD 2))))
((STRING SIMPLE-STRING)
(MAKE-STRING LENGTH))
(SIMPLE-VECTOR (MAKE-ARRAY LENGTH))
((ARRAY SIMPLE-ARRAY VECTOR)
(CL:IF (CL:LISTP TYPE)
(MAKE-ARRAY LENGTH :ELEMENT-TYPE (CADR TYPE))
(MAKE-ARRAY LENGTH)))
((BIT-VECTOR SIMPLE-BIT-VECTOR)
(MAKE-ARRAY LENGTH :ELEMENT-TYPE (QUOTE (MOD 2))))
(T (CL:ERROR "~S is a bad type specifier for sequence functions." TYPE))))
(DEFUN CL:ELT (SEQUENCE INDEX) (* amd " 5-Jun-86 17:48")
(CL:WHEN (< INDEX 0)
(CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
:NAME SEQUENCE :INDEX INDEX))
(SEQ-DISPATCH SEQUENCE (CL:DO ((COUNT INDEX (1- COUNT)))
((= COUNT 0)
(CL:IF (ENDP SEQUENCE)
(CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
:NAME SEQUENCE :INDEX INDEX)
(CAR SEQUENCE)))
(CL:IF (ENDP SEQUENCE)
(CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
:NAME SEQUENCE :INDEX INDEX)
(CL:POP SEQUENCE)))
(CL:IF (>= INDEX (CL:LENGTH (THE VECTOR SEQUENCE)))
(CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
:NAME SEQUENCE :INDEX INDEX)
(AREF SEQUENCE INDEX))))
(DEFUN %%SETELT (SEQUENCE INDEX NEWVAL) (* raf "27-Jan-86 17:30")
(CL:WHEN (< INDEX 0)
(CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
:NAME SEQUENCE :INDEX INDEX))
(SEQ-DISPATCH SEQUENCE (CL:DO ((COUNT INDEX (1- COUNT))
(SEQ SEQUENCE))
((= COUNT 0)
(CL:IF (ENDP SEQ)
(CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
:NAME SEQUENCE :INDEX INDEX)
(RPLACA SEQ NEWVAL))
NEWVAL)
(CL:IF (ENDP (CDR SEQ))
(CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
:NAME SEQUENCE :INDEX INDEX)
(CL:POP SEQ)))
(CL:IF (>= INDEX (CL:LENGTH (THE VECTOR SEQUENCE)))
(CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
:NAME SEQUENCE :INDEX INDEX)
(SETF (AREF SEQUENCE INDEX)
NEWVAL))))
(DEFSETF CL:ELT %%SETELT)
(* "Should be removed from CMLSETF")
(DEFUN SUBSEQ (SEQUENCE START &OPTIONAL END) (* amd " 2-May-86 13:41")
(SEQ-DISPATCH SEQUENCE (LIST-SUBSEQ* SEQUENCE START END)
(VECTOR-SUBSEQ* SEQUENCE START END)))
(DEFUN LIST-SUBSEQ* (SEQUENCE START &OPTIONAL END)
(DECLARE (TYPE LIST SEQUENCE)) (* amd " 2-May-86 13:40")
(CL:UNLESS (AND END (>= START END))
(LET* ((GROVELED (NTHCDR START SEQUENCE))
(RESULT (LIST (CAR GROVELED))))
(CL:WHEN GROVELED (CL:DO ((LIST (CDR GROVELED)
(CDR LIST))
(SPLICE RESULT (CDR (RPLACD SPLICE (LIST (CAR LIST)))))
(INDEX (1+ START)
(1+ INDEX)))
((OR (ENDP LIST)
(AND END (>= INDEX END)))
RESULT))))))
(DEFUN VECTOR-SUBSEQ* (SEQUENCE START &OPTIONAL (END (CL:LENGTH SEQUENCE)))
(* amd " 2-May-86 13:40")
(DECLARE (TYPE VECTOR SEQUENCE))
(CL:DO ((OLD-INDEX START (1+ OLD-INDEX))
(NEW-INDEX 0 (1+ NEW-INDEX))
(COPY (MAKE-SEQUENCE-LIKE SEQUENCE (- END START))))
((>= OLD-INDEX END)
COPY)
(SETF (AREF COPY NEW-INDEX)
(AREF SEQUENCE OLD-INDEX))))
(DEFSETF SUBSEQ (SEQUENCE START &OPTIONAL END) (NEW-SEQUENCE)
(BQUOTE (PROGN (CL:REPLACE (\, SEQUENCE)
(\, NEW-SEQUENCE)
:START1
(\, START)
:END1
(\, END))
(\, NEW-SEQUENCE))))
(* "Should be removed from CMLSETF")
(DEFUN COPY-SEQ (SEQUENCE) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ."
(SEQ-DISPATCH SEQUENCE (LIST-COPY-SEQ* SEQUENCE)
(VECTOR-COPY-SEQ* SEQUENCE)))
(DEFMACRO LIST-COPY-SEQ (LIST) (BQUOTE (APPEND (\, LIST))))
(DEFUN LIST-COPY-SEQ* (SEQUENCE) (LIST-COPY-SEQ SEQUENCE))
(DEFMACRO VECTOR-COPY-SEQ (SEQUENCE TYPE) (BQUOTE (LET ((LENGTH (CL:LENGTH (THE VECTOR (\, SEQUENCE))
)))
(CL:DO ((INDEX 0 (1+ INDEX))
(COPY (MAKE-SEQUENCE-OF-TYPE
(\, TYPE)
LENGTH)))
((= INDEX LENGTH)
COPY)
(SETF (AREF COPY INDEX)
(AREF (\, SEQUENCE)
INDEX))))))
(DEFUN VECTOR-COPY-SEQ* (SEQUENCE) (VECTOR-COPY-SEQ SEQUENCE (TYPE-OF SEQUENCE)))
(DEFUN CL:LENGTH (SEQUENCE) (* lmm "25-Feb-86 13:06")
(SEQ-DISPATCH SEQUENCE (LENGTH SEQUENCE)
(CL:IF (ARRAY-HAS-FILL-POINTER-P (THE VECTOR SEQUENCE))
(FILL-POINTER SEQUENCE)
(CAR (ARRAY-DIMENSIONS SEQUENCE)))))
(DEFUN CL:REVERSE (SEQUENCE)
"Returns a new sequence containing the same elements but in reverse order."
(SEQ-DISPATCH SEQUENCE (REVERSE SEQUENCE)
(VECTOR-REVERSE* SEQUENCE)))
(DEFMACRO LIST-REVERSE-MACRO (SEQUENCE) (BQUOTE (CL:DO ((NEW-LIST NIL))
((ENDP (\, SEQUENCE))
NEW-LIST)
(CL:PUSH (CL:POP (\, SEQUENCE))
NEW-LIST))))
(DEFMACRO VECTOR-REVERSE (SEQUENCE TYPE) (BQUOTE (LET ((LENGTH (CL:LENGTH (\, SEQUENCE))))
(CL:DO ((FORWARD-INDEX 0 (1+ FORWARD-INDEX))
(BACKWARD-INDEX (1- LENGTH)
(1- BACKWARD-INDEX))
(NEW-SEQUENCE (MAKE-SEQUENCE-OF-TYPE
(\, TYPE)
LENGTH)))
((= FORWARD-INDEX LENGTH)
NEW-SEQUENCE)
(SETF (AREF NEW-SEQUENCE FORWARD-INDEX)
(AREF (\, SEQUENCE)
BACKWARD-INDEX))))))
(DEFUN VECTOR-REVERSE* (SEQUENCE) (* raf "18-Dec-85 00:07")
(VECTOR-REVERSE SEQUENCE (TYPE-OF SEQUENCE)))
(DEFUN CL:NREVERSE (SEQUENCE)
"Returns a sequence of the same elements in reverse order (the argument is destroyed)."
(* kbr: "31-Aug-85 17:57")
(SEQ-DISPATCH SEQUENCE (DREVERSE SEQUENCE)
(VECTOR-NREVERSE* SEQUENCE)))
(DEFMACRO LIST-NREVERSE-MACRO (LIST) (BQUOTE (CL:DO ((1ST (CDR (\, LIST))
(COND
((ENDP 1ST)
1ST)
(T (CDR 1ST))))
(2ND (\, LIST)
1ST)
(3RD (QUOTE NIL)
2ND))
((ENDP 2ND)
3RD)
(RPLACD 2ND 3RD))))
(DEFUN LIST-NREVERSE* (SEQUENCE) (LIST-NREVERSE-MACRO SEQUENCE))
(DEFMACRO VECTOR-NREVERSE (SEQUENCE) (BQUOTE (LET ((LENGTH (CL:LENGTH (THE VECTOR (\, SEQUENCE)))))
(CL:DO ((LEFT-INDEX 0 (1+ LEFT-INDEX))
(RIGHT-INDEX (1- LENGTH)
(1- RIGHT-INDEX))
(HALF-LENGTH (IQUOTIENT LENGTH 2)))
((= LEFT-INDEX HALF-LENGTH)
(\, SEQUENCE))
(ROTATEF (AREF (\, SEQUENCE)
LEFT-INDEX)
(AREF (\, SEQUENCE)
RIGHT-INDEX))))))
(DEFUN VECTOR-NREVERSE* (SEQUENCE) (VECTOR-NREVERSE SEQUENCE))
(DEFUN MAKE-SEQUENCE (TYPE LENGTH &KEY INITIAL-ELEMENT) (* raf "27-Jan-86 17:30")
(CASE (TYPE-SPECIFIER TYPE)
(LIST (MAKE-LIST LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT))
((SIMPLE-STRING STRING)
(LET ((STRING (MAKE-STRING LENGTH)))
(CL:WHEN INITIAL-ELEMENT (CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
STRING)
(SETF (CHAR (THE SIMPLE-STRING STRING)
INDEX)
INITIAL-ELEMENT)))
STRING))
(SIMPLE-VECTOR (MAKE-ARRAY LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT))
((ARRAY VECTOR SIMPLE-ARRAY)
(CL:IF (CL:LISTP TYPE)
(MAKE-ARRAY LENGTH :ELEMENT-TYPE (CADR TYPE)
:INITIAL-ELEMENT INITIAL-ELEMENT)
(MAKE-ARRAY LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT)))
((BIT-VECTOR SIMPLE-BIT-VECTOR)
(MAKE-ARRAY LENGTH :ELEMENT-TYPE (QUOTE (MOD 2))
:INITIAL-ELEMENT INITIAL-ELEMENT))
(T (CL:ERROR "~S is a bad type specifier for sequences." TYPE))))
(DEFUN CONCATENATE (RESULT-TYPE &REST SEQUENCES) (* kbr: "31-Aug-85 19:50")
(*
"This should be (subtypep result-type 'sequence)")
(CASE (TYPE-SPECIFIER RESULT-TYPE)
(LIST (CL:APPLY (FUNCTION CONCAT-TO-LIST*)
SEQUENCES))
((SIMPLE-VECTOR SIMPLE-STRING VECTOR STRING ARRAY SIMPLE-ARRAY BIT-VECTOR SIMPLE-BIT-VECTOR)
(CL:APPLY (FUNCTION CONCAT-TO-SIMPLE*)
RESULT-TYPE SEQUENCES))
(T (CL:ERROR "~S: invalid output type specification." RESULT-TYPE))))
(DEFMACRO CONCATENATE-TO-LIST (SEQUENCES)
(BQUOTE (LET ((RESULT (LIST NIL)))
(CL:DO ((SEQUENCES (\, SEQUENCES)
(CDR SEQUENCES))
(SPLICE RESULT))
((NULL SEQUENCES)
(CDR RESULT))
(LET ((SEQUENCE (CAR SEQUENCES)))
(SEQ-DISPATCH SEQUENCE (CL:DO ((SEQUENCE SEQUENCE (CDR SEQUENCE)))
((ENDP SEQUENCE))
(SETQ SPLICE
(CDR (RPLACD SPLICE (CONS (CAR SEQUENCE)
NIL)))))
(CL:DO ((INDEX 0 (1+ INDEX))
(LENGTH (CL:LENGTH SEQUENCE)))
((= INDEX LENGTH))
(SETQ SPLICE (CDR (RPLACD SPLICE (CONS (AREF SEQUENCE INDEX
)
NIL)))))))))))
(DEFUN CONCAT-TO-LIST* (&REST SEQUENCES) (CONCATENATE-TO-LIST SEQUENCES))
(DEFUN CONCAT-TO-SIMPLE* (RESULT-TYPE &REST SEQUENCES) (* kbr: " 1-Sep-85 19:21")
(CL:DO ((SEQS SEQUENCES (CDR SEQS))
(TOTAL-LENGTH 0)
(LENGTHS NIL))
((NULL SEQS)
(CL:DO ((SEQUENCES SEQUENCES (CDR SEQUENCES))
(LENGTHS LENGTHS (CDR LENGTHS))
(INDEX 0)
(RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE TOTAL-LENGTH)))
((= INDEX TOTAL-LENGTH)
RESULT)
(CL:SETQ LENGTHS (REVERSE LENGTHS))
(LET ((SEQUENCE (CAR SEQUENCES)))
(SEQ-DISPATCH SEQUENCE (CL:DO ((SEQUENCE SEQUENCE (CDR SEQUENCE)))
((ENDP SEQUENCE))
(SETF (AREF RESULT INDEX)
(CAR SEQUENCE))
(INCF INDEX))
(CL:DO ((JNDEX 0 (1+ JNDEX)))
((= JNDEX (CAR LENGTHS)))
(SETF (AREF RESULT INDEX)
(AREF SEQUENCE JNDEX))
(INCF INDEX))))))
(LET ((LENGTH (CL:LENGTH (CAR SEQS))))
(CL:PUSH LENGTH LENGTHS)
(INCF TOTAL-LENGTH LENGTH))))
(DEFMACRO ELT-SLICE (SEQUENCES N) (BQUOTE (CL:MAPCAR (FUNCTION (CL:LAMBDA (SEQ)
(CL:ELT SEQ (\, N))))
(\, SEQUENCES))))
(DEFMACRO MAP-FOR-EFFECT (FUNCTION SEQUENCES) (BQUOTE (CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(MIN-LENGTH (CL:LENGTH FIRST-SEQUENCE))
)
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX MIN-LENGTH)
NIL)
(CL:APPLY (\, FUNCTION)
(ELT-SLICE (\, SEQUENCES)
INDEX))))
(LET ((LENGTH (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< LENGTH MIN-LENGTH)
(SETQ MIN-LENGTH LENGTH))))))
(DEFMACRO MAP-TO-LIST (FN SEQUENCES) (*
"used to be 'function', but the prettyprinter does bad things to that.")
(BQUOTE (CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(MIN-LENGTH (CL:LENGTH FIRST-SEQUENCE)))
((NULL SEQS)
(LET ((RESULT (LIST NIL)))
(CL:DO ((INDEX 0 (1+ INDEX))
(SPLICE RESULT))
((= INDEX MIN-LENGTH)
(CDR RESULT))
(SETQ SPLICE (CDR (RPLACD SPLICE (CONS (CL:APPLY (\, FN)
(ELT-SLICE (\, SEQUENCES
)
INDEX))
NIL)))))))
(LET ((LENGTH (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< LENGTH MIN-LENGTH)
(CL:SETQ MIN-LENGTH LENGTH))))))
(DEFMACRO MAP-TO-SIMPLE (OUTPUT-TYPE-SPEC FUNCTION SEQUENCES)
(BQUOTE (CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(MIN-LENGTH (CL:LENGTH FIRST-SEQUENCE)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX))
(RESULT (MAKE-SEQUENCE-OF-TYPE (\, OUTPUT-TYPE-SPEC)
MIN-LENGTH)))
((= INDEX MIN-LENGTH)
RESULT)
(SETF (AREF RESULT INDEX)
(CL:APPLY (\, FUNCTION)
(ELT-SLICE (\, SEQUENCES)
INDEX)))))
(LET ((LENGTH (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< LENGTH MIN-LENGTH)
(SETQ MIN-LENGTH LENGTH))))))
(DEFUN CL:MAP (RESULT-TYPE FUNCTION FIRST-SEQUENCE &REST MORE-SEQUENCES)
(* amd " 5-Jun-86 19:17")
"FUNCTION must take as many arguments as there are sequences provided. The result is a sequence such that element i is the result of applying FUNCTION to element i of each of the argument sequences."
(LET ((SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
(CASE (TYPE-SPECIFIER RESULT-TYPE)
(NIL (MAP-FOR-EFFECT FUNCTION SEQUENCES))
(LIST (MAP-TO-LIST FUNCTION SEQUENCES))
((SIMPLE-VECTOR SIMPLE-STRING VECTOR STRING ARRAY SIMPLE-ARRAY BIT-VECTOR
SIMPLE-BIT-VECTOR)
(MAP-TO-SIMPLE RESULT-TYPE FUNCTION SEQUENCES))
(T (CL:ERROR "~S: invalid output type specifier." RESULT-TYPE)))))
(DEFUN CL:SOME (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. SOME returns the first non-() value encountered, or () if the end of a sequence is reached."
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(LENGTH (CL:LENGTH FIRST-SEQUENCE))
(SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
NIL)
(LET ((RESULT (CL:APPLY PREDICATE (ELT-SLICE SEQUENCES INDEX))))
(CL:WHEN RESULT (RETURN RESULT)))))
(LET ((THIS (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< THIS LENGTH)
(SETQ LENGTH THIS)))))
(DEFUN CL:EVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. EVERY returns () as soon as any invocation of PREDICATE returns (), or T if every invocation is non-()."
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(LENGTH (CL:LENGTH FIRST-SEQUENCE))
(SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
T)
(LET ((RESULT (CL:APPLY PREDICATE (ELT-SLICE SEQUENCES INDEX))))
(CL:UNLESS RESULT (RETURN NIL)))))
(LET ((THIS (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< THIS LENGTH)
(SETQ LENGTH THIS)))))
(DEFUN CL:NOTANY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. NOTANY returns () as soon as any invocation of PREDICATE returns a non-() value, or T if the end of a sequence is reached."
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(LENGTH (CL:LENGTH FIRST-SEQUENCE))
(SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
T)
(LET ((RESULT (CL:APPLY PREDICATE (ELT-SLICE SEQUENCES INDEX))))
(CL:WHEN RESULT (RETURN NIL)))))
(LET ((THIS (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< THIS LENGTH)
(SETQ LENGTH THIS)))))
(DEFUN CL:NOTEVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. NOTEVERY returns T as soon as any invocation of PREDICATE returns (), or () if every invocation is non-()."
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(LENGTH (CL:LENGTH FIRST-SEQUENCE))
(SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
NIL)
(LET ((RESULT (CL:APPLY PREDICATE (ELT-SLICE SEQUENCES INDEX))))
(CL:UNLESS RESULT (RETURN T)))))
(LET ((THIS (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< THIS LENGTH)
(SETQ LENGTH THIS)))))
(DEFMACRO LIST-REDUCE-FROM-END (FUNCTION SEQUENCE START END INITIAL-VALUE INITIAL-PROVIDED)
(BQUOTE (LET ((SEQUENCE (NTHCDR (- (CL:LENGTH (\, SEQUENCE))
(\, END))
(REVERSE (\, SEQUENCE)))))
(CL:WHEN (\, INITIAL-PROVIDED)
(CL:PUSH (\, INITIAL-VALUE)
SEQUENCE))
(CL:DO* ((COUNT (- (\, END)
(\, START)
(CL:IF (\, INITIAL-PROVIDED)
0 1))
(1- COUNT))
(SEQUENCE SEQUENCE (CDR SEQUENCE))
(VALUE (CAR SEQUENCE)
(FUNCALL (\, FUNCTION)
(CAR SEQUENCE)
VALUE)))
((= COUNT 0)
VALUE)))))
(DEFMACRO LIST-REDUCE (FUNCTION SEQUENCE START END INITIAL-VALUE INITIAL-PROVIDED)
(BQUOTE (LET ((SEQUENCE (NTHCDR (\, START)
(\, SEQUENCE))))
(CL:WHEN (\, INITIAL-PROVIDED)
(CL:PUSH (\, INITIAL-VALUE)
SEQUENCE))
(CL:DO* ((COUNT (- END START (CL:IF (\, INITIAL-PROVIDED)
0 1))
(1- COUNT))
(SEQUENCE SEQUENCE (CDR SEQUENCE))
(VALUE (CAR SEQUENCE)
(FUNCALL (\, FUNCTION)
VALUE
(CAR SEQUENCE))))
((= COUNT 0)
VALUE)))))
(DEFMACRO MUMBLE-REDUCE-FROM-END (FUNCTION SEQUENCE START END INITIAL-VALUE REF)
(BQUOTE (CL:DO ((INDEX (1- (\, END))
(1- INDEX))
(VALUE (\, INITIAL-VALUE))
(TERMINUS (1- (\, START))))
((<= INDEX TERMINUS)
VALUE)
(SETQ VALUE (FUNCALL (\, FUNCTION)
((\, REF)
(\, SEQUENCE)
INDEX)
VALUE)))))
(DEFMACRO MUMBLE-REDUCE (FUNCTION SEQUENCE START END INITIAL-VALUE REF)
(BQUOTE (CL:DO ((INDEX (\, START)
(1+ INDEX))
(VALUE (\, INITIAL-VALUE)))
((>= INDEX (\, END))
VALUE)
(SETQ VALUE (FUNCALL (\, FUNCTION)
VALUE
((\, REF)
(\, SEQUENCE)
INDEX))))))
(DEFUN REDUCE (FUNCTION SEQUENCE &KEY FROM-END (START 0)
(END (CL:LENGTH SEQUENCE))
(INITIAL-VALUE NIL INITIAL-PROVIDED)) (* raf "28-Apr-86 18:01")
(COND
((<= END START)
(CL:IF INITIAL-PROVIDED INITIAL-VALUE (FUNCALL FUNCTION)))
((CL:LISTP SEQUENCE)
(CL:IF FROM-END (LIST-REDUCE-FROM-END FUNCTION SEQUENCE START END INITIAL-VALUE
INITIAL-PROVIDED)
(LIST-REDUCE FUNCTION SEQUENCE START END INITIAL-VALUE INITIAL-PROVIDED)))
(T (COND
(FROM-END (CL:UNLESS INITIAL-PROVIDED (CL:SETQ END (1- END)
INITIAL-VALUE
(AREF SEQUENCE END)))
(MUMBLE-REDUCE-FROM-END FUNCTION SEQUENCE START END INITIAL-VALUE AREF))
(T (CL:UNLESS INITIAL-PROVIDED (CL:SETQ INITIAL-VALUE (AREF SEQUENCE START)
START
(1+ START)))
(MUMBLE-REDUCE FUNCTION SEQUENCE START END INITIAL-VALUE AREF))))))
(DEFUN FILL (SEQUENCE ITEM &KEY (START 0)
(END (CL:LENGTH SEQUENCE)))
"Replace the specified elements of SEQUENCE with ITEM."
(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 (CL:LENGTH TARGET-SEQUENCE)))
((:START2 SOURCE-START)
0)
((:END2 SOURCE-END (CL:LENGTH SOURCE-SEQUENCE))))
(* jrb: "23-Apr-86 11:00")
(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 (CL:LENGTH SEQUENCE))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY)))
"Returns a sequence formed by destructively removing the specified Item from the given sequence."
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(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 (CL:LENGTH SEQUENCE))
(COUNT MOST-POSITIVE-FIXNUM)) "Returns a sequence formed by destructively removing the elements satisfying the specified predicate from the given sequence."
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(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 (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY))
(COUNT MOST-POSITIVE-FIXNUM)) "Returns a sequence formed by destructively removing the elements not satisfying the specified Predicate from the given Sequence."
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(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 (CL:LENGTH SEQUENCE))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))) (* raf " 3-Dec-85 23:31")
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(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 (CL:LENGTH SEQUENCE))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY)))
"Returns a copy of sequence with elements such that predicate(element) is non-null are removed"
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(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 (CL:LENGTH SEQUENCE))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY)))
"Returns a copy of sequence with elements such that predicate(element) is null are removed"
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(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 (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY))) "The elements of Sequence are examined, and if any two match, one is discarded. The resulting sequence is returned."
(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 (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY))) "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."
(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 (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY))) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New."
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(SUBST-DISPATCH (QUOTE NORMAL))))
(DEFUN SUBSTITUTE-IF (NEW TEST SEQUENCE &KEY FROM-END (START 0)
(END (CL:LENGTH SEQUENCE))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))) "Returns a sequence of the same kind as Sequence with the same elements except that all elements satisfying the Test are replaced with New."
(LET ((LENGTH (CL:LENGTH SEQUENCE))
TEST-NOT OLD)
(SUBST-DISPATCH (QUOTE IF))))
(DEFUN SUBSTITUTE-IF-NOT (NEW TEST SEQUENCE &KEY FROM-END (START 0)
(END (CL:LENGTH SEQUENCE))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))) "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."
(LET ((LENGTH (CL:LENGTH SEQUENCE))
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 (CL:WHEN (VECTORP SEQUENCE)
(CL:LENGTH (THE VECTOR SEQUENCE))))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))
(START 0)) (* raf "27-Jan-86 17:31")
(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 (CL:WHEN (VECTORP SEQUENCE)
(CL:LENGTH (THE VECTOR SEQUENCE))))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))) (* raf "27-Jan-86 17:31")
(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 (CL:WHEN (VECTORP SEQUENCE)
(CL:LENGTH (THE VECTOR SEQUENCE))))
(COUNT MOST-POSITIVE-FIXNUM)
(KEY (FUNCTION IDENTITY))) (* raf "27-Jan-86 17:31")
(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))))
(DEFMACRO VECTOR-FIND (ITEM SEQUENCE) (BQUOTE (LET ((INCREMENTER (CL:IF FROM-END -1 1))
(START (CL:IF FROM-END (1- END)
START))
(END (CL:IF FROM-END (1- START)
END)))
(CL:DO ((INDEX START (+ INDEX INCREMENTER))
(CURRENT))
((= INDEX END)
NIL)
(SETQ CURRENT (AREF (\, SEQUENCE)
INDEX))
(CL:IF TEST-NOT
(CL:UNLESS (FUNCALL TEST-NOT
(\, ITEM)
(FUNCALL KEY
CURRENT))
(RETURN CURRENT))
(CL:WHEN (FUNCALL TEST (\, ITEM)
(FUNCALL KEY CURRENT
))
(RETURN CURRENT)))))))
(DEFMACRO LIST-FIND (ITEM SEQUENCE) (BQUOTE (CL:IF FROM-END
(CL:DO ((SEQUENCE
(NTHCDR (- (LENGTH (\, SEQUENCE))
END)
(REVERSE (\, SEQUENCE))))
(INDEX (1- END)
(1- INDEX))
(CURRENT))
((OR (= INDEX (1- START))
(ENDP SEQUENCE))
NIL)
(SETQ CURRENT (CL:POP SEQUENCE))
(CL:IF TEST-NOT
(CL:UNLESS (FUNCALL TEST-NOT
(\, ITEM)
(FUNCALL KEY
CURRENT))
(RETURN CURRENT))
(CL:WHEN (FUNCALL TEST (\, ITEM)
(FUNCALL KEY CURRENT
))
(RETURN CURRENT))))
(CL:DO ((SEQUENCE (NTHCDR START (\, SEQUENCE)))
(INDEX START (1+ INDEX))
(CURRENT))
((OR (= INDEX END)
(ENDP SEQUENCE))
NIL)
(SETQ CURRENT (CL:POP SEQUENCE))
(CL:IF TEST-NOT
(CL:UNLESS (FUNCALL TEST-NOT
(\, ITEM)
(FUNCALL KEY
CURRENT))
(RETURN CURRENT))
(CL:WHEN (FUNCALL TEST (\, ITEM)
(FUNCALL KEY CURRENT
))
(RETURN CURRENT)))))))
(DEFMACRO VECTOR-FIND-IF (TEST SEQUENCE) (BQUOTE (LET ((INCREMENTER (CL:IF FROM-END -1 1))
(START (CL:IF FROM-END (1- END)
START))
(END (CL:IF FROM-END (1- START)
END)))
(CL:DO ((INDEX START (+ INDEX INCREMENTER))
(CURRENT))
((= INDEX END)
NIL)
(SETQ CURRENT (AREF (\, SEQUENCE)
INDEX))
(CL:WHEN (FUNCALL (\, TEST)
(FUNCALL KEY CURRENT))
(RETURN CURRENT))))))
(DEFMACRO LIST-FIND-IF (TEST SEQUENCE) (BQUOTE (CL:IF FROM-END
(CL:DO ((SEQUENCE (NTHCDR (- LENGTH END)
(REVERSE (\, SEQUENCE)
)))
(INDEX (1- END)
(1- INDEX))
(CURRENT))
((OR (= INDEX (1- START))
(ENDP SEQUENCE))
NIL)
(SETQ CURRENT (CL:POP SEQUENCE))
(CL:WHEN (FUNCALL (\, TEST)
(FUNCALL KEY CURRENT))
(RETURN CURRENT)))
(CL:DO ((SEQUENCE (NTHCDR START (\, SEQUENCE)))
(INDEX START (1+ INDEX))
(CURRENT))
((OR (= INDEX END)
(ENDP SEQUENCE))
NIL)
(SETQ CURRENT (CL:POP SEQUENCE))
(CL:WHEN (FUNCALL (\, TEST)
(FUNCALL KEY CURRENT))
(RETURN CURRENT))))))
(DEFMACRO VECTOR-FIND-IF-NOT (TEST SEQUENCE) (BQUOTE (LET ((INCREMENTER (CL:IF FROM-END -1 1))
(START (CL:IF FROM-END (1- END)
START))
(END (CL:IF FROM-END (1- START)
END)))
(CL:DO ((INDEX START (+ INDEX INCREMENTER))
(CURRENT))
((= INDEX END)
NIL)
(SETQ CURRENT (AREF (\, SEQUENCE)
INDEX))
(CL:UNLESS (FUNCALL (\, TEST)
(FUNCALL KEY
CURRENT))
(RETURN CURRENT))))))
(DEFMACRO LIST-FIND-IF-NOT (TEST SEQUENCE) (BQUOTE (CL:IF FROM-END
(CL:DO ((SEQUENCE
(NTHCDR (- LENGTH END)
(REVERSE (\, SEQUENCE))))
(INDEX (1- END)
(1- INDEX))
(CURRENT))
((OR (= INDEX (1- START))
(ENDP SEQUENCE))
NIL)
(SETQ CURRENT (CL:POP SEQUENCE))
(CL:UNLESS (FUNCALL (\, TEST)
(FUNCALL KEY
CURRENT))
(RETURN CURRENT)))
(CL:DO ((SEQUENCE (NTHCDR START
(\, SEQUENCE)))
(INDEX START (1+ INDEX))
(CURRENT))
((OR (= INDEX END)
(ENDP SEQUENCE))
NIL)
(SETQ CURRENT (CL:POP SEQUENCE))
(CL:UNLESS (FUNCALL (\, TEST)
(FUNCALL KEY
CURRENT))
(RETURN CURRENT))))))
(DEFUN LIST-FIND* (ITEM SEQUENCE FROM-END TEST TEST-NOT START END KEY) (LIST-FIND ITEM SEQUENCE))
(DEFUN VECTOR-FIND* (ITEM SEQUENCE FROM-END TEST TEST-NOT START END KEY) (VECTOR-FIND ITEM SEQUENCE))
(DEFUN CL:FIND (ITEM SEQUENCE &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT
(START 0)
(END (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY)))
"Returns the first element in SEQUENCE satisfying the test (default is EQL) with the given ITEM"
(SEQ-DISPATCH SEQUENCE (LIST-FIND* ITEM SEQUENCE FROM-END TEST TEST-NOT START END KEY)
(VECTOR-FIND* ITEM SEQUENCE FROM-END TEST TEST-NOT START END KEY)))
(DEFUN FIND-IF (TEST SEQUENCE &KEY FROM-END (START 0)
(END (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY)))
"Returns the zero-origin index of the first element satisfying the test."
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(SEQ-DISPATCH SEQUENCE (LIST-FIND-IF TEST SEQUENCE)
(VECTOR-FIND-IF TEST SEQUENCE))))
(DEFUN FIND-IF-NOT (TEST SEQUENCE &KEY FROM-END (START 0)
(END (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY)))
"Returns the zero-origin index of the first element not satisfying the test."
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(SEQ-DISPATCH SEQUENCE (LIST-FIND-IF-NOT TEST SEQUENCE)
(VECTOR-FIND-IF-NOT TEST SEQUENCE))))
(DEFMACRO VECTOR-POSITION (ITEM SEQUENCE)
(BQUOTE (LET ((INCREMENTER (CL:IF FROM-END -1 1))
(START (CL:IF FROM-END (1- END)
START))
(END (CL:IF FROM-END (1- START)
END)))
(CL:DO ((INDEX START (+ INDEX INCREMENTER)))
((= INDEX END)
NIL)
(CL:IF TEST-NOT (CL:UNLESS (FUNCALL TEST-NOT (\, ITEM)
(FUNCALL KEY (AREF (\, SEQUENCE)
INDEX)))
(RETURN INDEX))
(CL:WHEN (FUNCALL TEST (\, ITEM)
(FUNCALL KEY (AREF (\, SEQUENCE)
INDEX)))
(RETURN INDEX)))))))
(DEFMACRO VECTOR-POSITION-IF (TEST SEQUENCE)
(BQUOTE (LET ((INCREMENTER (CL:IF FROM-END -1 1))
(START (CL:IF FROM-END (1- END)
START))
(END (CL:IF FROM-END (1- START)
END)))
(CL:DO ((INDEX START (+ INDEX INCREMENTER)))
((= INDEX END)
NIL)
(CL:WHEN (FUNCALL (\, TEST)
(FUNCALL KEY (AREF (\, SEQUENCE)
INDEX)))
(RETURN INDEX))))))
(DEFMACRO LIST-POSITION (ITEM SEQUENCE) (BQUOTE
(CL:IF FROM-END
(CL:DO ((SEQUENCE (NTHCDR (- (LENGTH SEQUENCE)
END)
(REVERSE (\, SEQUENCE))))
(INDEX (1- END)
(1- INDEX)))
((OR (= INDEX (1- START))
(ENDP SEQUENCE))
NIL)
(CL:IF TEST-NOT
(CL:UNLESS (FUNCALL TEST-NOT
(\, ITEM)
(FUNCALL KEY
(CL:POP
SEQUENCE
)))
(RETURN INDEX))
(CL:WHEN (FUNCALL TEST (\, ITEM)
(FUNCALL KEY
(CL:POP SEQUENCE
)))
(RETURN INDEX))))
(CL:DO ((SEQUENCE (NTHCDR START (\, SEQUENCE)))
(INDEX START (1+ INDEX)))
((OR (= INDEX END)
(ENDP SEQUENCE))
NIL)
(CL:IF TEST-NOT
(CL:UNLESS (FUNCALL TEST-NOT
(\, ITEM)
(FUNCALL KEY
(CL:POP
SEQUENCE
)))
(RETURN INDEX))
(CL:WHEN (FUNCALL TEST (\, ITEM)
(FUNCALL KEY
(CL:POP SEQUENCE
)))
(RETURN INDEX)))))))
(DEFMACRO LIST-POSITION-IF (TEST SEQUENCE) (BQUOTE (CL:IF FROM-END
(CL:DO ((SEQUENCE
(NTHCDR (- LENGTH END)
(REVERSE (\, SEQUENCE))))
(INDEX (1- END)
(1- INDEX)))
((OR (= INDEX (1- START))
(ENDP SEQUENCE))
NIL)
(CL:WHEN (FUNCALL
(\, TEST)
(FUNCALL KEY (CL:POP
SEQUENCE)))
(RETURN INDEX)))
(CL:DO ((SEQUENCE (NTHCDR START
(\, SEQUENCE)))
(INDEX START (1+ INDEX)))
((OR (= INDEX END)
(ENDP SEQUENCE))
NIL)
(CL:WHEN (FUNCALL
(\, TEST)
(FUNCALL KEY (CL:POP
SEQUENCE)))
(RETURN INDEX))))))
(DEFMACRO VECTOR-POSITION-IF-NOT (TEST SEQUENCE)
(BQUOTE (LET ((INCREMENTER (CL:IF FROM-END -1 1))
(START (CL:IF FROM-END (1- END)
START))
(END (CL:IF FROM-END (1- START)
END)))
(CL:DO ((INDEX START (+ INDEX INCREMENTER)))
((= INDEX END)
NIL)
(CL:UNLESS (FUNCALL (\, TEST)
(FUNCALL KEY (AREF (\, SEQUENCE)
INDEX)))
(RETURN INDEX))))))
(DEFMACRO LIST-POSITION-IF-NOT (TEST SEQUENCE)
(BQUOTE (CL:IF FROM-END (CL:DO ((SEQUENCE (NTHCDR (- LENGTH END)
(REVERSE (\, SEQUENCE))))
(INDEX (1- END)
(1- INDEX)))
((OR (= INDEX (1- START))
(ENDP SEQUENCE))
NIL)
(CL:UNLESS (FUNCALL (\, TEST)
(FUNCALL KEY (CL:POP SEQUENCE)))
(RETURN INDEX)))
(CL:DO ((SEQUENCE (NTHCDR START (\, SEQUENCE)))
(INDEX START (1+ INDEX)))
((OR (= INDEX END)
(ENDP SEQUENCE))
NIL)
(CL:UNLESS (FUNCALL (\, TEST)
(FUNCALL KEY (CL:POP SEQUENCE)))
(RETURN INDEX))))))
(DEFUN LIST-POSITION* (ITEM SEQUENCE FROM-END TEST TEST-NOT START END KEY) (LIST-POSITION ITEM
SEQUENCE))
(DEFUN VECTOR-POSITION* (ITEM SEQUENCE FROM-END TEST TEST-NOT START END KEY) (VECTOR-POSITION ITEM
SEQUENCE))
(DEFUN CL:POSITION (ITEM SEQUENCE &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT
(START 0)
(END (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY))) "Returns the zero-origin index of the first element in SEQUENCE satisfying the test (default is EQL) with the given ITEM"
(SEQ-DISPATCH SEQUENCE (LIST-POSITION* ITEM SEQUENCE FROM-END TEST TEST-NOT START END KEY)
(VECTOR-POSITION* ITEM SEQUENCE FROM-END TEST TEST-NOT START END KEY)))
(DEFUN POSITION-IF (TEST SEQUENCE &KEY FROM-END (START 0)
(KEY (FUNCTION IDENTITY))
(END (CL:LENGTH SEQUENCE)))
"Returns the zero-origin index of the first element satisfying test(el)"
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(SEQ-DISPATCH SEQUENCE (LIST-POSITION-IF TEST SEQUENCE)
(VECTOR-POSITION-IF TEST SEQUENCE))))
(DEFUN POSITION-IF-NOT (TEST SEQUENCE &KEY FROM-END (START 0)
(KEY (FUNCTION IDENTITY))
(END (CL:LENGTH SEQUENCE)))
"Returns the zero-origin index of the first element not satisfying test(el)"
(LET ((LENGTH (CL:LENGTH SEQUENCE)))
(SEQ-DISPATCH SEQUENCE (LIST-POSITION-IF-NOT TEST SEQUENCE)
(VECTOR-POSITION-IF-NOT TEST SEQUENCE))))
(DEFMACRO VECTOR-COUNT (ITEM SEQUENCE) (BQUOTE (CL:DO ((INDEX START (1+ INDEX))
(COUNT 0))
((= INDEX END)
COUNT)
(CL:IF TEST-NOT
(CL:UNLESS
(FUNCALL TEST-NOT (\, ITEM)
(FUNCALL KEY (AREF (\, SEQUENCE)
INDEX)))
(INCF COUNT))
(CL:WHEN
(FUNCALL TEST (\, ITEM)
(FUNCALL KEY (AREF (\, SEQUENCE)
INDEX)))
(INCF COUNT))))))
(DEFMACRO LIST-COUNT (ITEM SEQUENCE) (BQUOTE (CL:DO ((SEQUENCE (NTHCDR START (\, SEQUENCE)))
(INDEX START (1+ INDEX))
(COUNT 0))
((OR (= INDEX END)
(ENDP SEQUENCE))
COUNT)
(CL:IF TEST-NOT (CL:UNLESS
(FUNCALL TEST-NOT (\, ITEM)
(FUNCALL KEY (CL:POP
SEQUENCE)))
(INCF COUNT))
(CL:WHEN (FUNCALL TEST (\, ITEM)
(FUNCALL KEY (CL:POP
SEQUENCE)))
(INCF COUNT))))))
(DEFMACRO VECTOR-COUNT-IF (PREDICATE SEQUENCE) (BQUOTE
(CL:DO ((INDEX START (1+ INDEX))
(COUNT 0))
((= INDEX END)
COUNT)
(CL:WHEN (FUNCALL (\, PREDICATE)
(FUNCALL KEY
(AREF (\, SEQUENCE)
INDEX)))
(INCF COUNT)))))
(DEFMACRO LIST-COUNT-IF (PREDICATE SEQUENCE) (BQUOTE (CL:DO ((SEQUENCE (NTHCDR START (\, SEQUENCE)))
(INDEX START (1+ INDEX))
(COUNT 0))
((OR (= INDEX END)
(ENDP SEQUENCE))
COUNT)
(CL:WHEN (FUNCALL (\, PREDICATE)
(FUNCALL KEY (CL:POP
SEQUENCE)))
(INCF COUNT)))))
(DEFMACRO VECTOR-COUNT-IF-NOT (PREDICATE SEQUENCE)
(BQUOTE (CL:DO ((INDEX START (1+ INDEX))
(COUNT 0))
((= INDEX END)
COUNT)
(CL:UNLESS (FUNCALL (\, PREDICATE)
(FUNCALL KEY (AREF (\, SEQUENCE)
INDEX)))
(INCF COUNT)))))
(DEFMACRO LIST-COUNT-IF-NOT (PREDICATE SEQUENCE) (BQUOTE (CL:DO ((SEQUENCE (NTHCDR START (\, SEQUENCE
)))
(INDEX START (1+ INDEX))
(COUNT 0))
((OR (= INDEX END)
(ENDP SEQUENCE))
COUNT)
(CL:UNLESS (FUNCALL
(\, PREDICATE)
(FUNCALL KEY (CL:POP
SEQUENCE)))
(INCF COUNT)))))
(DEFUN CL:COUNT (ITEM SEQUENCE &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT
(START 0)
(END (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY))) (* raf "17-Dec-85 22:39")
(SEQ-DISPATCH SEQUENCE (LIST-COUNT ITEM SEQUENCE)
(VECTOR-COUNT ITEM SEQUENCE)))
(DEFUN COUNT-IF (TEST SEQUENCE &KEY FROM-END (START 0)
(END (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY))) (* raf "17-Dec-85 22:40")
(SEQ-DISPATCH SEQUENCE (LIST-COUNT-IF TEST SEQUENCE)
(VECTOR-COUNT-IF TEST SEQUENCE)))
(DEFUN COUNT-IF-NOT (TEST SEQUENCE &KEY FROM-END (START 0)
(END (CL:LENGTH SEQUENCE))
(KEY (FUNCTION IDENTITY))) (* raf "17-Dec-85 22:40")
(SEQ-DISPATCH SEQUENCE (LIST-COUNT-IF-NOT TEST SEQUENCE)
(VECTOR-COUNT-IF-NOT TEST SEQUENCE)))
(DEFMACRO MATCH-VARS (&REST BODY) (BQUOTE (LET ((INC (CL:IF FROM-END -1 1))
(START1 (CL:IF FROM-END (1- END1)
START1))
(START2 (CL:IF FROM-END (1- END2)
START2))
(END1 (CL:IF FROM-END (1- START1)
END1))
(END2 (CL:IF FROM-END (1- START2)
END2)))
(\,@ BODY))))
(DEFMACRO MATCHIFY-LIST (SEQUENCE START LENGTH END) (BQUOTE (SETQ (\, SEQUENCE)
(CL:IF FROM-END
(NTHCDR (- (\, LENGTH)
(\, START)
1)
(REVERSE (\, SEQUENCE)))
(NTHCDR (\, START)
(\, SEQUENCE))))))
(DEFMACRO IF-MISMATCH (ELT1 ELT2) (BQUOTE (COND
((= INDEX1 END1)
(RETURN (COND
((= INDEX2 END2)
NIL)
(FROM-END (1+ INDEX1))
(T INDEX1))))
((= INDEX2 END2)
(RETURN (CL:IF FROM-END (1+ INDEX1)
INDEX1)))
(TEST-NOT (CL:WHEN (FUNCALL TEST-NOT (FUNCALL
KEY
(\, ELT1))
(FUNCALL KEY (\, ELT2)))
(RETURN (CL:IF FROM-END (1+ INDEX1)
INDEX1))))
(T (CL:UNLESS (FUNCALL TEST (FUNCALL KEY (\, ELT1))
(FUNCALL KEY (\, ELT2)))
(RETURN (CL:IF FROM-END (1+ INDEX1)
INDEX1)))))))
(DEFMACRO MUMBLE-MUMBLE-MISMATCH NIL (BQUOTE (CL:DO ((INDEX1 START1 (+ INDEX1 INC))
(INDEX2 START2 (+ INDEX2 INC)))
NIL
(IF-MISMATCH (AREF SEQUENCE1 INDEX1)
(AREF SEQUENCE2 INDEX2)))))
(DEFMACRO MUMBLE-LIST-MISMATCH NIL (BQUOTE (CL:DO ((INDEX1 START1 (+ INDEX1 INC))
(INDEX2 START2 (+ INDEX2 INC)))
NIL
(IF-MISMATCH (AREF SEQUENCE1 INDEX1)
(CL:POP SEQUENCE2)))))
(DEFMACRO LIST-MUMBLE-MISMATCH NIL (BQUOTE (CL:DO ((INDEX1 START1 (+ INDEX1 INC))
(INDEX2 START2 (+ INDEX2 INC)))
NIL
(IF-MISMATCH (CL:POP SEQUENCE1)
(AREF SEQUENCE2 INDEX2)))))
(DEFMACRO LIST-LIST-MISMATCH NIL (BQUOTE (CL:DO ((INDEX1 START1 (+ INDEX1 INC))
(INDEX2 START2 (+ INDEX2 INC)))
NIL
(IF-MISMATCH (CL:POP SEQUENCE1)
(CL:POP SEQUENCE2)))))
(DEFUN MISMATCH (SEQUENCE1 SEQUENCE2 &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT
(START1 0)
(END1 (CL:LENGTH SEQUENCE1))
(START2 0)
(END2 (CL:LENGTH SEQUENCE2))
(KEY (FUNCTION IDENTITY))) (* raf " 3-Dec-85 15:32")
(LET ((LENGTH1 (CL:LENGTH SEQUENCE1))
(LENGTH2 (CL:LENGTH SEQUENCE2)))
(MATCH-VARS (SEQ-DISPATCH SEQUENCE1 (PROGN (MATCHIFY-LIST SEQUENCE1 START1 LENGTH1 END1)
(SEQ-DISPATCH SEQUENCE2
(PROGN (MATCHIFY-LIST SEQUENCE2 START2
LENGTH2 END2)
(LIST-LIST-MISMATCH))
(LIST-MUMBLE-MISMATCH)))
(SEQ-DISPATCH SEQUENCE2 (PROGN (MATCHIFY-LIST SEQUENCE2 START2 LENGTH2
END2)
(MUMBLE-LIST-MISMATCH))
(MUMBLE-MUMBLE-MISMATCH))))))
(DEFMACRO COMPARE-ELEMENTS (ELT1 ELT2) (BQUOTE (CL:IF TEST-NOT (NOT (FUNCALL TEST-NOT
(FUNCALL KEY (\, ELT1))
(FUNCALL KEY (\, ELT2))))
(FUNCALL TEST (FUNCALL KEY (\, ELT1))
(FUNCALL KEY (\, ELT2))))))
(DEFMACRO SEARCH-COMPARE-LIST-LIST (MAIN SUB) (BQUOTE (CL:DO ((MAIN (\, MAIN)
(CDR MAIN))
(JNDEX START1 (1+ JNDEX))
(SUB (NTHCDR START1 (\, SUB))
(CDR SUB)))
((OR (ENDP MAIN)
(ENDP SUB)
(= END1 JNDEX))
T)
(COMPARE-ELEMENTS (CAR MAIN)
(CAR SUB)))))
(DEFMACRO SEARCH-COMPARE-LIST-VECTOR (MAIN SUB) (BQUOTE (CL:DO ((MAIN (\, MAIN)
(CDR MAIN))
(INDEX START1 (1+ INDEX)))
((OR (ENDP MAIN)
(= INDEX END1))
T)
(COMPARE-ELEMENTS (CAR MAIN)
(AREF (\, SUB)
INDEX)))))
(DEFMACRO SEARCH-COMPARE-VECTOR-LIST (MAIN SUB INDEX) (BQUOTE (CL:DO ((SUB (NTHCDR START1
(\, SUB))
(CDR SUB))
(JNDEX START1 (1+ JNDEX))
(INDEX (\, INDEX)
(1+ INDEX)))
((OR (= END1 JNDEX)
(ENDP SUB))
T)
(COMPARE-ELEMENTS
(AREF (\, MAIN)
INDEX)
(CAR SUB)))))
(DEFMACRO SEARCH-COMPARE-VECTOR-VECTOR (MAIN SUB INDEX) (BQUOTE (CL:DO ((INDEX (\, INDEX)
(1+ INDEX))
(SUB-INDEX START1
(1+ SUB-INDEX)))
((= SUB-INDEX END1)
T)
(COMPARE-ELEMENTS
(AREF (\, MAIN)
INDEX)
(AREF (\, SUB)
SUB-INDEX)))))
(DEFMACRO SEARCH-COMPARE (MAIN-TYPE MAIN SUB INDEX) (CL:IF (EQ MAIN-TYPE (QUOTE LIST))
(BQUOTE (SEQ-DISPATCH (\, SUB)
(SEARCH-COMPARE-LIST-LIST
(\, MAIN)
(\, SUB))
(SEARCH-COMPARE-LIST-VECTOR
(\, MAIN)
(\, SUB))))
(BQUOTE (SEQ-DISPATCH (\, SUB)
(SEARCH-COMPARE-VECTOR-LIST
(\, MAIN)
(\, SUB)
(\, INDEX))
(
SEARCH-COMPARE-VECTOR-VECTOR
(\, MAIN)
(\, SUB)
(\, INDEX))))))
(DEFMACRO LIST-SEARCH (MAIN SUB) (BQUOTE (CL:DO ((MAIN (NTHCDR START2 (\, MAIN))
(CDR MAIN))
(INDEX2 START2 (1+ INDEX2))
(TERMINUS (- END2 (- END1 START1)))
(LAST-MATCH NIL))
((> INDEX2 TERMINUS)
LAST-MATCH)
(CL:WHEN (SEARCH-COMPARE LIST MAIN (\, SUB)
INDEX2)
(CL:IF FROM-END (SETQ LAST-MATCH INDEX2)
(RETURN INDEX2))))))
(DEFMACRO VECTOR-SEARCH (MAIN SUB) (BQUOTE (CL:DO ((INDEX2 START2 (1+ INDEX2))
(TERMINUS (- END2 (- END1 START1)))
(LAST-MATCH NIL))
((> INDEX2 TERMINUS)
LAST-MATCH)
(CL:WHEN (SEARCH-COMPARE VECTOR (\, MAIN)
(\, SUB)
INDEX2)
(CL:IF FROM-END (SETQ LAST-MATCH INDEX2)
(RETURN INDEX2))))))
(DEFUN SEARCH (SEQUENCE1 SEQUENCE2 &KEY FROM-END (TEST (FUNCTION EQL))
TEST-NOT
(START1 0)
(END1 (CL:LENGTH SEQUENCE1))
(START2 0)
(END2 (CL:LENGTH SEQUENCE2))
(KEY (FUNCTION IDENTITY))) "A search is conducted using EQL for the first subsequence of sequence2 which element-wise matches sequence1. If there is such a subsequence in sequence2, the index of the its leftmost element is returned otherwise () is returned."
(SEQ-DISPATCH SEQUENCE2 (LIST-SEARCH SEQUENCE2 SEQUENCE1)
(VECTOR-SEARCH SEQUENCE2 SEQUENCE1)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* STRING-TO-SIMPLE-STRING* VECTOR-TO-BIT-VECTOR*
VECTOR-TO-STRING* VECTOR-TO-VECTOR* VECTOR-TO-LIST* LIST-TO-VECTOR*
LIST-TO-BIT-VECTOR* LIST-TO-STRING* CL:COERCE)
)
(PUTPROPS CMLSEQ COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (8897 18189 (CL:COERCE 8907 . 14065) (LIST-TO-STRING* 14067 . 14473) (
LIST-TO-BIT-VECTOR* 14475 . 14967) (LIST-TO-VECTOR* 14969 . 15389) (VECTOR-TO-LIST* 15391 . 15756) (
VECTOR-TO-VECTOR* 15758 . 16180) (VECTOR-TO-STRING* 16182 . 16590) (VECTOR-TO-BIT-VECTOR* 16592 .
17086) (STRING-TO-SIMPLE-STRING* 17088 . 17612) (BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* 17614 . 18187)))))
STOP