1.0.11.1: Handle set-but-empty environment variables
[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 ;;; Converting bytes to character codes is easy: just use a 256-element
176 ;;; lookup table that maps each possible byte to its corresponding
177 ;;; character code.
178 ;;;
179 ;;; Converting character codes to bytes is a little harder, since the
180 ;;; codes may be spare (e.g. we use codes 0-127, 3490, and 4598).  The
181 ;;; previous version of this macro utilized a gigantic CASE expression
182 ;;; to do the hard work, with the result that the code was huge (since
183 ;;; SBCL's then-current compilation strategy for CASE expressions was
184 ;;; (and still is) converting CASE into COND into if-the-elses--which is
185 ;;; also inefficient unless your code happens to occur very early in the
186 ;;; chain.
187 ;;;
188 ;;; The current strategy is to build a table:
189 ;;;
190 ;;; [ ... code_1 byte_1 code_2 byte_2 ... code_n byte_n ... ]
191 ;;;
192 ;;; such that the codes are sorted in order from lowest to highest.  We
193 ;;; can then binary search the table to discover the appropriate byte
194 ;;; for a character code.  We also implement an optimization: all unibyte
195 ;;; mappings do not remap ASCII (0-127) and some do not remap part of
196 ;;; the range beyond character code 127.  So we check to see if the
197 ;;; character code falls into that range first (a quick check, since
198 ;;; character codes are guaranteed to be positive) and then do the binary
199 ;;; search if not.  This optimization also enables us to cut down on the
200 ;;; size of our lookup table.
201 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
202   (let* (;; Build a list of (CODE BYTE) pairs
203          (pairs (loop for byte below 256
204                    for code = (let ((exception (cdr (assoc byte exceptions))))
205                                 (cond
206                                   ((car exception) (car exception))
207                                   ((null exception) byte)
208                                   (t nil)))
209                    when code collect (list code byte) into elements
210                    finally (return elements)))
211          ;; Find the smallest character code such that the corresponding
212          ;; byte is != to the code.
213          (lowest-non-equivalent-code (position-if-not #'(lambda (pair)
214                                                           (apply #'= pair))
215                                                       pairs))
216          ;; Sort them for our lookup table.
217          (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
218                              #'< :key #'car))
219          ;; Create the lookup table.
220          (sorted-lookup-table
221           (reduce #'append sorted-pairs :from-end t :initial-value nil)))
222     `(progn
223        ; Can't inline it with a non-null lexical environment anyway.
224        ;(declaim (inline ,byte-char-name))
225        (let ((byte-to-code-table
226               ,(make-array 256 :element-type t #+nil 'char-code
227                            :initial-contents (loop for byte below 256
228                                                 collect
229                                                 (let ((exception (cadr (assoc byte exceptions))))
230                                                   (if exception
231                                                       exception
232                                                       byte)))))
233              (code-to-byte-table
234               ,(make-array (length sorted-lookup-table)
235                            :initial-contents sorted-lookup-table)))
236          (defun ,byte-char-name (byte)
237            (declare (optimize speed (safety 0))
238                     (type (unsigned-byte 8) byte))
239            (aref byte-to-code-table byte))
240          (defun ,code-byte-name (code)
241            (declare (optimize speed (safety 0))
242                     (type char-code code))
243            (if (< code ,lowest-non-equivalent-code)
244                code
245                ;; We could toss in some TRULY-THEs if we really needed to
246                ;; make this faster...
247                (loop with low = 0
248                   with high = (- (length code-to-byte-table) 2)
249                   while (< low high)
250                   do (let ((mid (logandc2 (truncate (+ low high 2) 2) 1)))
251                        (if (< code (aref code-to-byte-table mid))
252                            (setf high (- mid 2))
253                            (setf low mid)))
254                   finally (return (if (eql code (aref code-to-byte-table low))
255                                       (aref code-to-byte-table (1+ low))
256                                       nil)))))))))
257
258 #!+sb-unicode
259 (define-unibyte-mapper
260     latin9->code-mapper
261     code->latin9-mapper
262   (#xA4 #x20AC)
263   (#xA6 #x0160)
264   (#xA8 #x0161)
265   (#xB4 #x017D)
266   (#xB8 #x017E)
267   (#xBC #x0152)
268   (#xBD #x0153)
269   (#xBE #x0178))
270
271 (declaim (inline get-latin-bytes))
272 (defun get-latin-bytes (mapper external-format string pos)
273   (let ((code (funcall mapper (char-code (char string pos)))))
274     (declare (type (or null char-code) code))
275     (values (cond
276               ((and code (< code 256)) code)
277               (t
278                (encoding-error external-format string pos)))
279             1)))
280
281 (declaim (inline code->ascii-mapper))
282 (defun code->ascii-mapper (code)
283   (declare (optimize speed (safety 0))
284            (type char-code code))
285   (if (> code 127)
286       nil
287       code))
288
289 (declaim (inline get-ascii-bytes))
290 (defun get-ascii-bytes (string pos)
291   (declare (optimize speed (safety 0))
292            (type simple-string string)
293            (type array-range pos))
294   (get-latin-bytes #'code->ascii-mapper :ascii string pos))
295
296 (declaim (inline get-latin1-bytes))
297 (defun get-latin1-bytes (string pos)
298   (declare (optimize speed (safety 0))
299            (type simple-string string)
300            (type array-range pos))
301   (get-latin-bytes #'identity :latin-1 string pos))
302
303 #!+sb-unicode
304 (progn
305   (declaim (inline get-latin9-bytes))
306   (defun get-latin9-bytes (string pos)
307     (declare (optimize speed (safety 0))
308              (type simple-string string)
309              (type array-range pos))
310     (get-latin-bytes #'code->latin9-mapper :latin-9 string pos)))
311
312 (declaim (inline string->latin%))
313 (defun string->latin% (string sstart send get-bytes null-padding)
314   (declare (optimize speed)
315            (type simple-string string)
316            (type index sstart send)
317            (type (integer 0 1) null-padding)
318            (type function get-bytes))
319   ;; The latin encodings are all unibyte encodings, so just directly
320   ;; compute the number of octets we're going to generate.
321   (let ((octets (make-array (+ (- send sstart) null-padding)
322                             ;; This takes care of any null padding the
323                             ;; caller requests.
324                             :initial-element 0
325                             :element-type '(unsigned-byte 8)))
326         (index 0)
327         (error-position 0))
328     (tagbody
329      :no-error
330        (loop for pos of-type index from sstart below send
331           do (let ((byte (funcall get-bytes string pos)))
332                (typecase byte
333                  ((unsigned-byte 8)
334                   (locally (declare (optimize (sb!c::insert-array-bounds-checks 0)))
335                     (setf (aref octets index) byte)))
336                  ((simple-array (unsigned-byte 8) (*))
337                   ;; KLUDGE: We ran into encoding errors.  Bail and do
338                   ;; things the slow way (does anybody actually use this
339                   ;; functionality besides our own test suite?).
340                   (setf error-position pos)
341                   (go :error)))
342                (incf index))
343           finally (return-from string->latin% octets))
344      :error
345        ;; We have encoded INDEX octets so far and we ran into an encoding
346        ;; error at ERROR-POSITION.
347        (let ((new-octets (make-array (* index 2)
348                                      :element-type '(unsigned-byte 8)
349                                      :adjustable t :fill-pointer index)))
350          (replace new-octets octets)
351          (loop for pos of-type index from error-position below send
352             do (let ((thing (funcall get-bytes string pos)))
353                  (typecase thing
354                    ((unsigned-byte 8)
355                     (vector-push-extend thing new-octets))
356                    ((simple-array (unsigned-byte 8) (*))
357                     (dotimes (i (length thing))
358                       (vector-push-extend (aref thing i) new-octets)))))
359             finally (return-from string->latin%
360                       (progn
361                         (unless (zerop null-padding)
362                           (vector-push-extend 0 new-octets))
363                         (copy-seq new-octets))))))))
364
365 (defun string->ascii (string sstart send null-padding)
366   (declare (optimize speed (safety 0))
367            (type simple-string string)
368            (type array-range sstart send))
369   (values (string->latin% string sstart send #'get-ascii-bytes null-padding)))
370
371 (defun string->latin1 (string sstart send null-padding)
372   (declare (optimize speed (safety 0))
373            (type simple-string string)
374            (type array-range sstart send))
375   (values (string->latin% string sstart send #'get-latin1-bytes null-padding)))
376
377 #!+sb-unicode
378 (defun string->latin9 (string sstart send null-padding)
379   (declare (optimize speed (safety 0))
380            (type simple-string string)
381            (type array-range sstart send))
382   (values (string->latin% string sstart send #'get-latin9-bytes null-padding)))
383
384 ;;; to utf8
385
386 (declaim (inline char-len-as-utf8))
387 (defun char-len-as-utf8 (code)
388   (declare (optimize speed (safety 0))
389            (type (integer 0 (#.sb!xc:char-code-limit)) code))
390   (cond ((< code 0) (bug "can't happen"))
391         ((< code #x80) 1)
392         ((< code #x800) 2)
393         ((< code #x10000) 3)
394         ((< code #x110000) 4)
395         (t (bug "can't happen"))))
396
397 (defun string->utf8 (string sstart send null-padding)
398   (declare (optimize (speed 3) (safety 0))
399            (type simple-string string)
400            (type (integer 0 1) null-padding)
401            (type array-range sstart send))
402   (macrolet ((ascii-bash ()
403                '(let ((array (make-array (+ null-padding (- send sstart))
404                                          :element-type '(unsigned-byte 8))))
405                  (loop for i from sstart below send
406                        do (setf (aref array i) (char-code (char string i))))
407                  array)))
408     (etypecase string
409       ((simple-array character (*))
410        (let ((utf8-length 0))
411          ;; Since it has to fit in a vector, it must be a fixnum!
412          (declare (type (and unsigned-byte fixnum) utf8-length))
413          (loop for i of-type index from sstart below send
414                do (incf utf8-length (char-len-as-utf8 (char-code (char string i)))))
415          (if (= utf8-length (- send sstart))
416              (ascii-bash)
417              (let ((array (make-array (+ null-padding utf8-length)
418                                       :element-type '(unsigned-byte 8)))
419                    (index 0))
420                (declare (type index index))
421                (flet ((add-byte (b)
422                         (setf (aref array index) b)
423                         (incf index)))
424                  (declare (inline add-byte))
425                  (loop for i of-type index from sstart below send
426                        do (let ((code (char-code (char string i))))
427                             (case (char-len-as-utf8 code)
428                               (1
429                                (add-byte code))
430                               (2
431                                (add-byte (logior #b11000000 (ldb (byte 5 6) code)))
432                                (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
433                               (3
434                                (add-byte (logior #b11100000 (ldb (byte 4 12) code)))
435                                (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
436                                (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
437                               (4
438                                (add-byte (logior #b11110000 (ldb (byte 3 18) code)))
439                                (add-byte (logior #b10000000 (ldb (byte 6 12) code)))
440                                (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
441                                (add-byte (logior #b10000000 (ldb (byte 6 0) code))))))
442                        finally (return array)))))))
443       #!+sb-unicode
444       ((simple-array base-char (*))
445        ;; On unicode builds BASE-STRINGs are limited to ASCII range, so we can take
446        ;; a fast path -- and get benefit of the element type information. On non-unicode
447        ;; build BASE-CHAR == CHARACTER.
448        (ascii-bash))
449       ((simple-array nil (*))
450        ;; Just get the error...
451        (aref string sstart)))))
452 \f
453 ;;;; to-string conversions
454
455 ;;; from latin (including ascii)
456
457 (defmacro define-ascii->string (accessor type)
458   (let ((name (make-od-name 'ascii->string accessor)))
459     `(progn
460       (defun ,name (array astart aend)
461         (declare (optimize speed)
462                  (type ,type array)
463                  (type array-range astart aend))
464         ;; Since there is such a thing as a malformed ascii byte, a
465         ;; simple "make the string, fill it in" won't do.
466         (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
467           (loop for apos from astart below aend
468                 do (let* ((code (,accessor array apos))
469                           (string-content
470                            (if (< code 128)
471                                (code-char code)
472                                (decoding-error array apos (1+ apos) :ascii
473                                                'malformed-ascii apos))))
474                      (if (characterp string-content)
475                          (vector-push-extend string-content string)
476                          (loop for c across string-content
477                                do (vector-push-extend c string))))
478                 finally (return (coerce string 'simple-string))))))))
479 (instantiate-octets-definition define-ascii->string)
480
481 (defmacro define-latin->string* (accessor type)
482   (let ((name (make-od-name 'latin->string* accessor)))
483     `(progn
484       (declaim (inline ,name))
485       (defun ,name (string sstart send array astart aend mapper)
486         (declare (optimize speed (safety 0))
487                  (type simple-string string)
488                  (type ,type array)
489                  (type array-range sstart send astart aend)
490                  (function mapper))
491         (varimap string sstart send
492                  astart aend
493                  (lambda (spos apos)
494                    (setf (char string spos) (code-char (funcall mapper (,accessor array apos))))
495                    (values 1 1)))))))
496 (instantiate-octets-definition define-latin->string*)
497
498 (defmacro define-latin1->string* (accessor type)
499   (declare (ignore type))
500   (let ((name (make-od-name 'latin1->string* accessor)))
501     `(progn
502       (defun ,name (string sstart send array astart aend)
503         (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity)))))
504 (instantiate-octets-definition define-latin1->string*)
505
506 #!+sb-unicode
507 (progn
508   (defmacro define-latin9->string* (accessor type)
509     (declare (ignore type))
510     (let ((name (make-od-name 'latin9->string* accessor)))
511       `(progn
512         (defun ,name (string sstart send array astart aend)
513           (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'latin9->code-mapper)))))
514   (instantiate-octets-definition define-latin9->string*))
515
516 (defmacro define-latin->string (accessor type)
517   (let ((name (make-od-name 'latin->string accessor)))
518     `(progn
519       (declaim (inline latin->string))
520       (defun ,name (array astart aend mapper)
521         (declare (optimize speed (safety 0))
522                  (type ,type array)
523                  (type array-range astart aend)
524                  (type function mapper))
525         (let ((length (the array-range (- aend astart))))
526           (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
527                                                             array astart aend
528                                                             mapper)))))))
529 (instantiate-octets-definition define-latin->string)
530
531 (defmacro define-latin1->string (accessor type)
532   (declare (ignore type))
533   `(defun ,(make-od-name 'latin1->string accessor) (array astart aend)
534     (,(make-od-name 'latin->string accessor) array astart aend #'identity)))
535 (instantiate-octets-definition define-latin1->string)
536
537 #!+sb-unicode
538 (progn
539   (defmacro define-latin9->string (accessor type)
540     (declare (ignore type))
541     `(defun ,(make-od-name 'latin9->string accessor) (array astart aend)
542       (,(make-od-name 'latin->string accessor) array astart aend #'latin9->code-mapper)))
543   (instantiate-octets-definition define-latin9->string))
544
545 ;;; from utf8
546
547 (defmacro define-bytes-per-utf8-character (accessor type)
548   (let ((name (make-od-name 'bytes-per-utf8-character accessor)))
549     `(progn
550       ;;(declaim (inline ,name))
551       (let ((lexically-max
552              (string->utf8 (string (code-char ,(1- sb!xc:char-code-limit)))
553                            0 1 0)))
554         (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max))
555         (defun ,name (array pos end)
556           (declare (optimize speed (safety 0))
557                    (type ,type array)
558                    (type array-range pos end))
559           ;; returns the number of bytes consumed and nil if it's a
560           ;; valid character or the number of bytes consumed and a
561           ;; replacement string if it's not.
562           (let ((initial-byte (,accessor array pos))
563                 (reject-reason nil)
564                 (reject-position pos)
565                 (remaining-bytes (- end pos)))
566             (declare (type array-range reject-position remaining-bytes))
567             (labels ((valid-utf8-starter-byte-p (b)
568                        (declare (type (unsigned-byte 8) b))
569                        (let ((ok (cond
570                                    ((zerop (logand b #b10000000)) 1)
571                                    ((= (logand b #b11100000) #b11000000)
572                                     2)
573                                    ((= (logand b #b11110000) #b11100000)
574                                     3)
575                                    ((= (logand b #b11111000) #b11110000)
576                                     4)
577                                    ((= (logand b #b11111100) #b11111000)
578                                     5)
579                                    ((= (logand b #b11111110) #b11111100)
580                                     6)
581                                    (t
582                                     nil))))
583                          (unless ok
584                            (setf reject-reason 'invalid-utf8-starter-byte))
585                          ok))
586                      (enough-bytes-left-p (x)
587                        (let ((ok (> end (+ pos (1- x)))))
588                          (unless ok
589                            (setf reject-reason 'end-of-input-in-character))
590                          ok))
591                      (valid-secondary-p (x)
592                        (let* ((idx (the array-range (+ pos x)))
593                               (b (,accessor array idx))
594                               (ok (= (logand b #b11000000) #b10000000)))
595                          (unless ok
596                            (setf reject-reason 'invalid-utf8-continuation-byte)
597                            (setf reject-position idx))
598                          ok))
599                      (preliminary-ok-for-length (maybe-len len)
600                        (and (eql maybe-len len)
601                             ;; Has to be done in this order so that
602                             ;; certain broken sequences (e.g., the
603                             ;; two-byte sequence `"initial (length 3)"
604                             ;; "non-continuation"' -- `#xef #x32')
605                             ;; signal only part of that sequence as
606                             ;; erroneous.
607                             (loop for i from 1 below (min len remaining-bytes)
608                                   always (valid-secondary-p i))
609                             (enough-bytes-left-p len)))
610                      (overlong-chk (x y)
611                        (let ((ok (or (/= initial-byte x)
612                                      (/= (logior (,accessor array (the array-range (+ pos 1)))
613                                                  y)
614                                          y))))
615                          (unless ok
616                            (setf reject-reason 'overlong-utf8-sequence))
617                          ok))
618                      (character-below-char-code-limit-p ()
619                        ;; This is only called on a four-byte sequence
620                        ;; (two in non-unicode builds) to ensure we
621                        ;; don't go over SBCL's character limts.
622                        (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos))
623                                         nil)
624                                        ((> (aref lexically-max 0) (,accessor array pos))
625                                         t)
626                                        ((< (aref lexically-max 1) (,accessor array (+ pos 1)))
627                                         nil)
628                                        #!+sb-unicode
629                                        ((> (aref lexically-max 1) (,accessor array (+ pos 1)))
630                                         t)
631                                        #!+sb-unicode
632                                        ((< (aref lexically-max 2) (,accessor array (+ pos 2)))
633                                         nil)
634                                        #!+sb-unicode
635                                        ((> (aref lexically-max 2) (,accessor array (+ pos 2)))
636                                         t)
637                                        #!+sb-unicode
638                                        ((< (aref lexically-max 3) (,accessor array (+ pos 3)))
639                                         nil)
640                                        (t t))))
641                          (unless ok
642                            (setf reject-reason 'character-out-of-range))
643                          ok)))
644               (declare (inline valid-utf8-starter-byte-p
645                                enough-bytes-left-p
646                                valid-secondary-p
647                                preliminary-ok-for-length
648                                overlong-chk))
649               (let ((maybe-len (valid-utf8-starter-byte-p initial-byte)))
650                 (cond ((eql maybe-len 1)
651                        (values 1 nil))
652                       ((and (preliminary-ok-for-length maybe-len 2)
653                             (overlong-chk #b11000000 #b10111111)
654                             (overlong-chk #b11000001 #b10111111)
655                             #!-sb-unicode (character-below-char-code-limit-p))
656                        (values 2 nil))
657                       ((and (preliminary-ok-for-length maybe-len 3)
658                             (overlong-chk #b11100000 #b10011111)
659                             #!-sb-unicode (not (setf reject-reason 'character-out-of-range)))
660                        (values 3 nil))
661                       ((and (preliminary-ok-for-length maybe-len 4)
662                             (overlong-chk #b11110000 #b10001111)
663                             #!-sb-unicode (not (setf reject-reason 'character-out-of-range))
664                             (character-below-char-code-limit-p))
665                        (values 4 nil))
666                       ((and (preliminary-ok-for-length maybe-len 5)
667                             (overlong-chk #b11111000 #b10000111)
668                             (not (setf reject-reason 'character-out-of-range)))
669                        (bug "can't happen"))
670                       ((and (preliminary-ok-for-length maybe-len 6)
671                             (overlong-chk #b11111100 #b10000011)
672                             (not (setf reject-reason 'character-out-of-range)))
673                        (bug "can't happen"))
674                       (t
675                        (let* ((bad-end (ecase reject-reason
676                                          (invalid-utf8-starter-byte
677                                           (1+ pos))
678                                          (end-of-input-in-character
679                                           end)
680                                          (invalid-utf8-continuation-byte
681                                           reject-position)
682                                          ((overlong-utf8-sequence character-out-of-range)
683                                           (+ pos maybe-len))))
684                               (bad-len (- bad-end pos)))
685                          (declare (type array-range bad-end bad-len))
686                          (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position)))
687                            (values bad-len replacement)))))))))))))
688 (instantiate-octets-definition define-bytes-per-utf8-character)
689
690 (defmacro define-simple-get-utf8-char (accessor type)
691   (let ((name (make-od-name 'simple-get-utf8-char accessor)))
692     `(progn
693       (declaim (inline ,name))
694       (defun ,name (array pos bytes)
695         (declare (optimize speed (safety 0))
696                  (type ,type array)
697                  (type array-range pos)
698                  (type (integer 1 4) bytes))
699         (flet ((cref (x)
700                  (,accessor array (the array-range (+ pos x)))))
701           (declare (inline cref))
702           (code-char (ecase bytes
703                        (1 (cref 0))
704                        (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6)
705                                   (ldb (byte 6 0) (cref 1))))
706                        (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12)
707                                   (ash (ldb (byte 6 0) (cref 1)) 6)
708                                   (ldb (byte 6 0) (cref 2))))
709                        (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18)
710                                   (ash (ldb (byte 6 0) (cref 1)) 12)
711                                   (ash (ldb (byte 6 0) (cref 2)) 6)
712                                   (ldb (byte 6 0) (cref 3)))))))))))
713 (instantiate-octets-definition define-simple-get-utf8-char)
714
715 (defmacro define-utf8->string (accessor type)
716   (let ((name (make-od-name 'utf8->string accessor)))
717     `(progn
718       (defun ,name (array astart aend)
719         (declare (optimize speed (safety 0))
720                  (type ,type array)
721                  (type array-range astart aend))
722         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
723           (loop with pos = astart
724                 while (< pos aend)
725                 do (multiple-value-bind (bytes invalid)
726                        (,(make-od-name 'bytes-per-utf8-character accessor) array pos aend)
727                      (declare (type (or null string) invalid))
728                      (cond
729                        ((null invalid)
730                         (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor) array pos bytes) string))
731                        (t
732                         (dotimes (i (length invalid))
733                           (vector-push-extend (char invalid i) string))))
734                      (incf pos bytes)))
735           (coerce string 'simple-string))))))
736 (instantiate-octets-definition define-utf8->string)
737 \f
738 ;;;; external formats
739
740 (defvar *default-external-format* nil)
741
742 (defun default-external-format ()
743   (or *default-external-format*
744       ;; On non-unicode, use iso-8859-1 instead of detecting it from
745       ;; the locale settings. Defaulting to an external-format which
746       ;; can represent characters that the CHARACTER type can't
747       ;; doesn't seem very sensible.
748       #!-sb-unicode
749       (setf *default-external-format* :latin-1)
750       (let ((external-format #!-win32 (intern (or (sb!alien:alien-funcall
751                                                     (extern-alien
752                                                       "nl_langinfo"
753                                                       (function (c-string :external-format :latin-1)
754                                                                 int))
755                                                     sb!unix:codeset)
756                                                   "LATIN-1")
757                                               "KEYWORD")
758                              #!+win32 (sb!win32::ansi-codepage)))
759         (/show0 "cold-printing defaulted external-format:")
760         #!+sb-show
761         (cold-print external-format)
762         (/show0 "matching to known aliases")
763         (dolist (entry *external-formats*
764                  (progn
765                    ;;; FIXME! This WARN would try to do printing
766                    ;;; before the streams have been initialized,
767                    ;;; causing an infinite erroring loop. We should
768                    ;;; either print it by calling to C, or delay the
769                    ;;; warning until later. Since we're in freeze
770                    ;;; right now, and the warning isn't really
771                    ;;; essential, I'm doing what's least likely to
772                    ;;; cause damage, and commenting it out. This
773                    ;;; should be revisited after 0.9.17. -- JES,
774                    ;;; 2006-09-21
775                    #+nil
776                    (warn "Invalid external-format ~A; using LATIN-1"
777                          external-format)
778                    (setf external-format :latin-1)))
779           (/show0 "cold printing known aliases:")
780           #!+sb-show
781           (dolist (alias (first entry)) (cold-print alias))
782           (/show0 "done cold-printing known aliases")
783           (when (member external-format (first entry))
784             (/show0 "matched")
785             (return)))
786         (/show0 "/default external format ok")
787         (setf *default-external-format* external-format))))
788
789 ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
790 (defparameter *external-format-functions* (make-hash-table))
791
792 (defun add-external-format-funs (format-names funs)
793   (dolist (name format-names (values))
794     (setf (gethash name *external-format-functions*) funs)))
795
796 (add-external-format-funs
797  '(:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|)
798  '(ascii->string-aref string->ascii))
799 (add-external-format-funs
800  '(:latin1 :latin-1 :iso-8859-1 :iso8859-1)
801  '(latin1->string-aref string->latin1))
802 #!+sb-unicode
803 (add-external-format-funs
804  '(:latin9 :latin-9 :iso-8859-15 :iso8859-15)
805  '(latin9->string-aref string->latin9))
806 (add-external-format-funs '(:utf8 :utf-8) '(utf8->string-aref string->utf8))
807
808 (defun external-formats-funs (external-format)
809   (when (eql external-format :default)
810     (setf external-format (default-external-format)))
811   (or (gethash external-format *external-format-functions*)
812       (error "Unknown external-format ~S" external-format)))
813 \f
814 ;;;; public interface
815
816 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
817   (declare (type (vector (unsigned-byte 8)) vector))
818   (with-array-data ((vector vector)
819                     (start start)
820                     (end (%check-vector-sequence-bounds vector start end)))
821     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
822     (funcall (symbol-function (first (external-formats-funs external-format)))
823              vector start end)))
824
825 (defun string-to-octets (string &key (external-format :default)
826                          (start 0) end null-terminate)
827   (declare (type string string))
828   (with-array-data ((string string)
829                     (start start)
830                     (end (%check-vector-sequence-bounds string start end)))
831     (declare (type simple-string string))
832     (funcall (symbol-function (second (external-formats-funs external-format)))
833              string start end (if null-terminate 1 0))))
834
835 #!+sb-unicode
836 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
837 #!+sb-unicode
838 (defun use-unicode-replacement-char (condition)
839   (use-value +unicode-replacement-character+ condition))
840
841 ;;; Utilities that maybe should be exported
842
843 #!+sb-unicode
844 (defmacro with-standard-replacement-character (&body body)
845   `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
846     ,@body))
847
848 (defmacro with-default-decoding-replacement ((c) &body body)
849   (let ((cname (gensym)))
850   `(let ((,cname ,c))
851     (handler-bind
852         ((octet-decoding-error (lambda (c)
853                                  (use-value ,cname c))))
854       ,@body))))