src/code/external-formats/mb-util.lisp

   1 (in-package "SB!IMPL")
   2
   3 (defmacro define-multibyte-mapper (name list)
   4   (let ((list (sort (copy-list list) #'< :key #'car))
   5         (hi (loop for x in list maximize (max (car x) (cadr x)))))
   6     `(defparameter ,name
   7        (make-array '(,(length list) 2)
   8                    :element-type '(integer 0 ,hi)
   9                    :initial-contents ',list))))
  10
  11 (defun get-multibyte-mapper (table code)
  12   (declare (optimize speed (safety 0))
  13            (type (array * (* 2)) table)
  14            (type fixnum code))
  15   (labels ((recur (start end)
  16              (declare (type fixnum start end))
  17              (let* ((m (ash (+ start end) -1))
  18                     (x (aref table m 0)))
  19                (declare (type fixnum m x))
  20                (cond ((= x code)
  21                       (aref table m 1))
  22                      ((and (< x code) (< m end))
  23                       (recur (1+ m) end))
  24                      ((and (> x code) (> m start))
  25                       (recur start (1- m)))))))
  26     (recur 0 (1- (array-dimension table 0)))))
  27
  28 (eval-when (:compile-toplevel :load-toplevel :execute)
  29   ;; FIXME: better to change make-od-name() to accept multiple
  30   ;; arguments in octets.lisp?
  31   (defun make-od-name-list (&rest syms)
  32     (reduce #'make-od-name syms))
  33
  34   (defun define-bytes-per-mb-character-1 (accessor type format
  35                                           mb-len mb-continuation-byte-p)
  36     (let ((name (make-od-name-list 'bytes-per format 'character accessor))
  37           (invalid-mb-starter-byte
  38            (make-od-name-list 'invalid format 'starter-byte))
  39           (invalid-mb-continuation-byte
  40            (make-od-name-list 'invalid format 'continuation-byte)))
  41       `(progn
  42          ;;(declaim (inline ,name))
  43          (defun ,name (array pos end)
  44            (declare (optimize speed (safety 0))
  45                     (type ,type array)
  46                     (type array-range pos end))
  47            ;; returns the number of bytes consumed and nil if it's a
  48            ;; valid character or the number of bytes consumed and a
  49            ;; replacement string if it's not.
  50            (let ((initial-byte (,accessor array pos))
  51                  (reject-reason nil)
  52                  (reject-position pos)
  53                  (remaining-bytes (- end pos)))
  54              (declare (type array-range reject-position remaining-bytes))
  55              (labels ((valid-starter-byte-p (b)
  56                         (declare (type (unsigned-byte 8) b))
  57                         (let ((ok (,mb-len b)))
  58                           (unless ok
  59                             (setf reject-reason ',invalid-mb-starter-byte))
  60                           ok))
  61                       (enough-bytes-left-p (x)
  62                         (let ((ok (> end (+ pos (1- x)))))
  63                           (unless ok
  64                             (setf reject-reason 'end-of-input-in-character))
  65                           ok))
  66                       (valid-secondary-p (x)
  67                         (let* ((idx (the array-range (+ pos x)))
  68                                (b (,accessor array idx))
  69                                (ok (,mb-continuation-byte-p b)))
  70                           (unless ok
  71                             (setf reject-reason ',invalid-mb-continuation-byte)
  72                             (setf reject-position idx))
  73                           ok))
  74                       (preliminary-ok-for-length (maybe-len len)
  75                         (and (eql maybe-len len)
  76                              ;; Has to be done in this order so that
  77                              ;; certain broken sequences (e.g., the
  78                              ;; two-byte sequence `"initial (length 3)"
  79                              ;; "non-continuation"' -- `#xef #x32')
  80                              ;; signal only part of that sequence as
  81                              ;; erroneous.
  82                              (loop for i from 1 below (min len remaining-bytes)
  83                                 always (valid-secondary-p i))
  84                              (enough-bytes-left-p len))))
  85                (declare (inline valid-starter-byte-p
  86                                 enough-bytes-left-p
  87                                 valid-secondary-p
  88                                 preliminary-ok-for-length))
  89                (let ((maybe-len (valid-starter-byte-p initial-byte)))
  90                  (cond ((eql maybe-len 1)
  91                         (values 1 nil))
  92                        ((preliminary-ok-for-length maybe-len 2)
  93                         (values 2 nil))
  94                        ((preliminary-ok-for-length maybe-len 3)
  95                         (values 3 nil))
  96                        (t
  97                         (let* ((bad-end (ecase reject-reason
  98                                           (,invalid-mb-starter-byte
  99                                            (1+ pos))
 100                                           (end-of-input-in-character
 101                                            end)
 102                                           (,invalid-mb-continuation-byte
 103                                            reject-position)))
 104                                (bad-len (- bad-end pos)))
 105                           (declare (type array-range bad-end bad-len))
 106                           (let ((replacement (decoding-error array pos bad-end ,format reject-reason reject-position)))
 107                             (values bad-len replacement))))))))))))
 108
 109   (defun define-simple-get-mb-char-1 (accessor type format mb-to-ucs)
 110     (let ((name (make-od-name-list 'simple-get format 'char accessor))
 111           (malformed (make-od-name 'malformed format)))
 112       `(progn
 113          (declaim (inline ,name))
 114          (defun ,name (array pos bytes)
 115            (declare (optimize speed (safety 0))
 116                     (type ,type array)
 117                     (type array-range pos)
 118                     (type (integer 1 3) bytes))
 119            (flet ((cref (x)
 120                     (,accessor array (the array-range (+ pos x)))))
 121              (declare (inline cref))
 122              (let ((code (,mb-to-ucs (ecase bytes
 123                                        (1 (cref 0))
 124                                        (2 (logior (ash (cref 0) 8) (cref 1)))
 125                                        (3 (logior (ash (cref 0) 16)
 126                                                   (ash (cref 1) 8)
 127                                                   (cref 2)))))))
 128                (if code
 129                    (code-char code)
 130                    (decoding-error array pos (+ pos bytes) ,format
 131                                    ',malformed pos))))))))
 132
 133   (defun define-mb->string-1 (accessor type format)
 134     (let ((name
 135            (make-od-name-list format '>string accessor))
 136           (bytes-per-mb-character
 137            (make-od-name-list 'bytes-per format 'character accessor))
 138           (simple-get-mb-char
 139            (make-od-name-list 'simple-get format 'char accessor)))
 140       `(progn
 141          (defun ,name (array astart aend)
 142            (declare (optimize speed (safety 0))
 143                     (type ,type array)
 144                     (type array-range astart aend))
 145            (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 146              (loop with pos = astart
 147                 while (< pos aend)
 148                 do (multiple-value-bind (bytes invalid)
 149                        (,bytes-per-mb-character array pos aend)
 150                      (declare (type (or null string) invalid))
 151                      (cond
 152                        ((null invalid)
 153                         (let ((thing (,simple-get-mb-char array pos bytes)))
 154                           (typecase thing
 155                             (character (vector-push-extend thing string))
 156                             (string
 157                                (dotimes (i (length thing))
 158                                  (vector-push-extend (char thing i) string))))))
 159                        (t
 160                         (dotimes (i (length invalid))
 161                           (vector-push-extend (char invalid i) string))))
 162                      (incf pos bytes)))
 163              (coerce string 'simple-string))))))
 164
 165   (declaim (inline mb-char-len))
 166   (defun mb-char-len (code)
 167     (declare (optimize speed (safety 0))
 168              (type fixnum code))
 169     (cond ((< code 0) (bug "can't happen"))
 170           ((< code #x100) 1)
 171           ((< code #x10000) 2)
 172           ((< code #x1000000) 3)
 173           (t (bug "can't happen"))))
 174   )
 175
 176 (defmacro define-multibyte-encoding (format aliases
 177                                      ucs-to-mb mb-to-ucs
 178                                      mb-len mb-continuation-byte-p)
 179   (let ((char->mb (make-od-name 'char-> format))
 180         (string->mb (make-od-name 'string-> format))
 181         (define-bytes-per-mb-character
 182          (make-od-name-list 'define-bytes-per format 'character))
 183         (define-simple-get-mb-char
 184          (make-od-name-list 'define-simple-get format 'char))
 185         (define-mb->string
 186          (make-od-name-list 'define format '>string)))
 187     `(progn
 188        ;; for octets.lisp
 189        (define-condition ,(make-od-name 'malformed format)
 190            (octet-decoding-error) ())
 191        (define-condition ,(make-od-name-list 'invalid format 'starter-byte)
 192            (octet-decoding-error) ())
 193        (define-condition ,(make-od-name-list 'invalid format 'continuation-byte)
 194            (octet-decoding-error) ())
 195
 196        (declaim (inline ,char->mb))
 197        (defun ,char->mb (char dest string pos)
 198          (declare (optimize speed (safety 0))
 199                   (type (array (unsigned-byte 8) (*)) dest))
 200          (let ((code (,ucs-to-mb (char-code char))))
 201            (if code
 202                (flet ((add-byte (b)
 203                         (declare (type (unsigned-byte 8) b))
 204                         (vector-push-extend b dest)))
 205                  (declare (inline add-byte))
 206                  (setf code (the fixnum code))
 207                  (ecase (mb-char-len code)
 208                    (1
 209                     (add-byte code))
 210                    (2
 211                     (add-byte (ldb (byte 8 8) code))
 212                     (add-byte (ldb (byte 8 0) code)))
 213                    (3
 214                     (add-byte (ldb (byte 8 16) code))
 215                     (add-byte (ldb (byte 8 8) code))
 216                     (add-byte (ldb (byte 8 0) code)))))
 217                (encoding-error ,format string pos))))
 218
 219        (defun ,string->mb (string sstart send additional-space)
 220          (declare (optimize speed (safety 0))
 221                   (type simple-string string)
 222                   (type array-range sstart send additional-space))
 223          (let ((array (make-array (+ additional-space (- send sstart))
 224                                   :element-type '(unsigned-byte 8)
 225                                   :adjustable t
 226                                   :fill-pointer 0)))
 227            (loop for i from sstart below send
 228               do (,char->mb (char string i) array string i))
 229            (dotimes (i additional-space)
 230              (vector-push-extend 0 array))
 231            (coerce array '(simple-array (unsigned-byte 8) (*)))))
 232
 233        (defmacro ,define-bytes-per-mb-character (accessor type)
 234          (define-bytes-per-mb-character-1 accessor type ',format
 235                                           ',mb-len ',mb-continuation-byte-p))
 236
 237        (instantiate-octets-definition ,define-bytes-per-mb-character)
 238
 239        (defmacro ,define-simple-get-mb-char (accessor type)
 240          (define-simple-get-mb-char-1 accessor type ',format ',mb-to-ucs))
 241
 242        (instantiate-octets-definition ,define-simple-get-mb-char)
 243
 244        (defmacro ,define-mb->string (accessor type)
 245          (define-mb->string-1 accessor type ',format))
 246
 247        (instantiate-octets-definition ,define-mb->string)
 248
 249        ;; for fd-stream.lisp
 250        (define-external-format/variable-width ,aliases t
 251          ;; KLUDGE: it so happens that at present (2009-10-22) none of
 252          ;; the external formats defined with
 253          ;; define-multibyte-encoding can encode the unicode
 254          ;; replacement character, so we hardcode the preferred
 255          ;; replacement here.
 256          #\?
 257          (block size
 258            (mb-char-len (or (,ucs-to-mb (char-code byte))
 259                             (return-from size 0))))
 260          (let ((mb (,ucs-to-mb bits)))
 261            (if (null mb)
 262                (external-format-encoding-error stream byte)
 263                (ecase size
 264                  (1 (setf (sap-ref-8 sap tail) mb))
 265                  (2 (setf (sap-ref-8 sap tail) (ldb (byte 8 8) mb)
 266                           (sap-ref-8 sap (1+ tail)) (ldb (byte 8 0) mb)))
 267                  (3 (setf (sap-ref-8 sap tail) (ldb (byte 8 16) mb)
 268                           (sap-ref-8 sap (1+ tail)) (ldb (byte 8 8) mb)
 269                           (sap-ref-8 sap (+ 2 tail)) (ldb (byte 8 0) mb))))))
 270          (1 (,mb-len byte))
 271          (let* ((mb (ecase size
 272                       (1 byte)
 273                       (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
 274                            (unless (,mb-continuation-byte-p byte2)
 275                              (return-from decode-break-reason 2))
 276                            (dpb byte (byte 8 8) byte2)))
 277                       (3 (let ((byte2 (sap-ref-8 sap (1+ head)))
 278                                (byte3 (sap-ref-8 sap (+ 2 head))))
 279                            (unless (,mb-continuation-byte-p byte2)
 280                              (return-from decode-break-reason 2))
 281                            (unless (,mb-continuation-byte-p byte3)
 282                              (return-from decode-break-reason 3))
 283                            (dpb byte (byte 8 16) (dpb byte2 (byte 8 8) byte3))))))
 284                 (ucs (,mb-to-ucs mb)))
 285            (if (null ucs)
 286                (return-from decode-break-reason 1)
 287                (code-char ucs)))
 288          ,(make-od-name format '>string-aref)
 289          ,string->mb))))