src/code/external-formats/ucs-2.lisp

   1 (in-package #:sb!impl)
   2
   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
   7
   8 ;;;  Utilities
   9
  10 (declaim (inline sap-ref-16le (setf sap-ref-16le)
  11                  sap-ref-16be (setf sap-ref-16be)))
  12
  13 ;;; Define feature LITTLE-ENDIAN-AND-MISALIGNED-READ?
  14 (defun sap-ref-16le (sap offset)
  15   #!+(or x86 x86-64)
  16   (sap-ref-16 sap offset)
  17   #!-(or x86 x86-64)
  18   (dpb (sap-ref-8 sap (1+ offset)) (byte 8 8)
  19        (sap-ref-8 sap offset)))
  20
  21 (defun (setf sap-ref-16le) (value sap offset)
  22   #!+(or x86 x86-64)
  23   (setf (sap-ref-16 sap offset) value)
  24   #!-(or x86 x86-64)
  25   (setf (sap-ref-8 sap offset) (logand #xFF value)
  26         (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))
  27
  28 (defun sap-ref-16be (sap offset)
  29   (dpb (sap-ref-8 sap offset) (byte 8 8)
  30        (sap-ref-8 sap (1+ offset))))
  31
  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)))
  35
  36 ;;;
  37 ;;;   Define external format: fd-stream
  38 ;;;
  39 (define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) nil
  40   2
  41   (if (< bits #x10000)
  42       (setf (sap-ref-16le sap tail) bits)
  43       (external-format-encoding-error stream bits))
  44   2
  45   (code-char (sap-ref-16le sap head)))
  46
  47 (define-external-format/variable-width (:ucs-2be :ucs2be) nil
  48   2
  49   (if (< bits #x10000)
  50       (setf (sap-ref-16be sap tail) bits)
  51       (external-format-encoding-error stream bits))
  52   2
  53   (code-char (sap-ref-16be sap head)))
  54
  55
  56 ;;;
  57 ;;;   octets
  58 ;;;
  59
  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)))
  66     (if (< code #x10000)
  67         (flet ((add-byte (b)
  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)))
  73         ; signal error
  74         (encoding-error :ucs-2le string pos))))
  75
  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)))
  81     (if (< code #x10000)
  82         (flet ((add-byte (b)
  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)))
  88         ; signal error
  89         (encoding-error :ucs-16be string pos))))
  90
  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)
  97                            :fill-pointer 0)))
  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) (*)))))
 104
 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)
 111                            :fill-pointer 0)))
 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) (*)))))
 118
 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)))
 124     `(progn
 125       (defun ,name-le (array pos end)
 126         (declare (ignore array pos end))
 127         (values 2 nil))
 128       (defun ,name-be (array pos end)
 129         (declare (ignore array pos end))
 130         (values 2 nil)))))
 131 (instantiate-octets-definition define-bytes-per-ucs2-character)
 132
 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)))
 136     `(progn
 137       (defun ,name-le (array pos bytes)
 138         (declare (optimize speed (safety 0))
 139                  (type ,type array)
 140                  (type array-range pos)
 141                  (type (integer 1 4) bytes)
 142                  (ignore 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))
 148              `(flet ((cref (x)
 149                       (,accessor array (the array-range (+ pos x)))))
 150                (declare (inline cref))
 151                (code-char (dpb (cref 1) (byte 8 8)
 152                           (cref 0))))))
 153       (defun ,name-be (array pos bytes)
 154         (declare (optimize speed (safety 0))
 155                  (type ,type array)
 156                  (type array-range pos)
 157                  (type (integer 1 4) bytes)
 158                  (ignore 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))
 163              `(flet ((cref (x)
 164                       (,accessor array (the array-range (+ pos x)))))
 165                (declare (inline cref))
 166                (code-char (dpb (cref 0) (byte 8 8)
 167                                (cref 1)))))))))
 168
 169 (instantiate-octets-definition define-simple-get-ucs2-character)
 170
 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)))
 174     `(progn
 175       (defun ,name-le (array astart aend)
 176         (declare (optimize speed (safety 0))
 177                  (type ,type array)
 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
 181                 while (< pos aend)
 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))
 186                      (vector-push-extend
 187                       (,(make-od-name 'simple-get-ucs-2le-char accessor)
 188                         array pos bytes)
 189                       string)
 190                      (incf pos bytes)))
 191           string))
 192       (defun ,name-be (array astart aend)
 193         (declare (optimize speed (safety 0))
 194                  (type ,type array)
 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
 198                 while (< pos aend)
 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))
 203                      (vector-push-extend
 204                       (,(make-od-name 'simple-get-ucs-2be-char accessor)
 205                         array pos bytes)
 206                       string)
 207                      (incf pos bytes)))
 208           string)))))
 209
 210 (instantiate-octets-definition define-ucs-2->string)
 211
 212 (add-external-format-funs '(:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2)
 213                           '(ucs-2le->string-aref string->ucs-2le))
 214
 215 (add-external-format-funs '(:ucs-2be :ucs2be)
 216                           '(ucs-2be->string-aref string->ucs-2be))