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