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))))
406 and j from sstart below send
407 do (setf (aref array i) (char-code (char string j))))
410 ((simple-array character (*))
411 (let ((utf8-length 0))
412 ;; Since it has to fit in a vector, it must be a fixnum!
413 (declare (type (and unsigned-byte fixnum) utf8-length))
414 (loop for i of-type index from sstart below send
415 do (incf utf8-length (char-len-as-utf8 (char-code (char string i)))))
416 (if (= utf8-length (- send sstart))
418 (let ((array (make-array (+ null-padding utf8-length)
419 :element-type '(unsigned-byte 8)))
421 (declare (type index index))
423 (setf (aref array index) b)
425 (declare (inline add-byte))
426 (loop for i of-type index from sstart below send
427 do (let ((code (char-code (char string i))))
428 (case (char-len-as-utf8 code)
432 (add-byte (logior #b11000000 (ldb (byte 5 6) code)))
433 (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
435 (add-byte (logior #b11100000 (ldb (byte 4 12) code)))
436 (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
437 (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
439 (add-byte (logior #b11110000 (ldb (byte 3 18) code)))
440 (add-byte (logior #b10000000 (ldb (byte 6 12) code)))
441 (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
442 (add-byte (logior #b10000000 (ldb (byte 6 0) code))))))
443 finally (return array)))))))
445 ((simple-array base-char (*))
446 ;; On unicode builds BASE-STRINGs are limited to ASCII range, so we can take
447 ;; a fast path -- and get benefit of the element type information. On non-unicode
448 ;; build BASE-CHAR == CHARACTER.
450 ((simple-array nil (*))
451 ;; Just get the error...
452 (aref string sstart)))))
454 ;;;; to-string conversions
456 ;;; from latin (including ascii)
458 (defmacro define-ascii->string (accessor type)
459 (let ((name (make-od-name 'ascii->string accessor)))
461 (defun ,name (array astart aend)
462 (declare (optimize speed)
464 (type array-range astart aend))
465 ;; Since there is such a thing as a malformed ascii byte, a
466 ;; simple "make the string, fill it in" won't do.
467 (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
468 (loop for apos from astart below aend
469 do (let* ((code (,accessor array apos))
473 (decoding-error array apos (1+ apos) :ascii
474 'malformed-ascii apos))))
475 (if (characterp string-content)
476 (vector-push-extend string-content string)
477 (loop for c across string-content
478 do (vector-push-extend c string))))
479 finally (return (coerce string 'simple-string))))))))
480 (instantiate-octets-definition define-ascii->string)
482 (defmacro define-latin->string* (accessor type)
483 (let ((name (make-od-name 'latin->string* accessor)))
485 (declaim (inline ,name))
486 (defun ,name (string sstart send array astart aend mapper)
487 (declare (optimize speed (safety 0))
488 (type simple-string string)
490 (type array-range sstart send astart aend)
492 (varimap string sstart send
495 (setf (char string spos) (code-char (funcall mapper (,accessor array apos))))
497 (instantiate-octets-definition define-latin->string*)
499 (defmacro define-latin1->string* (accessor type)
500 (declare (ignore type))
501 (let ((name (make-od-name 'latin1->string* accessor)))
503 (defun ,name (string sstart send array astart aend)
504 (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity)))))
505 (instantiate-octets-definition define-latin1->string*)
509 (defmacro define-latin9->string* (accessor type)
510 (declare (ignore type))
511 (let ((name (make-od-name 'latin9->string* accessor)))
513 (defun ,name (string sstart send array astart aend)
514 (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'latin9->code-mapper)))))
515 (instantiate-octets-definition define-latin9->string*))
517 (defmacro define-latin->string (accessor type)
518 (let ((name (make-od-name 'latin->string accessor)))
520 (declaim (inline latin->string))
521 (defun ,name (array astart aend mapper)
522 (declare (optimize speed (safety 0))
524 (type array-range astart aend)
525 (type function mapper))
526 (let ((length (the array-range (- aend astart))))
527 (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
530 (instantiate-octets-definition define-latin->string)
532 (defmacro define-latin1->string (accessor type)
533 (declare (ignore type))
534 `(defun ,(make-od-name 'latin1->string accessor) (array astart aend)
535 (,(make-od-name 'latin->string accessor) array astart aend #'identity)))
536 (instantiate-octets-definition define-latin1->string)
540 (defmacro define-latin9->string (accessor type)
541 (declare (ignore type))
542 `(defun ,(make-od-name 'latin9->string accessor) (array astart aend)
543 (,(make-od-name 'latin->string accessor) array astart aend #'latin9->code-mapper)))
544 (instantiate-octets-definition define-latin9->string))
548 (defmacro define-bytes-per-utf8-character (accessor type)
549 (let ((name (make-od-name 'bytes-per-utf8-character accessor)))
551 ;;(declaim (inline ,name))
553 (string->utf8 (string (code-char ,(1- sb!xc:char-code-limit)))
555 (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max))
556 (defun ,name (array pos end)
557 (declare (optimize speed (safety 0))
559 (type array-range pos end))
560 ;; returns the number of bytes consumed and nil if it's a
561 ;; valid character or the number of bytes consumed and a
562 ;; replacement string if it's not.
563 (let ((initial-byte (,accessor array pos))
565 (reject-position pos)
566 (remaining-bytes (- end pos)))
567 (declare (type array-range reject-position remaining-bytes))
568 (labels ((valid-utf8-starter-byte-p (b)
569 (declare (type (unsigned-byte 8) b))
571 ((zerop (logand b #b10000000)) 1)
572 ((= (logand b #b11100000) #b11000000)
574 ((= (logand b #b11110000) #b11100000)
576 ((= (logand b #b11111000) #b11110000)
578 ((= (logand b #b11111100) #b11111000)
580 ((= (logand b #b11111110) #b11111100)
585 (setf reject-reason 'invalid-utf8-starter-byte))
587 (enough-bytes-left-p (x)
588 (let ((ok (> end (+ pos (1- x)))))
590 (setf reject-reason 'end-of-input-in-character))
592 (valid-secondary-p (x)
593 (let* ((idx (the array-range (+ pos x)))
594 (b (,accessor array idx))
595 (ok (= (logand b #b11000000) #b10000000)))
597 (setf reject-reason 'invalid-utf8-continuation-byte)
598 (setf reject-position idx))
600 (preliminary-ok-for-length (maybe-len len)
601 (and (eql maybe-len len)
602 ;; Has to be done in this order so that
603 ;; certain broken sequences (e.g., the
604 ;; two-byte sequence `"initial (length 3)"
605 ;; "non-continuation"' -- `#xef #x32')
606 ;; signal only part of that sequence as
608 (loop for i from 1 below (min len remaining-bytes)
609 always (valid-secondary-p i))
610 (enough-bytes-left-p len)))
612 (let ((ok (or (/= initial-byte x)
613 (/= (logior (,accessor array (the array-range (+ pos 1)))
617 (setf reject-reason 'overlong-utf8-sequence))
619 (character-below-char-code-limit-p ()
620 ;; This is only called on a four-byte sequence
621 ;; (two in non-unicode builds) to ensure we
622 ;; don't go over SBCL's character limts.
623 (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos))
625 ((> (aref lexically-max 0) (,accessor array pos))
627 ((< (aref lexically-max 1) (,accessor array (+ pos 1)))
630 ((> (aref lexically-max 1) (,accessor array (+ pos 1)))
633 ((< (aref lexically-max 2) (,accessor array (+ pos 2)))
636 ((> (aref lexically-max 2) (,accessor array (+ pos 2)))
639 ((< (aref lexically-max 3) (,accessor array (+ pos 3)))
643 (setf reject-reason 'character-out-of-range))
645 (declare (inline valid-utf8-starter-byte-p
648 preliminary-ok-for-length
650 (let ((maybe-len (valid-utf8-starter-byte-p initial-byte)))
651 (cond ((eql maybe-len 1)
653 ((and (preliminary-ok-for-length maybe-len 2)
654 (overlong-chk #b11000000 #b10111111)
655 (overlong-chk #b11000001 #b10111111)
656 #!-sb-unicode (character-below-char-code-limit-p))
658 ((and (preliminary-ok-for-length maybe-len 3)
659 (overlong-chk #b11100000 #b10011111)
660 #!-sb-unicode (not (setf reject-reason 'character-out-of-range)))
662 ((and (preliminary-ok-for-length maybe-len 4)
663 (overlong-chk #b11110000 #b10001111)
664 #!-sb-unicode (not (setf reject-reason 'character-out-of-range))
665 (character-below-char-code-limit-p))
667 ((and (preliminary-ok-for-length maybe-len 5)
668 (overlong-chk #b11111000 #b10000111)
669 (not (setf reject-reason 'character-out-of-range)))
670 (bug "can't happen"))
671 ((and (preliminary-ok-for-length maybe-len 6)
672 (overlong-chk #b11111100 #b10000011)
673 (not (setf reject-reason 'character-out-of-range)))
674 (bug "can't happen"))
676 (let* ((bad-end (ecase reject-reason
677 (invalid-utf8-starter-byte
679 (end-of-input-in-character
681 (invalid-utf8-continuation-byte
683 ((overlong-utf8-sequence character-out-of-range)
685 (bad-len (- bad-end pos)))
686 (declare (type array-range bad-end bad-len))
687 (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position)))
688 (values bad-len replacement)))))))))))))
689 (instantiate-octets-definition define-bytes-per-utf8-character)
691 (defmacro define-simple-get-utf8-char (accessor type)
692 (let ((name (make-od-name 'simple-get-utf8-char accessor)))
694 (declaim (inline ,name))
695 (defun ,name (array pos bytes)
696 (declare (optimize speed (safety 0))
698 (type array-range pos)
699 (type (integer 1 4) bytes))
701 (,accessor array (the array-range (+ pos x)))))
702 (declare (inline cref))
703 (code-char (ecase bytes
705 (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6)
706 (ldb (byte 6 0) (cref 1))))
707 (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12)
708 (ash (ldb (byte 6 0) (cref 1)) 6)
709 (ldb (byte 6 0) (cref 2))))
710 (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18)
711 (ash (ldb (byte 6 0) (cref 1)) 12)
712 (ash (ldb (byte 6 0) (cref 2)) 6)
713 (ldb (byte 6 0) (cref 3)))))))))))
714 (instantiate-octets-definition define-simple-get-utf8-char)
716 (defmacro define-utf8->string (accessor type)
717 (let ((name (make-od-name 'utf8->string accessor)))
719 (defun ,name (array astart aend)
720 (declare (optimize speed (safety 0))
722 (type array-range astart aend))
723 (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
724 (loop with pos = astart
726 do (multiple-value-bind (bytes invalid)
727 (,(make-od-name 'bytes-per-utf8-character accessor) array pos aend)
728 (declare (type (or null string) invalid))
731 (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor) array pos bytes) string))
733 (dotimes (i (length invalid))
734 (vector-push-extend (char invalid i) string))))
736 (coerce string 'simple-string))))))
737 (instantiate-octets-definition define-utf8->string)
739 ;;;; external formats
741 (defvar *default-external-format* nil)
743 (defun default-external-format ()
744 (or *default-external-format*
745 ;; On non-unicode, use iso-8859-1 instead of detecting it from
746 ;; the locale settings. Defaulting to an external-format which
747 ;; can represent characters that the CHARACTER type can't
748 ;; doesn't seem very sensible.
750 (setf *default-external-format* :latin-1)
751 (let ((external-format #!-win32 (intern (or (sb!alien:alien-funcall
754 (function (c-string :external-format :latin-1)
759 #!+win32 (sb!win32::ansi-codepage)))
760 (/show0 "cold-printing defaulted external-format:")
762 (cold-print external-format)
763 (/show0 "matching to known aliases")
764 (dolist (entry *external-formats*
766 ;;; FIXME! This WARN would try to do printing
767 ;;; before the streams have been initialized,
768 ;;; causing an infinite erroring loop. We should
769 ;;; either print it by calling to C, or delay the
770 ;;; warning until later. Since we're in freeze
771 ;;; right now, and the warning isn't really
772 ;;; essential, I'm doing what's least likely to
773 ;;; cause damage, and commenting it out. This
774 ;;; should be revisited after 0.9.17. -- JES,
777 (warn "Invalid external-format ~A; using LATIN-1"
779 (setf external-format :latin-1)))
780 (/show0 "cold printing known aliases:")
782 (dolist (alias (first entry)) (cold-print alias))
783 (/show0 "done cold-printing known aliases")
784 (when (member external-format (first entry))
787 (/show0 "/default external format ok")
788 (setf *default-external-format* external-format))))
790 ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
791 (defparameter *external-format-functions* (make-hash-table))
793 (defun add-external-format-funs (format-names funs)
794 (dolist (name format-names (values))
795 (setf (gethash name *external-format-functions*) funs)))
797 (add-external-format-funs
798 '(:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|)
799 '(ascii->string-aref string->ascii))
800 (add-external-format-funs
801 '(:latin1 :latin-1 :iso-8859-1 :iso8859-1)
802 '(latin1->string-aref string->latin1))
804 (add-external-format-funs
805 '(:latin9 :latin-9 :iso-8859-15 :iso8859-15)
806 '(latin9->string-aref string->latin9))
807 (add-external-format-funs '(:utf8 :utf-8) '(utf8->string-aref string->utf8))
809 (defun external-formats-funs (external-format)
810 (when (eql external-format :default)
811 (setf external-format (default-external-format)))
812 (or (gethash external-format *external-format-functions*)
813 (error "Unknown external-format ~S" external-format)))
815 ;;;; public interface
817 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
818 (declare (type (vector (unsigned-byte 8)) vector))
819 (with-array-data ((vector vector)
822 :check-fill-pointer t)
823 (declare (type (simple-array (unsigned-byte 8) (*)) vector))
824 (funcall (symbol-function (first (external-formats-funs external-format)))
827 (defun string-to-octets (string &key (external-format :default)
828 (start 0) end null-terminate)
829 (declare (type string string))
830 (with-array-data ((string string)
833 :check-fill-pointer t)
834 (declare (type simple-string string))
835 (funcall (symbol-function (second (external-formats-funs external-format)))
836 string start end (if null-terminate 1 0))))
839 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
841 (defun use-unicode-replacement-char (condition)
842 (use-value +unicode-replacement-character+ condition))
844 ;;; Utilities that maybe should be exported
847 (defmacro with-standard-replacement-character (&body body)
848 `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
851 (defmacro with-default-decoding-replacement ((c) &body body)
852 (let ((cname (gensym)))
855 ((octet-decoding-error (lambda (c)
856 (use-value ,cname c))))