io.encodings/external-format.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   This code is free software; you can redistribute it and/or
   4 ;;   modify it under the terms of the version 2.1 of
   5 ;;   the GNU Lesser General Public License as published by
   6 ;;   the Free Software Foundation, as clarified by the
   7 ;;   preamble found here:
   8 ;;       http://opensource.franz.com/preamble.html
   9 ;;
  10 ;;   This program is distributed in the hope that it will be useful,
  11 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;   GNU General Public License for more details.
  14 ;;
  15 ;;   You should have received a copy of the GNU Lesser General
  16 ;;   Public License along with this library; if not, write to the
  17 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  18 ;;   Boston, MA 02110-1301, USA
  19
  20 (in-package :io.encodings)
  21
  22 (declaim (optimize (speed 0) (space 0) (safety 3) (debug 3)))
  23
  24 ;; Mostly taken from SBCL's sb-simple-streams contrib
  25 ;;; **********************************************************************
  26 ;;; This code was written by Paul Foley
  27 ;;;
  28
  29 ;;; Sbcl port by Rudi Schlatte.
  30 \f
  31 (define-condition octet-encoding-error (error)
  32   ((string :initarg :string :reader octets-encoding-error-string)
  33    (start :initarg :start :accessor octet-encoding-error-start)
  34    (end :initarg :end :accessor octet-encoding-error-end)
  35    (position :initarg :position :reader octets-encoding-error-position)
  36    (external-format :initarg :external-format
  37                     :reader octets-encoding-error-external-format))
  38   (:report (lambda (c s)
  39              (format s "Unable to encode character ~A as ~S."
  40                      (char-code (char (octets-encoding-error-string c)
  41                                       (octets-encoding-error-position c)))
  42                      (octets-encoding-error-external-format c)))))
  43
  44 (define-condition illegal-character (octet-encoding-error) ())
  45
  46
  47 (define-condition octet-decoding-error (error)
  48   ((array :initarg :array :accessor octet-decoding-error-array)
  49    (start :initarg :start :accessor octet-decoding-error-start)
  50    (end :initarg :end :accessor octet-decoding-error-end)
  51    (position :initarg :position :accessor octet-decoding-bad-byte-position)
  52    (external-format :initarg :external-format
  53                     :accessor octet-decoding-error-external-format))
  54   (:report
  55    (lambda (c s)
  56      (format s "Illegal ~A character starting at byte position ~D: ~A."
  57              (octet-decoding-error-external-format c)
  58              (octet-decoding-bad-byte-position c)
  59              (cffi:mem-aref (octet-decoding-error-array c) :uint8
  60                             (octet-decoding-bad-byte-position c))))))
  61
  62 (define-condition end-of-input-in-character (octet-decoding-error) ())
  63 (define-condition malformed-multibyte-sequence (octet-decoding-error) ())
  64 (define-condition invalid-starter-octet (malformed-multibyte-sequence) ())
  65 (define-condition invalid-continuation-octet (malformed-multibyte-sequence) ())
  66 (define-condition overlong-octet-sequence (malformed-multibyte-sequence) ())
  67 (define-condition illegal-code-point (octet-decoding-error) ())
  68 \f
  69 ;;;
  70 ;;;
  71 ;;; EXTERNAL-FORMAT
  72 ;;;
  73 ;;;
  74
  75 (deftype line-terminator ()
  76   '(member :unix :mac :dos))
  77
  78 (defvar *default-external-format* #+ucs-chars :utf-8
  79                                   #-ucs-chars :iso-8859-1)
  80 (eval-when (:compile-toplevel :load-toplevel :execute)
  81   (defvar *default-line-terminator* :unix))
  82
  83 (defvar *external-formats* (make-hash-table))
  84 (defvar *external-format-aliases* (make-hash-table))
  85 (defvar *external-format-list* nil)
  86
  87 (defstruct (external-format
  88              (:conc-name ef-)
  89              (:print-function %print-external-format)
  90              (:constructor %make-external-format (name
  91                                                   line-terminator
  92                                                   octet-size
  93                                                   octets-to-char
  94                                                   char-to-octets)))
  95   (name (missing-arg) :type keyword :read-only t)
  96   (line-terminator (missing-arg) :type keyword)
  97   (octets-to-char (missing-arg) :type function :read-only t)
  98   (char-to-octets (missing-arg) :type function :read-only t)
  99   (octet-size (missing-arg) :type real))
 100
 101 (defun %print-external-format (ef stream depth)
 102   (declare (ignore depth))
 103   (print-unreadable-object (ef stream :type t :identity nil)
 104     (format stream "~A ~S"
 105             (ef-name ef) (ef-line-terminator ef))))
 106
 107 (defun make-external-format (name &key new-name
 108                              (line-terminator *default-line-terminator*)
 109                              (octet-size 1.5))
 110   (check-type line-terminator line-terminator)
 111   (let ((ef (find-external-format name)))
 112     (%make-external-format
 113      (or new-name (ef-name ef))
 114      (or line-terminator (ef-line-terminator ef))
 115      (if (and octet-size (<= 1 octet-size 4))
 116          octet-size
 117          (ef-octet-size ef))
 118      (ef-octets-to-char ef)
 119      (ef-char-to-octets ef))))
 120 \f
 121 ;;;
 122 ;;; UTILS
 123 ;;;
 124 (deftype octet ()
 125   '(unsigned-byte 8))
 126
 127 (deftype buffer-index ()
 128   '(unsigned-byte 24))
 129
 130 (defmacro add-external-format (name aliases ef)
 131   (with-gensyms ($alias$)
 132     `(progn
 133        (setf (gethash ,name *external-formats*) ,ef)
 134        (setf *external-format-list* (append *external-format-list* (list ,name)))
 135        (dolist (,$alias$ ',aliases)
 136          (assert (keywordp ,$alias$))
 137          (setf (gethash ,$alias$ *external-format-aliases*) ,name)))))
 138
 139 (defmacro define-external-format (name aliases octet-size octets-to-char char-to-octets
 140                                   &key (line-terminator *default-line-terminator*))
 141   (with-gensyms ($ef$)
 142     `(macrolet ((to-char (&body body)
 143                   `(lambda (input output error-fn bytes-left)
 144                      (declare (type (function () octet) input)
 145                               (type (function (character) t) output)
 146                               (type (function (symbol) character) error-fn)
 147                               (type buffer-index bytes-left)
 148                               (ignorable input output error-fn bytes-left))
 149                      ,@body))
 150                 (to-octets (&body body)
 151                   `(lambda (input output error-fn chars-left)
 152                      (declare (type (function () character) input)
 153                               (type (function (octet) t) output)
 154                               (type (function (symbol) character) error-fn)
 155                               (type buffer-index chars-left)
 156                               (ignorable input output error-fn chars-left))
 157                      ,@body)))
 158        (let ((,$ef$ (%make-external-format ,name ,line-terminator ,octet-size
 159                                            ,octets-to-char ,char-to-octets)))
 160          (add-external-format ,name ,aliases ,$ef$)))))
 161
 162 (defun find-external-format (name &optional (error-p t))
 163   (when (external-format-p name)
 164     (return-from find-external-format name))
 165
 166   (when (eq name :default)
 167     (setq name *default-external-format*))
 168   (when (stringp name)
 169     (setf name (ensure-keyword name)))
 170
 171   (or (gethash name *external-formats*)
 172       (gethash (gethash name *external-format-aliases*)
 173                *external-formats*)
 174       (if error-p (error "External format ~S not found." name) nil)))
 175
 176 (defun ensure-external-format (external-format)
 177   (etypecase external-format
 178     (external-format external-format)
 179     (null   (find-external-format :default))
 180     (symbol (find-external-format external-format))
 181     (cons
 182      (apply #'make-external-format external-format))))
 183 \f
 184 ;;;
 185 ;;;
 186 ;;; EXTERNAL FORMATS
 187 ;;;
 188 ;;;
 189
 190 (define-condition void-external-format (error) ()
 191   (:report
 192    (lambda (condition stream)
 193      (declare (ignore condition))
 194      (format stream "Attempting I/O through void external-format."))))
 195
 196 (define-external-format :void () 0
 197   (to-char
 198    (error 'void-external-format))
 199   (to-octets
 200    (error 'void-external-format)))
 201
 202 (define-external-format :ascii (:us-ascii) 1
 203   (to-char
 204    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 205    (let ((code (funcall input)))
 206      (if (< code 128)
 207          (funcall output (aref +iso-8859-1-table+ code))
 208          (funcall output (funcall error-fn 'illegal-code-point)))))
 209   (to-octets
 210    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 211    (let ((code (char-code (funcall input))))
 212      (if (< code 128)
 213          (funcall output code)
 214          (funcall output (char-code (funcall error-fn 'illegal-character)))))))
 215
 216 (define-external-format :iso-8859-1 (:iso8859-1 :ISO_8859-1 :latin1 :latin-1 :l1
 217                                      :csISOLatin1 :iso-ir-100 :CP819) 1
 218   (to-char
 219    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 220    (let ((code (funcall input)))
 221      (funcall output (aref +iso-8859-1-table+ code))))
 222   (to-octets
 223    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 224    (let ((code (char-code (funcall input))))
 225      (if (< code 256)
 226          (funcall output code)
 227          (funcall output (char-code (funcall error-fn 'illegal-character)))))))
 228
 229 #+ucs-chars
 230 (defmacro define-iso-8859-external-formats (indexes)
 231   (flet ((get-name-and-aliases (index)
 232            (if (endp index)
 233                (values index nil)
 234                (values (car index)
 235                        (cdr index)))))
 236     `(progn
 237        ,@(loop :for i :in indexes
 238             :collect
 239             (multiple-value-bind (index aliases) (get-name-and-aliases i)
 240               (let ((table (concat-symbol "+iso-8859-" index "-table+"))
 241                     (name (ensure-keyword
 242                            (concatenate 'string "ISO-8859-" index))))
 243                 (push (ensure-keyword
 244                        (concatenate 'string "ISO8859-" index))
 245                       aliases)
 246                 `(define-external-format ,name ,aliases 1
 247                    (to-char
 248                     (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 249                     (let ((code (funcall input)))
 250                       (funcall output (aref ,table code))))
 251                    (to-octets
 252                     (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 253                     (let ((code (position (funcall input) ,table)))
 254                       (if code
 255                           (funcall output code)
 256                           (funcall output
 257                                    (position (funcall error-fn 'illegal-character)
 258                                              ,table))))))))))))
 259
 260 #+ucs-chars
 261 (define-iso-8859-external-formats
 262     (("2" :ISO_8859-2 :latin2 :latin-2 :l2 :csISOLatin2 :iso-ir-101)
 263      ("3" :ISO_8859-3 :latin3 :latin-2 :l3 :csISOLatin3 :iso-ir-109)
 264      ("4" :ISO_8859-4 :latin4 :latin-4 :l4 :csISOLatin4 :iso-ir-110)
 265      ("5" :ISO_8859-5 :cyrillic :csISOLatinCyrillic :iso-ir-144)
 266      ("6" :ISO_8859-6 :arabic :csISOLatinArabic :iso-ir-127)
 267      ("7" :ISO_8859-7 :greek :greek8 :csISOLatinGreek :iso-ir-126)
 268      ("8" :ISO_8859-8 :hebrew :csISOLatinHebrew :iso-ir-138)
 269      ("9" :ISO_8859-9 :latin5 :latin-5 :l5 :csISOLatin5 :iso-ir-148)
 270      ("10" :ISO_8859-10 :latin6 :latin-6 :l6 :csISOLatin6 :iso-ir-157)
 271      ("11" :ISO_8859-11 :thai :csISOLatinThai :iso-ir-166)
 272      ("13" :ISO_8859-13 :baltic :csISOLatinBaltic :iso-ir-179)
 273      ("14" :ISO_8859-14 :iso-celtic :latin8 :l8 :csISOLatinCeltic :iso-ir-199)
 274      ("15" :ISO_8859-15 :latin9 :latin-9 :l9 :csISOLatin9 :iso-ir-203)
 275      ("16" :ISO_8859-16 :latin10 :latin-10 :l10 :csISOLatin10 :iso-ir-226)))
 276
 277 (define-constant +max-unicode-code-point+ #x10FFFF)
 278
 279 #+ucs-chars (declaim (inline illegal-unicode-code-point))
 280 #+ucs-chars
 281 (defun illegal-unicode-code-point (code)
 282   (declare (type (unsigned-byte 32) code))
 283   (or (<= #xD800 code #xDFFF)
 284       (= code #xFFFE)
 285       (= code #xFFFF)
 286       (> code +max-unicode-code-point+)))
 287
 288 #+ucs-chars
 289 (define-external-format :utf-8 (:utf8) 2
 290   (to-char
 291    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 292    (block utf-8-decode
 293      (let ((code 0) (bytes-needed nil)
 294            (byte0 0) (byte1 0)
 295            (byte2 0) (byte3 0))
 296        (declare (type octet byte0 byte1 byte2 byte3))
 297        (labels ((decode-err (sym)
 298                   (return-from utf-8-decode
 299                     (funcall output (funcall error-fn sym))))
 300                 (utf-8-byte-len (code)
 301                   (declare (type octet code))
 302                   (cond
 303                     ((not (logbitp 7 code))                  1)
 304                     ((= (logand code #b11100000) #b11000000) 2)
 305                     ((= (logand code #b11110000) #b11100000) 3)
 306                     ((= (logand code #b11111000) #b11110000) 4)
 307                     (t (decode-err 'invalid-starter-octet))))
 308                 (valid-secondary-check (byte)
 309                   (or (= (logand byte #b11000000) #b10000000)
 310                       (decode-err 'invalid-continuation-octet)))
 311                 (overlong-check (starter mask)
 312                   (or (/= starter byte0)
 313                       (/= (logior byte1 mask) mask)
 314                       (decode-err 'overlong-octet-sequence))))
 315          (macrolet ((put-and-check-valid-secondary-bytes (&rest places)
 316                       `(progn ,@(reduce #'append places
 317                                         :key #'(lambda (x) `((setf ,x (funcall input))
 318                                                              (valid-secondary-check ,x)))))))
 319            (setf byte0 (funcall input)
 320                  bytes-needed (utf-8-byte-len byte0))
 321            (when (< bytes-left bytes-needed)
 322              (decode-err 'end-of-input-in-character))
 323            (case bytes-needed
 324              (1 (setf code byte0))
 325              (2 (put-and-check-valid-secondary-bytes byte1)
 326                 (overlong-check #b11000000 #b10111111)
 327                 (overlong-check #b11000001 #b10111111)
 328                 (setf code (logior (ash (ldb (byte 5 0) byte0) 6)
 329                                    (ldb (byte 6 0) byte1))))
 330              (3 (put-and-check-valid-secondary-bytes byte1 byte2)
 331                 (overlong-check #b11100000 #b10011111)
 332                 (setf code (logior (ash (ldb (byte 4 0) byte0) 12)
 333                                    (ash (ldb (byte 6 0) byte1) 6)
 334                                    (ldb (byte 6 0) byte2)))
 335                 (when (illegal-unicode-code-point code)
 336                   (decode-err 'illegal-code-point)))
 337              (4 (put-and-check-valid-secondary-bytes byte1 byte2 byte3)
 338                 (overlong-check #b11110000 #b10001111)
 339                 (setf code (logior (ash (ldb (byte 3 0) byte0) 18)
 340                                    (ash (ldb (byte 6 0) byte1) 12)
 341                                    (ash (ldb (byte 6 0) byte2) 6)
 342                                    (ldb (byte 6 0) byte3)))))
 343            (funcall output (code-char code)))))))
 344   (to-octets
 345    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 346    (let ((code (char-code (funcall input))))
 347      (when (illegal-unicode-code-point code)
 348        (setf code (char-code (funcall error-fn 'illegal-character))))
 349      (cond
 350        ((< code #x80)
 351         (funcall output code))
 352        ((< code #x800)
 353         (funcall output (logior #xC0 (ldb (byte 5 6) code)))
 354         (funcall output (logior #x80 (ldb (byte 6 0) code))))
 355        ((< code #x10000)
 356         (funcall output (logior #xE0 (ldb (byte 4 12) code)))
 357         (funcall output (logior #x80 (ldb (byte 6 6) code)))
 358         (funcall output (logior #x80 (ldb (byte 6 0) code))))
 359        ((< code #x200000)
 360         (funcall output (logior #xF0 (ldb (byte 3 18) code)))
 361         (funcall output (logior #x80 (ldb (byte 6 12) code)))
 362         (funcall output (logior #x80 (ldb (byte 6 6) code)))
 363         (funcall output (logior #x80 (ldb (byte 6 0) code))))))))
 364
 365 #+ucs-chars
 366 (define-external-format :utf-16 (:utf16 :utf-16be :utf16be) 2
 367   (to-char
 368    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 369    (block utf-16-decode
 370      (flet ((read-word ()
 371               (+ (ash (funcall input) 8) (funcall input)))
 372             (decode-err (sym)
 373               (return-from utf-16-decode
 374                 (funcall output (funcall error-fn sym)))))
 375        (macrolet ((put-word (word bytes-needed)
 376                     `(progn (when (> ,bytes-needed bytes-left)
 377                               (decode-err 'end-of-input-in-character))
 378                             (setf ,word (read-word)))))
 379          (let ((code 0) (w0 0) (w1 0))
 380            (declare (type (unsigned-byte 32) code)
 381                     (type (unsigned-byte 16) w0 w1))
 382            (put-word w0 2)
 383            (cond ((not (<= #xD800 w0 #xDFFF))
 384                   (setf code w0))
 385                  ((> w0 #xDBFF)
 386                   (decode-err 'invalid-starter-octet))
 387                  (t (put-word w1 4)
 388                     (if (<= #xDC00 w1 #xDFFF)
 389                         (setf code (+ (ash (ldb (byte 10 0) w0) 10)
 390                                       (ldb (byte 10 0) w1)
 391                                       #x10000))
 392                         (decode-err 'invalid-continuation-octet))))
 393            (funcall output (code-char code)))))))
 394   (to-octets
 395    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 396    (flet ((write-word (word)
 397             (funcall output (ldb (byte 8 8) word))
 398             (funcall output (ldb (byte 8 0) word))))
 399      (let ((code (char-code (funcall input))))
 400        (when (illegal-unicode-code-point code)
 401          (setf code (char-code (funcall error-fn 'illegal-character))))
 402        (cond ((< code #x10000)
 403               (write-word code))
 404              (t (decf code #x10000)
 405                 (write-word (logior #xD800 (ldb (byte 10 10) code)))
 406                 (write-word (logior #xDC00 (ldb (byte 10 0) code)))))))))
 407
 408 #+ucs-chars
 409 (define-external-format :utf-16le (:utf16le) 2
 410   (to-char
 411    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 412    (block utf-16-decode
 413      (flet ((read-word ()
 414               (+ (funcall input) (ash (funcall input) 8)))
 415             (decode-err (sym)
 416               (return-from utf-16-decode
 417                 (funcall output (funcall error-fn sym)))))
 418        (macrolet ((put-word (word bytes-needed)
 419                     `(progn (when (> ,bytes-needed bytes-left)
 420                               (decode-err 'end-of-input-in-character))
 421                             (setf ,word (read-word)))))
 422          (let ((code 0) (w0 0) (w1 0))
 423            (declare (type (unsigned-byte 32) code)
 424                     (type (unsigned-byte 16) w0 w1))
 425            (put-word w0 2)
 426            (cond ((not (<= #xD800 w0 #xDFFF))
 427                   (setf code w0))
 428                  ((> w0 #xDBFF)
 429                   (decode-err 'invalid-starter-octet))
 430                  (t (put-word w1 4)
 431                     (if (<= #xDC00 w1 #xDFFF)
 432                         (setf code (+ (ash (ldb (byte 10 0) w0) 10)
 433                                       (ldb (byte 10 0) w1)
 434                                       #x10000))
 435                         (decode-err 'invalid-continuation-octet))))
 436            (funcall output (code-char code)))))))
 437   (to-octets
 438    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 439    (flet ((write-word (word)
 440             (funcall output (ldb (byte 8 0) word))
 441             (funcall output (ldb (byte 8 8) word))))
 442      (let ((code (char-code (funcall input))))
 443        (when (illegal-unicode-code-point code)
 444          (setf code (char-code (funcall error-fn 'illegal-character))))
 445        (cond ((< code #x10000)
 446               (write-word code))
 447              (t (decf code #x10000)
 448                 (write-word (logior #xD800 (ldb (byte 10 10) code)))
 449                 (write-word (logior #xDC00 (ldb (byte 10 0) code)))))))))
 450 \f
 451 ;;;
 452 ;;;
 453 ;;; CONVERSION FUNCTIONS
 454 ;;;
 455 ;;;
 456
 457 (define-constant +replacement-char+
 458     #+ucs-chars #xFFFD
 459     #-ucs-chars (char-code #\?))
 460
 461 ;;
 462 ;; OCTETS-TO-CHAR
 463 ;;
 464
 465 (defmacro octets-to-char (external-format input output error-fn bytes-left)
 466   `(funcall (ef-octets-to-char ,external-format) ,input ,output ,error-fn
 467             ,bytes-left))
 468
 469 (defun read-replacement-char ()
 470   (format *query-io* "Enter a replacement character(evaluated): ")
 471   (finish-output *query-io*)
 472   (list (eval (read *query-io*))))
 473
 474 (defun %octets-to-string (buffer string start end ef &optional max-char-num (prevptr start))
 475   (declare (type et:foreign-pointer buffer)
 476            (type buffer-index start end)
 477            (type external-format ef)
 478            (type (or null signed-byte) max-char-num)
 479            (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 480   (unless max-char-num (setf max-char-num -1))
 481   (let ((ptr start)
 482         (pos -1)
 483         (char-count -1)
 484         oldpos oldptr)
 485     (labels
 486         ((input ()
 487            (prog1 (cffi:mem-aref buffer :uint8 ptr) (incf ptr)))
 488          (output (char)
 489            (setf (char string (incf pos)) char))
 490          (error-fn (symbol)
 491            (restart-case
 492                (error symbol :array buffer
 493                       :start start :end end
 494                       :position oldptr
 495                       :external-format (ef-name ef))
 496              (use-value (s)
 497                :report "Supply a replacement character."
 498                :interactive read-replacement-char
 499                s)
 500              (use-standard-unicode-replacement ()
 501                :report "Use standard UCS replacement character"
 502                (code-char +replacement-char+))
 503              (stop-decoding ()
 504                :report "Stop decoding and return to last good offset."
 505                (setf pos oldpos)
 506                (exit))))
 507          (exit ()
 508            (return-from %octets-to-string (values (1+ pos) (- ptr start) prevptr))))
 509       (loop :while (and (< ptr end)
 510                         (/= (incf char-count) max-char-num))
 511          :do (setf oldpos pos
 512                    oldptr ptr)
 513          (octets-to-char ef #'input #'output #'error-fn (- end ptr))
 514          (setf prevptr oldptr))
 515       (exit))))
 516
 517
 518 (defun octets-to-string (octets
 519                          &key (start 0) end
 520                          (external-format :default)
 521                          (auto-correct nil))
 522   (setf octets (coerce octets '(simple-array octet (*))))
 523   (check-type start buffer-index)
 524   (check-type end (or null buffer-index))
 525   (let ((ef (find-external-format external-format))
 526         (end (or end (length octets)))
 527         (string nil))
 528     (assert (<= start end))
 529     (setf string (make-string (- end start)))
 530     (cffi:with-pointer-to-vector-data (octets-ptr octets)
 531       (let ((pos (if auto-correct
 532                      (handler-bind ((octet-decoding-error
 533                                      #'(lambda (error)
 534                                          (declare (ignore error))
 535                                          (invoke-restart 'use-value #\?))))
 536                        (%octets-to-string octets-ptr string start end ef))
 537                      (%octets-to-string octets-ptr string start end ef))))
 538         (shrink-vector string pos)))))
 539
 540 ;;
 541 ;; CHAR-TO-OCTETS
 542 ;;
 543
 544 (defmacro char-to-octets (ef input output error-fn chars-left)
 545   `(funcall (ef-char-to-octets ,ef) ,input ,output ,error-fn
 546             ,chars-left))
 547
 548 (defun string-to-octets (string &key start end
 549                          (external-format :default)
 550                          adjust-factor)
 551   (declare (type string string)
 552            (type (or null buffer-index) start)
 553            (type (or null buffer-index) end)
 554            (type (or null real) adjust-factor)
 555            (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 556
 557   (setf start (or start 0)
 558         end (or end (length string)))
 559   (let* ((ef (find-external-format external-format))
 560          (buffer (make-array (1+ (length string))
 561                              :element-type 'octet))
 562          (adjust-threshold (length string))
 563          (ptr start) oldptr
 564          (pos -1) oldpos)
 565     (setf adjust-factor (if (and adjust-factor (<= 1 adjust-factor 4))
 566                             adjust-factor
 567                             (ef-octet-size ef)))
 568     (tagbody
 569        (flet ((input ()
 570                 (prog1 (char string ptr) (incf ptr)))
 571               (output (octet)
 572                 (setf (aref buffer (incf pos)) octet)
 573                 (when (= pos adjust-threshold)
 574                   (setf adjust-threshold (truncate (* adjust-factor (1+ pos))))
 575                   (setf buffer (adjust-array buffer adjust-threshold))))
 576               (error-fn (symbol)
 577                 (restart-case
 578                     (error symbol :string buffer
 579                            :start start :end end
 580                            :position oldptr
 581                            :external-format (ef-name ef))
 582                   (use-value (s)
 583                     :report "Supply a replacement character."
 584                     :interactive read-replacement-char
 585                     s)
 586                   (use-standard-unicode-replacement ()
 587                     :report "Use standard UCS replacement character"
 588                     (code-char +replacement-char+))
 589                   (stop-decoding ()
 590                     :report "Stop decoding and return to last good offset."
 591                     (setf pos oldpos)
 592                     (go :exit)))))
 593          (loop :while (< ptr end)
 594             :do (setf oldpos pos oldptr ptr)
 595             (char-to-octets ef #'input #'output #'error-fn (- end ptr))))
 596      :exit (return-from string-to-octets (shrink-vector buffer (1+ pos))))))