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