src/code/seq.lisp

   1 ;;;; generic SEQUENCEs
   2 ;;;;
   3 ;;;; KLUDGE: comment from original CMU CL source:
   4 ;;;;   Be careful when modifying code. A lot of the structure of the
   5 ;;;;   code is affected by the fact that compiler transforms use the
   6 ;;;;   lower level support functions. If transforms are written for
   7 ;;;;   some sequence operation, note how the END argument is handled
   8 ;;;;   in other operations with transforms.
   9
  10 ;;;; This software is part of the SBCL system. See the README file for
  11 ;;;; more information.
  12 ;;;;
  13 ;;;; This software is derived from the CMU CL system, which was
  14 ;;;; written at Carnegie Mellon University and released into the
  15 ;;;; public domain. The software is in the public domain and is
  16 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  17 ;;;; files for more information.
  18
  19 (in-package "SB!IMPL")
  20
  21 (file-comment
  22   "$Header$")
  23 \f
  24 ;;;; utilities
  25
  26 (eval-when (:compile-toplevel)
  27
  28 ;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
  29
  30 ;;; FIXME: It might be worth making three cases here, LIST, SIMPLE-VECTOR,
  31 ;;; and VECTOR, instead of the current LIST and VECTOR. It tend to make code
  32 ;;; run faster but be bigger; some benchmarking is needed to decide.
  33 (sb!xc:defmacro seq-dispatch (sequence list-form array-form)
  34   `(if (listp ,sequence)
  35        ,list-form
  36        ,array-form))
  37
  38 ;;; FIXME: Implementations of MAPFOO which use this are O(N*N) when users
  39 ;;; could reasonably expect them to be O(N). This should be fixed.
  40 (sb!xc:defmacro elt-slice (sequences n)
  41   #!+sb-doc
  42   "Returns a list of the Nth element of each of the sequences. Used by MAP
  43    and friends."
  44   `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences))
  45
  46 (sb!xc:defmacro make-sequence-like (sequence length)
  47   #!+sb-doc
  48   "Returns a sequence of the same type as SEQUENCE and the given LENGTH."
  49   `(make-sequence-of-type (type-of ,sequence) ,length))
  50
  51 (sb!xc:defmacro type-specifier-atom (type)
  52   #!+sb-doc "Returns the broad class of which TYPE is a specific subclass."
  53   `(if (atom ,type) ,type (car ,type)))
  54
  55 ) ; EVAL-WHEN
  56
  57 ;;; Given an arbitrary type specifier, return a sane sequence type
  58 ;;; specifier that we can directly match.
  59 (defun result-type-or-lose (type &optional nil-ok)
  60   (let ((type (specifier-type type)))
  61     (cond
  62       ((eq type *empty-type*)
  63        (if nil-ok
  64            nil
  65            (error 'simple-type-error
  66                   :datum type
  67                   :expected-type '(or vector cons)
  68                   :format-control
  69                   "NIL output type invalid for this sequence function."
  70                   :format-arguments ())))
  71       ((dolist (seq-type '(list string simple-vector bit-vector))
  72          (when (csubtypep type (specifier-type seq-type))
  73            (return seq-type))))
  74       ((csubtypep type (specifier-type 'vector))
  75        (type-specifier type))
  76       (t
  77        (error 'simple-type-error
  78               :datum type
  79               :expected-type 'sequence
  80               :format-control
  81               "~S is a bad type specifier for sequence functions."
  82               :format-arguments (list type))))))
  83
  84 (defun signal-index-too-large-error (sequence index)
  85   (let* ((length (length sequence))
  86          (max-index (and (plusp length)(1- length))))
  87     (error 'index-too-large-error
  88            :datum index
  89            :expected-type (if max-index
  90                               `(integer 0 ,max-index)
  91                               ;; This seems silly, is there something better?
  92                               '(integer (0) (0))))))
  93
  94 (defun make-sequence-of-type (type length)
  95   #!+sb-doc "Returns a sequence of the given TYPE and LENGTH."
  96   (declare (fixnum length))
  97   (case (type-specifier-atom type)
  98     (list (make-list length))
  99     ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
 100     ((string simple-string base-string simple-base-string)
 101      (make-string length))
 102     (simple-vector (make-array length))
 103     ((array simple-array vector)
 104      (if (listp type)
 105          (make-array length :element-type (cadr type))
 106          (make-array length)))
 107     (t
 108      (make-sequence-of-type (result-type-or-lose type) length))))
 109 \f
 110 (defun elt (sequence index)
 111   #!+sb-doc "Returns the element of SEQUENCE specified by INDEX."
 112   (etypecase sequence
 113     (list
 114      (do ((count index (1- count))
 115           (list sequence (cdr list)))
 116          ((= count 0)
 117           (if (endp list)
 118               (signal-index-too-large-error sequence index)
 119               (car list)))
 120        (declare (type (integer 0) count))))
 121     (vector
 122      (when (>= index (length sequence))
 123        (signal-index-too-large-error sequence index))
 124      (aref sequence index))))
 125
 126 (defun %setelt (sequence index newval)
 127   #!+sb-doc "Store NEWVAL as the component of SEQUENCE specified by INDEX."
 128   (etypecase sequence
 129     (list
 130      (do ((count index (1- count))
 131           (seq sequence))
 132          ((= count 0) (rplaca seq newval) newval)
 133        (declare (fixnum count))
 134        (if (atom (cdr seq))
 135            (signal-index-too-large-error sequence index)
 136            (setq seq (cdr seq)))))
 137     (vector
 138      (when (>= index (length sequence))
 139        (signal-index-too-large-error sequence index))
 140      (setf (aref sequence index) newval))))
 141
 142 (defun length (sequence)
 143   #!+sb-doc "Returns an integer that is the length of SEQUENCE."
 144   (etypecase sequence
 145     (vector (length (truly-the vector sequence)))
 146     (list (length (truly-the list sequence)))))
 147
 148 (defun make-sequence (type length &key (initial-element NIL iep))
 149   #!+sb-doc
 150   "Returns a sequence of the given Type and Length, with elements initialized
 151   to :Initial-Element."
 152   (declare (fixnum length))
 153   (let ((type (specifier-type type)))
 154     (cond ((csubtypep type (specifier-type 'list))
 155            (make-list length :initial-element initial-element))
 156           ((csubtypep type (specifier-type 'string))
 157            (if iep
 158                (make-string length :initial-element initial-element)
 159                (make-string length)))
 160           ((csubtypep type (specifier-type 'simple-vector))
 161            (make-array length :initial-element initial-element))
 162           ((csubtypep type (specifier-type 'bit-vector))
 163            (if iep
 164                (make-array length :element-type '(mod 2)
 165                            :initial-element initial-element)
 166                (make-array length :element-type '(mod 2))))
 167           ((csubtypep type (specifier-type 'vector))
 168            (if (typep type 'array-type)
 169                (let ((etype (type-specifier
 170                              (array-type-specialized-element-type type)))
 171                      (vlen (car (array-type-dimensions type))))
 172                  (if (and (numberp vlen) (/= vlen length))
 173                    (error 'simple-type-error
 174                           ;; these two are under-specified by ANSI
 175                           :datum (type-specifier type)
 176                           :expected-type (type-specifier type)
 177                           :format-control
 178                           "The length of ~S does not match the specified length  of ~S."
 179                           :format-arguments
 180                           (list (type-specifier type) length)))
 181                  (if iep
 182                      (make-array length :element-type etype
 183                                  :initial-element initial-element)
 184                      (make-array length :element-type etype)))
 185                (make-array length :initial-element initial-element)))
 186           (t (error 'simple-type-error
 187                     :datum type
 188                     :expected-type 'sequence
 189                     :format-control "~S is a bad type specifier for sequences."
 190                     :format-arguments (list type))))))
 191 \f
 192 ;;;; SUBSEQ
 193 ;;;;
 194 ;;;; The support routines for SUBSEQ are used by compiler transforms, so we
 195 ;;;; worry about dealing with END being supplied or defaulting to NIL
 196 ;;;; at this level.
 197
 198 (defun vector-subseq* (sequence start &optional end)
 199   (declare (type vector sequence))
 200   (declare (type fixnum start))
 201   (declare (type (or null fixnum) end))
 202   (when (null end) (setf end (length sequence)))
 203   (do ((old-index start (1+ old-index))
 204        (new-index 0 (1+ new-index))
 205        (copy (make-sequence-like sequence (- end start))))
 206       ((= old-index end) copy)
 207     (declare (fixnum old-index new-index))
 208     (setf (aref copy new-index) (aref sequence old-index))))
 209
 210 (defun list-subseq* (sequence start &optional end)
 211   (declare (type list sequence))
 212   (declare (type fixnum start))
 213   (declare (type (or null fixnum) end))
 214   (if (and end (>= start (the fixnum end)))
 215       ()
 216       (let* ((groveled (nthcdr start sequence))
 217              (result (list (car groveled))))
 218         (if groveled
 219             (do ((list (cdr groveled) (cdr list))
 220                  (splice result (cdr (rplacd splice (list (car list)))))
 221                  (index (1+ start) (1+ index)))
 222                 ((or (atom list) (and end (= index (the fixnum end))))
 223                  result)
 224               (declare (fixnum index)))
 225             ()))))
 226
 227 ;;; SUBSEQ cannot default end to the length of sequence since it is not
 228 ;;; an error to supply nil for its value. We must test for end being nil
 229 ;;; in the body of the function, and this is actually done in the support
 230 ;;; routines for other reasons (see above).
 231 (defun subseq (sequence start &optional end)
 232   #!+sb-doc
 233   "Returns a copy of a subsequence of SEQUENCE starting with element number
 234    START and continuing to the end of SEQUENCE or the optional END."
 235   (seq-dispatch sequence
 236                 (list-subseq* sequence start end)
 237                 (vector-subseq* sequence start end)))
 238 \f
 239 ;;;; COPY-SEQ
 240
 241 (eval-when (:compile-toplevel :execute)
 242
 243 (sb!xc:defmacro vector-copy-seq (sequence type)
 244   `(let ((length (length (the vector ,sequence))))
 245      (declare (fixnum length))
 246      (do ((index 0 (1+ index))
 247           (copy (make-sequence-of-type ,type length)))
 248          ((= index length) copy)
 249        (declare (fixnum index))
 250        (setf (aref copy index) (aref ,sequence index)))))
 251
 252 (sb!xc:defmacro list-copy-seq (list)
 253   `(if (atom ,list) '()
 254        (let ((result (cons (car ,list) '()) ))
 255          (do ((x (cdr ,list) (cdr x))
 256               (splice result
 257                       (cdr (rplacd splice (cons (car x) '() ))) ))
 258              ((atom x) (unless (null x)
 259                                (rplacd splice x))
 260                        result)))))
 261
 262 ) ; EVAL-WHEN
 263
 264 (defun copy-seq (sequence)
 265   #!+sb-doc "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
 266   (seq-dispatch sequence
 267                 (list-copy-seq* sequence)
 268                 (vector-copy-seq* sequence)))
 269
 270 ;;; internal frobs
 271
 272 (defun list-copy-seq* (sequence)
 273   (list-copy-seq sequence))
 274
 275 (defun vector-copy-seq* (sequence)
 276   (vector-copy-seq sequence (type-of sequence)))
 277 \f
 278 ;;;; FILL
 279
 280 (eval-when (:compile-toplevel :execute)
 281
 282 (sb!xc:defmacro vector-fill (sequence item start end)
 283   `(do ((index ,start (1+ index)))
 284        ((= index (the fixnum ,end)) ,sequence)
 285      (declare (fixnum index))
 286      (setf (aref ,sequence index) ,item)))
 287
 288 (sb!xc:defmacro list-fill (sequence item start end)
 289   `(do ((current (nthcdr ,start ,sequence) (cdr current))
 290         (index ,start (1+ index)))
 291        ((or (atom current) (and end (= index (the fixnum ,end))))
 292         sequence)
 293      (declare (fixnum index))
 294      (rplaca current ,item)))
 295
 296 ) ; EVAL-WHEN
 297
 298 ;;; The support routines for FILL are used by compiler transforms, so we
 299 ;;; worry about dealing with END being supplied or defaulting to NIL
 300 ;;; at this level.
 301
 302 (defun list-fill* (sequence item start end)
 303   (declare (list sequence))
 304   (list-fill sequence item start end))
 305
 306 (defun vector-fill* (sequence item start end)
 307   (declare (vector sequence))
 308   (when (null end) (setq end (length sequence)))
 309   (vector-fill sequence item start end))
 310
 311 ;;; FILL cannot default end to the length of sequence since it is not
 312 ;;; an error to supply nil for its value. We must test for end being nil
 313 ;;; in the body of the function, and this is actually done in the support
 314 ;;; routines for other reasons (see above).
 315 (defun fill (sequence item &key (start 0) end)
 316   #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM."
 317   (seq-dispatch sequence
 318                 (list-fill* sequence item start end)
 319                 (vector-fill* sequence item start end)))
 320 \f
 321 ;;;; REPLACE
 322
 323 (eval-when (:compile-toplevel :execute)
 324
 325 ;;; If we are copying around in the same vector, be careful not to copy the
 326 ;;; same elements over repeatedly. We do this by copying backwards.
 327 (sb!xc:defmacro mumble-replace-from-mumble ()
 328   `(if (and (eq target-sequence source-sequence) (> target-start source-start))
 329        (let ((nelts (min (- target-end target-start)
 330                          (- source-end source-start))))
 331          (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1)
 332                             (1- target-index))
 333               (source-index (+ (the fixnum source-start) (the fixnum nelts) -1)
 334                             (1- source-index)))
 335              ((= target-index (the fixnum (1- target-start))) target-sequence)
 336            (declare (fixnum target-index source-index))
 337            (setf (aref target-sequence target-index)
 338                  (aref source-sequence source-index))))
 339        (do ((target-index target-start (1+ target-index))
 340             (source-index source-start (1+ source-index)))
 341            ((or (= target-index (the fixnum target-end))
 342                 (= source-index (the fixnum source-end)))
 343             target-sequence)
 344          (declare (fixnum target-index source-index))
 345          (setf (aref target-sequence target-index)
 346                (aref source-sequence source-index)))))
 347
 348 (sb!xc:defmacro list-replace-from-list ()
 349   `(if (and (eq target-sequence source-sequence) (> target-start source-start))
 350        (let ((new-elts (subseq source-sequence source-start
 351                                (+ (the fixnum source-start)
 352                                   (the fixnum
 353                                        (min (- (the fixnum target-end)
 354                                                (the fixnum target-start))
 355                                             (- (the fixnum source-end)
 356                                                (the fixnum source-start))))))))
 357          (do ((n new-elts (cdr n))
 358               (o (nthcdr target-start target-sequence) (cdr o)))
 359              ((null n) target-sequence)
 360            (rplaca o (car n))))
 361        (do ((target-index target-start (1+ target-index))
 362             (source-index source-start (1+ source-index))
 363             (target-sequence-ref (nthcdr target-start target-sequence)
 364                                  (cdr target-sequence-ref))
 365             (source-sequence-ref (nthcdr source-start source-sequence)
 366                                  (cdr source-sequence-ref)))
 367            ((or (= target-index (the fixnum target-end))
 368                 (= source-index (the fixnum source-end))
 369                 (null target-sequence-ref) (null source-sequence-ref))
 370             target-sequence)
 371          (declare (fixnum target-index source-index))
 372          (rplaca target-sequence-ref (car source-sequence-ref)))))
 373
 374 (sb!xc:defmacro list-replace-from-mumble ()
 375   `(do ((target-index target-start (1+ target-index))
 376         (source-index source-start (1+ source-index))
 377         (target-sequence-ref (nthcdr target-start target-sequence)
 378                              (cdr target-sequence-ref)))
 379        ((or (= target-index (the fixnum target-end))
 380             (= source-index (the fixnum source-end))
 381             (null target-sequence-ref))
 382         target-sequence)
 383      (declare (fixnum source-index target-index))
 384      (rplaca target-sequence-ref (aref source-sequence source-index))))
 385
 386 (sb!xc:defmacro mumble-replace-from-list ()
 387   `(do ((target-index target-start (1+ target-index))
 388         (source-index source-start (1+ source-index))
 389         (source-sequence (nthcdr source-start source-sequence)
 390                          (cdr source-sequence)))
 391        ((or (= target-index (the fixnum target-end))
 392             (= source-index (the fixnum source-end))
 393             (null source-sequence))
 394         target-sequence)
 395      (declare (fixnum target-index source-index))
 396      (setf (aref target-sequence target-index) (car source-sequence))))
 397
 398 ) ; EVAL-WHEN
 399
 400 ;;;; The support routines for REPLACE are used by compiler transforms, so we
 401 ;;;; worry about dealing with END being supplied or defaulting to NIL
 402 ;;;; at this level.
 403
 404 (defun list-replace-from-list* (target-sequence source-sequence target-start
 405                                 target-end source-start source-end)
 406   (when (null target-end) (setq target-end (length target-sequence)))
 407   (when (null source-end) (setq source-end (length source-sequence)))
 408   (list-replace-from-list))
 409
 410 (defun list-replace-from-vector* (target-sequence source-sequence target-start
 411                                   target-end source-start source-end)
 412   (when (null target-end) (setq target-end (length target-sequence)))
 413   (when (null source-end) (setq source-end (length source-sequence)))
 414   (list-replace-from-mumble))
 415
 416 (defun vector-replace-from-list* (target-sequence source-sequence target-start
 417                                   target-end source-start source-end)
 418   (when (null target-end) (setq target-end (length target-sequence)))
 419   (when (null source-end) (setq source-end (length source-sequence)))
 420   (mumble-replace-from-list))
 421
 422 (defun vector-replace-from-vector* (target-sequence source-sequence
 423                                     target-start target-end source-start
 424                                     source-end)
 425   (when (null target-end) (setq target-end (length target-sequence)))
 426   (when (null source-end) (setq source-end (length source-sequence)))
 427   (mumble-replace-from-mumble))
 428
 429 ;;; REPLACE cannot default end arguments to the length of sequence since it
 430 ;;; is not an error to supply nil for their values. We must test for ends
 431 ;;; being nil in the body of the function.
 432 (defun replace (target-sequence source-sequence &key
 433                 ((:start1 target-start) 0)
 434                 ((:end1 target-end))
 435                 ((:start2 source-start) 0)
 436                 ((:end2 source-end)))
 437   #!+sb-doc
 438   "The target sequence is destructively modified by copying successive
 439    elements into it from the source sequence."
 440   (let ((target-end (or target-end (length target-sequence)))
 441         (source-end (or source-end (length source-sequence))))
 442     (seq-dispatch target-sequence
 443                   (seq-dispatch source-sequence
 444                                 (list-replace-from-list)
 445                                 (list-replace-from-mumble))
 446                   (seq-dispatch source-sequence
 447                                 (mumble-replace-from-list)
 448                                 (mumble-replace-from-mumble)))))
 449 \f
 450 ;;;; REVERSE
 451
 452 (eval-when (:compile-toplevel :execute)
 453
 454 (sb!xc:defmacro vector-reverse (sequence type)
 455   `(let ((length (length ,sequence)))
 456      (declare (fixnum length))
 457      (do ((forward-index 0 (1+ forward-index))
 458           (backward-index (1- length) (1- backward-index))
 459           (new-sequence (make-sequence-of-type ,type length)))
 460          ((= forward-index length) new-sequence)
 461        (declare (fixnum forward-index backward-index))
 462        (setf (aref new-sequence forward-index)
 463              (aref ,sequence backward-index)))))
 464
 465 (sb!xc:defmacro list-reverse-macro (sequence)
 466   `(do ((new-list ()))
 467        ((atom ,sequence) new-list)
 468      (push (pop ,sequence) new-list)))
 469
 470 ) ; EVAL-WHEN
 471
 472 (defun reverse (sequence)
 473   #!+sb-doc
 474   "Returns a new sequence containing the same elements but in reverse order."
 475   (seq-dispatch sequence
 476                 (list-reverse* sequence)
 477                 (vector-reverse* sequence)))
 478
 479 ;;; internal frobs
 480
 481 (defun list-reverse* (sequence)
 482   (list-reverse-macro sequence))
 483
 484 (defun vector-reverse* (sequence)
 485   (vector-reverse sequence (type-of sequence)))
 486 \f
 487 ;;;; NREVERSE
 488
 489 (eval-when (:compile-toplevel :execute)
 490
 491 (sb!xc:defmacro vector-nreverse (sequence)
 492   `(let ((length (length (the vector ,sequence))))
 493      (declare (fixnum length))
 494      (do ((left-index 0 (1+ left-index))
 495           (right-index (1- length) (1- right-index))
 496           (half-length (truncate length 2)))
 497          ((= left-index half-length) ,sequence)
 498        (declare (fixnum left-index right-index half-length))
 499        (rotatef (aref ,sequence left-index)
 500                 (aref ,sequence right-index)))))
 501
 502 (sb!xc:defmacro list-nreverse-macro (list)
 503   `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st)))
 504         (2nd ,list 1st)
 505         (3rd '() 2nd))
 506        ((atom 2nd) 3rd)
 507      (rplacd 2nd 3rd)))
 508
 509 ) ; EVAL-WHEN
 510
 511 (defun list-nreverse* (sequence)
 512   (list-nreverse-macro sequence))
 513
 514 (defun vector-nreverse* (sequence)
 515   (vector-nreverse sequence))
 516
 517 (defun nreverse (sequence)
 518   #!+sb-doc
 519   "Returns a sequence of the same elements in reverse order; the argument
 520    is destroyed."
 521   (seq-dispatch sequence
 522                 (list-nreverse* sequence)
 523                 (vector-nreverse* sequence)))
 524 \f
 525 ;;;; CONCATENATE
 526
 527 (eval-when (:compile-toplevel :execute)
 528
 529 (sb!xc:defmacro concatenate-to-list (sequences)
 530   `(let ((result (list nil)))
 531      (do ((sequences ,sequences (cdr sequences))
 532           (splice result))
 533          ((null sequences) (cdr result))
 534        (let ((sequence (car sequences)))
 535          ;; FIXME: It appears to me that this and CONCATENATE-TO-MUMBLE
 536          ;; could benefit from a DO-SEQUENCE macro.
 537          (seq-dispatch sequence
 538                        (do ((sequence sequence (cdr sequence)))
 539                            ((atom sequence))
 540                          (setq splice
 541                                (cdr (rplacd splice (list (car sequence))))))
 542                        (do ((index 0 (1+ index))
 543                             (length (length sequence)))
 544                            ((= index length))
 545                          (declare (fixnum index length))
 546                          (setq splice
 547                                (cdr (rplacd splice
 548                                             (list (aref sequence index)))))))))))
 549
 550 (sb!xc:defmacro concatenate-to-mumble (output-type-spec sequences)
 551   `(do ((seqs ,sequences (cdr seqs))
 552         (total-length 0)
 553         (lengths ()))
 554        ((null seqs)
 555         (do ((sequences ,sequences (cdr sequences))
 556              (lengths lengths (cdr lengths))
 557              (index 0)
 558              (result (make-sequence-of-type ,output-type-spec total-length)))
 559             ((= index total-length) result)
 560           (declare (fixnum index))
 561           (let ((sequence (car sequences)))
 562             (seq-dispatch sequence
 563                           (do ((sequence sequence (cdr sequence)))
 564                               ((atom sequence))
 565                             (setf (aref result index) (car sequence))
 566                             (setq index (1+ index)))
 567                           (do ((jndex 0 (1+ jndex))
 568                                (this-length (car lengths)))
 569                               ((= jndex this-length))
 570                             (declare (fixnum jndex this-length))
 571                             (setf (aref result index)
 572                                   (aref sequence jndex))
 573                             (setq index (1+ index)))))))
 574      (let ((length (length (car seqs))))
 575        (declare (fixnum length))
 576        (setq lengths (nconc lengths (list length)))
 577        (setq total-length (+ total-length length)))))
 578
 579 ) ; EVAL-WHEN
 580 \f
 581 ;;; FIXME: Make a compiler macro or transform for this which efficiently
 582 ;;; handles the case of constant 'STRING first argument. (It's not just time
 583 ;;; efficiency, but space efficiency..)
 584 (defun concatenate (output-type-spec &rest sequences)
 585   #!+sb-doc
 586   "Returns a new sequence of all the argument sequences concatenated together
 587   which shares no structure with the original argument sequences of the
 588   specified OUTPUT-TYPE-SPEC."
 589   (case (type-specifier-atom output-type-spec)
 590     ((simple-vector simple-string vector string array simple-array
 591                     bit-vector simple-bit-vector base-string
 592                     simple-base-string) ; FIXME: unifying principle here?
 593      (let ((result (apply #'concat-to-simple* output-type-spec sequences)))
 594        #!+high-security
 595        (check-type-var result output-type-spec)
 596        result))
 597     (list (apply #'concat-to-list* sequences))
 598     (t
 599      (apply #'concatenate (result-type-or-lose output-type-spec) sequences))))
 600
 601 ;;; internal frobs
 602 ;;; FIXME: These are weird. They're never called anywhere except in
 603 ;;; CONCATENATE. It seems to me that the macros ought to just
 604 ;;; be expanded directly in CONCATENATE, or in CONCATENATE-STRING
 605 ;;; and CONCATENATE-LIST variants. Failing that, these ought to be local
 606 ;;; functions (FLET).
 607 (defun concat-to-list* (&rest sequences)
 608   (concatenate-to-list sequences))
 609 (defun concat-to-simple* (type &rest sequences)
 610   (concatenate-to-mumble type sequences))
 611 \f
 612 ;;;; MAP
 613
 614 ;;; helper functions to handle the common consing subcases of MAP
 615 (declaim (ftype (function (function sequence) list) %map-list-arity-1))
 616 (declaim (ftype (function (function sequence) simple-vector)
 617                 %map-simple-vector-arity-1))
 618 (macrolet ((dosequence ((i sequence) &body body)
 619              (once-only ((sequence sequence))
 620                `(etypecase ,sequence
 621                   (list (dolist (,i ,sequence) ,@body))
 622                   (simple-vector (dovector (,i sequence) ,@body))
 623                   (vector (dovector (,i sequence) ,@body))))))
 624   (defun %map-to-list-arity-1 (fun sequence)
 625     (declare (type function fun))
 626     (let ((really-fun (if (functionp fun) fun (%coerce-name-to-function fun)))
 627           (reversed-result nil))
 628       (dosequence (element sequence)
 629         (push (funcall really-fun element)
 630               reversed-result))
 631       (nreverse reversed-result)))
 632   (defun %map-to-simple-vector-arity-1 (fun sequence)
 633     (declare (type function fun))
 634     (let ((really-fun (if (functionp fun) fun (%coerce-name-to-function fun)))
 635           (result (make-array (length sequence)))
 636           (index 0))
 637       (declare (type index index))
 638       (dosequence (element sequence)
 639         (setf (aref result index)
 640               (funcall really-fun element))
 641         (incf index))
 642       result)))
 643
 644 (eval-when (:compile-toplevel :execute)
 645
 646 (sb!xc:defmacro map-to-list (function sequences)
 647   `(do ((seqs more-sequences (cdr seqs))
 648         (min-length (length first-sequence)))
 649        ((null seqs)
 650         (let ((result (list nil)))
 651           (do ((index 0 (1+ index))
 652                (splice result))
 653               ((= index min-length) (cdr result))
 654             (declare (fixnum index))
 655             (setq splice
 656                   (cdr (rplacd splice
 657                                (list (apply ,function (elt-slice ,sequences
 658                                                                  index)))))))))
 659      (declare (fixnum min-length))
 660      (let ((length (length (car seqs))))
 661        (declare (fixnum length))
 662        (if (< length min-length)
 663            (setq min-length length)))))
 664
 665 (sb!xc:defmacro map-to-simple (output-type-spec function sequences)
 666   `(do ((seqs more-sequences (cdr seqs))
 667         (min-length (length first-sequence)))
 668        ((null seqs)
 669         (do ((index 0 (1+ index))
 670              (result (make-sequence-of-type ,output-type-spec min-length)))
 671             ((= index min-length) result)
 672           (declare (fixnum index))
 673           (setf (aref result index)
 674                 (apply ,function (elt-slice ,sequences index)))))
 675      (declare (fixnum min-length))
 676      (let ((length (length (car seqs))))
 677        (declare (fixnum length))
 678        (if (< length min-length)
 679            (setq min-length length)))))
 680
 681 (sb!xc:defmacro map-for-effect (function sequences)
 682   `(do ((seqs more-sequences (cdr seqs))
 683         (min-length (length first-sequence)))
 684        ((null seqs)
 685         (do ((index 0 (1+ index)))
 686             ((= index min-length) nil)
 687           (apply ,function (elt-slice ,sequences index))))
 688      (declare (fixnum min-length))
 689      (let ((length (length (car seqs))))
 690        (declare (fixnum length))
 691        (if (< length min-length)
 692            (setq min-length length)))))
 693
 694 ) ; EVAL-WHEN
 695
 696 #!+high-security-support
 697 (defun get-minimum-length-sequences (sequences)
 698   #!+sb-doc "Gets the minimum length of the sequences. This is
 699 needed to check whether the supplied type is appropriate."
 700     (let ((min nil))
 701       (dolist (i sequences)
 702         (when (or (listp i) (vectorp i))
 703           (let ((l (length i)))
 704             (when (or (null min)
 705                       (> min l)))
 706             (setf min l))))
 707       min))
 708
 709 (defun map (output-type-spec function first-sequence &rest more-sequences)
 710   #!+sb-doc
 711   "FUNCTION must take as many arguments as there are sequences provided. The
 712    result is a sequence such that element i is the result of applying FUNCTION
 713    to element i of each of the argument sequences."
 714   (let ((really-function (if (functionp function)
 715                              function
 716                              (%coerce-name-to-function function))))
 717     ;; Pick off the easy non-consing arity-1 special case and handle
 718     ;; it without consing, since the user probably didn't expect us to
 719     ;; cons here. (Notably, the super duper users who wrote PCL in
 720     ;; terms of quantifiers without declaring the types of their
 721     ;; sequence arguments didn't expect to end up consing when SBCL
 722     ;; transforms the quantifiers into calls to MAP NIL.)
 723     (when (and (null more-sequences)
 724                (null output-type-spec))
 725       (macrolet ((frob () '(return-from map
 726                              (map nil really-function first-sequence))))
 727         (etypecase first-sequence
 728           (simple-vector (frob))
 729           (list (frob))
 730           (vector (frob)))))
 731     ;; Otherwise, if the user didn't give us enough information to
 732     ;; simplify at compile time, we cons and cons and cons..
 733     (let ((sequences (cons first-sequence more-sequences)))
 734       (case (type-specifier-atom output-type-spec)
 735         ((nil) (map-for-effect really-function sequences))
 736         (list (map-to-list really-function sequences))
 737         ((simple-vector simple-string vector string array simple-array
 738                         bit-vector simple-bit-vector base-string simple-base-string)
 739          #!+high-security
 740          (let ((min-length-sequences (get-minimum-length-sequences
 741                                       sequences))
 742                (dimensions (array-type-dimensions (specifier-type
 743                                                    output-type-spec))))
 744            (when (or (/= (length dimensions) 1)
 745                      (and (not (eq (car dimensions) '*))
 746                           (/= (car dimensions) min-length-sequences)))
 747              (error 'simple-type-error
 748                     :datum output-type-spec
 749                     :expected-type
 750                     (ecase (type-specifier-atom output-type-spec)
 751                       ((simple-vector bit-vector simple-bit-vector string simple-string base-string)
 752                        `(,(type-specifier-atom output-type-spec) ,min-length-sequences))
 753                       ((array vector simple-array)   `(,(type-specifier-atom output-type-spec) * ,min-length-sequences)))
 754                     :format-control "Minimum length of sequences is ~S, this is not compatible with the type ~S."
 755                     :format-arguments
 756                     (list min-length-sequences output-type-spec))))
 757          (let ((result (map-to-simple output-type-spec
 758                                       really-function
 759                                       sequences)))
 760            #!+high-security
 761            (check-type-var result output-type-spec)
 762            result))
 763         (t
 764          (apply #'map (result-type-or-lose output-type-spec t)
 765                 really-function sequences))))))
 766
 767 #!+high-security-support
 768 (defun map-without-errorchecking
 769     (output-type-spec function first-sequence &rest more-sequences)
 770   #!+sb-doc
 771   "FUNCTION must take as many arguments as there are sequences provided. The
 772    result is a sequence such that element i is the result of applying FUNCTION
 773    to element I of each of the argument sequences. This version has no
 774    error-checking, to pass cold-load."
 775   (let ((sequences (cons first-sequence more-sequences)))
 776     (case (type-specifier-atom output-type-spec)
 777       ((nil) (map-for-effect function sequences))
 778       (list (map-to-list function sequences))
 779       ((simple-vector simple-string vector string array simple-array
 780         bit-vector simple-bit-vector base-string simple-base-string)
 781        (map-to-simple output-type-spec function sequences))
 782       (t
 783        (apply #'map (result-type-or-lose output-type-spec t)
 784               function sequences)))))
 785
 786 (defun map-into (result-sequence function &rest sequences)
 787   (let* ((fp-result
 788           (and (arrayp result-sequence)
 789                (array-has-fill-pointer-p result-sequence)))
 790          (len (apply #'min
 791                      (if fp-result
 792                          (array-dimension result-sequence 0)
 793                          (length result-sequence))
 794                      (mapcar #'length sequences))))
 795
 796     (when fp-result
 797       (setf (fill-pointer result-sequence) len))
 798
 799     (dotimes (index len)
 800       (setf (elt result-sequence index)
 801             (apply function
 802                    (mapcar #'(lambda (seq) (elt seq index))
 803                            sequences)))))
 804   result-sequence)
 805 \f
 806 ;;;; quantifiers
 807
 808 ;;; We borrow the logic from (MAP NIL ..) to handle iteration over
 809 ;;; arbitrary sequence arguments, both in the full call case and in
 810 ;;; the open code case.
 811 (macrolet ((defquantifier (name found-test found-result
 812                                 &key doc (unfound-result (not found-result)))
 813              `(progn
 814                 ;; KLUDGE: It would be really nice if we could simply
 815                 ;; do something like this
 816                 ;;  (declaim (inline ,name))
 817                 ;;  (defun ,name (pred first-seq &rest more-seqs)
 818                 ;;    ,doc
 819                 ;;    (flet ((map-me (&rest rest)
 820                 ;;             (let ((pred-value (apply pred rest)))
 821                 ;;               (,found-test pred-value
 822                 ;;                 (return-from ,name
 823                 ;;                   ,found-result)))))
 824                 ;;      (declare (inline map-me))
 825                 ;;      (apply #'map nil #'map-me first-seq more-seqs)
 826                 ;;      ,unfound-result))
 827                 ;; but Python doesn't seem to be smart enough about
 828                 ;; inlining and APPLY to recognize that it can use
 829                 ;; the DEFTRANSFORM for MAP in the resulting inline
 830                 ;; expansion. I don't have any appetite for deep
 831                 ;; compiler hacking right now, so I'll just work
 832                 ;; around the apparent problem by using a compiler
 833                 ;; macro instead. -- WHN 20000410
 834                 (defun ,name (pred first-seq &rest more-seqs)
 835                   #!+sb-doc ,doc
 836                   (flet ((map-me (&rest rest)
 837                            (let ((pred-value (apply pred rest)))
 838                              (,found-test pred-value
 839                                           (return-from ,name
 840                                             ,found-result)))))
 841                     (declare (inline map-me))
 842                     (apply #'map nil #'map-me first-seq more-seqs)
 843                     ,unfound-result))
 844                 ;; KLUDGE: It would be more obviously correct -- but
 845                 ;; also significantly messier -- for PRED-VALUE to be
 846                 ;; a gensym. However, a private symbol really does
 847                 ;; seem to be good enough; and anyway the really
 848                 ;; obviously correct solution is to make Python smart
 849                 ;; enough that we can use an inline function instead
 850                 ;; of a compiler macro (as above). -- WHN 20000410
 851                 (define-compiler-macro ,name (pred first-seq &rest more-seqs)
 852                   (let ((elements (mapcar (lambda (x)
 853                                             (declare (ignore x))
 854                                             (gensym "ARG"))
 855                                           (cons first-seq more-seqs)))
 856                         (blockname (gensym "BLOCK")))
 857                     (once-only ((pred pred))
 858                       `(block ,blockname
 859                          (map nil
 860                               (lambda (,@elements)
 861                                 (let ((pred-value (funcall ,pred ,@elements)))
 862                                   (,',found-test pred-value
 863                                     (return-from ,blockname
 864                                       ,',found-result))))
 865                               ,first-seq
 866                               ,@more-seqs)
 867                          ,',unfound-result)))))))
 868   (defquantifier some when pred-value :unfound-result nil :doc
 869   "PREDICATE is applied to the elements with index 0 of the sequences, then
 870    possibly to those with index 1, and so on. SOME returns the first
 871    non-NIL value encountered, or NIL if the end of a sequence is reached.")
 872   (defquantifier every unless nil :doc
 873   "PREDICATE is applied to the elements with index 0 of the sequences, then
 874    possibly to those with index 1, and so on. EVERY returns NIL as soon
 875    as any invocation of PREDICATE returns NIL, or T if every invocation
 876    is non-NIL.")
 877   (defquantifier notany when nil :doc
 878   "PREDICATE is applied to the elements with index 0 of the sequences, then
 879    possibly to those with index 1, and so on. NOTANY returns NIL as soon
 880    as any invocation of PREDICATE returns a non-NIL value, or T if the end
 881    of a sequence is reached.")
 882   (defquantifier notevery unless t :doc
 883   "PREDICATE is applied to the elements with index 0 of the sequences, then
 884    possibly to those with index 1, and so on. NOTEVERY returns T as soon
 885    as any invocation of PREDICATE returns NIL, or NIL if every invocation
 886    is non-NIL."))
 887 \f
 888 ;;;; REDUCE
 889
 890 (eval-when (:compile-toplevel :execute)
 891
 892 (sb!xc:defmacro mumble-reduce (function
 893                                sequence
 894                                key
 895                                start
 896                                end
 897                                initial-value
 898                                ref)
 899   `(do ((index ,start (1+ index))
 900         (value ,initial-value))
 901        ((= index (the fixnum ,end)) value)
 902      (declare (fixnum index))
 903      (setq value (funcall ,function value
 904                           (apply-key ,key (,ref ,sequence index))))))
 905
 906 (sb!xc:defmacro mumble-reduce-from-end (function
 907                                         sequence
 908                                         key
 909                                         start
 910                                         end
 911                                         initial-value
 912                                         ref)
 913   `(do ((index (1- ,end) (1- index))
 914         (value ,initial-value)
 915         (terminus (1- ,start)))
 916        ((= index terminus) value)
 917      (declare (fixnum index terminus))
 918      (setq value (funcall ,function
 919                           (apply-key ,key (,ref ,sequence index))
 920                           value))))
 921
 922 (sb!xc:defmacro list-reduce (function
 923                              sequence
 924                              key
 925                              start
 926                              end
 927                              initial-value
 928                              ivp)
 929   `(let ((sequence (nthcdr ,start ,sequence)))
 930      (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
 931                  (1+ count))
 932           (sequence (if ,ivp sequence (cdr sequence))
 933                     (cdr sequence))
 934           (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
 935                  (funcall ,function value (apply-key ,key (car sequence)))))
 936          ((= count (the fixnum ,end)) value)
 937        (declare (fixnum count)))))
 938
 939 (sb!xc:defmacro list-reduce-from-end (function
 940                                       sequence
 941                                       key
 942                                       start
 943                                       end
 944                                       initial-value
 945                                       ivp)
 946   `(let ((sequence (nthcdr (- (the fixnum (length ,sequence))
 947                               (the fixnum ,end))
 948                            (reverse ,sequence))))
 949      (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
 950                  (1+ count))
 951           (sequence (if ,ivp sequence (cdr sequence))
 952                     (cdr sequence))
 953           (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
 954                  (funcall ,function (apply-key ,key (car sequence)) value)))
 955          ((= count (the fixnum ,end)) value)
 956        (declare (fixnum count)))))
 957
 958 ) ; EVAL-WHEN
 959
 960 (defun reduce (function sequence &key key from-end (start 0)
 961                         end (initial-value nil ivp))
 962   (declare (type index start))
 963   (let ((start start)
 964         (end (or end (length sequence))))
 965     (declare (type index start end))
 966     (cond ((= end start)
 967            (if ivp initial-value (funcall function)))
 968           ((listp sequence)
 969            (if from-end
 970                (list-reduce-from-end function sequence key start end
 971                                      initial-value ivp)
 972                (list-reduce function sequence key start end
 973                             initial-value ivp)))
 974           (from-end
 975            (when (not ivp)
 976              (setq end (1- (the fixnum end)))
 977              (setq initial-value (apply-key key (aref sequence end))))
 978            (mumble-reduce-from-end function sequence key start end
 979                                    initial-value aref))
 980           (t
 981            (when (not ivp)
 982              (setq initial-value (apply-key key (aref sequence start)))
 983              (setq start (1+ start)))
 984            (mumble-reduce function sequence key start end
 985                           initial-value aref)))))
 986 \f
 987 ;;;; DELETE
 988
 989 (eval-when (:compile-toplevel :execute)
 990
 991 (sb!xc:defmacro mumble-delete (pred)
 992   `(do ((index start (1+ index))
 993         (jndex start)
 994         (number-zapped 0))
 995        ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
 996         (do ((index index (1+ index))           ; Copy the rest of the vector.
 997              (jndex jndex (1+ jndex)))
 998             ((= index (the fixnum length))
 999              (shrink-vector sequence jndex))
1000           (declare (fixnum index jndex))
1001           (setf (aref sequence jndex) (aref sequence index))))
1002      (declare (fixnum index jndex number-zapped))
1003      (setf (aref sequence jndex) (aref sequence index))
1004      (if ,pred
1005          (setq number-zapped (1+ number-zapped))
1006          (setq jndex (1+ jndex)))))
1007
1008 (sb!xc:defmacro mumble-delete-from-end (pred)
1009   `(do ((index (1- (the fixnum end)) (1- index)) ; Find the losers.
1010         (number-zapped 0)
1011         (losers ())
1012         this-element
1013         (terminus (1- start)))
1014        ((or (= index terminus) (= number-zapped (the fixnum count)))
1015         (do ((losers losers)                     ; Delete the losers.
1016              (index start (1+ index))
1017              (jndex start))
1018             ((or (null losers) (= index (the fixnum end)))
1019              (do ((index index (1+ index))       ; Copy the rest of the vector.
1020                   (jndex jndex (1+ jndex)))
1021                  ((= index (the fixnum length))
1022                   (shrink-vector sequence jndex))
1023                (declare (fixnum index jndex))
1024                (setf (aref sequence jndex) (aref sequence index))))
1025           (declare (fixnum index jndex))
1026           (setf (aref sequence jndex) (aref sequence index))
1027           (if (= index (the fixnum (car losers)))
1028               (pop losers)
1029               (setq jndex (1+ jndex)))))
1030      (declare (fixnum index number-zapped terminus))
1031      (setq this-element (aref sequence index))
1032      (when ,pred
1033        (setq number-zapped (1+ number-zapped))
1034        (push index losers))))
1035
1036 (sb!xc:defmacro normal-mumble-delete ()
1037   `(mumble-delete
1038     (if test-not
1039         (not (funcall test-not item (apply-key key (aref sequence index))))
1040         (funcall test item (apply-key key (aref sequence index))))))
1041
1042 (sb!xc:defmacro normal-mumble-delete-from-end ()
1043   `(mumble-delete-from-end
1044     (if test-not
1045         (not (funcall test-not item (apply-key key this-element)))
1046         (funcall test item (apply-key key this-element)))))
1047
1048 (sb!xc:defmacro list-delete (pred)
1049   `(let ((handle (cons nil sequence)))
1050      (do ((current (nthcdr start sequence) (cdr current))
1051           (previous (nthcdr start handle))
1052           (index start (1+ index))
1053           (number-zapped 0))
1054          ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
1055           (cdr handle))
1056        (declare (fixnum index number-zapped))
1057        (cond (,pred
1058               (rplacd previous (cdr current))
1059               (setq number-zapped (1+ number-zapped)))
1060              (t
1061               (setq previous (cdr previous)))))))
1062
1063 (sb!xc:defmacro list-delete-from-end (pred)
1064   `(let* ((reverse (nreverse (the list sequence)))
1065           (handle (cons nil reverse)))
1066      (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse)
1067                    (cdr current))
1068           (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
1069           (index start (1+ index))
1070           (number-zapped 0))
1071          ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
1072           (nreverse (cdr handle)))
1073        (declare (fixnum index number-zapped))
1074        (cond (,pred
1075               (rplacd previous (cdr current))
1076               (setq number-zapped (1+ number-zapped)))
1077              (t
1078               (setq previous (cdr previous)))))))
1079
1080 (sb!xc:defmacro normal-list-delete ()
1081   '(list-delete
1082     (if test-not
1083         (not (funcall test-not item (apply-key key (car current))))
1084         (funcall test item (apply-key key (car current))))))
1085
1086 (sb!xc:defmacro normal-list-delete-from-end ()
1087   '(list-delete-from-end
1088     (if test-not
1089         (not (funcall test-not item (apply-key key (car current))))
1090         (funcall test item (apply-key key (car current))))))
1091
1092 ) ; EVAL-WHEN
1093
1094 (defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
1095                 end count key)
1096   #!+sb-doc
1097   "Returns a sequence formed by destructively removing the specified Item from
1098   the given Sequence."
1099   (declare (fixnum start))
1100   (let* ((length (length sequence))
1101          (end (or end length))
1102          (count (or count most-positive-fixnum)))
1103     (declare (type index length end)
1104              (fixnum count))
1105     (seq-dispatch sequence
1106                   (if from-end
1107                       (normal-list-delete-from-end)
1108                       (normal-list-delete))
1109                   (if from-end
1110                       (normal-mumble-delete-from-end)
1111                       (normal-mumble-delete)))))
1112
1113 (eval-when (:compile-toplevel :execute)
1114
1115 (sb!xc:defmacro if-mumble-delete ()
1116   `(mumble-delete
1117     (funcall predicate (apply-key key (aref sequence index)))))
1118
1119 (sb!xc:defmacro if-mumble-delete-from-end ()
1120   `(mumble-delete-from-end
1121     (funcall predicate (apply-key key this-element))))
1122
1123 (sb!xc:defmacro if-list-delete ()
1124   '(list-delete
1125     (funcall predicate (apply-key key (car current)))))
1126
1127 (sb!xc:defmacro if-list-delete-from-end ()
1128   '(list-delete-from-end
1129     (funcall predicate (apply-key key (car current)))))
1130
1131 ) ; EVAL-WHEN
1132
1133 (defun delete-if (predicate sequence &key from-end (start 0) key end count)
1134   #!+sb-doc
1135   "Returns a sequence formed by destructively removing the elements satisfying
1136   the specified Predicate from the given Sequence."
1137   (declare (fixnum start))
1138   (let* ((length (length sequence))
1139          (end (or end length))
1140          (count (or count most-positive-fixnum)))
1141     (declare (type index length end)
1142              (fixnum count))
1143     (seq-dispatch sequence
1144                   (if from-end
1145                       (if-list-delete-from-end)
1146                       (if-list-delete))
1147                   (if from-end
1148                       (if-mumble-delete-from-end)
1149                       (if-mumble-delete)))))
1150
1151 (eval-when (:compile-toplevel :execute)
1152
1153 (sb!xc:defmacro if-not-mumble-delete ()
1154   `(mumble-delete
1155     (not (funcall predicate (apply-key key (aref sequence index))))))
1156
1157 (sb!xc:defmacro if-not-mumble-delete-from-end ()
1158   `(mumble-delete-from-end
1159     (not (funcall predicate (apply-key key this-element)))))
1160
1161 (sb!xc:defmacro if-not-list-delete ()
1162   '(list-delete
1163     (not (funcall predicate (apply-key key (car current))))))
1164
1165 (sb!xc:defmacro if-not-list-delete-from-end ()
1166   '(list-delete-from-end
1167     (not (funcall predicate (apply-key key (car current))))))
1168
1169 ) ; EVAL-WHEN
1170
1171 (defun delete-if-not (predicate sequence &key from-end (start 0) end key count)
1172   #!+sb-doc
1173   "Returns a sequence formed by destructively removing the elements not
1174   satisfying the specified Predicate from the given Sequence."
1175   (declare (fixnum start))
1176   (let* ((length (length sequence))
1177          (end (or end length))
1178          (count (or count most-positive-fixnum)))
1179     (declare (type index length end)
1180              (fixnum count))
1181     (seq-dispatch sequence
1182                   (if from-end
1183                       (if-not-list-delete-from-end)
1184                       (if-not-list-delete))
1185                   (if from-end
1186                       (if-not-mumble-delete-from-end)
1187                       (if-not-mumble-delete)))))
1188 \f
1189 ;;;; REMOVE
1190
1191 (eval-when (:compile-toplevel :execute)
1192
1193 ;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that
1194 ;;; satisfies the predicate.
1195 (sb!xc:defmacro mumble-remove-macro (bump left begin finish right pred)
1196   `(do ((index ,begin (,bump index))
1197         (result
1198          (do ((index ,left (,bump index))
1199               (result (make-sequence-like sequence length)))
1200              ((= index (the fixnum ,begin)) result)
1201            (declare (fixnum index))
1202            (setf (aref result index) (aref sequence index))))
1203         (new-index ,begin)
1204         (number-zapped 0)
1205         (this-element))
1206        ((or (= index (the fixnum ,finish))
1207             (= number-zapped (the fixnum count)))
1208         (do ((index index (,bump index))
1209              (new-index new-index (,bump new-index)))
1210             ((= index (the fixnum ,right)) (shrink-vector result new-index))
1211           (declare (fixnum index new-index))
1212           (setf (aref result new-index) (aref sequence index))))
1213      (declare (fixnum index new-index number-zapped))
1214      (setq this-element (aref sequence index))
1215      (cond (,pred (setq number-zapped (1+ number-zapped)))
1216            (t (setf (aref result new-index) this-element)
1217               (setq new-index (,bump new-index))))))
1218
1219 (sb!xc:defmacro mumble-remove (pred)
1220   `(mumble-remove-macro 1+ 0 start end length ,pred))
1221
1222 (sb!xc:defmacro mumble-remove-from-end (pred)
1223   `(let ((sequence (copy-seq sequence)))
1224      (mumble-delete-from-end ,pred)))
1225
1226 (sb!xc:defmacro normal-mumble-remove ()
1227   `(mumble-remove
1228     (if test-not
1229         (not (funcall test-not item (apply-key key this-element)))
1230         (funcall test item (apply-key key this-element)))))
1231
1232 (sb!xc:defmacro normal-mumble-remove-from-end ()
1233   `(mumble-remove-from-end
1234     (if test-not
1235         (not (funcall test-not item (apply-key key this-element)))
1236         (funcall test item (apply-key key this-element)))))
1237
1238 (sb!xc:defmacro if-mumble-remove ()
1239   `(mumble-remove (funcall predicate (apply-key key this-element))))
1240
1241 (sb!xc:defmacro if-mumble-remove-from-end ()
1242   `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
1243
1244 (sb!xc:defmacro if-not-mumble-remove ()
1245   `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
1246
1247 (sb!xc:defmacro if-not-mumble-remove-from-end ()
1248   `(mumble-remove-from-end
1249     (not (funcall predicate (apply-key key this-element)))))
1250
1251 ;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies
1252 ;;; the predicate.
1253 (sb!xc:defmacro list-remove-macro (pred reverse?)
1254   `(let* ((sequence ,(if reverse?
1255                          '(reverse (the list sequence))
1256                          'sequence))
1257           (splice (list nil))
1258           (results (do ((index 0 (1+ index))
1259                         (before-start splice))
1260                        ((= index (the fixnum start)) before-start)
1261                      (declare (fixnum index))
1262                      (setq splice
1263                            (cdr (rplacd splice (list (pop sequence))))))))
1264      (do ((index start (1+ index))
1265           (this-element)
1266           (number-zapped 0))
1267          ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
1268           (do ((index index (1+ index)))
1269               ((null sequence)
1270                ,(if reverse?
1271                     '(nreverse (the list (cdr results)))
1272                     '(cdr results)))
1273             (declare (fixnum index))
1274             (setq splice (cdr (rplacd splice (list (pop sequence)))))))
1275        (declare (fixnum index number-zapped))
1276        (setq this-element (pop sequence))
1277        (if ,pred
1278            (setq number-zapped (1+ number-zapped))
1279            (setq splice (cdr (rplacd splice (list this-element))))))))
1280
1281 (sb!xc:defmacro list-remove (pred)
1282   `(list-remove-macro ,pred nil))
1283
1284 (sb!xc:defmacro list-remove-from-end (pred)
1285   `(list-remove-macro ,pred t))
1286
1287 (sb!xc:defmacro normal-list-remove ()
1288   `(list-remove
1289     (if test-not
1290         (not (funcall test-not item (apply-key key this-element)))
1291         (funcall test item (apply-key key this-element)))))
1292
1293 (sb!xc:defmacro normal-list-remove-from-end ()
1294   `(list-remove-from-end
1295     (if test-not
1296         (not (funcall test-not item (apply-key key this-element)))
1297         (funcall test item (apply-key key this-element)))))
1298
1299 (sb!xc:defmacro if-list-remove ()
1300   `(list-remove
1301     (funcall predicate (apply-key key this-element))))
1302
1303 (sb!xc:defmacro if-list-remove-from-end ()
1304   `(list-remove-from-end
1305     (funcall predicate (apply-key key this-element))))
1306
1307 (sb!xc:defmacro if-not-list-remove ()
1308   `(list-remove
1309     (not (funcall predicate (apply-key key this-element)))))
1310
1311 (sb!xc:defmacro if-not-list-remove-from-end ()
1312   `(list-remove-from-end
1313     (not (funcall predicate (apply-key key this-element)))))
1314
1315 ) ; EVAL-WHEN
1316
1317 (defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
1318                 end count key)
1319   #!+sb-doc
1320   "Returns a copy of SEQUENCE with elements satisfying the test (default is
1321    EQL) with ITEM removed."
1322   (declare (fixnum start))
1323   (let* ((length (length sequence))
1324          (end (or end length))
1325          (count (or count most-positive-fixnum)))
1326     (declare (type index length end)
1327              (fixnum count))
1328     (seq-dispatch sequence
1329                   (if from-end
1330                       (normal-list-remove-from-end)
1331                       (normal-list-remove))
1332                   (if from-end
1333                       (normal-mumble-remove-from-end)
1334                       (normal-mumble-remove)))))
1335
1336 (defun remove-if (predicate sequence &key from-end (start 0) end count key)
1337   #!+sb-doc
1338   "Returns a copy of sequence with elements such that predicate(element)
1339    is non-null are removed"
1340   (declare (fixnum start))
1341   (let* ((length (length sequence))
1342          (end (or end length))
1343          (count (or count most-positive-fixnum)))
1344     (declare (type index length end)
1345              (fixnum count))
1346     (seq-dispatch sequence
1347                   (if from-end
1348                       (if-list-remove-from-end)
1349                       (if-list-remove))
1350                   (if from-end
1351                       (if-mumble-remove-from-end)
1352                       (if-mumble-remove)))))
1353
1354 (defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
1355   #!+sb-doc
1356   "Returns a copy of sequence with elements such that predicate(element)
1357    is null are removed"
1358   (declare (fixnum start))
1359   (let* ((length (length sequence))
1360          (end (or end length))
1361          (count (or count most-positive-fixnum)))
1362     (declare (type index length end)
1363              (fixnum count))
1364     (seq-dispatch sequence
1365                   (if from-end
1366                       (if-not-list-remove-from-end)
1367                       (if-not-list-remove))
1368                   (if from-end
1369                       (if-not-mumble-remove-from-end)
1370                       (if-not-mumble-remove)))))
1371 \f
1372 ;;;; REMOVE-DUPLICATES
1373
1374 ;;; Remove duplicates from a list. If from-end, remove the later duplicates,
1375 ;;; not the earlier ones. Thus if we check from-end we don't copy an item
1376 ;;; if we look into the already copied structure (from after :start) and see
1377 ;;; the item. If we check from beginning we check into the rest of the
1378 ;;; original list up to the :end marker (this we have to do by running a
1379 ;;; do loop down the list that far and using our test.
1380 (defun list-remove-duplicates* (list test test-not start end key from-end)
1381   (declare (fixnum start))
1382   (let* ((result (list ())) ; Put a marker on the beginning to splice with.
1383          (splice result)
1384          (current list))
1385     (do ((index 0 (1+ index)))
1386         ((= index start))
1387       (declare (fixnum index))
1388       (setq splice (cdr (rplacd splice (list (car current)))))
1389       (setq current (cdr current)))
1390     (do ((index 0 (1+ index)))
1391         ((or (and end (= index (the fixnum end)))
1392              (atom current)))
1393       (declare (fixnum index))
1394       (if (or (and from-end
1395                    (not (member (apply-key key (car current))
1396                                 (nthcdr (1+ start) result)
1397                                 :test test
1398                                 :test-not test-not
1399                                 :key key)))
1400               (and (not from-end)
1401                    (not (do ((it (apply-key key (car current)))
1402                              (l (cdr current) (cdr l))
1403                              (i (1+ index) (1+ i)))
1404                             ((or (atom l) (and end (= i (the fixnum end))))
1405                              ())
1406                           (declare (fixnum i))
1407                           (if (if test-not
1408                                   (not (funcall test-not it (apply-key key (car l))))
1409                                   (funcall test it (apply-key key (car l))))
1410                               (return t))))))
1411           (setq splice (cdr (rplacd splice (list (car current))))))
1412       (setq current (cdr current)))
1413     (do ()
1414         ((atom current))
1415       (setq splice (cdr (rplacd splice (list (car current)))))
1416       (setq current (cdr current)))
1417     (cdr result)))
1418
1419 (defun vector-remove-duplicates* (vector test test-not start end key from-end
1420                                          &optional (length (length vector)))
1421   (declare (vector vector) (fixnum start length))
1422   (when (null end) (setf end (length vector)))
1423   (let ((result (make-sequence-like vector length))
1424         (index 0)
1425         (jndex start))
1426     (declare (fixnum index jndex))
1427     (do ()
1428         ((= index start))
1429       (setf (aref result index) (aref vector index))
1430       (setq index (1+ index)))
1431     (do ((elt))
1432         ((= index end))
1433       (setq elt (aref vector index))
1434       (unless (or (and from-end
1435                         (position (apply-key key elt) result :start start
1436                            :end jndex :test test :test-not test-not :key key))
1437                   (and (not from-end)
1438                         (position (apply-key key elt) vector :start (1+ index)
1439                            :end end :test test :test-not test-not :key key)))
1440         (setf (aref result jndex) elt)
1441         (setq jndex (1+ jndex)))
1442       (setq index (1+ index)))
1443     (do ()
1444         ((= index length))
1445       (setf (aref result jndex) (aref vector index))
1446       (setq index (1+ index))
1447       (setq jndex (1+ jndex)))
1448     (shrink-vector result jndex)))
1449
1450 (defun remove-duplicates (sequence &key
1451                                    (test #'eql)
1452                                    test-not
1453                                    (start 0)
1454                                    from-end
1455                                    end
1456                                    key)
1457   #!+sb-doc
1458   "The elements of Sequence are compared pairwise, and if any two match,
1459    the one occurring earlier is discarded, unless FROM-END is true, in
1460    which case the one later in the sequence is discarded. The resulting
1461    sequence is returned.
1462
1463    The :TEST-NOT argument is depreciated."
1464   (declare (fixnum start))
1465   (seq-dispatch sequence
1466                 (if sequence
1467                     (list-remove-duplicates* sequence test test-not
1468                                               start end key from-end))
1469                 (vector-remove-duplicates* sequence test test-not
1470                                             start end key from-end)))
1471 \f
1472 ;;;; DELETE-DUPLICATES
1473
1474 (defun list-delete-duplicates* (list test test-not key from-end start end)
1475   (declare (fixnum start))
1476   (let ((handle (cons nil list)))
1477     (do ((current (nthcdr start list) (cdr current))
1478          (previous (nthcdr start handle))
1479          (index start (1+ index)))
1480         ((or (and end (= index (the fixnum end))) (null current))
1481          (cdr handle))
1482       (declare (fixnum index))
1483       (if (do ((x (if from-end
1484                       (nthcdr (1+ start) handle)
1485                       (cdr current))
1486                   (cdr x))
1487                (i (1+ index) (1+ i)))
1488               ((or (null x)
1489                    (and (not from-end) end (= i (the fixnum end)))
1490                    (eq x current))
1491                nil)
1492             (declare (fixnum i))
1493             (if (if test-not
1494                     (not (funcall test-not
1495                                   (apply-key key (car current))
1496                                   (apply-key key (car x))))
1497                     (funcall test
1498                              (apply-key key (car current))
1499                              (apply-key key (car x))))
1500                 (return t)))
1501           (rplacd previous (cdr current))
1502           (setq previous (cdr previous))))))
1503
1504 (defun vector-delete-duplicates* (vector test test-not key from-end start end
1505                                          &optional (length (length vector)))
1506   (declare (vector vector) (fixnum start length))
1507   (when (null end) (setf end (length vector)))
1508   (do ((index start (1+ index))
1509        (jndex start))
1510       ((= index end)
1511        (do ((index index (1+ index))            ; copy the rest of the vector
1512             (jndex jndex (1+ jndex)))
1513            ((= index length)
1514             (shrink-vector vector jndex)
1515             vector)
1516          (setf (aref vector jndex) (aref vector index))))
1517     (declare (fixnum index jndex))
1518     (setf (aref vector jndex) (aref vector index))
1519     (unless (position (apply-key key (aref vector index)) vector :key key
1520                       :start (if from-end start (1+ index)) :test test
1521                       :end (if from-end jndex end) :test-not test-not)
1522       (setq jndex (1+ jndex)))))
1523
1524 (defun delete-duplicates (sequence &key
1525                                    (test #'eql)
1526                                    test-not
1527                                    (start 0)
1528                                    from-end
1529                                    end
1530                                    key)
1531   #!+sb-doc
1532   "The elements of Sequence are examined, and if any two match, one is
1533    discarded. The resulting sequence, which may be formed by destroying the
1534    given sequence, is returned.
1535
1536    The :TEST-NOT argument is depreciated."
1537   (seq-dispatch sequence
1538     (if sequence
1539         (list-delete-duplicates* sequence test test-not key from-end start end))
1540   (vector-delete-duplicates* sequence test test-not key from-end start end)))
1541 \f
1542 ;;;; SUBSTITUTE
1543
1544 (defun list-substitute* (pred new list start end count key test test-not old)
1545   (declare (fixnum start end count))
1546   (let* ((result (list nil))
1547          elt
1548          (splice result)
1549          (list list))      ; Get a local list for a stepper.
1550     (do ((index 0 (1+ index)))
1551         ((= index start))
1552       (declare (fixnum index))
1553       (setq splice (cdr (rplacd splice (list (car list)))))
1554       (setq list (cdr list)))
1555     (do ((index start (1+ index)))
1556         ((or (= index end) (null list) (= count 0)))
1557       (declare (fixnum index))
1558       (setq elt (car list))
1559       (setq splice
1560             (cdr (rplacd splice
1561                          (list
1562                           (cond
1563                            ((case pred
1564                                    (normal
1565                                     (if test-not
1566                                         (not
1567                                          (funcall test-not old (apply-key key elt)))
1568                                         (funcall test old (apply-key key elt))))
1569                                    (if (funcall test (apply-key key elt)))
1570                                    (if-not (not (funcall test (apply-key key elt)))))
1571                             (setq count (1- count))
1572                             new)
1573                                 (t elt))))))
1574       (setq list (cdr list)))
1575     (do ()
1576         ((null list))
1577       (setq splice (cdr (rplacd splice (list (car list)))))
1578       (setq list (cdr list)))
1579     (cdr result)))
1580
1581 ;;; Replace old with new in sequence moving from left to right by incrementer
1582 ;;; on each pass through the loop. Called by all three substitute functions.
1583 (defun vector-substitute* (pred new sequence incrementer left right length
1584                            start end count key test test-not old)
1585   (declare (fixnum start count end incrementer right))
1586   (let ((result (make-sequence-like sequence length))
1587         (index left))
1588     (declare (fixnum index))
1589     (do ()
1590         ((= index start))
1591       (setf (aref result index) (aref sequence index))
1592       (setq index (+ index incrementer)))
1593     (do ((elt))
1594         ((or (= index end) (= count 0)))
1595       (setq elt (aref sequence index))
1596       (setf (aref result index)
1597             (cond ((case pred
1598                           (normal
1599                             (if test-not
1600                                 (not (funcall test-not old (apply-key key elt)))
1601                                 (funcall test old (apply-key key elt))))
1602                           (if (funcall test (apply-key key elt)))
1603                           (if-not (not (funcall test (apply-key key elt)))))
1604                    (setq count (1- count))
1605                    new)
1606                   (t elt)))
1607       (setq index (+ index incrementer)))
1608     (do ()
1609         ((= index right))
1610       (setf (aref result index) (aref sequence index))
1611       (setq index (+ index incrementer)))
1612     result))
1613
1614 (eval-when (:compile-toplevel :execute)
1615
1616 (sb!xc:defmacro subst-dispatch (pred)
1617   `(if (listp sequence)
1618        (if from-end
1619            (nreverse (list-substitute* ,pred
1620                                        new
1621                                        (reverse sequence)
1622                                        (- (the fixnum length)
1623                                           (the fixnum end))
1624                                        (- (the fixnum length)
1625                                           (the fixnum start))
1626                                        count key test test-not old))
1627            (list-substitute* ,pred
1628                              new sequence start end count key test test-not
1629                              old))
1630       (if from-end
1631           (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
1632                               -1 length (1- (the fixnum end))
1633                               (1- (the fixnum start))
1634                               count key test test-not old)
1635           (vector-substitute* ,pred new sequence 1 0 length length
1636            start end count key test test-not old))))
1637
1638 ) ; EVAL-WHEN
1639
1640 (defun substitute (new old sequence &key from-end (test #'eql) test-not
1641                    (start 0) count end key)
1642   #!+sb-doc
1643   "Returns a sequence of the same kind as Sequence with the same elements
1644   except that all elements equal to Old are replaced with New. See manual
1645   for details."
1646   (declare (fixnum start))
1647   (let* ((length (length sequence))
1648          (end (or end length))
1649          (count (or count most-positive-fixnum)))
1650     (declare (type index length end)
1651              (fixnum count))
1652     (subst-dispatch 'normal)))
1653 \f
1654 ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
1655
1656 (defun substitute-if (new test sequence &key from-end (start 0) end count key)
1657   #!+sb-doc
1658   "Returns a sequence of the same kind as Sequence with the same elements
1659   except that all elements satisfying the Test are replaced with New. See
1660   manual for details."
1661   (declare (fixnum start))
1662   (let* ((length (length sequence))
1663          (end (or end length))
1664          (count (or count most-positive-fixnum))
1665          test-not
1666          old)
1667     (declare (type index length end)
1668              (fixnum count))
1669     (subst-dispatch 'if)))
1670
1671 (defun substitute-if-not (new test sequence &key from-end (start 0)
1672                            end count key)
1673   #!+sb-doc
1674   "Returns a sequence of the same kind as Sequence with the same elements
1675   except that all elements not satisfying the Test are replaced with New.
1676   See manual for details."
1677   (declare (fixnum start))
1678   (let* ((length (length sequence))
1679          (end (or end length))
1680          (count (or count most-positive-fixnum))
1681          test-not
1682          old)
1683     (declare (type index length end)
1684              (fixnum count))
1685     (subst-dispatch 'if-not)))
1686 \f
1687 ;;;; NSUBSTITUTE
1688
1689 (defun nsubstitute (new old sequence &key from-end (test #'eql) test-not
1690                      end count key (start 0))
1691   #!+sb-doc
1692   "Returns a sequence of the same kind as Sequence with the same elements
1693   except that all elements equal to Old are replaced with New. The Sequence
1694   may be destroyed. See manual for details."
1695   (declare (fixnum start))
1696   (let ((end (or end (length sequence)))
1697         (count (or count most-positive-fixnum)))
1698     (declare (fixnum count))
1699     (if (listp sequence)
1700         (if from-end
1701             (nreverse (nlist-substitute*
1702                        new old (nreverse (the list sequence))
1703                        test test-not start end count key))
1704             (nlist-substitute* new old sequence
1705                                test test-not start end count key))
1706         (if from-end
1707             (nvector-substitute* new old sequence -1
1708                                  test test-not (1- end) (1- start) count key)
1709             (nvector-substitute* new old sequence 1
1710                                  test test-not start end count key)))))
1711
1712 (defun nlist-substitute* (new old sequence test test-not start end count key)
1713   (declare (fixnum start count end))
1714   (do ((list (nthcdr start sequence) (cdr list))
1715        (index start (1+ index)))
1716       ((or (= index end) (null list) (= count 0)) sequence)
1717     (declare (fixnum index))
1718     (when (if test-not
1719               (not (funcall test-not old (apply-key key (car list))))
1720               (funcall test old (apply-key key (car list))))
1721       (rplaca list new)
1722       (setq count (1- count)))))
1723
1724 (defun nvector-substitute* (new old sequence incrementer
1725                             test test-not start end count key)
1726   (declare (fixnum start incrementer count end))
1727   (do ((index start (+ index incrementer)))
1728       ((or (= index end) (= count 0)) sequence)
1729     (declare (fixnum index))
1730     (when (if test-not
1731               (not (funcall test-not
1732                             old
1733                             (apply-key key (aref sequence index))))
1734               (funcall test old (apply-key key (aref sequence index))))
1735       (setf (aref sequence index) new)
1736       (setq count (1- count)))))
1737 \f
1738 ;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
1739
1740 (defun nsubstitute-if (new test sequence &key from-end (start 0) end count key)
1741   #!+sb-doc
1742   "Returns a sequence of the same kind as Sequence with the same elements
1743    except that all elements satisfying the Test are replaced with New. The
1744    Sequence may be destroyed. See manual for details."
1745   (declare (fixnum start))
1746   (let ((end (or end (length sequence)))
1747         (count (or count most-positive-fixnum)))
1748     (declare (fixnum end count))
1749     (if (listp sequence)
1750         (if from-end
1751             (nreverse (nlist-substitute-if*
1752                        new test (nreverse (the list sequence))
1753                        start end count key))
1754             (nlist-substitute-if* new test sequence
1755                                   start end count key))
1756         (if from-end
1757             (nvector-substitute-if* new test sequence -1
1758                                     (1- end) (1- start) count key)
1759             (nvector-substitute-if* new test sequence 1
1760                                     start end count key)))))
1761
1762 (defun nlist-substitute-if* (new test sequence start end count key)
1763   (declare (fixnum end))
1764   (do ((list (nthcdr start sequence) (cdr list))
1765        (index start (1+ index)))
1766       ((or (= index end) (null list) (= count 0)) sequence)
1767     (when (funcall test (apply-key key (car list)))
1768       (rplaca list new)
1769       (setq count (1- count)))))
1770
1771 (defun nvector-substitute-if* (new test sequence incrementer
1772                                start end count key)
1773   (do ((index start (+ index incrementer)))
1774       ((or (= index end) (= count 0)) sequence)
1775     (when (funcall test (apply-key key (aref sequence index)))
1776       (setf (aref sequence index) new)
1777       (setq count (1- count)))))
1778
1779 (defun nsubstitute-if-not (new test sequence &key from-end (start 0)
1780                                end count key)
1781   #!+sb-doc
1782   "Returns a sequence of the same kind as Sequence with the same elements
1783    except that all elements not satisfying the Test are replaced with New.
1784    The Sequence may be destroyed. See manual for details."
1785   (declare (fixnum start))
1786   (let ((end (or end (length sequence)))
1787         (count (or count most-positive-fixnum)))
1788     (declare (fixnum end count))
1789     (if (listp sequence)
1790         (if from-end
1791             (nreverse (nlist-substitute-if-not*
1792                        new test (nreverse (the list sequence))
1793                        start end count key))
1794             (nlist-substitute-if-not* new test sequence
1795                                       start end count key))
1796         (if from-end
1797             (nvector-substitute-if-not* new test sequence -1
1798                                         (1- end) (1- start) count key)
1799             (nvector-substitute-if-not* new test sequence 1
1800                                         start end count key)))))
1801
1802 (defun nlist-substitute-if-not* (new test sequence start end count key)
1803   (declare (fixnum end))
1804   (do ((list (nthcdr start sequence) (cdr list))
1805        (index start (1+ index)))
1806       ((or (= index end) (null list) (= count 0)) sequence)
1807     (when (not (funcall test (apply-key key (car list))))
1808       (rplaca list new)
1809       (setq count (1- count)))))
1810
1811 (defun nvector-substitute-if-not* (new test sequence incrementer
1812                                    start end count key)
1813   (do ((index start (+ index incrementer)))
1814       ((or (= index end) (= count 0)) sequence)
1815     (when (not (funcall test (apply-key key (aref sequence index))))
1816       (setf (aref sequence index) new)
1817       (setq count (1- count)))))
1818 \f
1819 ;;; locater macros used by FIND and POSITION
1820
1821 (eval-when (:compile-toplevel :execute)
1822
1823 (sb!xc:defmacro vector-locater-macro (sequence body-form return-type)
1824   `(let ((incrementer (if from-end -1 1))
1825          (start (if from-end (1- (the fixnum end)) start))
1826          (end (if from-end (1- (the fixnum start)) end)))
1827      (declare (fixnum start end incrementer))
1828      (do ((index start (+ index incrementer))
1829           ,@(case return-type (:position nil) (:element '(current))))
1830          ((= index end) ())
1831        (declare (fixnum index))
1832        ,@(case return-type
1833            (:position nil)
1834            (:element `((setf current (aref ,sequence index)))))
1835        ,body-form)))
1836
1837 (sb!xc:defmacro locater-test-not (item sequence seq-type return-type)
1838   (let ((seq-ref (case return-type
1839                    (:position
1840                     (case seq-type
1841                       (:vector `(aref ,sequence index))
1842                       (:list `(pop ,sequence))))
1843                    (:element 'current)))
1844         (return (case return-type
1845                   (:position 'index)
1846                   (:element 'current))))
1847     `(if test-not
1848          (if (not (funcall test-not ,item (apply-key key ,seq-ref)))
1849              (return ,return))
1850          (if (funcall test ,item (apply-key key ,seq-ref))
1851              (return ,return)))))
1852
1853 (sb!xc:defmacro vector-locater (item sequence return-type)
1854   `(vector-locater-macro ,sequence
1855                          (locater-test-not ,item ,sequence :vector ,return-type)
1856                          ,return-type))
1857 \f
1858 (sb!xc:defmacro locater-if-test (test sequence seq-type return-type sense)
1859   (let ((seq-ref (case return-type
1860                    (:position
1861                     (case seq-type
1862                       (:vector `(aref ,sequence index))
1863                       (:list `(pop ,sequence))))
1864                    (:element 'current)))
1865         (return (case return-type
1866                   (:position 'index)
1867                   (:element 'current))))
1868     (if sense
1869         `(if (funcall ,test (apply-key key ,seq-ref))
1870              (return ,return))
1871         `(if (not (funcall ,test (apply-key key ,seq-ref)))
1872              (return ,return)))))
1873
1874 (sb!xc:defmacro vector-locater-if-macro (test sequence return-type sense)
1875   `(vector-locater-macro ,sequence
1876                          (locater-if-test ,test ,sequence :vector ,return-type ,sense)
1877                          ,return-type))
1878
1879 (sb!xc:defmacro vector-locater-if (test sequence return-type)
1880   `(vector-locater-if-macro ,test ,sequence ,return-type t))
1881
1882 (sb!xc:defmacro vector-locater-if-not (test sequence return-type)
1883   `(vector-locater-if-macro ,test ,sequence ,return-type nil))
1884 \f
1885 (sb!xc:defmacro list-locater-macro (sequence body-form return-type)
1886   `(if from-end
1887        (do ((sequence (nthcdr (- (the fixnum (length sequence))
1888                                  (the fixnum end))
1889                               (reverse (the list ,sequence))))
1890             (index (1- (the fixnum end)) (1- index))
1891             (terminus (1- (the fixnum start)))
1892             ,@(case return-type (:position nil) (:element '(current))))
1893            ((or (= index terminus) (null sequence)) ())
1894          (declare (fixnum index terminus))
1895          ,@(case return-type
1896              (:position nil)
1897              (:element `((setf current (pop ,sequence)))))
1898          ,body-form)
1899        (do ((sequence (nthcdr start ,sequence))
1900             (index start (1+ index))
1901             ,@(case return-type (:position nil) (:element '(current))))
1902            ((or (= index (the fixnum end)) (null sequence)) ())
1903          (declare (fixnum index))
1904          ,@(case return-type
1905              (:position nil)
1906              (:element `((setf current (pop ,sequence)))))
1907          ,body-form)))
1908
1909 (sb!xc:defmacro list-locater (item sequence return-type)
1910   `(list-locater-macro ,sequence
1911                        (locater-test-not ,item ,sequence :list ,return-type)
1912                        ,return-type))
1913
1914 (sb!xc:defmacro list-locater-if-macro (test sequence return-type sense)
1915   `(list-locater-macro ,sequence
1916                        (locater-if-test ,test ,sequence :list ,return-type ,sense)
1917                        ,return-type))
1918
1919 (sb!xc:defmacro list-locater-if (test sequence return-type)
1920   `(list-locater-if-macro ,test ,sequence ,return-type t))
1921
1922 (sb!xc:defmacro list-locater-if-not (test sequence return-type)
1923   `(list-locater-if-macro ,test ,sequence ,return-type nil))
1924
1925 ) ; EVAL-WHEN
1926 \f
1927 ;;; POSITION
1928
1929 (eval-when (:compile-toplevel :execute)
1930
1931 (sb!xc:defmacro vector-position (item sequence)
1932   `(vector-locater ,item ,sequence :position))
1933
1934 (sb!xc:defmacro list-position (item sequence)
1935   `(list-locater ,item ,sequence :position))
1936
1937 ) ; EVAL-WHEN
1938
1939 ;;; POSITION cannot default end to the length of sequence since it is not
1940 ;;; an error to supply nil for its value. We must test for end being nil
1941 ;;; in the body of the function, and this is actually done in the support
1942 ;;; routines for other reasons (see below).
1943 (defun position (item sequence &key from-end (test #'eql) test-not (start 0)
1944                   end key)
1945   #!+sb-doc
1946   "Returns the zero-origin index of the first element in SEQUENCE
1947    satisfying the test (default is EQL) with the given ITEM"
1948   (seq-dispatch sequence
1949     (list-position* item sequence from-end test test-not start end key)
1950     (vector-position* item sequence from-end test test-not start end key)))
1951
1952 ;;; The support routines for SUBSEQ are used by compiler transforms, so we
1953 ;;; worry about dealing with END being supplied or defaulting to NIL
1954 ;;; at this level.
1955
1956 (defun list-position* (item sequence from-end test test-not start end key)
1957   (declare (fixnum start))
1958   (when (null end) (setf end (length sequence)))
1959   (list-position item sequence))
1960
1961 (defun vector-position* (item sequence from-end test test-not start end key)
1962   (declare (fixnum start))
1963   (when (null end) (setf end (length sequence)))
1964   (vector-position item sequence))
1965 \f
1966 ;;;; POSITION-IF
1967
1968 (eval-when (:compile-toplevel :execute)
1969
1970 (sb!xc:defmacro vector-position-if (test sequence)
1971   `(vector-locater-if ,test ,sequence :position))
1972
1973 (sb!xc:defmacro list-position-if (test sequence)
1974   `(list-locater-if ,test ,sequence :position))
1975
1976 ) ; EVAL-WHEN
1977
1978 (defun position-if (test sequence &key from-end (start 0) key end)
1979   #!+sb-doc
1980   "Returns the zero-origin index of the first element satisfying test(el)"
1981   (declare (fixnum start))
1982   (let ((end (or end (length sequence))))
1983     (declare (type index end))
1984     (seq-dispatch sequence
1985                   (list-position-if test sequence)
1986                   (vector-position-if test sequence))))
1987 \f
1988 ;;;; POSITION-IF-NOT
1989
1990 (eval-when (:compile-toplevel :execute)
1991
1992 (sb!xc:defmacro vector-position-if-not (test sequence)
1993   `(vector-locater-if-not ,test ,sequence :position))
1994
1995 (sb!xc:defmacro list-position-if-not (test sequence)
1996   `(list-locater-if-not ,test ,sequence :position))
1997
1998 ) ; EVAL-WHEN
1999
2000 (defun position-if-not (test sequence &key from-end (start 0) key end)
2001   #!+sb-doc
2002   "Returns the zero-origin index of the first element not satisfying test(el)"
2003   (declare (fixnum start))
2004   (let ((end (or end (length sequence))))
2005     (declare (type index end))
2006     (seq-dispatch sequence
2007                   (list-position-if-not test sequence)
2008                   (vector-position-if-not test sequence))))
2009 \f
2010 ;;;; FIND
2011
2012 (eval-when (:compile-toplevel :execute)
2013
2014 (sb!xc:defmacro vector-find (item sequence)
2015   `(vector-locater ,item ,sequence :element))
2016
2017 (sb!xc:defmacro list-find (item sequence)
2018   `(list-locater ,item ,sequence :element))
2019
2020 ) ; EVAL-WHEN
2021
2022 ;;; Note: FIND cannot default end to the length of sequence since it
2023 ;;; is not an error to supply NIL for its value. We must test for end
2024 ;;; being NIL in the body of the function, and this is actually done
2025 ;;; in the support routines for other reasons (see above).
2026 (defun find (item sequence &key from-end (test #'eql) test-not (start 0)
2027                   end key)
2028   #!+sb-doc
2029   "Returns the first element in SEQUENCE satisfying the test (default
2030    is EQL) with the given ITEM"
2031   (declare (fixnum start))
2032   (seq-dispatch sequence
2033     (list-find* item sequence from-end test test-not start end key)
2034     (vector-find* item sequence from-end test test-not start end key)))
2035
2036 ;;; The support routines for FIND are used by compiler transforms, so we
2037 ;;; worry about dealing with END being supplied or defaulting to NIL
2038 ;;; at this level.
2039
2040 (defun list-find* (item sequence from-end test test-not start end key)
2041   (when (null end) (setf end (length sequence)))
2042   (list-find item sequence))
2043
2044 (defun vector-find* (item sequence from-end test test-not start end key)
2045   (when (null end) (setf end (length sequence)))
2046   (vector-find item sequence))
2047 \f
2048 ;;;; FIND-IF and FIND-IF-NOT
2049
2050 (eval-when (:compile-toplevel :execute)
2051
2052 (sb!xc:defmacro vector-find-if (test sequence)
2053   `(vector-locater-if ,test ,sequence :element))
2054
2055 (sb!xc:defmacro list-find-if (test sequence)
2056   `(list-locater-if ,test ,sequence :element))
2057
2058 ) ; EVAL-WHEN
2059
2060 (defun find-if (test sequence &key from-end (start 0) end key)
2061   #!+sb-doc
2062   "Returns the zero-origin index of the first element satisfying the test."
2063   (declare (fixnum start))
2064   (let ((end (or end (length sequence))))
2065     (declare (type index end))
2066     (seq-dispatch sequence
2067                   (list-find-if test sequence)
2068                   (vector-find-if test sequence))))
2069
2070 (eval-when (:compile-toplevel :execute)
2071
2072 (sb!xc:defmacro vector-find-if-not (test sequence)
2073   `(vector-locater-if-not ,test ,sequence :element))
2074
2075 (sb!xc:defmacro list-find-if-not (test sequence)
2076   `(list-locater-if-not ,test ,sequence :element))
2077
2078 ) ; EVAL-WHEN
2079
2080 (defun find-if-not (test sequence &key from-end (start 0) end key)
2081   #!+sb-doc
2082   "Returns the zero-origin index of the first element not satisfying the test."
2083   (declare (fixnum start))
2084   (let ((end (or end (length sequence))))
2085     (declare (type index end))
2086     (seq-dispatch sequence
2087                   (list-find-if-not test sequence)
2088                   (vector-find-if-not test sequence))))
2089 \f
2090 ;;;; COUNT
2091
2092 (eval-when (:compile-toplevel :execute)
2093
2094 (sb!xc:defmacro vector-count (item sequence)
2095   `(do ((index start (1+ index))
2096         (count 0))
2097        ((= index (the fixnum end)) count)
2098      (declare (fixnum index count))
2099      (if test-not
2100          (unless (funcall test-not ,item
2101                           (apply-key key (aref ,sequence index)))
2102            (setq count (1+ count)))
2103          (when (funcall test ,item (apply-key key (aref ,sequence index)))
2104            (setq count (1+ count))))))
2105
2106 (sb!xc:defmacro list-count (item sequence)
2107   `(do ((sequence (nthcdr start ,sequence))
2108         (index start (1+ index))
2109         (count 0))
2110        ((or (= index (the fixnum end)) (null sequence)) count)
2111      (declare (fixnum index count))
2112      (if test-not
2113          (unless (funcall test-not ,item (apply-key key (pop sequence)))
2114            (setq count (1+ count)))
2115          (when (funcall test ,item (apply-key key (pop sequence)))
2116            (setq count (1+ count))))))
2117
2118 ) ; EVAL-WHEN
2119
2120 (defun count (item sequence &key from-end (test #'eql) test-not (start 0)
2121                 end key)
2122   #!+sb-doc
2123   "Returns the number of elements in SEQUENCE satisfying a test with ITEM,
2124    which defaults to EQL."
2125   (declare (ignore from-end) (fixnum start))
2126   (let ((end (or end (length sequence))))
2127     (declare (type index end))
2128     (seq-dispatch sequence
2129                   (list-count item sequence)
2130                   (vector-count item sequence))))
2131 \f
2132 ;;;; COUNT-IF and COUNT-IF-NOT
2133
2134 (eval-when (:compile-toplevel :execute)
2135
2136 (sb!xc:defmacro vector-count-if (predicate sequence)
2137   `(do ((index start (1+ index))
2138         (count 0))
2139        ((= index (the fixnum end)) count)
2140      (declare (fixnum index count))
2141      (if (funcall ,predicate (apply-key key (aref ,sequence index)))
2142          (setq count (1+ count)))))
2143
2144 (sb!xc:defmacro list-count-if (predicate sequence)
2145   `(do ((sequence (nthcdr start ,sequence))
2146         (index start (1+ index))
2147         (count 0))
2148        ((or (= index (the fixnum end)) (null sequence)) count)
2149      (declare (fixnum index count))
2150      (if (funcall ,predicate (apply-key key (pop sequence)))
2151          (setq count (1+ count)))))
2152
2153 ) ; EVAL-WHEN
2154
2155 (defun count-if (test sequence &key from-end (start 0) end key)
2156   #!+sb-doc
2157   "Returns the number of elements in SEQUENCE satisfying TEST(el)."
2158   (declare (ignore from-end) (fixnum start))
2159   (let ((end (or end (length sequence))))
2160     (declare (type index end))
2161     (seq-dispatch sequence
2162                   (list-count-if test sequence)
2163                   (vector-count-if test sequence))))
2164
2165 (eval-when (:compile-toplevel :execute)
2166
2167 (sb!xc:defmacro vector-count-if-not (predicate sequence)
2168   `(do ((index start (1+ index))
2169         (count 0))
2170        ((= index (the fixnum end)) count)
2171      (declare (fixnum index count))
2172      (if (not (funcall ,predicate (apply-key key (aref ,sequence index))))
2173          (setq count (1+ count)))))
2174
2175 (sb!xc:defmacro list-count-if-not (predicate sequence)
2176   `(do ((sequence (nthcdr start ,sequence))
2177         (index start (1+ index))
2178         (count 0))
2179        ((or (= index (the fixnum end)) (null sequence)) count)
2180      (declare (fixnum index count))
2181      (if (not (funcall ,predicate (apply-key key (pop sequence))))
2182          (setq count (1+ count)))))
2183
2184 ) ; EVAL-WHEN
2185
2186 (defun count-if-not (test sequence &key from-end (start 0) end key)
2187   #!+sb-doc
2188   "Returns the number of elements in SEQUENCE not satisfying TEST(el)."
2189   (declare (ignore from-end) (fixnum start))
2190   (let ((end (or end (length sequence))))
2191     (declare (type index end))
2192     (seq-dispatch sequence
2193                   (list-count-if-not test sequence)
2194                   (vector-count-if-not test sequence))))
2195 \f
2196 ;;;; MISMATCH
2197
2198 (eval-when (:compile-toplevel :execute)
2199
2200 (sb!xc:defmacro match-vars (&rest body)
2201   `(let ((inc (if from-end -1 1))
2202          (start1 (if from-end (1- (the fixnum end1)) start1))
2203          (start2 (if from-end (1- (the fixnum end2)) start2))
2204          (end1 (if from-end (1- (the fixnum start1)) end1))
2205          (end2 (if from-end (1- (the fixnum start2)) end2)))
2206      (declare (fixnum inc start1 start2 end1 end2))
2207      ,@body))
2208
2209 (sb!xc:defmacro matchify-list ((sequence start length end) &body body)
2210   (declare (ignore end)) ;; ### Should END be used below?
2211   `(let ((,sequence (if from-end
2212                         (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
2213                                 (reverse (the list ,sequence)))
2214                         (nthcdr ,start ,sequence))))
2215      (declare (type list ,sequence))
2216      ,@body))
2217
2218 ) ; EVAL-WHEN
2219
2220 (eval-when (:compile-toplevel :execute)
2221
2222 (sb!xc:defmacro if-mismatch (elt1 elt2)
2223   `(cond ((= (the fixnum index1) (the fixnum end1))
2224           (return (if (= (the fixnum index2) (the fixnum end2))
2225                       nil
2226                       (if from-end
2227                           (1+ (the fixnum index1))
2228                           (the fixnum index1)))))
2229          ((= (the fixnum index2) (the fixnum end2))
2230           (return (if from-end (1+ (the fixnum index1)) index1)))
2231          (test-not
2232           (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
2233               (return (if from-end (1+ (the fixnum index1)) index1))))
2234          (t (if (not (funcall test (apply-key key ,elt1)
2235                               (apply-key key ,elt2)))
2236                 (return (if from-end (1+ (the fixnum index1)) index1))))))
2237
2238 (sb!xc:defmacro mumble-mumble-mismatch ()
2239   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2240         (index2 start2 (+ index2 (the fixnum inc))))
2241        (())
2242      (declare (fixnum index1 index2))
2243      (if-mismatch (aref sequence1 index1) (aref sequence2 index2))))
2244
2245 (sb!xc:defmacro mumble-list-mismatch ()
2246   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2247         (index2 start2 (+ index2 (the fixnum inc))))
2248        (())
2249      (declare (fixnum index1 index2))
2250      (if-mismatch (aref sequence1 index1) (pop sequence2))))
2251 \f
2252 (sb!xc:defmacro list-mumble-mismatch ()
2253   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2254         (index2 start2 (+ index2 (the fixnum inc))))
2255        (())
2256      (declare (fixnum index1 index2))
2257      (if-mismatch (pop sequence1) (aref sequence2 index2))))
2258
2259 (sb!xc:defmacro list-list-mismatch ()
2260   `(do ((sequence1 sequence1)
2261         (sequence2 sequence2)
2262         (index1 start1 (+ index1 (the fixnum inc)))
2263         (index2 start2 (+ index2 (the fixnum inc))))
2264        (())
2265      (declare (fixnum index1 index2))
2266      (if-mismatch (pop sequence1) (pop sequence2))))
2267
2268 ) ; EVAL-WHEN
2269
2270 (defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not
2271                            (start1 0) end1 (start2 0) end2 key)
2272   #!+sb-doc
2273   "The specified subsequences of Sequence1 and Sequence2 are compared
2274    element-wise. If they are of equal length and match in every element, the
2275    result is Nil. Otherwise, the result is a non-negative integer, the index
2276    within Sequence1 of the leftmost position at which they fail to match; or,
2277    if one is shorter than and a matching prefix of the other, the index within
2278    Sequence1 beyond the last position tested is returned. If a non-Nil
2279    :From-End keyword argument is given, then one plus the index of the
2280    rightmost position in which the sequences differ is returned."
2281   (declare (fixnum start1 start2))
2282   (let* ((length1 (length sequence1))
2283          (end1 (or end1 length1))
2284          (length2 (length sequence2))
2285          (end2 (or end2 length2)))
2286     (declare (type index length1 end1 length2 end2))
2287     (match-vars
2288      (seq-dispatch sequence1
2289        (matchify-list (sequence1 start1 length1 end1)
2290          (seq-dispatch sequence2
2291            (matchify-list (sequence2 start2 length2 end2)
2292              (list-list-mismatch))
2293            (list-mumble-mismatch)))
2294        (seq-dispatch sequence2
2295          (matchify-list (sequence2 start2 length2 end2)
2296            (mumble-list-mismatch))
2297          (mumble-mumble-mismatch))))))
2298 \f
2299 ;;; search comparison functions
2300
2301 (eval-when (:compile-toplevel :execute)
2302
2303 ;;; Compare two elements and return if they don't match.
2304 (sb!xc:defmacro compare-elements (elt1 elt2)
2305   `(if test-not
2306        (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
2307            (return nil)
2308            t)
2309        (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
2310            (return nil)
2311            t)))
2312
2313 (sb!xc:defmacro search-compare-list-list (main sub)
2314   `(do ((main ,main (cdr main))
2315         (jndex start1 (1+ jndex))
2316         (sub (nthcdr start1 ,sub) (cdr sub)))
2317        ((or (null main) (null sub) (= (the fixnum end1) jndex))
2318         t)
2319      (declare (fixnum jndex))
2320      (compare-elements (car main) (car sub))))
2321
2322 (sb!xc:defmacro search-compare-list-vector (main sub)
2323   `(do ((main ,main (cdr main))
2324         (index start1 (1+ index)))
2325        ((or (null main) (= index (the fixnum end1))) t)
2326      (declare (fixnum index))
2327      (compare-elements (car main) (aref ,sub index))))
2328
2329 (sb!xc:defmacro search-compare-vector-list (main sub index)
2330   `(do ((sub (nthcdr start1 ,sub) (cdr sub))
2331         (jndex start1 (1+ jndex))
2332         (index ,index (1+ index)))
2333        ((or (= (the fixnum end1) jndex) (null sub)) t)
2334      (declare (fixnum jndex index))
2335      (compare-elements (aref ,main index) (car sub))))
2336
2337 (sb!xc:defmacro search-compare-vector-vector (main sub index)
2338   `(do ((index ,index (1+ index))
2339         (sub-index start1 (1+ sub-index)))
2340        ((= sub-index (the fixnum end1)) t)
2341      (declare (fixnum sub-index index))
2342      (compare-elements (aref ,main index) (aref ,sub sub-index))))
2343
2344 (sb!xc:defmacro search-compare (main-type main sub index)
2345   (if (eq main-type 'list)
2346       `(seq-dispatch ,sub
2347                      (search-compare-list-list ,main ,sub)
2348                      (search-compare-list-vector ,main ,sub))
2349       `(seq-dispatch ,sub
2350                      (search-compare-vector-list ,main ,sub ,index)
2351                      (search-compare-vector-vector ,main ,sub ,index))))
2352
2353 ) ; EVAL-WHEN
2354 \f
2355 ;;;; SEARCH
2356
2357 (eval-when (:compile-toplevel :execute)
2358
2359 (sb!xc:defmacro list-search (main sub)
2360   `(do ((main (nthcdr start2 ,main) (cdr main))
2361         (index2 start2 (1+ index2))
2362         (terminus (- (the fixnum end2)
2363                      (the fixnum (- (the fixnum end1)
2364                                     (the fixnum start1)))))
2365         (last-match ()))
2366        ((> index2 terminus) last-match)
2367      (declare (fixnum index2 terminus))
2368      (if (search-compare list main ,sub index2)
2369          (if from-end
2370              (setq last-match index2)
2371              (return index2)))))
2372
2373 (sb!xc:defmacro vector-search (main sub)
2374   `(do ((index2 start2 (1+ index2))
2375         (terminus (- (the fixnum end2)
2376                      (the fixnum (- (the fixnum end1)
2377                                     (the fixnum start1)))))
2378         (last-match ()))
2379        ((> index2 terminus) last-match)
2380      (declare (fixnum index2 terminus))
2381      (if (search-compare vector ,main ,sub index2)
2382          (if from-end
2383              (setq last-match index2)
2384              (return index2)))))
2385
2386 ) ; EVAL-WHEN
2387
2388 (defun search (sequence1 sequence2 &key from-end (test #'eql) test-not
2389                 (start1 0) end1 (start2 0) end2 key)
2390   (declare (fixnum start1 start2))
2391   (let ((end1 (or end1 (length sequence1)))
2392         (end2 (or end2 (length sequence2))))
2393     (seq-dispatch sequence2
2394                   (list-search sequence2 sequence1)
2395                   (vector-search sequence2 sequence1))))