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