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