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