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