src/code/external-formats/enc-utf.lisp

   1 ;;;; Unicode Transformation Format (UTF) encodings
   2 ;;;;
   3 ;;;; In our interpretation, these are distinct from UCS 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 \f
  20 (declaim (inline utf-noncharacter-code-p))
  21 (defun utf-noncharacter-code-p (code)
  22   (or (<= #xd800 code #xdfff)
  23       (<= #xfdd0 code #xfdef)
  24       (= (logand code #xfffe) #xfffe)))
  25
  26 ;;; Conversion to UTF-16{LE,BE}
  27 (declaim (inline char->utf-16le))
  28 (defun char->utf-16le (char dest string pos)
  29   (declare (optimize speed (safety 0))
  30            (type (array (unsigned-byte 8) (*)) dest))
  31   (let ((code (char-code char)))
  32     (if (utf-noncharacter-code-p code)
  33         (let ((replacement (encoding-error :utf-16le string pos)))
  34           (declare (type (simple-array (unsigned-byte 8) (*)) replacement))
  35           (dotimes (i (length replacement))
  36             (vector-push-extend (aref replacement i) dest)))
  37         (flet ((add-byte (b)
  38                  (declare (type (unsigned-byte 8) b))
  39                  (vector-push-extend b dest)))
  40           (declare (inline add-byte))
  41           (cond
  42             ((< code #x10000)
  43              (add-byte (ldb (byte 8 0) code))
  44              (add-byte (ldb (byte 8 8) code)))
  45             (t
  46              (let* ((codeoid (- code #x10000))
  47                     (high (dpb (ldb (byte 10 10) codeoid) (byte 10 0) #xd800))
  48                     (low (dpb (ldb (byte 10 0) codeoid) (byte 10 0) #xdc00)))
  49                (add-byte (ldb (byte 8 0) high))
  50                (add-byte (ldb (byte 8 8) high))
  51                (add-byte (ldb (byte 8 0) low))
  52                (add-byte (ldb (byte 8 8) low)))))))))
  53
  54 (declaim (inline char->utf-16be))
  55 (defun char->utf-16be (char dest string pos)
  56   (declare (optimize speed (safety 0))
  57            (type (array (unsigned-byte 8) (*)) dest))
  58     (let ((code (char-code char)))
  59     (if (utf-noncharacter-code-p code)
  60         (let ((replacement (encoding-error :utf-16be string pos)))
  61           (declare (type (simple-array (unsigned-byte 8) (*)) replacement))
  62           (dotimes (i (length replacement))
  63             (vector-push-extend (aref replacement i) dest)))
  64         (flet ((add-byte (b)
  65                  (declare (type (unsigned-byte 8) b))
  66                  (vector-push-extend b dest)))
  67           (declare (inline add-byte))
  68           (cond
  69             ((< code #x10000)
  70              (add-byte (ldb (byte 8 8) code))
  71              (add-byte (ldb (byte 8 0) code)))
  72             (t
  73              (let* ((codeoid (- code #x10000))
  74                     (high (dpb (ldb (byte 10 10) codeoid) (byte 10 0) #xd800))
  75                     (low (dpb (ldb (byte 10 0) codeoid) (byte 10 0) #xdc00)))
  76                (add-byte (ldb (byte 8 8) high))
  77                (add-byte (ldb (byte 8 0) high))
  78                (add-byte (ldb (byte 8 8) low))
  79                (add-byte (ldb (byte 8 0) low)))))))))
  80
  81 (defun string->utf-16le (string sstart send additional-space)
  82   (declare (optimize speed (safety 0))
  83            (type simple-string string)
  84            (type array-range sstart send additional-space))
  85   (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
  86                            :element-type '(unsigned-byte 8)
  87                            :fill-pointer 0 :adjustable t)))
  88     (loop for i from sstart below send
  89           do (char->utf-16le (char string i) array string i))
  90     (dotimes (i (* 2 additional-space))
  91       (vector-push-extend 0 array))
  92     (coerce array '(simple-array (unsigned-byte 8) (*)))))
  93
  94 (defun string->utf-16be (string sstart send additional-space)
  95   (declare (optimize speed (safety 0))
  96            (type simple-string string)
  97            (type array-range sstart send additional-space))
  98   (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
  99                            :element-type '(unsigned-byte 8)
 100                            :fill-pointer 0 :adjustable t)))
 101     (loop for i from sstart below send
 102           do (char->utf-16be (char string i) array string i))
 103     (dotimes (i (* 2 additional-space))
 104       (vector-push-extend 0 array))
 105     (coerce array '(simple-array (unsigned-byte 8) (*)))))
 106
 107 ;; Conversion from UTF-16{LE,BE}
 108 (defmacro define-bytes-per-utf16-character (accessor type)
 109   (declare (ignore type))
 110   (let ((name-le (make-od-name 'bytes-per-utf-16le-character accessor))
 111         (name-be (make-od-name 'bytes-per-utf-16be-character accessor)))
 112     `(progn
 113       (defun ,name-le (array pos end)
 114         (let ((remaining (- end pos)))
 115           (when (< remaining 2)
 116             (return-from ,name-le (values remaining (decoding-error array pos end :utf-16le 'octet-decoding-error pos))))
 117           (let ((low (dpb (,accessor array (+ pos 1)) (byte 8 8) (,accessor array pos))))
 118             (if (<= #xd800 low #xdbff)
 119                 (if (< remaining 4)
 120                     (values remaining (decoding-error array pos end :utf-16le 'octet-decoding-error pos))
 121                     (let ((high (dpb (,accessor array (+ pos 3)) (byte 8 8) (,accessor array (+ pos 2)))))
 122                       (if (<= #xdc00 high #xdfff)
 123                           (let ((code (dpb (ldb (byte 10 0) low) (byte 10 10) (ldb (byte 10 0) high))))
 124                             (if (= (logand code #xfffe) #xfffe)
 125                                 (values 4 (decoding-error array pos (+ pos 4) :utf-16le 'octet-decoding-error pos))
 126                                 (values 4 nil)))
 127                           (values 2 (decoding-error array pos (+ pos 2) :utf-16le 'octet-decoding-error pos)))))
 128                 (if (or (<= #xdc00 low #xdfff)
 129                         (<= #xfdd0 low #xfdef)
 130                         (= (logand low #xfffe) #xfffe))
 131                     (values 2 (decoding-error array pos (+ pos 2) :utf-16le 'octet-decoding-error pos))
 132                     (values 2 nil))))))
 133       (defun ,name-be (array pos end)
 134         (let ((remaining (- end pos)))
 135           (when (< remaining 2)
 136             (return-from ,name-be (values remaining (decoding-error array pos end :utf-16le 'octet-decoding-error pos))))
 137           (let ((low (dpb (,accessor array pos) (byte 8 8) (,accessor array (+ pos 1)))))
 138             (if (<= #xd800 low #xdbff)
 139                 (if (< remaining 4)
 140                     (values remaining (decoding-error array pos end :utf-16le 'octet-decoding-error pos))
 141                     (let ((high (dpb (,accessor array (+ pos 2)) (byte 8 8) (,accessor array (+ pos 3)))))
 142                       (if (<= #xdc00 high #xdfff)
 143                           (let ((code (dpb (ldb (byte 10 0) low) (byte 10 10) (ldb (byte 10 0) high))))
 144                             (if (= (logand code #xfffe) #xfffe)
 145                                 (values 4 (decoding-error array pos (+ pos 4) :utf-16le 'octet-decoding-error pos))
 146                                 (values 4 nil)))
 147                           (values 2 (decoding-error array pos (+ pos 2) :utf-16le 'octet-decoding-error pos)))))
 148                 (if (or (<= #xdc00 low #xdfff)
 149                         (<= #xfdd0 low #xfdef)
 150                         (= (logand low #xfffe) #xfffe))
 151                     (values 2 (decoding-error array pos (+ pos 2) :utf-16le 'octet-decoding-error pos))
 152                     (values 2 nil)))))))))
 153 (instantiate-octets-definition define-bytes-per-utf16-character)
 154
 155 (defmacro define-simple-get-utf16-character (accessor type)
 156   (let ((name-le (make-od-name 'simple-get-utf-16le-char accessor))
 157         (name-be (make-od-name 'simple-get-utf-16be-char accessor)))
 158     `(progn
 159       (defun ,name-le (array pos bytes)
 160         (declare (optimize speed (safety 0))
 161                  (type ,type array)
 162                  (type array-range pos)
 163                  (type (integer 1 4) bytes)
 164                  (ignore bytes))
 165         ;; Optimization for SYSTEM-AREA-POINTER: use SAP-REF-16LE that
 166         ;; reads two bytes at once on some architectures.
 167         (let ((code ,(if (and (eq accessor 'sap-ref-8)
 168                               (eq type 'system-area-pointer))
 169                          '(sap-ref-16le array pos)
 170                          `(flet ((cref (x)
 171                                    (,accessor array (the array-range (+ pos x)))))
 172                             (declare (inline cref))
 173                             (dpb (cref 1) (byte 8 8) (cref 0))))))
 174           (if (<= #xd800 code #xdbff)
 175               (let ((next ,(if (and (eq accessor 'sap-ref-8)
 176                                     (eq type 'system-area-pointer))
 177                                '(sap-ref-16le array (+ pos 2))
 178                                `(flet ((cref (x)
 179                                          (,accessor array (the array-range (+ pos x)))))
 180                                   (declare (inline cref))
 181                                   (dpb (cref 3) (byte 8 8) (cref 2))))))
 182                 (code-char (+ #x10000 (dpb (ldb (byte 10 0) code) (byte 10 10) (ldb (byte 10 0) next)))))
 183               (code-char code))))
 184       (defun ,name-be (array pos bytes)
 185         (declare (optimize speed (safety 0))
 186                  (type ,type array)
 187                  (type array-range pos)
 188                  (type (integer 1 4) bytes)
 189                  (ignore bytes))
 190         ;; Use SAP-REF-16BE even if it is not optimized
 191         (let ((code ,(if (and (eq accessor 'sap-ref-8)
 192                               (eq type 'system-area-pointer))
 193                          '(sap-ref-16be array pos)
 194                          `(flet ((cref (x)
 195                                    (,accessor array (the array-range (+ pos x)))))
 196                             (declare (inline cref))
 197                             (dpb (cref 0) (byte 8 8) (cref 1))))))
 198           (if (<= #xd800 code #xdbff)
 199               (let ((next ,(if (and (eq accessor 'sap-ref-8)
 200                                     (eq type 'system-area-pointer))
 201                                '(sap-ref-16be array (+ pos 2))
 202                                `(flet ((cref (x)
 203                                          (,accessor array (the array-range (+ pos x)))))
 204                                   (declare (inline cref))
 205                                   (dpb (cref 2) (byte 8 8) (cref 3))))))
 206                 (code-char (+ #x10000 (dpb (ldb (byte 10 0) code) (byte 10 10) (ldb (byte 10 0) next)))))
 207               (code-char code)))))))
 208
 209 (instantiate-octets-definition define-simple-get-utf16-character)
 210
 211 (defmacro define-utf-16->string (accessor type)
 212   (let ((name-le (make-od-name 'utf-16le->string accessor))
 213         (name-be (make-od-name 'utf-16be->string accessor)))
 214     `(progn
 215       (defun ,name-le (array astart aend)
 216         (declare (optimize speed (safety 0))
 217                  (type ,type array)
 218                  (type array-range astart aend))
 219         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 220           (loop with pos = astart
 221                 while (< pos aend)
 222                 do (multiple-value-bind (bytes invalid)
 223                        (,(make-od-name 'bytes-per-utf-16le-character accessor) array pos aend)
 224                      (declare (type (or null string) invalid))
 225                      (cond
 226                        ((null invalid)
 227                         (vector-push-extend
 228                          (,(make-od-name 'simple-get-utf-16le-char accessor)
 229                            array pos bytes)
 230                          string))
 231                        (t (dotimes (i (length invalid))
 232                             (vector-push-extend (char invalid i) string))))
 233                      (incf pos bytes)))
 234           string))
 235       (defun ,name-be (array astart aend)
 236         (declare (optimize speed (safety 0))
 237                  (type ,type array)
 238                  (type array-range astart aend))
 239         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 240           (loop with pos = astart
 241                 while (< pos aend)
 242                 do (multiple-value-bind (bytes invalid)
 243                        (,(make-od-name 'bytes-per-utf-16be-character accessor) array pos aend)
 244                      (declare (type (or null string) invalid))
 245                      (cond
 246                        ((null invalid)
 247                         (vector-push-extend
 248                          (,(make-od-name 'simple-get-utf-16be-char accessor)
 249                            array pos bytes)
 250                          string))
 251                        (t (dotimes (i (length invalid))
 252                             (vector-push-extend (char invalid i) string))))
 253                      (incf pos bytes)))
 254           string)))))
 255
 256 (instantiate-octets-definition define-utf-16->string)
 257
 258 (define-external-format/variable-width (:utf-16le :utf16le) t
 259   (code-char #xfffd)
 260   (let ((bits (char-code byte)))
 261     (if (< bits #x10000) 2 4))
 262   (cond
 263     ((< bits #x10000)
 264      (if (utf-noncharacter-code-p bits)
 265          (external-format-encoding-error stream bits)
 266          (setf (sap-ref-16le sap tail) bits)))
 267     (t (if (= (logand bits #xfffe) #xfffe)
 268            (external-format-encoding-error stream bits)
 269            (let* ((new-bits (- bits #x10000))
 270                   (high (ldb (byte 10 10) new-bits))
 271                   (low (ldb (byte 10 0) new-bits)))
 272              (setf (sap-ref-16le sap tail) (dpb high (byte 10 0) #xd800))
 273              (setf (sap-ref-16le sap (+ tail 2)) (dpb low (byte 10 0) #xdc00))))))
 274   (2 (if (<= #xd800 (sap-ref-16le sap head) #xdbff) 4 2))
 275   (let ((bits (sap-ref-16le sap head)))
 276     (cond
 277       ((or (<= #xdc00 bits #xdfff)
 278            (<= #xfdd0 bits #xfdef)
 279            (= (logand bits #xfffe) #xfffe))
 280        (return-from decode-break-reason 2))
 281       ((<= #xd800 bits #xdbff)
 282        (let ((next (sap-ref-16le sap (+ head 2))))
 283          (unless (<= #xdc00 next #xdfff)
 284            (return-from decode-break-reason 2))
 285          (let ((code (dpb (ldb (byte 10 0) bits) (byte 10 10) (ldb (byte 10 0) next))))
 286            (if (= (logand code #xfffe) #xfffe)
 287                (return-from decode-break-reason 4)
 288                (code-char (+ #x10000 code))))))
 289       (t (code-char bits))))
 290   utf-16le->string-aref
 291   string->utf-16le)
 292
 293 (define-external-format/variable-width (:utf-16be :utf16be) t
 294   (code-char #xfffd)
 295   (let ((bits (char-code byte)))
 296     (if (< bits #x10000) 2 4))
 297   (cond
 298     ((< bits #x10000)
 299      (if (utf-noncharacter-code-p bits)
 300          (external-format-encoding-error stream bits)
 301          (setf (sap-ref-16be sap tail) bits)))
 302     (t (if (= (logand bits #xfffe) #xfffe)
 303            (external-format-encoding-error stream bits)
 304            (let* ((new-bits (- bits #x10000))
 305                   (high (ldb (byte 10 10) new-bits))
 306                   (low (ldb (byte 10 0) new-bits)))
 307              (setf (sap-ref-16be sap tail) (dpb high (byte 10 0) #xd800))
 308              (setf (sap-ref-16be sap (+ tail 2)) (dpb low (byte 10 0) #xdc00))))))
 309   (2 (if (<= #xd800 (sap-ref-16be sap head) #xdbff) 4 2))
 310   (let ((bits (sap-ref-16be sap head)))
 311     (cond
 312       ((or (<= #xdc00 bits #xdfff)
 313            (<= #xfdd0 bits #xfdef)
 314            (= (logand bits #xfffe) #xfffe))
 315        (return-from decode-break-reason 2))
 316       ((<= #xd800 bits #xdbff)
 317        (let ((next (sap-ref-16be sap (+ head 2))))
 318          (unless (<= #xdc00 next #xdfff)
 319            (return-from decode-break-reason 2))
 320          (let ((code (dpb (ldb (byte 10 0) bits) (byte 10 10) (ldb (byte 10 0) next))))
 321            (if (= (logand code #xfffe) #xfffe)
 322                (return-from decode-break-reason 4)
 323                (code-char (+ #x10000 code))))))
 324       (t (code-char bits))))
 325   utf-16be->string-aref
 326   string->utf-16be)
 327 \f
 328 (declaim (inline char->utf-32le))
 329 (defun char->utf-32le (char dest string pos)
 330   (declare (optimize speed (safety 0))
 331            (type (array (unsigned-byte 8) (*)) dest))
 332   (let ((code (char-code char)))
 333     (if (utf-noncharacter-code-p code)
 334         (let ((replacement (encoding-error :utf-32le string pos)))
 335           (declare (type (simple-array (unsigned-byte 8) (*)) replacement))
 336           (dotimes (i (length replacement))
 337             (vector-push-extend (aref replacement i) dest)))
 338         (flet ((add-byte (b)
 339                  (declare (type (unsigned-byte 8) b))
 340                  (vector-push-extend b dest)))
 341           (declare (inline add-byte))
 342           (add-byte (ldb (byte 8 0) code))
 343           (add-byte (ldb (byte 8 8) code))
 344           (add-byte (ldb (byte 8 16) code))
 345           (add-byte (ldb (byte 8 24) code))))))
 346
 347 (declaim (inline char->utf-32be))
 348 (defun char->utf-32be (char dest string pos)
 349   (declare (optimize speed (safety 0))
 350            (type (array (unsigned-byte 8) (*)) dest))
 351   (let ((code (char-code char)))
 352     (if (utf-noncharacter-code-p code)
 353         (let ((replacement (encoding-error :utf-32be string pos)))
 354           (declare (type (simple-array (unsigned-byte 8) (*)) replacement))
 355           (dotimes (i (length replacement))
 356             (vector-push-extend (aref replacement i) dest)))
 357         (flet ((add-byte (b)
 358                  (declare (type (unsigned-byte 8) b))
 359                  (vector-push-extend b dest)))
 360           (declare (inline add-byte))
 361           (add-byte (ldb (byte 8 24) code))
 362           (add-byte (ldb (byte 8 16) code))
 363           (add-byte (ldb (byte 8 8) code))
 364           (add-byte (ldb (byte 8 0) code))))))
 365
 366 (defun string->utf-32le (string sstart send additional-space)
 367   (declare (optimize speed (safety 0))
 368            (type simple-string string)
 369            (type array-range sstart send additional-space))
 370   (let ((array (make-array (* 4 (+ additional-space (- send sstart)))
 371                            :element-type '(unsigned-byte 8)
 372                            :fill-pointer 0 :adjustable t)))
 373     (loop for i from sstart below send
 374           do (char->utf-32le (char string i) array string i))
 375     (dotimes (i (* 4 additional-space))
 376       (vector-push-extend 0 array))
 377     (coerce array '(simple-array (unsigned-byte 8) (*)))))
 378
 379 (defun string->utf-32be (string sstart send additional-space)
 380   (declare (optimize speed (safety 0))
 381            (type simple-string string)
 382            (type array-range sstart send additional-space))
 383   (let ((array (make-array (* 4 (+ additional-space (- send sstart)))
 384                            :element-type '(unsigned-byte 8)
 385                            :fill-pointer 0 :adjustable t)))
 386     (loop for i from sstart below send
 387           do (char->utf-32be (char string i) array string i))
 388     (dotimes (i (* 4 additional-space))
 389       (vector-push-extend 0 array))
 390     (coerce array '(simple-array (unsigned-byte 8) (*)))))
 391
 392 ;; Conversion from UTF-32{LE,BE}
 393 (defmacro define-bytes-per-utf32-character (accessor type)
 394   (declare (ignore type))
 395   (let ((name-le (make-od-name 'bytes-per-utf-32le-character accessor))
 396         (name-be (make-od-name 'bytes-per-utf-32be-character accessor)))
 397     `(progn
 398       (defun ,name-le (array pos end)
 399         (declare (ignore array pos end))
 400         (values 4 nil))
 401       (defun ,name-be (array pos end)
 402         (declare (ignore array pos end))
 403         (values 4 nil)))))
 404 (instantiate-octets-definition define-bytes-per-utf32-character)
 405
 406 (defmacro define-simple-get-utf32-character (accessor type)
 407   (let ((name-le (make-od-name 'simple-get-utf-32le-char accessor))
 408         (name-be (make-od-name 'simple-get-utf-32be-char accessor)))
 409     `(progn
 410       (defun ,name-le (array pos bytes)
 411         (declare (optimize speed (safety 0))
 412                  (type ,type array)
 413                  (type array-range pos)
 414                  (type (integer 1 4) bytes))
 415         ;; Optimization for SYSTEM-AREA-POINTER: use SAP-REF-32LE that
 416         ;; reads four bytes at once on some architectures.
 417         (let ((code ,(if (and (eq accessor 'sap-ref-8)
 418                               (eq type 'system-area-pointer))
 419                          '(sap-ref-32le array pos)
 420                          `(flet ((cref (x)
 421                                    (,accessor array (the array-range (+ pos x)))))
 422                             (declare (inline cref))
 423                             (dpb (cref 3) (byte 8 24)
 424                                  (dpb (cref 2) (byte 8 16)
 425                                       (dpb (cref 1) (byte 8 8) (cref 0))))))))
 426           (if (and (< code char-code-limit)
 427                    (not (utf-noncharacter-code-p code)))
 428               (code-char code)
 429               (decoding-error array pos (+ pos bytes) :utf-32le
 430                               'octet-decoding-error pos))))
 431       (defun ,name-be (array pos bytes)
 432         (declare (optimize speed (safety 0))
 433                  (type ,type array)
 434                  (type array-range pos)
 435                  (type (integer 1 4) bytes))
 436         ;; Use SAP-REF-32BE even if it is not optimized
 437         (let ((code ,(if (and (eq accessor 'sap-ref-8)
 438                               (eq type 'system-area-pointer))
 439                          '(sap-ref-32be array pos)
 440                          `(flet ((cref (x)
 441                                    (,accessor array (the array-range (+ pos x)))))
 442                             (declare (inline cref))
 443                             (dpb (cref 0) (byte 8 24)
 444                                  (dpb (cref 1) (byte 8 16)
 445                                       (dpb (cref 2) (byte 8 8) (cref 3))))))))
 446           (if (and (< code char-code-limit)
 447                    (not (utf-noncharacter-code-p code)))
 448               (code-char code)
 449               (decoding-error array pos (+ pos bytes) :utf-32be
 450                               'octet-decoding-error pos)))))))
 451
 452 (instantiate-octets-definition define-simple-get-utf32-character)
 453
 454 (defmacro define-utf-32->string (accessor type)
 455   (let ((name-le (make-od-name 'utf-32le->string accessor))
 456         (name-be (make-od-name 'utf-32be->string accessor)))
 457     `(progn
 458       (defun ,name-le (array astart aend)
 459         (declare (optimize speed (safety 0))
 460                  (type ,type array)
 461                  (type array-range astart aend))
 462         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 463           (loop with pos = astart
 464                 while (< pos aend)
 465                 do (multiple-value-bind (bytes invalid)
 466                        (,(make-od-name 'bytes-per-utf-32le-character accessor) array pos aend)
 467                      (declare (type (or null string) invalid))
 468                      (aver (null invalid))
 469                      (let ((thing (,(make-od-name 'simple-get-utf-32le-char accessor) array pos bytes)))
 470                        (typecase thing
 471                          (character (vector-push-extend thing string))
 472                          (string (dotimes (i (length thing))
 473                                    (vector-push-extend (char thing i) string)))))
 474                      (incf pos bytes)))
 475           string))
 476       (defun ,name-be (array astart aend)
 477         (declare (optimize speed (safety 0))
 478                  (type ,type array)
 479                  (type array-range astart aend))
 480         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 481           (loop with pos = astart
 482                 while (< pos aend)
 483                 do (multiple-value-bind (bytes invalid)
 484                        (,(make-od-name 'bytes-per-utf-32be-character accessor) array pos aend)
 485                      (declare (type (or null string) invalid))
 486                      (aver (null invalid))
 487                      (let ((thing (,(make-od-name 'simple-get-utf-32be-char accessor) array pos bytes)))
 488                        (typecase thing
 489                          (character (vector-push-extend thing string))
 490                          (string (dotimes (i (length thing))
 491                                    (vector-push-extend (char thing i) string)))))
 492                      (incf pos bytes)))
 493           string)))))
 494
 495 (instantiate-octets-definition define-utf-32->string)
 496
 497 (define-external-format/variable-width (:utf-32le :utf32le) t
 498   (code-char #xfffd)
 499   4
 500   (if (utf-noncharacter-code-p bits)
 501       (external-format-encoding-error stream bits)
 502       (setf (sap-ref-32le sap tail) bits))
 503   4
 504   (let ((code (sap-ref-32le sap head)))
 505     (if (and (< code char-code-limit)
 506              (not (utf-noncharacter-code-p code)))
 507         (code-char code)
 508         (return-from decode-break-reason 4)))
 509   utf-32le->string-aref
 510   string->utf-32le)
 511
 512 (define-external-format/variable-width (:utf-32be :utf32be) t
 513   (code-char #xfffd)
 514   4
 515   (if (utf-noncharacter-code-p bits)
 516       (external-format-encoding-error stream bits)
 517       (setf (sap-ref-32be sap tail) bits))
 518   4
 519   (let ((code (sap-ref-32be sap head)))
 520     (if (and (< code char-code-limit)
 521              (not (utf-noncharacter-code-p code)))
 522         (code-char code)
 523         (return-from decode-break-reason 4)))
 524   utf-32be->string-aref
 525   string->utf-32be)