3 ;;; TODO Macro for generating different variants:
4 ;;; :ucs-2le (little endian) sap-ref-16le
5 ;;; :ucs-2be (big endian) sap-ref-16be
6 ;;; :ucs-2 (native) sap-ref-16
10 (declaim (inline sap-ref-16le (setf sap-ref-16le)
11 sap-ref-16be (setf sap-ref-16be)))
13 ;;; Define feature LITTLE-ENDIAN-AND-MISALIGNED-READ?
14 (defun sap-ref-16le (sap offset)
16 (sap-ref-16 sap offset)
18 (dpb (sap-ref-8 sap (1+ offset)) (byte 8 8)
19 (sap-ref-8 sap offset)))
21 (defun (setf sap-ref-16le) (value sap offset)
23 (setf (sap-ref-16 sap offset) value)
25 (setf (sap-ref-8 sap offset) (logand #xFF value)
26 (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))
28 (defun sap-ref-16be (sap offset)
29 (dpb (sap-ref-8 sap offset) (byte 8 8)
30 (sap-ref-8 sap (1+ offset))))
32 (defun (setf sap-ref-16be) (value sap offset)
33 (setf (sap-ref-8 sap (1+ offset)) (logand #xFF value)
34 (sap-ref-8 sap offset) (ldb (byte 8 8) value)))
37 ;;; Define external format: fd-stream
39 (define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) nil
42 (setf (sap-ref-16le sap tail) bits)
43 (external-format-encoding-error stream bits))
45 (code-char (sap-ref-16le sap head)))
47 (define-external-format/variable-width (:ucs-2be :ucs2be) nil
50 (setf (sap-ref-16be sap tail) bits)
51 (external-format-encoding-error stream bits))
53 (code-char (sap-ref-16be sap head)))
60 ;;; Conversion to UCS-2{LE,BE}
61 (declaim (inline char->ucs-2le))
62 (defun char->ucs-2le (char dest string pos)
63 (declare (optimize speed (safety 0))
64 (type (array (unsigned-byte 8) (*)) dest))
65 (let ((code (char-code char)))
68 (declare (type (unsigned-byte 8) b))
69 (vector-push b dest)))
70 (declare (inline add-byte))
71 (add-byte (ldb (byte 8 0) code))
72 (add-byte (ldb (byte 8 8) code)))
74 (encoding-error :ucs-2le string pos))))
76 (declaim (inline char->ucs-2be))
77 (defun char->ucs-2be (char dest string pos)
78 (declare (optimize speed (safety 0))
79 (type (array (unsigned-byte 8) (*)) dest))
80 (let ((code (char-code char)))
83 (declare (type (unsigned-byte 8) b))
84 (vector-push b dest)))
85 (declare (inline add-byte))
86 (add-byte (ldb (byte 8 8) code))
87 (add-byte (ldb (byte 8 0) code)))
89 (encoding-error :ucs-16be string pos))))
91 (defun string->ucs-2le (string sstart send additional-space)
92 (declare (optimize speed (safety 0))
93 (type simple-string string)
94 (type array-range sstart send additional-space))
95 (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
96 :element-type '(unsigned-byte 8)
98 (loop for i from sstart below send
99 do (char->ucs-2le (char string i) array string i))
100 (dotimes (i additional-space)
101 (vector-push 0 array)
102 (vector-push 0 array))
103 (coerce array '(simple-array (unsigned-byte 8) (*)))))
105 (defun string->ucs-2be (string sstart send additional-space)
106 (declare (optimize speed (safety 0))
107 (type simple-string string)
108 (type array-range sstart send additional-space))
109 (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
110 :element-type '(unsigned-byte 8)
112 (loop for i from sstart below send
113 do (char->ucs-2be (char string i) array string i))
114 (dotimes (i additional-space)
115 (vector-push 0 array)
116 (vector-push 0 array))
117 (coerce array '(simple-array (unsigned-byte 8) (*)))))
119 ;; Conversion from UCS-2{LE,BE}
120 (defmacro define-bytes-per-ucs2-character (accessor type)
121 (declare (ignore type))
122 (let ((name-le (make-od-name 'bytes-per-ucs-2le-character accessor))
123 (name-be (make-od-name 'bytes-per-ucs-2be-character accessor)))
125 (defun ,name-le (array pos end)
126 (declare (ignore array pos end))
128 (defun ,name-be (array pos end)
129 (declare (ignore array pos end))
131 (instantiate-octets-definition define-bytes-per-ucs2-character)
133 (defmacro define-simple-get-ucs2-character (accessor type)
134 (let ((name-le (make-od-name 'simple-get-ucs-2le-char accessor))
135 (name-be (make-od-name 'simple-get-ucs-2be-char accessor)))
137 (defun ,name-le (array pos bytes)
138 (declare (optimize speed (safety 0))
140 (type array-range pos)
141 (type (integer 1 4) bytes)
143 ;; Optimization for SYSTEM-AREA-POINTER: use SAP-REF-16LE that
144 ;; reads two bytes at once on some architectures.
145 ,(if (and (eq accessor 'sap-ref-8)
146 (eq type 'system-area-pointer))
147 '(code-char (sap-ref-16le array pos))
149 (,accessor array (the array-range (+ pos x)))))
150 (declare (inline cref))
151 (code-char (dpb (cref 1) (byte 8 8)
153 (defun ,name-be (array pos bytes)
154 (declare (optimize speed (safety 0))
156 (type array-range pos)
157 (type (integer 1 4) bytes)
159 ;; Use SAP-REF-16BE even if it is not optimized
160 ,(if (and (eq accessor 'sap-ref-8)
161 (eq type 'system-area-pointer))
162 '(code-char (sap-ref-16be array pos))
164 (,accessor array (the array-range (+ pos x)))))
165 (declare (inline cref))
166 (code-char (dpb (cref 0) (byte 8 8)
169 (instantiate-octets-definition define-simple-get-ucs2-character)
171 (defmacro define-ucs-2->string (accessor type)
172 (let ((name-le (make-od-name 'ucs-2le->string accessor))
173 (name-be (make-od-name 'ucs-2be->string accessor)))
175 (defun ,name-le (array astart aend)
176 (declare (optimize speed (safety 0))
178 (type array-range astart aend))
179 (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
180 (loop with pos = astart
182 do (multiple-value-bind (bytes invalid)
183 (,(make-od-name 'bytes-per-ucs-2le-character accessor) array pos aend)
184 (declare (type (or null string) invalid))
185 (assert (null invalid))
187 (,(make-od-name 'simple-get-ucs-2le-char accessor)
192 (defun ,name-be (array astart aend)
193 (declare (optimize speed (safety 0))
195 (type array-range astart aend))
196 (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
197 (loop with pos = astart
199 do (multiple-value-bind (bytes invalid)
200 (,(make-od-name 'bytes-per-ucs-2be-character accessor) array pos aend)
201 (declare (type (or null string) invalid))
202 (assert (null invalid))
204 (,(make-od-name 'simple-get-ucs-2be-char accessor)
210 (instantiate-octets-definition define-ucs-2->string)
212 (add-external-format-funs '(:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2)
213 '(ucs-2le->string-aref string->ucs-2le))
215 (add-external-format-funs '(:ucs-2be :ucs2be)
216 '(ucs-2be->string-aref string->ucs-2be))