src/code/octets.lisp

   1 ;;;; code for string to octet conversion
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 ;;; FIXME: The latin9 stuff is currently #!+sb-unicode, because I
  13 ;;; don't like the idea of trying to do CODE-CHAR #x<big>.  Is that a
  14 ;;; justified fear?  Can we arrange that it's caught and converted to
  15 ;;; a decoding error error?  Or should we just give up on non-Unicode
  16 ;;; builds?
  17
  18 (in-package "SB!IMPL")
  19
  20 ;;; FIXME: don't we have this somewhere else?
  21 (deftype array-range ()
  22   "A number that can represent an index into a vector, including
  23 one-past-the-end"
  24   '(integer 0 #.sb!xc:array-dimension-limit))
  25 \f
  26 ;;;; conditions
  27
  28 ;;; encoding condition
  29
  30 (define-condition octets-encoding-error (character-encoding-error)
  31   ((string :initarg :string :reader octets-encoding-error-string)
  32    (position :initarg :position :reader octets-encoding-error-position)
  33    (external-format :initarg :external-format
  34                     :reader octets-encoding-error-external-format))
  35   (:report (lambda (c s)
  36              (format s "Unable to encode character ~A as ~S."
  37                      (char-code (char (octets-encoding-error-string c)
  38                                       (octets-encoding-error-position c)))
  39                      (octets-encoding-error-external-format c)))))
  40
  41 (defun read-replacement-character ()
  42   (format *query-io*
  43           "Replacement byte, bytes, character, or string (evaluated): ")
  44   (finish-output *query-io*)
  45   (list (eval (read *query-io*))))
  46
  47 (defun encoding-error (external-format string pos)
  48   (restart-case
  49       (error 'octets-encoding-error
  50              :external-format external-format
  51              :string string
  52              :position pos)
  53     (use-value (replacement)
  54       :report "Supply a set of bytes to use in place of the invalid one."
  55       :interactive read-replacement-character
  56       (typecase replacement
  57         ((unsigned-byte 8)
  58          (make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement))
  59         (character
  60          (string-to-octets (string replacement)
  61                            :external-format external-format))
  62         (string
  63          (string-to-octets replacement
  64                            :external-format external-format))
  65         (t
  66          (coerce replacement '(simple-array (unsigned-byte 8) (*))))))))
  67
  68 ;;; decoding condition
  69
  70 ;;; for UTF8, the specific condition signalled will be a generalized
  71 ;;; instance of one of the following:
  72 ;;;
  73 ;;;   end-of-input-in-character
  74 ;;;   character-out-of-range
  75 ;;;   invalid-utf8-starter-byte
  76 ;;;   invalid-utf8-continuation-byte
  77 ;;;   overlong-utf8-sequence
  78 ;;;
  79 ;;; Of these, the only one truly likely to be of interest to calling
  80 ;;; code is end-of-input-in-character (in which case it's likely to
  81 ;;; want to make a note of octet-decoding-error-start, supply "" as a
  82 ;;; replacement string, and then move that last chunk of bytes to the
  83 ;;; beginning of its buffer for the next go round) but they're all
  84 ;;; provided on the off chance they're of interest.  The next most
  85 ;;; likely interesting option is overlong-utf8-sequence -- the
  86 ;;; application, if it cares to, can decode this itself (taking care
  87 ;;; to ensure that the result isn't out of range of CHAR-CODE-LIMIT)
  88 ;;; and return that result.  This library doesn't provide support for
  89 ;;; that as a conforming UTF-8-using program is supposed to treat it
  90 ;;; as an error.
  91
  92 (define-condition octet-decoding-error (character-decoding-error)
  93   ((array :initarg :array :accessor octet-decoding-error-array)
  94    (start :initarg :start :accessor octet-decoding-error-start)
  95    (end :initarg :end :accessor octet-decoding-error-end)
  96    (position :initarg :pos :accessor octet-decoding-bad-byte-position)
  97    (external-format :initarg :external-format
  98                     :accessor octet-decoding-error-external-format))
  99   (:report
 100    (lambda (condition stream)
 101      (format stream "Illegal ~S character starting at byte position ~D."
 102              (octet-decoding-error-external-format condition)
 103              (octet-decoding-error-start condition)))))
 104
 105 (define-condition end-of-input-in-character (octet-decoding-error) ())
 106 (define-condition character-out-of-range (octet-decoding-error) ())
 107 (define-condition invalid-utf8-starter-byte (octet-decoding-error) ())
 108 (define-condition invalid-utf8-continuation-byte (octet-decoding-error) ())
 109 (define-condition overlong-utf8-sequence (octet-decoding-error) ())
 110
 111 (define-condition malformed-ascii (octet-decoding-error) ())
 112
 113 (defun read-replacement-string ()
 114   (format *query-io* "Enter a replacement string designator (evaluated): ")
 115   (finish-output *query-io*)
 116   (list (eval (read *query-io*))))
 117
 118 (defun decoding-error (array start end external-format reason pos)
 119   (restart-case
 120       (error reason
 121              :external-format external-format
 122              :array array
 123              :start start
 124              :end end
 125              :pos pos)
 126     (use-value (s)
 127       :report "Supply a replacement string designator."
 128       :interactive read-replacement-string
 129       (string s))))
 130
 131 ;;; Utilities used in both to-string and to-octet conversions
 132
 133 (defmacro instantiate-octets-definition (definer)
 134   `(progn
 135     (,definer aref (simple-array (unsigned-byte 8) (*)))
 136     (,definer sap-ref-8 system-area-pointer)))
 137
 138 ;;; maps into TO-SEQ from elements of FROM-SEQ via MAPPER.  MAPPER
 139 ;;; returns two values: the number of elments stored in TO-SEQ, and
 140 ;;; the number used up from FROM-SEQ.  MAPPER is responsible for
 141 ;;; getting out if either sequence runs out of room.
 142 (declaim (inline varimap))
 143 (defun varimap (to-seq to-start to-end from-start from-end mapper)
 144   (declare (optimize speed (safety 0))
 145            (type array-range to-start to-end from-start from-end)
 146            (type function mapper))
 147   (loop with from-size of-type array-range = 0
 148         and to-size of-type array-range = 0
 149         for to-pos of-type array-range = to-start then (+ to-pos to-size)
 150         for from-pos of-type array-range = from-start then (+ from-pos from-size)
 151         while (and (< to-pos to-end)
 152                    (< from-pos from-end))
 153         do (multiple-value-bind (ts fs) (funcall mapper to-pos from-pos)
 154              (setf to-size ts
 155                    from-size fs))
 156         finally (return (values to-seq to-pos from-pos))))
 157
 158 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
 159 ;;; and fix it, or else replace with SYMBOLICATE.
 160 ;;;
 161 ;;; FIXME: this is cute, but is going to prevent greps for def.*<name>
 162 ;;; from working for (defun ,(make-od-name ...) ...)
 163 (eval-when (:compile-toplevel :load-toplevel :execute)
 164   (defun make-od-name (sym1 sym2)
 165     ;; "MAKE-NAME" is too generic, but this doesn't do quite what
 166     ;; SYMBOLICATE does; MAKE-OD-NAME ("octets definition") it is
 167     ;; then.
 168     (intern (concatenate 'string (symbol-name sym1) "-" (symbol-name sym2))
 169             (symbol-package sym1))))
 170 \f
 171 ;;;; to-octets conversions
 172
 173 ;;; to latin (including ascii)
 174
 175 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
 176   `(progn
 177     (declaim (inline ,byte-char-name))
 178     (defun ,byte-char-name (byte)
 179       (declare (optimize speed (safety 0))
 180                (type (unsigned-byte 8) byte))
 181       (aref ,(make-array 256
 182                          :initial-contents (loop for byte below 256
 183                                                  collect
 184                                                   (let ((exception (cadr (assoc byte exceptions))))
 185                                                     (if exception
 186                                                         exception
 187                                                         byte))))
 188             byte))
 189     ;; This used to be inlined, but it caused huge slowdowns in SBCL builds,
 190     ;; bloated the core by about 700k on x86-64. Removing the inlining
 191     ;; didn't seem to have any performance effect. -- JES, 2005-10-15
 192     (defun ,code-byte-name (code)
 193       (declare (optimize speed (safety 0))
 194                (type char-code code))
 195       ;; FIXME: I'm not convinced doing this with CASE is a good idea as
 196       ;; long as it's just macroexpanded into a stupid COND. Consider
 197       ;; for example the output of (DISASSEMBLE 'SB-IMPL::CODE->CP1250-MAPPER)
 198       ;; -- JES, 2005-10-15
 199       (case code
 200         ,@(mapcar (lambda (exception)
 201                     (destructuring-bind (byte code) exception
 202                       `(,code ,byte)))
 203                   exceptions)
 204         (,(mapcar #'car exceptions) nil)
 205         (otherwise (if (< code 256) code nil))))))
 206
 207 #!+sb-unicode
 208 (define-unibyte-mapper
 209     latin9->code-mapper
 210     code->latin9-mapper
 211   (#xA4 #x20AC)
 212   (#xA6 #x0160)
 213   (#xA8 #x0161)
 214   (#xB4 #x017D)
 215   (#xB8 #x017E)
 216   (#xBC #x0152)
 217   (#xBD #x0153)
 218   (#xBE #x0178))
 219
 220 (declaim (inline get-latin-bytes))
 221 (defun get-latin-bytes (mapper external-format string pos end)
 222   (declare (ignore end))
 223   (let ((code (funcall mapper (char-code (char string pos)))))
 224     (values (cond
 225               ((and code (< code 256)) code)
 226               (t
 227                (encoding-error external-format string pos)))
 228             1)))
 229
 230 (declaim (inline code->ascii-mapper))
 231 (defun code->ascii-mapper (code)
 232   (declare (optimize speed (safety 0))
 233            (type char-code code))
 234   (if (> code 127)
 235       nil
 236       code))
 237
 238 (declaim (inline get-ascii-bytes))
 239 (defun get-ascii-bytes (string pos end)
 240   (declare (optimize speed (safety 0))
 241            (type simple-string string)
 242            (type array-range pos end))
 243   (get-latin-bytes #'code->ascii-mapper :ascii string pos end))
 244
 245 (declaim (inline get-latin1-bytes))
 246 (defun get-latin1-bytes (string pos end)
 247   (declare (optimize speed (safety 0))
 248            (type simple-string string)
 249            (type array-range pos end))
 250   (get-latin-bytes #'identity :latin-1 string pos end))
 251
 252 #!+sb-unicode
 253 (progn
 254   (declaim (inline get-latin9-bytes))
 255   (defun get-latin9-bytes (string pos end)
 256     (declare (optimize speed (safety 0))
 257              (type simple-string string)
 258              (type array-range pos end))
 259     (get-latin-bytes #'code->latin9-mapper :latin-9 string pos end)))
 260
 261 (declaim (inline string->latin%))
 262 (defun string->latin% (string sstart send get-bytes null-padding)
 263   (declare (optimize speed)
 264            (type simple-string string)
 265            (type array-range sstart send null-padding)
 266            (type function get-bytes))
 267   (let ((octets (make-array 0 :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8))))
 268     (loop for pos from sstart below send
 269           do (let ((byte-or-bytes (funcall get-bytes string pos send)))
 270                (declare (type (or (unsigned-byte 8) (simple-array (unsigned-byte 8) (*))) byte-or-bytes))
 271                (cond
 272                  ((numberp byte-or-bytes)
 273                   (vector-push-extend byte-or-bytes octets))
 274                  (t
 275                   (dotimes (i (length byte-or-bytes))
 276                     (vector-push-extend (aref byte-or-bytes i) octets))))))
 277     (dotimes (i null-padding)
 278       (vector-push-extend 0 octets))
 279     (coerce octets '(simple-array (unsigned-byte 8) (*)))))
 280
 281 (defun string->ascii (string sstart send null-padding)
 282   (declare (optimize speed (safety 0))
 283            (type simple-string string)
 284            (type array-range sstart send))
 285   (values (string->latin% string sstart send #'get-ascii-bytes null-padding)))
 286
 287 (defun string->latin1 (string sstart send null-padding)
 288   (declare (optimize speed (safety 0))
 289            (type simple-string string)
 290            (type array-range sstart send))
 291   (values (string->latin% string sstart send #'get-latin1-bytes null-padding)))
 292
 293 #!+sb-unicode
 294 (defun string->latin9 (string sstart send null-padding)
 295   (declare (optimize speed (safety 0))
 296            (type simple-string string)
 297            (type array-range sstart send))
 298   (values (string->latin% string sstart send #'get-latin9-bytes null-padding)))
 299
 300 ;;; to utf8
 301
 302 (declaim (inline char-len-as-utf8))
 303 (defun char-len-as-utf8 (code)
 304   (declare (optimize speed (safety 0))
 305            (type (integer 0 (#.sb!xc:char-code-limit)) code))
 306   (cond ((< code 0) (bug "can't happen"))
 307         ((< code #x80) 1)
 308         ((< code #x800) 2)
 309         ((< code #x10000) 3)
 310         ((< code #x110000) 4)
 311         (t (bug "can't happen"))))
 312
 313 (declaim (inline char->utf8))
 314 (defun char->utf8 (char dest)
 315   (declare (optimize speed (safety 0))
 316            (type (array (unsigned-byte 8) (*)) dest))
 317   (let ((code (char-code char)))
 318     (flet ((add-byte (b)
 319              (declare (type (unsigned-byte 8) b))
 320              (vector-push-extend b dest)))
 321       (declare (inline add-byte))
 322       (ecase (char-len-as-utf8 code)
 323         (1
 324          (add-byte code))
 325         (2
 326          (add-byte (logior #b11000000 (ldb (byte 5 6) code)))
 327          (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
 328         (3
 329          (add-byte (logior #b11100000 (ldb (byte 4 12) code)))
 330          (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
 331          (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
 332         (4
 333          (add-byte (logior #b11110000 (ldb (byte 3 18) code)))
 334          (add-byte (logior #b10000000 (ldb (byte 6 12) code)))
 335          (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
 336          (add-byte (logior #b10000000 (ldb (byte 6 0) code))))))))
 337
 338 (defun string->utf8 (string sstart send additional-space)
 339   (declare (optimize speed (safety 0))
 340            (type simple-string string)
 341            (type array-range sstart send additional-space))
 342   (let ((array (make-array (+ additional-space (- send sstart))
 343                            :element-type '(unsigned-byte 8)
 344                            :adjustable t
 345                            :fill-pointer 0)))
 346     (loop for i from sstart below send
 347           do (char->utf8 (char string i) array))
 348     (dotimes (i additional-space)
 349       (vector-push-extend 0 array))
 350     (coerce array '(simple-array (unsigned-byte 8) (*)))))
 351 \f
 352 ;;;; to-string conversions
 353
 354 ;;; from latin (including ascii)
 355
 356 (defmacro define-ascii->string (accessor type)
 357   (let ((name (make-od-name 'ascii->string accessor)))
 358     `(progn
 359       (defun ,name (array astart aend)
 360         (declare (optimize speed)
 361                  (type ,type array)
 362                  (type array-range astart aend))
 363         ;; Since there is such a thing as a malformed ascii byte, a
 364         ;; simple "make the string, fill it in" won't do.
 365         (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
 366           (loop for apos from astart below aend
 367                 do (let* ((code (,accessor array apos))
 368                           (string-content
 369                            (if (< code 128)
 370                                (code-char code)
 371                                (decoding-error array apos (1+ apos) :ascii
 372                                                'malformed-ascii apos))))
 373                      (if (characterp string-content)
 374                          (vector-push-extend string-content string)
 375                          (loop for c across string-content
 376                                do (vector-push-extend c string))))
 377                 finally (return (coerce string 'simple-string))))))))
 378 (instantiate-octets-definition define-ascii->string)
 379
 380 (defmacro define-latin->string* (accessor type)
 381   (let ((name (make-od-name 'latin->string* accessor)))
 382     `(progn
 383       (declaim (inline ,name))
 384       (defun ,name (string sstart send array astart aend mapper)
 385         (declare (optimize speed (safety 0))
 386                  (type simple-string string)
 387                  (type ,type array)
 388                  (type array-range sstart send astart aend)
 389                  (function mapper))
 390         (varimap string sstart send
 391                  astart aend
 392                  (lambda (spos apos)
 393                    (setf (char string spos) (code-char (funcall mapper (,accessor array apos))))
 394                    (values 1 1)))))))
 395 (instantiate-octets-definition define-latin->string*)
 396
 397 (defmacro define-latin1->string* (accessor type)
 398   (declare (ignore type))
 399   (let ((name (make-od-name 'latin1->string* accessor)))
 400     `(progn
 401       (defun ,name (string sstart send array astart aend)
 402         (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity)))))
 403 (instantiate-octets-definition define-latin1->string*)
 404
 405 #!+sb-unicode
 406 (progn
 407   (defmacro define-latin9->string* (accessor type)
 408     (declare (ignore type))
 409     (let ((name (make-od-name 'latin9->string* accessor)))
 410       `(progn
 411         (defun ,name (string sstart send array astart aend)
 412           (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'latin9->code-mapper)))))
 413   (instantiate-octets-definition define-latin9->string*))
 414
 415 (defmacro define-latin->string (accessor type)
 416   (let ((name (make-od-name 'latin->string accessor)))
 417     `(progn
 418       (declaim (inline latin->string))
 419       (defun ,name (array astart aend mapper)
 420         (declare (optimize speed (safety 0))
 421                  (type ,type array)
 422                  (type array-range astart aend)
 423                  (type function mapper))
 424         (let ((length (the array-range (- aend astart))))
 425           (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
 426                                                             array astart aend
 427                                                             mapper)))))))
 428 (instantiate-octets-definition define-latin->string)
 429
 430 (defmacro define-latin1->string (accessor type)
 431   (declare (ignore type))
 432   `(defun ,(make-od-name 'latin1->string accessor) (array astart aend)
 433     (,(make-od-name 'latin->string accessor) array astart aend #'identity)))
 434 (instantiate-octets-definition define-latin1->string)
 435
 436 #!+sb-unicode
 437 (progn
 438   (defmacro define-latin9->string (accessor type)
 439     (declare (ignore type))
 440     `(defun ,(make-od-name 'latin9->string accessor) (array astart aend)
 441       (,(make-od-name 'latin->string accessor) array astart aend #'latin9->code-mapper)))
 442   (instantiate-octets-definition define-latin9->string))
 443
 444 ;;; from utf8
 445
 446 (defmacro define-bytes-per-utf8-character (accessor type)
 447   (let ((name (make-od-name 'bytes-per-utf8-character accessor)))
 448     `(progn
 449       ;;(declaim (inline ,name))
 450       (let ((lexically-max
 451              (string->utf8 (string (code-char ,(1- sb!xc:char-code-limit)))
 452                            0 1 0)))
 453         (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max))
 454         (defun ,name (array pos end)
 455           (declare (optimize speed (safety 0))
 456                    (type ,type array)
 457                    (type array-range pos end))
 458           ;; returns the number of bytes consumed and nil if it's a
 459           ;; valid character or the number of bytes consumed and a
 460           ;; replacement string if it's not.
 461           (let ((initial-byte (,accessor array pos))
 462                 (reject-reason nil)
 463                 (reject-position pos)
 464                 (remaining-bytes (- end pos)))
 465             (declare (type array-range reject-position remaining-bytes))
 466             (labels ((valid-utf8-starter-byte-p (b)
 467                        (declare (type (unsigned-byte 8) b))
 468                        (let ((ok (cond
 469                                    ((zerop (logand b #b10000000)) 1)
 470                                    ((= (logand b #b11100000) #b11000000)
 471                                     2)
 472                                    ((= (logand b #b11110000) #b11100000)
 473                                     3)
 474                                    ((= (logand b #b11111000) #b11110000)
 475                                     4)
 476                                    ((= (logand b #b11111100) #b11111000)
 477                                     5)
 478                                    ((= (logand b #b11111110) #b11111100)
 479                                     6)
 480                                    (t
 481                                     nil))))
 482                          (unless ok
 483                            (setf reject-reason 'invalid-utf8-starter-byte))
 484                          ok))
 485                      (enough-bytes-left-p (x)
 486                        (let ((ok (> end (+ pos (1- x)))))
 487                          (unless ok
 488                            (setf reject-reason 'end-of-input-in-character))
 489                          ok))
 490                      (valid-secondary-p (x)
 491                        (let* ((idx (the array-range (+ pos x)))
 492                               (b (,accessor array idx))
 493                               (ok (= (logand b #b11000000) #b10000000)))
 494                          (unless ok
 495                            (setf reject-reason 'invalid-utf8-continuation-byte)
 496                            (setf reject-position idx))
 497                          ok))
 498                      (preliminary-ok-for-length (maybe-len len)
 499                        (and (eql maybe-len len)
 500                             ;; Has to be done in this order so that
 501                             ;; certain broken sequences (e.g., the
 502                             ;; two-byte sequence `"initial (length 3)"
 503                             ;; "non-continuation"' -- `#xef #x32')
 504                             ;; signal only part of that sequence as
 505                             ;; erronous.
 506                             (loop for i from 1 below (min len remaining-bytes)
 507                                   always (valid-secondary-p i))
 508                             (enough-bytes-left-p len)))
 509                      (overlong-chk (x y)
 510                        (let ((ok (or (/= initial-byte x)
 511                                      (/= (logior (,accessor array (the array-range (+ pos 1)))
 512                                                  y)
 513                                          y))))
 514                          (unless ok
 515                            (setf reject-reason 'overlong-utf8-sequence))
 516                          ok))
 517                      (character-below-char-code-limit-p ()
 518                        ;; This is only called on a four-byte sequence
 519                        ;; (two in non-unicode builds) to ensure we
 520                        ;; don't go over SBCL's character limts.
 521                        (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos))
 522                                         nil)
 523                                        ((> (aref lexically-max 0) (,accessor array pos))
 524                                         t)
 525                                        ((< (aref lexically-max 1) (,accessor array (+ pos 1)))
 526                                         nil)
 527                                        #!+sb-unicode
 528                                        ((> (aref lexically-max 1) (,accessor array (+ pos 1)))
 529                                         t)
 530                                        #!+sb-unicode
 531                                        ((< (aref lexically-max 2) (,accessor array (+ pos 2)))
 532                                         nil)
 533                                        #!+sb-unicode
 534                                        ((> (aref lexically-max 2) (,accessor array (+ pos 2)))
 535                                         t)
 536                                        #!+sb-unicode
 537                                        ((< (aref lexically-max 3) (,accessor array (+ pos 3)))
 538                                         nil)
 539                                        (t t))))
 540                          (unless ok
 541                            (setf reject-reason 'character-out-of-range))
 542                          ok)))
 543               (declare (inline valid-utf8-starter-byte-p
 544                                enough-bytes-left-p
 545                                valid-secondary-p
 546                                preliminary-ok-for-length
 547                                overlong-chk))
 548               (let ((maybe-len (valid-utf8-starter-byte-p initial-byte)))
 549                 (cond ((eql maybe-len 1)
 550                        (values 1 nil))
 551                       ((and (preliminary-ok-for-length maybe-len 2)
 552                             (overlong-chk #b11000000 #b10111111)
 553                             (overlong-chk #b11000001 #b10111111)
 554                             #!-sb-unicode (character-below-char-code-limit-p))
 555                        (values 2 nil))
 556                       ((and (preliminary-ok-for-length maybe-len 3)
 557                             (overlong-chk #b11100000 #b10011111)
 558                             #!-sb-unicode (not (setf reject-reason 'character-out-of-range)))
 559                        (values 3 nil))
 560                       ((and (preliminary-ok-for-length maybe-len 4)
 561                             (overlong-chk #b11110000 #b10001111)
 562                             #!-sb-unicode (not (setf reject-reason 'character-out-of-range))
 563                             (character-below-char-code-limit-p))
 564                        (values 4 nil))
 565                       ((and (preliminary-ok-for-length maybe-len 5)
 566                             (overlong-chk #b11111000 #b10000111)
 567                             (not (setf reject-reason 'character-out-of-range)))
 568                        (bug "can't happen"))
 569                       ((and (preliminary-ok-for-length maybe-len 6)
 570                             (overlong-chk #b11111100 #b10000011)
 571                             (not (setf reject-reason 'character-out-of-range)))
 572                        (bug "can't happen"))
 573                       (t
 574                        (let* ((bad-end (ecase reject-reason
 575                                          (invalid-utf8-starter-byte
 576                                           (1+ pos))
 577                                          (end-of-input-in-character
 578                                           end)
 579                                          (invalid-utf8-continuation-byte
 580                                           reject-position)
 581                                          ((overlong-utf8-sequence character-out-of-range)
 582                                           (+ pos maybe-len))))
 583                               (bad-len (- bad-end pos)))
 584                          (declare (type array-range bad-end bad-len))
 585                          (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position)))
 586                            (values bad-len replacement)))))))))))))
 587 (instantiate-octets-definition define-bytes-per-utf8-character)
 588
 589 (defmacro define-simple-get-utf8-char (accessor type)
 590   (let ((name (make-od-name 'simple-get-utf8-char accessor)))
 591     `(progn
 592       (declaim (inline ,name))
 593       (defun ,name (array pos bytes)
 594         (declare (optimize speed (safety 0))
 595                  (type ,type array)
 596                  (type array-range pos)
 597                  (type (integer 1 4) bytes))
 598         (flet ((cref (x)
 599                  (,accessor array (the array-range (+ pos x)))))
 600           (declare (inline cref))
 601           (code-char (ecase bytes
 602                        (1 (cref 0))
 603                        (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6)
 604                                   (ldb (byte 6 0) (cref 1))))
 605                        (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12)
 606                                   (ash (ldb (byte 6 0) (cref 1)) 6)
 607                                   (ldb (byte 6 0) (cref 2))))
 608                        (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18)
 609                                   (ash (ldb (byte 6 0) (cref 1)) 12)
 610                                   (ash (ldb (byte 6 0) (cref 2)) 6)
 611                                   (ldb (byte 6 0) (cref 3)))))))))))
 612 (instantiate-octets-definition define-simple-get-utf8-char)
 613
 614 (defmacro define-utf8->string (accessor type)
 615   (let ((name (make-od-name 'utf8->string accessor)))
 616     `(progn
 617       (defun ,name (array astart aend)
 618         (declare (optimize speed (safety 0))
 619                  (type ,type array)
 620                  (type array-range astart aend))
 621         (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
 622           (loop with pos = astart
 623                 while (< pos aend)
 624                 do (multiple-value-bind (bytes invalid)
 625                        (,(make-od-name 'bytes-per-utf8-character accessor) array pos aend)
 626                      (declare (type (or null string) invalid))
 627                      (cond
 628                        ((null invalid)
 629                         (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor) array pos bytes) string))
 630                        (t
 631                         (dotimes (i (length invalid))
 632                           (vector-push-extend (char invalid i) string))))
 633                      (incf pos bytes)))
 634           (coerce string 'simple-string))))))
 635 (instantiate-octets-definition define-utf8->string)
 636 \f
 637 ;;;; external formats
 638
 639 (defvar *default-external-format* nil)
 640
 641 (defun default-external-format ()
 642   (or *default-external-format*
 643       (let ((external-format (intern (or (sb!alien:alien-funcall
 644                                           (extern-alien
 645                                            "nl_langinfo"
 646                                            (function c-string int))
 647                                           sb!unix:codeset)
 648                                          "LATIN-1")
 649                                      "KEYWORD")))
 650         (/show0 "cold-printing defaulted external-format:")
 651         #!+sb-show
 652         (cold-print external-format)
 653         (/show0 "matching to known aliases")
 654         (dolist (entry *external-formats*
 655                  (progn
 656                    (warn "Invalid external-format ~A; using LATIN-1"
 657                          external-format)
 658                    (setf external-format :latin-1)))
 659           (/show0 "cold printing known aliases:")
 660           #!+sb-show
 661           (dolist (alias (first entry)) (cold-print alias))
 662           (/show0 "done cold-printing known aliases")
 663           (when (member external-format (first entry))
 664             (/show0 "matched")
 665             (return)))
 666         (/show0 "/default external format ok")
 667         (setf *default-external-format* external-format))))
 668
 669 ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
 670 (defparameter *external-format-functions*
 671   '(((:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|)
 672      ascii->string-aref string->ascii)
 673     ((:latin1 :latin-1 :iso-8859-1 :iso8859-1)
 674      latin1->string-aref string->latin1)
 675     #!+sb-unicode
 676     ((:latin9 :latin-9 :iso-8859-15 :iso8859-15)
 677      latin9->string-aref string->latin9)
 678     ((:utf8 :utf-8)
 679      utf8->string-aref string->utf8)))
 680
 681 (defun external-formats-funs (external-format)
 682   (when (eql external-format :default)
 683     (setf external-format (default-external-format)))
 684   (or (cdr (find external-format (the list *external-format-functions*)
 685                  :test #'member
 686                  :key #'car))
 687       (error "Unknown external-format ~S" external-format)))
 688 \f
 689 ;;;; public interface
 690
 691 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
 692   (declare (type (vector (unsigned-byte 8)) vector))
 693   (with-array-data ((vector vector)
 694                     (start start)
 695                     (end (%check-vector-sequence-bounds vector start end)))
 696     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
 697     (funcall (symbol-function (first (external-formats-funs external-format)))
 698              vector start end)))
 699
 700 (defun string-to-octets (string &key (external-format :default)
 701                          (start 0) end null-terminate)
 702   (declare (type string string))
 703   (with-array-data ((string string)
 704                     (start start)
 705                     (end (%check-vector-sequence-bounds string start end)))
 706     (declare (type simple-string string))
 707     (funcall (symbol-function (second (external-formats-funs external-format)))
 708              string start end (if null-terminate 1 0))))
 709
 710 #!+sb-unicode
 711 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
 712 #!+sb-unicode
 713 (defun use-unicode-replacement-char (condition)
 714   (use-value +unicode-replacement-character+ condition))
 715
 716 ;;; Utilities that maybe should be exported
 717
 718 #!+sb-unicode
 719 (defmacro with-standard-replacement-character (&body body)
 720   `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
 721     ,@body))
 722
 723 (defmacro with-default-decoding-replacement ((c) &body body)
 724   (let ((cname (gensym)))
 725   `(let ((,cname ,c))
 726     (handler-bind
 727         ((octet-decoding-error (lambda (c)
 728                                  (use-value ,cname c))))
 729       ,@body))))