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