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
78 ;;; Of these, the only one truly likely to be of interest to calling
79 ;;; code is end-of-input-in-character (in which case it's likely to
80 ;;; want to make a note of octet-decoding-error-start, supply "" as a
81 ;;; replacement string, and then move that last chunk of bytes to the
82 ;;; beginning of its buffer for the next go round) but they're all
83 ;;; provided on the off chance they're of interest.
85 (define-condition octet-decoding-error (character-decoding-error)
86 ((array :initarg :array :accessor octet-decoding-error-array)
87 (start :initarg :start :accessor octet-decoding-error-start)
88 (end :initarg :end :accessor octet-decoding-error-end)
89 (position :initarg :pos :accessor octet-decoding-bad-byte-position)
90 (external-format :initarg :external-format
91 :accessor octet-decoding-error-external-format))
93 (lambda (condition stream)
94 (format stream "Illegal ~S character starting at byte position ~D."
95 (octet-decoding-error-external-format condition)
96 (octet-decoding-error-start condition)))))
98 (define-condition end-of-input-in-character (octet-decoding-error) ())
99 (define-condition character-out-of-range (octet-decoding-error) ())
100 (define-condition invalid-utf8-starter-byte (octet-decoding-error) ())
101 (define-condition invalid-utf8-continuation-byte (octet-decoding-error) ())
102 (define-condition overlong-utf8-sequence (octet-decoding-error) ())
104 (define-condition malformed-ascii (octet-decoding-error) ())
106 (defun read-replacement-string ()
107 (format *query-io* "Enter a replacement string designator (evaluated): ")
108 (finish-output *query-io*)
109 (list (eval (read *query-io*))))
111 (defun decoding-error (array start end external-format reason pos)
114 :external-format external-format
120 :report "Supply a replacement string designator."
121 :interactive read-replacement-string
124 ;;; Utilities used in both to-string and to-octet conversions
126 (defmacro instantiate-octets-definition (definer)
128 (,definer aref (simple-array (unsigned-byte 8) (*)))
129 (,definer sap-ref-8 system-area-pointer)))
131 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
132 ;;; and fix it, or else replace with SYMBOLICATE.
134 ;;; FIXME: this is cute, but is going to prevent greps for def.*<name>
135 ;;; from working for (defun ,(make-od-name ...) ...)
136 (eval-when (:compile-toplevel :load-toplevel :execute)
137 (defun make-od-name (sym1 sym2)
138 ;; "MAKE-NAME" is too generic, but this doesn't do quite what
139 ;; SYMBOLICATE does; MAKE-OD-NAME ("octets definition") it is
141 (intern (concatenate 'string (symbol-name sym1) "-" (symbol-name sym2))
142 (symbol-package sym1))))
144 ;;;; to-octets conversions
146 ;;; to latin (including ascii)
148 ;;; Converting bytes to character codes is easy: just use a 256-element
149 ;;; lookup table that maps each possible byte to its corresponding
152 ;;; Converting character codes to bytes is a little harder, since the
153 ;;; codes may be spare (e.g. we use codes 0-127, 3490, and 4598). The
154 ;;; previous version of this macro utilized a gigantic CASE expression
155 ;;; to do the hard work, with the result that the code was huge (since
156 ;;; SBCL's then-current compilation strategy for CASE expressions was
157 ;;; (and still is) converting CASE into COND into if-the-elses--which is
158 ;;; also inefficient unless your code happens to occur very early in the
161 ;;; The current strategy is to build a table:
163 ;;; [ ... code_1 byte_1 code_2 byte_2 ... code_n byte_n ... ]
165 ;;; such that the codes are sorted in order from lowest to highest. We
166 ;;; can then binary search the table to discover the appropriate byte
167 ;;; for a character code. We also implement an optimization: all unibyte
168 ;;; mappings do not remap ASCII (0-127) and some do not remap part of
169 ;;; the range beyond character code 127. So we check to see if the
170 ;;; character code falls into that range first (a quick check, since
171 ;;; character codes are guaranteed to be positive) and then do the binary
172 ;;; search if not. This optimization also enables us to cut down on the
173 ;;; size of our lookup table.
174 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
175 (let* (;; Build a list of (CODE BYTE) pairs
176 (pairs (loop for byte below 256
177 for code = (let ((exception (cdr (assoc byte exceptions))))
179 ((car exception) (car exception))
180 ((null exception) byte)
182 when code collect (list code byte) into elements
183 finally (return elements)))
184 ;; Find the smallest character code such that the corresponding
185 ;; byte is != to the code.
186 (lowest-non-equivalent-code (position-if-not #'(lambda (pair)
189 ;; Sort them for our lookup table.
190 (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
192 ;; Create the lookup table.
194 (reduce #'append sorted-pairs :from-end t :initial-value nil)))
196 ; Can't inline it with a non-null lexical environment anyway.
197 ;(declaim (inline ,byte-char-name))
198 (let ((byte-to-code-table
199 ,(make-array 256 :element-type t #+nil 'char-code
200 :initial-contents (loop for byte below 256
202 (let ((exception (cadr (assoc byte exceptions))))
207 ,(make-array (length sorted-lookup-table)
208 :initial-contents sorted-lookup-table)))
209 (defun ,byte-char-name (byte)
210 (declare (optimize speed (safety 0))
211 (type (unsigned-byte 8) byte))
212 (aref byte-to-code-table byte))
213 (defun ,code-byte-name (code)
214 (declare (optimize speed (safety 0))
215 (type char-code code))
216 (if (< code ,lowest-non-equivalent-code)
218 ;; We could toss in some TRULY-THEs if we really needed to
219 ;; make this faster...
221 with high = (- (length code-to-byte-table) 2)
223 do (let ((mid (logandc2 (truncate (+ low high 2) 2) 1)))
224 (if (< code (aref code-to-byte-table mid))
225 (setf high (- mid 2))
227 finally (return (if (eql code (aref code-to-byte-table low))
228 (aref code-to-byte-table (1+ low))
231 (declaim (inline get-latin-bytes))
232 (defun get-latin-bytes (mapper external-format string pos)
233 (let ((code (funcall mapper (char-code (char string pos)))))
234 (declare (type (or null char-code) code))
236 ((and code (< code 256)) code)
238 (encoding-error external-format string pos)))
241 (declaim (inline string->latin%))
242 (defun string->latin% (string sstart send get-bytes null-padding)
243 (declare (optimize speed)
244 (type simple-string string)
245 (type index sstart send)
246 (type (integer 0 1) null-padding)
247 (type function get-bytes))
248 ;; The latin encodings are all unibyte encodings, so just directly
249 ;; compute the number of octets we're going to generate.
250 (let ((octets (make-array (+ (- send sstart) null-padding)
251 ;; This takes care of any null padding the
254 :element-type '(unsigned-byte 8)))
260 (loop for pos of-type index from sstart below send
261 do (let ((byte (funcall get-bytes string pos)))
264 (locally (declare (optimize (sb!c::insert-array-bounds-checks 0)))
265 (setf (aref octets index) byte)))
266 ((simple-array (unsigned-byte 8) (*))
267 ;; KLUDGE: We ran into encoding errors. Bail and do
268 ;; things the slow way (does anybody actually use this
269 ;; functionality besides our own test suite?).
270 (setf error-position pos error-replacement byte)
273 finally (return-from string->latin% octets))
275 ;; We have encoded INDEX octets so far and we ran into an
276 ;; encoding error at ERROR-POSITION; the user has asked us to
277 ;; replace the expected output with ERROR-REPLACEMENT.
278 (let ((new-octets (make-array (* index 2)
279 :element-type '(unsigned-byte 8)
280 :adjustable t :fill-pointer index)))
281 (replace new-octets octets)
282 (flet ((extend (thing)
284 ((unsigned-byte 8) (vector-push-extend thing new-octets))
285 ((simple-array (unsigned-byte 8) (*))
286 (dotimes (i (length thing))
287 (vector-push-extend (aref thing i) new-octets))))))
288 (extend error-replacement)
289 (loop for pos of-type index from (1+ error-position) below send
290 do (extend (funcall get-bytes string pos))
291 finally (return-from string->latin%
293 (unless (zerop null-padding)
294 (vector-push-extend 0 new-octets))
295 (copy-seq new-octets)))))))))
297 ;;;; to-string conversions
299 ;;; from latin (including ascii)
301 (defmacro define-latin->string* (accessor type)
302 (let ((name (make-od-name 'latin->string* accessor)))
304 (declaim (inline ,name))
305 (defun ,name (string sstart send array astart aend mapper)
306 (declare (optimize speed (safety 0))
307 (type simple-string string)
309 (type array-range sstart send astart aend)
311 (loop for spos from sstart below send
312 for apos from astart below aend
313 do (setf (char string spos)
314 (code-char (funcall mapper (,accessor array apos))))
315 finally (return (values string spos apos)))))))
316 (instantiate-octets-definition define-latin->string*)
318 (defmacro define-latin->string (accessor type)
319 (let ((name (make-od-name 'latin->string accessor)))
321 (declaim (inline ,name))
322 (defun ,name (array astart aend mapper)
323 (declare (optimize speed (safety 0))
325 (type array-range astart aend)
326 (type function mapper))
327 (let ((length (the array-range (- aend astart))))
328 (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
331 (instantiate-octets-definition define-latin->string)
333 ;;;; external formats
335 (defvar *default-external-format* nil)
337 (defun default-external-format ()
338 (or *default-external-format*
339 ;; On non-unicode, use iso-8859-1 instead of detecting it from
340 ;; the locale settings. Defaulting to an external-format which
341 ;; can represent characters that the CHARACTER type can't
342 ;; doesn't seem very sensible.
344 (setf *default-external-format* :latin-1)
345 (let ((external-format #!-win32 (intern (or (sb!alien:alien-funcall
348 (function (c-string :external-format :latin-1)
353 #!+win32 (sb!win32::ansi-codepage)))
354 (/show0 "cold-printing defaulted external-format:")
356 (cold-print external-format)
357 (/show0 "matching to known aliases")
358 (let ((entry (sb!impl::get-external-format external-format)))
363 ;; FIXME! This WARN would try to do printing
364 ;; before the streams have been initialized,
365 ;; causing an infinite erroring loop. We should
366 ;; either print it by calling to C, or delay the
367 ;; warning until later. Since we're in freeze
368 ;; right now, and the warning isn't really
369 ;; essential, I'm doing what's least likely to
370 ;; cause damage, and commenting it out. This
371 ;; should be revisited after 0.9.17. -- JES,
374 (warn "Invalid external-format ~A; using LATIN-1"
376 (setf external-format :latin-1))))
377 (/show0 "/default external format ok")
378 (setf *default-external-format* external-format))))
380 ;;;; public interface
382 (defun maybe-defaulted-external-format (external-format)
383 (sb!impl::get-external-format-or-lose (if (eq external-format :default)
384 (default-external-format)
387 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
388 (declare (type (vector (unsigned-byte 8)) vector))
389 (with-array-data ((vector vector)
392 :check-fill-pointer t)
393 (declare (type (simple-array (unsigned-byte 8) (*)) vector))
394 (let ((ef (maybe-defaulted-external-format external-format)))
395 (funcall (sb!impl::ef-octets-to-string-fun ef) vector start end))))
397 (defun string-to-octets (string &key (external-format :default)
398 (start 0) end null-terminate)
399 (declare (type string string))
400 (with-array-data ((string string)
403 :check-fill-pointer t)
404 (declare (type simple-string string))
405 (let ((ef (maybe-defaulted-external-format external-format)))
406 (funcall (sb!impl::ef-string-to-octets-fun ef) string start end
407 (if null-terminate 1 0)))))
410 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
412 (defun use-unicode-replacement-char (condition)
413 (use-value +unicode-replacement-character+ condition))
415 ;;; Utilities that maybe should be exported
418 (defmacro with-standard-replacement-character (&body body)
419 `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
422 (defmacro with-default-decoding-replacement ((c) &body body)
423 (let ((cname (gensym)))
426 ((octet-decoding-error (lambda (c)
427 (use-value ,cname c))))