Silence notes about being specialised EQ templates on x86oids
[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 encoding-error (external-format string pos)
42   (restart-case
43       (error 'octets-encoding-error
44              :external-format external-format
45              :string string
46              :position pos)
47     (use-value (replacement)
48       :report "Supply a set of bytes to use in place of the invalid one."
49       :interactive
50       (lambda ()
51         (read-evaluated-form
52          "Replacement byte, bytes, character, or string (evaluated): "))
53       (typecase replacement
54         ((unsigned-byte 8)
55          (make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement))
56         (character
57          (string-to-octets (string replacement)
58                            :external-format external-format))
59         (string
60          (string-to-octets replacement
61                            :external-format external-format))
62         (t
63          (coerce replacement '(simple-array (unsigned-byte 8) (*))))))))
64
65 ;;; decoding condition
66
67 ;;; for UTF8, the specific condition signalled will be a generalized
68 ;;; instance of one of the following:
69 ;;;
70 ;;;   end-of-input-in-character
71 ;;;   character-out-of-range
72 ;;;   invalid-utf8-starter-byte
73 ;;;   invalid-utf8-continuation-byte
74 ;;;
75 ;;; Of these, the only one truly likely to be of interest to calling
76 ;;; code is end-of-input-in-character (in which case it's likely to
77 ;;; want to make a note of octet-decoding-error-start, supply "" as a
78 ;;; replacement string, and then move that last chunk of bytes to the
79 ;;; beginning of its buffer for the next go round) but they're all
80 ;;; provided on the off chance they're of interest.
81
82 (define-condition octet-decoding-error (character-decoding-error)
83   ((array :initarg :array :accessor octet-decoding-error-array)
84    (start :initarg :start :accessor octet-decoding-error-start)
85    (end :initarg :end :accessor octet-decoding-error-end)
86    (position :initarg :pos :accessor octet-decoding-bad-byte-position)
87    (external-format :initarg :external-format
88                     :accessor octet-decoding-error-external-format))
89   (:report
90    (lambda (condition stream)
91      (format stream "Illegal ~S character starting at byte position ~D."
92              (octet-decoding-error-external-format condition)
93              (octet-decoding-error-start condition)))))
94
95 (define-condition end-of-input-in-character (octet-decoding-error) ())
96 (define-condition character-out-of-range (octet-decoding-error) ())
97 (define-condition invalid-utf8-starter-byte (octet-decoding-error) ())
98 (define-condition invalid-utf8-continuation-byte (octet-decoding-error) ())
99 (define-condition overlong-utf8-sequence (octet-decoding-error) ())
100
101 (define-condition malformed-ascii (octet-decoding-error) ())
102
103 (defun decoding-error (array start end external-format reason pos)
104   (restart-case
105       (error reason
106              :external-format external-format
107              :array array
108              :start start
109              :end end
110              :pos pos)
111     (use-value (s)
112       :report "Supply a replacement string designator."
113       :interactive
114       (lambda ()
115         (read-evaluated-form
116          "Enter a replacement string designator (evaluated): "))
117       (string s))))
118
119 ;;; Utilities used in both to-string and to-octet conversions
120
121 (defmacro instantiate-octets-definition (definer)
122   `(progn
123     (,definer aref (simple-array (unsigned-byte 8) (*)))
124     (,definer sap-ref-8 system-area-pointer)))
125
126 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
127 ;;; and fix it, or else replace with SYMBOLICATE.
128 ;;;
129 ;;; FIXME: this is cute, but is going to prevent greps for def.*<name>
130 ;;; from working for (defun ,(make-od-name ...) ...)
131 (eval-when (:compile-toplevel :load-toplevel :execute)
132   (defun make-od-name (sym1 sym2)
133     ;; "MAKE-NAME" is too generic, but this doesn't do quite what
134     ;; SYMBOLICATE does; MAKE-OD-NAME ("octets definition") it is
135     ;; then.
136     (intern (concatenate 'string (symbol-name sym1) "-" (symbol-name sym2))
137             (symbol-package sym1))))
138 \f
139 ;;;; to-octets conversions
140
141 ;;; to latin (including ascii)
142
143 ;;; Converting bytes to character codes is easy: just use a 256-element
144 ;;; lookup table that maps each possible byte to its corresponding
145 ;;; character code.
146 ;;;
147 ;;; Converting character codes to bytes is a little harder, since the
148 ;;; codes may be spare (e.g. we use codes 0-127, 3490, and 4598).  The
149 ;;; previous version of this macro utilized a gigantic CASE expression
150 ;;; to do the hard work, with the result that the code was huge (since
151 ;;; SBCL's then-current compilation strategy for CASE expressions was
152 ;;; (and still is) converting CASE into COND into if-the-elses--which is
153 ;;; also inefficient unless your code happens to occur very early in the
154 ;;; chain.
155 ;;;
156 ;;; The current strategy is to build a table:
157 ;;;
158 ;;; [ ... code_1 byte_1 code_2 byte_2 ... code_n byte_n ... ]
159 ;;;
160 ;;; such that the codes are sorted in order from lowest to highest.  We
161 ;;; can then binary search the table to discover the appropriate byte
162 ;;; for a character code.  We also implement an optimization: all unibyte
163 ;;; mappings do not remap ASCII (0-127) and some do not remap part of
164 ;;; the range beyond character code 127.  So we check to see if the
165 ;;; character code falls into that range first (a quick check, since
166 ;;; character codes are guaranteed to be positive) and then do the binary
167 ;;; search if not.  This optimization also enables us to cut down on the
168 ;;; size of our lookup table.
169 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
170   (let* (;; Build a list of (CODE BYTE) pairs
171          (pairs (loop for byte below 256
172                    for code = (let ((exception (cdr (assoc byte exceptions))))
173                                 (cond
174                                   ((car exception) (car exception))
175                                   ((null exception) byte)
176                                   (t nil)))
177                    when code collect (list code byte) into elements
178                    finally (return elements)))
179          ;; Find the smallest character code such that the corresponding
180          ;; byte is != to the code.
181          (lowest-non-equivalent-code
182           (caar (sort (copy-seq exceptions) #'< :key #'car)))
183          ;; Sort them for our lookup table.
184          (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
185                              #'< :key #'car))
186          ;; Create the lookup table.
187          (sorted-lookup-table
188           (reduce #'append sorted-pairs :from-end t :initial-value nil)))
189     `(progn
190        ; Can't inline it with a non-null lexical environment anyway.
191        ;(declaim (inline ,byte-char-name))
192        (let ((byte-to-code-table
193               ,(make-array 256 :element-type t #+nil 'char-code
194                            :initial-contents (loop for byte below 256
195                                                 collect
196                                                 (let ((exception (cdr (assoc byte exceptions))))
197                                                   (if exception
198                                                       (car exception)
199                                                       byte)))))
200              (code-to-byte-table
201               ,(make-array (length sorted-lookup-table)
202                            :initial-contents sorted-lookup-table)))
203          (defun ,byte-char-name (byte)
204            (declare (optimize speed (safety 0))
205                     (type (unsigned-byte 8) byte))
206            (aref byte-to-code-table byte))
207          (defun ,code-byte-name (code)
208            (declare (optimize speed (safety 0))
209                     (type char-code code))
210            (if (< code ,lowest-non-equivalent-code)
211                code
212                ;; We could toss in some TRULY-THEs if we really needed to
213                ;; make this faster...
214                (loop with low = 0
215                   with high = (- (length code-to-byte-table) 2)
216                   while (< low high)
217                   do (let ((mid (logandc2 (truncate (+ low high 2) 2) 1)))
218                        (if (< code (aref code-to-byte-table mid))
219                            (setf high (- mid 2))
220                            (setf low mid)))
221                   finally (return (if (eql code (aref code-to-byte-table low))
222                                       (aref code-to-byte-table (1+ low))
223                                       nil)))))))))
224
225 (declaim (inline get-latin-bytes))
226 (defun get-latin-bytes (mapper external-format string pos)
227   (let ((code (funcall mapper (char-code (char string pos)))))
228     (declare (type (or null char-code) code))
229     (values (cond
230               ((and code (< code 256)) code)
231               (t
232                (encoding-error external-format string pos)))
233             1)))
234
235 (declaim (inline string->latin%))
236 (defun string->latin% (string sstart send get-bytes null-padding)
237   (declare (optimize speed)
238            (type simple-string string)
239            (type index sstart send)
240            (type (integer 0 1) null-padding)
241            (type function get-bytes))
242   ;; The latin encodings are all unibyte encodings, so just directly
243   ;; compute the number of octets we're going to generate.
244   (let ((octets (make-array (+ (- send sstart) null-padding)
245                             ;; This takes care of any null padding the
246                             ;; caller requests.
247                             :initial-element 0
248                             :element-type '(unsigned-byte 8)))
249         (index 0)
250         (error-position 0)
251         (error-replacement))
252     (tagbody
253      :no-error
254        (loop for pos of-type index from sstart below send
255           do (let ((byte (funcall get-bytes string pos)))
256                (typecase byte
257                  ((unsigned-byte 8)
258                   (locally (declare (optimize (sb!c::insert-array-bounds-checks 0)))
259                     (setf (aref octets index) byte)))
260                  ((simple-array (unsigned-byte 8) (*))
261                   ;; KLUDGE: We ran into encoding errors.  Bail and do
262                   ;; things the slow way (does anybody actually use this
263                   ;; functionality besides our own test suite?).
264                   (setf error-position pos error-replacement byte)
265                   (go :error)))
266                (incf index))
267           finally (return-from string->latin% octets))
268      :error
269        ;; We have encoded INDEX octets so far and we ran into an
270        ;; encoding error at ERROR-POSITION; the user has asked us to
271        ;; replace the expected output with ERROR-REPLACEMENT.
272        (let ((new-octets (make-array (* index 2)
273                                      :element-type '(unsigned-byte 8)
274                                      :adjustable t :fill-pointer index)))
275          (replace new-octets octets)
276          (flet ((extend (thing)
277                  (typecase thing
278                    ((unsigned-byte 8) (vector-push-extend thing new-octets))
279                    ((simple-array (unsigned-byte 8) (*))
280                     (dotimes (i (length thing))
281                       (vector-push-extend (aref thing i) new-octets))))))
282            (extend error-replacement)
283            (loop for pos of-type index from (1+ error-position) below send
284                  do (extend (funcall get-bytes string pos))
285                  finally (return-from string->latin%
286                            (progn
287                              (unless (zerop null-padding)
288                                (vector-push-extend 0 new-octets))
289                              (copy-seq new-octets)))))))))
290 \f
291 ;;;; to-string conversions
292
293 ;;; from latin (including ascii)
294
295 (defmacro define-latin->string* (accessor type)
296   (let ((name (make-od-name 'latin->string* accessor)))
297     `(progn
298       (declaim (inline ,name))
299       (defun ,name (string sstart send array astart aend mapper)
300         (declare (optimize speed (safety 0))
301                  (type simple-string string)
302                  (type ,type array)
303                  (type array-range sstart send astart aend)
304                  (function mapper))
305         (loop for spos from sstart below send
306            for apos from astart below aend
307            do (setf (char string spos)
308                     (code-char (funcall mapper (,accessor array apos))))
309            finally (return (values string spos apos)))))))
310 (instantiate-octets-definition define-latin->string*)
311
312 (defmacro define-latin->string (accessor type)
313   (let ((name (make-od-name 'latin->string accessor)))
314     `(progn
315       (declaim (inline ,name))
316       (defun ,name (array astart aend mapper)
317         (declare (optimize speed (safety 0))
318                  (type ,type array)
319                  (type array-range astart aend)
320                  (type function mapper))
321         (let ((length (the array-range (- aend astart))))
322           (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
323                                                             array astart aend
324                                                             mapper)))))))
325 (instantiate-octets-definition define-latin->string)
326 \f
327 ;;;; external formats
328
329 (defvar *default-external-format* nil)
330
331 (defun default-external-format ()
332   (or *default-external-format*
333       ;; On non-unicode, use iso-8859-1 instead of detecting it from
334       ;; the locale settings. Defaulting to an external-format which
335       ;; can represent characters that the CHARACTER type can't
336       ;; doesn't seem very sensible.
337       #!-sb-unicode
338       (setf *default-external-format* :latin-1)
339       (let ((external-format #!-win32 (intern (or (sb!alien:alien-funcall
340                                                     (extern-alien
341                                                       "nl_langinfo"
342                                                       (function (c-string :external-format :latin-1)
343                                                                 int))
344                                                     sb!unix:codeset)
345                                                   "LATIN-1")
346                                               "KEYWORD")
347                              #!+win32 (sb!win32::ansi-codepage)))
348         (/show0 "cold-printing defaulted external-format:")
349         #!+sb-show
350         (cold-print external-format)
351         (/show0 "matching to known aliases")
352         (let ((entry (sb!impl::get-external-format external-format)))
353           (cond
354             (entry
355              (/show0 "matched"))
356             (t
357              ;; FIXME! This WARN would try to do printing
358              ;; before the streams have been initialized,
359              ;; causing an infinite erroring loop. We should
360              ;; either print it by calling to C, or delay the
361              ;; warning until later. Since we're in freeze
362              ;; right now, and the warning isn't really
363              ;; essential, I'm doing what's least likely to
364              ;; cause damage, and commenting it out. This
365              ;; should be revisited after 0.9.17. -- JES,
366              ;; 2006-09-21
367              #+nil
368              (warn "Invalid external-format ~A; using LATIN-1"
369                    external-format)
370              (setf external-format :latin-1))))
371         (/show0 "/default external format ok")
372         (setf *default-external-format* external-format))))
373 \f
374 ;;;; public interface
375
376 (defun maybe-defaulted-external-format (external-format)
377   (sb!impl::get-external-format-or-lose (if (eq external-format :default)
378                                             (default-external-format)
379                                             external-format)))
380
381 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
382   (declare (type (vector (unsigned-byte 8)) vector))
383   (with-array-data ((vector vector)
384                     (start start)
385                     (end end)
386                     :check-fill-pointer t)
387     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
388     (let ((ef (maybe-defaulted-external-format external-format)))
389       (funcall (sb!impl::ef-octets-to-string-fun ef) vector start end))))
390
391 (defun string-to-octets (string &key (external-format :default)
392                          (start 0) end null-terminate)
393   (declare (type string string))
394   (with-array-data ((string string)
395                     (start start)
396                     (end end)
397                     :check-fill-pointer t)
398     (declare (type simple-string string))
399     (let ((ef (maybe-defaulted-external-format external-format)))
400       (funcall (sb!impl::ef-string-to-octets-fun ef) string start end
401                (if null-terminate 1 0)))))
402
403 #!+sb-unicode
404 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
405 #!+sb-unicode
406 (defun use-unicode-replacement-char (condition)
407   (use-value +unicode-replacement-character+ condition))
408
409 ;;; Utilities that maybe should be exported
410
411 #!+sb-unicode
412 (defmacro with-standard-replacement-character (&body body)
413   `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
414     ,@body))
415
416 (defmacro with-default-decoding-replacement ((c) &body body)
417   (let ((cname (gensym)))
418   `(let ((,cname ,c))
419     (handler-bind
420         ((octet-decoding-error (lambda (c)
421                                  (use-value ,cname c))))
422       ,@body))))