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