Add safepoint mechanism
[sbcl.git] / src / code / external-formats / enc-ucs.lisp
1 ;;;; Universal Character Set (UCS) encodings
2 ;;;;
3 ;;;; In our interpretation, these are distinct from UTF encodings: the
4 ;;;; UCS encodings are a direct encoding of the code point, in 16- and
5 ;;;; 32-bit variants; by contrast, the UTF encodings handle Unicode
6 ;;;; surrogate code points specially.
7
8 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; more information.
10 ;;;;
11 ;;;; This software is derived from the CMU CL system, which was
12 ;;;; written at Carnegie Mellon University and released into the
13 ;;;; public domain. The software is in the public domain and is
14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
15 ;;;; files for more information.
16
17 (in-package "SB!IMPL")
18
19 ;;; TODO Macro for generating different variants:
20 ;;; :ucs-2le (little endian)    sap-ref-16le
21 ;;; :ucs-2be (big endian)       sap-ref-16be
22 ;;; :ucs-2   (native)           sap-ref-16
23
24 ;;;  Utilities
25
26 (declaim
27  (inline sap-ref-16le (setf sap-ref-16le) sap-ref-16be (setf sap-ref-16be)
28          sap-ref-32le (setf sap-ref-32le) sap-ref-32be (setf sap-ref-32be)))
29
30 ;;; Define feature LITTLE-ENDIAN-AND-MISALIGNED-READ?
31 (defun sap-ref-16le (sap offset)
32   #!+(or x86 x86-64)
33   (sap-ref-16 sap offset)
34   #!-(or x86 x86-64)
35   (dpb (sap-ref-8 sap (1+ offset)) (byte 8 8)
36        (sap-ref-8 sap offset)))
37
38 (defun (setf sap-ref-16le) (value sap offset)
39   #!+(or x86 x86-64)
40   (setf (sap-ref-16 sap offset) value)
41   #!-(or x86 x86-64)
42   (setf (sap-ref-8 sap offset) (logand value #xff)
43         (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))
44
45 (defun sap-ref-16be (sap offset)
46   (dpb (sap-ref-8 sap offset) (byte 8 8)
47        (sap-ref-8 sap (1+ offset))))
48
49 (defun (setf sap-ref-16be) (value sap offset)
50   (setf (sap-ref-8 sap (1+ offset)) (logand value #xff)
51         (sap-ref-8 sap offset) (ldb (byte 8 8) value)))
52
53 (defun sap-ref-32le (sap offset)
54   #!+(or x86 x86-64)
55   (sap-ref-32 sap offset)
56   #!-(or x86 x86-64)
57   (dpb (sap-ref-8 sap (+ offset 3)) (byte 8 24)
58        (dpb (sap-ref-8 sap (+ offset 2)) (byte 8 16)
59             (sap-ref-16le sap offset))))
60
61 (defun (setf sap-ref-32le) (value sap offset)
62   #!+(or x86 x86-64)
63   (setf (sap-ref-32 sap offset) value)
64   #!-(or x86 x86-64)
65   (setf (sap-ref-8 sap offset) (logand value #xff)
66         (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)
67         (sap-ref-8 sap (+ offset 2)) (ldb (byte 8 16) value)
68         (sap-ref-8 sap (+ offset 3)) (ldb (byte 8 24) value)))
69
70 (defun sap-ref-32be (sap offset)
71   (dpb (sap-ref-8 sap offset) (byte 8 24)
72        (dpb (sap-ref-8 sap (1+ offset)) (byte 8 16)
73             (dpb (sap-ref-8 sap (+ offset 2)) (byte 8 8)
74                  (sap-ref-8 sap (+ offset 3))))))
75
76 (defun (setf sap-ref-32be) (value sap offset)
77   (setf (sap-ref-8 sap offset) (ldb (byte 8 24) value)
78         (sap-ref-8 sap (1+ offset)) (ldb (byte 8 16) value)
79         (sap-ref-8 sap (+ offset 2)) (ldb (byte 8 8) value)
80         (sap-ref-8 sap (+ offset 3)) (logand value #xff)))
81 \f
82 ;;;
83 ;;;   octets
84 ;;;
85
86 ;;; Conversion to UCS-2{LE,BE}
87 (declaim (inline char->ucs-2le))
88 (defun char->ucs-2le (char dest string pos)
89   (declare (optimize speed (safety 0))
90            (type (array (unsigned-byte 8) (*)) dest))
91   (let ((code (char-code char)))
92     (if (< code #x10000)
93         (flet ((add-byte (b)
94                  (declare (type (unsigned-byte 8) b))
95                  (vector-push-extend b dest)))
96           (declare (inline add-byte))
97           (add-byte (ldb (byte 8 0) code))
98           (add-byte (ldb (byte 8 8) code)))
99         (let ((replacement (encoding-error :ucs-2le string pos)))
100           (declare (type (simple-array (unsigned-byte 8) (*)) replacement))
101           (dotimes (i (length replacement))
102             (vector-push-extend (aref replacement i) dest))))))
103
104 (declaim (inline char->ucs-2be))
105 (defun char->ucs-2be (char dest string pos)
106   (declare (optimize speed (safety 0))
107            (type (array (unsigned-byte 8) (*)) dest))
108   (let ((code (char-code char)))
109     (if (< code #x10000)
110         (flet ((add-byte (b)
111                  (declare (type (unsigned-byte 8) b))
112                  (vector-push-extend b dest)))
113           (declare (inline add-byte))
114           (add-byte (ldb (byte 8 8) code))
115           (add-byte (ldb (byte 8 0) code)))
116         (let ((replacement (encoding-error :ucs-2be string pos)))
117           (declare (type (simple-array (unsigned-byte 8) (*)) replacement))
118           (dotimes (i (length replacement))
119             (vector-push-extend (aref replacement i) dest))))))
120
121 (defun string->ucs-2le (string sstart send additional-space)
122   (declare (optimize speed (safety 0))
123            (type simple-string string)
124            (type array-range sstart send additional-space))
125   (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
126                            :element-type '(unsigned-byte 8)
127                            :fill-pointer 0 :adjustable t)))
128     (loop for i from sstart below send
129           do (char->ucs-2le (char string i) array string i))
130     (dotimes (i (* 2 additional-space))
131       (vector-push-extend 0 array))
132     (coerce array '(simple-array (unsigned-byte 8) (*)))))
133
134 (defun string->ucs-2be (string sstart send additional-space)
135   (declare (optimize speed (safety 0))
136            (type simple-string string)
137            (type array-range sstart send additional-space))
138   (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
139                            :element-type '(unsigned-byte 8)
140                            :fill-pointer 0 :adjustable t)))
141     (loop for i from sstart below send
142           do (char->ucs-2be (char string i) array string i))
143     (dotimes (i (* 2 additional-space))
144       (vector-push-extend 0 array))
145     (coerce array '(simple-array (unsigned-byte 8) (*)))))
146
147 ;; Conversion from UCS-2{LE,BE}
148 (defmacro define-bytes-per-ucs2-character (accessor type)
149   (declare (ignore type))
150   (let ((name-le (make-od-name 'bytes-per-ucs-2le-character accessor))
151         (name-be (make-od-name 'bytes-per-ucs-2be-character accessor)))
152     `(progn
153       (defun ,name-le (array pos end)
154         (declare (ignore array pos end))
155         (values 2 nil))
156       (defun ,name-be (array pos end)
157         (declare (ignore array pos end))
158         (values 2 nil)))))
159 (instantiate-octets-definition define-bytes-per-ucs2-character)
160
161 (defmacro define-simple-get-ucs2-character (accessor type)
162   (let ((name-le (make-od-name 'simple-get-ucs-2le-char accessor))
163         (name-be (make-od-name 'simple-get-ucs-2be-char accessor)))
164     `(progn
165       (defun ,name-le (array pos bytes)
166         (declare (optimize speed (safety 0))
167                  (type ,type array)
168                  (type array-range pos)
169                  (type (integer 1 4) bytes)
170                  (ignore bytes))
171         ;; Optimization for SYSTEM-AREA-POINTER: use SAP-REF-16LE that
172         ;; reads two bytes at once on some architectures.
173         ,(if (and (eq accessor 'sap-ref-8)
174                   (eq type 'system-area-pointer))
175              '(code-char (sap-ref-16le array pos))
176              `(flet ((cref (x)
177                       (,accessor array (the array-range (+ pos x)))))
178                (declare (inline cref))
179                (code-char (dpb (cref 1) (byte 8 8) (cref 0))))))
180       (defun ,name-be (array pos bytes)
181         (declare (optimize speed (safety 0))
182                  (type ,type array)
183                  (type array-range pos)
184                  (type (integer 1 4) bytes)
185                  (ignore bytes))
186         ;; Use SAP-REF-16BE even if it is not optimized
187         ,(if (and (eq accessor 'sap-ref-8)
188                   (eq type 'system-area-pointer))
189              '(code-char (sap-ref-16be array pos))
190              `(flet ((cref (x)
191                       (,accessor array (the array-range (+ pos x)))))
192                (declare (inline cref))
193                (code-char (dpb (cref 0) (byte 8 8) (cref 1)))))))))
194
195 (instantiate-octets-definition define-simple-get-ucs2-character)
196
197 (defmacro define-ucs-2->string (accessor type)
198   (let ((name-le (make-od-name 'ucs-2le->string accessor))
199         (name-be (make-od-name 'ucs-2be->string accessor)))
200     `(progn
201       (defun ,name-le (array astart aend)
202         (declare (optimize speed (safety 0))
203                  (type ,type array)
204                  (type array-range astart aend))
205         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
206           (loop with pos = astart
207                 while (< pos aend)
208                 do (multiple-value-bind (bytes invalid)
209                        (,(make-od-name 'bytes-per-ucs-2le-character accessor) array pos aend)
210                      (declare (type (or null string) invalid))
211                      (aver (null invalid))
212                      (vector-push-extend
213                       (,(make-od-name 'simple-get-ucs-2le-char accessor)
214                         array pos bytes)
215                       string)
216                      (incf pos bytes)))
217           string))
218       (defun ,name-be (array astart aend)
219         (declare (optimize speed (safety 0))
220                  (type ,type array)
221                  (type array-range astart aend))
222         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
223           (loop with pos = astart
224                 while (< pos aend)
225                 do (multiple-value-bind (bytes invalid)
226                        (,(make-od-name 'bytes-per-ucs-2be-character accessor) array pos aend)
227                      (declare (type (or null string) invalid))
228                      (aver (null invalid))
229                      (vector-push-extend
230                       (,(make-od-name 'simple-get-ucs-2be-char accessor)
231                         array pos bytes)
232                       string)
233                      (incf pos bytes)))
234           string)))))
235
236 (instantiate-octets-definition define-ucs-2->string)
237
238 (define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) t
239   (code-char #xfffd)
240   2
241   (if (< bits #x10000)
242       (setf (sap-ref-16le sap tail) bits)
243       (external-format-encoding-error stream bits))
244   2
245   (code-char (sap-ref-16le sap head))
246   ucs-2le->string-aref
247   string->ucs-2le)
248
249 (define-external-format/variable-width (:ucs-2be :ucs2be) t
250   (code-char #xfffd)
251   2
252   (if (< bits #x10000)
253       (setf (sap-ref-16be sap tail) bits)
254       (external-format-encoding-error stream bits))
255   2
256   (code-char (sap-ref-16be sap head))
257   ucs-2be->string-aref
258   string->ucs-2be)
259 \f
260 (declaim (inline char->ucs-4le))
261 (defun char->ucs-4le (char dest string pos)
262   (declare (optimize speed (safety 0))
263            (type (array (unsigned-byte 8) (*)) dest)
264            (ignore string pos))
265   (let ((code (char-code char)))
266     (flet ((add-byte (b)
267              (declare (type (unsigned-byte 8) b))
268              (vector-push-extend b dest)))
269       (declare (inline add-byte))
270       (add-byte (ldb (byte 8 0) code))
271       (add-byte (ldb (byte 8 8) code))
272       (add-byte (ldb (byte 8 16) code))
273       (add-byte (ldb (byte 8 24) code)))))
274
275 (declaim (inline char->ucs-4be))
276 (defun char->ucs-4be (char dest string pos)
277   (declare (optimize speed (safety 0))
278            (type (array (unsigned-byte 8) (*)) dest)
279            (ignore string pos))
280   (let ((code (char-code char)))
281     (flet ((add-byte (b)
282              (declare (type (unsigned-byte 8) b))
283              (vector-push-extend b dest)))
284       (declare (inline add-byte))
285       (add-byte (ldb (byte 8 24) code))
286       (add-byte (ldb (byte 8 16) code))
287       (add-byte (ldb (byte 8 8) code))
288       (add-byte (ldb (byte 8 0) code)))))
289
290 (defun string->ucs-4le (string sstart send additional-space)
291   (declare (optimize speed (safety 0))
292            (type simple-string string)
293            (type array-range sstart send additional-space))
294   (let ((array (make-array (* 4 (+ additional-space (- send sstart)))
295                            :element-type '(unsigned-byte 8)
296                            :fill-pointer 0 :adjustable t)))
297     (loop for i from sstart below send
298           do (char->ucs-4le (char string i) array string i))
299     (dotimes (i (* 4 additional-space))
300       (vector-push-extend 0 array))
301     (coerce array '(simple-array (unsigned-byte 8) (*)))))
302
303 (defun string->ucs-4be (string sstart send additional-space)
304   (declare (optimize speed (safety 0))
305            (type simple-string string)
306            (type array-range sstart send additional-space))
307   (let ((array (make-array (* 4 (+ additional-space (- send sstart)))
308                            :element-type '(unsigned-byte 8)
309                            :fill-pointer 0 :adjustable t)))
310     (loop for i from sstart below send
311           do (char->ucs-4be (char string i) array string i))
312     (dotimes (i (* 4 additional-space))
313       (vector-push-extend 0 array))
314     (coerce array '(simple-array (unsigned-byte 8) (*)))))
315
316 ;; Conversion from UCS-4{LE,BE}
317 (defmacro define-bytes-per-ucs4-character (accessor type)
318   (declare (ignore type))
319   (let ((name-le (make-od-name 'bytes-per-ucs-4le-character accessor))
320         (name-be (make-od-name 'bytes-per-ucs-4be-character accessor)))
321     `(progn
322       (defun ,name-le (array pos end)
323         (declare (ignore array pos end))
324         (values 4 nil))
325       (defun ,name-be (array pos end)
326         (declare (ignore array pos end))
327         (values 4 nil)))))
328 (instantiate-octets-definition define-bytes-per-ucs4-character)
329
330 (defmacro define-simple-get-ucs4-character (accessor type)
331   (let ((name-le (make-od-name 'simple-get-ucs-4le-char accessor))
332         (name-be (make-od-name 'simple-get-ucs-4be-char accessor)))
333     `(progn
334       (defun ,name-le (array pos bytes)
335         (declare (optimize speed (safety 0))
336                  (type ,type array)
337                  (type array-range pos)
338                  (type (integer 1 4) bytes))
339         ;; Optimization for SYSTEM-AREA-POINTER: use SAP-REF-32LE that
340         ;; reads four bytes at once on some architectures.
341         (let ((code ,(if (and (eq accessor 'sap-ref-8)
342                               (eq type 'system-area-pointer))
343                          '(sap-ref-32le array pos)
344                          `(flet ((cref (x)
345                                    (,accessor array (the array-range (+ pos x)))))
346                             (declare (inline cref))
347                             (dpb (cref 3) (byte 8 24)
348                                  (dpb (cref 2) (byte 8 16)
349                                       (dpb (cref 1) (byte 8 8) (cref 0))))))))
350           (if (< code char-code-limit)
351               (code-char code)
352               (decoding-error array pos (+ pos bytes) :ucs-4le
353                               'octet-decoding-error pos))))
354       (defun ,name-be (array pos bytes)
355         (declare (optimize speed (safety 0))
356                  (type ,type array)
357                  (type array-range pos)
358                  (type (integer 1 4) bytes))
359         ;; Use SAP-REF-32BE even if it is not optimized
360         (let ((code ,(if (and (eq accessor 'sap-ref-8)
361                               (eq type 'system-area-pointer))
362                          '(sap-ref-32be array pos)
363                          `(flet ((cref (x)
364                                    (,accessor array (the array-range (+ pos x)))))
365                             (declare (inline cref))
366                             (dpb (cref 0) (byte 8 24)
367                                  (dpb (cref 1) (byte 8 16)
368                                       (dpb (cref 2) (byte 8 8) (cref 3))))))))
369           (if (< code char-code-limit)
370               (code-char code)
371               (decoding-error array pos (+ pos bytes) :ucs-4be
372                               'octet-decoding-error pos)))))))
373
374 (instantiate-octets-definition define-simple-get-ucs4-character)
375
376 (defmacro define-ucs-4->string (accessor type)
377   (let ((name-le (make-od-name 'ucs-4le->string accessor))
378         (name-be (make-od-name 'ucs-4be->string accessor)))
379     `(progn
380       (defun ,name-le (array astart aend)
381         (declare (optimize speed (safety 0))
382                  (type ,type array)
383                  (type array-range astart aend))
384         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
385           (loop with pos = astart
386                 while (< pos aend)
387                 do (multiple-value-bind (bytes invalid)
388                        (,(make-od-name 'bytes-per-ucs-4le-character accessor) array pos aend)
389                      (declare (type (or null string) invalid))
390                      (aver (null invalid))
391                      (let ((thing (,(make-od-name 'simple-get-ucs-4le-char accessor) array pos bytes)))
392                        (typecase thing
393                          (character (vector-push-extend thing string))
394                          (string (dotimes (i (length thing))
395                                    (vector-push-extend (char thing i) string)))))
396                      (incf pos bytes)))
397           string))
398       (defun ,name-be (array astart aend)
399         (declare (optimize speed (safety 0))
400                  (type ,type array)
401                  (type array-range astart aend))
402         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
403           (loop with pos = astart
404                 while (< pos aend)
405                 do (multiple-value-bind (bytes invalid)
406                        (,(make-od-name 'bytes-per-ucs-4be-character accessor) array pos aend)
407                      (declare (type (or null string) invalid))
408                      (aver (null invalid))
409                      (let ((thing (,(make-od-name 'simple-get-ucs-4be-char accessor) array pos bytes)))
410                        (typecase thing
411                          (character (vector-push-extend thing string))
412                          (string (dotimes (i (length thing))
413                                    (vector-push-extend (char thing i) string)))))
414                      (incf pos bytes)))
415           string)))))
416
417 (instantiate-octets-definition define-ucs-4->string)
418
419 (define-external-format/variable-width (:ucs-4le :ucs4le) nil
420   (code-char #xfffd)
421   4
422   (setf (sap-ref-32le sap tail) bits)
423   4
424   (let ((code (sap-ref-32le sap head)))
425     (if (< code char-code-limit)
426         (code-char code)
427         (return-from decode-break-reason 4)))
428   ucs-4le->string-aref
429   string->ucs-4le)
430
431 (define-external-format/variable-width (:ucs-4be :ucs4be) nil
432   (code-char #xfffd)
433   4
434   (setf (sap-ref-32be sap tail) bits)
435   4
436   (let ((code (sap-ref-32be sap head)))
437     (if (< code char-code-limit)
438         (code-char code)
439         (return-from decode-break-reason 4)))
440   ucs-4be->string-aref
441   string->ucs-4be)