Make sure quantifiers don't cons

[sbcl.git] / src / code / seq.lisp

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 6ff9ebc..e6abb66 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -20,6 +20,12 @@
 \f
 ;;;; utilities
 
 \f
 ;;;; utilities
 

+(defun %check-generic-sequence-bounds (seq start end)
+  (let ((length (sb!sequence:length seq)))
+    (if (<= 0 start (or end length) length)
+        (or end length)
+        (sequence-bounding-indices-bad-error seq start end))))
+

 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 (defparameter *sequence-keyword-info*
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 (defparameter *sequence-keyword-info*

@@ -33,31 +39,34 @@
                           0
                           (1- most-positive-fixnum))))
            (mod #.sb!xc:most-positive-fixnum))
                           0
                           (1- most-positive-fixnum))))
            (mod #.sb!xc:most-positive-fixnum))

+    ;; Entries for {start,end}{,1,2}

     ,@(mapcan (lambda (names)
                 (destructuring-bind (start end length sequence) names
                   (list
                    `(,start
                      0
                      nil
     ,@(mapcan (lambda (names)
                 (destructuring-bind (start end length sequence) names
                   (list
                    `(,start
                      0
                      nil

-                     (if (<= 0 ,start ,length)
+                     ;; Only evaluate LENGTH (which may be expensive)
+                     ;; if START is non-NIL.
+                     (if (or (zerop ,start) (<= 0 ,start ,length))

                          ,start
                          ,start

-                         (signal-bounding-indices-bad-error ,sequence
-                                                            ,start ,end))
+                         (sequence-bounding-indices-bad-error ,sequence ,start ,end))

                      index)
                      index)

-                  `(,end
-                    nil
-                    nil
-                    (if (or (null ,end) (<= ,start ,end ,length))
-                        ;; Defaulting of NIL is done inside the
-                        ;; bodies, for ease of sharing with compiler
-                        ;; transforms.
-                        ;;
-                        ;; FIXME: defend against non-number non-NIL
-                        ;; stuff?
-                        ,end
-                        (signal-bounding-indices-bad-error ,sequence
-                                                           ,start ,end))
-                    (or null index)))))
+                   `(,end
+                     nil
+                     nil
+                     ;; Only evaluate LENGTH (which may be expensive)
+                     ;; if END is non-NIL.
+                     (if (or (null ,end) (<= ,start ,end ,length))
+                         ;; Defaulting of NIL is done inside the
+                         ;; bodies, for ease of sharing with compiler
+                         ;; transforms.
+                         ;;
+                         ;; FIXME: defend against non-number non-NIL
+                         ;; stuff?
+                         ,end
+                         (sequence-bounding-indices-bad-error ,sequence ,start ,end))
+                     (or null index)))))

               '((start end length sequence)
                 (start1 end1 length1 sequence1)
                 (start2 end2 length2 sequence2)))
               '((start end length sequence)
                 (start1 end1 length1 sequence1)
                 (start2 end2 length2 sequence2)))

@@ -72,44 +81,52 @@
     (test-not nil
               nil
               (and test-not (%coerce-callable-to-fun test-not))
     (test-not nil
               nil
               (and test-not (%coerce-callable-to-fun test-not))

-              (or null function))
-    ))
+              (or null function))))

 
 (sb!xc:defmacro define-sequence-traverser (name args &body body)
   (multiple-value-bind (body declarations docstring)
       (parse-body body :doc-string-allowed t)
 
 (sb!xc:defmacro define-sequence-traverser (name args &body body)
   (multiple-value-bind (body declarations docstring)
       (parse-body body :doc-string-allowed t)

-    (collect ((new-args) (new-declarations) (adjustments))
+    (collect ((new-args)
+              (new-declarations)
+              ;; Things which are definitely used in any code path.
+              (rebindings/eager)
+              ;; Things which may be used/are only used in certain
+              ;; code paths (e.g. length).
+              (rebindings/lazy))

       (dolist (arg args)
         (case arg
           ;; FIXME: make this robust.  And clean.
       (dolist (arg args)
         (case arg
           ;; FIXME: make this robust.  And clean.

-          ((sequence)
-           (new-args arg)
-           (adjustments '(length (length sequence)))
-           (new-declarations '(type index length)))
-          ((sequence1)
-           (new-args arg)
-           (adjustments '(length1 (length sequence1)))
-           (new-declarations '(type index length1)))
-          ((sequence2)
-           (new-args arg)
-           (adjustments '(length2 (length sequence2)))
-           (new-declarations '(type index length2)))
+          ((sequence sequence1 sequence2)
+           (let* ((length-var (ecase arg
+                                (sequence  'length)
+                                (sequence1 'length1)
+                                (sequence2 'length2)))
+                  (cache-var (symbolicate length-var '#:-cache)))
+             (new-args arg)
+             (rebindings/eager `(,cache-var nil))
+             (rebindings/lazy
+              `(,length-var (truly-the
+                             index
+                             (or ,cache-var (setf ,cache-var (length ,arg))))))))

           ((function predicate)
            (new-args arg)
           ((function predicate)
            (new-args arg)

-           (adjustments `(,arg (%coerce-callable-to-fun ,arg))))
-          (t (let ((info (cdr (assoc arg *sequence-keyword-info*))))
-               (cond (info
-                      (destructuring-bind (default supplied-p adjuster type) info
-                        (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
-                        (adjustments `(,arg ,adjuster))
-                        (new-declarations `(type ,type ,arg))))
-                     (t (new-args arg)))))))
+           (rebindings/eager `(,arg (%coerce-callable-to-fun ,arg))))
+          (t
+           (let ((info (cdr (assoc arg *sequence-keyword-info*))))
+             (cond (info
+                    (destructuring-bind (default supplied-p adjuster type) info
+                      (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
+                      (rebindings/eager `(,arg ,adjuster))
+                      (new-declarations `(type ,type ,arg))))
+                   (t (new-args arg)))))))

       `(defun ,name ,(new-args)
          ,@(when docstring (list docstring))
          ,@declarations
       `(defun ,name ,(new-args)
          ,@(when docstring (list docstring))
          ,@declarations

-         (let* (,@(adjustments))
-           (declare ,@(new-declarations))
-           ,@body)))))
+         (symbol-macrolet (,@(rebindings/lazy))
+           (let* (,@(rebindings/eager))
+             (declare ,@(new-declarations))
+             ,@body
+             ))))))

 
 ;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE.
 ;;;
 
 ;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE.
 ;;;

@@ -198,6 +215,7 @@
              "Vector length (~W) doesn't match declared length (~W)."
              :format-arguments (list actual-length declared-length))))
   vector)
              "Vector length (~W) doesn't match declared length (~W)."
              :format-arguments (list actual-length declared-length))))
   vector)

+

 (defun sequence-of-checked-length-given-type (sequence result-type)
   (let ((ctype (specifier-type result-type)))
     (if (not (array-type-p ctype))
 (defun sequence-of-checked-length-given-type (sequence result-type)
   (let ((ctype (specifier-type result-type)))
     (if (not (array-type-p ctype))

@@ -220,14 +238,44 @@
                               ;; This seems silly, is there something better?
                               '(integer 0 (0))))))
 
                               ;; This seems silly, is there something better?
                               '(integer 0 (0))))))
 

-(defun signal-bounding-indices-bad-error (sequence start end)
-  (let ((length (length sequence)))
+(declaim (ftype (function (t t t) nil) sequence-bounding-indices-bad-error))
+(defun sequence-bounding-indices-bad-error (sequence start end)
+  (let ((size (length sequence)))

     (error 'bounding-indices-bad-error
            :datum (cons start end)
     (error 'bounding-indices-bad-error
            :datum (cons start end)

-           :expected-type `(cons (integer 0 ,length)
-                                 (or null (integer ,start ,length)))
+           :expected-type `(cons (integer 0 ,size)
+                                 (integer ,start ,size))

            :object sequence)))
            :object sequence)))

+
+(declaim (ftype (function (t t t) nil) array-bounding-indices-bad-error))
+(defun array-bounding-indices-bad-error (array start end)
+  (let ((size (array-total-size array)))
+    (error 'bounding-indices-bad-error
+           :datum (cons start end)
+           :expected-type `(cons (integer 0 ,size)
+                                 (integer ,start ,size))
+           :object array)))
+
+(declaim (ftype (function (t) nil) circular-list-error))
+(defun circular-list-error (list)
+  (let ((*print-circle* t))
+    (error 'simple-type-error
+           :format-control "List is circular:~%  ~S"
+           :format-arguments (list list)
+           :datum list
+           :type '(and list (satisfies list-length)))))
+

 \f
 \f

+
+(defun emptyp (sequence)
+  #!+sb-doc
+  "Returns T if SEQUENCE is an empty sequence and NIL
+   otherwise. Signals an error if SEQUENCE is not a sequence."
+  (seq-dispatch sequence
+                (null sequence)
+                (zerop (length sequence))
+                (sb!sequence:emptyp sequence)))
+

 (defun elt (sequence index)
   #!+sb-doc "Return the element of SEQUENCE specified by INDEX."
   (seq-dispatch sequence
 (defun elt (sequence index)
   #!+sb-doc "Return the element of SEQUENCE specified by INDEX."
   (seq-dispatch sequence

@@ -272,20 +320,22 @@
   "Return a sequence of the given TYPE and LENGTH, with elements initialized
   to INITIAL-ELEMENT."
   (declare (fixnum length))
   "Return a sequence of the given TYPE and LENGTH, with elements initialized
   to INITIAL-ELEMENT."
   (declare (fixnum length))

-  (let* ((adjusted-type
-          (typecase type
+  (let* ((expanded-type (typexpand type))
+         (adjusted-type
+          (typecase expanded-type

             (atom (cond
             (atom (cond

-                    ((eq type 'string) '(vector character))
-                    ((eq type 'simple-string) '(simple-array character (*)))
+                    ((eq expanded-type 'string) '(vector character))
+                    ((eq expanded-type 'simple-string)
+                     '(simple-array character (*)))

                     (t type)))
             (cons (cond
                     (t type)))
             (cons (cond

-                    ((eq (car type) 'string) `(vector character ,@(cdr type)))
-                    ((eq (car type) 'simple-string)
-                     `(simple-array character ,(if (cdr type)
-                                                   (cdr type)
+                    ((eq (car expanded-type) 'string)
+                     `(vector character ,@(cdr expanded-type)))
+                    ((eq (car expanded-type) 'simple-string)
+                     `(simple-array character ,(if (cdr expanded-type)
+                                                   (cdr expanded-type)

                                                    '(*))))
                                                    '(*))))

-                    (t type)))
-            (t type)))
+                    (t type)))))

          (type (specifier-type adjusted-type)))
     (cond ((csubtypep type (specifier-type 'list))
            (cond
          (type (specifier-type adjusted-type)))
     (cond ((csubtypep type (specifier-type 'list))
            (cond

@@ -348,44 +398,76 @@
 \f
 ;;;; SUBSEQ
 ;;;;
 \f
 ;;;; SUBSEQ
 ;;;;

+
+(define-array-dispatch vector-subseq-dispatch (array start end)
+  (declare (optimize speed (safety 0)))
+  (declare (type index start end))
+  (subseq array start end))
+

 ;;;; The support routines for SUBSEQ are used by compiler transforms,
 ;;;; so we worry about dealing with END being supplied or defaulting
 ;;;; to NIL at this level.
 
 ;;;; The support routines for SUBSEQ are used by compiler transforms,
 ;;;; so we worry about dealing with END being supplied or defaulting
 ;;;; to NIL at this level.
 

-(defun vector-subseq* (sequence start &optional end)
+(defun vector-subseq* (sequence start end)

   (declare (type vector sequence))
   (declare (type vector sequence))

-  (declare (type index start))
-  (declare (type (or null index) end))
-  (when (null end)
-    (setf end (length sequence)))
-  (unless (<= 0 start end (length sequence))
-    (signal-bounding-indices-bad-error sequence start end))
-  (do ((old-index start (1+ old-index))
-       (new-index 0 (1+ new-index))
-       (copy (%make-sequence-like sequence (- end start))))
-      ((= old-index end) copy)
-    (declare (fixnum old-index new-index))
-    (setf (aref copy new-index)
-          (aref sequence old-index))))
-
-(defun list-subseq* (sequence start &optional end)
-  (declare (type list sequence))
-  ;; the INDEX declaration isn't actually mandatory, but it's true for
-  ;; all practical purposes.
-  (declare (type index start))
-  (declare (type (or null index) end))
-  (do ((list sequence (cdr list))
-       (index 0 (1+ index))
-       (result nil))
-      (nil)
-    (cond
-      ((null list) (if (or (and end (> end index))
-                           (< index start))
-                       (signal-bounding-indices-bad-error sequence start end)
-                       (return (nreverse result))))
-      ((< index start) nil)
-      ((and end (= index end)) (return (nreverse result)))
-      (t (push (car list) result)))))
+  (declare (type index start)
+           (type (or null index) end)
+           (optimize speed))
+  (with-array-data ((data sequence)
+                    (start start)
+                    (end end)
+                    :check-fill-pointer t
+                    :force-inline t)
+    (vector-subseq-dispatch data start end)))
+
+(defun list-subseq* (sequence start end)
+  (declare (type list sequence)
+           (type unsigned-byte start)
+           (type (or null unsigned-byte) end))
+  (flet ((oops ()
+           (sequence-bounding-indices-bad-error sequence start end)))
+    (let ((pointer sequence))
+      (unless (zerop start)
+        ;; If START > 0 the list cannot be empty. So CDR down to
+        ;; it START-1 times, check that we still have something, then
+        ;; CDR the final time.
+        ;;
+        ;; If START was zero, the list may be empty if END is NIL or
+        ;; also zero.
+        (when (> start 1)
+          (setf pointer (nthcdr (1- start) pointer)))
+        (if pointer
+            (pop pointer)
+            (oops)))
+      (if end
+          (let ((n (- end start)))
+            (declare (integer n))
+            (when (minusp n)
+              (oops))
+            (when (plusp n)
+              (let* ((head (list nil))
+                     (tail head))
+                (macrolet ((pop-one ()
+                             `(let ((tmp (list (pop pointer))))
+                                (setf (cdr tail) tmp
+                                      tail tmp))))
+                  ;; Bignum case
+                  (loop until (fixnump n)
+                        do (pop-one)
+                           (decf n))
+                  ;; Fixnum case, but leave last element, so we should
+                  ;; still have something left in the sequence.
+                  (let ((m (1- n)))
+                    (declare (fixnum m))
+                    (loop repeat m
+                          do (pop-one)))
+                  (unless pointer
+                    (oops))
+                  ;; OK, pop the last one.
+                  (pop-one)
+                  (cdr head)))))
+            (loop while pointer
+                  collect (pop pointer))))))

 
 (defun subseq (sequence start &optional end)
   #!+sb-doc
 
 (defun subseq (sequence start &optional end)
   #!+sb-doc

@@ -398,84 +480,91 @@
 \f
 ;;;; COPY-SEQ
 
 \f
 ;;;; COPY-SEQ
 

-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-copy-seq (sequence)
-  `(let ((length (length (the vector ,sequence))))
-     (declare (fixnum length))
-     (do ((index 0 (1+ index))
-          (copy (%make-sequence-like ,sequence length)))
-         ((= index length) copy)
-       (declare (fixnum index))
-       (setf (aref copy index) (aref ,sequence index)))))
-
-(sb!xc:defmacro list-copy-seq (list)
-  `(if (atom ,list) '()
-       (let ((result (cons (car ,list) '()) ))
-         (do ((x (cdr ,list) (cdr x))
-              (splice result
-                      (cdr (rplacd splice (cons (car x) '() ))) ))
-             ((atom x) (unless (null x)
-                               (rplacd splice x))
-                       result)))))
-
-) ; EVAL-WHEN
-

 (defun copy-seq (sequence)
   #!+sb-doc "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
   (seq-dispatch sequence
     (list-copy-seq* sequence)
 (defun copy-seq (sequence)
   #!+sb-doc "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
   (seq-dispatch sequence
     (list-copy-seq* sequence)

-    (vector-copy-seq* sequence)
+    (vector-subseq* sequence 0 nil)

     (sb!sequence:copy-seq sequence)))
 
     (sb!sequence:copy-seq sequence)))
 

-;;; internal frobs
-

 (defun list-copy-seq* (sequence)
 (defun list-copy-seq* (sequence)

-  (list-copy-seq sequence))
-
-(defun vector-copy-seq* (sequence)
-  (declare (type vector sequence))
-  (vector-copy-seq sequence))
+  (!copy-list-macro sequence :check-proper-list t))

 \f
 ;;;; FILL
 
 \f
 ;;;; FILL
 

-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-fill (sequence item start end)
-  `(do ((index ,start (1+ index)))
-       ((= index (the fixnum ,end)) ,sequence)
-     (declare (fixnum index))
-     (setf (aref ,sequence index) ,item)))
-
-(sb!xc:defmacro list-fill (sequence item start end)
-  `(do ((current (nthcdr ,start ,sequence) (cdr current))
-        (index ,start (1+ index)))
-       ((or (atom current) (and end (= index (the fixnum ,end))))
-        sequence)
-     (declare (fixnum index))
-     (rplaca current ,item)))
-
-) ; EVAL-WHEN
-
-;;; The support routines for FILL are used by compiler transforms, so we
-;;; worry about dealing with END being supplied or defaulting to NIL
-;;; at this level.
-

 (defun list-fill* (sequence item start end)
 (defun list-fill* (sequence item start end)

-  (declare (list sequence))
-  (list-fill sequence item start end))
+  (declare (type list sequence)
+           (type unsigned-byte start)
+           (type (or null unsigned-byte) end))
+  (flet ((oops ()
+           (sequence-bounding-indices-bad-error sequence start end)))
+    (let ((pointer sequence))
+      (unless (zerop start)
+        ;; If START > 0 the list cannot be empty. So CDR down to it
+        ;; START-1 times, check that we still have something, then CDR
+        ;; the final time.
+        ;;
+        ;; If START was zero, the list may be empty if END is NIL or
+        ;; also zero.
+        (unless (= start 1)
+          (setf pointer (nthcdr (1- start) pointer)))
+        (if pointer
+            (pop pointer)
+            (oops)))
+      (if end
+          (let ((n (- end start)))
+            (declare (integer n))
+            (when (minusp n)
+              (oops))
+            (when (plusp n)
+              (loop repeat n
+                    do (setf pointer (cdr (rplaca pointer item))))))
+          (loop while pointer
+                do (setf pointer (cdr (rplaca pointer item)))))))
+  sequence)

 
 (defun vector-fill* (sequence item start end)
 
 (defun vector-fill* (sequence item start end)

-  (declare (vector sequence))
-  (when (null end) (setq end (length sequence)))
-  (vector-fill sequence item start end))
-
-(define-sequence-traverser fill (sequence item &rest args &key start end)
-  #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM."
+  (with-array-data ((data sequence)
+                    (start start)
+                    (end end)
+                    :force-inline t
+                    :check-fill-pointer t)
+    (let ((setter (!find-data-vector-setter data)))
+      (declare (optimize (speed 3) (safety 0)))
+      (do ((index start (1+ index)))
+          ((= index end) sequence)
+        (declare (index index))
+        (funcall setter data index item)))))
+
+(defun string-fill* (sequence item start end)
+  (declare (string sequence))
+  (with-array-data ((data sequence)
+                    (start start)
+                    (end end)
+                    :force-inline t
+                    :check-fill-pointer t)
+    ;; DEFTRANSFORM for FILL will turn these into
+    ;; calls to UB*-BASH-FILL.
+    (etypecase data
+      #!+sb-unicode
+      ((simple-array character (*))
+       (let ((item (locally (declare (optimize (safety 3)))
+                     (the character item))))
+         (fill data item :start start :end end)))
+      ((simple-array base-char (*))
+       (let ((item (locally (declare (optimize (safety 3)))
+                     (the base-char item))))
+         (fill data item :start start :end end))))))
+
+(defun fill (sequence item &key (start 0) end)
+  #!+sb-doc
+  "Replace the specified elements of SEQUENCE with ITEM."

   (seq-dispatch sequence
   (seq-dispatch sequence

-    (list-fill* sequence item start end)
-    (vector-fill* sequence item start end)
-    (apply #'sb!sequence:fill sequence item args)))
+   (list-fill* sequence item start end)
+   (vector-fill* sequence item start end)
+   (sb!sequence:fill sequence item
+                     :start start
+                     :end (%check-generic-sequence-bounds sequence start end))))

 \f
 ;;;; REPLACE
 
 \f
 ;;;; REPLACE
 

@@ -601,9 +690,14 @@
 (define-sequence-traverser replace
     (sequence1 sequence2 &rest args &key start1 end1 start2 end2)
   #!+sb-doc
 (define-sequence-traverser replace
     (sequence1 sequence2 &rest args &key start1 end1 start2 end2)
   #!+sb-doc

-  "The target sequence is destructively modified by copying successive
-   elements into it from the source sequence."
-  (declare (dynamic-extent args))
+  "Destructively modifies SEQUENCE1 by copying successive elements
+into it from the SEQUENCE2.
+
+Elements are copied to the subseqeuence bounded by START1 and END1,
+from the subsequence bounded by START2 and END2. If these subsequences
+are not of the same length, then the shorter length determines how
+many elements are copied."
+  (declare (truly-dynamic-extent args))

   (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or
          ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind
          ;; these things here so that legacy code gets the names it's
   (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or
          ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind
          ;; these things here so that legacy code gets the names it's

@@ -704,114 +798,120 @@
 \f
 ;;;; CONCATENATE
 
 \f
 ;;;; CONCATENATE
 

-(defmacro sb!sequence:dosequence ((e sequence &optional return) &body body)
+(defmacro sb!sequence:dosequence ((element sequence &optional return) &body body)
+  #!+sb-doc
+  "Executes BODY with ELEMENT subsequently bound to each element of
+  SEQUENCE, then returns RETURN."

   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
     (let ((s sequence)
           (sequence (gensym "SEQUENCE")))
       `(block nil
         (let ((,sequence ,s))
           (seq-dispatch ,sequence
   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
     (let ((s sequence)
           (sequence (gensym "SEQUENCE")))
       `(block nil
         (let ((,sequence ,s))
           (seq-dispatch ,sequence

-            (dolist (,e ,sequence ,return) ,@body)
-            (dovector (,e ,sequence ,return) ,@body)
+            (dolist (,element ,sequence ,return) ,@body)
+            (do-vector-data (,element ,sequence ,return) ,@body)

             (multiple-value-bind (state limit from-end step endp elt)
                 (sb!sequence:make-sequence-iterator ,sequence)
               (do ((state state (funcall step ,sequence state from-end)))
                   ((funcall endp ,sequence state limit from-end)
             (multiple-value-bind (state limit from-end step endp elt)
                 (sb!sequence:make-sequence-iterator ,sequence)
               (do ((state state (funcall step ,sequence state from-end)))
                   ((funcall endp ,sequence state limit from-end)

-                   (let ((,e nil))
+                   (let ((,element nil))

                      ,@(filter-dolist-declarations decls)
                      ,@(filter-dolist-declarations decls)

-                     ,e
+                     ,element

                      ,return))
                      ,return))

-                (let ((,e (funcall elt ,sequence state)))
+                (let ((,element (funcall elt ,sequence state)))

                   ,@decls
                   (tagbody
                      ,@forms))))))))))
                   ,@decls
                   (tagbody
                      ,@forms))))))))))

-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro concatenate-to-list (sequences)
-  `(let ((result (list nil)))
-     (do ((sequences ,sequences (cdr sequences))
-          (splice result))
-         ((null sequences) (cdr result))
-       (let ((sequence (car sequences)))
-         (sb!sequence:dosequence (e sequence)
-           (setq splice (cdr (rplacd splice (list e)))))))))
-
-(sb!xc:defmacro concatenate-to-mumble (output-type-spec sequences)
-  `(do ((seqs ,sequences (cdr seqs))
-        (total-length 0)
-        (lengths ()))
-       ((null seqs)
-        (do ((sequences ,sequences (cdr sequences))
-             (lengths lengths (cdr lengths))
-             (index 0)
-             (result (make-sequence ,output-type-spec total-length)))
-            ((= index total-length) result)
-          (declare (fixnum index))
-          (let ((sequence (car sequences)))
-            (sb!sequence:dosequence (e sequence)
-              (setf (aref result index) e)
-              (incf index)))))
-     (let ((length (length (car seqs))))
-       (declare (fixnum length))
-       (setq lengths (nconc lengths (list length)))
-       (setq total-length (+ total-length length)))))
-
-) ; EVAL-WHEN

 \f
 (defun concatenate (output-type-spec &rest sequences)
   #!+sb-doc
   "Return a new sequence of all the argument sequences concatenated together
   which shares no structure with the original argument sequences of the
   specified OUTPUT-TYPE-SPEC."
 \f
 (defun concatenate (output-type-spec &rest sequences)
   #!+sb-doc
   "Return a new sequence of all the argument sequences concatenated together
   which shares no structure with the original argument sequences of the
   specified OUTPUT-TYPE-SPEC."

-  (let ((type (specifier-type output-type-spec)))
-  (cond
-    ((csubtypep type (specifier-type 'list))
-     (cond
-       ((type= type (specifier-type 'list))
-        (apply #'concat-to-list* sequences))
-       ((eq type *empty-type*)
-        (bad-sequence-type-error nil))
-       ((type= type (specifier-type 'null))
-        (if (every (lambda (x) (or (null x)
-                                   (and (vectorp x) (= (length x) 0))))
-                   sequences)
-            'nil
-            (sequence-type-length-mismatch-error
-             type
-             ;; FIXME: circular list issues.
-             (reduce #'+ sequences :key #'length))))
-       ((cons-type-p type)
-        (multiple-value-bind (min exactp)
-            (sb!kernel::cons-type-length-info type)
-          (let ((length (reduce #'+ sequences :key #'length)))
-            (if exactp
-                (unless (= length min)
-                  (sequence-type-length-mismatch-error type length))
-                (unless (>= length min)
-                  (sequence-type-length-mismatch-error type length)))
-            (apply #'concat-to-list* sequences))))
-       (t (sequence-type-too-hairy (type-specifier type)))))
-    ((csubtypep type (specifier-type 'vector))
-     (apply #'concat-to-simple* output-type-spec sequences))
-    ((and (csubtypep type (specifier-type 'sequence))
-          (find-class output-type-spec nil))
-     (coerce (apply #'concat-to-simple* 'vector sequences) output-type-spec))
-    (t
-     (bad-sequence-type-error output-type-spec)))))
-
-;;; internal frobs
-;;; FIXME: These are weird. They're never called anywhere except in
-;;; CONCATENATE. It seems to me that the macros ought to just
-;;; be expanded directly in CONCATENATE, or in CONCATENATE-STRING
-;;; and CONCATENATE-LIST variants. Failing that, these ought to be local
-;;; functions (FLET).
-(defun concat-to-list* (&rest sequences)
-  (concatenate-to-list sequences))
-(defun concat-to-simple* (type &rest sequences)
-  (concatenate-to-mumble type sequences))
+  (flet ((concat-to-list* (sequences)
+           (let ((result (list nil)))
+             (do ((sequences sequences (cdr sequences))
+                  (splice result))
+                 ((null sequences) (cdr result))
+               (let ((sequence (car sequences)))
+                 (sb!sequence:dosequence (e sequence)
+                   (setq splice (cdr (rplacd splice (list e)))))))))
+         (concat-to-simple* (type-spec sequences)
+           (do ((seqs sequences (cdr seqs))
+                (total-length 0)
+                (lengths ()))
+               ((null seqs)
+                (do ((sequences sequences (cdr sequences))
+                     (lengths lengths (cdr lengths))
+                     (index 0)
+                     (result (make-sequence type-spec total-length)))
+                    ((= index total-length) result)
+                  (declare (fixnum index))
+                  (let ((sequence (car sequences)))
+                    (sb!sequence:dosequence (e sequence)
+                      (setf (aref result index) e)
+                      (incf index)))))
+             (let ((length (length (car seqs))))
+               (declare (fixnum length))
+               (setq lengths (nconc lengths (list length)))
+               (setq total-length (+ total-length length))))))
+    (let ((type (specifier-type output-type-spec)))
+      (cond
+        ((csubtypep type (specifier-type 'list))
+         (cond
+           ((type= type (specifier-type 'list))
+            (concat-to-list* sequences))
+           ((eq type *empty-type*)
+            (bad-sequence-type-error nil))
+           ((type= type (specifier-type 'null))
+            (unless (every #'emptyp sequences)
+              (sequence-type-length-mismatch-error
+               type (reduce #'+ sequences :key #'length))) ; FIXME: circular list issues.
+            '())
+           ((cons-type-p type)
+            (multiple-value-bind (min exactp)
+                (sb!kernel::cons-type-length-info type)
+              (let ((length (reduce #'+ sequences :key #'length)))
+                (if exactp
+                    (unless (= length min)
+                      (sequence-type-length-mismatch-error type length))
+                    (unless (>= length min)
+                      (sequence-type-length-mismatch-error type length)))
+                (concat-to-list* sequences))))
+           (t (sequence-type-too-hairy (type-specifier type)))))
+        ((csubtypep type (specifier-type 'vector))
+         (concat-to-simple* output-type-spec sequences))
+        ((and (csubtypep type (specifier-type 'sequence))
+              (find-class output-type-spec nil))
+         (coerce (concat-to-simple* 'vector sequences) output-type-spec))
+        (t
+         (bad-sequence-type-error output-type-spec))))))
+
+;;; Efficient out-of-line concatenate for strings. Compiler transforms
+;;; CONCATENATE 'STRING &co into these.
+(macrolet ((def (name element-type)
+             `(defun ,name (&rest sequences)
+                (declare (dynamic-extent sequences)
+                         (optimize speed)
+                         (optimize (sb!c::insert-array-bounds-checks 0)))
+                (let* ((lengths (mapcar #'length sequences))
+                       (result (make-array (the integer (apply #'+ lengths))
+                                           :element-type ',element-type))
+                       (start 0))
+                  (declare (index start))
+                  (dolist (seq sequences)
+                    (string-dispatch
+                        ((simple-array character (*))
+                         (simple-array base-char (*))
+                         t)
+                        seq
+                      (replace result seq :start1 start))
+                    (incf start (the index (pop lengths))))
+                  result))))
+  (def %concatenate-to-string character)
+  (def %concatenate-to-base-string base-char))

 \f
 \f

-;;;; MAP and MAP-INTO
+;;;; MAP

 
 ;;; helper functions to handle arity-1 subcases of MAP
 (declaim (ftype (function (function sequence) list) %map-list-arity-1))
 
 ;;; helper functions to handle arity-1 subcases of MAP
 (declaim (ftype (function (function sequence) list) %map-list-arity-1))

@@ -891,9 +991,9 @@
            (type list sequences))
   (let ((result nil))
     (flet ((f (&rest args)
            (type list sequences))
   (let ((result nil))
     (flet ((f (&rest args)

-             (declare (dynamic-extent args))
+             (declare (truly-dynamic-extent args))

              (push (apply fun args) result)))
              (push (apply fun args) result)))

-      (declare (dynamic-extent #'f))
+      (declare (truly-dynamic-extent #'f))

       (%map-for-effect #'f sequences))
     (nreverse result)))
 (defun %map-to-vector (output-type-spec fun sequences)
       (%map-for-effect #'f sequences))
     (nreverse result)))
 (defun %map-to-vector (output-type-spec fun sequences)

@@ -901,19 +1001,19 @@
            (type list sequences))
   (let ((min-len 0))
     (flet ((f (&rest args)
            (type list sequences))
   (let ((min-len 0))
     (flet ((f (&rest args)

-             (declare (dynamic-extent args))
+             (declare (truly-dynamic-extent args))

              (declare (ignore args))
              (incf min-len)))
              (declare (ignore args))
              (incf min-len)))

-      (declare (dynamic-extent #'f))
+      (declare (truly-dynamic-extent #'f))

       (%map-for-effect #'f sequences))
     (let ((result (make-sequence output-type-spec min-len))
           (i 0))
       (declare (type (simple-array * (*)) result))
       (flet ((f (&rest args)
       (%map-for-effect #'f sequences))
     (let ((result (make-sequence output-type-spec min-len))
           (i 0))
       (declare (type (simple-array * (*)) result))
       (flet ((f (&rest args)

-               (declare (dynamic-extent args))
+               (declare (truly-dynamic-extent args))

                (setf (aref result i) (apply fun args))
                (incf i)))
                (setf (aref result i) (apply fun args))
                (incf i)))

-        (declare (dynamic-extent #'f))
+        (declare (truly-dynamic-extent #'f))

         (%map-for-effect #'f sequences))
       result)))
 (defun %map-to-sequence (result-type fun sequences)
         (%map-for-effect #'f sequences))
       result)))
 (defun %map-to-sequence (result-type fun sequences)

@@ -921,20 +1021,20 @@
            (type list sequences))
   (let ((min-len 0))
     (flet ((f (&rest args)
            (type list sequences))
   (let ((min-len 0))
     (flet ((f (&rest args)

-             (declare (dynamic-extent args))
+             (declare (truly-dynamic-extent args))

              (declare (ignore args))
              (incf min-len)))
              (declare (ignore args))
              (incf min-len)))

-      (declare (dynamic-extent #'f))
+      (declare (truly-dynamic-extent #'f))

       (%map-for-effect #'f sequences))
     (let ((result (make-sequence result-type min-len)))
       (multiple-value-bind (state limit from-end step endp elt setelt)
           (sb!sequence:make-sequence-iterator result)
         (declare (ignore limit endp elt))
         (flet ((f (&rest args)
       (%map-for-effect #'f sequences))
     (let ((result (make-sequence result-type min-len)))
       (multiple-value-bind (state limit from-end step endp elt setelt)
           (sb!sequence:make-sequence-iterator result)
         (declare (ignore limit endp elt))
         (flet ((f (&rest args)

-                 (declare (dynamic-extent args))
+                 (declare (truly-dynamic-extent args))

                  (funcall setelt (apply fun args) result state)
                  (setq state (funcall step result state from-end))))
                  (funcall setelt (apply fun args) result state)
                  (setq state (funcall step result state from-end))))

-          (declare (dynamic-extent #'f))
+          (declare (truly-dynamic-extent #'f))

           (%map-for-effect #'f sequences)))
       result)))
 
           (%map-for-effect #'f sequences)))
       result)))
 

@@ -975,34 +1075,79 @@
          first-sequence
          more-sequences))
 
          first-sequence
          more-sequences))
 

-;;; KLUDGE: MAP has been rewritten substantially since the fork from
-;;; CMU CL in order to give reasonable performance, but this
-;;; implementation of MAP-INTO still has the same problems as the old
-;;; MAP code. Ideally, MAP-INTO should be rewritten to be efficient in
-;;; the same way that the corresponding cases of MAP have been
-;;; rewritten. Instead of doing it now, though, it's easier to wait
-;;; until we have DYNAMIC-EXTENT, at which time it should become
-;;; extremely easy to define a reasonably efficient MAP-INTO in terms
-;;; of (MAP NIL ..). -- WHN 20000920
+;;;; MAP-INTO
+
+(defmacro map-into-lambda (sequences params &body body)
+  (check-type sequences symbol)
+  `(flet ((f ,params ,@body))
+     (declare (truly-dynamic-extent #'f))
+     ;; Note (MAP-INTO SEQ (LAMBDA () ...)) is a different animal,
+     ;; hence the awkward flip between MAP and LOOP.
+     (if ,sequences
+         (apply #'map nil #'f ,sequences)
+         (loop (f)))))
+
+(define-array-dispatch vector-map-into (data start end fun sequences)
+  (declare (optimize speed (safety 0))
+           (type index start end)
+           (type function fun)
+           (type list sequences))
+  (let ((index start))
+    (declare (type index index))
+    (block mapping
+      (map-into-lambda sequences (&rest args)
+        (declare (truly-dynamic-extent args))
+        (when (eql index end)
+          (return-from mapping))
+        (setf (aref data index) (apply fun args))
+        (incf index)))
+    index))
+
+;;; Uses the machinery of (MAP NIL ...). For non-vectors we avoid
+;;; computing the length of the result sequence since we can detect
+;;; the end during mapping (if MAP even gets that far).
+;;;
+;;; For each result type, define a mapping function which is
+;;; responsible for replacing RESULT-SEQUENCE elements and for
+;;; terminating itself if the end of RESULT-SEQUENCE is reached.
+;;; The mapping function is defined with MAP-INTO-LAMBDA.
+;;;
+;;; MAP-INTO-LAMBDAs are optimized since they are the inner loops.
+;;; Because we are manually doing bounds checking with known types,
+;;; safety is turned off for vectors and lists but kept for generic
+;;; sequences.

 (defun map-into (result-sequence function &rest sequences)
 (defun map-into (result-sequence function &rest sequences)

-  (let* ((fp-result
-          (and (arrayp result-sequence)
-               (array-has-fill-pointer-p result-sequence)))
-         (len (apply #'min
-                     (if fp-result
-                         (array-dimension result-sequence 0)
-                         (length result-sequence))
-                     (mapcar #'length sequences))))
-
-    (when fp-result
-      (setf (fill-pointer result-sequence) len))
-
-    (let ((really-fun (%coerce-callable-to-fun function)))
-      (dotimes (index len)
-        (setf (elt result-sequence index)
-              (apply really-fun
-                     (mapcar (lambda (seq) (elt seq index))
-                             sequences))))))
+  (let ((really-fun (%coerce-callable-to-fun function)))
+    (etypecase result-sequence
+      (vector
+       (with-array-data ((data result-sequence) (start) (end)
+                         ;; MAP-INTO ignores fill pointer when mapping
+                         :check-fill-pointer nil)
+         (let ((new-end (vector-map-into data start end really-fun sequences)))
+           (when (array-has-fill-pointer-p result-sequence)
+             (setf (fill-pointer result-sequence) (- new-end start))))))
+      (list
+       (let ((node result-sequence))
+         (declare (type list node))
+         (map-into-lambda sequences (&rest args)
+           (declare (truly-dynamic-extent args)
+                    (optimize speed (safety 0)))
+           (when (null node)
+             (return-from map-into result-sequence))
+           (setf (car node) (apply really-fun args))
+           (setf node (cdr node)))))
+      (sequence
+       (multiple-value-bind (iter limit from-end)
+           (sb!sequence:make-sequence-iterator result-sequence)
+         (map-into-lambda sequences (&rest args)
+           (declare (truly-dynamic-extent args) (optimize speed))
+           (when (sb!sequence:iterator-endp result-sequence
+                                            iter limit from-end)
+             (return-from map-into result-sequence))
+           (setf (sb!sequence:iterator-element result-sequence iter)
+                 (apply really-fun args))
+           (setf iter (sb!sequence:iterator-step result-sequence
+                                                           iter from-end)))))))

   result-sequence)
 \f
 ;;;; quantifiers
   result-sequence)
 \f
 ;;;; quantifiers

@@ -1062,17 +1207,20 @@
                 ;; from the old seq.lisp into target-seq.lisp.
                 (define-compiler-macro ,name (pred first-seq &rest more-seqs)
                   (let ((elements (make-gensym-list (1+ (length more-seqs))))
                 ;; from the old seq.lisp into target-seq.lisp.
                 (define-compiler-macro ,name (pred first-seq &rest more-seqs)
                   (let ((elements (make-gensym-list (1+ (length more-seqs))))

-                        (blockname (gensym "BLOCK")))
+                        (blockname (sb!xc:gensym "BLOCK"))
+                        (wrapper (sb!xc:gensym "WRAPPER")))

                     (once-only ((pred pred))
                       `(block ,blockname
                     (once-only ((pred pred))
                       `(block ,blockname

-                         (map nil
-                              (lambda (,@elements)
-                                (let ((pred-value (funcall ,pred ,@elements)))
-                                  (,',found-test pred-value
-                                    (return-from ,blockname
-                                      ,',found-result))))
-                              ,first-seq
-                              ,@more-seqs)
+                         (flet ((,wrapper (,@elements)
+                                  (declare (optimize (sb!c::check-tag-existence 0)))
+                                  (let ((pred-value (funcall ,pred ,@elements)))
+                                    (,',found-test pred-value
+                                                   (return-from ,blockname
+                                                     ,',found-result)))))
+                           (declare (inline ,wrapper)
+                                    (dynamic-extent #',wrapper))
+                           (map nil #',wrapper ,first-seq
+                                ,@more-seqs))

                          ,',unfound-result)))))))
   (defquantifier some when pred-value :unfound-result nil :doc
   "Apply PREDICATE to the 0-indexed elements of the sequences, then
                          ,',unfound-result)))))))
   (defquantifier some when pred-value :unfound-result nil :doc
   "Apply PREDICATE to the 0-indexed elements of the sequences, then

@@ -1163,19 +1311,20 @@
 
 (define-sequence-traverser reduce (function sequence &rest args &key key
                                    from-end start end (initial-value nil ivp))
 
 (define-sequence-traverser reduce (function sequence &rest args &key key
                                    from-end start end (initial-value nil ivp))

-  (declare (type index start))
-  (declare (dynamic-extent args))
-  (let ((start start)
-        (end (or end length)))
-    (declare (type index start end))
-    (seq-dispatch sequence
+  (declare (type index start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if (= end start)
           (if ivp initial-value (funcall function))
           (if from-end
               (list-reduce-from-end function sequence key start end
                                     initial-value ivp)
               (list-reduce function sequence key start end
       (if (= end start)
           (if ivp initial-value (funcall function))
           (if from-end
               (list-reduce-from-end function sequence key start end
                                     initial-value ivp)
               (list-reduce function sequence key start end

-                           initial-value ivp)))
+                           initial-value ivp))))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if (= end start)
           (if ivp initial-value (funcall function))
           (if from-end
       (if (= end start)
           (if ivp initial-value (funcall function))
           (if from-end

@@ -1190,8 +1339,8 @@
                   (setq initial-value (apply-key key (aref sequence start)))
                   (setq start (1+ start)))
                 (mumble-reduce function sequence key start end
                   (setq initial-value (apply-key key (aref sequence start)))
                   (setq start (1+ start)))
                 (mumble-reduce function sequence key start end

-                               initial-value aref))))
-      (apply #'sb!sequence:reduce function sequence args))))
+                               initial-value aref)))))
+    (apply #'sb!sequence:reduce function sequence args)))

 \f
 ;;;; DELETE
 
 \f
 ;;;; DELETE
 

@@ -1306,18 +1455,20 @@
   #!+sb-doc
   "Return a sequence formed by destructively removing the specified ITEM from
   the given SEQUENCE."
   #!+sb-doc
   "Return a sequence formed by destructively removing the specified ITEM from
   the given SEQUENCE."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (type index end))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (normal-list-delete-from-end)
       (if from-end
           (normal-list-delete-from-end)

-          (normal-list-delete))
+          (normal-list-delete)))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (normal-mumble-delete-from-end)
       (if from-end
           (normal-mumble-delete-from-end)

-          (normal-mumble-delete))
-      (apply #'sb!sequence:delete item sequence args))))
+          (normal-mumble-delete)))
+    (apply #'sb!sequence:delete item sequence args)))

 
 (eval-when (:compile-toplevel :execute)
 
 
 (eval-when (:compile-toplevel :execute)
 

@@ -1344,18 +1495,20 @@
   #!+sb-doc
   "Return a sequence formed by destructively removing the elements satisfying
   the specified PREDICATE from the given SEQUENCE."
   #!+sb-doc
   "Return a sequence formed by destructively removing the elements satisfying
   the specified PREDICATE from the given SEQUENCE."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (type index end))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (if-list-delete-from-end)
       (if from-end
           (if-list-delete-from-end)

-          (if-list-delete))
+          (if-list-delete)))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (if-mumble-delete-from-end)
       (if from-end
           (if-mumble-delete-from-end)

-          (if-mumble-delete))
-      (apply #'sb!sequence:delete-if predicate sequence args))))
+          (if-mumble-delete)))
+    (apply #'sb!sequence:delete-if predicate sequence args)))

 
 (eval-when (:compile-toplevel :execute)
 
 
 (eval-when (:compile-toplevel :execute)
 

@@ -1382,18 +1535,20 @@
   #!+sb-doc
   "Return a sequence formed by destructively removing the elements not
   satisfying the specified PREDICATE from the given SEQUENCE."
   #!+sb-doc
   "Return a sequence formed by destructively removing the elements not
   satisfying the specified PREDICATE from the given SEQUENCE."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (type index end))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (if-not-list-delete-from-end)
       (if from-end
           (if-not-list-delete-from-end)

-          (if-not-list-delete))
+          (if-not-list-delete)))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (if-not-mumble-delete-from-end)
       (if from-end
           (if-not-mumble-delete-from-end)

-          (if-not-mumble-delete))
-      (apply #'sb!sequence:delete-if-not predicate sequence args))))
+          (if-not-mumble-delete)))
+    (apply #'sb!sequence:delete-if-not predicate sequence args)))

 \f
 ;;;; REMOVE
 
 \f
 ;;;; REMOVE
 

@@ -1531,52 +1686,58 @@
   #!+sb-doc
   "Return a copy of SEQUENCE with elements satisfying the test (default is
    EQL) with ITEM removed."
   #!+sb-doc
   "Return a copy of SEQUENCE with elements satisfying the test (default is
    EQL) with ITEM removed."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (type index end))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (normal-list-remove-from-end)
       (if from-end
           (normal-list-remove-from-end)

-          (normal-list-remove))
+          (normal-list-remove)))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (normal-mumble-remove-from-end)
       (if from-end
           (normal-mumble-remove-from-end)

-          (normal-mumble-remove))
-      (apply #'sb!sequence:remove item sequence args))))
+          (normal-mumble-remove)))
+    (apply #'sb!sequence:remove item sequence args)))

 
 (define-sequence-traverser remove-if
     (predicate sequence &rest args &key from-end start end count key)
   #!+sb-doc
   "Return a copy of sequence with elements satisfying PREDICATE removed."
 
 (define-sequence-traverser remove-if
     (predicate sequence &rest args &key from-end start end count key)
   #!+sb-doc
   "Return a copy of sequence with elements satisfying PREDICATE removed."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (type index end))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (if-list-remove-from-end)
       (if from-end
           (if-list-remove-from-end)

-          (if-list-remove))
+          (if-list-remove)))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (if-mumble-remove-from-end)
       (if from-end
           (if-mumble-remove-from-end)

-          (if-mumble-remove))
-      (apply #'sb!sequence:remove-if predicate sequence args))))
+          (if-mumble-remove)))
+    (apply #'sb!sequence:remove-if predicate sequence args)))

 
 (define-sequence-traverser remove-if-not
     (predicate sequence &rest args &key from-end start end count key)
   #!+sb-doc
   "Return a copy of sequence with elements not satisfying PREDICATE removed."
 
 (define-sequence-traverser remove-if-not
     (predicate sequence &rest args &key from-end start end count key)
   #!+sb-doc
   "Return a copy of sequence with elements not satisfying PREDICATE removed."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (type index end))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (if-not-list-remove-from-end)
       (if from-end
           (if-not-list-remove-from-end)

-          (if-not-list-remove))
+          (if-not-list-remove)))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (if-not-mumble-remove-from-end)
       (if from-end
           (if-not-mumble-remove-from-end)

-          (if-not-mumble-remove))
-      (apply #'sb!sequence:remove-if-not predicate sequence args))))
+          (if-not-mumble-remove)))
+    (apply #'sb!sequence:remove-if-not predicate sequence args)))

 \f
 ;;;; REMOVE-DUPLICATES
 
 \f
 ;;;; REMOVE-DUPLICATES
 

@@ -1682,20 +1843,22 @@
     (do ((elt))
         ((= index end))
       (setq elt (aref vector index))
     (do ((elt))
         ((= index end))
       (setq elt (aref vector index))

-      ;; FIXME: Relying on POSITION allowing both :TEST and :TEST-NOT
-      ;; arguments simultaneously is a little fragile, since ANSI says
-      ;; we can't depend on it, so we need to remember to keep that
-      ;; extension in our implementation. It'd probably be better to
-      ;; rewrite this to avoid passing both (as
-      ;; LIST-REMOVE-DUPLICATES* was rewritten ca. sbcl-0.7.12.18).

       (unless (or (and from-end
       (unless (or (and from-end

-                       (position (apply-key key elt) result
-                                 :start start :end jndex
-                                 :test test :test-not test-not :key key))
+                       (if test-not
+                           (position (apply-key key elt) result
+                                     :start start :end jndex
+                                     :test-not test-not :key key)
+                           (position (apply-key key elt) result
+                                     :start start :end jndex
+                                     :test test :key key)))

                   (and (not from-end)
                   (and (not from-end)

-                       (position (apply-key key elt) vector
-                                 :start (1+ index) :end end
-                                 :test test :test-not test-not :key key)))
+                       (if test-not
+                           (position (apply-key key elt) vector
+                                     :start (1+ index) :end end
+                                     :test-not test-not :key key)
+                           (position (apply-key key elt) vector
+                                     :start (1+ index) :end end
+                                     :test test :key key))))

         (setf (aref result jndex) elt)
         (setq jndex (1+ jndex)))
       (setq index (1+ index)))
         (setf (aref result jndex) elt)
         (setq jndex (1+ jndex)))
       (setq index (1+ index)))

@@ -1715,8 +1878,8 @@
    sequence is returned.
 
    The :TEST-NOT argument is deprecated."
    sequence is returned.
 
    The :TEST-NOT argument is deprecated."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (fixnum start)
+           (truly-dynamic-extent args))

   (seq-dispatch sequence
     (if sequence
         (list-remove-duplicates* sequence test test-not
   (seq-dispatch sequence
     (if sequence
         (list-remove-duplicates* sequence test test-not

@@ -1770,9 +1933,15 @@
          (setf (aref vector jndex) (aref vector index))))
     (declare (fixnum index jndex))
     (setf (aref vector jndex) (aref vector index))
          (setf (aref vector jndex) (aref vector index))))
     (declare (fixnum index jndex))
     (setf (aref vector jndex) (aref vector index))

-    (unless (position (apply-key key (aref vector index)) vector :key key
-                      :start (if from-end start (1+ index)) :test test
-                      :end (if from-end jndex end) :test-not test-not)
+    (unless (if test-not
+                (position (apply-key key (aref vector index)) vector :key key
+                          :start (if from-end start (1+ index))
+                          :end (if from-end jndex end)
+                          :test-not test-not)
+                (position (apply-key key (aref vector index)) vector :key key
+                          :start (if from-end start (1+ index))
+                          :end (if from-end jndex end)
+                          :test test))

       (setq jndex (1+ jndex)))))
 
 (define-sequence-traverser delete-duplicates
       (setq jndex (1+ jndex)))))
 
 (define-sequence-traverser delete-duplicates

@@ -1783,11 +1952,11 @@
    given sequence, is returned.
 
    The :TEST-NOT argument is deprecated."
    given sequence, is returned.
 
    The :TEST-NOT argument is deprecated."

-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))

   (seq-dispatch sequence
   (seq-dispatch sequence

-    (if sequence
-        (list-delete-duplicates* sequence test test-not
-                                 key from-end start end))
+    (when sequence
+      (list-delete-duplicates* sequence test test-not
+                               key from-end start end))

     (vector-delete-duplicates* sequence test test-not key from-end start end)
     (apply #'sb!sequence:delete-duplicates sequence args)))
 \f
     (vector-delete-duplicates* sequence test test-not key from-end start end)
     (apply #'sb!sequence:delete-duplicates sequence args)))
 \f

@@ -1867,25 +2036,31 @@
 
 (sb!xc:defmacro subst-dispatch (pred)
   `(seq-dispatch sequence
 
 (sb!xc:defmacro subst-dispatch (pred)
   `(seq-dispatch sequence

-     (if from-end
-         (nreverse (list-substitute* ,pred
-                                     new
-                                     (reverse sequence)
-                                     (- (the fixnum length)
-                                        (the fixnum end))
-                                     (- (the fixnum length)
-                                        (the fixnum start))
-                                     count key test test-not old))
-         (list-substitute* ,pred
-                           new sequence start end count key test test-not
-                           old))
-    (if from-end
-        (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
-                            -1 length (1- (the fixnum end))
-                            (1- (the fixnum start))
-                            count key test test-not old)
-        (vector-substitute* ,pred new sequence 1 0 length length
-                            start end count key test test-not old))
+     (let ((end (or end length)))
+       (declare (type index end))
+       (if from-end
+           (nreverse (list-substitute* ,pred
+                                       new
+                                       (reverse sequence)
+                                       (- (the fixnum length)
+                                          (the fixnum end))
+                                       (- (the fixnum length)
+                                          (the fixnum start))
+                                       count key test test-not old))
+           (list-substitute* ,pred
+                             new sequence start end count key test test-not
+                             old)))
+
+     (let ((end (or end length)))
+       (declare (type index end))
+       (if from-end
+           (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
+                               -1 length (1- (the fixnum end))
+                               (1- (the fixnum start))
+                               count key test test-not old)
+           (vector-substitute* ,pred new sequence 1 0 length length
+                               start end count key test test-not old)))
+

     ;; FIXME: wow, this is an odd way to implement the dispatch.  PRED
     ;; here is (QUOTE [NORMAL|IF|IF-NOT]).  Not only is this pretty
     ;; pointless, but also LIST-SUBSTITUTE* and VECTOR-SUBSTITUTE*
     ;; FIXME: wow, this is an odd way to implement the dispatch.  PRED
     ;; here is (QUOTE [NORMAL|IF|IF-NOT]).  Not only is this pretty
     ;; pointless, but also LIST-SUBSTITUTE* and VECTOR-SUBSTITUTE*

@@ -1902,11 +2077,9 @@
   #!+sb-doc
   "Return a sequence of the same kind as SEQUENCE with the same elements,
   except that all elements equal to OLD are replaced with NEW."
   #!+sb-doc
   "Return a sequence of the same kind as SEQUENCE with the same elements,
   except that all elements equal to OLD are replaced with NEW."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (type index end))
-    (subst-dispatch 'normal)))
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (subst-dispatch 'normal))

 \f
 ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
 
 \f
 ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
 

@@ -1915,13 +2088,11 @@
   #!+sb-doc
   "Return a sequence of the same kind as SEQUENCE with the same elements
   except that all elements satisfying the PRED are replaced with NEW."
   #!+sb-doc
   "Return a sequence of the same kind as SEQUENCE with the same elements
   except that all elements satisfying the PRED are replaced with NEW."

-  (declare (dynamic-extent args))
-  (declare (fixnum start))
-  (let ((end (or end length))
-        (test predicate)
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (let ((test predicate)

         (test-not nil)
         old)
         (test-not nil)
         old)

-    (declare (type index length end))

     (subst-dispatch 'if)))
 
 (define-sequence-traverser substitute-if-not
     (subst-dispatch 'if)))
 
 (define-sequence-traverser substitute-if-not

@@ -1929,13 +2100,11 @@
   #!+sb-doc
   "Return a sequence of the same kind as SEQUENCE with the same elements
   except that all elements not satisfying the PRED are replaced with NEW."
   #!+sb-doc
   "Return a sequence of the same kind as SEQUENCE with the same elements
   except that all elements not satisfying the PRED are replaced with NEW."

-  (declare (dynamic-extent args))
-  (declare (fixnum start))
-  (let ((end (or end length))
-        (test predicate)
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (let ((test predicate)

         (test-not nil)
         old)
         (test-not nil)
         old)

-    (declare (type index length end))

     (subst-dispatch 'if-not)))
 \f
 ;;;; NSUBSTITUTE
     (subst-dispatch 'if-not)))
 \f
 ;;;; NSUBSTITUTE

@@ -1947,24 +2116,26 @@
   "Return a sequence of the same kind as SEQUENCE with the same elements
   except that all elements equal to OLD are replaced with NEW. SEQUENCE
   may be destructively modified."
   "Return a sequence of the same kind as SEQUENCE with the same elements
   except that all elements equal to OLD are replaced with NEW. SEQUENCE
   may be destructively modified."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
       (if from-end

-          (let ((length (length sequence)))
-            (nreverse (nlist-substitute*
-                       new old (nreverse (the list sequence))
-                       test test-not (- length end) (- length start)
-                       count key)))
+          (nreverse (nlist-substitute*
+                     new old (nreverse (the list sequence))
+                     test test-not (- length end) (- length start)
+                     count key))

           (nlist-substitute* new old sequence
           (nlist-substitute* new old sequence

-                             test test-not start end count key))
+                             test test-not start end count key)))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (nvector-substitute* new old sequence -1
                                test test-not (1- end) (1- start) count key)
           (nvector-substitute* new old sequence 1
       (if from-end
           (nvector-substitute* new old sequence -1
                                test test-not (1- end) (1- start) count key)
           (nvector-substitute* new old sequence 1

-                               test test-not start end count key))
-      (apply #'sb!sequence:nsubstitute new old sequence args))))
+                               test test-not start end count key)))
+    (apply #'sb!sequence:nsubstitute new old sequence args)))

 
 (defun nlist-substitute* (new old sequence test test-not start end count key)
   (declare (fixnum start count end))
 
 (defun nlist-substitute* (new old sequence test test-not start end count key)
   (declare (fixnum start count end))

@@ -2000,27 +2171,29 @@
   "Return a sequence of the same kind as SEQUENCE with the same elements
    except that all elements satisfying PREDICATE are replaced with NEW.
    SEQUENCE may be destructively modified."
   "Return a sequence of the same kind as SEQUENCE with the same elements
    except that all elements satisfying PREDICATE are replaced with NEW.
    SEQUENCE may be destructively modified."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (fixnum end))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
       (if from-end

-          (let ((length (length sequence)))
-            (nreverse (nlist-substitute-if*
-                       new predicate (nreverse (the list sequence))
-                       (- length end) (- length start) count key)))
+          (nreverse (nlist-substitute-if*
+                     new predicate (nreverse (the list sequence))
+                     (- length end) (- length start) count key))

           (nlist-substitute-if* new predicate sequence
           (nlist-substitute-if* new predicate sequence

-                                start end count key))
+                                start end count key)))
+    (let ((end (or end length)))
+      (declare (type index end))

       (if from-end
           (nvector-substitute-if* new predicate sequence -1
                                   (1- end) (1- start) count key)
           (nvector-substitute-if* new predicate sequence 1
       (if from-end
           (nvector-substitute-if* new predicate sequence -1
                                   (1- end) (1- start) count key)
           (nvector-substitute-if* new predicate sequence 1

-                                  start end count key))
-      (apply #'sb!sequence:nsubstitute-if new predicate sequence args))))
+                                  start end count key)))
+    (apply #'sb!sequence:nsubstitute-if new predicate sequence args)))

 
 (defun nlist-substitute-if* (new test sequence start end count key)
 
 (defun nlist-substitute-if* (new test sequence start end count key)

-  (declare (fixnum end))
+  (declare (type fixnum end)
+           (type function test)) ; coercion is done by caller

   (do ((list (nthcdr start sequence) (cdr list))
        (index start (1+ index)))
       ((or (= index end) (null list) (= count 0)) sequence)
   (do ((list (nthcdr start sequence) (cdr list))
        (index start (1+ index)))
       ((or (= index end) (null list) (= count 0)) sequence)

@@ -2030,6 +2203,8 @@
 
 (defun nvector-substitute-if* (new test sequence incrementer
                                start end count key)
 
 (defun nvector-substitute-if* (new test sequence incrementer
                                start end count key)

+  (declare (type fixnum end)
+           (type function test)) ; coercion is done by caller

   (do ((index start (+ index incrementer)))
       ((or (= index end) (= count 0)) sequence)
     (when (funcall test (apply-key key (aref sequence index)))
   (do ((index start (+ index incrementer)))
       ((or (= index end) (= count 0)) sequence)
     (when (funcall test (apply-key key (aref sequence index)))

@@ -2042,27 +2217,29 @@
   "Return a sequence of the same kind as SEQUENCE with the same elements
    except that all elements not satisfying PREDICATE are replaced with NEW.
    SEQUENCE may be destructively modified."
   "Return a sequence of the same kind as SEQUENCE with the same elements
    except that all elements not satisfying PREDICATE are replaced with NEW.
    SEQUENCE may be destructively modified."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length)))
-    (declare (fixnum end))
-    (seq-dispatch sequence
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence
+    (let ((end (or end length)))
+      (declare (fixnum end))

       (if from-end
       (if from-end

-          (let ((length (length sequence)))
-            (nreverse (nlist-substitute-if-not*
-                       new predicate (nreverse (the list sequence))
-                       (- length end) (- length start) count key)))
+          (nreverse (nlist-substitute-if-not*
+                     new predicate (nreverse (the list sequence))
+                     (- length end) (- length start) count key))

           (nlist-substitute-if-not* new predicate sequence
           (nlist-substitute-if-not* new predicate sequence

-                                    start end count key))
+                                    start end count key)))
+    (let ((end (or end length)))
+      (declare (fixnum end))

       (if from-end
           (nvector-substitute-if-not* new predicate sequence -1
                                       (1- end) (1- start) count key)
           (nvector-substitute-if-not* new predicate sequence 1
       (if from-end
           (nvector-substitute-if-not* new predicate sequence -1
                                       (1- end) (1- start) count key)
           (nvector-substitute-if-not* new predicate sequence 1

-                                      start end count key))
-      (apply #'sb!sequence:nsubstitute-if-not new predicate sequence args))))
+                                      start end count key)))
+    (apply #'sb!sequence:nsubstitute-if-not new predicate sequence args)))

 
 (defun nlist-substitute-if-not* (new test sequence start end count key)
 
 (defun nlist-substitute-if-not* (new test sequence start end count key)

-  (declare (fixnum end))
+  (declare (type fixnum end)
+           (type function test)) ; coercion is done by caller

   (do ((list (nthcdr start sequence) (cdr list))
        (index start (1+ index)))
       ((or (= index end) (null list) (= count 0)) sequence)
   (do ((list (nthcdr start sequence) (cdr list))
        (index start (1+ index)))
       ((or (= index end) (null list) (= count 0)) sequence)

@@ -2072,6 +2249,8 @@
 
 (defun nvector-substitute-if-not* (new test sequence incrementer
                                    start end count key)
 
 (defun nvector-substitute-if-not* (new test sequence incrementer
                                    start end count key)

+  (declare (type fixnum end)
+           (type function test)) ; coercion is done by caller

   (do ((index start (+ index incrementer)))
       ((or (= index end) (= count 0)) sequence)
     (when (not (funcall test (apply-key key (aref sequence index))))
   (do ((index start (+ index incrementer)))
       ((or (= index end) (= count 0)) sequence)
     (when (not (funcall test (apply-key key (aref sequence index))))

@@ -2089,21 +2268,36 @@
 (macrolet (;; shared logic for defining %FIND-POSITION and
            ;; %FIND-POSITION-IF in terms of various inlineable cases
            ;; of the expression defined in FROB and VECTOR*-FROB
 (macrolet (;; shared logic for defining %FIND-POSITION and
            ;; %FIND-POSITION-IF in terms of various inlineable cases
            ;; of the expression defined in FROB and VECTOR*-FROB

-           (frobs ()
+           (frobs (&optional bit-frob)

              `(seq-dispatch sequence-arg
                (frob sequence-arg from-end)
                (with-array-data ((sequence sequence-arg :offset-var offset)
                                  (start start)
              `(seq-dispatch sequence-arg
                (frob sequence-arg from-end)
                (with-array-data ((sequence sequence-arg :offset-var offset)
                                  (start start)

-                                 (end (%check-vector-sequence-bounds
-                                       sequence-arg start end)))
+                                 (end end)
+                                 :check-fill-pointer t)

                  (multiple-value-bind (f p)
                  (multiple-value-bind (f p)

-                     (macrolet ((frob2 () '(if from-end
-                                            (frob sequence t)
-                                            (frob sequence nil))))
+                     (macrolet ((frob2 () `(if from-end
+                                               (frob sequence t)
+                                               (frob sequence nil))))

                        (typecase sequence
                        (typecase sequence

-                         (simple-vector (frob2))
-                         (simple-base-string (frob2))
-                         (t (vector*-frob sequence))))
+                         #!+sb-unicode
+                         ((simple-array character (*)) (frob2))
+                         ((simple-array base-char (*)) (frob2))
+                         ,@(when bit-frob
+                             `((simple-bit-vector
+                                (if (and (typep item 'bit)
+                                         (eq #'identity key)
+                                         (or (eq #'eq test)
+                                             (eq #'eql test)
+                                             (eq #'equal test)))
+                                    (let ((p (%bit-position item sequence
+                                                            from-end start end)))
+                                      (if p
+                                          (values item p)
+                                          (values nil nil)))
+                                    (vector*-frob sequence)))))
+                         (t
+                          (vector*-frob sequence))))

                    (declare (type (or index null) p))
                    (values f (and p (the index (- p offset)))))))))
   (defun %find-position (item sequence-arg from-end start end key test)
                    (declare (type (or index null) p))
                    (values f (and p (the index (- p offset)))))))))
   (defun %find-position (item sequence-arg from-end start end key test)

@@ -2113,7 +2307,7 @@
                (vector*-frob (sequence)
                  `(%find-position-vector-macro item ,sequence
                                                from-end start end key test)))
                (vector*-frob (sequence)
                  `(%find-position-vector-macro item ,sequence
                                                from-end start end key test)))

-      (frobs)))
+      (frobs t)))

   (defun %find-position-if (predicate sequence-arg from-end start end key)
     (macrolet ((frob (sequence from-end)
                  `(%find-position-if predicate ,sequence
   (defun %find-position-if (predicate sequence-arg from-end start end key)
     (macrolet ((frob (sequence from-end)
                  `(%find-position-if predicate ,sequence

@@ -2133,7 +2327,7 @@
 
 (defun find
     (item sequence &rest args &key from-end (start 0) end key test test-not)
 
 (defun find
     (item sequence &rest args &key from-end (start 0) end key test test-not)

-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))

   (seq-dispatch sequence
     (nth-value 0 (%find-position
                   item sequence from-end start end
   (seq-dispatch sequence
     (nth-value 0 (%find-position
                   item sequence from-end start end

@@ -2146,7 +2340,7 @@
     (apply #'sb!sequence:find item sequence args)))
 (defun position
     (item sequence &rest args &key from-end (start 0) end key test test-not)
     (apply #'sb!sequence:find item sequence args)))
 (defun position
     (item sequence &rest args &key from-end (start 0) end key test test-not)

-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))

   (seq-dispatch sequence
     (nth-value 1 (%find-position
                   item sequence from-end start end
   (seq-dispatch sequence
     (nth-value 1 (%find-position
                   item sequence from-end start end

@@ -2159,7 +2353,7 @@
     (apply #'sb!sequence:position item sequence args)))
 
 (defun find-if (predicate sequence &rest args &key from-end (start 0) end key)
     (apply #'sb!sequence:position item sequence args)))
 
 (defun find-if (predicate sequence &rest args &key from-end (start 0) end key)

-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))

   (seq-dispatch sequence
     (nth-value 0 (%find-position-if
                   (%coerce-callable-to-fun predicate)
   (seq-dispatch sequence
     (nth-value 0 (%find-position-if
                   (%coerce-callable-to-fun predicate)

@@ -2172,7 +2366,7 @@
     (apply #'sb!sequence:find-if predicate sequence args)))
 (defun position-if
     (predicate sequence &rest args &key from-end (start 0) end key)
     (apply #'sb!sequence:find-if predicate sequence args)))
 (defun position-if
     (predicate sequence &rest args &key from-end (start 0) end key)

-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))

   (seq-dispatch sequence
     (nth-value 1 (%find-position-if
                   (%coerce-callable-to-fun predicate)
   (seq-dispatch sequence
     (nth-value 1 (%find-position-if
                   (%coerce-callable-to-fun predicate)

@@ -2186,7 +2380,7 @@
 
 (defun find-if-not
     (predicate sequence &rest args &key from-end (start 0) end key)
 
 (defun find-if-not
     (predicate sequence &rest args &key from-end (start 0) end key)

-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))

   (seq-dispatch sequence
     (nth-value 0 (%find-position-if-not
                   (%coerce-callable-to-fun predicate)
   (seq-dispatch sequence
     (nth-value 0 (%find-position-if-not
                   (%coerce-callable-to-fun predicate)

@@ -2199,7 +2393,7 @@
     (apply #'sb!sequence:find-if-not predicate sequence args)))
 (defun position-if-not
     (predicate sequence &rest args &key from-end (start 0) end key)
     (apply #'sb!sequence:find-if-not predicate sequence args)))
 (defun position-if-not
     (predicate sequence &rest args &key from-end (start 0) end key)

-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))

   (seq-dispatch sequence
     (nth-value 1 (%find-position-if-not
                   (%coerce-callable-to-fun predicate)
   (seq-dispatch sequence
     (nth-value 1 (%find-position-if-not
                   (%coerce-callable-to-fun predicate)

@@ -2247,36 +2441,40 @@
     (pred sequence &rest args &key from-end start end key)
   #!+sb-doc
   "Return the number of elements in SEQUENCE satisfying PRED(el)."
     (pred sequence &rest args &key from-end start end key)
   #!+sb-doc
   "Return the number of elements in SEQUENCE satisfying PRED(el)."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length))
-        (pred (%coerce-callable-to-fun pred)))
-    (declare (type index end))
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (let ((pred (%coerce-callable-to-fun pred)))

     (seq-dispatch sequence
     (seq-dispatch sequence

-      (if from-end
-          (list-count-if nil t pred sequence)
-          (list-count-if nil nil pred sequence))
-      (if from-end
-          (vector-count-if nil t pred sequence)
-          (vector-count-if nil nil pred sequence))
+      (let ((end (or end length)))
+        (declare (type index end))
+        (if from-end
+            (list-count-if nil t pred sequence)
+            (list-count-if nil nil pred sequence)))
+      (let ((end (or end length)))
+        (declare (type index end))
+        (if from-end
+            (vector-count-if nil t pred sequence)
+            (vector-count-if nil nil pred sequence)))

       (apply #'sb!sequence:count-if pred sequence args))))
 
 (define-sequence-traverser count-if-not
     (pred sequence &rest args &key from-end start end key)
   #!+sb-doc
   "Return the number of elements in SEQUENCE not satisfying TEST(el)."
       (apply #'sb!sequence:count-if pred sequence args))))
 
 (define-sequence-traverser count-if-not
     (pred sequence &rest args &key from-end start end key)
   #!+sb-doc
   "Return the number of elements in SEQUENCE not satisfying TEST(el)."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
-  (let ((end (or end length))
-        (pred (%coerce-callable-to-fun pred)))
-    (declare (type index end))
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))
+  (let ((pred (%coerce-callable-to-fun pred)))

     (seq-dispatch sequence
     (seq-dispatch sequence

-      (if from-end
-          (list-count-if t t pred sequence)
-          (list-count-if t nil pred sequence))
-      (if from-end
-          (vector-count-if t t pred sequence)
-          (vector-count-if t nil pred sequence))
+      (let ((end (or end length)))
+        (declare (type index end))
+        (if from-end
+            (list-count-if t t pred sequence)
+            (list-count-if t nil pred sequence)))
+      (let ((end (or end length)))
+        (declare (type index end))
+        (if from-end
+            (vector-count-if t t pred sequence)
+            (vector-count-if t nil pred sequence)))

       (apply #'sb!sequence:count-if-not pred sequence args))))
 
 (define-sequence-traverser count
       (apply #'sb!sequence:count-if-not pred sequence args))))
 
 (define-sequence-traverser count

@@ -2285,27 +2483,29 @@
   #!+sb-doc
   "Return the number of elements in SEQUENCE satisfying a test with ITEM,
    which defaults to EQL."
   #!+sb-doc
   "Return the number of elements in SEQUENCE satisfying a test with ITEM,
    which defaults to EQL."

-  (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (type fixnum start)
+           (truly-dynamic-extent args))

   (when (and test-p test-not-p)
     ;; ANSI Common Lisp has left the behavior in this situation unspecified.
     ;; (CLHS 17.2.1)
     (error ":TEST and :TEST-NOT are both present."))
   (when (and test-p test-not-p)
     ;; ANSI Common Lisp has left the behavior in this situation unspecified.
     ;; (CLHS 17.2.1)
     (error ":TEST and :TEST-NOT are both present."))

-  (let ((end (or end length)))
-    (declare (type index end))
-    (let ((%test (if test-not-p
-                     (lambda (x)
-                       (not (funcall test-not item x)))
-                     (lambda (x)
-                       (funcall test item x)))))
-      (seq-dispatch sequence
+  (let ((%test (if test-not-p
+                   (lambda (x)
+                     (not (funcall test-not item x)))
+                   (lambda (x)
+                     (funcall test item x)))))
+    (seq-dispatch sequence
+      (let ((end (or end length)))
+        (declare (type index end))

         (if from-end
             (list-count-if nil t %test sequence)
         (if from-end
             (list-count-if nil t %test sequence)

-            (list-count-if nil nil %test sequence))
+            (list-count-if nil nil %test sequence)))
+      (let ((end (or end length)))
+        (declare (type index end))

         (if from-end
             (vector-count-if nil t %test sequence)
         (if from-end
             (vector-count-if nil t %test sequence)

-            (vector-count-if nil nil %test sequence))
-        (apply #'sb!sequence:count item sequence args)))))
+            (vector-count-if nil nil %test sequence)))
+      (apply #'sb!sequence:count item sequence args))))

 \f
 ;;;; MISMATCH
 
 \f
 ;;;; MISMATCH
 

@@ -2393,26 +2593,39 @@
    SEQUENCE1 beyond the last position tested is returned. If a non-NIL
    :FROM-END argument is given, then one plus the index of the rightmost
    position in which the sequences differ is returned."
    SEQUENCE1 beyond the last position tested is returned. If a non-NIL
    :FROM-END argument is given, then one plus the index of the rightmost
    position in which the sequences differ is returned."

-  (declare (fixnum start1 start2))
-  (declare (dynamic-extent args))
-  (let* ((end1 (or end1 length1))
-         (end2 (or end2 length2)))
-    (declare (type index end1 end2))
-    (match-vars
-     (seq-dispatch sequence1
-       (seq-dispatch sequence2
+  (declare (type fixnum start1 start2))
+  (declare (truly-dynamic-extent args))
+  (seq-dispatch sequence1
+    (seq-dispatch sequence2
+      (let ((end1 (or end1 length1))
+            (end2 (or end2 length2)))
+        (declare (type index end1 end2))
+        (match-vars

          (matchify-list (sequence1 start1 length1 end1)
            (matchify-list (sequence2 start2 length2 end2)
          (matchify-list (sequence1 start1 length1 end1)
            (matchify-list (sequence2 start2 length2 end2)

-             (list-list-mismatch)))
+             (list-list-mismatch)))))
+      (let ((end1 (or end1 length1))
+            (end2 (or end2 length2)))
+        (declare (type index end1 end2))
+        (match-vars

          (matchify-list (sequence1 start1 length1 end1)
          (matchify-list (sequence1 start1 length1 end1)

-           (list-mumble-mismatch))
-         (apply #'sb!sequence:mismatch sequence1 sequence2 args))
-       (seq-dispatch sequence2
+           (list-mumble-mismatch))))
+      (apply #'sb!sequence:mismatch sequence1 sequence2 args))
+    (seq-dispatch sequence2
+      (let ((end1 (or end1 length1))
+            (end2 (or end2 length2)))
+        (declare (type index end1 end2))
+        (match-vars

          (matchify-list (sequence2 start2 length2 end2)
          (matchify-list (sequence2 start2 length2 end2)

-           (mumble-list-mismatch))
-         (mumble-mumble-mismatch)
-         (apply #'sb!sequence:mismatch sequence1 sequence2 args))
-       (apply #'sb!sequence:mismatch sequence1 sequence2 args)))))
+           (mumble-list-mismatch))))
+      (let ((end1 (or end1 length1))
+            (end2 (or end2 length2)))
+        (declare (type index end1 end2))
+        (match-vars
+         (mumble-mumble-mismatch)))
+      (apply #'sb!sequence:mismatch sequence1 sequence2 args))
+    (apply #'sb!sequence:mismatch sequence1 sequence2 args)))
+

 \f
 ;;; search comparison functions
 
 \f
 ;;; search comparison functions
 

@@ -2503,23 +2716,18 @@
 (define-sequence-traverser search
     (sequence1 sequence2 &rest args &key
      from-end test test-not start1 end1 start2 end2 key)
 (define-sequence-traverser search
     (sequence1 sequence2 &rest args &key
      from-end test test-not start1 end1 start2 end2 key)

-  (declare (fixnum start1 start2))
-  (declare (dynamic-extent args))
-  (let ((end1 (or end1 length1))
-        (end2 (or end2 length2)))
-    (seq-dispatch sequence2
-      (list-search sequence2 sequence1)
-      (vector-search sequence2 sequence1)
-      (apply #'sb!sequence:search sequence1 sequence2 args))))
-
-(sb!xc:defmacro string-dispatch ((&rest types) var &body body)
-  (let ((fun (gensym "STRING-DISPATCH-FUN-")))
-    `(flet ((,fun (,var)
-              ,@body))
-       (declare (inline ,fun))
-       (etypecase ,var
-         ,@(loop for type in types
-                 collect `(,type (,fun (the ,type ,var))))))))
+  (declare (type fixnum start1 start2)
+           (truly-dynamic-extent args))
+  (seq-dispatch sequence2
+    (let ((end1 (or end1 length1))
+          (end2 (or end2 length2)))
+      (declare (type index end1 end2))
+      (list-search sequence2 sequence1))
+    (let ((end1 (or end1 length1))
+          (end2 (or end2 length2)))
+      (declare (type index end1 end2))
+      (vector-search sequence2 sequence1))
+    (apply #'sb!sequence:search sequence1 sequence2 args)))

 
 ;;; FIXME: this was originally in array.lisp; it might be better to
 ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in
 
 ;;; FIXME: this was originally in array.lisp; it might be better to
 ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in

@@ -2542,4 +2750,4 @@
                                axis (car dims) contents (length contents)))
                       (sb!sequence:dosequence (content contents)
                         (frob (1+ axis) (cdr dims) content))))))
                                axis (car dims) contents (length contents)))
                       (sb!sequence:dosequence (content contents)
                         (frob (1+ axis) (cdr dims) content))))))

-      (frob 0 dimensions initial-contents))))
\ No newline at end of file
+      (frob 0 dimensions initial-contents))))