0.9.5.58:
[sbcl.git] / src / code / octets.lisp
1 ;;;; code for string to octet conversion
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
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
16 ;;; builds?
17
18 (in-package "SB!IMPL")
19
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
23 one-past-the-end"
24   '(integer 0 #.sb!xc:array-dimension-limit))
25 \f
26 ;;;; conditions
27
28 ;;; encoding condition
29
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)))))
40
41 (defun read-replacement-character ()
42   (format *query-io*
43           "Replacement byte, bytes, character, or string (evaluated): ")
44   (finish-output *query-io*)
45   (list (eval (read *query-io*))))
46
47 (defun encoding-error (external-format string pos)
48   (restart-case
49       (error 'octets-encoding-error
50              :external-format external-format
51              :string string
52              :position pos)
53     (use-value (replacement)
54       :report "Supply a set of bytes to use in place of the invalid one."
55       :interactive read-replacement-character
56       (typecase replacement
57         ((unsigned-byte 8)
58          (make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement))
59         (character
60          (string-to-octets (string replacement)
61                            :external-format external-format))
62         (string
63          (string-to-octets replacement
64                            :external-format external-format))
65         (t
66          (coerce replacement '(simple-array (unsigned-byte 8) (*))))))))
67
68 ;;; decoding condition
69
70 ;;; for UTF8, the specific condition signalled will be a generalized
71 ;;; instance of one of the following:
72 ;;;
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
78 ;;;
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
90 ;;; as an error.
91
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))
99   (:report
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)))))
104
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) ())
110
111 (define-condition malformed-ascii (octet-decoding-error) ())
112
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*))))
117
118 (defun decoding-error (array start end external-format reason pos)
119   (restart-case
120       (error reason
121              :external-format external-format
122              :array array
123              :start start
124              :end end
125              :pos pos)
126     (use-value (s)
127       :report "Supply a replacement string designator."
128       :interactive read-replacement-string
129       (string s))))
130
131 ;;; Utilities used in both to-string and to-octet conversions
132
133 (defmacro instantiate-octets-definition (definer)
134   `(progn
135     (,definer aref (simple-array (unsigned-byte 8) (*)))
136     (,definer sap-ref-8 system-area-pointer)))
137
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)
154              (setf to-size ts
155                    from-size fs))
156         finally (return (values to-seq to-pos from-pos))))
157
158 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
159 ;;; and fix it, or else replace with SYMBOLICATE.
160 ;;;
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
167     ;; then.
168     (intern (concatenate 'string (symbol-name sym1) "-" (symbol-name sym2))
169             (symbol-package sym1))))
170 \f
171 ;;;; to-octets conversions
172
173 ;;; to latin (including ascii)
174
175 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
176   `(progn
177     (declaim (inline ,byte-char-name ,code-byte-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
183                                                  collect
184                                                   (let ((exception (cadr (assoc byte exceptions))))
185                                                     (if exception
186                                                         exception
187                                                         byte))))
188             byte))
189     (defun ,code-byte-name (code)
190       (declare (optimize speed (safety 0))
191                (type char-code code))
192       (case code
193         ,@(mapcar (lambda (exception)
194                     (destructuring-bind (byte code) exception
195                       `(,code ,byte)))
196                   exceptions)
197         (,(mapcar #'car exceptions) nil)
198         (otherwise (if (< code 256) code nil))))))
199
200 #!+sb-unicode
201 (define-unibyte-mapper
202     latin9->code-mapper
203     code->latin9-mapper
204   (#xA4 #x20AC)
205   (#xA6 #x0160)
206   (#xA8 #x0161)
207   (#xB4 #x017D)
208   (#xB8 #x017E)
209   (#xBC #x0152)
210   (#xBD #x0153)
211   (#xBE #x0178))
212
213 (declaim (inline get-latin-bytes))
214 (defun get-latin-bytes (mapper external-format string pos end)
215   (declare (ignore end))
216   (let ((code (funcall mapper (char-code (char string pos)))))
217     (values (cond
218               ((and code (< code 256)) code)
219               (t
220                (encoding-error external-format string pos)))
221             1)))
222
223 (declaim (inline code->ascii-mapper))
224 (defun code->ascii-mapper (code)
225   (declare (optimize speed (safety 0))
226            (type char-code code))
227   (if (> code 127)
228       nil
229       code))
230
231 (declaim (inline get-ascii-bytes))
232 (defun get-ascii-bytes (string pos end)
233   (declare (optimize speed (safety 0))
234            (type simple-string string)
235            (type array-range pos end))
236   (get-latin-bytes #'code->ascii-mapper :ascii string pos end))
237
238 (declaim (inline get-latin1-bytes))
239 (defun get-latin1-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 #'identity :latin-1 string pos end))
244
245 #!+sb-unicode
246 (progn
247   (declaim (inline get-latin9-bytes))
248   (defun get-latin9-bytes (string pos end)
249     (declare (optimize speed (safety 0))
250              (type simple-string string)
251              (type array-range pos end))
252     (get-latin-bytes #'code->latin9-mapper :latin-9 string pos end)))
253
254 (declaim (inline string->latin%))
255 (defun string->latin% (string sstart send get-bytes null-padding)
256   (declare (optimize speed)
257            (type simple-string string)
258            (type array-range sstart send null-padding)
259            (type function get-bytes))
260   (let ((octets (make-array 0 :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8))))
261     (loop for pos from sstart below send
262           do (let ((byte-or-bytes (funcall get-bytes string pos send)))
263                (declare (type (or (unsigned-byte 8) (simple-array (unsigned-byte 8) (*))) byte-or-bytes))
264                (cond
265                  ((numberp byte-or-bytes)
266                   (vector-push-extend byte-or-bytes octets))
267                  (t
268                   (dotimes (i (length byte-or-bytes))
269                     (vector-push-extend (aref byte-or-bytes i) octets))))))
270     (dotimes (i null-padding)
271       (vector-push-extend 0 octets))
272     (coerce octets '(simple-array (unsigned-byte 8) (*)))))
273
274 (defun string->ascii (string sstart send null-padding)
275   (declare (optimize speed (safety 0))
276            (type simple-string string)
277            (type array-range sstart send))
278   (values (string->latin% string sstart send #'get-ascii-bytes null-padding)))
279
280 (defun string->latin1 (string sstart send null-padding)
281   (declare (optimize speed (safety 0))
282            (type simple-string string)
283            (type array-range sstart send))
284   (values (string->latin% string sstart send #'get-latin1-bytes null-padding)))
285
286 #!+sb-unicode
287 (defun string->latin9 (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-latin9-bytes null-padding)))
292
293 ;;; to utf8
294
295 (declaim (inline char-len-as-utf8))
296 (defun char-len-as-utf8 (code)
297   (declare (optimize speed (safety 0))
298            (type (integer 0 (#.sb!xc:char-code-limit)) code))
299   (cond ((< code 0) (bug "can't happen"))
300         ((< code #x80) 1)
301         ((< code #x800) 2)
302         ((< code #x10000) 3)
303         ((< code #x110000) 4)
304         (t (bug "can't happen"))))
305
306 (declaim (inline char->utf8))
307 (defun char->utf8 (char dest)
308   (declare (optimize speed (safety 0))
309            (type (array (unsigned-byte 8) (*)) dest))
310   (let ((code (char-code char)))
311     (flet ((add-byte (b)
312              (declare (type (unsigned-byte 8) b))
313              (vector-push-extend b dest)))
314       (declare (inline add-byte))
315       (ecase (char-len-as-utf8 code)
316         (1
317          (add-byte code))
318         (2
319          (add-byte (logior #b11000000 (ldb (byte 5 6) code)))
320          (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
321         (3
322          (add-byte (logior #b11100000 (ldb (byte 4 12) code)))
323          (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
324          (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
325         (4
326          (add-byte (logior #b11110000 (ldb (byte 3 18) code)))
327          (add-byte (logior #b10000000 (ldb (byte 6 12) code)))
328          (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
329          (add-byte (logior #b10000000 (ldb (byte 6 0) code))))))))
330
331 (defun string->utf8 (string sstart send additional-space)
332   (declare (optimize speed (safety 0))
333            (type simple-string string)
334            (type array-range sstart send additional-space))
335   (let ((array (make-array (+ additional-space (- send sstart))
336                            :element-type '(unsigned-byte 8)
337                            :adjustable t
338                            :fill-pointer 0)))
339     (loop for i from sstart below send
340           do (char->utf8 (char string i) array))
341     (dotimes (i additional-space)
342       (vector-push-extend 0 array))
343     (coerce array '(simple-array (unsigned-byte 8) (*)))))
344 \f
345 ;;;; to-string conversions
346
347 ;;; from latin (including ascii)
348
349 (defmacro define-ascii->string (accessor type)
350   (let ((name (make-od-name 'ascii->string accessor)))
351     `(progn
352       (defun ,name (array astart aend)
353         (declare (optimize speed)
354                  (type ,type array)
355                  (type array-range astart aend))
356         ;; Since there is such a thing as a malformed ascii byte, a
357         ;; simple "make the string, fill it in" won't do.
358         (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
359           (loop for apos from astart below aend
360                 do (let* ((code (,accessor array apos))
361                           (string-content
362                            (if (< code 128)
363                                (code-char code)
364                                (decoding-error array apos (1+ apos) :ascii
365                                                'malformed-ascii apos))))
366                      (if (characterp string-content)
367                          (vector-push-extend string-content string)
368                          (loop for c across string-content
369                                do (vector-push-extend c string))))
370                 finally (return (coerce string 'simple-string))))))))
371 (instantiate-octets-definition define-ascii->string)
372
373 (defmacro define-latin->string* (accessor type)
374   (let ((name (make-od-name 'latin->string* accessor)))
375     `(progn
376       (declaim (inline ,name))
377       (defun ,name (string sstart send array astart aend mapper)
378         (declare (optimize speed (safety 0))
379                  (type simple-string string)
380                  (type ,type array)
381                  (type array-range sstart send astart aend)
382                  (function mapper))
383         (varimap string sstart send
384                  astart aend
385                  (lambda (spos apos)
386                    (setf (char string spos) (code-char (funcall mapper (,accessor array apos))))
387                    (values 1 1)))))))
388 (instantiate-octets-definition define-latin->string*)
389
390 (defmacro define-latin1->string* (accessor type)
391   (declare (ignore type))
392   (let ((name (make-od-name 'latin1->string* accessor)))
393     `(progn
394       (defun ,name (string sstart send array astart aend)
395         (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity)))))
396 (instantiate-octets-definition define-latin1->string*)
397
398 #!+sb-unicode
399 (progn
400   (defmacro define-latin9->string* (accessor type)
401     (declare (ignore type))
402     (let ((name (make-od-name 'latin9->string* accessor)))
403       `(progn
404         (defun ,name (string sstart send array astart aend)
405           (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'latin9->code-mapper)))))
406   (instantiate-octets-definition define-latin9->string*))
407
408 (defmacro define-latin->string (accessor type)
409   (let ((name (make-od-name 'latin->string accessor)))
410     `(progn
411       (declaim (inline latin->string))
412       (defun ,name (array astart aend mapper)
413         (declare (optimize speed (safety 0))
414                  (type ,type array)
415                  (type array-range astart aend)
416                  (type function mapper))
417         (let ((length (the array-range (- aend astart))))
418           (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
419                                                             array astart aend
420                                                             mapper)))))))
421 (instantiate-octets-definition define-latin->string)
422
423 (defmacro define-latin1->string (accessor type)
424   (declare (ignore type))
425   `(defun ,(make-od-name 'latin1->string accessor) (array astart aend)
426     (,(make-od-name 'latin->string accessor) array astart aend #'identity)))
427 (instantiate-octets-definition define-latin1->string)
428
429 #!+sb-unicode
430 (progn
431   (defmacro define-latin9->string (accessor type)
432     (declare (ignore type))
433     `(defun ,(make-od-name 'latin9->string accessor) (array astart aend)
434       (,(make-od-name 'latin->string accessor) array astart aend #'latin9->code-mapper)))
435   (instantiate-octets-definition define-latin9->string))
436
437 ;;; from utf8
438
439 (defmacro define-bytes-per-utf8-character (accessor type)
440   (let ((name (make-od-name 'bytes-per-utf8-character accessor)))
441     `(progn
442       ;;(declaim (inline ,name))
443       (let ((lexically-max
444              (string->utf8 (string (code-char ,(1- sb!xc:char-code-limit)))
445                            0 1 0)))
446         (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max))
447         (defun ,name (array pos end)
448           (declare (optimize speed (safety 0))
449                    (type ,type array)
450                    (type array-range pos end))
451           ;; returns the number of bytes consumed and nil if it's a
452           ;; valid character or the number of bytes consumed and a
453           ;; replacement string if it's not.
454           (let ((initial-byte (,accessor array pos))
455                 (reject-reason nil)
456                 (reject-position pos)
457                 (remaining-bytes (- end pos)))
458             (declare (type array-range reject-position remaining-bytes))
459             (labels ((valid-utf8-starter-byte-p (b)
460                        (declare (type (unsigned-byte 8) b))
461                        (let ((ok (cond
462                                    ((zerop (logand b #b10000000)) 1)
463                                    ((= (logand b #b11100000) #b11000000)
464                                     2)
465                                    ((= (logand b #b11110000) #b11100000)
466                                     3)
467                                    ((= (logand b #b11111000) #b11110000)
468                                     4)
469                                    ((= (logand b #b11111100) #b11111000)
470                                     5)
471                                    ((= (logand b #b11111110) #b11111100)
472                                     6)
473                                    (t
474                                     nil))))
475                          (unless ok
476                            (setf reject-reason 'invalid-utf8-starter-byte))
477                          ok))
478                      (enough-bytes-left-p (x)
479                        (let ((ok (> end (+ pos (1- x)))))
480                          (unless ok
481                            (setf reject-reason 'end-of-input-in-character))
482                          ok))
483                      (valid-secondary-p (x)
484                        (let* ((idx (the array-range (+ pos x)))
485                               (b (,accessor array idx))
486                               (ok (= (logand b #b11000000) #b10000000)))
487                          (unless ok
488                            (setf reject-reason 'invalid-utf8-continuation-byte)
489                            (setf reject-position idx))
490                          ok))
491                      (preliminary-ok-for-length (maybe-len len)
492                        (and (eql maybe-len len)
493                             ;; Has to be done in this order so that
494                             ;; certain broken sequences (e.g., the
495                             ;; two-byte sequence `"initial (length 3)"
496                             ;; "non-continuation"' -- `#xef #x32')
497                             ;; signal only part of that sequence as
498                             ;; erronous.
499                             (loop for i from 1 below (min len remaining-bytes)
500                                   always (valid-secondary-p i))
501                             (enough-bytes-left-p len)))
502                      (overlong-chk (x y)
503                        (let ((ok (or (/= initial-byte x)
504                                      (/= (logior (,accessor array (the array-range (+ pos 1)))
505                                                  y)
506                                          y))))
507                          (unless ok
508                            (setf reject-reason 'overlong-utf8-sequence))
509                          ok))
510                      (character-below-char-code-limit-p ()
511                        ;; This is only called on a four-byte sequence
512                        ;; (two in non-unicode builds) to ensure we
513                        ;; don't go over SBCL's character limts.
514                        (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos))
515                                         nil)
516                                        ((> (aref lexically-max 0) (,accessor array pos))
517                                         t)
518                                        ((< (aref lexically-max 1) (,accessor array (+ pos 1)))
519                                         nil)
520                                        #!+sb-unicode
521                                        ((> (aref lexically-max 1) (,accessor array (+ pos 1)))
522                                         t)
523                                        #!+sb-unicode
524                                        ((< (aref lexically-max 2) (,accessor array (+ pos 2)))
525                                         nil)
526                                        #!+sb-unicode
527                                        ((> (aref lexically-max 2) (,accessor array (+ pos 2)))
528                                         t)
529                                        #!+sb-unicode
530                                        ((< (aref lexically-max 3) (,accessor array (+ pos 3)))
531                                         nil)
532                                        (t t))))
533                          (unless ok
534                            (setf reject-reason 'character-out-of-range))
535                          ok)))
536               (declare (inline valid-utf8-starter-byte-p
537                                enough-bytes-left-p
538                                valid-secondary-p
539                                preliminary-ok-for-length
540                                overlong-chk))
541               (let ((maybe-len (valid-utf8-starter-byte-p initial-byte)))
542                 (cond ((eql maybe-len 1)
543                        (values 1 nil))
544                       ((and (preliminary-ok-for-length maybe-len 2)
545                             (overlong-chk #b11000000 #b10111111)
546                             (overlong-chk #b11000001 #b10111111)
547                             #!-sb-unicode (character-below-char-code-limit-p))
548                        (values 2 nil))
549                       ((and (preliminary-ok-for-length maybe-len 3)
550                             (overlong-chk #b11100000 #b10011111)
551                             #!-sb-unicode (not (setf reject-reason 'character-out-of-range)))
552                        (values 3 nil))
553                       ((and (preliminary-ok-for-length maybe-len 4)
554                             (overlong-chk #b11110000 #b10001111)
555                             #!-sb-unicode (not (setf reject-reason 'character-out-of-range))
556                             (character-below-char-code-limit-p))
557                        (values 4 nil))
558                       ((and (preliminary-ok-for-length maybe-len 5)
559                             (overlong-chk #b11111000 #b10000111)
560                             (not (setf reject-reason 'character-out-of-range)))
561                        (bug "can't happen"))
562                       ((and (preliminary-ok-for-length maybe-len 6)
563                             (overlong-chk #b11111100 #b10000011)
564                             (not (setf reject-reason 'character-out-of-range)))
565                        (bug "can't happen"))
566                       (t
567                        (let* ((bad-end (ecase reject-reason
568                                          (invalid-utf8-starter-byte
569                                           (1+ pos))
570                                          (end-of-input-in-character
571                                           end)
572                                          (invalid-utf8-continuation-byte
573                                           reject-position)
574                                          ((overlong-utf8-sequence character-out-of-range)
575                                           (+ pos maybe-len))))
576                               (bad-len (- bad-end pos)))
577                          (declare (type array-range bad-end bad-len))
578                          (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position)))
579                            (values bad-len replacement)))))))))))))
580 (instantiate-octets-definition define-bytes-per-utf8-character)
581
582 (defmacro define-simple-get-utf8-char (accessor type)
583   (let ((name (make-od-name 'simple-get-utf8-char accessor)))
584     `(progn
585       (declaim (inline ,name))
586       (defun ,name (array pos bytes)
587         (declare (optimize speed (safety 0))
588                  (type ,type array)
589                  (type array-range pos)
590                  (type (integer 1 4) bytes))
591         (flet ((cref (x)
592                  (,accessor array (the array-range (+ pos x)))))
593           (declare (inline cref))
594           (code-char (ecase bytes
595                        (1 (cref 0))
596                        (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6)
597                                   (ldb (byte 6 0) (cref 1))))
598                        (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12)
599                                   (ash (ldb (byte 6 0) (cref 1)) 6)
600                                   (ldb (byte 6 0) (cref 2))))
601                        (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18)
602                                   (ash (ldb (byte 6 0) (cref 1)) 12)
603                                   (ash (ldb (byte 6 0) (cref 2)) 6)
604                                   (ldb (byte 6 0) (cref 3)))))))))))
605 (instantiate-octets-definition define-simple-get-utf8-char)
606
607 (defmacro define-utf8->string (accessor type)
608   (let ((name (make-od-name 'utf8->string accessor)))
609     `(progn
610       (defun ,name (array astart aend)
611         (declare (optimize speed (safety 0))
612                  (type ,type array)
613                  (type array-range astart aend))
614         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
615           (loop with pos = astart
616                 while (< pos aend)
617                 do (multiple-value-bind (bytes invalid)
618                        (,(make-od-name 'bytes-per-utf8-character accessor) array pos aend)
619                      (declare (type (or null string) invalid))
620                      (cond
621                        ((null invalid)
622                         (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor) array pos bytes) string))
623                        (t
624                         (dotimes (i (length invalid))
625                           (vector-push-extend (char invalid i) string))))
626                      (incf pos bytes)))
627           (coerce string 'simple-string))))))
628 (instantiate-octets-definition define-utf8->string)
629 \f
630 ;;;; external formats
631
632 (defvar *default-external-format* nil)
633
634 (defun default-external-format ()
635   (or *default-external-format*
636       (let ((external-format (intern (or (sb!alien:alien-funcall
637                                           (extern-alien
638                                            "nl_langinfo"
639                                            (function c-string int))
640                                           sb!unix:codeset)
641                                          "LATIN-1")
642                                      "KEYWORD")))
643         (/show0 "cold-printing defaulted external-format:")
644         #!+sb-show
645         (cold-print external-format)
646         (/show0 "matching to known aliases")
647         (dolist (entry *external-formats*
648                  (progn
649                    (warn "Invalid external-format ~A; using LATIN-1"
650                          external-format)
651                    (setf external-format :latin-1)))
652           (/show0 "cold printing known aliases:")
653           #!+sb-show
654           (dolist (alias (first entry)) (cold-print alias))
655           (/show0 "done cold-printing known aliases")
656           (when (member external-format (first entry))
657             (/show0 "matched")
658             (return)))
659         (/show0 "/default external format ok")
660         (setf *default-external-format* external-format))))
661
662 ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
663 (defparameter *external-format-functions*
664   '(((:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|)
665      ascii->string-aref string->ascii)
666     ((:latin1 :latin-1 :iso-8859-1 :iso8859-1)
667      latin1->string-aref string->latin1)
668     #!+sb-unicode
669     ((:latin9 :latin-9 :iso-8859-15 :iso8859-15)
670      latin9->string-aref string->latin9)
671     ((:utf8 :utf-8)
672      utf8->string-aref string->utf8)))
673
674 (defun external-formats-funs (external-format)
675   (when (eql external-format :default)
676     (setf external-format (default-external-format)))
677   (or (cdr (find external-format (the list *external-format-functions*)
678                  :test #'member
679                  :key #'car))
680       (error "Unknown external-format ~S" external-format)))
681 \f
682 ;;;; public interface
683
684 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
685   (declare (type (vector (unsigned-byte 8)) vector))
686   (with-array-data ((vector vector)
687                     (start start)
688                     (end (%check-vector-sequence-bounds vector start end)))
689     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
690     (funcall (symbol-function (first (external-formats-funs external-format)))
691              vector start end)))
692
693 (defun string-to-octets (string &key (external-format :default)
694                          (start 0) end null-terminate)
695   (declare (type string string))
696   (with-array-data ((string string)
697                     (start start)
698                     (end (%check-vector-sequence-bounds string start end)))
699     (declare (type simple-string string))
700     (funcall (symbol-function (second (external-formats-funs external-format)))
701              string start end (if null-terminate 1 0))))
702
703 #!+sb-unicode
704 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
705 #!+sb-unicode
706 (defun use-unicode-replacement-char (condition)
707   (use-value +unicode-replacement-character+ condition))
708
709 ;;; Utilities that maybe should be exported
710
711 #!+sb-unicode
712 (defmacro with-standard-replacement-character (&body body)
713   `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
714     ,@body))
715
716 (defmacro with-default-decoding-replacement ((c) &body body)
717   (let ((cname (gensym)))
718   `(let ((,cname ,c))
719     (handler-bind
720         ((octet-decoding-error (lambda (c)
721                                  (use-value ,cname c))))
722       ,@body))))