1 ;;;; code for string to octet conversion
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 ;;; FIXME: The latin9 stuff is currently #!+sb-unicode, because I
13 ;;; don't like the idea of trying to do CODE-CHAR #x<big>. Is that a
14 ;;; justified fear? Can we arrange that it's caught and converted to
15 ;;; a decoding error error? Or should we just give up on non-Unicode
18 (in-package "SB!IMPL")
20 ;;; FIXME: don't we have this somewhere else?
21 (deftype array-range
()
22 "A number that can represent an index into a vector, including
24 '(integer 0 #.sb
!xc
:array-dimension-limit
))
28 ;;; encoding condition
30 (define-condition octets-encoding-error
(character-encoding-error)
31 ((string :initarg
:string
:reader octets-encoding-error-string
)
32 (position :initarg
:position
:reader octets-encoding-error-position
)
33 (external-format :initarg
:external-format
34 :reader octets-encoding-error-external-format
))
35 (:report
(lambda (c s
)
36 (format s
"Unable to encode character ~A as ~S."
37 (char-code (char (octets-encoding-error-string c
)
38 (octets-encoding-error-position c
)))
39 (octets-encoding-error-external-format c
)))))
41 (defun read-replacement-character ()
43 "Replacement byte, bytes, character, or string (evaluated): ")
44 (finish-output *query-io
*)
45 (list (eval (read *query-io
*))))
47 (defun encoding-error (external-format string pos
)
49 (error 'octets-encoding-error
50 :external-format external-format
53 (use-value (replacement)
54 :report
"Supply a set of bytes to use in place of the invalid one."
55 :interactive read-replacement-character
58 (make-array 1 :element-type
'(unsigned-byte 8) :initial-element replacement
))
60 (string-to-octets (string replacement
)
61 :external-format external-format
))
63 (string-to-octets replacement
64 :external-format external-format
))
66 (coerce replacement
'(simple-array (unsigned-byte 8) (*))))))))
68 ;;; decoding condition
70 ;;; for UTF8, the specific condition signalled will be a generalized
71 ;;; instance of one of the following:
73 ;;; end-of-input-in-character
74 ;;; character-out-of-range
75 ;;; invalid-utf8-starter-byte
76 ;;; invalid-utf8-continuation-byte
77 ;;; overlong-utf8-sequence
79 ;;; Of these, the only one truly likely to be of interest to calling
80 ;;; code is end-of-input-in-character (in which case it's likely to
81 ;;; want to make a note of octet-decoding-error-start, supply "" as a
82 ;;; replacement string, and then move that last chunk of bytes to the
83 ;;; beginning of its buffer for the next go round) but they're all
84 ;;; provided on the off chance they're of interest. The next most
85 ;;; likely interesting option is overlong-utf8-sequence -- the
86 ;;; application, if it cares to, can decode this itself (taking care
87 ;;; to ensure that the result isn't out of range of CHAR-CODE-LIMIT)
88 ;;; and return that result. This library doesn't provide support for
89 ;;; that as a conforming UTF-8-using program is supposed to treat it
92 (define-condition octet-decoding-error
(character-decoding-error)
93 ((array :initarg
:array
:accessor octet-decoding-error-array
)
94 (start :initarg
:start
:accessor octet-decoding-error-start
)
95 (end :initarg
:end
:accessor octet-decoding-error-end
)
96 (position :initarg
:pos
:accessor octet-decoding-bad-byte-position
)
97 (external-format :initarg
:external-format
98 :accessor octet-decoding-error-external-format
))
100 (lambda (condition stream
)
101 (format stream
"Illegal ~S character starting at byte position ~D."
102 (octet-decoding-error-external-format condition
)
103 (octet-decoding-error-start condition
)))))
105 (define-condition end-of-input-in-character
(octet-decoding-error) ())
106 (define-condition character-out-of-range
(octet-decoding-error) ())
107 (define-condition invalid-utf8-starter-byte
(octet-decoding-error) ())
108 (define-condition invalid-utf8-continuation-byte
(octet-decoding-error) ())
109 (define-condition overlong-utf8-sequence
(octet-decoding-error) ())
111 (define-condition malformed-ascii
(octet-decoding-error) ())
113 (defun read-replacement-string ()
114 (format *query-io
* "Enter a replacement string designator (evaluated): ")
115 (finish-output *query-io
*)
116 (list (eval (read *query-io
*))))
118 (defun decoding-error (array start end external-format reason pos
)
121 :external-format external-format
127 :report
"Supply a replacement string designator."
128 :interactive read-replacement-string
131 ;;; Utilities used in both to-string and to-octet conversions
133 (defmacro instantiate-octets-definition
(definer)
135 (,definer aref
(simple-array (unsigned-byte 8) (*)))
136 (,definer sap-ref-8 system-area-pointer
)))
138 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
139 ;;; and fix it, or else replace with SYMBOLICATE.
141 ;;; FIXME: this is cute, but is going to prevent greps for def.*<name>
142 ;;; from working for (defun ,(make-od-name ...) ...)
143 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
144 (defun make-od-name (sym1 sym2
)
145 ;; "MAKE-NAME" is too generic, but this doesn't do quite what
146 ;; SYMBOLICATE does; MAKE-OD-NAME ("octets definition") it is
148 (intern (concatenate 'string
(symbol-name sym1
) "-" (symbol-name sym2
))
149 (symbol-package sym1
))))
151 ;;;; to-octets conversions
153 ;;; to latin (including ascii)
155 ;;; Converting bytes to character codes is easy: just use a 256-element
156 ;;; lookup table that maps each possible byte to its corresponding
159 ;;; Converting character codes to bytes is a little harder, since the
160 ;;; codes may be spare (e.g. we use codes 0-127, 3490, and 4598). The
161 ;;; previous version of this macro utilized a gigantic CASE expression
162 ;;; to do the hard work, with the result that the code was huge (since
163 ;;; SBCL's then-current compilation strategy for CASE expressions was
164 ;;; (and still is) converting CASE into COND into if-the-elses--which is
165 ;;; also inefficient unless your code happens to occur very early in the
168 ;;; The current strategy is to build a table:
170 ;;; [ ... code_1 byte_1 code_2 byte_2 ... code_n byte_n ... ]
172 ;;; such that the codes are sorted in order from lowest to highest. We
173 ;;; can then binary search the table to discover the appropriate byte
174 ;;; for a character code. We also implement an optimization: all unibyte
175 ;;; mappings do not remap ASCII (0-127) and some do not remap part of
176 ;;; the range beyond character code 127. So we check to see if the
177 ;;; character code falls into that range first (a quick check, since
178 ;;; character codes are guaranteed to be positive) and then do the binary
179 ;;; search if not. This optimization also enables us to cut down on the
180 ;;; size of our lookup table.
181 (defmacro define-unibyte-mapper
(byte-char-name code-byte-name
&rest exceptions
)
182 (let* (;; Build a list of (CODE BYTE) pairs
183 (pairs (loop for byte below
256
184 for code
= (let ((exception (cdr (assoc byte exceptions
))))
186 ((car exception
) (car exception
))
187 ((null exception
) byte
)
189 when code collect
(list code byte
) into elements
190 finally
(return elements
)))
191 ;; Find the smallest character code such that the corresponding
192 ;; byte is != to the code.
193 (lowest-non-equivalent-code (position-if-not #'(lambda (pair)
196 ;; Sort them for our lookup table.
197 (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code
)
199 ;; Create the lookup table.
201 (reduce #'append sorted-pairs
:from-end t
:initial-value nil
)))
203 ; Can't inline it with a non-null lexical environment anyway.
204 ;(declaim (inline ,byte-char-name))
205 (let ((byte-to-code-table
206 ,(make-array 256 :element-type t
#+nil
'char-code
207 :initial-contents
(loop for byte below
256
209 (let ((exception (cadr (assoc byte exceptions
))))
214 ,(make-array (length sorted-lookup-table
)
215 :initial-contents sorted-lookup-table
)))
216 (defun ,byte-char-name
(byte)
217 (declare (optimize speed
(safety 0))
218 (type (unsigned-byte 8) byte
))
219 (aref byte-to-code-table byte
))
220 (defun ,code-byte-name
(code)
221 (declare (optimize speed
(safety 0))
222 (type char-code code
))
223 (if (< code
,lowest-non-equivalent-code
)
225 ;; We could toss in some TRULY-THEs if we really needed to
226 ;; make this faster...
228 with high
= (- (length code-to-byte-table
) 2)
230 do
(let ((mid (logandc2 (truncate (+ low high
2) 2) 1)))
231 (if (< code
(aref code-to-byte-table mid
))
232 (setf high
(- mid
2))
234 finally
(return (if (eql code
(aref code-to-byte-table low
))
235 (aref code-to-byte-table
(1+ low
))
238 (declaim (inline get-latin-bytes
))
239 (defun get-latin-bytes (mapper external-format string pos
)
240 (let ((code (funcall mapper
(char-code (char string pos
)))))
241 (declare (type (or null char-code
) code
))
243 ((and code
(< code
256)) code
)
245 (encoding-error external-format string pos
)))
248 (declaim (inline string-
>latin%
))
249 (defun string->latin%
(string sstart send get-bytes null-padding
)
250 (declare (optimize speed
)
251 (type simple-string string
)
252 (type index sstart send
)
253 (type (integer 0 1) null-padding
)
254 (type function get-bytes
))
255 ;; The latin encodings are all unibyte encodings, so just directly
256 ;; compute the number of octets we're going to generate.
257 (let ((octets (make-array (+ (- send sstart
) null-padding
)
258 ;; This takes care of any null padding the
261 :element-type
'(unsigned-byte 8)))
267 (loop for pos of-type index from sstart below send
268 do
(let ((byte (funcall get-bytes string pos
)))
271 (locally (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
272 (setf (aref octets index
) byte
)))
273 ((simple-array (unsigned-byte 8) (*))
274 ;; KLUDGE: We ran into encoding errors. Bail and do
275 ;; things the slow way (does anybody actually use this
276 ;; functionality besides our own test suite?).
277 (setf error-position pos error-replacement byte
)
280 finally
(return-from string-
>latin% octets
))
282 ;; We have encoded INDEX octets so far and we ran into an
283 ;; encoding error at ERROR-POSITION; the user has asked us to
284 ;; replace the expected output with ERROR-REPLACEMENT.
285 (let ((new-octets (make-array (* index
2)
286 :element-type
'(unsigned-byte 8)
287 :adjustable t
:fill-pointer index
)))
288 (replace new-octets octets
)
289 (flet ((extend (thing)
291 ((unsigned-byte 8) (vector-push-extend thing new-octets
))
292 ((simple-array (unsigned-byte 8) (*))
293 (dotimes (i (length thing
))
294 (vector-push-extend (aref thing i
) new-octets
))))))
295 (extend error-replacement
)
296 (loop for pos of-type index from
(1+ error-position
) below send
297 do
(extend (funcall get-bytes string pos
))
298 finally
(return-from string-
>latin%
300 (unless (zerop null-padding
)
301 (vector-push-extend 0 new-octets
))
302 (copy-seq new-octets
)))))))))
304 ;;;; to-string conversions
306 ;;; from latin (including ascii)
308 (defmacro define-latin-
>string
* (accessor type
)
309 (let ((name (make-od-name 'latin-
>string
* accessor
)))
311 (declaim (inline ,name
))
312 (defun ,name
(string sstart send array astart aend mapper
)
313 (declare (optimize speed
(safety 0))
314 (type simple-string string
)
316 (type array-range sstart send astart aend
)
318 (loop for spos from sstart below send
319 for apos from astart below aend
320 do
(setf (char string spos
)
321 (code-char (funcall mapper
(,accessor array apos
))))
322 finally
(return (values string spos apos
)))))))
323 (instantiate-octets-definition define-latin-
>string
*)
325 (defmacro define-latin-
>string
(accessor type
)
326 (let ((name (make-od-name 'latin-
>string accessor
)))
328 (declaim (inline ,name
))
329 (defun ,name
(array astart aend mapper
)
330 (declare (optimize speed
(safety 0))
332 (type array-range astart aend
)
333 (type function mapper
))
334 (let ((length (the array-range
(- aend astart
))))
335 (values (,(make-od-name 'latin-
>string
* accessor
) (make-string length
) 0 length
338 (instantiate-octets-definition define-latin-
>string
)
340 ;;;; external formats
342 (defvar *default-external-format
* nil
)
344 (defun default-external-format ()
345 (or *default-external-format
*
346 ;; On non-unicode, use iso-8859-1 instead of detecting it from
347 ;; the locale settings. Defaulting to an external-format which
348 ;; can represent characters that the CHARACTER type can't
349 ;; doesn't seem very sensible.
351 (setf *default-external-format
* :latin-1
)
352 (let ((external-format #!-win32
(intern (or (sb!alien
:alien-funcall
355 (function (c-string :external-format
:latin-1
)
360 #!+win32
(sb!win32
::ansi-codepage
)))
361 (/show0
"cold-printing defaulted external-format:")
363 (cold-print external-format
)
364 (/show0
"matching to known aliases")
365 (let ((entry (sb!impl
::get-external-format external-format
)))
370 ;; FIXME! This WARN would try to do printing
371 ;; before the streams have been initialized,
372 ;; causing an infinite erroring loop. We should
373 ;; either print it by calling to C, or delay the
374 ;; warning until later. Since we're in freeze
375 ;; right now, and the warning isn't really
376 ;; essential, I'm doing what's least likely to
377 ;; cause damage, and commenting it out. This
378 ;; should be revisited after 0.9.17. -- JES,
381 (warn "Invalid external-format ~A; using LATIN-1"
383 (setf external-format
:latin-1
))))
384 (/show0
"/default external format ok")
385 (setf *default-external-format
* external-format
))))
387 ;;;; public interface
389 (defun maybe-defaulted-external-format (external-format)
390 (sb!impl
::get-external-format-or-lose
(if (eq external-format
:default
)
391 (default-external-format)
394 (defun octets-to-string (vector &key
(external-format :default
) (start 0) end
)
395 (declare (type (vector (unsigned-byte 8)) vector
))
396 (with-array-data ((vector vector
)
399 :check-fill-pointer t
)
400 (declare (type (simple-array (unsigned-byte 8) (*)) vector
))
401 (let ((ef (maybe-defaulted-external-format external-format
)))
402 (funcall (symbol-function (sb!impl
::ef-octets-to-string-sym ef
))
405 (defun string-to-octets (string &key
(external-format :default
)
406 (start 0) end null-terminate
)
407 (declare (type string string
))
408 (with-array-data ((string string
)
411 :check-fill-pointer t
)
412 (declare (type simple-string string
))
413 (let ((ef (maybe-defaulted-external-format external-format
)))
414 (funcall (symbol-function (sb!impl
::ef-string-to-octets-sym ef
))
415 string start end
(if null-terminate
1 0)))))
418 (defvar +unicode-replacement-character
+ (string (code-char #xfffd
)))
420 (defun use-unicode-replacement-char (condition)
421 (use-value +unicode-replacement-character
+ condition
))
423 ;;; Utilities that maybe should be exported
426 (defmacro with-standard-replacement-character
(&body body
)
427 `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char
))
430 (defmacro with-default-decoding-replacement
((c) &body body
)
431 (let ((cname (gensym)))
434 ((octet-decoding-error (lambda (c)
435 (use-value ,cname c
))))