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