Remove duplicate implementations of (setf aref/sbit/bit).

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

diff --git a/src/code/octets.lisp b/src/code/octets.lisp
index eb87cd1..4a98d80 100644 (file)
--- a/src/code/octets.lisp
+++ b/src/code/octets.lisp
@@ -38,12 +38,6 @@ one-past-the-end"
                                       (octets-encoding-error-position c)))
                      (octets-encoding-error-external-format c)))))
 
                                       (octets-encoding-error-position c)))
                      (octets-encoding-error-external-format c)))))
 

-(defun read-replacement-character ()
-  (format *query-io*
-          "Replacement byte, bytes, character, or string (evaluated): ")
-  (finish-output *query-io*)
-  (list (eval (read *query-io*))))
-

 (defun encoding-error (external-format string pos)
   (restart-case
       (error 'octets-encoding-error
 (defun encoding-error (external-format string pos)
   (restart-case
       (error 'octets-encoding-error

@@ -52,7 +46,10 @@ one-past-the-end"
              :position pos)
     (use-value (replacement)
       :report "Supply a set of bytes to use in place of the invalid one."
              :position pos)
     (use-value (replacement)
       :report "Supply a set of bytes to use in place of the invalid one."

-      :interactive read-replacement-character
+      :interactive
+      (lambda ()
+        (read-evaluated-form
+         "Replacement byte, bytes, character, or string (evaluated): "))

       (typecase replacement
         ((unsigned-byte 8)
          (make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement))
       (typecase replacement
         ((unsigned-byte 8)
          (make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement))

@@ -74,20 +71,13 @@ one-past-the-end"
 ;;;   character-out-of-range
 ;;;   invalid-utf8-starter-byte
 ;;;   invalid-utf8-continuation-byte
 ;;;   character-out-of-range
 ;;;   invalid-utf8-starter-byte
 ;;;   invalid-utf8-continuation-byte

-;;;   overlong-utf8-sequence

 ;;;
 ;;; Of these, the only one truly likely to be of interest to calling
 ;;; code is end-of-input-in-character (in which case it's likely to
 ;;; want to make a note of octet-decoding-error-start, supply "" as a
 ;;; replacement string, and then move that last chunk of bytes to the
 ;;; beginning of its buffer for the next go round) but they're all
 ;;;
 ;;; Of these, the only one truly likely to be of interest to calling
 ;;; code is end-of-input-in-character (in which case it's likely to
 ;;; want to make a note of octet-decoding-error-start, supply "" as a
 ;;; replacement string, and then move that last chunk of bytes to the
 ;;; beginning of its buffer for the next go round) but they're all

-;;; provided on the off chance they're of interest.  The next most
-;;; likely interesting option is overlong-utf8-sequence -- the
-;;; application, if it cares to, can decode this itself (taking care
-;;; to ensure that the result isn't out of range of CHAR-CODE-LIMIT)
-;;; and return that result.  This library doesn't provide support for
-;;; that as a conforming UTF-8-using program is supposed to treat it
-;;; as an error.
+;;; provided on the off chance they're of interest.

 
 (define-condition octet-decoding-error (character-decoding-error)
   ((array :initarg :array :accessor octet-decoding-error-array)
 
 (define-condition octet-decoding-error (character-decoding-error)
   ((array :initarg :array :accessor octet-decoding-error-array)

@@ -110,11 +100,6 @@ one-past-the-end"
 
 (define-condition malformed-ascii (octet-decoding-error) ())
 
 
 (define-condition malformed-ascii (octet-decoding-error) ())
 

-(defun read-replacement-string ()
-  (format *query-io* "Enter a replacement string designator (evaluated): ")
-  (finish-output *query-io*)
-  (list (eval (read *query-io*))))
-

 (defun decoding-error (array start end external-format reason pos)
   (restart-case
       (error reason
 (defun decoding-error (array start end external-format reason pos)
   (restart-case
       (error reason

@@ -125,7 +110,10 @@ one-past-the-end"
              :pos pos)
     (use-value (s)
       :report "Supply a replacement string designator."
              :pos pos)
     (use-value (s)
       :report "Supply a replacement string designator."

-      :interactive read-replacement-string
+      :interactive
+      (lambda ()
+        (read-evaluated-form
+         "Enter a replacement string designator (evaluated): "))

       (string s))))
 
 ;;; Utilities used in both to-string and to-octet conversions
       (string s))))
 
 ;;; Utilities used in both to-string and to-octet conversions

@@ -135,26 +123,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.
 ;;;

@@ -210,9 +178,8 @@ one-past-the-end"
                    finally (return elements)))
          ;; Find the smallest character code such that the corresponding
          ;; byte is != to the code.
                    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))
+         (lowest-non-equivalent-code
+          (caar (sort (copy-seq exceptions) #'< :key #'car)))

          ;; Sort them for our lookup table.
          (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
                              #'< :key #'car))
          ;; Sort them for our lookup table.
          (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
                              #'< :key #'car))

@@ -226,9 +193,9 @@ one-past-the-end"
               ,(make-array 256 :element-type t #+nil 'char-code
                            :initial-contents (loop for byte below 256
                                                 collect
               ,(make-array 256 :element-type t #+nil 'char-code
                            :initial-contents (loop for byte below 256
                                                 collect

-                                                (let ((exception (cadr (assoc byte exceptions))))
+                                                (let ((exception (cdr (assoc byte exceptions))))

                                                   (if exception
                                                   (if exception

-                                                      exception
+                                                      (car exception)

                                                       byte)))))
              (code-to-byte-table
               ,(make-array (length sorted-lookup-table)
                                                       byte)))))
              (code-to-byte-table
               ,(make-array (length sorted-lookup-table)

@@ -255,19 +222,6 @@ one-past-the-end"
                                       (aref code-to-byte-table (1+ low))
                                       nil)))))))))
 
                                       (aref code-to-byte-table (1+ low))
                                       nil)))))))))
 

-#!+sb-unicode
-(define-unibyte-mapper
-    latin9->code-mapper
-    code->latin9-mapper
-  (#xA4 #x20AC)
-  (#xA6 #x0160)
-  (#xA8 #x0161)
-  (#xB4 #x017D)
-  (#xB8 #x017E)
-  (#xBC #x0152)
-  (#xBD #x0153)
-  (#xBE #x0178))
-

 (declaim (inline get-latin-bytes))
 (defun get-latin-bytes (mapper external-format string pos)
   (let ((code (funcall mapper (char-code (char string pos)))))
 (declaim (inline get-latin-bytes))
 (defun get-latin-bytes (mapper external-format string pos)
   (let ((code (funcall mapper (char-code (char string pos)))))

@@ -278,37 +232,6 @@ one-past-the-end"
                (encoding-error external-format string pos)))
             1)))
 
                (encoding-error external-format string pos)))
             1)))
 

-(declaim (inline code->ascii-mapper))
-(defun code->ascii-mapper (code)
-  (declare (optimize speed (safety 0))
-           (type char-code code))
-  (if (> code 127)
-      nil
-      code))
-
-(declaim (inline get-ascii-bytes))
-(defun get-ascii-bytes (string pos)
-  (declare (optimize speed (safety 0))
-           (type simple-string string)
-           (type array-range pos))
-  (get-latin-bytes #'code->ascii-mapper :ascii string pos))
-
-(declaim (inline get-latin1-bytes))
-(defun get-latin1-bytes (string pos)
-  (declare (optimize speed (safety 0))
-           (type simple-string string)
-           (type array-range pos))
-  (get-latin-bytes #'identity :latin-1 string pos))
-
-#!+sb-unicode
-(progn
-  (declaim (inline get-latin9-bytes))
-  (defun get-latin9-bytes (string pos)
-    (declare (optimize speed (safety 0))
-             (type simple-string string)
-             (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)
 (declaim (inline string->latin%))
 (defun string->latin% (string sstart send get-bytes null-padding)
   (declare (optimize speed)

@@ -324,7 +247,8 @@ one-past-the-end"
                             :initial-element 0
                             :element-type '(unsigned-byte 8)))
         (index 0)
                             :initial-element 0
                             :element-type '(unsigned-byte 8)))
         (index 0)

-        (error-position 0))
+        (error-position 0)
+        (error-replacement))

     (tagbody
      :no-error
        (loop for pos of-type index from sstart below send
     (tagbody
      :no-error
        (loop for pos of-type index from sstart below send

@@ -337,147 +261,37 @@ one-past-the-end"
                   ;; KLUDGE: We ran into encoding errors.  Bail and do
                   ;; things the slow way (does anybody actually use this
                   ;; functionality besides our own test suite?).
                   ;; 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)
+                  (setf error-position pos error-replacement byte)

                   (go :error)))
                (incf index))
           finally (return-from string->latin% octets))
      :error
                   (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.
+       ;; We have encoded INDEX octets so far and we ran into an
+       ;; encoding error at ERROR-POSITION; the user has asked us to
+       ;; replace the expected output with ERROR-REPLACEMENT.

        (let ((new-octets (make-array (* index 2)
                                      :element-type '(unsigned-byte 8)
                                      :adjustable t :fill-pointer index)))
          (replace new-octets octets)
        (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)))
+         (flet ((extend (thing)

                  (typecase thing
                  (typecase thing

-                   ((unsigned-byte 8)
-                    (vector-push-extend thing new-octets))
+                   ((unsigned-byte 8) (vector-push-extend thing new-octets))

                    ((simple-array (unsigned-byte 8) (*))
                     (dotimes (i (length thing))
                    ((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))
-           (type simple-string string)
-           (type array-range sstart send))
-  (values (string->latin% string sstart send #'get-ascii-bytes null-padding)))
-
-(defun string->latin1 (string sstart send null-padding)
-  (declare (optimize speed (safety 0))
-           (type simple-string string)
-           (type array-range sstart send))
-  (values (string->latin% string sstart send #'get-latin1-bytes null-padding)))
-
-#!+sb-unicode
-(defun string->latin9 (string sstart send null-padding)
-  (declare (optimize speed (safety 0))
-           (type simple-string string)
-           (type array-range sstart send))
-  (values (string->latin% string sstart send #'get-latin9-bytes null-padding)))
-
-;;; to utf8
-
-(declaim (inline char-len-as-utf8))
-(defun char-len-as-utf8 (code)
-  (declare (optimize speed (safety 0))
-           (type (integer 0 (#.sb!xc:char-code-limit)) code))
-  (cond ((< code 0) (bug "can't happen"))
-        ((< code #x80) 1)
-        ((< code #x800) 2)
-        ((< code #x10000) 3)
-        ((< code #x110000) 4)
-        (t (bug "can't happen"))))
-
-(defun string->utf8 (string sstart send null-padding)
-  (declare (optimize (speed 3) (safety 0))
-           (type simple-string string)
-           (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 sstart below send
-                       do (setf (aref array i) (char-code (char string i))))
-                 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)))))
+                      (vector-push-extend (aref thing i) new-octets))))))
+           (extend error-replacement)
+           (loop for pos of-type index from (1+ error-position) below send
+                 do (extend (funcall get-bytes string pos))
+                 finally (return-from string->latin%
+                           (progn
+                             (unless (zerop null-padding)
+                               (vector-push-extend 0 new-octets))
+                             (copy-seq new-octets)))))))))

 \f
 ;;;; to-string conversions
 
 ;;; from latin (including ascii)
 
 \f
 ;;;; to-string conversions
 
 ;;; from latin (including ascii)
 

-(defmacro define-ascii->string (accessor type)
-  (let ((name (make-od-name 'ascii->string accessor)))
-    `(progn
-      (defun ,name (array astart aend)
-        (declare (optimize speed)
-                 (type ,type array)
-                 (type array-range astart aend))
-        ;; Since there is such a thing as a malformed ascii byte, a
-        ;; simple "make the string, fill it in" won't do.
-        (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
-          (loop for apos from astart below aend
-                do (let* ((code (,accessor array apos))
-                          (string-content
-                           (if (< code 128)
-                               (code-char code)
-                               (decoding-error array apos (1+ apos) :ascii
-                                               'malformed-ascii apos))))
-                     (if (characterp string-content)
-                         (vector-push-extend string-content string)
-                         (loop for c across string-content
-                               do (vector-push-extend c string))))
-                finally (return (coerce string 'simple-string))))))))
-(instantiate-octets-definition define-ascii->string)
-

 (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

@@ -488,35 +302,17 @@ 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*)
 
 (instantiate-octets-definition define-latin->string*)
 

-(defmacro define-latin1->string* (accessor type)
-  (declare (ignore type))
-  (let ((name (make-od-name 'latin1->string* accessor)))
-    `(progn
-      (defun ,name (string sstart send array astart aend)
-        (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity)))))
-(instantiate-octets-definition define-latin1->string*)
-
-#!+sb-unicode
-(progn
-  (defmacro define-latin9->string* (accessor type)
-    (declare (ignore type))
-    (let ((name (make-od-name 'latin9->string* accessor)))
-      `(progn
-        (defun ,name (string sstart send array astart aend)
-          (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'latin9->code-mapper)))))
-  (instantiate-octets-definition define-latin9->string*))
-

 (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)

@@ -527,213 +323,6 @@ one-past-the-end"
                                                             array astart aend
                                                             mapper)))))))
 (instantiate-octets-definition define-latin->string)
                                                             array astart aend
                                                             mapper)))))))
 (instantiate-octets-definition define-latin->string)

-
-(defmacro define-latin1->string (accessor type)
-  (declare (ignore type))
-  `(defun ,(make-od-name 'latin1->string accessor) (array astart aend)
-    (,(make-od-name 'latin->string accessor) array astart aend #'identity)))
-(instantiate-octets-definition define-latin1->string)
-
-#!+sb-unicode
-(progn
-  (defmacro define-latin9->string (accessor type)
-    (declare (ignore type))
-    `(defun ,(make-od-name 'latin9->string accessor) (array astart aend)
-      (,(make-od-name 'latin->string accessor) array astart aend #'latin9->code-mapper)))
-  (instantiate-octets-definition define-latin9->string))
-
-;;; from utf8
-
-(defmacro define-bytes-per-utf8-character (accessor type)
-  (let ((name (make-od-name 'bytes-per-utf8-character accessor)))
-    `(progn
-      ;;(declaim (inline ,name))
-      (let ((lexically-max
-             (string->utf8 (string (code-char ,(1- sb!xc:char-code-limit)))
-                           0 1 0)))
-        (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max))
-        (defun ,name (array pos end)
-          (declare (optimize speed (safety 0))
-                   (type ,type array)
-                   (type array-range pos end))
-          ;; returns the number of bytes consumed and nil if it's a
-          ;; valid character or the number of bytes consumed and a
-          ;; replacement string if it's not.
-          (let ((initial-byte (,accessor array pos))
-                (reject-reason nil)
-                (reject-position pos)
-                (remaining-bytes (- end pos)))
-            (declare (type array-range reject-position remaining-bytes))
-            (labels ((valid-utf8-starter-byte-p (b)
-                       (declare (type (unsigned-byte 8) b))
-                       (let ((ok (cond
-                                   ((zerop (logand b #b10000000)) 1)
-                                   ((= (logand b #b11100000) #b11000000)
-                                    2)
-                                   ((= (logand b #b11110000) #b11100000)
-                                    3)
-                                   ((= (logand b #b11111000) #b11110000)
-                                    4)
-                                   ((= (logand b #b11111100) #b11111000)
-                                    5)
-                                   ((= (logand b #b11111110) #b11111100)
-                                    6)
-                                   (t
-                                    nil))))
-                         (unless ok
-                           (setf reject-reason 'invalid-utf8-starter-byte))
-                         ok))
-                     (enough-bytes-left-p (x)
-                       (let ((ok (> end (+ pos (1- x)))))
-                         (unless ok
-                           (setf reject-reason 'end-of-input-in-character))
-                         ok))
-                     (valid-secondary-p (x)
-                       (let* ((idx (the array-range (+ pos x)))
-                              (b (,accessor array idx))
-                              (ok (= (logand b #b11000000) #b10000000)))
-                         (unless ok
-                           (setf reject-reason 'invalid-utf8-continuation-byte)
-                           (setf reject-position idx))
-                         ok))
-                     (preliminary-ok-for-length (maybe-len len)
-                       (and (eql maybe-len len)
-                            ;; Has to be done in this order so that
-                            ;; certain broken sequences (e.g., the
-                            ;; two-byte sequence `"initial (length 3)"
-                            ;; "non-continuation"' -- `#xef #x32')
-                            ;; signal only part of that sequence as
-                            ;; erroneous.
-                            (loop for i from 1 below (min len remaining-bytes)
-                                  always (valid-secondary-p i))
-                            (enough-bytes-left-p len)))
-                     (overlong-chk (x y)
-                       (let ((ok (or (/= initial-byte x)
-                                     (/= (logior (,accessor array (the array-range (+ pos 1)))
-                                                 y)
-                                         y))))
-                         (unless ok
-                           (setf reject-reason 'overlong-utf8-sequence))
-                         ok))
-                     (character-below-char-code-limit-p ()
-                       ;; This is only called on a four-byte sequence
-                       ;; (two in non-unicode builds) to ensure we
-                       ;; don't go over SBCL's character limts.
-                       (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos))
-                                        nil)
-                                       ((> (aref lexically-max 0) (,accessor array pos))
-                                        t)
-                                       ((< (aref lexically-max 1) (,accessor array (+ pos 1)))
-                                        nil)
-                                       #!+sb-unicode
-                                       ((> (aref lexically-max 1) (,accessor array (+ pos 1)))
-                                        t)
-                                       #!+sb-unicode
-                                       ((< (aref lexically-max 2) (,accessor array (+ pos 2)))
-                                        nil)
-                                       #!+sb-unicode
-                                       ((> (aref lexically-max 2) (,accessor array (+ pos 2)))
-                                        t)
-                                       #!+sb-unicode
-                                       ((< (aref lexically-max 3) (,accessor array (+ pos 3)))
-                                        nil)
-                                       (t t))))
-                         (unless ok
-                           (setf reject-reason 'character-out-of-range))
-                         ok)))
-              (declare (inline valid-utf8-starter-byte-p
-                               enough-bytes-left-p
-                               valid-secondary-p
-                               preliminary-ok-for-length
-                               overlong-chk))
-              (let ((maybe-len (valid-utf8-starter-byte-p initial-byte)))
-                (cond ((eql maybe-len 1)
-                       (values 1 nil))
-                      ((and (preliminary-ok-for-length maybe-len 2)
-                            (overlong-chk #b11000000 #b10111111)
-                            (overlong-chk #b11000001 #b10111111)
-                            #!-sb-unicode (character-below-char-code-limit-p))
-                       (values 2 nil))
-                      ((and (preliminary-ok-for-length maybe-len 3)
-                            (overlong-chk #b11100000 #b10011111)
-                            #!-sb-unicode (not (setf reject-reason 'character-out-of-range)))
-                       (values 3 nil))
-                      ((and (preliminary-ok-for-length maybe-len 4)
-                            (overlong-chk #b11110000 #b10001111)
-                            #!-sb-unicode (not (setf reject-reason 'character-out-of-range))
-                            (character-below-char-code-limit-p))
-                       (values 4 nil))
-                      ((and (preliminary-ok-for-length maybe-len 5)
-                            (overlong-chk #b11111000 #b10000111)
-                            (not (setf reject-reason 'character-out-of-range)))
-                       (bug "can't happen"))
-                      ((and (preliminary-ok-for-length maybe-len 6)
-                            (overlong-chk #b11111100 #b10000011)
-                            (not (setf reject-reason 'character-out-of-range)))
-                       (bug "can't happen"))
-                      (t
-                       (let* ((bad-end (ecase reject-reason
-                                         (invalid-utf8-starter-byte
-                                          (1+ pos))
-                                         (end-of-input-in-character
-                                          end)
-                                         (invalid-utf8-continuation-byte
-                                          reject-position)
-                                         ((overlong-utf8-sequence character-out-of-range)
-                                          (+ pos maybe-len))))
-                              (bad-len (- bad-end pos)))
-                         (declare (type array-range bad-end bad-len))
-                         (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position)))
-                           (values bad-len replacement)))))))))))))
-(instantiate-octets-definition define-bytes-per-utf8-character)
-
-(defmacro define-simple-get-utf8-char (accessor type)
-  (let ((name (make-od-name 'simple-get-utf8-char accessor)))
-    `(progn
-      (declaim (inline ,name))
-      (defun ,name (array pos bytes)
-        (declare (optimize speed (safety 0))
-                 (type ,type array)
-                 (type array-range pos)
-                 (type (integer 1 4) bytes))
-        (flet ((cref (x)
-                 (,accessor array (the array-range (+ pos x)))))
-          (declare (inline cref))
-          (code-char (ecase bytes
-                       (1 (cref 0))
-                       (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6)
-                                  (ldb (byte 6 0) (cref 1))))
-                       (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12)
-                                  (ash (ldb (byte 6 0) (cref 1)) 6)
-                                  (ldb (byte 6 0) (cref 2))))
-                       (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18)
-                                  (ash (ldb (byte 6 0) (cref 1)) 12)
-                                  (ash (ldb (byte 6 0) (cref 2)) 6)
-                                  (ldb (byte 6 0) (cref 3)))))))))))
-(instantiate-octets-definition define-simple-get-utf8-char)
-
-(defmacro define-utf8->string (accessor type)
-  (let ((name (make-od-name 'utf8->string accessor)))
-    `(progn
-      (defun ,name (array astart aend)
-        (declare (optimize speed (safety 0))
-                 (type ,type array)
-                 (type array-range astart aend))
-        (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
-          (loop with pos = astart
-                while (< pos aend)
-                do (multiple-value-bind (bytes invalid)
-                       (,(make-od-name 'bytes-per-utf8-character accessor) array pos aend)
-                     (declare (type (or null string) invalid))
-                     (cond
-                       ((null invalid)
-                        (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor) array pos bytes) string))
-                       (t
-                        (dotimes (i (length invalid))
-                          (vector-push-extend (char invalid i) string))))
-                     (incf pos bytes)))
-          (coerce string 'simple-string))))))
-(instantiate-octets-definition define-utf8->string)

 \f
 ;;;; external formats
 
 \f
 ;;;; external formats
 

@@ -760,59 +349,35 @@ one-past-the-end"
         #!+sb-show
         (cold-print external-format)
         (/show0 "matching to known aliases")
         #!+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)))
-          (/show0 "cold printing known aliases:")
-          #!+sb-show
-          (dolist (alias (first entry)) (cold-print alias))
-          (/show0 "done cold-printing known aliases")
-          (when (member external-format (first entry))
-            (/show0 "matched")
-            (return)))
+        (let ((entry (sb!impl::get-external-format external-format)))
+          (cond
+            (entry
+             (/show0 "matched"))
+            (t
+             ;; 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))))

         (/show0 "/default external format ok")
         (setf *default-external-format* external-format))))
         (/show0 "/default external format ok")
         (setf *default-external-format* external-format))))

-
-;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
-(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)))
-  (or (gethash external-format *external-format-functions*)
-      (error "Unknown external-format ~S" external-format)))

 \f
 ;;;; public interface
 
 \f
 ;;;; public interface
 

+(defun maybe-defaulted-external-format (external-format)
+  (sb!impl::get-external-format-or-lose (if (eq external-format :default)
+                                            (default-external-format)
+                                            external-format)))
+

 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
   (declare (type (vector (unsigned-byte 8)) vector))
   (with-array-data ((vector vector)
 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
   (declare (type (vector (unsigned-byte 8)) vector))
   (with-array-data ((vector vector)

@@ -820,8 +385,8 @@ one-past-the-end"
                     (end end)
                     :check-fill-pointer t)
     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
                     (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)))
+    (let ((ef (maybe-defaulted-external-format external-format)))
+      (funcall (sb!impl::ef-octets-to-string-fun ef) vector start end))))

 
 (defun string-to-octets (string &key (external-format :default)
                          (start 0) end null-terminate)
 
 (defun string-to-octets (string &key (external-format :default)
                          (start 0) end null-terminate)

@@ -831,8 +396,9 @@ one-past-the-end"
                     (end end)
                     :check-fill-pointer t)
     (declare (type simple-string string))
                     (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))))
+    (let ((ef (maybe-defaulted-external-format external-format)))
+      (funcall (sb!impl::ef-string-to-octets-fun ef) string start end
+               (if null-terminate 1 0)))))

 
 #!+sb-unicode
 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
 
 #!+sb-unicode
 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))