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 ;;;
  78 ;;; Of these, the only one truly likely to be of interest to calling
  79 ;;; code is end-of-input-in-character (in which case it's likely to
  80 ;;; want to make a note of octet-decoding-error-start, supply "" as a
  81 ;;; replacement string, and then move that last chunk of bytes to the
  82 ;;; beginning of its buffer for the next go round) but they're all
  83 ;;; provided on the off chance they're of interest.
  84
  85 (define-condition octet-decoding-error (character-decoding-error)
  86   ((array :initarg :array :accessor octet-decoding-error-array)
  87    (start :initarg :start :accessor octet-decoding-error-start)
  88    (end :initarg :end :accessor octet-decoding-error-end)
  89    (position :initarg :pos :accessor octet-decoding-bad-byte-position)
  90    (external-format :initarg :external-format
  91                     :accessor octet-decoding-error-external-format))
  92   (:report
  93    (lambda (condition stream)
  94      (format stream "Illegal ~S character starting at byte position ~D."
  95              (octet-decoding-error-external-format condition)
  96              (octet-decoding-error-start condition)))))
  97
  98 (define-condition end-of-input-in-character (octet-decoding-error) ())
  99 (define-condition character-out-of-range (octet-decoding-error) ())
 100 (define-condition invalid-utf8-starter-byte (octet-decoding-error) ())
 101 (define-condition invalid-utf8-continuation-byte (octet-decoding-error) ())
 102 (define-condition overlong-utf8-sequence (octet-decoding-error) ())
 103
 104 (define-condition malformed-ascii (octet-decoding-error) ())
 105
 106 (defun read-replacement-string ()
 107   (format *query-io* "Enter a replacement string designator (evaluated): ")
 108   (finish-output *query-io*)
 109   (list (eval (read *query-io*))))
 110
 111 (defun decoding-error (array start end external-format reason pos)
 112   (restart-case
 113       (error reason
 114              :external-format external-format
 115              :array array
 116              :start start
 117              :end end
 118              :pos pos)
 119     (use-value (s)
 120       :report "Supply a replacement string designator."
 121       :interactive read-replacement-string
 122       (string s))))
 123
 124 ;;; Utilities used in both to-string and to-octet conversions
 125
 126 (defmacro instantiate-octets-definition (definer)
 127   `(progn
 128     (,definer aref (simple-array (unsigned-byte 8) (*)))
 129     (,definer sap-ref-8 system-area-pointer)))
 130
 131 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
 132 ;;; and fix it, or else replace with SYMBOLICATE.
 133 ;;;
 134 ;;; FIXME: this is cute, but is going to prevent greps for def.*<name>
 135 ;;; from working for (defun ,(make-od-name ...) ...)
 136 (eval-when (:compile-toplevel :load-toplevel :execute)
 137   (defun make-od-name (sym1 sym2)
 138     ;; "MAKE-NAME" is too generic, but this doesn't do quite what
 139     ;; SYMBOLICATE does; MAKE-OD-NAME ("octets definition") it is
 140     ;; then.
 141     (intern (concatenate 'string (symbol-name sym1) "-" (symbol-name sym2))
 142             (symbol-package sym1))))
 143 \f
 144 ;;;; to-octets conversions
 145
 146 ;;; to latin (including ascii)
 147
 148 ;;; Converting bytes to character codes is easy: just use a 256-element
 149 ;;; lookup table that maps each possible byte to its corresponding
 150 ;;; character code.
 151 ;;;
 152 ;;; Converting character codes to bytes is a little harder, since the
 153 ;;; codes may be spare (e.g. we use codes 0-127, 3490, and 4598).  The
 154 ;;; previous version of this macro utilized a gigantic CASE expression
 155 ;;; to do the hard work, with the result that the code was huge (since
 156 ;;; SBCL's then-current compilation strategy for CASE expressions was
 157 ;;; (and still is) converting CASE into COND into if-the-elses--which is
 158 ;;; also inefficient unless your code happens to occur very early in the
 159 ;;; chain.
 160 ;;;
 161 ;;; The current strategy is to build a table:
 162 ;;;
 163 ;;; [ ... code_1 byte_1 code_2 byte_2 ... code_n byte_n ... ]
 164 ;;;
 165 ;;; such that the codes are sorted in order from lowest to highest.  We
 166 ;;; can then binary search the table to discover the appropriate byte
 167 ;;; for a character code.  We also implement an optimization: all unibyte
 168 ;;; mappings do not remap ASCII (0-127) and some do not remap part of
 169 ;;; the range beyond character code 127.  So we check to see if the
 170 ;;; character code falls into that range first (a quick check, since
 171 ;;; character codes are guaranteed to be positive) and then do the binary
 172 ;;; search if not.  This optimization also enables us to cut down on the
 173 ;;; size of our lookup table.
 174 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
 175   (let* (;; Build a list of (CODE BYTE) pairs
 176          (pairs (loop for byte below 256
 177                    for code = (let ((exception (cdr (assoc byte exceptions))))
 178                                 (cond
 179                                   ((car exception) (car exception))
 180                                   ((null exception) byte)
 181                                   (t nil)))
 182                    when code collect (list code byte) into elements
 183                    finally (return elements)))
 184          ;; Find the smallest character code such that the corresponding
 185          ;; byte is != to the code.
 186          (lowest-non-equivalent-code
 187           (caar (sort (copy-seq exceptions) #'< :key #'car)))
 188          ;; Sort them for our lookup table.
 189          (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
 190                              #'< :key #'car))
 191          ;; Create the lookup table.
 192          (sorted-lookup-table
 193           (reduce #'append sorted-pairs :from-end t :initial-value nil)))
 194     `(progn
 195        ; Can't inline it with a non-null lexical environment anyway.
 196        ;(declaim (inline ,byte-char-name))
 197        (let ((byte-to-code-table
 198               ,(make-array 256 :element-type t #+nil 'char-code
 199                            :initial-contents (loop for byte below 256
 200                                                 collect
 201                                                 (let ((exception (cdr (assoc byte exceptions))))
 202                                                   (if exception
 203                                                       (car exception)
 204                                                       byte)))))
 205              (code-to-byte-table
 206               ,(make-array (length sorted-lookup-table)
 207                            :initial-contents sorted-lookup-table)))
 208          (defun ,byte-char-name (byte)
 209            (declare (optimize speed (safety 0))
 210                     (type (unsigned-byte 8) byte))
 211            (aref byte-to-code-table byte))
 212          (defun ,code-byte-name (code)
 213            (declare (optimize speed (safety 0))
 214                     (type char-code code))
 215            (if (< code ,lowest-non-equivalent-code)
 216                code
 217                ;; We could toss in some TRULY-THEs if we really needed to
 218                ;; make this faster...
 219                (loop with low = 0
 220                   with high = (- (length code-to-byte-table) 2)
 221                   while (< low high)
 222                   do (let ((mid (logandc2 (truncate (+ low high 2) 2) 1)))
 223                        (if (< code (aref code-to-byte-table mid))
 224                            (setf high (- mid 2))
 225                            (setf low mid)))
 226                   finally (return (if (eql code (aref code-to-byte-table low))
 227                                       (aref code-to-byte-table (1+ low))
 228                                       nil)))))))))
 229
 230 (declaim (inline get-latin-bytes))
 231 (defun get-latin-bytes (mapper external-format string pos)
 232   (let ((code (funcall mapper (char-code (char string pos)))))
 233     (declare (type (or null char-code) code))
 234     (values (cond
 235               ((and code (< code 256)) code)
 236               (t
 237                (encoding-error external-format string pos)))
 238             1)))
 239
 240 (declaim (inline string->latin%))
 241 (defun string->latin% (string sstart send get-bytes null-padding)
 242   (declare (optimize speed)
 243            (type simple-string string)
 244            (type index sstart send)
 245            (type (integer 0 1) null-padding)
 246            (type function get-bytes))
 247   ;; The latin encodings are all unibyte encodings, so just directly
 248   ;; compute the number of octets we're going to generate.
 249   (let ((octets (make-array (+ (- send sstart) null-padding)
 250                             ;; This takes care of any null padding the
 251                             ;; caller requests.
 252                             :initial-element 0
 253                             :element-type '(unsigned-byte 8)))
 254         (index 0)
 255         (error-position 0)
 256         (error-replacement))
 257     (tagbody
 258      :no-error
 259        (loop for pos of-type index from sstart below send
 260           do (let ((byte (funcall get-bytes string pos)))
 261                (typecase byte
 262                  ((unsigned-byte 8)
 263                   (locally (declare (optimize (sb!c::insert-array-bounds-checks 0)))
 264                     (setf (aref octets index) byte)))
 265                  ((simple-array (unsigned-byte 8) (*))
 266                   ;; KLUDGE: We ran into encoding errors.  Bail and do
 267                   ;; things the slow way (does anybody actually use this
 268                   ;; functionality besides our own test suite?).
 269                   (setf error-position pos error-replacement byte)
 270                   (go :error)))
 271                (incf index))
 272           finally (return-from string->latin% octets))
 273      :error
 274        ;; We have encoded INDEX octets so far and we ran into an
 275        ;; encoding error at ERROR-POSITION; the user has asked us to
 276        ;; replace the expected output with ERROR-REPLACEMENT.
 277        (let ((new-octets (make-array (* index 2)
 278                                      :element-type '(unsigned-byte 8)
 279                                      :adjustable t :fill-pointer index)))
 280          (replace new-octets octets)
 281          (flet ((extend (thing)
 282                  (typecase thing
 283                    ((unsigned-byte 8) (vector-push-extend thing new-octets))
 284                    ((simple-array (unsigned-byte 8) (*))
 285                     (dotimes (i (length thing))
 286                       (vector-push-extend (aref thing i) new-octets))))))
 287            (extend error-replacement)
 288            (loop for pos of-type index from (1+ error-position) below send
 289                  do (extend (funcall get-bytes string pos))
 290                  finally (return-from string->latin%
 291                            (progn
 292                              (unless (zerop null-padding)
 293                                (vector-push-extend 0 new-octets))
 294                              (copy-seq new-octets)))))))))
 295 \f
 296 ;;;; to-string conversions
 297
 298 ;;; from latin (including ascii)
 299
 300 (defmacro define-latin->string* (accessor type)
 301   (let ((name (make-od-name 'latin->string* accessor)))
 302     `(progn
 303       (declaim (inline ,name))
 304       (defun ,name (string sstart send array astart aend mapper)
 305         (declare (optimize speed (safety 0))
 306                  (type simple-string string)
 307                  (type ,type array)
 308                  (type array-range sstart send astart aend)
 309                  (function mapper))
 310         (loop for spos from sstart below send
 311            for apos from astart below aend
 312            do (setf (char string spos)
 313                     (code-char (funcall mapper (,accessor array apos))))
 314            finally (return (values string spos apos)))))))
 315 (instantiate-octets-definition define-latin->string*)
 316
 317 (defmacro define-latin->string (accessor type)
 318   (let ((name (make-od-name 'latin->string accessor)))
 319     `(progn
 320       (declaim (inline ,name))
 321       (defun ,name (array astart aend mapper)
 322         (declare (optimize speed (safety 0))
 323                  (type ,type array)
 324                  (type array-range astart aend)
 325                  (type function mapper))
 326         (let ((length (the array-range (- aend astart))))
 327           (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
 328                                                             array astart aend
 329                                                             mapper)))))))
 330 (instantiate-octets-definition define-latin->string)
 331 \f
 332 ;;;; external formats
 333
 334 (defvar *default-external-format* nil)
 335
 336 (defun default-external-format ()
 337   (or *default-external-format*
 338       ;; On non-unicode, use iso-8859-1 instead of detecting it from
 339       ;; the locale settings. Defaulting to an external-format which
 340       ;; can represent characters that the CHARACTER type can't
 341       ;; doesn't seem very sensible.
 342       #!-sb-unicode
 343       (setf *default-external-format* :latin-1)
 344       (let ((external-format #!-win32 (intern (or (sb!alien:alien-funcall
 345                                                     (extern-alien
 346                                                       "nl_langinfo"
 347                                                       (function (c-string :external-format :latin-1)
 348                                                                 int))
 349                                                     sb!unix:codeset)
 350                                                   "LATIN-1")
 351                                               "KEYWORD")
 352                              #!+win32 (sb!win32::ansi-codepage)))
 353         (/show0 "cold-printing defaulted external-format:")
 354         #!+sb-show
 355         (cold-print external-format)
 356         (/show0 "matching to known aliases")
 357         (let ((entry (sb!impl::get-external-format external-format)))
 358           (cond
 359             (entry
 360              (/show0 "matched"))
 361             (t
 362              ;; FIXME! This WARN would try to do printing
 363              ;; before the streams have been initialized,
 364              ;; causing an infinite erroring loop. We should
 365              ;; either print it by calling to C, or delay the
 366              ;; warning until later. Since we're in freeze
 367              ;; right now, and the warning isn't really
 368              ;; essential, I'm doing what's least likely to
 369              ;; cause damage, and commenting it out. This
 370              ;; should be revisited after 0.9.17. -- JES,
 371              ;; 2006-09-21
 372              #+nil
 373              (warn "Invalid external-format ~A; using LATIN-1"
 374                    external-format)
 375              (setf external-format :latin-1))))
 376         (/show0 "/default external format ok")
 377         (setf *default-external-format* external-format))))
 378 \f
 379 ;;;; public interface
 380
 381 (defun maybe-defaulted-external-format (external-format)
 382   (sb!impl::get-external-format-or-lose (if (eq external-format :default)
 383                                             (default-external-format)
 384                                             external-format)))
 385
 386 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
 387   (declare (type (vector (unsigned-byte 8)) vector))
 388   (with-array-data ((vector vector)
 389                     (start start)
 390                     (end end)
 391                     :check-fill-pointer t)
 392     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
 393     (let ((ef (maybe-defaulted-external-format external-format)))
 394       (funcall (sb!impl::ef-octets-to-string-fun ef) vector start end))))
 395
 396 (defun string-to-octets (string &key (external-format :default)
 397                          (start 0) end null-terminate)
 398   (declare (type string string))
 399   (with-array-data ((string string)
 400                     (start start)
 401                     (end end)
 402                     :check-fill-pointer t)
 403     (declare (type simple-string string))
 404     (let ((ef (maybe-defaulted-external-format external-format)))
 405       (funcall (sb!impl::ef-string-to-octets-fun ef) string start end
 406                (if null-terminate 1 0)))))
 407
 408 #!+sb-unicode
 409 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
 410 #!+sb-unicode
 411 (defun use-unicode-replacement-char (condition)
 412   (use-value +unicode-replacement-character+ condition))
 413
 414 ;;; Utilities that maybe should be exported
 415
 416 #!+sb-unicode
 417 (defmacro with-standard-replacement-character (&body body)
 418   `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
 419     ,@body))
 420
 421 (defmacro with-default-decoding-replacement ((c) &body body)
 422   (let ((cname (gensym)))
 423   `(let ((,cname ,c))
 424     (handler-bind
 425         ((octet-decoding-error (lambda (c)
 426                                  (use-value ,cname c))))
 427       ,@body))))