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 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
177 (declaim (inline ,byte-char-name))
178 (defun ,byte-char-name (byte)
179 (declare (optimize speed (safety 0))
180 (type (unsigned-byte 8) byte))
181 (aref ,(make-array 256
182 :initial-contents (loop for byte below 256
184 (let ((exception (cadr (assoc byte exceptions))))
189 ;; This used to be inlined, but it caused huge slowdowns in SBCL builds,
190 ;; bloated the core by about 700k on x86-64. Removing the inlining
191 ;; didn't seem to have any performance effect. -- JES, 2005-10-15
192 (defun ,code-byte-name (code)
193 (declare (optimize speed (safety 0))
194 (type char-code code))
195 ;; FIXME: I'm not convinced doing this with CASE is a good idea as
196 ;; long as it's just macroexpanded into a stupid COND. Consider
197 ;; for example the output of (DISASSEMBLE 'SB-IMPL::CODE->CP1250-MAPPER)
198 ;; -- JES, 2005-10-15
200 ,@(mapcar (lambda (exception)
201 (destructuring-bind (byte code) exception
204 (,(mapcar #'car exceptions) nil)
205 (otherwise (if (< code 256) code nil))))))
208 (define-unibyte-mapper
220 (declaim (inline get-latin-bytes))
221 (defun get-latin-bytes (mapper external-format string pos end)
222 (declare (ignore end))
223 (let ((code (funcall mapper (char-code (char string pos)))))
225 ((and code (< code 256)) code)
227 (encoding-error external-format string pos)))
230 (declaim (inline code->ascii-mapper))
231 (defun code->ascii-mapper (code)
232 (declare (optimize speed (safety 0))
233 (type char-code code))
238 (declaim (inline get-ascii-bytes))
239 (defun get-ascii-bytes (string pos end)
240 (declare (optimize speed (safety 0))
241 (type simple-string string)
242 (type array-range pos end))
243 (get-latin-bytes #'code->ascii-mapper :ascii string pos end))
245 (declaim (inline get-latin1-bytes))
246 (defun get-latin1-bytes (string pos end)
247 (declare (optimize speed (safety 0))
248 (type simple-string string)
249 (type array-range pos end))
250 (get-latin-bytes #'identity :latin-1 string pos end))
254 (declaim (inline get-latin9-bytes))
255 (defun get-latin9-bytes (string pos end)
256 (declare (optimize speed (safety 0))
257 (type simple-string string)
258 (type array-range pos end))
259 (get-latin-bytes #'code->latin9-mapper :latin-9 string pos end)))
261 (declaim (inline string->latin%))
262 (defun string->latin% (string sstart send get-bytes null-padding)
263 (declare (optimize speed)
264 (type simple-string string)
265 (type array-range sstart send null-padding)
266 (type function get-bytes))
267 (let ((octets (make-array 0 :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8))))
268 (loop for pos from sstart below send
269 do (let ((byte-or-bytes (funcall get-bytes string pos send)))
270 (declare (type (or (unsigned-byte 8) (simple-array (unsigned-byte 8) (*))) byte-or-bytes))
272 ((numberp byte-or-bytes)
273 (vector-push-extend byte-or-bytes octets))
275 (dotimes (i (length byte-or-bytes))
276 (vector-push-extend (aref byte-or-bytes i) octets))))))
277 (dotimes (i null-padding)
278 (vector-push-extend 0 octets))
279 (coerce octets '(simple-array (unsigned-byte 8) (*)))))
281 (defun string->ascii (string sstart send null-padding)
282 (declare (optimize speed (safety 0))
283 (type simple-string string)
284 (type array-range sstart send))
285 (values (string->latin% string sstart send #'get-ascii-bytes null-padding)))
287 (defun string->latin1 (string sstart send null-padding)
288 (declare (optimize speed (safety 0))
289 (type simple-string string)
290 (type array-range sstart send))
291 (values (string->latin% string sstart send #'get-latin1-bytes null-padding)))
294 (defun string->latin9 (string sstart send null-padding)
295 (declare (optimize speed (safety 0))
296 (type simple-string string)
297 (type array-range sstart send))
298 (values (string->latin% string sstart send #'get-latin9-bytes null-padding)))
302 (declaim (inline char-len-as-utf8))
303 (defun char-len-as-utf8 (code)
304 (declare (optimize speed (safety 0))
305 (type (integer 0 (#.sb!xc:char-code-limit)) code))
306 (cond ((< code 0) (bug "can't happen"))
310 ((< code #x110000) 4)
311 (t (bug "can't happen"))))
313 (declaim (inline char->utf8))
314 (defun char->utf8 (char dest)
315 (declare (optimize speed (safety 0))
316 (type (array (unsigned-byte 8) (*)) dest))
317 (let ((code (char-code char)))
319 (declare (type (unsigned-byte 8) b))
320 (vector-push-extend b dest)))
321 (declare (inline add-byte))
322 (ecase (char-len-as-utf8 code)
326 (add-byte (logior #b11000000 (ldb (byte 5 6) code)))
327 (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
329 (add-byte (logior #b11100000 (ldb (byte 4 12) code)))
330 (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
331 (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
333 (add-byte (logior #b11110000 (ldb (byte 3 18) code)))
334 (add-byte (logior #b10000000 (ldb (byte 6 12) code)))
335 (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
336 (add-byte (logior #b10000000 (ldb (byte 6 0) code))))))))
338 (defun string->utf8 (string sstart send additional-space)
339 (declare (optimize speed (safety 0))
340 (type simple-string string)
341 (type array-range sstart send additional-space))
342 (let ((array (make-array (+ additional-space (- send sstart))
343 :element-type '(unsigned-byte 8)
346 (loop for i from sstart below send
347 do (char->utf8 (char string i) array))
348 (dotimes (i additional-space)
349 (vector-push-extend 0 array))
350 (coerce array '(simple-array (unsigned-byte 8) (*)))))
352 ;;;; to-string conversions
354 ;;; from latin (including ascii)
356 (defmacro define-ascii->string (accessor type)
357 (let ((name (make-od-name 'ascii->string accessor)))
359 (defun ,name (array astart aend)
360 (declare (optimize speed)
362 (type array-range astart aend))
363 ;; Since there is such a thing as a malformed ascii byte, a
364 ;; simple "make the string, fill it in" won't do.
365 (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
366 (loop for apos from astart below aend
367 do (let* ((code (,accessor array apos))
371 (decoding-error array apos (1+ apos) :ascii
372 'malformed-ascii apos))))
373 (if (characterp string-content)
374 (vector-push-extend string-content string)
375 (loop for c across string-content
376 do (vector-push-extend c string))))
377 finally (return (coerce string 'simple-string))))))))
378 (instantiate-octets-definition define-ascii->string)
380 (defmacro define-latin->string* (accessor type)
381 (let ((name (make-od-name 'latin->string* accessor)))
383 (declaim (inline ,name))
384 (defun ,name (string sstart send array astart aend mapper)
385 (declare (optimize speed (safety 0))
386 (type simple-string string)
388 (type array-range sstart send astart aend)
390 (varimap string sstart send
393 (setf (char string spos) (code-char (funcall mapper (,accessor array apos))))
395 (instantiate-octets-definition define-latin->string*)
397 (defmacro define-latin1->string* (accessor type)
398 (declare (ignore type))
399 (let ((name (make-od-name 'latin1->string* accessor)))
401 (defun ,name (string sstart send array astart aend)
402 (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity)))))
403 (instantiate-octets-definition define-latin1->string*)
407 (defmacro define-latin9->string* (accessor type)
408 (declare (ignore type))
409 (let ((name (make-od-name 'latin9->string* accessor)))
411 (defun ,name (string sstart send array astart aend)
412 (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'latin9->code-mapper)))))
413 (instantiate-octets-definition define-latin9->string*))
415 (defmacro define-latin->string (accessor type)
416 (let ((name (make-od-name 'latin->string accessor)))
418 (declaim (inline latin->string))
419 (defun ,name (array astart aend mapper)
420 (declare (optimize speed (safety 0))
422 (type array-range astart aend)
423 (type function mapper))
424 (let ((length (the array-range (- aend astart))))
425 (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
428 (instantiate-octets-definition define-latin->string)
430 (defmacro define-latin1->string (accessor type)
431 (declare (ignore type))
432 `(defun ,(make-od-name 'latin1->string accessor) (array astart aend)
433 (,(make-od-name 'latin->string accessor) array astart aend #'identity)))
434 (instantiate-octets-definition define-latin1->string)
438 (defmacro define-latin9->string (accessor type)
439 (declare (ignore type))
440 `(defun ,(make-od-name 'latin9->string accessor) (array astart aend)
441 (,(make-od-name 'latin->string accessor) array astart aend #'latin9->code-mapper)))
442 (instantiate-octets-definition define-latin9->string))
446 (defmacro define-bytes-per-utf8-character (accessor type)
447 (let ((name (make-od-name 'bytes-per-utf8-character accessor)))
449 ;;(declaim (inline ,name))
451 (string->utf8 (string (code-char ,(1- sb!xc:char-code-limit)))
453 (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max))
454 (defun ,name (array pos end)
455 (declare (optimize speed (safety 0))
457 (type array-range pos end))
458 ;; returns the number of bytes consumed and nil if it's a
459 ;; valid character or the number of bytes consumed and a
460 ;; replacement string if it's not.
461 (let ((initial-byte (,accessor array pos))
463 (reject-position pos)
464 (remaining-bytes (- end pos)))
465 (declare (type array-range reject-position remaining-bytes))
466 (labels ((valid-utf8-starter-byte-p (b)
467 (declare (type (unsigned-byte 8) b))
469 ((zerop (logand b #b10000000)) 1)
470 ((= (logand b #b11100000) #b11000000)
472 ((= (logand b #b11110000) #b11100000)
474 ((= (logand b #b11111000) #b11110000)
476 ((= (logand b #b11111100) #b11111000)
478 ((= (logand b #b11111110) #b11111100)
483 (setf reject-reason 'invalid-utf8-starter-byte))
485 (enough-bytes-left-p (x)
486 (let ((ok (> end (+ pos (1- x)))))
488 (setf reject-reason 'end-of-input-in-character))
490 (valid-secondary-p (x)
491 (let* ((idx (the array-range (+ pos x)))
492 (b (,accessor array idx))
493 (ok (= (logand b #b11000000) #b10000000)))
495 (setf reject-reason 'invalid-utf8-continuation-byte)
496 (setf reject-position idx))
498 (preliminary-ok-for-length (maybe-len len)
499 (and (eql maybe-len len)
500 ;; Has to be done in this order so that
501 ;; certain broken sequences (e.g., the
502 ;; two-byte sequence `"initial (length 3)"
503 ;; "non-continuation"' -- `#xef #x32')
504 ;; signal only part of that sequence as
506 (loop for i from 1 below (min len remaining-bytes)
507 always (valid-secondary-p i))
508 (enough-bytes-left-p len)))
510 (let ((ok (or (/= initial-byte x)
511 (/= (logior (,accessor array (the array-range (+ pos 1)))
515 (setf reject-reason 'overlong-utf8-sequence))
517 (character-below-char-code-limit-p ()
518 ;; This is only called on a four-byte sequence
519 ;; (two in non-unicode builds) to ensure we
520 ;; don't go over SBCL's character limts.
521 (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos))
523 ((> (aref lexically-max 0) (,accessor array pos))
525 ((< (aref lexically-max 1) (,accessor array (+ pos 1)))
528 ((> (aref lexically-max 1) (,accessor array (+ pos 1)))
531 ((< (aref lexically-max 2) (,accessor array (+ pos 2)))
534 ((> (aref lexically-max 2) (,accessor array (+ pos 2)))
537 ((< (aref lexically-max 3) (,accessor array (+ pos 3)))
541 (setf reject-reason 'character-out-of-range))
543 (declare (inline valid-utf8-starter-byte-p
546 preliminary-ok-for-length
548 (let ((maybe-len (valid-utf8-starter-byte-p initial-byte)))
549 (cond ((eql maybe-len 1)
551 ((and (preliminary-ok-for-length maybe-len 2)
552 (overlong-chk #b11000000 #b10111111)
553 (overlong-chk #b11000001 #b10111111)
554 #!-sb-unicode (character-below-char-code-limit-p))
556 ((and (preliminary-ok-for-length maybe-len 3)
557 (overlong-chk #b11100000 #b10011111)
558 #!-sb-unicode (not (setf reject-reason 'character-out-of-range)))
560 ((and (preliminary-ok-for-length maybe-len 4)
561 (overlong-chk #b11110000 #b10001111)
562 #!-sb-unicode (not (setf reject-reason 'character-out-of-range))
563 (character-below-char-code-limit-p))
565 ((and (preliminary-ok-for-length maybe-len 5)
566 (overlong-chk #b11111000 #b10000111)
567 (not (setf reject-reason 'character-out-of-range)))
568 (bug "can't happen"))
569 ((and (preliminary-ok-for-length maybe-len 6)
570 (overlong-chk #b11111100 #b10000011)
571 (not (setf reject-reason 'character-out-of-range)))
572 (bug "can't happen"))
574 (let* ((bad-end (ecase reject-reason
575 (invalid-utf8-starter-byte
577 (end-of-input-in-character
579 (invalid-utf8-continuation-byte
581 ((overlong-utf8-sequence character-out-of-range)
583 (bad-len (- bad-end pos)))
584 (declare (type array-range bad-end bad-len))
585 (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position)))
586 (values bad-len replacement)))))))))))))
587 (instantiate-octets-definition define-bytes-per-utf8-character)
589 (defmacro define-simple-get-utf8-char (accessor type)
590 (let ((name (make-od-name 'simple-get-utf8-char accessor)))
592 (declaim (inline ,name))
593 (defun ,name (array pos bytes)
594 (declare (optimize speed (safety 0))
596 (type array-range pos)
597 (type (integer 1 4) bytes))
599 (,accessor array (the array-range (+ pos x)))))
600 (declare (inline cref))
601 (code-char (ecase bytes
603 (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6)
604 (ldb (byte 6 0) (cref 1))))
605 (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12)
606 (ash (ldb (byte 6 0) (cref 1)) 6)
607 (ldb (byte 6 0) (cref 2))))
608 (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18)
609 (ash (ldb (byte 6 0) (cref 1)) 12)
610 (ash (ldb (byte 6 0) (cref 2)) 6)
611 (ldb (byte 6 0) (cref 3)))))))))))
612 (instantiate-octets-definition define-simple-get-utf8-char)
614 (defmacro define-utf8->string (accessor type)
615 (let ((name (make-od-name 'utf8->string accessor)))
617 (defun ,name (array astart aend)
618 (declare (optimize speed (safety 0))
620 (type array-range astart aend))
621 (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
622 (loop with pos = astart
624 do (multiple-value-bind (bytes invalid)
625 (,(make-od-name 'bytes-per-utf8-character accessor) array pos aend)
626 (declare (type (or null string) invalid))
629 (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor) array pos bytes) string))
631 (dotimes (i (length invalid))
632 (vector-push-extend (char invalid i) string))))
634 (coerce string 'simple-string))))))
635 (instantiate-octets-definition define-utf8->string)
637 ;;;; external formats
639 (defvar *default-external-format* nil)
641 (defun default-external-format ()
642 (or *default-external-format*
643 (let ((external-format (intern (or (sb!alien:alien-funcall
646 (function c-string int))
650 (/show0 "cold-printing defaulted external-format:")
652 (cold-print external-format)
653 (/show0 "matching to known aliases")
654 (dolist (entry *external-formats*
656 (warn "Invalid external-format ~A; using LATIN-1"
658 (setf external-format :latin-1)))
659 (/show0 "cold printing known aliases:")
661 (dolist (alias (first entry)) (cold-print alias))
662 (/show0 "done cold-printing known aliases")
663 (when (member external-format (first entry))
666 (/show0 "/default external format ok")
667 (setf *default-external-format* external-format))))
669 ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
670 (defparameter *external-format-functions*
671 '(((:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|)
672 ascii->string-aref string->ascii)
673 ((:latin1 :latin-1 :iso-8859-1 :iso8859-1)
674 latin1->string-aref string->latin1)
676 ((:latin9 :latin-9 :iso-8859-15 :iso8859-15)
677 latin9->string-aref string->latin9)
679 utf8->string-aref string->utf8)))
681 (defun external-formats-funs (external-format)
682 (when (eql external-format :default)
683 (setf external-format (default-external-format)))
684 (or (cdr (find external-format (the list *external-format-functions*)
687 (error "Unknown external-format ~S" external-format)))
689 ;;;; public interface
691 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
692 (declare (type (vector (unsigned-byte 8)) vector))
693 (with-array-data ((vector vector)
695 (end (%check-vector-sequence-bounds vector start end)))
696 (declare (type (simple-array (unsigned-byte 8) (*)) vector))
697 (funcall (symbol-function (first (external-formats-funs external-format)))
700 (defun string-to-octets (string &key (external-format :default)
701 (start 0) end null-terminate)
702 (declare (type string string))
703 (with-array-data ((string string)
705 (end (%check-vector-sequence-bounds string start end)))
706 (declare (type simple-string string))
707 (funcall (symbol-function (second (external-formats-funs external-format)))
708 string start end (if null-terminate 1 0))))
711 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
713 (defun use-unicode-replacement-char (condition)
714 (use-value +unicode-replacement-character+ condition))
716 ;;; Utilities that maybe should be exported
719 (defmacro with-standard-replacement-character (&body body)
720 `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
723 (defmacro with-default-decoding-replacement ((c) &body body)
724 (let ((cname (gensym)))
727 ((octet-decoding-error (lambda (c)
728 (use-value ,cname c))))