1.0.5.34: faster STRING-TO-OCTETS for unibyte and UTF-8 encodings
authorNathan Froyd <froydnj@cs.rice.edu>
Sun, 6 May 2007 02:28:42 +0000 (02:28 +0000)
committerNathan Froyd <froydnj@cs.rice.edu>
Sun, 6 May 2007 02:28:42 +0000 (02:28 +0000)
* redo DEFINE-UNIBYTE-MAPPER to use a lookup table instead of
  a big CASE statement (optimizes for the common (?) case of
  mostly ASCII characters and gives smaller code);
* STRING->LATIN% now optimistically assumes that there are
  no encoding errors in the string and allocates an
  appropriately-sized octet vector upfront, falling back to
  the slower path if an encoding error is detected;
* do more or less the same thing for UTF-8 encoding, except
  that there is no slow path (since UTF-8 can encode all
  characters, unlike unibyte encodings)
* we have a ton of external formats; use a hash table for
  *EXTERNAL-FORMAT-FUNCTIONS* rather than a list to cut down
  on lookup time (this alone is worth ~10% without the other
  optimizations above...).

Code cleanups:

* use string package names like every other source file;
* properly separate function names from arglists;
* don't pass END parameters when we don't use them.

End result is ~20-30x speedup for unibyte encodings (depending
        on the encoding--LATIN-1 is ~20x, whereas something like CP857
        is ~30x) when encoding ASCII strings; smaller but still
        significant speedups when encoding non-ASCII strings.  UTF-8
        encoding is ~5-6x faster, which also means that we're faster
        than TRIVIAL-UTF-8 for encoding now (decoding is an entirely
        different matter).

NEWS
src/code/external-formats/enc-cyr.lisp
src/code/external-formats/enc-dos.lisp
src/code/external-formats/enc-iso.lisp
src/code/external-formats/enc-win.lisp
src/code/external-formats/mb-util.lisp
src/code/external-formats/ucs-2.lisp
src/code/octets.lisp
version.lisp-expr

diff --git a/NEWS b/NEWS
index 206fe12..1be4b07 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,8 @@
 changes in sbcl-1.0.6 relative to sbcl-1.0.5:
   * new contrib: sb-cover, an experimental code coverage tool, is included
     as a contrib module.
+  * optimization: STRING-TO-OCTETS for unibyte encodings and UTF-8 is
+    significantly faster.
   * enhancement: a new, experimental synchronous timeout facility is
     provided. Refer to SB-SYS:WITH-DEADLINE for details.
   * enhancement: when a symbol name conflict error arises, the
index 9d0061d..a0e033e 100644 (file)
@@ -1,4 +1,4 @@
-(in-package #:sb!impl)
+(in-package "SB!IMPL")
 
 (define-unibyte-mapper koi8-r->code-mapper code->koi8-r-mapper
   (#x80 #x2500) ; BOX DRAWINGS LIGHT HORIZONTAL
 )
 
 (declaim (inline get-koi8-r-bytes))
-(defun get-koi8-r-bytes(string pos end)
+(defun get-koi8-r-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->koi8-r-mapper :koi8-r string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->koi8-r-mapper :koi8-r string pos))
 
 (defun string->koi8-r (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-koi8-r->string)
 
-(push '((:koi8-r :|koi8-r|)
-        koi8-r->string-aref string->koi8-r)
-      *external-format-functions*)
+(add-external-format-funs '(:koi8-r :|koi8-r|)
+                          '(koi8-r->string-aref string->koi8-r))
 
 (define-external-format (:koi8-r :|koi8-r|)
     1 t
 )
 
 (declaim (inline get-koi8-u-bytes))
-(defun get-koi8-u-bytes(string pos end)
+(defun get-koi8-u-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->koi8-u-mapper :koi8-u string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->koi8-u-mapper :koi8-u string pos))
 
 (defun string->koi8-u (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-koi8-u->string)
 
-(push '((:koi8-u :|koi8-u|)
-        koi8-u->string-aref string->koi8-u)
-      *external-format-functions*)
+(add-external-format-funs '(:koi8-u :|koi8-u|)
+                          '(koi8-u->string-aref string->koi8-u))
 
 (define-external-format (:koi8-u :|koi8-u|)
     1 t
 )
 
 (declaim (inline get-x-mac-cyrillic-bytes))
-(defun get-x-mac-cyrillic-bytes(string pos end)
+(defun get-x-mac-cyrillic-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->x-mac-cyrillic-mapper :x-mac-cyrillic string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->x-mac-cyrillic-mapper :x-mac-cyrillic string pos))
 
 (defun string->x-mac-cyrillic (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-x-mac-cyrillic->string)
 
-(push '((:x-mac-cyrillic :|x-mac-cyrillic|)
-        x-mac-cyrillic->string-aref string->x-mac-cyrillic)
-      *external-format-functions*)
+(add-external-format-funs '(:x-mac-cyrillic :|x-mac-cyrillic|)
+                          '(x-mac-cyrillic->string-aref string->x-mac-cyrillic))
 
 (define-external-format (:x-mac-cyrillic :|x-mac-cyrillic|)
     1 t
index edb9457..83441ce 100644 (file)
@@ -1,4 +1,4 @@
-(in-package #:sb!impl)
+(in-package "SB!IMPL")
 
 (define-unibyte-mapper cp437->code-mapper code->cp437-mapper
   (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
 )
 
 (declaim (inline get-cp437-bytes))
-(defun get-cp437-bytes(string pos end)
+(defun get-cp437-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp437-mapper :cp437 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp437-mapper :cp437 string pos))
 
 (defun string->cp437 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp437->string)
 
-(push '((:cp437 :|cp437|)
-        cp437->string-aref string->cp437)
-      *external-format-functions*)
+(add-external-format-funs '(:cp437 :|cp437|)
+                          '(cp437->string-aref string->cp437))
 
 (define-external-format (:cp437 :|cp437|)
     1 t
 )
 
 (declaim (inline get-cp850-bytes))
-(defun get-cp850-bytes(string pos end)
+(defun get-cp850-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp850-mapper :cp850 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp850-mapper :cp850 string pos))
 
 (defun string->cp850 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp850->string)
 
-(push '((:cp850 :|cp850|)
-        cp850->string-aref string->cp850)
-      *external-format-functions*)
+(add-external-format-funs '(:cp850 :|cp850|)
+                          '(cp850->string-aref string->cp850))
 
 (define-external-format (:cp850 :|cp850|)
     1 t
 )
 
 (declaim (inline get-cp852-bytes))
-(defun get-cp852-bytes(string pos end)
+(defun get-cp852-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp852-mapper :cp852 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp852-mapper :cp852 string pos))
 
 (defun string->cp852 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp852->string)
 
-(push '((:cp852 :|cp852|)
-        cp852->string-aref string->cp852)
-      *external-format-functions*)
+(add-external-format-funs '(:cp852 :|cp852|)
+                          '(cp852->string-aref string->cp852))
 
 (define-external-format (:cp852 :|cp852|)
     1 t
 )
 
 (declaim (inline get-cp855-bytes))
-(defun get-cp855-bytes(string pos end)
+(defun get-cp855-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp855-mapper :cp855 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp855-mapper :cp855 string pos))
 
 (defun string->cp855 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp855->string)
 
-(push '((:cp855 :|cp855|)
-        cp855->string-aref string->cp855)
-      *external-format-functions*)
+(add-external-format-funs '(:cp855 :|cp855|)
+                          '(cp855->string-aref string->cp855))
 
 (define-external-format (:cp855 :|cp855|)
     1 t
 )
 
 (declaim (inline get-cp857-bytes))
-(defun get-cp857-bytes(string pos end)
+(defun get-cp857-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp857-mapper :cp857 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp857-mapper :cp857 string pos))
 
 (defun string->cp857 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp857->string)
 
-(push '((:cp857 :|cp857|)
-        cp857->string-aref string->cp857)
-      *external-format-functions*)
+(add-external-format-funs '(:cp857 :|cp857|)
+                          '(cp857->string-aref string->cp857))
 
 (define-external-format (:cp857 :|cp857|)
     1 t
 )
 
 (declaim (inline get-cp860-bytes))
-(defun get-cp860-bytes(string pos end)
+(defun get-cp860-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp860-mapper :cp860 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp860-mapper :cp860 string pos))
 
 (defun string->cp860 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp860->string)
 
-(push '((:cp860 :|cp860|)
-        cp860->string-aref string->cp860)
-      *external-format-functions*)
+(add-external-format-funs '(:cp860 :|cp860|)
+                          '(cp860->string-aref string->cp860))
 
 (define-external-format (:cp860 :|cp860|)
     1 t
 )
 
 (declaim (inline get-cp861-bytes))
-(defun get-cp861-bytes(string pos end)
+(defun get-cp861-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp861-mapper :cp861 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp861-mapper :cp861 string pos))
 
 (defun string->cp861 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp861->string)
 
-(push '((:cp861 :|cp861|)
-        cp861->string-aref string->cp861)
-      *external-format-functions*)
+(add-external-format-funs '(:cp861 :|cp861|)
+                          '(cp861->string-aref string->cp861))
 
 (define-external-format (:cp861 :|cp861|)
     1 t
 )
 
 (declaim (inline get-cp862-bytes))
-(defun get-cp862-bytes(string pos end)
+(defun get-cp862-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp862-mapper :cp862 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp862-mapper :cp862 string pos))
 
 (defun string->cp862 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp862->string)
 
-(push '((:cp862 :|cp862|)
-        cp862->string-aref string->cp862)
-      *external-format-functions*)
+(add-external-format-funs '(:cp862 :|cp862|)
+                          '(cp862->string-aref string->cp862))
 
 (define-external-format (:cp862 :|cp862|)
     1 t
 )
 
 (declaim (inline get-cp863-bytes))
-(defun get-cp863-bytes(string pos end)
+(defun get-cp863-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp863-mapper :cp863 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp863-mapper :cp863 string pos))
 
 (defun string->cp863 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp863->string)
 
-(push '((:cp863 :|cp863|)
-        cp863->string-aref string->cp863)
-      *external-format-functions*)
+(add-external-format-funs '(:cp863 :|cp863|)
+                          '(cp863->string-aref string->cp863))
 
 (define-external-format (:cp863 :|cp863|)
     1 t
 )
 
 (declaim (inline get-cp864-bytes))
-(defun get-cp864-bytes(string pos end)
+(defun get-cp864-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp864-mapper :cp864 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp864-mapper :cp864 string pos))
 
 (defun string->cp864 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp864->string)
 
-(push '((:cp864 :|cp864|)
-        cp864->string-aref string->cp864)
-      *external-format-functions*)
+(add-external-format-funs '(:cp864 :|cp864|)
+                          '(cp864->string-aref string->cp864))
 
 (define-external-format (:cp864 :|cp864|)
     1 t
 )
 
 (declaim (inline get-cp865-bytes))
-(defun get-cp865-bytes(string pos end)
+(defun get-cp865-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp865-mapper :cp865 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp865-mapper :cp865 string pos))
 
 (defun string->cp865 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp865->string)
 
-(push '((:cp865 :|cp865|)
-        cp865->string-aref string->cp865)
-      *external-format-functions*)
+(add-external-format-funs '(:cp865 :|cp865|)
+                          '(cp865->string-aref string->cp865))
 
 (define-external-format (:cp865 :|cp865|)
     1 t
 )
 
 (declaim (inline get-cp866-bytes))
-(defun get-cp866-bytes(string pos end)
+(defun get-cp866-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp866-mapper :cp866 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp866-mapper :cp866 string pos))
 
 (defun string->cp866 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp866->string)
 
-(push '((:cp866 :|cp866|)
-        cp866->string-aref string->cp866)
-      *external-format-functions*)
+(add-external-format-funs '(:cp866 :|cp866|)
+                          '(cp866->string-aref string->cp866))
 
 (define-external-format (:cp866 :|cp866|)
     1 t
 )
 
 (declaim (inline get-cp869-bytes))
-(defun get-cp869-bytes(string pos end)
+(defun get-cp869-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp869-mapper :cp869 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp869-mapper :cp869 string pos))
 
 (defun string->cp869 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp869->string)
 
-(push '((:cp869 :|cp869|)
-        cp869->string-aref string->cp869)
-      *external-format-functions*)
+(add-external-format-funs '(:cp869 :|cp869|)
+                          '(cp869->string-aref string->cp869))
 
 (define-external-format (:cp869 :|cp869|)
     1 t
 )
 
 (declaim (inline get-cp874-bytes))
-(defun get-cp874-bytes(string pos end)
+(defun get-cp874-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp874-mapper :cp874 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp874-mapper :cp874 string pos))
 
 (defun string->cp874 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp874->string)
 
-(push '((:cp874 :|cp874|)
-        cp874->string-aref string->cp874)
-      *external-format-functions*)
+(add-external-format-funs '(:cp874 :|cp874|)
+                          '(cp874->string-aref string->cp874))
 
 (define-external-format (:cp874 :|cp874|)
     1 t
index f8a1119..a6f446c 100644 (file)
@@ -1,4 +1,4 @@
-(in-package #:sb!impl)
+(in-package "SB!IMPL")
 
 (define-unibyte-mapper iso-8859-2->code-mapper code->iso-8859-2-mapper
   (#xA1 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK
 )
 
 (declaim (inline get-iso-8859-2-bytes))
-(defun get-iso-8859-2-bytes(string pos end)
+(defun get-iso-8859-2-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-2-mapper :iso-8859-2 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-2-mapper :iso-8859-2 string pos))
 
 (defun string->iso-8859-2 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
@@ -89,9 +89,8 @@
 
 (instantiate-octets-definition define-iso-8859-2->string)
 
-(push '((:iso-8859-2 :|iso-8859-2| :latin-2 :|latin-2|)
-        iso-8859-2->string-aref string->iso-8859-2)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-2 :|iso-8859-2| :latin-2 :|latin-2|)
+                          '(iso-8859-2->string-aref string->iso-8859-2))
 
 (define-external-format (:iso-8859-2 :|iso-8859-2| :latin-2 :|latin-2|)
     1 t
 )
 
 (declaim (inline get-iso-8859-3-bytes))
-(defun get-iso-8859-3-bytes(string pos end)
+(defun get-iso-8859-3-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-3-mapper :iso-8859-3 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-3-mapper :iso-8859-3 string pos))
 
 (defun string->iso-8859-3 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-3->string)
 
-(push '((:iso-8859-3 :|iso-8859-3| :latin-3 :|latin-3|)
-        iso-8859-3->string-aref string->iso-8859-3)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-3 :|iso-8859-3| :latin-3 :|latin-3|)
+                          '(iso-8859-3->string-aref string->iso-8859-3))
 
 (define-external-format (:iso-8859-3 :|iso-8859-3| :latin-3 :|latin-3|)
     1 t
 )
 
 (declaim (inline get-iso-8859-4-bytes))
-(defun get-iso-8859-4-bytes(string pos end)
+(defun get-iso-8859-4-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-4-mapper :iso-8859-4 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-4-mapper :iso-8859-4 string pos))
 
 (defun string->iso-8859-4 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-4->string)
 
-(push '((:iso-8859-4 :|iso-8859-4| :latin-4 :|latin-4|)
-        iso-8859-4->string-aref string->iso-8859-4)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-4 :|iso-8859-4| :latin-4 :|latin-4|)
+                          '(iso-8859-4->string-aref string->iso-8859-4))
 
 (define-external-format (:iso-8859-4 :|iso-8859-4| :latin-4 :|latin-4|)
     1 t
 )
 
 (declaim (inline get-iso-8859-5-bytes))
-(defun get-iso-8859-5-bytes(string pos end)
+(defun get-iso-8859-5-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-5-mapper :iso-8859-5 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-5-mapper :iso-8859-5 string pos))
 
 (defun string->iso-8859-5 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-5->string)
 
-(push '((:iso-8859-5 :|iso-8859-5|)
-        iso-8859-5->string-aref string->iso-8859-5)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-5 :|iso-8859-5|)
+                          '(iso-8859-5->string-aref string->iso-8859-5))
 
 (define-external-format (:iso-8859-5 :|iso-8859-5|)
     1 t
 )
 
 (declaim (inline get-iso-8859-6-bytes))
-(defun get-iso-8859-6-bytes(string pos end)
+(defun get-iso-8859-6-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-6-mapper :iso-8859-6 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-6-mapper :iso-8859-6 string pos))
 
 (defun string->iso-8859-6 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-6->string)
 
-(push '((:iso-8859-6 :|iso-8859-6|)
-        iso-8859-6->string-aref string->iso-8859-6)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-6 :|iso-8859-6|)
+                          '(iso-8859-6->string-aref string->iso-8859-6))
 
 (define-external-format (:iso-8859-6 :|iso-8859-6|)
     1 t
 )
 
 (declaim (inline get-iso-8859-7-bytes))
-(defun get-iso-8859-7-bytes(string pos end)
+(defun get-iso-8859-7-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-7-mapper :iso-8859-7 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-7-mapper :iso-8859-7 string pos))
 
 (defun string->iso-8859-7 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-7->string)
 
-(push '((:iso-8859-7 :|iso-8859-7|)
-        iso-8859-7->string-aref string->iso-8859-7)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-7 :|iso-8859-7|)
+                          '(iso-8859-7->string-aref string->iso-8859-7))
 
 (define-external-format (:iso-8859-7 :|iso-8859-7|)
     1 t
 )
 
 (declaim (inline get-iso-8859-8-bytes))
-(defun get-iso-8859-8-bytes(string pos end)
+(defun get-iso-8859-8-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-8-mapper :iso-8859-8 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-8-mapper :iso-8859-8 string pos))
 
 (defun string->iso-8859-8 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-8->string)
 
-(push '((:iso-8859-8 :|iso-8859-8|)
-        iso-8859-8->string-aref string->iso-8859-8)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-8 :|iso-8859-8|)
+                          '(iso-8859-8->string-aref string->iso-8859-8))
 
 (define-external-format (:iso-8859-8 :|iso-8859-8|)
     1 t
 )
 
 (declaim (inline get-iso-8859-9-bytes))
-(defun get-iso-8859-9-bytes(string pos end)
+(defun get-iso-8859-9-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-9-mapper :iso-8859-9 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-9-mapper :iso-8859-9 string pos))
 
 (defun string->iso-8859-9 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-9->string)
 
-(push '((:iso-8859-9 :|iso-8859-9| :latin-5 :|latin-5|)
-        iso-8859-9->string-aref string->iso-8859-9)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-9 :|iso-8859-9| :latin-5 :|latin-5|)
+                          '(iso-8859-9->string-aref string->iso-8859-9))
 
 (define-external-format (:iso-8859-9 :|iso-8859-9| :latin-5 :|latin-5|)
     1 t
 )
 
 (declaim (inline get-iso-8859-10-bytes))
-(defun get-iso-8859-10-bytes(string pos end)
+(defun get-iso-8859-10-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-10-mapper :iso-8859-10 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-10-mapper :iso-8859-10 string pos))
 
 (defun string->iso-8859-10 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-10->string)
 
-(push '((:iso-8859-10 :|iso-8859-10| :latin-6 :|latin-6|)
-        iso-8859-10->string-aref string->iso-8859-10)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-10 :|iso-8859-10| :latin-6 :|latin-6|)
+                          '(iso-8859-10->string-aref string->iso-8859-10))
 
 (define-external-format (:iso-8859-10 :|iso-8859-10| :latin-6 :|latin-6|)
     1 t
 )
 
 (declaim (inline get-iso-8859-11-bytes))
-(defun get-iso-8859-11-bytes(string pos end)
+(defun get-iso-8859-11-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-11-mapper :iso-8859-11 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-11-mapper :iso-8859-11 string pos))
 
 (defun string->iso-8859-11 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-11->string)
 
-(push '((:iso-8859-11 :|iso-8859-11|)
-        iso-8859-11->string-aref string->iso-8859-11)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-11 :|iso-8859-11|)
+                          '(iso-8859-11->string-aref string->iso-8859-11))
 
 (define-external-format (:iso-8859-11 :|iso-8859-11|)
     1 t
 )
 
 (declaim (inline get-iso-8859-13-bytes))
-(defun get-iso-8859-13-bytes(string pos end)
+(defun get-iso-8859-13-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-13-mapper :iso-8859-13 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-13-mapper :iso-8859-13 string pos))
 
 (defun string->iso-8859-13 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-13->string)
 
-(push '((:iso-8859-13 :|iso-8859-13| :latin-7 :|latin-7|)
-        iso-8859-13->string-aref string->iso-8859-13)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-13 :|iso-8859-13| :latin-7 :|latin-7|)
+                          '(iso-8859-13->string-aref string->iso-8859-13))
 
 (define-external-format (:iso-8859-13 :|iso-8859-13| :latin-7 :|latin-7|)
     1 t
 )
 
 (declaim (inline get-iso-8859-14-bytes))
-(defun get-iso-8859-14-bytes(string pos end)
+(defun get-iso-8859-14-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->iso-8859-14-mapper :iso-8859-14 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->iso-8859-14-mapper :iso-8859-14 string pos))
 
 (defun string->iso-8859-14 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-iso-8859-14->string)
 
-(push '((:iso-8859-14 :|iso-8859-14| :latin-8 :|latin-8|)
-        iso-8859-14->string-aref string->iso-8859-14)
-      *external-format-functions*)
+(add-external-format-funs '(:iso-8859-14 :|iso-8859-14| :latin-8 :|latin-8|)
+                          '(iso-8859-14->string-aref string->iso-8859-14))
 
 (define-external-format (:iso-8859-14 :|iso-8859-14| :latin-8 :|latin-8|)
     1 t
index a8bcc3c..6fca638 100644 (file)
@@ -1,4 +1,4 @@
-(in-package #:sb!impl)
+(in-package "SB!IMPL")
 
 (define-unibyte-mapper cp1250->code-mapper code->cp1250-mapper
   (#x80 #x20AC) ; EURO SIGN
 )
 
 (declaim (inline get-cp1250-bytes))
-(defun get-cp1250-bytes(string pos end)
+(defun get-cp1250-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1250-mapper :cp1250 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1250-mapper :cp1250 string pos))
 
 (defun string->cp1250 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1250->string)
 
-(push '((:cp1250 :|cp1250| :windows-1250 :|windows-1250|)
-        cp1250->string-aref string->cp1250)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1250 :|cp1250| :windows-1250 :|windows-1250|)
+                          '(cp1250->string-aref string->cp1250))
 
 (define-external-format (:cp1250 :|cp1250| :windows-1250 :|windows-1250|)
     1 t
 )
 
 (declaim (inline get-cp1251-bytes))
-(defun get-cp1251-bytes(string pos end)
+(defun get-cp1251-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1251-mapper :cp1251 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1251-mapper :cp1251 string pos))
 
 (defun string->cp1251 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1251->string)
 
-(push '((:cp1251 :|cp1251|  :windows-1251 :|windows-1251|)
-        cp1251->string-aref string->cp1251)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1251 :|cp1251|  :windows-1251 :|windows-1251|)
+                          '(cp1251->string-aref string->cp1251))
 
 (define-external-format (:cp1251 :|cp1251| :windows-1251 :|windows-1251|)
     1 t
 )
 
 (declaim (inline get-cp1252-bytes))
-(defun get-cp1252-bytes(string pos end)
+(defun get-cp1252-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1252-mapper :cp1252 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1252-mapper :cp1252 string pos))
 
 (defun string->cp1252 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1252->string)
 
-(push '((:cp1252 :|cp1252| :windows-1252 :|windows-1252|)
-        cp1252->string-aref string->cp1252)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1252 :|cp1252| :windows-1252 :|windows-1252|)
+                          '(cp1252->string-aref string->cp1252))
 
 (define-external-format (:cp1252 :|cp1252| :windows-1252 :|windows-1252|)
     1 t
 )
 
 (declaim (inline get-cp1253-bytes))
-(defun get-cp1253-bytes(string pos end)
+(defun get-cp1253-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1253-mapper :cp1253 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1253-mapper :cp1253 string pos))
 
 (defun string->cp1253 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1253->string)
 
-(push '((:cp1253 :|cp1253| :windows-1253 :|windows-1253|)
-        cp1253->string-aref string->cp1253)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1253 :|cp1253| :windows-1253 :|windows-1253|)
+                          '(cp1253->string-aref string->cp1253))
 
 (define-external-format (:cp1253 :|cp1253| :windows-1253 :|windows-1253|)
     1 t
 )
 
 (declaim (inline get-cp1254-bytes))
-(defun get-cp1254-bytes(string pos end)
+(defun get-cp1254-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1254-mapper :cp1254 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1254-mapper :cp1254 string pos))
 
 (defun string->cp1254 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1254->string)
 
-(push '((:cp1254 :|cp1254| :windows-1254 :|windows-1254|)
-        cp1254->string-aref string->cp1254)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1254 :|cp1254| :windows-1254 :|windows-1254|)
+                          '(cp1254->string-aref string->cp1254))
 
 (define-external-format (:cp1254 :|cp1254|)
     1 t
 )
 
 (declaim (inline get-cp1255-bytes))
-(defun get-cp1255-bytes(string pos end)
+(defun get-cp1255-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1255-mapper :cp1255 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1255-mapper :cp1255 string pos))
 
 (defun string->cp1255 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1255->string)
 
-(push '((:cp1255 :|cp1255| :windows-1255 :|windows-1255|)
-        cp1255->string-aref string->cp1255)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1255 :|cp1255| :windows-1255 :|windows-1255|)
+                          '(cp1255->string-aref string->cp1255))
 
 (define-external-format (:cp1255 :|cp1255| :windows-1255 :|windows-1255|)
     1 t
 )
 
 (declaim (inline get-cp1256-bytes))
-(defun get-cp1256-bytes(string pos end)
+(defun get-cp1256-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1256-mapper :cp1256 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1256-mapper :cp1256 string pos))
 
 (defun string->cp1256 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1256->string)
 
-(push '((:cp1256 :|cp1256| :windows-1256 :|windows-1256|)
-        cp1256->string-aref string->cp1256)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1256 :|cp1256| :windows-1256 :|windows-1256|)
+                          '(cp1256->string-aref string->cp1256))
 
 (define-external-format (:cp1256 :|cp1256|)
     1 t
 )
 
 (declaim (inline get-cp1257-bytes))
-(defun get-cp1257-bytes(string pos end)
+(defun get-cp1257-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1257-mapper :cp1257 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1257-mapper :cp1257 string pos))
 
 (defun string->cp1257 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1257->string)
 
-(push '((:cp1257 :|cp1257| :windows-1257 :|windows-1257|)
-        cp1257->string-aref string->cp1257)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1257 :|cp1257| :windows-1257 :|windows-1257|)
+                          '(cp1257->string-aref string->cp1257))
 
 (define-external-format (:cp1257 :|cp1257| :windows-1257 :|windows-1257|)
     1 t
 )
 
 (declaim (inline get-cp1258-bytes))
-(defun get-cp1258-bytes(string pos end)
+(defun get-cp1258-bytes (string pos)
   (declare (optimize speed (safety 0))
            (type simple-string string)
-           (type array-range pos end))
-  (get-latin-bytes #'code->cp1258-mapper :cp1258 string pos end))
+           (type array-range pos))
+  (get-latin-bytes #'code->cp1258-mapper :cp1258 string pos))
 
 (defun string->cp1258 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
 
 (instantiate-octets-definition define-cp1258->string)
 
-(push '((:cp1258 :|cp1258| :windows-1258 :|windows-1258|)
-        cp1258->string-aref string->cp1258)
-      *external-format-functions*)
+(add-external-format-funs '(:cp1258 :|cp1258| :windows-1258 :|windows-1258|)
+                          '(cp1258->string-aref string->cp1258))
 
 (define-external-format (:cp1258 :|cp1258| :windows-1258 :|windows-1258|)
     1 t
index ecac8fa..251b8d7 100644 (file)
 
        (instantiate-octets-definition ,define-mb->string)
 
-       (push '(,aliases
-               ,(make-od-name format '>string-aref) ,string->mb)
-             *external-format-functions*)
+       (add-external-format-funs ',aliases
+                                 '(,(make-od-name format '>string-aref)
+                                   ,string->mb))
        )))
index 2aea2df..fc1d4bd 100644 (file)
 
 (instantiate-octets-definition define-ucs-2->string)
 
-(pushnew '((:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2)
-           ucs-2le->string-aref string->ucs-2le)
-         *external-format-functions*)
+(add-external-format-funs '(:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2)
+                          '(ucs-2le->string-aref string->ucs-2le))
 
-(pushnew '((:ucs-2be :ucs2be)
-           ucs-2be->string-aref string->ucs-2be)
-         *external-format-functions*)
+(add-external-format-funs '(:ucs-2be :ucs2be)
+                          '(ucs-2be->string-aref string->ucs-2be))
index 247f685..13320f9 100644 (file)
@@ -172,37 +172,88 @@ one-past-the-end"
 
 ;;; 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)
-  `(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
@@ -218,8 +269,7 @@ one-past-the-end"
   (#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
@@ -237,47 +287,80 @@ one-past-the-end"
       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)
-           (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))
-(defun get-latin1-bytes (string pos end)
+(defun get-latin1-bytes (string pos)
   (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))
-  (defun get-latin9-bytes (string pos end)
+  (defun get-latin9-bytes (string pos)
     (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)
-           (type array-range sstart send null-padding)
+           (type index sstart send)
+           (type (integer 0 1) null-padding)
            (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))
@@ -311,44 +394,39 @@ one-past-the-end"
         ((< 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)
+(defun string->utf8 (string sstart send null-padding)
   (declare (optimize speed (safety 0))
            (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))
+  (let* ((utf8-length (loop for i of-type index from sstart below send
+                         sum (char-len-as-utf8 (char-code (char string i)))))
+         (array (make-array (+ null-padding utf8-length)
+                            :initial-element 0
+                            :element-type '(unsigned-byte 8)))
+         (index 0))
+    (declare (type index index))
+    (flet ((add-byte (b)
+             (setf (aref array index) b)
+             (incf index)))
+      (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)))))
 \f
 ;;;; to-string conversions
 
@@ -687,23 +765,28 @@ one-past-the-end"
         (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)))
-  (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
index 9b0dd83..c5a474d 100644 (file)
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.5.33"
+"1.0.5.34"