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 sb!xc: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 sb!xc: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 sb!xc: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 sb!xc:char-code-limit)
 438         (code-char code)
 439         (return-from decode-break-reason 4)))
 440   ucs-4be->string-aref
 441   string->ucs-4be)