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       (unless (or (and from-end
1686                        (if test-not
1687                            (position (apply-key key elt) result
1688                                      :start start :end jndex
1689                                      :test-not test-not :key key)
1690                            (position (apply-key key elt) result
1691                                      :start start :end jndex
1692                                      :test test :key key)))
1693                   (and (not from-end)
1694                        (if test-not
1695                            (position (apply-key key elt) vector
1696                                      :start (1+ index) :end end
1697                                      :test-not test-not :key key)
1698                            (position (apply-key key elt) vector
1699                                      :start (1+ index) :end end
1700                                      :test test :key key))))
1701         (setf (aref result jndex) elt)
1702         (setq jndex (1+ jndex)))
1703       (setq index (1+ index)))
1704     (do ()
1705         ((= index length))
1706       (setf (aref result jndex) (aref vector index))
1707       (setq index (1+ index))
1708       (setq jndex (1+ jndex)))
1709     (%shrink-vector result jndex)))
1710
1711 (define-sequence-traverser remove-duplicates
1712     (sequence &rest args &key test test-not start end from-end key)
1713   #!+sb-doc
1714   "The elements of SEQUENCE are compared pairwise, and if any two match,
1715    the one occurring earlier is discarded, unless FROM-END is true, in
1716    which case the one later in the sequence is discarded. The resulting
1717    sequence is returned.
1718
1719    The :TEST-NOT argument is deprecated."
1720   (declare (fixnum start))
1721   (declare (dynamic-extent args))
1722   (seq-dispatch sequence
1723     (if sequence
1724         (list-remove-duplicates* sequence test test-not
1725                                  start end key from-end))
1726     (vector-remove-duplicates* sequence test test-not start end key from-end)
1727     (apply #'sb!sequence:remove-duplicates sequence args)))
1728 \f
1729 ;;;; DELETE-DUPLICATES
1730
1731 (defun list-delete-duplicates* (list test test-not key from-end start end)
1732   (declare (fixnum start))
1733   (let ((handle (cons nil list)))
1734     (do ((current (nthcdr start list) (cdr current))
1735          (previous (nthcdr start handle))
1736          (index start (1+ index)))
1737         ((or (and end (= index (the fixnum end))) (null current))
1738          (cdr handle))
1739       (declare (fixnum index))
1740       (if (do ((x (if from-end
1741                       (nthcdr (1+ start) handle)
1742                       (cdr current))
1743                   (cdr x))
1744                (i (1+ index) (1+ i)))
1745               ((or (null x)
1746                    (and (not from-end) end (= i (the fixnum end)))
1747                    (eq x current))
1748                nil)
1749             (declare (fixnum i))
1750             (if (if test-not
1751                     (not (funcall test-not
1752                                   (apply-key key (car current))
1753                                   (apply-key key (car x))))
1754                     (funcall test
1755                              (apply-key key (car current))
1756                              (apply-key key (car x))))
1757                 (return t)))
1758           (rplacd previous (cdr current))
1759           (setq previous (cdr previous))))))
1760
1761 (defun vector-delete-duplicates* (vector test test-not key from-end start end
1762                                          &optional (length (length vector)))
1763   (declare (vector vector) (fixnum start length))
1764   (when (null end) (setf end (length vector)))
1765   (do ((index start (1+ index))
1766        (jndex start))
1767       ((= index end)
1768        (do ((index index (1+ index))            ; copy the rest of the vector
1769             (jndex jndex (1+ jndex)))
1770            ((= index length)
1771             (shrink-vector vector jndex))
1772          (setf (aref vector jndex) (aref vector index))))
1773     (declare (fixnum index jndex))
1774     (setf (aref vector jndex) (aref vector index))
1775     (unless (if test-not
1776                 (position (apply-key key (aref vector index)) vector :key key
1777                           :start (if from-end start (1+ index))
1778                           :end (if from-end jndex end)
1779                           :test-not test-not)
1780                 (position (apply-key key (aref vector index)) vector :key key
1781                           :start (if from-end start (1+ index))
1782                           :end (if from-end jndex end)
1783                           :test test))
1784       (setq jndex (1+ jndex)))))
1785
1786 (define-sequence-traverser delete-duplicates
1787     (sequence &rest args &key test test-not start end from-end key)
1788   #!+sb-doc
1789   "The elements of SEQUENCE are examined, and if any two match, one is
1790    discarded. The resulting sequence, which may be formed by destroying the
1791    given sequence, is returned.
1792
1793    The :TEST-NOT argument is deprecated."
1794   (declare (dynamic-extent args))
1795   (seq-dispatch sequence
1796     (if sequence
1797         (list-delete-duplicates* sequence test test-not
1798                                  key from-end start end))
1799     (vector-delete-duplicates* sequence test test-not key from-end start end)
1800     (apply #'sb!sequence:delete-duplicates sequence args)))
1801 \f
1802 ;;;; SUBSTITUTE
1803
1804 (defun list-substitute* (pred new list start end count key test test-not old)
1805   (declare (fixnum start end count))
1806   (let* ((result (list nil))
1807          elt
1808          (splice result)
1809          (list list))      ; Get a local list for a stepper.
1810     (do ((index 0 (1+ index)))
1811         ((= index start))
1812       (declare (fixnum index))
1813       (setq splice (cdr (rplacd splice (list (car list)))))
1814       (setq list (cdr list)))
1815     (do ((index start (1+ index)))
1816         ((or (= index end) (null list) (= count 0)))
1817       (declare (fixnum index))
1818       (setq elt (car list))
1819       (setq splice
1820             (cdr (rplacd splice
1821                          (list
1822                           (cond
1823                            ((case pred
1824                                    (normal
1825                                     (if test-not
1826                                         (not
1827                                          (funcall test-not old (apply-key key elt)))
1828                                         (funcall test old (apply-key key elt))))
1829                                    (if (funcall test (apply-key key elt)))
1830                                    (if-not (not (funcall test (apply-key key elt)))))
1831                             (decf count)
1832                             new)
1833                                 (t elt))))))
1834       (setq list (cdr list)))
1835     (do ()
1836         ((null list))
1837       (setq splice (cdr (rplacd splice (list (car list)))))
1838       (setq list (cdr list)))
1839     (cdr result)))
1840
1841 ;;; Replace old with new in sequence moving from left to right by incrementer
1842 ;;; on each pass through the loop. Called by all three substitute functions.
1843 (defun vector-substitute* (pred new sequence incrementer left right length
1844                            start end count key test test-not old)
1845   (declare (fixnum start count end incrementer right))
1846   (let ((result (%make-sequence-like sequence length))
1847         (index left))
1848     (declare (fixnum index))
1849     (do ()
1850         ((= index start))
1851       (setf (aref result index) (aref sequence index))
1852       (setq index (+ index incrementer)))
1853     (do ((elt))
1854         ((or (= index end) (= count 0)))
1855       (setq elt (aref sequence index))
1856       (setf (aref result index)
1857             (cond ((case pred
1858                           (normal
1859                             (if test-not
1860                                 (not (funcall test-not old (apply-key key elt)))
1861                                 (funcall test old (apply-key key elt))))
1862                           (if (funcall test (apply-key key elt)))
1863                           (if-not (not (funcall test (apply-key key elt)))))
1864                    (setq count (1- count))
1865                    new)
1866                   (t elt)))
1867       (setq index (+ index incrementer)))
1868     (do ()
1869         ((= index right))
1870       (setf (aref result index) (aref sequence index))
1871       (setq index (+ index incrementer)))
1872     result))
1873
1874 (eval-when (:compile-toplevel :execute)
1875
1876 (sb!xc:defmacro subst-dispatch (pred)
1877   `(seq-dispatch sequence
1878      (if from-end
1879          (nreverse (list-substitute* ,pred
1880                                      new
1881                                      (reverse sequence)
1882                                      (- (the fixnum length)
1883                                         (the fixnum end))
1884                                      (- (the fixnum length)
1885                                         (the fixnum start))
1886                                      count key test test-not old))
1887          (list-substitute* ,pred
1888                            new sequence start end count key test test-not
1889                            old))
1890     (if from-end
1891         (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
1892                             -1 length (1- (the fixnum end))
1893                             (1- (the fixnum start))
1894                             count key test test-not old)
1895         (vector-substitute* ,pred new sequence 1 0 length length
1896                             start end count key test test-not old))
1897     ;; FIXME: wow, this is an odd way to implement the dispatch.  PRED
1898     ;; here is (QUOTE [NORMAL|IF|IF-NOT]).  Not only is this pretty
1899     ;; pointless, but also LIST-SUBSTITUTE* and VECTOR-SUBSTITUTE*
1900     ;; dispatch once per element on PRED's run-time identity.
1901     ,(ecase (cadr pred)
1902        ((normal) `(apply #'sb!sequence:substitute new old sequence args))
1903        ((if) `(apply #'sb!sequence:substitute-if new predicate sequence args))
1904        ((if-not) `(apply #'sb!sequence:substitute-if-not new predicate sequence args)))))
1905 ) ; EVAL-WHEN
1906
1907 (define-sequence-traverser substitute
1908     (new old sequence &rest args &key from-end test test-not
1909          start count end key)
1910   #!+sb-doc
1911   "Return a sequence of the same kind as SEQUENCE with the same elements,
1912   except that all elements equal to OLD are replaced with NEW."
1913   (declare (fixnum start))
1914   (declare (dynamic-extent args))
1915   (let ((end (or end length)))
1916     (declare (type index end))
1917     (subst-dispatch 'normal)))
1918 \f
1919 ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
1920
1921 (define-sequence-traverser substitute-if
1922     (new predicate sequence &rest args &key from-end start end count key)
1923   #!+sb-doc
1924   "Return a sequence of the same kind as SEQUENCE with the same elements
1925   except that all elements satisfying the PRED are replaced with NEW."
1926   (declare (dynamic-extent args))
1927   (declare (fixnum start))
1928   (let ((end (or end length))
1929         (test predicate)
1930         (test-not nil)
1931         old)
1932     (declare (type index length end))
1933     (subst-dispatch 'if)))
1934
1935 (define-sequence-traverser substitute-if-not
1936     (new predicate sequence &rest args &key from-end start end count key)
1937   #!+sb-doc
1938   "Return a sequence of the same kind as SEQUENCE with the same elements
1939   except that all elements not satisfying the PRED are replaced with NEW."
1940   (declare (dynamic-extent args))
1941   (declare (fixnum start))
1942   (let ((end (or end length))
1943         (test predicate)
1944         (test-not nil)
1945         old)
1946     (declare (type index length end))
1947     (subst-dispatch 'if-not)))
1948 \f
1949 ;;;; NSUBSTITUTE
1950
1951 (define-sequence-traverser nsubstitute
1952     (new old sequence &rest args &key from-end test test-not
1953          end count key start)
1954   #!+sb-doc
1955   "Return a sequence of the same kind as SEQUENCE with the same elements
1956   except that all elements equal to OLD are replaced with NEW. SEQUENCE
1957   may be destructively modified."
1958   (declare (fixnum start))
1959   (declare (dynamic-extent args))
1960   (let ((end (or end length)))
1961     (seq-dispatch sequence
1962       (if from-end
1963           (let ((length (length sequence)))
1964             (nreverse (nlist-substitute*
1965                        new old (nreverse (the list sequence))
1966                        test test-not (- length end) (- length start)
1967                        count key)))
1968           (nlist-substitute* new old sequence
1969                              test test-not start end count key))
1970       (if from-end
1971           (nvector-substitute* new old sequence -1
1972                                test test-not (1- end) (1- start) count key)
1973           (nvector-substitute* new old sequence 1
1974                                test test-not start end count key))
1975       (apply #'sb!sequence:nsubstitute new old sequence args))))
1976
1977 (defun nlist-substitute* (new old sequence test test-not start end count key)
1978   (declare (fixnum start count end))
1979   (do ((list (nthcdr start sequence) (cdr list))
1980        (index start (1+ index)))
1981       ((or (= index end) (null list) (= count 0)) sequence)
1982     (declare (fixnum index))
1983     (when (if test-not
1984               (not (funcall test-not old (apply-key key (car list))))
1985               (funcall test old (apply-key key (car list))))
1986       (rplaca list new)
1987       (setq count (1- count)))))
1988
1989 (defun nvector-substitute* (new old sequence incrementer
1990                             test test-not start end count key)
1991   (declare (fixnum start incrementer count end))
1992   (do ((index start (+ index incrementer)))
1993       ((or (= index end) (= count 0)) sequence)
1994     (declare (fixnum index))
1995     (when (if test-not
1996               (not (funcall test-not
1997                             old
1998                             (apply-key key (aref sequence index))))
1999               (funcall test old (apply-key key (aref sequence index))))
2000       (setf (aref sequence index) new)
2001       (setq count (1- count)))))
2002 \f
2003 ;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
2004
2005 (define-sequence-traverser nsubstitute-if
2006     (new predicate sequence &rest args &key from-end start end count key)
2007   #!+sb-doc
2008   "Return a sequence of the same kind as SEQUENCE with the same elements
2009    except that all elements satisfying PREDICATE are replaced with NEW.
2010    SEQUENCE may be destructively modified."
2011   (declare (fixnum start))
2012   (declare (dynamic-extent args))
2013   (let ((end (or end length)))
2014     (declare (fixnum end))
2015     (seq-dispatch sequence
2016       (if from-end
2017           (let ((length (length sequence)))
2018             (nreverse (nlist-substitute-if*
2019                        new predicate (nreverse (the list sequence))
2020                        (- length end) (- length start) count key)))
2021           (nlist-substitute-if* new predicate sequence
2022                                 start end count key))
2023       (if from-end
2024           (nvector-substitute-if* new predicate sequence -1
2025                                   (1- end) (1- start) count key)
2026           (nvector-substitute-if* new predicate sequence 1
2027                                   start end count key))
2028       (apply #'sb!sequence:nsubstitute-if new predicate sequence args))))
2029
2030 (defun nlist-substitute-if* (new test sequence start end count key)
2031   (declare (fixnum end))
2032   (do ((list (nthcdr start sequence) (cdr list))
2033        (index start (1+ index)))
2034       ((or (= index end) (null list) (= count 0)) sequence)
2035     (when (funcall test (apply-key key (car list)))
2036       (rplaca list new)
2037       (setq count (1- count)))))
2038
2039 (defun nvector-substitute-if* (new test sequence incrementer
2040                                start end count key)
2041   (do ((index start (+ index incrementer)))
2042       ((or (= index end) (= count 0)) sequence)
2043     (when (funcall test (apply-key key (aref sequence index)))
2044       (setf (aref sequence index) new)
2045       (setq count (1- count)))))
2046
2047 (define-sequence-traverser nsubstitute-if-not
2048     (new predicate sequence &rest args &key from-end start end count key)
2049   #!+sb-doc
2050   "Return a sequence of the same kind as SEQUENCE with the same elements
2051    except that all elements not satisfying PREDICATE are replaced with NEW.
2052    SEQUENCE may be destructively modified."
2053   (declare (fixnum start))
2054   (declare (dynamic-extent args))
2055   (let ((end (or end length)))
2056     (declare (fixnum end))
2057     (seq-dispatch sequence
2058       (if from-end
2059           (let ((length (length sequence)))
2060             (nreverse (nlist-substitute-if-not*
2061                        new predicate (nreverse (the list sequence))
2062                        (- length end) (- length start) count key)))
2063           (nlist-substitute-if-not* new predicate sequence
2064                                     start end count key))
2065       (if from-end
2066           (nvector-substitute-if-not* new predicate sequence -1
2067                                       (1- end) (1- start) count key)
2068           (nvector-substitute-if-not* new predicate sequence 1
2069                                       start end count key))
2070       (apply #'sb!sequence:nsubstitute-if-not new predicate sequence args))))
2071
2072 (defun nlist-substitute-if-not* (new test sequence start end count key)
2073   (declare (fixnum end))
2074   (do ((list (nthcdr start sequence) (cdr list))
2075        (index start (1+ index)))
2076       ((or (= index end) (null list) (= count 0)) sequence)
2077     (when (not (funcall test (apply-key key (car list))))
2078       (rplaca list new)
2079       (decf count))))
2080
2081 (defun nvector-substitute-if-not* (new test sequence incrementer
2082                                    start end count key)
2083   (do ((index start (+ index incrementer)))
2084       ((or (= index end) (= count 0)) sequence)
2085     (when (not (funcall test (apply-key key (aref sequence index))))
2086       (setf (aref sequence index) new)
2087       (decf count))))
2088 \f
2089 ;;;; FIND, POSITION, and their -IF and -IF-NOT variants
2090
2091 (defun effective-find-position-test (test test-not)
2092   (effective-find-position-test test test-not))
2093 (defun effective-find-position-key (key)
2094   (effective-find-position-key key))
2095
2096 ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
2097 (macrolet (;; shared logic for defining %FIND-POSITION and
2098            ;; %FIND-POSITION-IF in terms of various inlineable cases
2099            ;; of the expression defined in FROB and VECTOR*-FROB
2100            (frobs ()
2101              `(seq-dispatch sequence-arg
2102                (frob sequence-arg from-end)
2103                (with-array-data ((sequence sequence-arg :offset-var offset)
2104                                  (start start)
2105                                  (end (%check-vector-sequence-bounds
2106                                        sequence-arg start end)))
2107                  (multiple-value-bind (f p)
2108                      (macrolet ((frob2 () '(if from-end
2109                                             (frob sequence t)
2110                                             (frob sequence nil))))
2111                        (typecase sequence
2112                          (simple-vector (frob2))
2113                          (simple-base-string (frob2))
2114                          (t (vector*-frob sequence))))
2115                    (declare (type (or index null) p))
2116                    (values f (and p (the index (- p offset)))))))))
2117   (defun %find-position (item sequence-arg from-end start end key test)
2118     (macrolet ((frob (sequence from-end)
2119                  `(%find-position item ,sequence
2120                                   ,from-end start end key test))
2121                (vector*-frob (sequence)
2122                  `(%find-position-vector-macro item ,sequence
2123                                                from-end start end key test)))
2124       (frobs)))
2125   (defun %find-position-if (predicate sequence-arg from-end start end key)
2126     (macrolet ((frob (sequence from-end)
2127                  `(%find-position-if predicate ,sequence
2128                                      ,from-end start end key))
2129                (vector*-frob (sequence)
2130                  `(%find-position-if-vector-macro predicate ,sequence
2131                                                   from-end start end key)))
2132       (frobs)))
2133   (defun %find-position-if-not (predicate sequence-arg from-end start end key)
2134     (macrolet ((frob (sequence from-end)
2135                  `(%find-position-if-not predicate ,sequence
2136                                          ,from-end start end key))
2137                (vector*-frob (sequence)
2138                  `(%find-position-if-not-vector-macro predicate ,sequence
2139                                                   from-end start end key)))
2140       (frobs))))
2141
2142 (defun find
2143     (item sequence &rest args &key from-end (start 0) end key test test-not)
2144   (declare (dynamic-extent args))
2145   (seq-dispatch sequence
2146     (nth-value 0 (%find-position
2147                   item sequence from-end start end
2148                   (effective-find-position-key key)
2149                   (effective-find-position-test test test-not)))
2150     (nth-value 0 (%find-position
2151                   item sequence from-end start end
2152                   (effective-find-position-key key)
2153                   (effective-find-position-test test test-not)))
2154     (apply #'sb!sequence:find item sequence args)))
2155 (defun position
2156     (item sequence &rest args &key from-end (start 0) end key test test-not)
2157   (declare (dynamic-extent args))
2158   (seq-dispatch sequence
2159     (nth-value 1 (%find-position
2160                   item sequence from-end start end
2161                   (effective-find-position-key key)
2162                   (effective-find-position-test test test-not)))
2163     (nth-value 1 (%find-position
2164                   item sequence from-end start end
2165                   (effective-find-position-key key)
2166                   (effective-find-position-test test test-not)))
2167     (apply #'sb!sequence:position item sequence args)))
2168
2169 (defun find-if (predicate sequence &rest args &key from-end (start 0) end key)
2170   (declare (dynamic-extent args))
2171   (seq-dispatch sequence
2172     (nth-value 0 (%find-position-if
2173                   (%coerce-callable-to-fun predicate)
2174                   sequence from-end start end
2175                   (effective-find-position-key key)))
2176     (nth-value 0 (%find-position-if
2177                   (%coerce-callable-to-fun predicate)
2178                   sequence from-end start end
2179                   (effective-find-position-key key)))
2180     (apply #'sb!sequence:find-if predicate sequence args)))
2181 (defun position-if
2182     (predicate sequence &rest args &key from-end (start 0) end key)
2183   (declare (dynamic-extent args))
2184   (seq-dispatch sequence
2185     (nth-value 1 (%find-position-if
2186                   (%coerce-callable-to-fun predicate)
2187                   sequence from-end start end
2188                   (effective-find-position-key key)))
2189     (nth-value 1 (%find-position-if
2190                   (%coerce-callable-to-fun predicate)
2191                   sequence from-end start end
2192                   (effective-find-position-key key)))
2193     (apply #'sb!sequence:position-if predicate sequence args)))
2194
2195 (defun find-if-not
2196     (predicate sequence &rest args &key from-end (start 0) end key)
2197   (declare (dynamic-extent args))
2198   (seq-dispatch sequence
2199     (nth-value 0 (%find-position-if-not
2200                   (%coerce-callable-to-fun predicate)
2201                   sequence from-end start end
2202                   (effective-find-position-key key)))
2203     (nth-value 0 (%find-position-if-not
2204                   (%coerce-callable-to-fun predicate)
2205                   sequence from-end start end
2206                   (effective-find-position-key key)))
2207     (apply #'sb!sequence:find-if-not predicate sequence args)))
2208 (defun position-if-not
2209     (predicate sequence &rest args &key from-end (start 0) end key)
2210   (declare (dynamic-extent args))
2211   (seq-dispatch sequence
2212     (nth-value 1 (%find-position-if-not
2213                   (%coerce-callable-to-fun predicate)
2214                   sequence from-end start end
2215                   (effective-find-position-key key)))
2216     (nth-value 1 (%find-position-if-not
2217                   (%coerce-callable-to-fun predicate)
2218                   sequence from-end start end
2219                   (effective-find-position-key key)))
2220     (apply #'sb!sequence:position-if-not predicate sequence args)))
2221 \f
2222 ;;;; COUNT-IF, COUNT-IF-NOT, and COUNT
2223
2224 (eval-when (:compile-toplevel :execute)
2225
2226 (sb!xc:defmacro vector-count-if (notp from-end-p predicate sequence)
2227   (let ((next-index (if from-end-p '(1- index) '(1+ index)))
2228         (pred `(funcall ,predicate (apply-key key (aref ,sequence index)))))
2229     `(let ((%start ,(if from-end-p '(1- end) 'start))
2230            (%end ,(if from-end-p '(1- start) 'end)))
2231       (do ((index %start ,next-index)
2232            (count 0))
2233           ((= index (the fixnum %end)) count)
2234         (declare (fixnum index count))
2235         (,(if notp 'unless 'when) ,pred
2236           (setq count (1+ count)))))))
2237
2238 (sb!xc:defmacro list-count-if (notp from-end-p predicate sequence)
2239   (let ((pred `(funcall ,predicate (apply-key key (pop sequence)))))
2240     `(let ((%start ,(if from-end-p '(- length end) 'start))
2241            (%end ,(if from-end-p '(- length start) 'end))
2242            (sequence ,(if from-end-p '(reverse sequence) 'sequence)))
2243       (do ((sequence (nthcdr %start ,sequence))
2244            (index %start (1+ index))
2245            (count 0))
2246           ((or (= index (the fixnum %end)) (null sequence)) count)
2247         (declare (fixnum index count))
2248         (,(if notp 'unless 'when) ,pred
2249           (setq count (1+ count)))))))
2250
2251
2252 ) ; EVAL-WHEN
2253
2254 (define-sequence-traverser count-if
2255     (pred sequence &rest args &key from-end start end key)
2256   #!+sb-doc
2257   "Return the number of elements in SEQUENCE satisfying PRED(el)."
2258   (declare (fixnum start))
2259   (declare (dynamic-extent args))
2260   (let ((end (or end length))
2261         (pred (%coerce-callable-to-fun pred)))
2262     (declare (type index end))
2263     (seq-dispatch sequence
2264       (if from-end
2265           (list-count-if nil t pred sequence)
2266           (list-count-if nil nil pred sequence))
2267       (if from-end
2268           (vector-count-if nil t pred sequence)
2269           (vector-count-if nil nil pred sequence))
2270       (apply #'sb!sequence:count-if pred sequence args))))
2271
2272 (define-sequence-traverser count-if-not
2273     (pred sequence &rest args &key from-end start end key)
2274   #!+sb-doc
2275   "Return the number of elements in SEQUENCE not satisfying TEST(el)."
2276   (declare (fixnum start))
2277   (declare (dynamic-extent args))
2278   (let ((end (or end length))
2279         (pred (%coerce-callable-to-fun pred)))
2280     (declare (type index end))
2281     (seq-dispatch sequence
2282       (if from-end
2283           (list-count-if t t pred sequence)
2284           (list-count-if t nil pred sequence))
2285       (if from-end
2286           (vector-count-if t t pred sequence)
2287           (vector-count-if t nil pred sequence))
2288       (apply #'sb!sequence:count-if-not pred sequence args))))
2289
2290 (define-sequence-traverser count
2291     (item sequence &rest args &key from-end start end
2292           key (test #'eql test-p) (test-not nil test-not-p))
2293   #!+sb-doc
2294   "Return the number of elements in SEQUENCE satisfying a test with ITEM,
2295    which defaults to EQL."
2296   (declare (fixnum start))
2297   (declare (dynamic-extent args))
2298   (when (and test-p test-not-p)
2299     ;; ANSI Common Lisp has left the behavior in this situation unspecified.
2300     ;; (CLHS 17.2.1)
2301     (error ":TEST and :TEST-NOT are both present."))
2302   (let ((end (or end length)))
2303     (declare (type index end))
2304     (let ((%test (if test-not-p
2305                      (lambda (x)
2306                        (not (funcall test-not item x)))
2307                      (lambda (x)
2308                        (funcall test item x)))))
2309       (seq-dispatch sequence
2310         (if from-end
2311             (list-count-if nil t %test sequence)
2312             (list-count-if nil nil %test sequence))
2313         (if from-end
2314             (vector-count-if nil t %test sequence)
2315             (vector-count-if nil nil %test sequence))
2316         (apply #'sb!sequence:count item sequence args)))))
2317 \f
2318 ;;;; MISMATCH
2319
2320 (eval-when (:compile-toplevel :execute)
2321
2322 (sb!xc:defmacro match-vars (&rest body)
2323   `(let ((inc (if from-end -1 1))
2324          (start1 (if from-end (1- (the fixnum end1)) start1))
2325          (start2 (if from-end (1- (the fixnum end2)) start2))
2326          (end1 (if from-end (1- (the fixnum start1)) end1))
2327          (end2 (if from-end (1- (the fixnum start2)) end2)))
2328      (declare (fixnum inc start1 start2 end1 end2))
2329      ,@body))
2330
2331 (sb!xc:defmacro matchify-list ((sequence start length end) &body body)
2332   (declare (ignore end)) ;; ### Should END be used below?
2333   `(let ((,sequence (if from-end
2334                         (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
2335                                 (reverse (the list ,sequence)))
2336                         (nthcdr ,start ,sequence))))
2337      (declare (type list ,sequence))
2338      ,@body))
2339
2340 ) ; EVAL-WHEN
2341
2342 (eval-when (:compile-toplevel :execute)
2343
2344 (sb!xc:defmacro if-mismatch (elt1 elt2)
2345   `(cond ((= (the fixnum index1) (the fixnum end1))
2346           (return (if (= (the fixnum index2) (the fixnum end2))
2347                       nil
2348                       (if from-end
2349                           (1+ (the fixnum index1))
2350                           (the fixnum index1)))))
2351          ((= (the fixnum index2) (the fixnum end2))
2352           (return (if from-end (1+ (the fixnum index1)) index1)))
2353          (test-not
2354           (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
2355               (return (if from-end (1+ (the fixnum index1)) index1))))
2356          (t (if (not (funcall test (apply-key key ,elt1)
2357                               (apply-key key ,elt2)))
2358                 (return (if from-end (1+ (the fixnum index1)) index1))))))
2359
2360 (sb!xc:defmacro mumble-mumble-mismatch ()
2361   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2362         (index2 start2 (+ index2 (the fixnum inc))))
2363        (())
2364      (declare (fixnum index1 index2))
2365      (if-mismatch (aref sequence1 index1) (aref sequence2 index2))))
2366
2367 (sb!xc:defmacro mumble-list-mismatch ()
2368   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2369         (index2 start2 (+ index2 (the fixnum inc))))
2370        (())
2371      (declare (fixnum index1 index2))
2372      (if-mismatch (aref sequence1 index1) (pop sequence2))))
2373 \f
2374 (sb!xc:defmacro list-mumble-mismatch ()
2375   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2376         (index2 start2 (+ index2 (the fixnum inc))))
2377        (())
2378      (declare (fixnum index1 index2))
2379      (if-mismatch (pop sequence1) (aref sequence2 index2))))
2380
2381 (sb!xc:defmacro list-list-mismatch ()
2382   `(do ((sequence1 sequence1)
2383         (sequence2 sequence2)
2384         (index1 start1 (+ index1 (the fixnum inc)))
2385         (index2 start2 (+ index2 (the fixnum inc))))
2386        (())
2387      (declare (fixnum index1 index2))
2388      (if-mismatch (pop sequence1) (pop sequence2))))
2389
2390 ) ; EVAL-WHEN
2391
2392 (define-sequence-traverser mismatch
2393     (sequence1 sequence2 &rest args &key from-end test test-not
2394      start1 end1 start2 end2 key)
2395   #!+sb-doc
2396   "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
2397    element-wise. If they are of equal length and match in every element, the
2398    result is NIL. Otherwise, the result is a non-negative integer, the index
2399    within SEQUENCE1 of the leftmost position at which they fail to match; or,
2400    if one is shorter than and a matching prefix of the other, the index within
2401    SEQUENCE1 beyond the last position tested is returned. If a non-NIL
2402    :FROM-END argument is given, then one plus the index of the rightmost
2403    position in which the sequences differ is returned."
2404   (declare (fixnum start1 start2))
2405   (declare (dynamic-extent args))
2406   (let* ((end1 (or end1 length1))
2407          (end2 (or end2 length2)))
2408     (declare (type index end1 end2))
2409     (match-vars
2410      (seq-dispatch sequence1
2411        (seq-dispatch sequence2
2412          (matchify-list (sequence1 start1 length1 end1)
2413            (matchify-list (sequence2 start2 length2 end2)
2414              (list-list-mismatch)))
2415          (matchify-list (sequence1 start1 length1 end1)
2416            (list-mumble-mismatch))
2417          (apply #'sb!sequence:mismatch sequence1 sequence2 args))
2418        (seq-dispatch sequence2
2419          (matchify-list (sequence2 start2 length2 end2)
2420            (mumble-list-mismatch))
2421          (mumble-mumble-mismatch)
2422          (apply #'sb!sequence:mismatch sequence1 sequence2 args))
2423        (apply #'sb!sequence:mismatch sequence1 sequence2 args)))))
2424 \f
2425 ;;; search comparison functions
2426
2427 (eval-when (:compile-toplevel :execute)
2428
2429 ;;; Compare two elements and return if they don't match.
2430 (sb!xc:defmacro compare-elements (elt1 elt2)
2431   `(if test-not
2432        (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
2433            (return nil)
2434            t)
2435        (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
2436            (return nil)
2437            t)))
2438
2439 (sb!xc:defmacro search-compare-list-list (main sub)
2440   `(do ((main ,main (cdr main))
2441         (jndex start1 (1+ jndex))
2442         (sub (nthcdr start1 ,sub) (cdr sub)))
2443        ((or (endp main) (endp sub) (<= end1 jndex))
2444         t)
2445      (declare (type (integer 0) jndex))
2446      (compare-elements (car sub) (car main))))
2447
2448 (sb!xc:defmacro search-compare-list-vector (main sub)
2449   `(do ((main ,main (cdr main))
2450         (index start1 (1+ index)))
2451        ((or (endp main) (= index end1)) t)
2452      (compare-elements (aref ,sub index) (car main))))
2453
2454 (sb!xc:defmacro search-compare-vector-list (main sub index)
2455   `(do ((sub (nthcdr start1 ,sub) (cdr sub))
2456         (jndex start1 (1+ jndex))
2457         (index ,index (1+ index)))
2458        ((or (<= end1 jndex) (endp sub)) t)
2459      (declare (type (integer 0) jndex))
2460      (compare-elements (car sub) (aref ,main index))))
2461
2462 (sb!xc:defmacro search-compare-vector-vector (main sub index)
2463   `(do ((index ,index (1+ index))
2464         (sub-index start1 (1+ sub-index)))
2465        ((= sub-index end1) t)
2466      (compare-elements (aref ,sub sub-index) (aref ,main index))))
2467
2468 (sb!xc:defmacro search-compare (main-type main sub index)
2469   (if (eq main-type 'list)
2470       `(seq-dispatch ,sub
2471          (search-compare-list-list ,main ,sub)
2472          (search-compare-list-vector ,main ,sub)
2473          ;; KLUDGE: just hack it together so that it works
2474          (return-from search (apply #'sb!sequence:search sequence1 sequence2 args)))
2475       `(seq-dispatch ,sub
2476          (search-compare-vector-list ,main ,sub ,index)
2477          (search-compare-vector-vector ,main ,sub ,index)
2478          (return-from search (apply #'sb!sequence:search sequence1 sequence2 args)))))
2479
2480 ) ; EVAL-WHEN
2481 \f
2482 ;;;; SEARCH
2483
2484 (eval-when (:compile-toplevel :execute)
2485
2486 (sb!xc:defmacro list-search (main sub)
2487   `(do ((main (nthcdr start2 ,main) (cdr main))
2488         (index2 start2 (1+ index2))
2489         (terminus (- end2 (the (integer 0) (- end1 start1))))
2490         (last-match ()))
2491        ((> index2 terminus) last-match)
2492      (declare (type (integer 0) index2))
2493      (if (search-compare list main ,sub index2)
2494          (if from-end
2495              (setq last-match index2)
2496              (return index2)))))
2497
2498 (sb!xc:defmacro vector-search (main sub)
2499   `(do ((index2 start2 (1+ index2))
2500         (terminus (- end2 (the (integer 0) (- end1 start1))))
2501         (last-match ()))
2502        ((> index2 terminus) last-match)
2503      (declare (type (integer 0) index2))
2504      (if (search-compare vector ,main ,sub index2)
2505          (if from-end
2506              (setq last-match index2)
2507              (return index2)))))
2508
2509 ) ; EVAL-WHEN
2510
2511 (define-sequence-traverser search
2512     (sequence1 sequence2 &rest args &key
2513      from-end test test-not start1 end1 start2 end2 key)
2514   (declare (fixnum start1 start2))
2515   (declare (dynamic-extent args))
2516   (let ((end1 (or end1 length1))
2517         (end2 (or end2 length2)))
2518     (seq-dispatch sequence2
2519       (list-search sequence2 sequence1)
2520       (vector-search sequence2 sequence1)
2521       (apply #'sb!sequence:search sequence1 sequence2 args))))
2522
2523 (sb!xc:defmacro string-dispatch ((&rest types) var &body body)
2524   (let ((fun (gensym "STRING-DISPATCH-FUN-")))
2525     `(flet ((,fun (,var)
2526               ,@body))
2527        (declare (inline ,fun))
2528        (etypecase ,var
2529          ,@(loop for type in types
2530                  collect `(,type (,fun (the ,type ,var))))))))
2531
2532 ;;; FIXME: this was originally in array.lisp; it might be better to
2533 ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in
2534 ;;; a new early-seq.lisp file.
2535 (defun fill-data-vector (vector dimensions initial-contents)
2536   (let ((index 0))
2537     (labels ((frob (axis dims contents)
2538                (cond ((null dims)
2539                       (setf (aref vector index) contents)
2540                       (incf index))
2541                      (t
2542                       (unless (typep contents 'sequence)
2543                         (error "malformed :INITIAL-CONTENTS: ~S is not a ~
2544                                 sequence, but ~W more layer~:P needed."
2545                                contents
2546                                (- (length dimensions) axis)))
2547                       (unless (= (length contents) (car dims))
2548                         (error "malformed :INITIAL-CONTENTS: Dimension of ~
2549                                 axis ~W is ~W, but ~S is ~W long."
2550                                axis (car dims) contents (length contents)))
2551                       (sb!sequence:dosequence (content contents)
2552                         (frob (1+ axis) (cdr dims) content))))))
2553       (frob 0 dimensions initial-contents))))