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