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 ;;;   octets
  38 ;;;
  39
  40 ;;; Conversion to UCS-2{LE,BE}
  41 (declaim (inline char->ucs-2le))
  42 (defun char->ucs-2le (char dest string pos)
  43   (declare (optimize speed (safety 0))
  44            (type (array (unsigned-byte 8) (*)) dest))
  45   (let ((code (char-code char)))
  46     (if (< code #x10000)
  47         (flet ((add-byte (b)
  48                  (declare (type (unsigned-byte 8) b))
  49                  (vector-push b dest)))
  50           (declare (inline add-byte))
  51           (add-byte (ldb (byte 8 0) code))
  52           (add-byte (ldb (byte 8 8) code)))
  53         ; signal error
  54         (encoding-error :ucs-2le string pos))))
  55
  56 (declaim (inline char->ucs-2be))
  57 (defun char->ucs-2be (char dest string pos)
  58   (declare (optimize speed (safety 0))
  59            (type (array (unsigned-byte 8) (*)) dest))
  60   (let ((code (char-code char)))
  61     (if (< code #x10000)
  62         (flet ((add-byte (b)
  63                  (declare (type (unsigned-byte 8) b))
  64                  (vector-push b dest)))
  65           (declare (inline add-byte))
  66           (add-byte (ldb (byte 8 8) code))
  67           (add-byte (ldb (byte 8 0) code)))
  68         ; signal error
  69         (encoding-error :ucs-16be string pos))))
  70
  71 (defun string->ucs-2le (string sstart send additional-space)
  72   (declare (optimize speed (safety 0))
  73            (type simple-string string)
  74            (type array-range sstart send additional-space))
  75   (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
  76                            :element-type '(unsigned-byte 8)
  77                            :fill-pointer 0)))
  78     (loop for i from sstart below send
  79           do (char->ucs-2le (char string i) array string i))
  80     (dotimes (i additional-space)
  81       (vector-push 0 array)
  82       (vector-push 0 array))
  83     (coerce array '(simple-array (unsigned-byte 8) (*)))))
  84
  85 (defun string->ucs-2be (string sstart send additional-space)
  86   (declare (optimize speed (safety 0))
  87            (type simple-string string)
  88            (type array-range sstart send additional-space))
  89   (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
  90                            :element-type '(unsigned-byte 8)
  91                            :fill-pointer 0)))
  92     (loop for i from sstart below send
  93           do (char->ucs-2be (char string i) array string i))
  94     (dotimes (i additional-space)
  95       (vector-push 0 array)
  96       (vector-push 0 array))
  97     (coerce array '(simple-array (unsigned-byte 8) (*)))))
  98
  99 ;; Conversion from UCS-2{LE,BE}
 100 (defmacro define-bytes-per-ucs2-character (accessor type)
 101   (declare (ignore type))
 102   (let ((name-le (make-od-name 'bytes-per-ucs-2le-character accessor))
 103         (name-be (make-od-name 'bytes-per-ucs-2be-character accessor)))
 104     `(progn
 105       (defun ,name-le (array pos end)
 106         (declare (ignore array pos end))
 107         (values 2 nil))
 108       (defun ,name-be (array pos end)
 109         (declare (ignore array pos end))
 110         (values 2 nil)))))
 111 (instantiate-octets-definition define-bytes-per-ucs2-character)
 112
 113 (defmacro define-simple-get-ucs2-character (accessor type)
 114   (let ((name-le (make-od-name 'simple-get-ucs-2le-char accessor))
 115         (name-be (make-od-name 'simple-get-ucs-2be-char accessor)))
 116     `(progn
 117       (defun ,name-le (array pos bytes)
 118         (declare (optimize speed (safety 0))
 119                  (type ,type array)
 120                  (type array-range pos)
 121                  (type (integer 1 4) bytes)
 122                  (ignore bytes))
 123         ;; Optimization for SYSTEM-AREA-POINTER: use SAP-REF-16LE that
 124         ;; reads two bytes at once on some architectures.
 125         ,(if (and (eq accessor 'sap-ref-8)
 126                   (eq type 'system-area-pointer))
 127              '(code-char (sap-ref-16le array pos))
 128              `(flet ((cref (x)
 129                       (,accessor array (the array-range (+ pos x)))))
 130                (declare (inline cref))
 131                (code-char (dpb (cref 1) (byte 8 8)
 132                           (cref 0))))))
 133       (defun ,name-be (array pos bytes)
 134         (declare (optimize speed (safety 0))
 135                  (type ,type array)
 136                  (type array-range pos)
 137                  (type (integer 1 4) bytes)
 138                  (ignore bytes))
 139         ;; Use SAP-REF-16BE even if it is not optimized
 140         ,(if (and (eq accessor 'sap-ref-8)
 141                   (eq type 'system-area-pointer))
 142              '(code-char (sap-ref-16be array pos))
 143              `(flet ((cref (x)
 144                       (,accessor array (the array-range (+ pos x)))))
 145                (declare (inline cref))
 146                (code-char (dpb (cref 0) (byte 8 8)
 147                                (cref 1)))))))))
 148
 149 (instantiate-octets-definition define-simple-get-ucs2-character)
 150
 151 (defmacro define-ucs-2->string (accessor type)
 152   (let ((name-le (make-od-name 'ucs-2le->string accessor))
 153         (name-be (make-od-name 'ucs-2be->string accessor)))
 154     `(progn
 155       (defun ,name-le (array astart aend)
 156         (declare (optimize speed (safety 0))
 157                  (type ,type array)
 158                  (type array-range astart aend))
 159         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 160           (loop with pos = astart
 161                 while (< pos aend)
 162                 do (multiple-value-bind (bytes invalid)
 163                        (,(make-od-name 'bytes-per-ucs-2le-character accessor) array pos aend)
 164                      (declare (type (or null string) invalid))
 165                      (assert (null invalid))
 166                      (vector-push-extend
 167                       (,(make-od-name 'simple-get-ucs-2le-char accessor)
 168                         array pos bytes)
 169                       string)
 170                      (incf pos bytes)))
 171           string))
 172       (defun ,name-be (array astart aend)
 173         (declare (optimize speed (safety 0))
 174                  (type ,type array)
 175                  (type array-range astart aend))
 176         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 177           (loop with pos = astart
 178                 while (< pos aend)
 179                 do (multiple-value-bind (bytes invalid)
 180                        (,(make-od-name 'bytes-per-ucs-2be-character accessor) array pos aend)
 181                      (declare (type (or null string) invalid))
 182                      (assert (null invalid))
 183                      (vector-push-extend
 184                       (,(make-od-name 'simple-get-ucs-2be-char accessor)
 185                         array pos bytes)
 186                       string)
 187                      (incf pos bytes)))
 188           string)))))
 189
 190 (instantiate-octets-definition define-ucs-2->string)
 191
 192 (define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) t
 193   (code-char #xfffd)
 194   2
 195   (if (< bits #x10000)
 196       (setf (sap-ref-16le sap tail) bits)
 197       (external-format-encoding-error stream bits))
 198   2
 199   (code-char (sap-ref-16le sap head))
 200   ucs-2le->string-aref
 201   string->ucs-2le)
 202
 203 (define-external-format/variable-width (:ucs-2be :ucs2be) t
 204   (code-char #xfffd)
 205   2
 206   (if (< bits #x10000)
 207       (setf (sap-ref-16be sap tail) bits)
 208       (external-format-encoding-error stream bits))
 209   2
 210   (code-char (sap-ref-16be sap head))
 211   ucs-2be->string-aref
 212   string->ucs-2be)