1.0.28.41: make MAKE-ARRAY transforms co-operate with FILL better

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

diff --git a/src/code/octets.lisp b/src/code/octets.lisp
index e768fb3..4f725a7 100644 (file)
--- a/src/code/octets.lisp
+++ b/src/code/octets.lisp
@@ -135,26 +135,6 @@ one-past-the-end"
     (,definer aref (simple-array (unsigned-byte 8) (*)))
     (,definer sap-ref-8 system-area-pointer)))
 
     (,definer aref (simple-array (unsigned-byte 8) (*)))
     (,definer sap-ref-8 system-area-pointer)))
 

-;;; maps into TO-SEQ from elements of FROM-SEQ via MAPPER.  MAPPER
-;;; returns two values: the number of elments stored in TO-SEQ, and
-;;; the number used up from FROM-SEQ.  MAPPER is responsible for
-;;; getting out if either sequence runs out of room.
-(declaim (inline varimap))
-(defun varimap (to-seq to-start to-end from-start from-end mapper)
-  (declare (optimize speed (safety 0))
-           (type array-range to-start to-end from-start from-end)
-           (type function mapper))
-  (loop with from-size of-type array-range = 0
-        and to-size of-type array-range = 0
-        for to-pos of-type array-range = to-start then (+ to-pos to-size)
-        for from-pos of-type array-range = from-start then (+ from-pos from-size)
-        while (and (< to-pos to-end)
-                   (< from-pos from-end))
-        do (multiple-value-bind (ts fs) (funcall mapper to-pos from-pos)
-             (setf to-size ts
-                   from-size fs))
-        finally (return (values to-seq to-pos from-pos))))
-

 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
 ;;; and fix it, or else replace with SYMBOLICATE.
 ;;;
 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
 ;;; and fix it, or else replace with SYMBOLICATE.
 ;;;

@@ -172,37 +152,88 @@ one-past-the-end"
 
 ;;; to latin (including ascii)
 
 
 ;;; to latin (including ascii)
 

+;;; Converting bytes to character codes is easy: just use a 256-element
+;;; lookup table that maps each possible byte to its corresponding
+;;; character code.
+;;;
+;;; Converting character codes to bytes is a little harder, since the
+;;; codes may be spare (e.g. we use codes 0-127, 3490, and 4598).  The
+;;; previous version of this macro utilized a gigantic CASE expression
+;;; to do the hard work, with the result that the code was huge (since
+;;; SBCL's then-current compilation strategy for CASE expressions was
+;;; (and still is) converting CASE into COND into if-the-elses--which is
+;;; also inefficient unless your code happens to occur very early in the
+;;; chain.
+;;;
+;;; The current strategy is to build a table:
+;;;
+;;; [ ... code_1 byte_1 code_2 byte_2 ... code_n byte_n ... ]
+;;;
+;;; such that the codes are sorted in order from lowest to highest.  We
+;;; can then binary search the table to discover the appropriate byte
+;;; for a character code.  We also implement an optimization: all unibyte
+;;; mappings do not remap ASCII (0-127) and some do not remap part of
+;;; the range beyond character code 127.  So we check to see if the
+;;; character code falls into that range first (a quick check, since
+;;; character codes are guaranteed to be positive) and then do the binary
+;;; search if not.  This optimization also enables us to cut down on the
+;;; size of our lookup table.

 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)

-  `(progn
-    (declaim (inline ,byte-char-name))
-    (defun ,byte-char-name (byte)
-      (declare (optimize speed (safety 0))
-               (type (unsigned-byte 8) byte))
-      (aref ,(make-array 256
-                         :initial-contents (loop for byte below 256
-                                                 collect
-                                                  (let ((exception (cadr (assoc byte exceptions))))
-                                                    (if exception
-                                                        exception
-                                                        byte))))
-            byte))
-    ;; This used to be inlined, but it caused huge slowdowns in SBCL builds,
-    ;; bloated the core by about 700k on x86-64. Removing the inlining
-    ;; didn't seem to have any performance effect. -- JES, 2005-10-15
-    (defun ,code-byte-name (code)
-      (declare (optimize speed (safety 0))
-               (type char-code code))
-      ;; FIXME: I'm not convinced doing this with CASE is a good idea as
-      ;; long as it's just macroexpanded into a stupid COND. Consider
-      ;; for example the output of (DISASSEMBLE 'SB-IMPL::CODE->CP1250-MAPPER)
-      ;; -- JES, 2005-10-15
-      (case code
-        ,@(mapcar (lambda (exception)
-                    (destructuring-bind (byte code) exception
-                      `(,code ,byte)))
-                  exceptions)
-        (,(mapcar #'car exceptions) nil)
-        (otherwise (if (< code 256) code nil))))))
+  (let* (;; Build a list of (CODE BYTE) pairs
+         (pairs (loop for byte below 256
+                   for code = (let ((exception (cdr (assoc byte exceptions))))
+                                (cond
+                                  ((car exception) (car exception))
+                                  ((null exception) byte)
+                                  (t nil)))
+                   when code collect (list code byte) into elements
+                   finally (return elements)))
+         ;; Find the smallest character code such that the corresponding
+         ;; byte is != to the code.
+         (lowest-non-equivalent-code (position-if-not #'(lambda (pair)
+                                                          (apply #'= pair))
+                                                      pairs))
+         ;; Sort them for our lookup table.
+         (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
+                             #'< :key #'car))
+         ;; Create the lookup table.
+         (sorted-lookup-table
+          (reduce #'append sorted-pairs :from-end t :initial-value nil)))
+    `(progn
+       ; Can't inline it with a non-null lexical environment anyway.
+       ;(declaim (inline ,byte-char-name))
+       (let ((byte-to-code-table
+              ,(make-array 256 :element-type t #+nil 'char-code
+                           :initial-contents (loop for byte below 256
+                                                collect
+                                                (let ((exception (cadr (assoc byte exceptions))))
+                                                  (if exception
+                                                      exception
+                                                      byte)))))
+             (code-to-byte-table
+              ,(make-array (length sorted-lookup-table)
+                           :initial-contents sorted-lookup-table)))
+         (defun ,byte-char-name (byte)
+           (declare (optimize speed (safety 0))
+                    (type (unsigned-byte 8) byte))
+           (aref byte-to-code-table byte))
+         (defun ,code-byte-name (code)
+           (declare (optimize speed (safety 0))
+                    (type char-code code))
+           (if (< code ,lowest-non-equivalent-code)
+               code
+               ;; We could toss in some TRULY-THEs if we really needed to
+               ;; make this faster...
+               (loop with low = 0
+                  with high = (- (length code-to-byte-table) 2)
+                  while (< low high)
+                  do (let ((mid (logandc2 (truncate (+ low high 2) 2) 1)))
+                       (if (< code (aref code-to-byte-table mid))
+                           (setf high (- mid 2))
+                           (setf low mid)))
+                  finally (return (if (eql code (aref code-to-byte-table low))
+                                      (aref code-to-byte-table (1+ low))
+                                      nil)))))))))

 
 #!+sb-unicode
 (define-unibyte-mapper
 
 #!+sb-unicode
 (define-unibyte-mapper

@@ -218,8 +249,7 @@ one-past-the-end"
   (#xBE #x0178))
 
 (declaim (inline get-latin-bytes))
   (#xBE #x0178))
 
 (declaim (inline get-latin-bytes))

-(defun get-latin-bytes (mapper external-format string pos end)
-  (declare (ignore end))
+(defun get-latin-bytes (mapper external-format string pos)

   (let ((code (funcall mapper (char-code (char string pos)))))
     (declare (type (or null char-code) code))
     (values (cond
   (let ((code (funcall mapper (char-code (char string pos)))))
     (declare (type (or null char-code) code))
     (values (cond

@@ -237,47 +267,80 @@ one-past-the-end"
       code))
 
 (declaim (inline get-ascii-bytes))
       code))
 
 (declaim (inline get-ascii-bytes))

-(defun get-ascii-bytes (string pos end)
+(defun get-ascii-bytes (string pos)

   (declare (optimize speed (safety 0))
            (type simple-string string)
   (declare (optimize speed (safety 0))
            (type simple-string string)

-           (type array-range pos end))
-  (get-latin-bytes #'code->ascii-mapper :ascii string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->ascii-mapper :ascii string pos))

 
 (declaim (inline get-latin1-bytes))
 
 (declaim (inline get-latin1-bytes))

-(defun get-latin1-bytes (string pos end)
+(defun get-latin1-bytes (string pos)

   (declare (optimize speed (safety 0))
            (type simple-string string)
   (declare (optimize speed (safety 0))
            (type simple-string string)

-           (type array-range pos end))
-  (get-latin-bytes #'identity :latin-1 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'identity :latin-1 string pos))

 
 #!+sb-unicode
 (progn
   (declaim (inline get-latin9-bytes))
 
 #!+sb-unicode
 (progn
   (declaim (inline get-latin9-bytes))

-  (defun get-latin9-bytes (string pos end)
+  (defun get-latin9-bytes (string pos)

     (declare (optimize speed (safety 0))
              (type simple-string string)
     (declare (optimize speed (safety 0))
              (type simple-string string)

-             (type array-range pos end))
-    (get-latin-bytes #'code->latin9-mapper :latin-9 string pos end)))
+             (type array-range pos))
+    (get-latin-bytes #'code->latin9-mapper :latin-9 string pos)))

 
 (declaim (inline string->latin%))
 (defun string->latin% (string sstart send get-bytes null-padding)
   (declare (optimize speed)
            (type simple-string string)
 
 (declaim (inline string->latin%))
 (defun string->latin% (string sstart send get-bytes null-padding)
   (declare (optimize speed)
            (type simple-string string)

-           (type array-range sstart send null-padding)
+           (type index sstart send)
+           (type (integer 0 1) null-padding)

            (type function get-bytes))
            (type function get-bytes))

-  (let ((octets (make-array 0 :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8))))
-    (loop for pos from sstart below send
-          do (let ((byte-or-bytes (funcall get-bytes string pos send)))
-               (declare (type (or (unsigned-byte 8) (simple-array (unsigned-byte 8) (*))) byte-or-bytes))
-               (cond
-                 ((numberp byte-or-bytes)
-                  (vector-push-extend byte-or-bytes octets))
-                 (t
-                  (dotimes (i (length byte-or-bytes))
-                    (vector-push-extend (aref byte-or-bytes i) octets))))))
-    (dotimes (i null-padding)
-      (vector-push-extend 0 octets))
-    (coerce octets '(simple-array (unsigned-byte 8) (*)))))
+  ;; The latin encodings are all unibyte encodings, so just directly
+  ;; compute the number of octets we're going to generate.
+  (let ((octets (make-array (+ (- send sstart) null-padding)
+                            ;; This takes care of any null padding the
+                            ;; caller requests.
+                            :initial-element 0
+                            :element-type '(unsigned-byte 8)))
+        (index 0)
+        (error-position 0))
+    (tagbody
+     :no-error
+       (loop for pos of-type index from sstart below send
+          do (let ((byte (funcall get-bytes string pos)))
+               (typecase byte
+                 ((unsigned-byte 8)
+                  (locally (declare (optimize (sb!c::insert-array-bounds-checks 0)))
+                    (setf (aref octets index) byte)))
+                 ((simple-array (unsigned-byte 8) (*))
+                  ;; KLUDGE: We ran into encoding errors.  Bail and do
+                  ;; things the slow way (does anybody actually use this
+                  ;; functionality besides our own test suite?).
+                  (setf error-position pos)
+                  (go :error)))
+               (incf index))
+          finally (return-from string->latin% octets))
+     :error
+       ;; We have encoded INDEX octets so far and we ran into an encoding
+       ;; error at ERROR-POSITION.
+       (let ((new-octets (make-array (* index 2)
+                                     :element-type '(unsigned-byte 8)
+                                     :adjustable t :fill-pointer index)))
+         (replace new-octets octets)
+         (loop for pos of-type index from error-position below send
+            do (let ((thing (funcall get-bytes string pos)))
+                 (typecase thing
+                   ((unsigned-byte 8)
+                    (vector-push-extend thing new-octets))
+                   ((simple-array (unsigned-byte 8) (*))
+                    (dotimes (i (length thing))
+                      (vector-push-extend (aref thing i) new-octets)))))
+            finally (return-from string->latin%
+                      (progn
+                        (unless (zerop null-padding)
+                          (vector-push-extend 0 new-octets))
+                        (copy-seq new-octets))))))))

 
 (defun string->ascii (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (defun string->ascii (string sstart send null-padding)
   (declare (optimize speed (safety 0))

@@ -311,44 +374,62 @@ one-past-the-end"
         ((< code #x110000) 4)
         (t (bug "can't happen"))))
 
         ((< code #x110000) 4)
         (t (bug "can't happen"))))
 

-(declaim (inline char->utf8))
-(defun char->utf8 (char dest)
-  (declare (optimize speed (safety 0))
-           (type (array (unsigned-byte 8) (*)) dest))
-  (let ((code (char-code char)))
-    (flet ((add-byte (b)
-             (declare (type (unsigned-byte 8) b))
-             (vector-push-extend b dest)))
-      (declare (inline add-byte))
-      (ecase (char-len-as-utf8 code)
-        (1
-         (add-byte code))
-        (2
-         (add-byte (logior #b11000000 (ldb (byte 5 6) code)))
-         (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
-        (3
-         (add-byte (logior #b11100000 (ldb (byte 4 12) code)))
-         (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
-         (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
-        (4
-         (add-byte (logior #b11110000 (ldb (byte 3 18) code)))
-         (add-byte (logior #b10000000 (ldb (byte 6 12) code)))
-         (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
-         (add-byte (logior #b10000000 (ldb (byte 6 0) code))))))))
-
-(defun string->utf8 (string sstart send additional-space)
-  (declare (optimize speed (safety 0))
+(defun string->utf8 (string sstart send null-padding)
+  (declare (optimize (speed 3) (safety 0))

            (type simple-string string)
            (type simple-string string)

-           (type array-range sstart send additional-space))
-  (let ((array (make-array (+ additional-space (- send sstart))
-                           :element-type '(unsigned-byte 8)
-                           :adjustable t
-                           :fill-pointer 0)))
-    (loop for i from sstart below send
-          do (char->utf8 (char string i) array))
-    (dotimes (i additional-space)
-      (vector-push-extend 0 array))
-    (coerce array '(simple-array (unsigned-byte 8) (*)))))
+           (type (integer 0 1) null-padding)
+           (type array-range sstart send))
+  (macrolet ((ascii-bash ()
+               '(let ((array (make-array (+ null-padding (- send sstart))
+                                         :element-type '(unsigned-byte 8))))
+                 (loop for i from 0
+                       and j from sstart below send
+                       do (setf (aref array i) (char-code (char string j))))
+                 array)))
+    (etypecase string
+      ((simple-array character (*))
+       (let ((utf8-length 0))
+         ;; Since it has to fit in a vector, it must be a fixnum!
+         (declare (type (and unsigned-byte fixnum) utf8-length))
+         (loop for i of-type index from sstart below send
+               do (incf utf8-length (char-len-as-utf8 (char-code (char string i)))))
+         (if (= utf8-length (- send sstart))
+             (ascii-bash)
+             (let ((array (make-array (+ null-padding utf8-length)
+                                      :element-type '(unsigned-byte 8)))
+                   (index 0))
+               (declare (type index index))
+               (flet ((add-byte (b)
+                        (setf (aref array index) b)
+                        (incf index)))
+                 (declare (inline add-byte))
+                 (loop for i of-type index from sstart below send
+                       do (let ((code (char-code (char string i))))
+                            (case (char-len-as-utf8 code)
+                              (1
+                               (add-byte code))
+                              (2
+                               (add-byte (logior #b11000000 (ldb (byte 5 6) code)))
+                               (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
+                              (3
+                               (add-byte (logior #b11100000 (ldb (byte 4 12) code)))
+                               (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
+                               (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
+                              (4
+                               (add-byte (logior #b11110000 (ldb (byte 3 18) code)))
+                               (add-byte (logior #b10000000 (ldb (byte 6 12) code)))
+                               (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
+                               (add-byte (logior #b10000000 (ldb (byte 6 0) code))))))
+                       finally (return array)))))))
+      #!+sb-unicode
+      ((simple-array base-char (*))
+       ;; On unicode builds BASE-STRINGs are limited to ASCII range, so we can take
+       ;; a fast path -- and get benefit of the element type information. On non-unicode
+       ;; build BASE-CHAR == CHARACTER.
+       (ascii-bash))
+      ((simple-array nil (*))
+       ;; Just get the error...
+       (aref string sstart)))))

 \f
 ;;;; to-string conversions
 
 \f
 ;;;; to-string conversions
 

@@ -388,11 +469,11 @@ one-past-the-end"
                  (type ,type array)
                  (type array-range sstart send astart aend)
                  (function mapper))
                  (type ,type array)
                  (type array-range sstart send astart aend)
                  (function mapper))

-        (varimap string sstart send
-                 astart aend
-                 (lambda (spos apos)
-                   (setf (char string spos) (code-char (funcall mapper (,accessor array apos))))
-                   (values 1 1)))))))
+        (loop for spos from sstart below send
+           for apos from astart below aend
+           do (setf (char string spos)
+                    (code-char (funcall mapper (,accessor array apos))))
+           finally (return (values string spos apos)))))))

 (instantiate-octets-definition define-latin->string*)
 
 (defmacro define-latin1->string* (accessor type)
 (instantiate-octets-definition define-latin->string*)
 
 (defmacro define-latin1->string* (accessor type)

@@ -416,7 +497,7 @@ one-past-the-end"
 (defmacro define-latin->string (accessor type)
   (let ((name (make-od-name 'latin->string accessor)))
     `(progn
 (defmacro define-latin->string (accessor type)
   (let ((name (make-od-name 'latin->string accessor)))
     `(progn

-      (declaim (inline latin->string))
+      (declaim (inline ,name))

       (defun ,name (array astart aend mapper)
         (declare (optimize speed (safety 0))
                  (type ,type array)
       (defun ,name (array astart aend mapper)
         (declare (optimize speed (safety 0))
                  (type ,type array)

@@ -503,7 +584,7 @@ one-past-the-end"
                             ;; two-byte sequence `"initial (length 3)"
                             ;; "non-continuation"' -- `#xef #x32')
                             ;; signal only part of that sequence as
                             ;; two-byte sequence `"initial (length 3)"
                             ;; "non-continuation"' -- `#xef #x32')
                             ;; signal only part of that sequence as

-                            ;; erronous.
+                            ;; erroneous.

                             (loop for i from 1 below (min len remaining-bytes)
                                   always (valid-secondary-p i))
                             (enough-bytes-left-p len)))
                             (loop for i from 1 below (min len remaining-bytes)
                                   always (valid-secondary-p i))
                             (enough-bytes-left-p len)))

@@ -641,19 +722,38 @@ one-past-the-end"
 
 (defun default-external-format ()
   (or *default-external-format*
 
 (defun default-external-format ()
   (or *default-external-format*

-      (let ((external-format (intern (or #!-win32 (sb!alien:alien-funcall
-                                          (extern-alien
-                                           "nl_langinfo"
-                                           (function c-string int))
-                                          sb!unix:codeset)
-                                         "LATIN-1")
-                                     "KEYWORD")))
+      ;; On non-unicode, use iso-8859-1 instead of detecting it from
+      ;; the locale settings. Defaulting to an external-format which
+      ;; can represent characters that the CHARACTER type can't
+      ;; doesn't seem very sensible.
+      #!-sb-unicode
+      (setf *default-external-format* :latin-1)
+      (let ((external-format #!-win32 (intern (or (sb!alien:alien-funcall
+                                                    (extern-alien
+                                                      "nl_langinfo"
+                                                      (function (c-string :external-format :latin-1)
+                                                                int))
+                                                    sb!unix:codeset)
+                                                  "LATIN-1")
+                                              "KEYWORD")
+                             #!+win32 (sb!win32::ansi-codepage)))

         (/show0 "cold-printing defaulted external-format:")
         #!+sb-show
         (cold-print external-format)
         (/show0 "matching to known aliases")
         (dolist (entry *external-formats*
                  (progn
         (/show0 "cold-printing defaulted external-format:")
         #!+sb-show
         (cold-print external-format)
         (/show0 "matching to known aliases")
         (dolist (entry *external-formats*
                  (progn

+                   ;;; FIXME! This WARN would try to do printing
+                   ;;; before the streams have been initialized,
+                   ;;; causing an infinite erroring loop. We should
+                   ;;; either print it by calling to C, or delay the
+                   ;;; warning until later. Since we're in freeze
+                   ;;; right now, and the warning isn't really
+                   ;;; essential, I'm doing what's least likely to
+                   ;;; cause damage, and commenting it out. This
+                   ;;; should be revisited after 0.9.17. -- JES,
+                   ;;; 2006-09-21
+                   #+nil

                    (warn "Invalid external-format ~A; using LATIN-1"
                          external-format)
                    (setf external-format :latin-1)))
                    (warn "Invalid external-format ~A; using LATIN-1"
                          external-format)
                    (setf external-format :latin-1)))

@@ -668,23 +768,28 @@ one-past-the-end"
         (setf *default-external-format* external-format))))
 
 ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
         (setf *default-external-format* external-format))))
 
 ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp

-(defparameter *external-format-functions*
-  '(((:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|)
-     ascii->string-aref string->ascii)
-    ((:latin1 :latin-1 :iso-8859-1 :iso8859-1)
-     latin1->string-aref string->latin1)
-    #!+sb-unicode
-    ((:latin9 :latin-9 :iso-8859-15 :iso8859-15)
-     latin9->string-aref string->latin9)
-    ((:utf8 :utf-8)
-     utf8->string-aref string->utf8)))
+(defparameter *external-format-functions* (make-hash-table))
+
+(defun add-external-format-funs (format-names funs)
+  (dolist (name format-names (values))
+    (setf (gethash name *external-format-functions*) funs)))
+
+(add-external-format-funs
+ '(:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|)
+ '(ascii->string-aref string->ascii))
+(add-external-format-funs
+ '(:latin1 :latin-1 :iso-8859-1 :iso8859-1)
+ '(latin1->string-aref string->latin1))
+#!+sb-unicode
+(add-external-format-funs
+ '(:latin9 :latin-9 :iso-8859-15 :iso8859-15)
+ '(latin9->string-aref string->latin9))
+(add-external-format-funs '(:utf8 :utf-8) '(utf8->string-aref string->utf8))

 
 (defun external-formats-funs (external-format)
   (when (eql external-format :default)
     (setf external-format (default-external-format)))
 
 (defun external-formats-funs (external-format)
   (when (eql external-format :default)
     (setf external-format (default-external-format)))

-  (or (cdr (find external-format (the list *external-format-functions*)
-                 :test #'member
-                 :key #'car))
+  (or (gethash external-format *external-format-functions*)

       (error "Unknown external-format ~S" external-format)))
 \f
 ;;;; public interface
       (error "Unknown external-format ~S" external-format)))
 \f
 ;;;; public interface

@@ -693,7 +798,8 @@ one-past-the-end"
   (declare (type (vector (unsigned-byte 8)) vector))
   (with-array-data ((vector vector)
                     (start start)
   (declare (type (vector (unsigned-byte 8)) vector))
   (with-array-data ((vector vector)
                     (start start)

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

     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
     (funcall (symbol-function (first (external-formats-funs external-format)))
              vector start end)))
     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
     (funcall (symbol-function (first (external-formats-funs external-format)))
              vector start end)))

@@ -703,7 +809,8 @@ one-past-the-end"
   (declare (type string string))
   (with-array-data ((string string)
                     (start start)
   (declare (type string string))
   (with-array-data ((string string)
                     (start start)

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

     (declare (type simple-string string))
     (funcall (symbol-function (second (external-formats-funs external-format)))
              string start end (if null-terminate 1 0))))
     (declare (type simple-string string))
     (funcall (symbol-function (second (external-formats-funs external-format)))
              string start end (if null-terminate 1 0))))