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 (defmacro word-specialized-vector-tag-p (tag)
 790   `(or
 791     ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
 792            when (and (eq (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)
 793                      (not (eq (sb!vm:saetp-specifier saetp) t)))
 794            collect `(eq ,tag ,(sb!vm:saetp-typecode saetp)))))
 795
 796 (defun reverse-word-specialized-vector (from to end)
 797   (declare (vector from))
 798   (do ((length (length to))
 799        (left-index 0 (1+ left-index))
 800        (right-index end))
 801       ((= left-index length))
 802     (declare (type index left-index right-index))
 803     (decf right-index)
 804     (setf (%vector-raw-bits to left-index)
 805           (%vector-raw-bits from right-index)))
 806   to)
 807
 808 (defun vector-reverse (vector)
 809   (declare (vector vector))
 810   (let ((length (length vector)))
 811     (with-array-data ((vector vector) (start) (end)
 812                       :check-fill-pointer t)
 813       (declare (ignore start))
 814       (let* ((tag (%other-pointer-widetag vector))
 815              (new-vector (allocate-vector-with-widetag tag length)))
 816         (cond ((= tag sb!vm:simple-vector-widetag)
 817                (do ((left-index 0 (1+ left-index))
 818                     (right-index end))
 819                    ((= left-index length))
 820                  (declare (type index left-index right-index))
 821                  (decf right-index)
 822                  (setf (svref new-vector left-index)
 823                        (svref vector right-index))))
 824               ((word-specialized-vector-tag-p tag)
 825                (reverse-word-specialized-vector vector new-vector end))
 826               (t
 827                (let ((getter (the function (svref %%data-vector-reffers%% tag)))
 828                      (setter (the function (svref %%data-vector-setters%% tag))))
 829                  (declare (fixnum length))
 830                  (do ((forward-index 0 (1+ forward-index))
 831                       (backward-index (1- end) (1- backward-index)))
 832                      ((= forward-index length))
 833                    (declare (fixnum forward-index backward-index))
 834                    (funcall setter new-vector forward-index
 835                             (funcall getter vector backward-index))))))
 836         new-vector))))
 837 \f
 838 ;;;; NREVERSE
 839
 840 (defun list-nreverse (list)
 841   (do ((1st (cdr list) (if (endp 1st) 1st (cdr 1st)))
 842        (2nd list 1st)
 843        (3rd '() 2nd))
 844       ((atom 2nd) 3rd)
 845     (rplacd 2nd 3rd)))
 846
 847 (defun nreverse-word-specialized-vector (vector start end)
 848   (do ((left-index start (1+ left-index))
 849        (right-index (1- end) (1- right-index)))
 850       ((<= right-index left-index))
 851     (declare (type index left-index right-index))
 852     (let ((left (%vector-raw-bits vector left-index))
 853           (right (%vector-raw-bits vector right-index)))
 854       (setf (%vector-raw-bits vector left-index) right
 855             (%vector-raw-bits vector right-index) left)))
 856   vector)
 857
 858 (defun vector-nreverse (vector)
 859   (declare (vector vector))
 860   (when (> (length vector) 1)
 861     (with-array-data ((vector vector) (start) (end)
 862                       :check-fill-pointer t)
 863       (let ((tag (%other-pointer-widetag vector)))
 864         (cond ((= tag sb!vm:simple-vector-widetag)
 865                (do ((left-index start (1+ left-index))
 866                     (right-index (1- end) (1- right-index)))
 867                    ((<= right-index left-index))
 868                  (declare (type index left-index right-index))
 869                  (let ((left (svref vector left-index))
 870                        (right (svref vector right-index)))
 871                    (setf (svref vector left-index) right
 872                          (svref vector right-index) left))))
 873               ((word-specialized-vector-tag-p tag)
 874                (nreverse-word-specialized-vector vector start end))
 875               (t
 876                (let* ((getter (the function (svref %%data-vector-reffers%% tag)))
 877                       (setter (the function (svref %%data-vector-setters%% tag))))
 878                  (do ((left-index start (1+ left-index))
 879                       (right-index (1- end) (1- right-index)))
 880                      ((<= right-index left-index))
 881                    (declare (type index left-index right-index))
 882                    (let ((left (funcall getter vector left-index))
 883                          (right (funcall getter vector right-index)))
 884                      (funcall setter vector left-index right)
 885                      (funcall setter vector right-index left)))))))))
 886   vector)
 887
 888 (defun nreverse (sequence)
 889   #!+sb-doc
 890   "Return a sequence of the same elements in reverse order; the argument
 891    is destroyed."
 892   (declare (explicit-check))
 893   (seq-dispatch-checking sequence
 894     (list-nreverse sequence)
 895     (vector-nreverse sequence)
 896     ;; The type deriver for this is 'result-type-first-arg',
 897     ;; meaning it should return definitely an EXTENDED-SEQUENCE
 898     ;; and not a list or vector.
 899     (the extended-sequence (values (sb!sequence:nreverse sequence)))))
 900 \f
 901
 902 (defmacro sb!sequence:dosequence ((element sequence &optional return) &body body)
 903   #!+sb-doc
 904   "Executes BODY with ELEMENT subsequently bound to each element of
 905   SEQUENCE, then returns RETURN."
 906   (multiple-value-bind (forms decls) (parse-body body nil)
 907     (once-only ((sequence sequence))
 908       (with-unique-names (state limit from-end step endp elt)
 909         `(block nil
 910            (seq-dispatch ,sequence
 911              (dolist (,element ,sequence ,return) ,@body)
 912              (do-vector-data (,element ,sequence ,return) ,@body)
 913              (multiple-value-bind (,state ,limit ,from-end ,step ,endp ,elt)
 914                  (sb!sequence:make-sequence-iterator ,sequence)
 915                (declare (function ,step ,endp ,elt))
 916                (do ((,state ,state (funcall ,step ,sequence ,state ,from-end)))
 917                    ((funcall ,endp ,sequence ,state ,limit ,from-end)
 918                     (let ((,element nil))
 919                       ,@(filter-dolist-declarations decls)
 920                       (declare (ignorable ,element))
 921                       ,return))
 922                  (let ((,element (funcall ,elt ,sequence ,state)))
 923                    ,@decls
 924                    (tagbody
 925                       ,@forms))))))))))
 926
 927 \f
 928 ;;;; CONCATENATE
 929
 930 (defun concatenate (result-type &rest sequences)
 931   #!+sb-doc
 932   "Return a new sequence of all the argument sequences concatenated together
 933   which shares no structure with the original argument sequences of the
 934   specified RESULT-TYPE."
 935   (declare (explicit-check)
 936            (dynamic-extent sequences))
 937   (flet ((concat-to-simple* (type-spec sequences)
 938            (do ((seqs sequences (cdr seqs))
 939                 (total-length 0)
 940                 (lengths ()))
 941                ((null seqs)
 942                 (do ((sequences sequences (cdr sequences))
 943                      (lengths lengths (cdr lengths))
 944                      (index 0)
 945                      (result (make-sequence type-spec total-length)))
 946                     ((= index total-length) result)
 947                   (declare (fixnum index))
 948                   (let ((sequence (car sequences)))
 949                     (sb!sequence:dosequence (e sequence)
 950                       (setf (aref result index) e)
 951                       (incf index)))))
 952              (let ((length (length (car seqs))))
 953                (declare (fixnum length))
 954                (setq lengths (nconc lengths (list length)))
 955                (setq total-length (+ total-length length))))))
 956     (case result-type
 957       ;; Pick up some common cases first
 958       (list
 959        (apply #'%concatenate-to-list sequences))
 960       ((vector simple-vector)
 961        (apply #'%concatenate-to-simple-vector sequences))
 962       #!+sb-unicode
 963       ((string simple-string)
 964        (apply #'%concatenate-to-string sequences))
 965       ((simple-base-string #!-sb-unicode string #!-sb-unicode simple-string)
 966        (apply #'%concatenate-to-base-string sequences))
 967       (t
 968        (let ((type (specifier-type result-type)))
 969          (cond
 970            ((csubtypep type (specifier-type 'list))
 971             (cond
 972               ((type= type (specifier-type 'list))
 973                (apply #'%concatenate-to-list sequences))
 974               ((eq type *empty-type*)
 975                (bad-sequence-type-error nil))
 976               ((type= type (specifier-type 'null))
 977                (unless (every #'emptyp sequences)
 978                  (sequence-type-length-mismatch-error
 979                   type (reduce #'+ sequences :key #'length))) ; FIXME: circular list issues.
 980                '())
 981               ((cons-type-p type)
 982                (multiple-value-bind (min exactp)
 983                    (sb!kernel::cons-type-length-info type)
 984                  (let ((length (reduce #'+ sequences :key #'length)))
 985                    (if exactp
 986                        (unless (= length min)
 987                          (sequence-type-length-mismatch-error type length))
 988                        (unless (>= length min)
 989                          (sequence-type-length-mismatch-error type length)))
 990                    (apply #'%concatenate-to-list sequences))))
 991               (t (sequence-type-too-hairy (type-specifier type)))))
 992            ((csubtypep type (specifier-type 'vector))
 993             (concat-to-simple* result-type sequences))
 994            ((when-extended-sequence-type
 995                 (result-type type :expandedp nil :prototype prototype)
 996               ;; This function has the EXPLICIT-CHECK declaration,
 997               ;; so we manually assert that it returns a SEQUENCE.
 998               (the extended-sequence
 999                    (apply #'sb!sequence:concatenate prototype sequences))))
1000            (t
1001             (bad-sequence-type-error result-type))))))))
1002
1003 ;;; Efficient out-of-line concatenate for strings. Compiler transforms
1004 ;;; CONCATENATE 'STRING &co into these.
1005 (macrolet ((def (name element-type &rest dispatch)
1006              `(defun ,name (&rest sequences)
1007                 (declare (explicit-check)
1008                          (optimize (sb!c::insert-array-bounds-checks 0)))
1009                 (let ((length 0))
1010                   (declare (index length))
1011                   (do-rest-arg ((seq) sequences)
1012                     (incf length (length seq)))
1013                   (let ((result (make-array length :element-type ',element-type))
1014                         (start 0))
1015                     (declare (index start))
1016                     (do-rest-arg ((seq) sequences)
1017                       (string-dispatch (,@dispatch t)
1018                                        seq
1019                         (let ((length (length seq)))
1020                           (replace result seq :start1 start)
1021                           (incf start length))))
1022                     result)))))
1023   #!+sb-unicode
1024   (def %concatenate-to-string character
1025     (simple-array character (*)) (simple-array base-char (*)))
1026   (def %concatenate-to-base-string base-char
1027     (simple-array base-char (*)) #!+sb-unicode (simple-array character (*)))
1028   (def %concatenate-to-simple-vector t simple-vector))
1029
1030 (defun %concatenate-to-list (&rest sequences)
1031   (declare (explicit-check))
1032   (let* ((result (list nil))
1033          (splice result))
1034     (do-rest-arg ((sequence) sequences)
1035       (sb!sequence:dosequence (e sequence)
1036         (setf splice (cdr (rplacd splice (list e))))))
1037     (cdr result)))
1038
1039 (defun %concatenate-to-vector (widetag &rest sequences)
1040   (declare (explicit-check))
1041   (let ((length 0))
1042     (declare (index length))
1043     (do-rest-arg ((seq) sequences)
1044       (incf length (length seq)))
1045     (let ((result (allocate-vector-with-widetag widetag length))
1046           (setter (the function (svref %%data-vector-setters%% widetag)))
1047           (index 0))
1048       (declare (index index))
1049       (do-rest-arg ((seq) sequences)
1050         (sb!sequence:dosequence (e seq)
1051           (funcall setter result index e)
1052           (incf index)))
1053       result)))
1054 \f
1055 ;;;; MAP
1056
1057 ;;; helper functions to handle arity-1 subcases of MAP
1058 (defun %map-to-list-arity-1 (fun sequence)
1059   (declare (explicit-check))
1060   (let ((reversed-result nil)
1061         (really-fun (%coerce-callable-to-fun fun)))
1062     (sb!sequence:dosequence (element sequence)
1063       (push (funcall really-fun element)
1064             reversed-result))
1065     (nreverse reversed-result)))
1066 (defun %map-to-simple-vector-arity-1 (fun sequence)
1067   (declare (explicit-check))
1068   (let ((result (make-array (length sequence)))
1069         (index 0)
1070         (really-fun (%coerce-callable-to-fun fun)))
1071     (declare (type index index))
1072     (sb!sequence:dosequence (element sequence)
1073       (setf (aref result index)
1074             (funcall really-fun element))
1075       (incf index))
1076     result))
1077 (defun %map-for-effect-arity-1 (fun sequence)
1078   (declare (explicit-check))
1079   (let ((really-fun (%coerce-callable-to-fun fun)))
1080     (sb!sequence:dosequence (element sequence)
1081       (funcall really-fun element)))
1082   nil)
1083
1084 (declaim (maybe-inline %map-for-effect))
1085 (defun %map-for-effect (fun sequences)
1086   (declare (type function fun) (type list sequences))
1087   (let ((%sequences sequences)
1088         (%iters (mapcar (lambda (s)
1089                           (seq-dispatch s
1090                             s
1091                             0
1092                             (multiple-value-list
1093                              (sb!sequence:make-sequence-iterator s))))
1094                         sequences))
1095         (%apply-args (make-list (length sequences))))
1096     ;; this is almost efficient (except in the general case where we
1097     ;; trampoline to MAKE-SEQUENCE-ITERATOR; if we had DX allocation
1098     ;; of MAKE-LIST, the whole of %MAP would be cons-free.
1099     ;; TODO: on x86-64, we do have. Now see if the above remark is true.
1100     (declare (type list %sequences %iters %apply-args))
1101     (loop
1102      (do ((in-sequences  %sequences  (cdr in-sequences))
1103           (in-iters      %iters      (cdr in-iters))
1104           (in-apply-args %apply-args (cdr in-apply-args)))
1105          ((null in-sequences) (apply fun %apply-args))
1106        (let ((i (car in-iters)))
1107          (declare (type (or list index) i))
1108          (cond
1109            ((listp (car in-sequences))
1110             (if (null i)
1111                 (return-from %map-for-effect nil)
1112                 (setf (car in-apply-args) (car i)
1113                       (car in-iters) (cdr i))))
1114            ((typep i 'index)
1115             (let ((v (the vector (car in-sequences))))
1116               (if (>= i (length v))
1117                   (return-from %map-for-effect nil)
1118                   (setf (car in-apply-args) (aref v i)
1119                         (car in-iters) (1+ i)))))
1120            (t
1121             ;; While on one hand this could benefit from a zero-safety ds-bind,
1122             ;; on the other, why not coerce these tuples to vectors or structs?
1123             (destructuring-bind (state limit from-end step endp elt &rest ignore)
1124                 i
1125               (declare (type function step endp elt)
1126                        (ignore ignore))
1127               (let ((s (car in-sequences)))
1128                 (if (funcall endp s state limit from-end)
1129                     (return-from %map-for-effect nil)
1130                     (progn
1131                       (setf (car in-apply-args) (funcall elt s state))
1132                       (setf (caar in-iters) (funcall step s state from-end)))))))))))))
1133 (defun %map-to-list (fun sequences)
1134   (declare (type function fun)
1135            (type list sequences))
1136   (let ((result nil))
1137     (flet ((f (&rest args)
1138              (declare (truly-dynamic-extent args))
1139              (push (apply fun args) result)))
1140       (declare (truly-dynamic-extent #'f))
1141       (%map-for-effect #'f sequences))
1142     (nreverse result)))
1143 (defun %map-to-vector (output-type-spec fun sequences)
1144   (declare (type function fun)
1145            (type list sequences))
1146   (let ((min-len 0))
1147     (flet ((f (&rest args)
1148              (declare (truly-dynamic-extent args))
1149              (declare (ignore args))
1150              (incf min-len)))
1151       (declare (truly-dynamic-extent #'f))
1152       (%map-for-effect #'f sequences))
1153     (let ((result (make-sequence output-type-spec min-len))
1154           (i 0))
1155       (declare (type (simple-array * (*)) result))
1156       (flet ((f (&rest args)
1157                (declare (truly-dynamic-extent args))
1158                (setf (aref result i) (apply fun args))
1159                (incf i)))
1160         (declare (truly-dynamic-extent #'f))
1161         (%map-for-effect #'f sequences))
1162       result)))
1163
1164 ;;; %MAP is just MAP without the final just-to-be-sure check that
1165 ;;; length of the output sequence matches any length specified
1166 ;;; in RESULT-TYPE.
1167 (defun %map (result-type function &rest sequences)
1168   (declare (explicit-check))
1169   (declare (dynamic-extent sequences))
1170   ;; Everything that we end up calling uses %COERCE-TO-CALLABLE
1171   ;; on FUNCTION so we don't need to declare it of type CALLABLE here.
1172   ;; Additionally all the arity-1 mappers use SEQ-DISPATCH which asserts
1173   ;; that the input is a SEQUENCE. Despite SEQ-DISPATCH being "less safe"
1174   ;; than SEQ-DISPATCH-CHECKING, both are in fact equally safe, because
1175   ;; the ARRAY case (which assumes that all arrays are vectors) utilizes
1176   ;; %WITH-ARRAY-DATA/FP which asserts that its input is a vector.
1177   (labels ((slower-map (type)
1178              (let ((really-fun (%coerce-callable-to-fun function)))
1179                (cond
1180                  ((eq type *empty-type*)
1181                   (%map-for-effect really-fun sequences))
1182                  ((csubtypep type (specifier-type 'list))
1183                   (%map-to-list really-fun sequences))
1184                  ((csubtypep type (specifier-type 'vector))
1185                   (%map-to-vector result-type really-fun sequences))
1186                  ((when-extended-sequence-type
1187                       (result-type type :expandedp nil :prototype prototype)
1188                     ;; This function has the EXPLICIT-CHECK
1189                     ;; declaration, so we manually assert that it
1190                     ;; returns a SEQUENCE.
1191                     (the extended-sequence
1192                          (apply #'sb!sequence:map
1193                                 prototype really-fun sequences))))
1194                  (t
1195                   (bad-sequence-type-error result-type))))))
1196     ;; Handle some easy cases faster
1197     (if (/= (length sequences) 1)
1198         (slower-map (specifier-type result-type))
1199         (let ((first-sequence (fast-&rest-nth 0 sequences)))
1200           (case result-type
1201            ((nil)
1202             (%map-for-effect-arity-1 function first-sequence))
1203            ((list cons)
1204             (%map-to-list-arity-1 function first-sequence))
1205            ((vector simple-vector)
1206             (%map-to-simple-vector-arity-1 function first-sequence))
1207            (t
1208             (let ((type (specifier-type result-type)))
1209               (cond ((eq type *empty-type*)
1210                      (%map-for-effect-arity-1 function first-sequence))
1211                     ((csubtypep type (specifier-type 'list))
1212                      (%map-to-list-arity-1 function first-sequence))
1213                     ((csubtypep type (specifier-type '(vector t)))
1214                      (%map-to-simple-vector-arity-1 function first-sequence))
1215                     (t
1216                      (slower-map type))))))))))
1217
1218 (defun map (result-type function first-sequence &rest more-sequences)
1219   (declare (explicit-check))
1220   (let ((result
1221          (apply #'%map result-type function first-sequence more-sequences)))
1222     (if (or (eq result-type 'nil) (typep result result-type))
1223         result
1224         (error 'simple-type-error
1225                :format-control "MAP result ~S is not a sequence of type ~S"
1226                :datum result
1227                :expected-type result-type
1228                :format-arguments (list result result-type)))))
1229
1230 ;;;; MAP-INTO
1231
1232 (defmacro map-into-lambda (sequences params &body body)
1233   (check-type sequences symbol)
1234   `(flet ((f ,params ,@body))
1235      (declare (truly-dynamic-extent #'f))
1236      ;; Note (MAP-INTO SEQ (LAMBDA () ...)) is a different animal,
1237      ;; hence the awkward flip between MAP and LOOP.
1238      (if ,sequences
1239          (apply #'%map nil #'f ,sequences)
1240          (loop (f)))))
1241
1242 (!define-array-dispatch vector-map-into (data start end fun sequences)
1243   (declare (type index start end)
1244            (type function fun)
1245            (type list sequences))
1246   (declare (explicit-check))
1247   (let ((index start))
1248     (declare (type index index))
1249     (block mapping
1250       (map-into-lambda sequences (&rest args)
1251         (declare (truly-dynamic-extent args))
1252         (when (eql index end)
1253           (return-from mapping))
1254         (setf (aref data index) (apply fun args))
1255         (incf index)))
1256     index))
1257
1258 ;;; Uses the machinery of (MAP NIL ...). For non-vectors we avoid
1259 ;;; computing the length of the result sequence since we can detect
1260 ;;; the end during mapping (if MAP even gets that far).
1261 ;;;
1262 ;;; For each result type, define a mapping function which is
1263 ;;; responsible for replacing RESULT-SEQUENCE elements and for
1264 ;;; terminating itself if the end of RESULT-SEQUENCE is reached.
1265 ;;; The mapping function is defined with MAP-INTO-LAMBDA.
1266 ;;;
1267 ;;; MAP-INTO-LAMBDAs are optimized since they are the inner loops.
1268 ;;; Because we are manually doing bounds checking with known types,
1269 ;;; safety is turned off for vectors and lists but kept for generic
1270 ;;; sequences.
1271 (defun map-into (result-sequence function &rest sequences)
1272   (declare (optimize (sb!c::check-tag-existence 0)))
1273   (let ((really-fun (%coerce-callable-to-fun function)))
1274     (etypecase result-sequence
1275       (vector
1276        (with-array-data ((data result-sequence) (start) (end)
1277                          ;; MAP-INTO ignores fill pointer when mapping
1278                          :check-fill-pointer nil)
1279          (let ((new-end (vector-map-into data start end really-fun sequences)))
1280            (when (array-has-fill-pointer-p result-sequence)
1281              (setf (fill-pointer result-sequence) (- new-end start))))))
1282       (list
1283        (let ((node result-sequence))
1284          (declare (type list node))
1285          (map-into-lambda sequences (&rest args)
1286            (declare (truly-dynamic-extent args))
1287            (cond ((null node)
1288                   (return-from map-into result-sequence))
1289                  ((not (listp (cdr node)))
1290                   (error 'simple-type-error
1291                          :format-control "~a is not a proper list"
1292                          :format-arguments (list result-sequence)
1293                          :expected-type 'list
1294                          :datum result-sequence)))
1295            (setf (car node) (apply really-fun args))
1296            (setf node (cdr node)))))
1297       (sequence
1298        (multiple-value-bind (iter limit from-end)
1299            (sb!sequence:make-sequence-iterator result-sequence)
1300          (map-into-lambda sequences (&rest args)
1301            (declare (truly-dynamic-extent args) (optimize speed))
1302            (when (sb!sequence:iterator-endp result-sequence
1303                                             iter limit from-end)
1304              (return-from map-into result-sequence))
1305            (setf (sb!sequence:iterator-element result-sequence iter)
1306                  (apply really-fun args))
1307            (setf iter (sb!sequence:iterator-step result-sequence
1308                                                            iter from-end)))))))
1309   result-sequence)
1310 \f
1311 ;;;; REDUCE
1312
1313 (eval-when (:compile-toplevel :execute)
1314
1315 (sb!xc:defmacro mumble-reduce (function
1316                                sequence
1317                                key
1318                                start
1319                                end
1320                                initial-value
1321                                ref)
1322   `(do ((index ,start (1+ index))
1323         (value ,initial-value))
1324        ((>= index ,end) value)
1325      (setq value (funcall ,function value
1326                           (apply-key ,key (,ref ,sequence index))))))
1327
1328 (sb!xc:defmacro mumble-reduce-from-end (function
1329                                         sequence
1330                                         key
1331                                         start
1332                                         end
1333                                         initial-value
1334                                         ref)
1335   `(do ((index (1- ,end) (1- index))
1336         (value ,initial-value)
1337         (terminus (1- ,start)))
1338        ((<= index terminus) value)
1339      (setq value (funcall ,function
1340                           (apply-key ,key (,ref ,sequence index))
1341                           value))))
1342
1343 (sb!xc:defmacro list-reduce (function
1344                              sequence
1345                              key
1346                              start
1347                              end
1348                              initial-value
1349                              ivp)
1350   `(let ((sequence (nthcdr ,start ,sequence)))
1351      (do ((count (if ,ivp ,start (1+ ,start))
1352                  (1+ count))
1353           (sequence (if ,ivp sequence (cdr sequence))
1354                     (cdr sequence))
1355           (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
1356                  (funcall ,function value (apply-key ,key (car sequence)))))
1357          ((>= count ,end) value))))
1358
1359 (sb!xc:defmacro list-reduce-from-end (function
1360                                       sequence
1361                                       key
1362                                       start
1363                                       end
1364                                       initial-value
1365                                       ivp)
1366   `(let ((sequence (nthcdr (- (length ,sequence) ,end)
1367                            (reverse ,sequence))))
1368      (do ((count (if ,ivp ,start (1+ ,start))
1369                  (1+ count))
1370           (sequence (if ,ivp sequence (cdr sequence))
1371                     (cdr sequence))
1372           (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
1373                  (funcall ,function (apply-key ,key (car sequence)) value)))
1374          ((>= count ,end) value))))
1375
1376 ) ; EVAL-WHEN
1377
1378 (define-sequence-traverser reduce (function sequence &rest args &key key
1379                                    from-end start end (initial-value nil ivp))
1380   (declare (type index start)
1381            (truly-dynamic-extent args))
1382   (seq-dispatch sequence
1383     (let ((end (or end length)))
1384       (declare (type index end))
1385       (if (= end start)
1386           (if ivp initial-value (funcall function))
1387           (if from-end
1388               (list-reduce-from-end function sequence key start end
1389                                     initial-value ivp)
1390               (list-reduce function sequence key start end
1391                            initial-value ivp))))
1392     (let ((end (or end length)))
1393       (declare (type index end))
1394       (if (= end start)
1395           (if ivp initial-value (funcall function))
1396           (if from-end
1397               (progn
1398                 (when (not ivp)
1399                   (setq end (1- (the fixnum end)))
1400                   (setq initial-value (apply-key key (aref sequence end))))
1401                 (mumble-reduce-from-end function sequence key start end
1402                                         initial-value aref))
1403               (progn
1404                 (when (not ivp)
1405                   (setq initial-value (apply-key key (aref sequence start)))
1406                   (setq start (1+ start)))
1407                 (mumble-reduce function sequence key start end
1408                                initial-value aref)))))
1409     (apply #'sb!sequence:reduce function sequence args)))
1410 \f
1411 ;;;; DELETE
1412
1413 (eval-when (:compile-toplevel :execute)
1414
1415 (sb!xc:defmacro mumble-delete (pred)
1416   `(do ((index start (1+ index))
1417         (jndex start)
1418         (number-zapped 0))
1419        ((or (= index (the fixnum end)) (= number-zapped count))
1420         (do ((index index (1+ index))           ; Copy the rest of the vector.
1421              (jndex jndex (1+ jndex)))
1422             ((= index (the fixnum length))
1423              (shrink-vector sequence jndex))
1424           (declare (fixnum index jndex))
1425           (setf (aref sequence jndex) (aref sequence index))))
1426      (declare (fixnum index jndex number-zapped))
1427      (setf (aref sequence jndex) (aref sequence index))
1428      (if ,pred
1429          (incf number-zapped)
1430          (incf jndex))))
1431
1432 (sb!xc:defmacro mumble-delete-from-end (pred)
1433   `(do ((index (1- (the fixnum end)) (1- index)) ; Find the losers.
1434         (number-zapped 0)
1435         (losers ())
1436         this-element
1437         (terminus (1- start)))
1438        ((or (= index terminus) (= number-zapped count))
1439         (do ((losers losers)                     ; Delete the losers.
1440              (index start (1+ index))
1441              (jndex start))
1442             ((or (null losers) (= index (the fixnum end)))
1443              (do ((index index (1+ index))       ; Copy the rest of the vector.
1444                   (jndex jndex (1+ jndex)))
1445                  ((= index (the fixnum length))
1446                   (shrink-vector sequence jndex))
1447                (declare (fixnum index jndex))
1448                (setf (aref sequence jndex) (aref sequence index))))
1449           (declare (fixnum index jndex))
1450           (setf (aref sequence jndex) (aref sequence index))
1451           (if (= index (the fixnum (car losers)))
1452               (pop losers)
1453               (incf jndex))))
1454      (declare (fixnum index number-zapped terminus))
1455      (setq this-element (aref sequence index))
1456      (when ,pred
1457        (incf number-zapped)
1458        (push index losers))))
1459
1460 (sb!xc:defmacro normal-mumble-delete ()
1461   `(mumble-delete
1462     (if test-not
1463         (not (funcall test-not item (apply-key key (aref sequence index))))
1464         (funcall test item (apply-key key (aref sequence index))))))
1465
1466 (sb!xc:defmacro normal-mumble-delete-from-end ()
1467   `(mumble-delete-from-end
1468     (if test-not
1469         (not (funcall test-not item (apply-key key this-element)))
1470         (funcall test item (apply-key key this-element)))))
1471
1472 (sb!xc:defmacro list-delete (pred)
1473   `(let ((handle (cons nil sequence)))
1474      (declare (truly-dynamic-extent handle))
1475      (do ((current (nthcdr start sequence) (cdr current))
1476           (previous (nthcdr start handle))
1477           (index start (1+ index))
1478           (number-zapped 0))
1479          ((or (= index (the fixnum end)) (= number-zapped count))
1480           (cdr handle))
1481        (declare (fixnum index number-zapped))
1482        (cond (,pred
1483               (rplacd previous (cdr current))
1484               (incf number-zapped))
1485              (t
1486               (setq previous (cdr previous)))))))
1487
1488 (sb!xc:defmacro list-delete-from-end (pred)
1489   `(let* ((reverse (nreverse (the list sequence)))
1490           (handle (cons nil reverse)))
1491      (declare (truly-dynamic-extent handle))
1492      (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse)
1493                    (cdr current))
1494           (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
1495           (index start (1+ index))
1496           (number-zapped 0))
1497          ((or (= index (the fixnum end)) (= number-zapped count))
1498           (nreverse (cdr handle)))
1499        (declare (fixnum index number-zapped))
1500        (cond (,pred
1501               (rplacd previous (cdr current))
1502               (incf number-zapped))
1503              (t
1504               (setq previous (cdr previous)))))))
1505
1506 (sb!xc:defmacro normal-list-delete ()
1507   '(list-delete
1508     (if test-not
1509         (not (funcall test-not item (apply-key key (car current))))
1510         (funcall test item (apply-key key (car current))))))
1511
1512 (sb!xc:defmacro normal-list-delete-from-end ()
1513   '(list-delete-from-end
1514     (if test-not
1515         (not (funcall test-not item (apply-key key (car current))))
1516         (funcall test item (apply-key key (car current))))))
1517
1518 ) ; EVAL-WHEN
1519
1520 (define-sequence-traverser delete
1521     (item sequence &rest args &key from-end test test-not start
1522      end count key)
1523   #!+sb-doc
1524   "Return a sequence formed by destructively removing the specified ITEM from
1525   the given SEQUENCE."
1526   (declare (type fixnum start)
1527            (truly-dynamic-extent args))
1528   (seq-dispatch sequence
1529     (let ((end (or end length)))
1530       (declare (type index end))
1531       (if from-end
1532           (normal-list-delete-from-end)
1533           (normal-list-delete)))
1534     (let ((end (or end length)))
1535       (declare (type index end))
1536       (if from-end
1537           (normal-mumble-delete-from-end)
1538           (normal-mumble-delete)))
1539     (apply #'sb!sequence:delete item sequence args)))
1540
1541 (eval-when (:compile-toplevel :execute)
1542
1543 (sb!xc:defmacro if-mumble-delete ()
1544   `(mumble-delete
1545     (funcall predicate (apply-key key (aref sequence index)))))
1546
1547 (sb!xc:defmacro if-mumble-delete-from-end ()
1548   `(mumble-delete-from-end
1549     (funcall predicate (apply-key key this-element))))
1550
1551 (sb!xc:defmacro if-list-delete ()
1552   '(list-delete
1553     (funcall predicate (apply-key key (car current)))))
1554
1555 (sb!xc:defmacro if-list-delete-from-end ()
1556   '(list-delete-from-end
1557     (funcall predicate (apply-key key (car current)))))
1558
1559 ) ; EVAL-WHEN
1560
1561 (define-sequence-traverser delete-if
1562     (predicate sequence &rest args &key from-end start key end count)
1563   #!+sb-doc
1564   "Return a sequence formed by destructively removing the elements satisfying
1565   the specified PREDICATE from the given SEQUENCE."
1566   (declare (type fixnum start)
1567            (truly-dynamic-extent args))
1568   (seq-dispatch sequence
1569     (let ((end (or end length)))
1570       (declare (type index end))
1571       (if from-end
1572           (if-list-delete-from-end)
1573           (if-list-delete)))
1574     (let ((end (or end length)))
1575       (declare (type index end))
1576       (if from-end
1577           (if-mumble-delete-from-end)
1578           (if-mumble-delete)))
1579     (apply #'sb!sequence:delete-if predicate sequence args)))
1580
1581 (eval-when (:compile-toplevel :execute)
1582
1583 (sb!xc:defmacro if-not-mumble-delete ()
1584   `(mumble-delete
1585     (not (funcall predicate (apply-key key (aref sequence index))))))
1586
1587 (sb!xc:defmacro if-not-mumble-delete-from-end ()
1588   `(mumble-delete-from-end
1589     (not (funcall predicate (apply-key key this-element)))))
1590
1591 (sb!xc:defmacro if-not-list-delete ()
1592   '(list-delete
1593     (not (funcall predicate (apply-key key (car current))))))
1594
1595 (sb!xc:defmacro if-not-list-delete-from-end ()
1596   '(list-delete-from-end
1597     (not (funcall predicate (apply-key key (car current))))))
1598
1599 ) ; EVAL-WHEN
1600
1601 (define-sequence-traverser delete-if-not
1602     (predicate sequence &rest args &key from-end start end key count)
1603   #!+sb-doc
1604   "Return a sequence formed by destructively removing the elements not
1605   satisfying the specified PREDICATE from the given SEQUENCE."
1606   (declare (type fixnum start)
1607            (truly-dynamic-extent args))
1608   (seq-dispatch sequence
1609     (let ((end (or end length)))
1610       (declare (type index end))
1611       (if from-end
1612           (if-not-list-delete-from-end)
1613           (if-not-list-delete)))
1614     (let ((end (or end length)))
1615       (declare (type index end))
1616       (if from-end
1617           (if-not-mumble-delete-from-end)
1618           (if-not-mumble-delete)))
1619     (apply #'sb!sequence:delete-if-not predicate sequence args)))
1620 \f
1621 ;;;; REMOVE
1622
1623 (eval-when (:compile-toplevel :execute)
1624
1625 ;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that
1626 ;;; satisfies the predicate.
1627 (sb!xc:defmacro mumble-remove-macro (bump left begin finish right pred)
1628   `(do ((index ,begin (,bump index))
1629         (result
1630          (do ((index ,left (,bump index))
1631               (result (%make-sequence-like sequence length)))
1632              ((= index (the fixnum ,begin)) result)
1633            (declare (fixnum index))
1634            (setf (aref result index) (aref sequence index))))
1635         (new-index ,begin)
1636         (number-zapped 0)
1637         (this-element))
1638        ((or (= index (the fixnum ,finish))
1639             (= number-zapped count))
1640         (do ((index index (,bump index))
1641              (new-index new-index (,bump new-index)))
1642             ((= index (the fixnum ,right)) (%shrink-vector result new-index))
1643           (declare (fixnum index new-index))
1644           (setf (aref result new-index) (aref sequence index))))
1645      (declare (fixnum index new-index number-zapped))
1646      (setq this-element (aref sequence index))
1647      (cond (,pred (incf number-zapped))
1648            (t (setf (aref result new-index) this-element)
1649               (setq new-index (,bump new-index))))))
1650
1651 (sb!xc:defmacro mumble-remove (pred)
1652   `(mumble-remove-macro 1+ 0 start end length ,pred))
1653
1654 (sb!xc:defmacro mumble-remove-from-end (pred)
1655   `(let ((sequence (copy-seq sequence)))
1656      (mumble-delete-from-end ,pred)))
1657
1658 (sb!xc:defmacro normal-mumble-remove ()
1659   `(mumble-remove
1660     (if test-not
1661         (not (funcall test-not item (apply-key key this-element)))
1662         (funcall test item (apply-key key this-element)))))
1663
1664 (sb!xc:defmacro normal-mumble-remove-from-end ()
1665   `(mumble-remove-from-end
1666     (if test-not
1667         (not (funcall test-not item (apply-key key this-element)))
1668         (funcall test item (apply-key key this-element)))))
1669
1670 (sb!xc:defmacro if-mumble-remove ()
1671   `(mumble-remove (funcall predicate (apply-key key this-element))))
1672
1673 (sb!xc:defmacro if-mumble-remove-from-end ()
1674   `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
1675
1676 (sb!xc:defmacro if-not-mumble-remove ()
1677   `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
1678
1679 (sb!xc:defmacro if-not-mumble-remove-from-end ()
1680   `(mumble-remove-from-end
1681     (not (funcall predicate (apply-key key this-element)))))
1682
1683 ;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies
1684 ;;; the predicate.
1685 (sb!xc:defmacro list-remove-macro (pred reverse?)
1686   `(let* ((sequence ,(if reverse?
1687                          '(reverse (the list sequence))
1688                          'sequence))
1689           (%start ,(if reverse? '(- length end) 'start))
1690           (%end ,(if reverse? '(- length start) 'end))
1691           (splice (list nil))
1692           (results (do ((index 0 (1+ index))
1693                         (before-start splice))
1694                        ((= index (the fixnum %start)) before-start)
1695                      (declare (fixnum index))
1696                      (setq splice
1697                            (cdr (rplacd splice (list (pop sequence))))))))
1698      (do ((index %start (1+ index))
1699           (this-element)
1700           (number-zapped 0))
1701          ((or (= index (the fixnum %end)) (= number-zapped count))
1702           (do ((index index (1+ index)))
1703               ((null sequence)
1704                ,(if reverse?
1705                     '(nreverse (the list (cdr results)))
1706                     '(cdr results)))
1707             (declare (fixnum index))
1708             (setq splice (cdr (rplacd splice (list (pop sequence)))))))
1709        (declare (fixnum index number-zapped))
1710        (setq this-element (pop sequence))
1711        (if ,pred
1712            (setq number-zapped (1+ number-zapped))
1713            (setq splice (cdr (rplacd splice (list this-element))))))))
1714
1715 (sb!xc:defmacro list-remove (pred)
1716   `(list-remove-macro ,pred nil))
1717
1718 (sb!xc:defmacro list-remove-from-end (pred)
1719   `(list-remove-macro ,pred t))
1720
1721 (sb!xc:defmacro normal-list-remove ()
1722   `(list-remove
1723     (if test-not
1724         (not (funcall test-not item (apply-key key this-element)))
1725         (funcall test item (apply-key key this-element)))))
1726
1727 (sb!xc:defmacro normal-list-remove-from-end ()
1728   `(list-remove-from-end
1729     (if test-not
1730         (not (funcall test-not item (apply-key key this-element)))
1731         (funcall test item (apply-key key this-element)))))
1732
1733 (sb!xc:defmacro if-list-remove ()
1734   `(list-remove
1735     (funcall predicate (apply-key key this-element))))
1736
1737 (sb!xc:defmacro if-list-remove-from-end ()
1738   `(list-remove-from-end
1739     (funcall predicate (apply-key key this-element))))
1740
1741 (sb!xc:defmacro if-not-list-remove ()
1742   `(list-remove
1743     (not (funcall predicate (apply-key key this-element)))))
1744
1745 (sb!xc:defmacro if-not-list-remove-from-end ()
1746   `(list-remove-from-end
1747     (not (funcall predicate (apply-key key this-element)))))
1748
1749 ) ; EVAL-WHEN
1750
1751 (define-sequence-traverser remove
1752     (item sequence &rest args &key from-end test test-not start
1753      end count key)
1754   #!+sb-doc
1755   "Return a copy of SEQUENCE with elements satisfying the test (default is
1756    EQL) with ITEM removed."
1757   (declare (type fixnum start)
1758            (truly-dynamic-extent args))
1759   (seq-dispatch sequence
1760     (let ((end (or end length)))
1761       (declare (type index end))
1762       (if from-end
1763           (normal-list-remove-from-end)
1764           (normal-list-remove)))
1765     (let ((end (or end length)))
1766       (declare (type index end))
1767       (if from-end
1768           (normal-mumble-remove-from-end)
1769           (normal-mumble-remove)))
1770     (apply #'sb!sequence:remove item sequence args)))
1771
1772 (define-sequence-traverser remove-if
1773     (predicate sequence &rest args &key from-end start end count key)
1774   #!+sb-doc
1775   "Return a copy of sequence with elements satisfying PREDICATE removed."
1776   (declare (type fixnum start)
1777            (truly-dynamic-extent args))
1778   (seq-dispatch sequence
1779     (let ((end (or end length)))
1780       (declare (type index end))
1781       (if from-end
1782           (if-list-remove-from-end)
1783           (if-list-remove)))
1784     (let ((end (or end length)))
1785       (declare (type index end))
1786       (if from-end
1787           (if-mumble-remove-from-end)
1788           (if-mumble-remove)))
1789     (apply #'sb!sequence:remove-if predicate sequence args)))
1790
1791 (define-sequence-traverser remove-if-not
1792     (predicate sequence &rest args &key from-end start end count key)
1793   #!+sb-doc
1794   "Return a copy of sequence with elements not satisfying PREDICATE removed."
1795   (declare (type fixnum start)
1796            (truly-dynamic-extent args))
1797   (seq-dispatch sequence
1798     (let ((end (or end length)))
1799       (declare (type index end))
1800       (if from-end
1801           (if-not-list-remove-from-end)
1802           (if-not-list-remove)))
1803     (let ((end (or end length)))
1804       (declare (type index end))
1805       (if from-end
1806           (if-not-mumble-remove-from-end)
1807           (if-not-mumble-remove)))
1808     (apply #'sb!sequence:remove-if-not predicate sequence args)))
1809 \f
1810 ;;;; REMOVE-DUPLICATES
1811
1812 ;;; Remove duplicates from a list. If from-end, remove the later duplicates,
1813 ;;; not the earlier ones. Thus if we check from-end we don't copy an item
1814 ;;; if we look into the already copied structure (from after :start) and see
1815 ;;; the item. If we check from beginning we check into the rest of the
1816 ;;; original list up to the :end marker (this we have to do by running a
1817 ;;; do loop down the list that far and using our test.
1818 (defun list-remove-duplicates* (list test test-not start end key from-end)
1819   (declare (fixnum start))
1820   (let* ((result (list ())) ; Put a marker on the beginning to splice with.
1821          (splice result)
1822          (current list)
1823          (end (or end (length list)))
1824          (hash (and (> (- end start) 20)
1825                     test
1826                     (not key)
1827                     (not test-not)
1828                     (or (eql test #'eql)
1829                         (eql test #'eq)
1830                         (eql test #'equal)
1831                         (eql test #'equalp))
1832                     (make-hash-table :test test :size (- end start)))))
1833     (do ((index 0 (1+ index)))
1834         ((= index start))
1835       (declare (fixnum index))
1836       (setq splice (cdr (rplacd splice (list (car current)))))
1837       (setq current (cdr current)))
1838     (if hash
1839         (do ((index start (1+ index)))
1840             ((or (and end (= index (the fixnum end)))
1841                  (atom current)))
1842           (declare (fixnum index))
1843           ;; The hash table contains links from values that are
1844           ;; already in result to the cons cell *preceding* theirs
1845           ;; in the list.  That is, for each value v in the list,
1846           ;; v and (cadr (gethash v hash)) are equal under TEST.
1847           (let ((prev (gethash (car current) hash)))
1848             (cond
1849              ((not prev)
1850               (setf (gethash (car current) hash) splice)
1851               (setq splice (cdr (rplacd splice (list (car current))))))
1852              ((not from-end)
1853               (let* ((old (cdr prev))
1854                      (next (cdr old)))
1855                 (if next
1856                   (let ((next-val (car next)))
1857                     ;; (assert (eq (gethash next-val hash) old))
1858                     (setf (cdr prev) next
1859                           (gethash next-val hash) prev
1860                           (gethash (car current) hash) splice
1861                           splice (cdr (rplacd splice (list (car current))))))
1862                   (setf (car old) (car current)))))))
1863           (setq current (cdr current)))
1864       (do ((index start (1+ index)))
1865           ((or (and end (= index (the fixnum end)))
1866                (atom current)))
1867         (declare (fixnum index))
1868         (if (or (and from-end
1869                      (not (if test-not
1870                               (member (apply-key key (car current))
1871                                       (nthcdr (1+ start) result)
1872                                       :test-not test-not
1873                                       :key key)
1874                             (member (apply-key key (car current))
1875                                     (nthcdr (1+ start) result)
1876                                     :test test
1877                                     :key key))))
1878                 (and (not from-end)
1879                      (not (do ((it (apply-key key (car current)))
1880                                (l (cdr current) (cdr l))
1881                                (i (1+ index) (1+ i)))
1882                               ((or (atom l) (and end (= i (the fixnum end))))
1883                                ())
1884                             (declare (fixnum i))
1885                             (if (if test-not
1886                                     (not (funcall test-not
1887                                                   it
1888                                                   (apply-key key (car l))))
1889                                   (funcall test it (apply-key key (car l))))
1890                                 (return t))))))
1891             (setq splice (cdr (rplacd splice (list (car current))))))
1892         (setq current (cdr current))))
1893     (do ()
1894         ((atom current))
1895       (setq splice (cdr (rplacd splice (list (car current)))))
1896       (setq current (cdr current)))
1897     (cdr result)))
1898
1899 (defun vector-remove-duplicates* (vector test test-not start end key from-end
1900                                          &optional (length (length vector)))
1901   (declare (vector vector) (fixnum start length))
1902   (when (null end) (setf end (length vector)))
1903   (let ((result (%make-sequence-like vector length))
1904         (index 0)
1905         (jndex start))
1906     (declare (fixnum index jndex))
1907     (do ()
1908         ((= index start))
1909       (setf (aref result index) (aref vector index))
1910       (setq index (1+ index)))
1911     (do ((elt))
1912         ((= index end))
1913       (setq elt (aref vector index))
1914       (unless (or (and from-end
1915                        (if test-not
1916                            (position (apply-key key elt) result
1917                                      :start start :end jndex
1918                                      :test-not test-not :key key)
1919                            (position (apply-key key elt) result
1920                                      :start start :end jndex
1921                                      :test test :key key)))
1922                   (and (not from-end)
1923                        (if test-not
1924                            (position (apply-key key elt) vector
1925                                      :start (1+ index) :end end
1926                                      :test-not test-not :key key)
1927                            (position (apply-key key elt) vector
1928                                      :start (1+ index) :end end
1929                                      :test test :key key))))
1930         (setf (aref result jndex) elt)
1931         (setq jndex (1+ jndex)))
1932       (setq index (1+ index)))
1933     (do ()
1934         ((= index length))
1935       (setf (aref result jndex) (aref vector index))
1936       (setq index (1+ index))
1937       (setq jndex (1+ jndex)))
1938     (%shrink-vector result jndex)))
1939
1940 (define-sequence-traverser remove-duplicates
1941     (sequence &rest args &key test test-not start end from-end key)
1942   #!+sb-doc
1943   "The elements of SEQUENCE are compared pairwise, and if any two match,
1944    the one occurring earlier is discarded, unless FROM-END is true, in
1945    which case the one later in the sequence is discarded. The resulting
1946    sequence is returned.
1947
1948    The :TEST-NOT argument is deprecated."
1949   (declare (fixnum start)
1950            (truly-dynamic-extent args))
1951   (seq-dispatch sequence
1952     (if sequence
1953         (list-remove-duplicates* sequence test test-not
1954                                  start end key from-end))
1955     (vector-remove-duplicates* sequence test test-not start end key from-end)
1956     (apply #'sb!sequence:remove-duplicates sequence args)))
1957 \f
1958 ;;;; DELETE-DUPLICATES
1959
1960 (defun list-delete-duplicates* (list test test-not key from-end start end)
1961   (declare (fixnum start))
1962   (let ((handle (cons nil list)))
1963     (declare (truly-dynamic-extent handle))
1964     (do ((current (nthcdr start list) (cdr current))
1965          (previous (nthcdr start handle))
1966          (index start (1+ index)))
1967         ((or (and end (= index (the fixnum end))) (null current))
1968          (cdr handle))
1969       (declare (fixnum index))
1970       (if (do ((x (if from-end
1971                       (nthcdr (1+ start) handle)
1972                       (cdr current))
1973                   (cdr x))
1974                (i (1+ index) (1+ i)))
1975               ((or (null x)
1976                    (and (not from-end) end (= i (the fixnum end)))
1977                    (eq x current))
1978                nil)
1979             (declare (fixnum i))
1980             (if (if test-not
1981                     (not (funcall test-not
1982                                   (apply-key key (car current))
1983                                   (apply-key key (car x))))
1984                     (funcall test
1985                              (apply-key key (car current))
1986                              (apply-key key (car x))))
1987                 (return t)))
1988           (rplacd previous (cdr current))
1989           (setq previous (cdr previous))))))
1990
1991 (defun vector-delete-duplicates* (vector test test-not key from-end start end
1992                                          &optional (length (length vector)))
1993   (declare (vector vector) (fixnum start length))
1994   (when (null end) (setf end (length vector)))
1995   (do ((index start (1+ index))
1996        (jndex start))
1997       ((= index end)
1998        (do ((index index (1+ index))            ; copy the rest of the vector
1999             (jndex jndex (1+ jndex)))
2000            ((= index length)
2001             (shrink-vector vector jndex))
2002          (setf (aref vector jndex) (aref vector index))))
2003     (declare (fixnum index jndex))
2004     (setf (aref vector jndex) (aref vector index))
2005     (unless (if test-not
2006                 (position (apply-key key (aref vector index)) vector :key key
2007                           :start (if from-end start (1+ index))
2008                           :end (if from-end jndex end)
2009                           :test-not test-not)
2010                 (position (apply-key key (aref vector index)) vector :key key
2011                           :start (if from-end start (1+ index))
2012                           :end (if from-end jndex end)
2013                           :test test))
2014       (setq jndex (1+ jndex)))))
2015
2016 (define-sequence-traverser delete-duplicates
2017     (sequence &rest args &key test test-not start end from-end key)
2018   #!+sb-doc
2019   "The elements of SEQUENCE are examined, and if any two match, one is
2020    discarded. The resulting sequence, which may be formed by destroying the
2021    given sequence, is returned.
2022
2023    The :TEST-NOT argument is deprecated."
2024   (declare (truly-dynamic-extent args))
2025   (seq-dispatch sequence
2026     (when sequence
2027       (list-delete-duplicates* sequence test test-not
2028                                key from-end start end))
2029     (vector-delete-duplicates* sequence test test-not key from-end start end)
2030     (apply #'sb!sequence:delete-duplicates sequence args)))
2031 \f
2032 ;;;; SUBSTITUTE
2033
2034 (defun list-substitute* (pred new list start end count key test test-not old)
2035   (declare (fixnum start end count)
2036            (type (or null function) key)
2037            (optimize speed))
2038   (let* ((result (list nil))
2039          (test (or test-not test))
2040          (test-not (or test-not
2041                        (eq pred 'if-not)))
2042          elt
2043          (splice result)
2044          (list list))      ; Get a local list for a stepper.
2045     (declare (function test))
2046     (do ((index 0 (1+ index)))
2047         ((= index start))
2048       (declare (fixnum index))
2049       (setf splice (cdr (rplacd splice (list (car list))))
2050             list (cdr list)))
2051     (do ((index start (1+ index)))
2052         ((or (= index end) (null list) (= count 0)))
2053       (declare (fixnum index))
2054       (setf elt (car list)
2055             splice
2056             (cdr (rplacd splice
2057                          (list
2058                           (cond ((let* ((elt (apply-key key elt))
2059                                         (value (if (eq pred 'normal)
2060                                                    (funcall test old elt)
2061                                                    (funcall test elt))))
2062                                    (if test-not
2063                                        (not value)
2064                                        value))
2065                                  (decf count)
2066                                  new)
2067                                 (t elt)))))
2068             list (cdr list)))
2069     (do ()
2070         ((null list))
2071       (setf splice (cdr (rplacd splice (list (car list))))
2072             list (cdr list)))
2073     (cdr result)))
2074
2075 ;;; Replace old with new in sequence moving from left to right by incrementer
2076 ;;; on each pass through the loop. Called by all three substitute functions.
2077 (defun vector-substitute* (pred new sequence incrementer left right length
2078                            start end count key test test-not old)
2079   (declare (fixnum start count end incrementer right)
2080            (type (or null function) key))
2081   (let* ((result (make-vector-like sequence length))
2082          (getter (the function (svref %%data-vector-reffers%%
2083                                       (%other-pointer-widetag sequence))))
2084          (setter (the function (svref %%data-vector-setters%%
2085                                       (%other-pointer-widetag result))))
2086          (test (or test-not test))
2087          (test-not (or test-not
2088                        (eq pred 'if-not)))
2089          (index left))
2090     (declare (fixnum index)
2091              (function test))
2092     (do ()
2093         ((= index start))
2094       (funcall setter result index
2095                (funcall getter sequence index))
2096       (incf index incrementer))
2097     (do ((elt))
2098         ((or (= index end) (= count 0)))
2099       (setf elt (funcall getter sequence index))
2100       (funcall setter result index
2101                (cond ((let* ((elt (apply-key key elt))
2102                              (value (if (eq pred 'normal)
2103                                         (funcall test old elt)
2104                                         (funcall test elt))))
2105                         (if test-not
2106                             (not value)
2107                             value))
2108                       (decf count)
2109                       new)
2110                      (t elt)))
2111       (incf index incrementer))
2112     (do ()
2113         ((= index right))
2114       (funcall setter result index
2115                (funcall getter sequence index))
2116       (incf index incrementer))
2117     result))
2118
2119 (eval-when (:compile-toplevel :execute)
2120
2121 (sb!xc:defmacro subst-dispatch (pred)
2122   `(seq-dispatch sequence
2123      (let ((end (or end length)))
2124        (declare (type index end))
2125        (if from-end
2126            (nreverse (list-substitute* ,pred
2127                                        new
2128                                        (reverse sequence)
2129                                        (- (the fixnum length)
2130                                           (the fixnum end))
2131                                        (- (the fixnum length)
2132                                           (the fixnum start))
2133                                        count key test test-not old))
2134            (list-substitute* ,pred
2135                              new sequence start end count key test test-not
2136                              old)))
2137
2138      (let ((end (or end length)))
2139        (declare (type index end))
2140        (if from-end
2141            (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
2142                                -1 length (1- (the fixnum end))
2143                                (1- (the fixnum start))
2144                                count key test test-not old)
2145            (vector-substitute* ,pred new sequence 1 0 length length
2146                                start end count key test test-not old)))
2147
2148     ;; FIXME: wow, this is an odd way to implement the dispatch.  PRED
2149     ;; here is (QUOTE [NORMAL|IF|IF-NOT]).  Not only is this pretty
2150     ;; pointless, but also LIST-SUBSTITUTE* and VECTOR-SUBSTITUTE*
2151     ;; dispatch once per element on PRED's run-time identity.
2152     ,(ecase (cadr pred)
2153        ((normal) `(apply #'sb!sequence:substitute new old sequence args))
2154        ((if) `(apply #'sb!sequence:substitute-if new predicate sequence args))
2155        ((if-not) `(apply #'sb!sequence:substitute-if-not new predicate sequence args)))))
2156 ) ; EVAL-WHEN
2157
2158 (define-sequence-traverser substitute
2159     (new old sequence &rest args &key from-end test test-not
2160          start count end key)
2161   #!+sb-doc
2162   "Return a sequence of the same kind as SEQUENCE with the same elements,
2163   except that all elements equal to OLD are replaced with NEW."
2164   (declare (type fixnum start)
2165            (truly-dynamic-extent args))
2166   (subst-dispatch 'normal))
2167 \f
2168 ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
2169
2170 (define-sequence-traverser substitute-if
2171     (new predicate sequence &rest args &key from-end start end count key)
2172   #!+sb-doc
2173   "Return a sequence of the same kind as SEQUENCE with the same elements
2174   except that all elements satisfying the PRED are replaced with NEW."
2175   (declare (type fixnum start)
2176            (truly-dynamic-extent args))
2177   (let ((test predicate)
2178         (test-not nil)
2179         old)
2180     (subst-dispatch 'if)))
2181
2182 (define-sequence-traverser substitute-if-not
2183     (new predicate sequence &rest args &key from-end start end count key)
2184   #!+sb-doc
2185   "Return a sequence of the same kind as SEQUENCE with the same elements
2186   except that all elements not satisfying the PRED are replaced with NEW."
2187   (declare (type fixnum start)
2188            (truly-dynamic-extent args))
2189   (let ((test predicate)
2190         (test-not nil)
2191         old)
2192     (subst-dispatch 'if-not)))
2193 \f
2194 ;;;; NSUBSTITUTE
2195
2196 (define-sequence-traverser nsubstitute
2197     (new old sequence &rest args &key from-end test test-not
2198          end count key start)
2199   #!+sb-doc
2200   "Return a sequence of the same kind as SEQUENCE with the same elements
2201   except that all elements equal to OLD are replaced with NEW. SEQUENCE
2202   may be destructively modified."
2203   (declare (type fixnum start)
2204            (truly-dynamic-extent args))
2205   (seq-dispatch sequence
2206     (let ((end (or end length)))
2207       (declare (type index end))
2208       (if from-end
2209           (nreverse (nlist-substitute*
2210                      new old (nreverse (the list sequence))
2211                      test test-not (- length end) (- length start)
2212                      count key))
2213           (nlist-substitute* new old sequence
2214                              test test-not start end count key)))
2215     (let ((end (or end length)))
2216       (declare (type index end))
2217       (if from-end
2218           (nvector-substitute* new old sequence -1
2219                                test test-not (1- end) (1- start) count key)
2220           (nvector-substitute* new old sequence 1
2221                                test test-not start end count key)))
2222     (apply #'sb!sequence:nsubstitute new old sequence args)))
2223
2224 (defun nlist-substitute* (new old sequence test test-not start end count key)
2225   (declare (fixnum start count end)
2226            (type (or null function) key))
2227   (do ((test (or test-not test))
2228        (list (nthcdr start sequence) (cdr list))
2229        (index start (1+ index)))
2230       ((or (= index end) (null list) (= count 0)) sequence)
2231     (declare (fixnum index)
2232              (function test))
2233     (let ((value (funcall test old (apply-key key (car list)))))
2234      (when (if test-not
2235                (not value)
2236                value)
2237        (rplaca list new)
2238        (decf count)))))
2239
2240 (defun nvector-substitute* (new old sequence incrementer
2241                             test test-not start end count key)
2242   (declare (fixnum start count end)
2243            (type (integer -1 1) incrementer)
2244            (type (or null function) key))
2245   (let* ((test (or test-not test))
2246          (tag (%other-pointer-widetag sequence))
2247          (getter (the function (svref %%data-vector-reffers%% tag)))
2248          (setter (the function (svref %%data-vector-setters%% tag))))
2249     (declare (function test))
2250     (do ((index start (+ index incrementer)))
2251         ((or (= index end) (= count 0)) sequence)
2252       (declare (fixnum index))
2253       (let* ((value (apply-key key (funcall getter sequence index)))
2254              (test (and (funcall test old value) 0)))
2255         (when (if test-not
2256                   (not test)
2257                   test)
2258           (funcall setter sequence index new)
2259           (decf count))))))
2260 \f
2261 ;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
2262
2263 (define-sequence-traverser nsubstitute-if
2264     (new predicate sequence &rest args &key from-end start end count key)
2265   #!+sb-doc
2266   "Return a sequence of the same kind as SEQUENCE with the same elements
2267    except that all elements satisfying PREDICATE are replaced with NEW.
2268    SEQUENCE may be destructively modified."
2269   (declare (type fixnum start)
2270            (truly-dynamic-extent args))
2271   (seq-dispatch sequence
2272     (let ((end (or end length)))
2273       (declare (type index end))
2274       (if from-end
2275           (nreverse (nlist-substitute-if*
2276                      new predicate (nreverse (the list sequence))
2277                      (- length end) (- length start) count key))
2278           (nlist-substitute-if* new predicate sequence
2279                                 start end count key)))
2280     (let ((end (or end length)))
2281       (declare (type index end))
2282       (if from-end
2283           (nvector-substitute-if* new predicate sequence -1
2284                                   (1- end) (1- start) count key)
2285           (nvector-substitute-if* new predicate sequence 1
2286                                   start end count key)))
2287     (apply #'sb!sequence:nsubstitute-if new predicate sequence args)))
2288
2289 (defun nlist-substitute-if* (new test sequence start end count key)
2290   (declare (type fixnum start end count)
2291            (type (or null function) key)
2292            (type function test)) ; coercion is done by caller
2293   (do ((list (nthcdr start sequence) (cdr list))
2294        (index start (1+ index)))
2295       ((or (= index end) (null list) (= count 0)) sequence)
2296     (declare (fixnum index))
2297     (when (funcall test (apply-key key (car list)))
2298       (rplaca list new)
2299       (decf count))))
2300
2301 (defun nvector-substitute-if* (new test sequence incrementer
2302                                start end count key)
2303   (declare (type fixnum end count)
2304            (type (integer -1 1) incrementer)
2305            (type (or null function) key)
2306            (type function test)) ; coercion is done by caller
2307   (let* ((tag (%other-pointer-widetag sequence))
2308          (getter (the function (svref %%data-vector-reffers%% tag)))
2309          (setter (the function (svref %%data-vector-setters%% tag))))
2310     (do ((index start (+ index incrementer)))
2311         ((or (= index end) (= count 0)) sequence)
2312       (declare (fixnum index))
2313       (when (funcall test (apply-key key (funcall getter sequence index)))
2314         (funcall setter sequence index new)
2315         (decf count)))))
2316
2317 (define-sequence-traverser nsubstitute-if-not
2318     (new predicate sequence &rest args &key from-end start end count key)
2319   #!+sb-doc
2320   "Return a sequence of the same kind as SEQUENCE with the same elements
2321    except that all elements not satisfying PREDICATE are replaced with NEW.
2322    SEQUENCE may be destructively modified."
2323   (declare (type fixnum start)
2324            (truly-dynamic-extent args))
2325   (seq-dispatch sequence
2326     (let ((end (or end length)))
2327       (declare (fixnum end))
2328       (if from-end
2329           (nreverse (nlist-substitute-if-not*
2330                      new predicate (nreverse (the list sequence))
2331                      (- length end) (- length start) count key))
2332           (nlist-substitute-if-not* new predicate sequence
2333                                     start end count key)))
2334     (let ((end (or end length)))
2335       (declare (fixnum end))
2336       (if from-end
2337           (nvector-substitute-if-not* new predicate sequence -1
2338                                       (1- end) (1- start) count key)
2339           (nvector-substitute-if-not* new predicate sequence 1
2340                                       start end count key)))
2341     (apply #'sb!sequence:nsubstitute-if-not new predicate sequence args)))
2342
2343 (defun nlist-substitute-if-not* (new test sequence start end count key)
2344   (declare (type fixnum start end count)
2345            (type (or null function) key)
2346            (type function test))        ; coercion is done by caller
2347   (do ((list (nthcdr start sequence) (cdr list))
2348        (index start (1+ index)))
2349       ((or (= index end) (null list) (= count 0)) sequence)
2350     (declare (fixnum index))
2351     (when (not (funcall test (apply-key key (car list))))
2352       (rplaca list new)
2353       (decf count))))
2354
2355 (defun nvector-substitute-if-not* (new test sequence incrementer
2356                                    start end count key)
2357   (declare (type fixnum end count)
2358            (type (integer -1 1) incrementer)
2359            (type (or null function) key)
2360            (type function test))        ; coercion is done by caller
2361   (let* ((tag (%other-pointer-widetag sequence))
2362          (getter (the function (svref %%data-vector-reffers%% tag)))
2363          (setter (the function (svref %%data-vector-setters%% tag))))
2364     (do ((index start (+ index incrementer)))
2365         ((or (= index end) (= count 0)) sequence)
2366       (declare (fixnum index))
2367       (when (not (funcall test (apply-key key (funcall getter sequence index))))
2368         (funcall setter sequence index new)
2369         (decf count)))))
2370 \f
2371 ;;;; FIND, POSITION, and their -IF and -IF-NOT variants
2372
2373 (defun effective-find-position-test (test test-not)
2374   (effective-find-position-test test test-not))
2375 (defun effective-find-position-key (key)
2376   (effective-find-position-key key))
2377
2378 ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
2379 (macrolet (;; shared logic for defining %FIND-POSITION and
2380            ;; %FIND-POSITION-IF in terms of various inlineable cases
2381            ;; of the expression defined in FROB and VECTOR*-FROB
2382            (frobs (&optional bit-frob)
2383              `(seq-dispatch sequence-arg
2384                (frob sequence-arg from-end)
2385                (with-array-data ((sequence sequence-arg :offset-var offset)
2386                                  (start start)
2387                                  (end end)
2388                                  :check-fill-pointer t)
2389                  (multiple-value-bind (f p)
2390                      (macrolet ((frob2 () `(if from-end
2391                                                (frob sequence t)
2392                                                (frob sequence nil))))
2393                        (typecase sequence
2394                          #!+sb-unicode
2395                          ((simple-array character (*)) (frob2))
2396                          ((simple-array base-char (*)) (frob2))
2397                          ,@(when bit-frob
2398                              `((simple-bit-vector
2399                                 (if (and (typep item 'bit)
2400                                          (eq #'identity key)
2401                                          (or (eq #'eq test)
2402                                              (eq #'eql test)
2403                                              (eq #'equal test)))
2404                                     (let ((p (%bit-position item sequence
2405                                                             from-end start end)))
2406                                       (if p
2407                                           (values item p)
2408                                           (values nil nil)))
2409                                     (vector*-frob sequence)))))
2410                          (t
2411                           (vector*-frob sequence))))
2412                    (declare (type (or index null) p))
2413                    (values f (and p (the index (- p offset)))))))))
2414   (defun %find-position (item sequence-arg from-end start end key test)
2415     (macrolet ((frob (sequence from-end)
2416                  `(%find-position item ,sequence
2417                                   ,from-end start end key test))
2418                (vector*-frob (sequence)
2419                  `(%find-position-vector-macro item ,sequence
2420                                                from-end start end key test)))
2421       (frobs t)))
2422   (defun %find-position-if (predicate sequence-arg from-end start end key)
2423     (macrolet ((frob (sequence from-end)
2424                  `(%find-position-if predicate ,sequence
2425                                      ,from-end start end key))
2426                (vector*-frob (sequence)
2427                  `(%find-position-if-vector-macro predicate ,sequence
2428                                                   from-end start end key)))
2429       (frobs)))
2430   (defun %find-position-if-not (predicate sequence-arg from-end start end key)
2431     (macrolet ((frob (sequence from-end)
2432                  `(%find-position-if-not predicate ,sequence
2433                                          ,from-end start end key))
2434                (vector*-frob (sequence)
2435                  `(%find-position-if-not-vector-macro predicate ,sequence
2436                                                   from-end start end key)))
2437       (frobs))))
2438
2439 (defun find
2440     (item sequence &rest args &key from-end (start 0) end key test test-not)
2441   (declare (truly-dynamic-extent args))
2442   (seq-dispatch sequence
2443     (nth-value 0 (%find-position
2444                   item sequence from-end start end
2445                   (effective-find-position-key key)
2446                   (effective-find-position-test test test-not)))
2447     (nth-value 0 (%find-position
2448                   item sequence from-end start end
2449                   (effective-find-position-key key)
2450                   (effective-find-position-test test test-not)))
2451     (apply #'sb!sequence:find item sequence args)))
2452 (defun position
2453     (item sequence &rest args &key from-end (start 0) end key test test-not)
2454   (declare (truly-dynamic-extent args))
2455   (seq-dispatch sequence
2456     (nth-value 1 (%find-position
2457                   item sequence from-end start end
2458                   (effective-find-position-key key)
2459                   (effective-find-position-test test test-not)))
2460     (nth-value 1 (%find-position
2461                   item sequence from-end start end
2462                   (effective-find-position-key key)
2463                   (effective-find-position-test test test-not)))
2464     (apply #'sb!sequence:position item sequence args)))
2465
2466 (defun find-if (predicate sequence &rest args &key from-end (start 0) end key)
2467   (declare (truly-dynamic-extent args))
2468   (seq-dispatch sequence
2469     (nth-value 0 (%find-position-if
2470                   (%coerce-callable-to-fun predicate)
2471                   sequence from-end start end
2472                   (effective-find-position-key key)))
2473     (nth-value 0 (%find-position-if
2474                   (%coerce-callable-to-fun predicate)
2475                   sequence from-end start end
2476                   (effective-find-position-key key)))
2477     (apply #'sb!sequence:find-if predicate sequence args)))
2478 (defun position-if
2479     (predicate sequence &rest args &key from-end (start 0) end key)
2480   (declare (truly-dynamic-extent args))
2481   (seq-dispatch sequence
2482     (nth-value 1 (%find-position-if
2483                   (%coerce-callable-to-fun predicate)
2484                   sequence from-end start end
2485                   (effective-find-position-key key)))
2486     (nth-value 1 (%find-position-if
2487                   (%coerce-callable-to-fun predicate)
2488                   sequence from-end start end
2489                   (effective-find-position-key key)))
2490     (apply #'sb!sequence:position-if predicate sequence args)))
2491
2492 (defun find-if-not
2493     (predicate sequence &rest args &key from-end (start 0) end key)
2494   (declare (truly-dynamic-extent args))
2495   (seq-dispatch sequence
2496     (nth-value 0 (%find-position-if-not
2497                   (%coerce-callable-to-fun predicate)
2498                   sequence from-end start end
2499                   (effective-find-position-key key)))
2500     (nth-value 0 (%find-position-if-not
2501                   (%coerce-callable-to-fun predicate)
2502                   sequence from-end start end
2503                   (effective-find-position-key key)))
2504     (apply #'sb!sequence:find-if-not predicate sequence args)))
2505 (defun position-if-not
2506     (predicate sequence &rest args &key from-end (start 0) end key)
2507   (declare (truly-dynamic-extent args))
2508   (seq-dispatch sequence
2509     (nth-value 1 (%find-position-if-not
2510                   (%coerce-callable-to-fun predicate)
2511                   sequence from-end start end
2512                   (effective-find-position-key key)))
2513     (nth-value 1 (%find-position-if-not
2514                   (%coerce-callable-to-fun predicate)
2515                   sequence from-end start end
2516                   (effective-find-position-key key)))
2517     (apply #'sb!sequence:position-if-not predicate sequence args)))
2518 \f
2519 ;;;; COUNT-IF, COUNT-IF-NOT, and COUNT
2520
2521 (eval-when (:compile-toplevel :execute)
2522
2523 (sb!xc:defmacro vector-count-if (notp from-end-p predicate sequence)
2524   (let ((next-index (if from-end-p '(1- index) '(1+ index)))
2525         (pred `(funcall ,predicate (apply-key key (aref ,sequence index)))))
2526     `(let ((%start ,(if from-end-p '(1- end) 'start))
2527            (%end ,(if from-end-p '(1- start) 'end)))
2528       (do ((index %start ,next-index)
2529            (count 0))
2530           ((= index (the fixnum %end)) count)
2531         (declare (fixnum index count))
2532         (,(if notp 'unless 'when) ,pred
2533           (setq count (1+ count)))))))
2534
2535 (sb!xc:defmacro list-count-if (notp from-end-p predicate sequence)
2536   (let ((pred `(funcall ,predicate (apply-key key (pop sequence)))))
2537     `(let ((%start ,(if from-end-p '(- length end) 'start))
2538            (%end ,(if from-end-p '(- length start) 'end))
2539            (sequence ,(if from-end-p '(reverse sequence) 'sequence)))
2540       (do ((sequence (nthcdr %start ,sequence))
2541            (index %start (1+ index))
2542            (count 0))
2543           ((or (= index (the fixnum %end)) (null sequence)) count)
2544         (declare (fixnum index count))
2545         (,(if notp 'unless 'when) ,pred
2546           (setq count (1+ count)))))))
2547
2548
2549 ) ; EVAL-WHEN
2550
2551 (define-sequence-traverser count-if
2552     (pred sequence &rest args &key from-end start end key)
2553   #!+sb-doc
2554   "Return the number of elements in SEQUENCE satisfying PRED(el)."
2555   (declare (type fixnum start)
2556            (truly-dynamic-extent args))
2557   (let ((pred (%coerce-callable-to-fun pred)))
2558     (seq-dispatch sequence
2559       (let ((end (or end length)))
2560         (declare (type index end))
2561         (if from-end
2562             (list-count-if nil t pred sequence)
2563             (list-count-if nil nil pred sequence)))
2564       (let ((end (or end length)))
2565         (declare (type index end))
2566         (if from-end
2567             (vector-count-if nil t pred sequence)
2568             (vector-count-if nil nil pred sequence)))
2569       (apply #'sb!sequence:count-if pred sequence args))))
2570
2571 (define-sequence-traverser count-if-not
2572     (pred sequence &rest args &key from-end start end key)
2573   #!+sb-doc
2574   "Return the number of elements in SEQUENCE not satisfying TEST(el)."
2575   (declare (type fixnum start)
2576            (truly-dynamic-extent args))
2577   (let ((pred (%coerce-callable-to-fun pred)))
2578     (seq-dispatch sequence
2579       (let ((end (or end length)))
2580         (declare (type index end))
2581         (if from-end
2582             (list-count-if t t pred sequence)
2583             (list-count-if t nil pred sequence)))
2584       (let ((end (or end length)))
2585         (declare (type index end))
2586         (if from-end
2587             (vector-count-if t t pred sequence)
2588             (vector-count-if t nil pred sequence)))
2589       (apply #'sb!sequence:count-if-not pred sequence args))))
2590
2591 (define-sequence-traverser count
2592     (item sequence &rest args &key from-end start end
2593           key (test #'eql test-p) (test-not nil test-not-p))
2594   #!+sb-doc
2595   "Return the number of elements in SEQUENCE satisfying a test with ITEM,
2596    which defaults to EQL."
2597   (declare (type fixnum start)
2598            (truly-dynamic-extent args))
2599   (when (and test-p test-not-p)
2600     ;; ANSI Common Lisp has left the behavior in this situation unspecified.
2601     ;; (CLHS 17.2.1)
2602     (error ":TEST and :TEST-NOT are both present."))
2603   (let ((%test (if test-not-p
2604                    (lambda (x)
2605                      (not (funcall test-not item x)))
2606                    (lambda (x)
2607                      (funcall test item x)))))
2608     (seq-dispatch sequence
2609       (let ((end (or end length)))
2610         (declare (type index end))
2611         (if from-end
2612             (list-count-if nil t %test sequence)
2613             (list-count-if nil nil %test sequence)))
2614       (let ((end (or end length)))
2615         (declare (type index end))
2616         (if from-end
2617             (vector-count-if nil t %test sequence)
2618             (vector-count-if nil nil %test sequence)))
2619       (apply #'sb!sequence:count item sequence args))))
2620 \f
2621 ;;;; MISMATCH
2622
2623 (eval-when (:compile-toplevel :execute)
2624
2625 (sb!xc:defmacro match-vars (&rest body)
2626   `(let ((inc (if from-end -1 1))
2627          (start1 (if from-end (1- (the fixnum end1)) start1))
2628          (start2 (if from-end (1- (the fixnum end2)) start2))
2629          (end1 (if from-end (1- (the fixnum start1)) end1))
2630          (end2 (if from-end (1- (the fixnum start2)) end2)))
2631      (declare (fixnum inc start1 start2 end1 end2))
2632      ,@body))
2633
2634 (sb!xc:defmacro matchify-list ((sequence start length end) &body body)
2635   (declare (ignore end)) ;; ### Should END be used below?
2636   `(let ((,sequence (if from-end
2637                         (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
2638                                 (reverse (the list ,sequence)))
2639                         (nthcdr ,start ,sequence))))
2640      (declare (type list ,sequence))
2641      ,@body))
2642
2643 ) ; EVAL-WHEN
2644
2645 (eval-when (:compile-toplevel :execute)
2646
2647 (sb!xc:defmacro if-mismatch (elt1 elt2)
2648   `(cond ((= (the fixnum index1) (the fixnum end1))
2649           (return (if (= (the fixnum index2) (the fixnum end2))
2650                       nil
2651                       (if from-end
2652                           (1+ (the fixnum index1))
2653                           (the fixnum index1)))))
2654          ((= (the fixnum index2) (the fixnum end2))
2655           (return (if from-end (1+ (the fixnum index1)) index1)))
2656          (test-not
2657           (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
2658               (return (if from-end (1+ (the fixnum index1)) index1))))
2659          (t (if (not (funcall test (apply-key key ,elt1)
2660                               (apply-key key ,elt2)))
2661                 (return (if from-end (1+ (the fixnum index1)) index1))))))
2662
2663 (sb!xc:defmacro mumble-mumble-mismatch ()
2664   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2665         (index2 start2 (+ index2 (the fixnum inc))))
2666        (())
2667      (declare (fixnum index1 index2))
2668      (if-mismatch (aref sequence1 index1) (aref sequence2 index2))))
2669
2670 (sb!xc:defmacro mumble-list-mismatch ()
2671   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2672         (index2 start2 (+ index2 (the fixnum inc))))
2673        (())
2674      (declare (fixnum index1 index2))
2675      (if-mismatch (aref sequence1 index1) (pop sequence2))))
2676 \f
2677 (sb!xc:defmacro list-mumble-mismatch ()
2678   `(do ((index1 start1 (+ index1 (the fixnum inc)))
2679         (index2 start2 (+ index2 (the fixnum inc))))
2680        (())
2681      (declare (fixnum index1 index2))
2682      (if-mismatch (pop sequence1) (aref sequence2 index2))))
2683
2684 (sb!xc:defmacro list-list-mismatch ()
2685   `(do ((sequence1 sequence1)
2686         (sequence2 sequence2)
2687         (index1 start1 (+ index1 (the fixnum inc)))
2688         (index2 start2 (+ index2 (the fixnum inc))))
2689        (())
2690      (declare (fixnum index1 index2))
2691      (if-mismatch (pop sequence1) (pop sequence2))))
2692
2693 ) ; EVAL-WHEN
2694
2695 (define-sequence-traverser mismatch
2696     (sequence1 sequence2 &rest args &key from-end test test-not
2697      start1 end1 start2 end2 key)
2698   #!+sb-doc
2699   "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
2700    element-wise. If they are of equal length and match in every element, the
2701    result is NIL. Otherwise, the result is a non-negative integer, the index
2702    within SEQUENCE1 of the leftmost position at which they fail to match; or,
2703    if one is shorter than and a matching prefix of the other, the index within
2704    SEQUENCE1 beyond the last position tested is returned. If a non-NIL
2705    :FROM-END argument is given, then one plus the index of the rightmost
2706    position in which the sequences differ is returned."
2707   (declare (type fixnum start1 start2))
2708   (declare (truly-dynamic-extent args))
2709   (seq-dispatch sequence1
2710     (seq-dispatch sequence2
2711       (let ((end1 (or end1 length1))
2712             (end2 (or end2 length2)))
2713         (declare (type index end1 end2))
2714         (match-vars
2715          (matchify-list (sequence1 start1 length1 end1)
2716            (matchify-list (sequence2 start2 length2 end2)
2717              (list-list-mismatch)))))
2718       (let ((end1 (or end1 length1))
2719             (end2 (or end2 length2)))
2720         (declare (type index end1 end2))
2721         (match-vars
2722          (matchify-list (sequence1 start1 length1 end1)
2723            (list-mumble-mismatch))))
2724       (apply #'sb!sequence:mismatch sequence1 sequence2 args))
2725     (seq-dispatch sequence2
2726       (let ((end1 (or end1 length1))
2727             (end2 (or end2 length2)))
2728         (declare (type index end1 end2))
2729         (match-vars
2730          (matchify-list (sequence2 start2 length2 end2)
2731            (mumble-list-mismatch))))
2732       (let ((end1 (or end1 length1))
2733             (end2 (or end2 length2)))
2734         (declare (type index end1 end2))
2735         (match-vars
2736          (mumble-mumble-mismatch)))
2737       (apply #'sb!sequence:mismatch sequence1 sequence2 args))
2738     (apply #'sb!sequence:mismatch sequence1 sequence2 args)))
2739
2740 \f
2741 ;;; search comparison functions
2742
2743 (eval-when (:compile-toplevel :execute)
2744
2745 ;;; Compare two elements and return if they don't match.
2746 (sb!xc:defmacro compare-elements (elt1 elt2)
2747   `(if test-not
2748        (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
2749            (return nil)
2750            t)
2751        (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
2752            (return nil)
2753            t)))
2754
2755 (sb!xc:defmacro search-compare-list-list (main sub)
2756   `(do ((main ,main (cdr main))
2757         (jndex start1 (1+ jndex))
2758         (sub (nthcdr start1 ,sub) (cdr sub)))
2759        ((or (endp main) (endp sub) (<= end1 jndex))
2760         t)
2761      (declare (type (integer 0) jndex))
2762      (compare-elements (car sub) (car main))))
2763
2764 (sb!xc:defmacro search-compare-list-vector (main sub)
2765   `(do ((main ,main (cdr main))
2766         (index start1 (1+ index)))
2767        ((or (endp main) (= index end1)) t)
2768      (compare-elements (aref ,sub index) (car main))))
2769
2770 (sb!xc:defmacro search-compare-vector-list (main sub index)
2771   `(do ((sub (nthcdr start1 ,sub) (cdr sub))
2772         (jndex start1 (1+ jndex))
2773         (index ,index (1+ index)))
2774        ((or (<= end1 jndex) (endp sub)) t)
2775      (declare (type (integer 0) jndex))
2776      (compare-elements (car sub) (aref ,main index))))
2777
2778 (sb!xc:defmacro search-compare-vector-vector (main sub index)
2779   `(do ((index ,index (1+ index))
2780         (sub-index start1 (1+ sub-index)))
2781        ((= sub-index end1) t)
2782      (compare-elements (aref ,sub sub-index) (aref ,main index))))
2783
2784 (sb!xc:defmacro search-compare (main-type main sub index)
2785   (if (eq main-type 'list)
2786       `(seq-dispatch ,sub
2787          (search-compare-list-list ,main ,sub)
2788          (search-compare-list-vector ,main ,sub)
2789          ;; KLUDGE: just hack it together so that it works
2790          (return-from search (apply #'sb!sequence:search sequence1 sequence2 args)))
2791       `(seq-dispatch ,sub
2792          (search-compare-vector-list ,main ,sub ,index)
2793          (search-compare-vector-vector ,main ,sub ,index)
2794          (return-from search (apply #'sb!sequence:search sequence1 sequence2 args)))))
2795
2796 ) ; EVAL-WHEN
2797 \f
2798 ;;;; SEARCH
2799
2800 (eval-when (:compile-toplevel :execute)
2801
2802 (sb!xc:defmacro list-search (main sub)
2803   `(do ((main (nthcdr start2 ,main) (cdr main))
2804         (index2 start2 (1+ index2))
2805         (terminus (- end2 (the (integer 0) (- end1 start1))))
2806         (last-match ()))
2807        ((> index2 terminus) last-match)
2808      (declare (type (integer 0) index2))
2809      (if (search-compare list main ,sub index2)
2810          (if from-end
2811              (setq last-match index2)
2812              (return index2)))))
2813
2814 (sb!xc:defmacro vector-search (main sub)
2815   `(do ((index2 start2 (1+ index2))
2816         (terminus (- end2 (the (integer 0) (- end1 start1))))
2817         (last-match ()))
2818        ((> index2 terminus) last-match)
2819      (declare (type (integer 0) index2))
2820      (if (search-compare vector ,main ,sub index2)
2821          (if from-end
2822              (setq last-match index2)
2823              (return index2)))))
2824
2825 ) ; EVAL-WHEN
2826
2827 (define-sequence-traverser search
2828     (sequence1 sequence2 &rest args &key
2829      from-end test test-not start1 end1 start2 end2 key)
2830   (declare (type fixnum start1 start2)
2831            (truly-dynamic-extent args))
2832   (seq-dispatch sequence2
2833     (let ((end1 (or end1 length1))
2834           (end2 (or end2 length2)))
2835       (declare (type index end1 end2))
2836       (list-search sequence2 sequence1))
2837     (let ((end1 (or end1 length1))
2838           (end2 (or end2 length2)))
2839       (declare (type index end1 end2))
2840       (vector-search sequence2 sequence1))
2841     (apply #'sb!sequence:search sequence1 sequence2 args)))
2842
2843 ;;; FIXME: this was originally in array.lisp; it might be better to
2844 ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in
2845 ;;; a new early-seq.lisp file.
2846 (defun fill-data-vector (vector dimensions initial-contents)
2847   (declare (explicit-check))
2848   (let ((index 0))
2849     (labels ((frob (axis dims contents)
2850                (cond ((null dims)
2851                       (setf (aref vector index) contents)
2852                       (incf index))
2853                      (t
2854                       (unless (typep contents 'sequence)
2855                         (error "malformed :INITIAL-CONTENTS: ~S is not a ~
2856                                 sequence, but ~W more layer~:P needed."
2857                                contents
2858                                (- (length dimensions) axis)))
2859                       (unless (= (length contents) (car dims))
2860                         (error "malformed :INITIAL-CONTENTS: Dimension of ~
2861                                 axis ~W is ~W, but ~S is ~W long."
2862                                axis (car dims) contents (length contents)))
2863                       (sb!sequence:dosequence (content contents)
2864                         (frob (1+ axis) (cdr dims) content))))))
2865       (frob 0 dimensions initial-contents))))