From: Nathan Froyd Date: Sun, 6 May 2007 02:28:42 +0000 (+0000) Subject: 1.0.5.34: faster STRING-TO-OCTETS for unibyte and UTF-8 encodings X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7effaab5d43dd5423938b00854848e01eb3a67c8;p=sbcl.git 1.0.5.34: faster STRING-TO-OCTETS for unibyte and UTF-8 encodings * 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). --- diff --git a/NEWS b/NEWS index 206fe12..1be4b07 100644 --- 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 diff --git a/src/code/external-formats/enc-cyr.lisp b/src/code/external-formats/enc-cyr.lisp index 9d0061d..a0e033e 100644 --- a/src/code/external-formats/enc-cyr.lisp +++ b/src/code/external-formats/enc-cyr.lisp @@ -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 @@ -132,11 +132,11 @@ ) (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)) @@ -160,9 +160,8 @@ (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 @@ -307,11 +306,11 @@ ) (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)) @@ -335,9 +334,8 @@ (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 @@ -477,11 +475,11 @@ ) (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)) @@ -505,9 +503,8 @@ (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 diff --git a/src/code/external-formats/enc-dos.lisp b/src/code/external-formats/enc-dos.lisp index edb9457..83441ce 100644 --- a/src/code/external-formats/enc-dos.lisp +++ b/src/code/external-formats/enc-dos.lisp @@ -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 @@ -132,11 +132,11 @@ ) (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)) @@ -160,9 +160,8 @@ (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 @@ -307,11 +306,11 @@ ) (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)) @@ -335,9 +334,8 @@ (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 @@ -482,11 +480,11 @@ ) (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)) @@ -510,9 +508,8 @@ (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 @@ -657,11 +654,11 @@ ) (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)) @@ -685,9 +682,8 @@ (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 @@ -831,11 +827,11 @@ ) (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)) @@ -859,9 +855,8 @@ (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 @@ -1006,11 +1001,11 @@ ) (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)) @@ -1034,9 +1029,8 @@ (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 @@ -1181,11 +1175,11 @@ ) (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)) @@ -1209,9 +1203,8 @@ (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 @@ -1356,11 +1349,11 @@ ) (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)) @@ -1384,9 +1377,8 @@ (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 @@ -1531,11 +1523,11 @@ ) (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)) @@ -1559,9 +1551,8 @@ (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 @@ -1703,11 +1694,11 @@ ) (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)) @@ -1731,9 +1722,8 @@ (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 @@ -1878,11 +1868,11 @@ ) (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)) @@ -1906,9 +1896,8 @@ (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 @@ -2053,11 +2042,11 @@ ) (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)) @@ -2081,9 +2070,8 @@ (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 @@ -2228,11 +2216,11 @@ ) (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)) @@ -2256,9 +2244,8 @@ (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 @@ -2402,11 +2389,11 @@ ) (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)) @@ -2430,9 +2417,8 @@ (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 diff --git a/src/code/external-formats/enc-iso.lisp b/src/code/external-formats/enc-iso.lisp index f8a1119..a6f446c 100644 --- a/src/code/external-formats/enc-iso.lisp +++ b/src/code/external-formats/enc-iso.lisp @@ -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 @@ -61,11 +61,11 @@ ) (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 @@ -143,11 +142,11 @@ ) (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)) @@ -171,9 +170,8 @@ (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 @@ -240,11 +238,11 @@ ) (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)) @@ -268,9 +266,8 @@ (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 @@ -381,11 +378,11 @@ ) (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)) @@ -409,9 +406,8 @@ (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 @@ -521,11 +517,11 @@ ) (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)) @@ -549,9 +545,8 @@ (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 @@ -648,11 +643,11 @@ ) (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)) @@ -676,9 +671,8 @@ (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 @@ -764,11 +758,11 @@ ) (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)) @@ -792,9 +786,8 @@ (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 @@ -817,11 +810,11 @@ ) (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)) @@ -845,9 +838,8 @@ (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 @@ -910,11 +902,11 @@ ) (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)) @@ -938,9 +930,8 @@ (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 @@ -1052,11 +1043,11 @@ ) (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)) @@ -1080,9 +1071,8 @@ (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 @@ -1155,11 +1145,11 @@ ) (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)) @@ -1183,9 +1173,8 @@ (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 @@ -1233,11 +1222,11 @@ ) (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)) @@ -1261,9 +1250,8 @@ (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 diff --git a/src/code/external-formats/enc-win.lisp b/src/code/external-formats/enc-win.lisp index a8bcc3c..6fca638 100644 --- a/src/code/external-formats/enc-win.lisp +++ b/src/code/external-formats/enc-win.lisp @@ -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 @@ -83,11 +83,11 @@ ) (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)) @@ -111,9 +111,8 @@ (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 @@ -243,11 +242,11 @@ ) (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)) @@ -271,9 +270,8 @@ (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 @@ -322,11 +320,11 @@ ) (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)) @@ -350,9 +348,8 @@ (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 @@ -476,11 +473,11 @@ ) (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)) @@ -504,9 +501,8 @@ (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 @@ -561,11 +557,11 @@ ) (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)) @@ -589,9 +585,8 @@ (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 @@ -707,11 +702,11 @@ ) (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)) @@ -735,9 +730,8 @@ (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 @@ -839,11 +833,11 @@ ) (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)) @@ -867,9 +861,8 @@ (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 @@ -973,11 +966,11 @@ ) (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)) @@ -1001,9 +994,8 @@ (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 @@ -1066,11 +1058,11 @@ ) (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)) @@ -1094,9 +1086,8 @@ (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 diff --git a/src/code/external-formats/mb-util.lisp b/src/code/external-formats/mb-util.lisp index ecac8fa..251b8d7 100644 --- a/src/code/external-formats/mb-util.lisp +++ b/src/code/external-formats/mb-util.lisp @@ -276,7 +276,7 @@ (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)) ))) diff --git a/src/code/external-formats/ucs-2.lisp b/src/code/external-formats/ucs-2.lisp index 2aea2df..fc1d4bd 100644 --- a/src/code/external-formats/ucs-2.lisp +++ b/src/code/external-formats/ucs-2.lisp @@ -209,10 +209,8 @@ (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)) diff --git a/src/code/octets.lisp b/src/code/octets.lisp index 247f685..13320f9 100644 --- a/src/code/octets.lisp +++ b/src/code/octets.lisp @@ -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))))) ;;;; 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))) ;;;; public interface diff --git a/version.lisp-expr b/version.lisp-expr index 9b0dd83..c5a474d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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"