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