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 ;;; maps into TO-SEQ from elements of FROM-SEQ via MAPPER. MAPPER
139 ;;; returns two values: the number of elments stored in TO-SEQ, and
140 ;;; the number used up from FROM-SEQ. MAPPER is responsible for
141 ;;; getting out if either sequence runs out of room.
142 (declaim (inline varimap
))
143 (defun varimap (to-seq to-start to-end from-start from-end mapper
)
144 (declare (optimize speed
(safety 0))
145 (type array-range to-start to-end from-start from-end
)
146 (type function mapper
))
147 (loop with from-size of-type array-range
= 0
148 and to-size of-type array-range
= 0
149 for to-pos of-type array-range
= to-start then
(+ to-pos to-size
)
150 for from-pos of-type array-range
= from-start then
(+ from-pos from-size
)
151 while
(and (< to-pos to-end
)
152 (< from-pos from-end
))
153 do
(multiple-value-bind (ts fs
) (funcall mapper to-pos from-pos
)
156 finally
(return (values to-seq to-pos from-pos
))))
158 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
159 ;;; and fix it, or else replace with SYMBOLICATE.
161 ;;; FIXME: this is cute, but is going to prevent greps for def.*<name>
162 ;;; from working for (defun ,(make-od-name ...) ...)
163 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
164 (defun make-od-name (sym1 sym2
)
165 ;; "MAKE-NAME" is too generic, but this doesn't do quite what
166 ;; SYMBOLICATE does; MAKE-OD-NAME ("octets definition") it is
168 (intern (concatenate 'string
(symbol-name sym1
) "-" (symbol-name sym2
))
169 (symbol-package sym1
))))
171 ;;;; to-octets conversions
173 ;;; to latin (including ascii)
175 ;;; Converting bytes to character codes is easy: just use a 256-element
176 ;;; lookup table that maps each possible byte to its corresponding
179 ;;; Converting character codes to bytes is a little harder, since the
180 ;;; codes may be spare (e.g. we use codes 0-127, 3490, and 4598). The
181 ;;; previous version of this macro utilized a gigantic CASE expression
182 ;;; to do the hard work, with the result that the code was huge (since
183 ;;; SBCL's then-current compilation strategy for CASE expressions was
184 ;;; (and still is) converting CASE into COND into if-the-elses--which is
185 ;;; also inefficient unless your code happens to occur very early in the
188 ;;; The current strategy is to build a table:
190 ;;; [ ... code_1 byte_1 code_2 byte_2 ... code_n byte_n ... ]
192 ;;; such that the codes are sorted in order from lowest to highest. We
193 ;;; can then binary search the table to discover the appropriate byte
194 ;;; for a character code. We also implement an optimization: all unibyte
195 ;;; mappings do not remap ASCII (0-127) and some do not remap part of
196 ;;; the range beyond character code 127. So we check to see if the
197 ;;; character code falls into that range first (a quick check, since
198 ;;; character codes are guaranteed to be positive) and then do the binary
199 ;;; search if not. This optimization also enables us to cut down on the
200 ;;; size of our lookup table.
201 (defmacro define-unibyte-mapper
(byte-char-name code-byte-name
&rest exceptions
)
202 (let* (;; Build a list of (CODE BYTE) pairs
203 (pairs (loop for byte below
256
204 for code
= (let ((exception (cdr (assoc byte exceptions
))))
206 ((car exception
) (car exception
))
207 ((null exception
) byte
)
209 when code collect
(list code byte
) into elements
210 finally
(return elements
)))
211 ;; Find the smallest character code such that the corresponding
212 ;; byte is != to the code.
213 (lowest-non-equivalent-code (position-if-not #'(lambda (pair)
216 ;; Sort them for our lookup table.
217 (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code
)
219 ;; Create the lookup table.
221 (reduce #'append sorted-pairs
:from-end t
:initial-value nil
)))
223 ; Can't inline it with a non-null lexical environment anyway.
224 ;(declaim (inline ,byte-char-name))
225 (let ((byte-to-code-table
226 ,(make-array 256 :element-type t
#+nil
'char-code
227 :initial-contents
(loop for byte below
256
229 (let ((exception (cadr (assoc byte exceptions
))))
234 ,(make-array (length sorted-lookup-table
)
235 :initial-contents sorted-lookup-table
)))
236 (defun ,byte-char-name
(byte)
237 (declare (optimize speed
(safety 0))
238 (type (unsigned-byte 8) byte
))
239 (aref byte-to-code-table byte
))
240 (defun ,code-byte-name
(code)
241 (declare (optimize speed
(safety 0))
242 (type char-code code
))
243 (if (< code
,lowest-non-equivalent-code
)
245 ;; We could toss in some TRULY-THEs if we really needed to
246 ;; make this faster...
248 with high
= (- (length code-to-byte-table
) 2)
250 do
(let ((mid (logandc2 (truncate (+ low high
2) 2) 1)))
251 (if (< code
(aref code-to-byte-table mid
))
252 (setf high
(- mid
2))
254 finally
(return (if (eql code
(aref code-to-byte-table low
))
255 (aref code-to-byte-table
(1+ low
))
259 (define-unibyte-mapper
271 (declaim (inline get-latin-bytes
))
272 (defun get-latin-bytes (mapper external-format string pos
)
273 (let ((code (funcall mapper
(char-code (char string pos
)))))
274 (declare (type (or null char-code
) code
))
276 ((and code
(< code
256)) code
)
278 (encoding-error external-format string pos
)))
281 (declaim (inline code-
>ascii-mapper
))
282 (defun code->ascii-mapper
(code)
283 (declare (optimize speed
(safety 0))
284 (type char-code code
))
289 (declaim (inline get-ascii-bytes
))
290 (defun get-ascii-bytes (string pos
)
291 (declare (optimize speed
(safety 0))
292 (type simple-string string
)
293 (type array-range pos
))
294 (get-latin-bytes #'code-
>ascii-mapper
:ascii string pos
))
296 (declaim (inline get-latin1-bytes
))
297 (defun get-latin1-bytes (string pos
)
298 (declare (optimize speed
(safety 0))
299 (type simple-string string
)
300 (type array-range pos
))
301 (get-latin-bytes #'identity
:latin-1 string pos
))
305 (declaim (inline get-latin9-bytes
))
306 (defun get-latin9-bytes (string pos
)
307 (declare (optimize speed
(safety 0))
308 (type simple-string string
)
309 (type array-range pos
))
310 (get-latin-bytes #'code-
>latin9-mapper
:latin-9 string pos
)))
312 (declaim (inline string-
>latin%
))
313 (defun string->latin%
(string sstart send get-bytes null-padding
)
314 (declare (optimize speed
)
315 (type simple-string string
)
316 (type index sstart send
)
317 (type (integer 0 1) null-padding
)
318 (type function get-bytes
))
319 ;; The latin encodings are all unibyte encodings, so just directly
320 ;; compute the number of octets we're going to generate.
321 (let ((octets (make-array (+ (- send sstart
) null-padding
)
322 ;; This takes care of any null padding the
325 :element-type
'(unsigned-byte 8)))
330 (loop for pos of-type index from sstart below send
331 do
(let ((byte (funcall get-bytes string pos
)))
334 (locally (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
335 (setf (aref octets index
) byte
)))
336 ((simple-array (unsigned-byte 8) (*))
337 ;; KLUDGE: We ran into encoding errors. Bail and do
338 ;; things the slow way (does anybody actually use this
339 ;; functionality besides our own test suite?).
340 (setf error-position pos
)
343 finally
(return-from string-
>latin% octets
))
345 ;; We have encoded INDEX octets so far and we ran into an encoding
346 ;; error at ERROR-POSITION.
347 (let ((new-octets (make-array (* index
2)
348 :element-type
'(unsigned-byte 8)
349 :adjustable t
:fill-pointer index
)))
350 (replace new-octets octets
)
351 (loop for pos of-type index from error-position below send
352 do
(let ((thing (funcall get-bytes string pos
)))
355 (vector-push-extend thing new-octets
))
356 ((simple-array (unsigned-byte 8) (*))
357 (dotimes (i (length thing
))
358 (vector-push-extend (aref thing i
) new-octets
)))))
359 finally
(return-from string-
>latin%
361 (unless (zerop null-padding
)
362 (vector-push-extend 0 new-octets
))
363 (copy-seq new-octets
))))))))
365 (defun string->ascii
(string sstart send null-padding
)
366 (declare (optimize speed
(safety 0))
367 (type simple-string string
)
368 (type array-range sstart send
))
369 (values (string->latin% string sstart send
#'get-ascii-bytes null-padding
)))
371 (defun string->latin1
(string sstart send null-padding
)
372 (declare (optimize speed
(safety 0))
373 (type simple-string string
)
374 (type array-range sstart send
))
375 (values (string->latin% string sstart send
#'get-latin1-bytes null-padding
)))
378 (defun string->latin9
(string sstart send null-padding
)
379 (declare (optimize speed
(safety 0))
380 (type simple-string string
)
381 (type array-range sstart send
))
382 (values (string->latin% string sstart send
#'get-latin9-bytes null-padding
)))
386 (declaim (inline char-len-as-utf8
))
387 (defun char-len-as-utf8 (code)
388 (declare (optimize speed
(safety 0))
389 (type (integer 0 (#.sb
!xc
:char-code-limit
)) code
))
390 (cond ((< code
0) (bug "can't happen"))
394 ((< code
#x110000
) 4)
395 (t (bug "can't happen"))))
397 (defun string->utf8
(string sstart send null-padding
)
398 (declare (optimize (speed 3) (safety 0))
399 (type simple-string string
)
400 (type (integer 0 1) null-padding
)
401 (type array-range sstart send
))
402 (macrolet ((ascii-bash ()
403 '(let ((array (make-array (+ null-padding
(- send sstart
))
404 :element-type
'(unsigned-byte 8))))
405 (loop for i from sstart below send
406 do
(setf (aref array i
) (char-code (char string i
))))
409 ((simple-array character
(*))
410 (let ((utf8-length 0))
411 ;; Since it has to fit in a vector, it must be a fixnum!
412 (declare (type (and unsigned-byte fixnum
) utf8-length
))
413 (loop for i of-type index from sstart below send
414 do
(incf utf8-length
(char-len-as-utf8 (char-code (char string i
)))))
415 (if (= utf8-length
(- send sstart
))
417 (let ((array (make-array (+ null-padding utf8-length
)
418 :element-type
'(unsigned-byte 8)))
420 (declare (type index index
))
422 (setf (aref array index
) b
)
424 (declare (inline add-byte
))
425 (loop for i of-type index from sstart below send
426 do
(let ((code (char-code (char string i
))))
427 (case (char-len-as-utf8 code
)
431 (add-byte (logior #b11000000
(ldb (byte 5 6) code
)))
432 (add-byte (logior #b10000000
(ldb (byte 6 0) code
))))
434 (add-byte (logior #b11100000
(ldb (byte 4 12) code
)))
435 (add-byte (logior #b10000000
(ldb (byte 6 6) code
)))
436 (add-byte (logior #b10000000
(ldb (byte 6 0) code
))))
438 (add-byte (logior #b11110000
(ldb (byte 3 18) code
)))
439 (add-byte (logior #b10000000
(ldb (byte 6 12) code
)))
440 (add-byte (logior #b10000000
(ldb (byte 6 6) code
)))
441 (add-byte (logior #b10000000
(ldb (byte 6 0) code
))))))
442 finally
(return array
)))))))
444 ((simple-array base-char
(*))
445 ;; On unicode builds BASE-STRINGs are limited to ASCII range, so we can take
446 ;; a fast path -- and get benefit of the element type information. On non-unicode
447 ;; build BASE-CHAR == CHARACTER.
449 ((simple-array nil
(*))
450 ;; Just get the error...
451 (aref string sstart
)))))
453 ;;;; to-string conversions
455 ;;; from latin (including ascii)
457 (defmacro define-ascii-
>string
(accessor type
)
458 (let ((name (make-od-name 'ascii-
>string accessor
)))
460 (defun ,name
(array astart aend
)
461 (declare (optimize speed
)
463 (type array-range astart aend
))
464 ;; Since there is such a thing as a malformed ascii byte, a
465 ;; simple "make the string, fill it in" won't do.
466 (let ((string (make-array 0 :element-type
'character
:fill-pointer
0 :adjustable t
)))
467 (loop for apos from astart below aend
468 do
(let* ((code (,accessor array apos
))
472 (decoding-error array apos
(1+ apos
) :ascii
473 'malformed-ascii apos
))))
474 (if (characterp string-content
)
475 (vector-push-extend string-content string
)
476 (loop for c across string-content
477 do
(vector-push-extend c string
))))
478 finally
(return (coerce string
'simple-string
))))))))
479 (instantiate-octets-definition define-ascii-
>string
)
481 (defmacro define-latin-
>string
* (accessor type
)
482 (let ((name (make-od-name 'latin-
>string
* accessor
)))
484 (declaim (inline ,name
))
485 (defun ,name
(string sstart send array astart aend mapper
)
486 (declare (optimize speed
(safety 0))
487 (type simple-string string
)
489 (type array-range sstart send astart aend
)
491 (varimap string sstart send
494 (setf (char string spos
) (code-char (funcall mapper
(,accessor array apos
))))
496 (instantiate-octets-definition define-latin-
>string
*)
498 (defmacro define-latin1-
>string
* (accessor type
)
499 (declare (ignore type
))
500 (let ((name (make-od-name 'latin1-
>string
* accessor
)))
502 (defun ,name
(string sstart send array astart aend
)
503 (,(make-od-name 'latin-
>string
* accessor
) string sstart send array astart aend
#'identity
)))))
504 (instantiate-octets-definition define-latin1-
>string
*)
508 (defmacro define-latin9-
>string
* (accessor type
)
509 (declare (ignore type
))
510 (let ((name (make-od-name 'latin9-
>string
* accessor
)))
512 (defun ,name
(string sstart send array astart aend
)
513 (,(make-od-name 'latin-
>string
* accessor
) string sstart send array astart aend
#'latin9-
>code-mapper
)))))
514 (instantiate-octets-definition define-latin9-
>string
*))
516 (defmacro define-latin-
>string
(accessor type
)
517 (let ((name (make-od-name 'latin-
>string accessor
)))
519 (declaim (inline latin-
>string
))
520 (defun ,name
(array astart aend mapper
)
521 (declare (optimize speed
(safety 0))
523 (type array-range astart aend
)
524 (type function mapper
))
525 (let ((length (the array-range
(- aend astart
))))
526 (values (,(make-od-name 'latin-
>string
* accessor
) (make-string length
) 0 length
529 (instantiate-octets-definition define-latin-
>string
)
531 (defmacro define-latin1-
>string
(accessor type
)
532 (declare (ignore type
))
533 `(defun ,(make-od-name 'latin1-
>string accessor
) (array astart aend
)
534 (,(make-od-name 'latin-
>string accessor
) array astart aend
#'identity
)))
535 (instantiate-octets-definition define-latin1-
>string
)
539 (defmacro define-latin9-
>string
(accessor type
)
540 (declare (ignore type
))
541 `(defun ,(make-od-name 'latin9-
>string accessor
) (array astart aend
)
542 (,(make-od-name 'latin-
>string accessor
) array astart aend
#'latin9-
>code-mapper
)))
543 (instantiate-octets-definition define-latin9-
>string
))
547 (defmacro define-bytes-per-utf8-character
(accessor type
)
548 (let ((name (make-od-name 'bytes-per-utf8-character accessor
)))
550 ;;(declaim (inline ,name))
552 (string->utf8
(string (code-char ,(1- sb
!xc
:char-code-limit
)))
554 (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode
4 #!-sb-unicode
2)) lexically-max
))
555 (defun ,name
(array pos end
)
556 (declare (optimize speed
(safety 0))
558 (type array-range pos end
))
559 ;; returns the number of bytes consumed and nil if it's a
560 ;; valid character or the number of bytes consumed and a
561 ;; replacement string if it's not.
562 (let ((initial-byte (,accessor array pos
))
564 (reject-position pos
)
565 (remaining-bytes (- end pos
)))
566 (declare (type array-range reject-position remaining-bytes
))
567 (labels ((valid-utf8-starter-byte-p (b)
568 (declare (type (unsigned-byte 8) b
))
570 ((zerop (logand b
#b10000000
)) 1)
571 ((= (logand b
#b11100000
) #b11000000
)
573 ((= (logand b
#b11110000
) #b11100000
)
575 ((= (logand b
#b11111000
) #b11110000
)
577 ((= (logand b
#b11111100
) #b11111000
)
579 ((= (logand b
#b11111110
) #b11111100
)
584 (setf reject-reason
'invalid-utf8-starter-byte
))
586 (enough-bytes-left-p (x)
587 (let ((ok (> end
(+ pos
(1- x
)))))
589 (setf reject-reason
'end-of-input-in-character
))
591 (valid-secondary-p (x)
592 (let* ((idx (the array-range
(+ pos x
)))
593 (b (,accessor array idx
))
594 (ok (= (logand b
#b11000000
) #b10000000
)))
596 (setf reject-reason
'invalid-utf8-continuation-byte
)
597 (setf reject-position idx
))
599 (preliminary-ok-for-length (maybe-len len
)
600 (and (eql maybe-len len
)
601 ;; Has to be done in this order so that
602 ;; certain broken sequences (e.g., the
603 ;; two-byte sequence `"initial (length 3)"
604 ;; "non-continuation"' -- `#xef #x32')
605 ;; signal only part of that sequence as
607 (loop for i from
1 below
(min len remaining-bytes
)
608 always
(valid-secondary-p i
))
609 (enough-bytes-left-p len
)))
611 (let ((ok (or (/= initial-byte x
)
612 (/= (logior (,accessor array
(the array-range
(+ pos
1)))
616 (setf reject-reason
'overlong-utf8-sequence
))
618 (character-below-char-code-limit-p ()
619 ;; This is only called on a four-byte sequence
620 ;; (two in non-unicode builds) to ensure we
621 ;; don't go over SBCL's character limts.
622 (let ((ok (cond ((< (aref lexically-max
0) (,accessor array pos
))
624 ((> (aref lexically-max
0) (,accessor array pos
))
626 ((< (aref lexically-max
1) (,accessor array
(+ pos
1)))
629 ((> (aref lexically-max
1) (,accessor array
(+ pos
1)))
632 ((< (aref lexically-max
2) (,accessor array
(+ pos
2)))
635 ((> (aref lexically-max
2) (,accessor array
(+ pos
2)))
638 ((< (aref lexically-max
3) (,accessor array
(+ pos
3)))
642 (setf reject-reason
'character-out-of-range
))
644 (declare (inline valid-utf8-starter-byte-p
647 preliminary-ok-for-length
649 (let ((maybe-len (valid-utf8-starter-byte-p initial-byte
)))
650 (cond ((eql maybe-len
1)
652 ((and (preliminary-ok-for-length maybe-len
2)
653 (overlong-chk #b11000000
#b10111111
)
654 (overlong-chk #b11000001
#b10111111
)
655 #!-sb-unicode
(character-below-char-code-limit-p))
657 ((and (preliminary-ok-for-length maybe-len
3)
658 (overlong-chk #b11100000
#b10011111
)
659 #!-sb-unicode
(not (setf reject-reason
'character-out-of-range
)))
661 ((and (preliminary-ok-for-length maybe-len
4)
662 (overlong-chk #b11110000
#b10001111
)
663 #!-sb-unicode
(not (setf reject-reason
'character-out-of-range
))
664 (character-below-char-code-limit-p))
666 ((and (preliminary-ok-for-length maybe-len
5)
667 (overlong-chk #b11111000
#b10000111
)
668 (not (setf reject-reason
'character-out-of-range
)))
669 (bug "can't happen"))
670 ((and (preliminary-ok-for-length maybe-len
6)
671 (overlong-chk #b11111100
#b10000011
)
672 (not (setf reject-reason
'character-out-of-range
)))
673 (bug "can't happen"))
675 (let* ((bad-end (ecase reject-reason
676 (invalid-utf8-starter-byte
678 (end-of-input-in-character
680 (invalid-utf8-continuation-byte
682 ((overlong-utf8-sequence character-out-of-range
)
684 (bad-len (- bad-end pos
)))
685 (declare (type array-range bad-end bad-len
))
686 (let ((replacement (decoding-error array pos bad-end
:utf-8 reject-reason reject-position
)))
687 (values bad-len replacement
)))))))))))))
688 (instantiate-octets-definition define-bytes-per-utf8-character
)
690 (defmacro define-simple-get-utf8-char
(accessor type
)
691 (let ((name (make-od-name 'simple-get-utf8-char accessor
)))
693 (declaim (inline ,name
))
694 (defun ,name
(array pos bytes
)
695 (declare (optimize speed
(safety 0))
697 (type array-range pos
)
698 (type (integer 1 4) bytes
))
700 (,accessor array
(the array-range
(+ pos x
)))))
701 (declare (inline cref
))
702 (code-char (ecase bytes
704 (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6)
705 (ldb (byte 6 0) (cref 1))))
706 (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12)
707 (ash (ldb (byte 6 0) (cref 1)) 6)
708 (ldb (byte 6 0) (cref 2))))
709 (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18)
710 (ash (ldb (byte 6 0) (cref 1)) 12)
711 (ash (ldb (byte 6 0) (cref 2)) 6)
712 (ldb (byte 6 0) (cref 3)))))))))))
713 (instantiate-octets-definition define-simple-get-utf8-char
)
715 (defmacro define-utf8-
>string
(accessor type
)
716 (let ((name (make-od-name 'utf8-
>string accessor
)))
718 (defun ,name
(array astart aend
)
719 (declare (optimize speed
(safety 0))
721 (type array-range astart aend
))
722 (let ((string (make-array 0 :adjustable t
:fill-pointer
0 :element-type
'character
)))
723 (loop with pos
= astart
725 do
(multiple-value-bind (bytes invalid
)
726 (,(make-od-name 'bytes-per-utf8-character accessor
) array pos aend
)
727 (declare (type (or null string
) invalid
))
730 (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor
) array pos bytes
) string
))
732 (dotimes (i (length invalid
))
733 (vector-push-extend (char invalid i
) string
))))
735 (coerce string
'simple-string
))))))
736 (instantiate-octets-definition define-utf8-
>string
)
738 ;;;; external formats
740 (defvar *default-external-format
* nil
)
742 (defun default-external-format ()
743 (or *default-external-format
*
744 ;; On non-unicode, use iso-8859-1 instead of detecting it from
745 ;; the locale settings. Defaulting to an external-format which
746 ;; can represent characters that the CHARACTER type can't
747 ;; doesn't seem very sensible.
749 (setf *default-external-format
* :latin-1
)
750 (let ((external-format #!-win32
(intern (or (sb!alien
:alien-funcall
753 (function (c-string :external-format
:latin-1
)
758 #!+win32
(sb!win32
::ansi-codepage
)))
759 (/show0
"cold-printing defaulted external-format:")
761 (cold-print external-format
)
762 (/show0
"matching to known aliases")
763 (dolist (entry *external-formats
*
765 ;;; FIXME! This WARN would try to do printing
766 ;;; before the streams have been initialized,
767 ;;; causing an infinite erroring loop. We should
768 ;;; either print it by calling to C, or delay the
769 ;;; warning until later. Since we're in freeze
770 ;;; right now, and the warning isn't really
771 ;;; essential, I'm doing what's least likely to
772 ;;; cause damage, and commenting it out. This
773 ;;; should be revisited after 0.9.17. -- JES,
776 (warn "Invalid external-format ~A; using LATIN-1"
778 (setf external-format
:latin-1
)))
779 (/show0
"cold printing known aliases:")
781 (dolist (alias (first entry
)) (cold-print alias
))
782 (/show0
"done cold-printing known aliases")
783 (when (member external-format
(first entry
))
786 (/show0
"/default external format ok")
787 (setf *default-external-format
* external-format
))))
789 ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
790 (defparameter *external-format-functions
* (make-hash-table))
792 (defun add-external-format-funs (format-names funs
)
793 (dolist (name format-names
(values))
794 (setf (gethash name
*external-format-functions
*) funs
)))
796 (add-external-format-funs
797 '(:ascii
:us-ascii
:ansi_x3.4-
1968 :iso-646
:iso-646-us
:|
646|
)
798 '(ascii->string-aref string-
>ascii
))
799 (add-external-format-funs
800 '(:latin1
:latin-1
:iso-8859-1
:iso8859-1
)
801 '(latin1->string-aref string-
>latin1
))
803 (add-external-format-funs
804 '(:latin9
:latin-9
:iso-8859-15
:iso8859-15
)
805 '(latin9->string-aref string-
>latin9
))
806 (add-external-format-funs '(:utf8
:utf-8
) '(utf8->string-aref string-
>utf8
))
808 (defun external-formats-funs (external-format)
809 (when (eql external-format
:default
)
810 (setf external-format
(default-external-format)))
811 (or (gethash external-format
*external-format-functions
*)
812 (error "Unknown external-format ~S" external-format
)))
814 ;;;; public interface
816 (defun octets-to-string (vector &key
(external-format :default
) (start 0) end
)
817 (declare (type (vector (unsigned-byte 8)) vector
))
818 (with-array-data ((vector vector
)
820 (end (%check-vector-sequence-bounds vector start end
)))
821 (declare (type (simple-array (unsigned-byte 8) (*)) vector
))
822 (funcall (symbol-function (first (external-formats-funs external-format
)))
825 (defun string-to-octets (string &key
(external-format :default
)
826 (start 0) end null-terminate
)
827 (declare (type string string
))
828 (with-array-data ((string string
)
830 (end (%check-vector-sequence-bounds string start end
)))
831 (declare (type simple-string string
))
832 (funcall (symbol-function (second (external-formats-funs external-format
)))
833 string start end
(if null-terminate
1 0))))
836 (defvar +unicode-replacement-character
+ (string (code-char #xfffd
)))
838 (defun use-unicode-replacement-char (condition)
839 (use-value +unicode-replacement-character
+ condition
))
841 ;;; Utilities that maybe should be exported
844 (defmacro with-standard-replacement-character
(&body body
)
845 `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char
))
848 (defmacro with-default-decoding-replacement
((c) &body body
)
849 (let ((cname (gensym)))
852 ((octet-decoding-error (lambda (c)
853 (use-value ,cname c
))))