X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=cc0267168121412577d70a91e81dabe9c9d24469;hb=41cb424785ec6daf0263acb1a6a8af9d41708990;hp=ed87d4cef780b441f0a9bfda3292cf8db247c490;hpb=1596e9fdeb2265c4a00e441bc8a1dbdc5364afa7;p=sbcl.git

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index ed87d4c..cc02671 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -20,6 +20,12 @@
 
 ;;;; 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*
@@ -41,8 +47,7 @@
                      nil
                      (if (<= 0 ,start ,length)
                          ,start
-                         (signal-bounding-indices-bad-error ,sequence
-                                                            ,start ,end))
+                         (sequence-bounding-indices-bad-error ,sequence ,start ,end))
                      index)
                   `(,end
                     nil
@@ -55,8 +60,7 @@
                         ;; FIXME: defend against non-number non-NIL
                         ;; stuff?
                         ,end
-                        (signal-bounding-indices-bad-error ,sequence
-                                                           ,start ,end))
+                        (sequence-bounding-indices-bad-error ,sequence ,start ,end))
                     (or null index)))))
               '((start end length sequence)
                 (start1 end1 length1 sequence1)
@@ -220,13 +224,33 @@
                               ;; 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)
-           :expected-type `(cons (integer 0 ,length)
-                                 (or null (integer ,start ,length)))
+           :expected-type `(cons (integer 0 ,size)
+                                 (integer ,start ,size))
            :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)))))
+
 
 (defun elt (sequence index)
   #!+sb-doc "Return the element of SEQUENCE specified by INDEX."
@@ -272,17 +296,18 @@
   "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
-                    ((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
-                    ((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)))
@@ -352,40 +377,66 @@
 ;;;; 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 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)
+    (funcall (!find-vector-subseq-fun data) 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
@@ -398,84 +449,91 @@
 
 ;;;; 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)
-    (vector-copy-seq* sequence)
+    (vector-subseq* sequence 0 nil)
     (sb!sequence:copy-seq sequence)))
 
-;;; internal frobs
-
 (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))
 
 ;;;; 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)
-  (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)
-  (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
-    (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))))
 
 ;;;; REPLACE
 
@@ -603,7 +661,7 @@
   #!+sb-doc
   "The target sequence is destructively modified by copying successive
    elements into it from the source sequence."
-  (declare (dynamic-extent args))
+  (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
@@ -725,91 +783,98 @@
                   ,@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
 
 (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))
+            (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)))
+                (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))
 
 ;;;; MAP and MAP-INTO
 
@@ -891,9 +956,9 @@
            (type list sequences))
   (let ((result nil))
     (flet ((f (&rest args)
-             (declare (dynamic-extent args))
+             (declare (truly-dynamic-extent args))
              (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)
@@ -901,19 +966,19 @@
            (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 (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)
-               (declare (dynamic-extent args))
+               (declare (truly-dynamic-extent args))
                (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)
@@ -921,20 +986,20 @@
            (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 (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)
-                 (declare (dynamic-extent args))
+                 (declare (truly-dynamic-extent args))
                  (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)))
 
@@ -1164,7 +1229,7 @@
 (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))
+  (declare (truly-dynamic-extent args))
   (let ((start start)
         (end (or end length)))
     (declare (type index start end))
@@ -1307,7 +1372,7 @@
   "Return a sequence formed by destructively removing the specified ITEM from
   the given SEQUENCE."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1345,7 +1410,7 @@
   "Return a sequence formed by destructively removing the elements satisfying
   the specified PREDICATE from the given SEQUENCE."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1383,7 +1448,7 @@
   "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))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1532,7 +1597,7 @@
   "Return a copy of SEQUENCE with elements satisfying the test (default is
    EQL) with ITEM removed."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1549,7 +1614,7 @@
   #!+sb-doc
   "Return a copy of sequence with elements satisfying PREDICATE removed."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1566,7 +1631,7 @@
   #!+sb-doc
   "Return a copy of sequence with elements not satisfying PREDICATE removed."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1718,7 +1783,7 @@
 
    The :TEST-NOT argument is deprecated."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (if sequence
         (list-remove-duplicates* sequence test test-not
@@ -1791,7 +1856,7 @@
    given sequence, is returned.
 
    The :TEST-NOT argument is deprecated."
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (if sequence
         (list-delete-duplicates* sequence test test-not
@@ -1911,7 +1976,7 @@
   "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))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (subst-dispatch 'normal)))
@@ -1923,7 +1988,7 @@
   #!+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 (truly-dynamic-extent args))
   (declare (fixnum start))
   (let ((end (or end length))
         (test predicate)
@@ -1937,7 +2002,7 @@
   #!+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 (truly-dynamic-extent args))
   (declare (fixnum start))
   (let ((end (or end length))
         (test predicate)
@@ -1956,7 +2021,7 @@
   except that all elements equal to OLD are replaced with NEW. SEQUENCE
   may be destructively modified."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (seq-dispatch sequence
       (if from-end
@@ -2009,7 +2074,7 @@
    except that all elements satisfying PREDICATE are replaced with NEW.
    SEQUENCE may be destructively modified."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (fixnum end))
     (seq-dispatch sequence
@@ -2051,7 +2116,7 @@
    except that all elements not satisfying PREDICATE are replaced with NEW.
    SEQUENCE may be destructively modified."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (fixnum end))
     (seq-dispatch sequence
@@ -2097,21 +2162,35 @@
 (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)
-                                 (end (%check-vector-sequence-bounds
-                                       sequence-arg start end)))
+                                 (end end)
+                                 :check-fill-pointer t)
                  (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
-                         (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 (eq #'identity key)
+                                         (or (eq #'eq test)
+                                             (eq #'eql test)
+                                             (eq #'equal test)))
+                                    (let ((p (%bit-position (the bit 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)
@@ -2121,7 +2200,7 @@
                (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
@@ -2141,7 +2220,7 @@
 
 (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
@@ -2154,7 +2233,7 @@
     (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
@@ -2167,7 +2246,7 @@
     (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)
@@ -2180,7 +2259,7 @@
     (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)
@@ -2194,7 +2273,7 @@
 
 (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)
@@ -2207,7 +2286,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)
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (nth-value 1 (%find-position-if-not
                   (%coerce-callable-to-fun predicate)
@@ -2256,7 +2335,7 @@
   #!+sb-doc
   "Return the number of elements in SEQUENCE satisfying PRED(el)."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length))
         (pred (%coerce-callable-to-fun pred)))
     (declare (type index end))
@@ -2274,7 +2353,7 @@
   #!+sb-doc
   "Return the number of elements in SEQUENCE not satisfying TEST(el)."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length))
         (pred (%coerce-callable-to-fun pred)))
     (declare (type index end))
@@ -2294,7 +2373,7 @@
   "Return the number of elements in SEQUENCE satisfying a test with ITEM,
    which defaults to EQL."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (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)
@@ -2402,7 +2481,7 @@
    :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))
+  (declare (truly-dynamic-extent args))
   (let* ((end1 (or end1 length1))
          (end2 (or end2 length2)))
     (declare (type index end1 end2))
@@ -2512,7 +2591,7 @@
     (sequence1 sequence2 &rest args &key
      from-end test test-not start1 end1 start2 end2 key)
   (declare (fixnum start1 start2))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end1 (or end1 length1))
         (end2 (or end2 length2)))
     (seq-dispatch sequence2
@@ -2520,15 +2599,6 @@
       (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))))))))
-
 ;;; FIXME: this was originally in array.lisp; it might be better to
 ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in
 ;;; a new early-seq.lisp file.