src/code/seq.lisp

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