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 encoding-error (external-format string pos)
  42   (restart-case
  43       (error 'octets-encoding-error
  44              :external-format external-format
  45              :string string
  46              :position pos)
  47     (use-value (replacement)
  48       :report "Supply a set of bytes to use in place of the invalid one."
  49       :interactive
  50       (lambda ()
  51         (read-evaluated-form
  52          "Replacement byte, bytes, character, or string (evaluated): "))
  53       (typecase replacement
  54         ((unsigned-byte 8)
  55          (make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement))
  56         (character
  57          (string-to-octets (string replacement)
  58                            :external-format external-format))
  59         (string
  60          (string-to-octets replacement
  61                            :external-format external-format))
  62         (t
  63          (coerce replacement '(simple-array (unsigned-byte 8) (*))))))))
  64
  65 ;;; decoding condition
  66
  67 ;;; for UTF8, the specific condition signalled will be a generalized
  68 ;;; instance of one of the following:
  69 ;;;
  70 ;;;   end-of-input-in-character
  71 ;;;   character-out-of-range
  72 ;;;   invalid-utf8-starter-byte
  73 ;;;   invalid-utf8-continuation-byte
  74 ;;;
  75 ;;; Of these, the only one truly likely to be of interest to calling
  76 ;;; code is end-of-input-in-character (in which case it's likely to
  77 ;;; want to make a note of octet-decoding-error-start, supply "" as a
  78 ;;; replacement string, and then move that last chunk of bytes to the
  79 ;;; beginning of its buffer for the next go round) but they're all
  80 ;;; provided on the off chance they're of interest.
  81
  82 (define-condition octet-decoding-error (character-decoding-error)
  83   ((array :initarg :array :accessor octet-decoding-error-array)
  84    (start :initarg :start :accessor octet-decoding-error-start)
  85    (end :initarg :end :accessor octet-decoding-error-end)
  86    (position :initarg :pos :accessor octet-decoding-bad-byte-position)
  87    (external-format :initarg :external-format
  88                     :accessor octet-decoding-error-external-format))
  89   (:report
  90    (lambda (condition stream)
  91      (format stream "Illegal ~S character starting at byte position ~D."
  92              (octet-decoding-error-external-format condition)
  93              (octet-decoding-error-start condition)))))
  94
  95 (define-condition end-of-input-in-character (octet-decoding-error) ())
  96 (define-condition character-out-of-range (octet-decoding-error) ())
  97 (define-condition invalid-utf8-starter-byte (octet-decoding-error) ())
  98 (define-condition invalid-utf8-continuation-byte (octet-decoding-error) ())
  99 (define-condition overlong-utf8-sequence (octet-decoding-error) ())
 100
 101 (define-condition malformed-ascii (octet-decoding-error) ())
 102
 103 (defun decoding-error (array start end external-format reason pos)
 104   (restart-case
 105       (error reason
 106              :external-format external-format
 107              :array array
 108              :start start
 109              :end end
 110              :pos pos)
 111     (use-value (s)
 112       :report "Supply a replacement string designator."
 113       :interactive
 114       (lambda ()
 115         (read-evaluated-form
 116          "Enter a replacement string designator (evaluated): "))
 117       (string s))))
 118
 119 ;;; Utilities used in both to-string and to-octet conversions
 120
 121 (defmacro instantiate-octets-definition (definer)
 122   `(progn
 123     (,definer aref (simple-array (unsigned-byte 8) (*)))
 124     (,definer sap-ref-8 system-area-pointer)))
 125
 126 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
 127 ;;; and fix it, or else replace with SYMBOLICATE.
 128 ;;;
 129 ;;; FIXME: this is cute, but is going to prevent greps for def.*<name>
 130 ;;; from working for (defun ,(make-od-name ...) ...)
 131 (eval-when (:compile-toplevel :load-toplevel :execute)
 132   (defun make-od-name (sym1 sym2)
 133     ;; "MAKE-NAME" is too generic, but this doesn't do quite what
 134     ;; SYMBOLICATE does; MAKE-OD-NAME ("octets definition") it is
 135     ;; then.
 136     (intern (concatenate 'string (symbol-name sym1) "-" (symbol-name sym2))
 137             (symbol-package sym1))))
 138 \f
 139 ;;;; to-octets conversions
 140
 141 ;;; to latin (including ascii)
 142
 143 ;;; Converting bytes to character codes is easy: just use a 256-element
 144 ;;; lookup table that maps each possible byte to its corresponding
 145 ;;; character code.
 146 ;;;
 147 ;;; Converting character codes to bytes is a little harder, since the
 148 ;;; codes may be spare (e.g. we use codes 0-127, 3490, and 4598).  The
 149 ;;; previous version of this macro utilized a gigantic CASE expression
 150 ;;; to do the hard work, with the result that the code was huge (since
 151 ;;; SBCL's then-current compilation strategy for CASE expressions was
 152 ;;; (and still is) converting CASE into COND into if-the-elses--which is
 153 ;;; also inefficient unless your code happens to occur very early in the
 154 ;;; chain.
 155 ;;;
 156 ;;; The current strategy is to build a table:
 157 ;;;
 158 ;;; [ ... code_1 byte_1 code_2 byte_2 ... code_n byte_n ... ]
 159 ;;;
 160 ;;; such that the codes are sorted in order from lowest to highest.  We
 161 ;;; can then binary search the table to discover the appropriate byte
 162 ;;; for a character code.  We also implement an optimization: all unibyte
 163 ;;; mappings do not remap ASCII (0-127) and some do not remap part of
 164 ;;; the range beyond character code 127.  So we check to see if the
 165 ;;; character code falls into that range first (a quick check, since
 166 ;;; character codes are guaranteed to be positive) and then do the binary
 167 ;;; search if not.  This optimization also enables us to cut down on the
 168 ;;; size of our lookup table.
 169 (defmacro define-unibyte-mapper (byte-char-name code-byte-name &rest exceptions)
 170   (let* (;; Build a list of (CODE BYTE) pairs
 171          (pairs (loop for byte below 256
 172                    for code = (let ((exception (cdr (assoc byte exceptions))))
 173                                 (cond
 174                                   ((car exception) (car exception))
 175                                   ((null exception) byte)
 176                                   (t nil)))
 177                    when code collect (list code byte) into elements
 178                    finally (return elements)))
 179          ;; Find the smallest character code such that the corresponding
 180          ;; byte is != to the code.
 181          (lowest-non-equivalent-code
 182           (caar (sort (copy-seq exceptions) #'< :key #'car)))
 183          ;; Sort them for our lookup table.
 184          (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
 185                              #'< :key #'car))
 186          ;; Create the lookup table.
 187          (sorted-lookup-table
 188           (reduce #'append sorted-pairs :from-end t :initial-value nil)))
 189     (flet ((pick-type (vector &optional missing-points-p)
 190              (if missing-points-p
 191                  (let ((max (reduce #'max (remove nil vector))))
 192                    (cond ((<= max #x7F) '(signed-byte 8))
 193                          ((<= max #x7FFF) '(signed-byte 16))
 194                          (t '(signed-byte 32))))
 195                  (let ((max (reduce #'max vector)))
 196                    (cond ((<= max #xFF) '(unsigned-byte 8))
 197                          ((<= max #xFFFF) '(unsigned-byte 16))
 198                          (t '(unsigned-byte 32)))))))
 199       `(progn
 200          ;; We *could* inline this, but it's not obviously the right thing,
 201          ;; because each use of the inlined function in a different file
 202          ;; would be forced to dump the large-ish array. To do things like
 203          ;; this, you generally want a load-time ref to a global constant.
 204        ;(declaim (inline ,byte-char-name))
 205          (defun ,byte-char-name (byte)
 206            (declare (optimize speed (safety 0))
 207                     (type (unsigned-byte 8) byte))
 208            ,(let ((byte-to-code
 209                    (loop for byte below 256
 210                       collect (let ((exception (cdr (assoc byte exceptions))))
 211                                 (if exception
 212                                     (car exception)
 213                                     byte)))))
 214               (if (position nil byte-to-code)
 215                   ;; There are bytes with no translation. Represent "missing"
 216                   ;; as -1 when stored, convert to NIL when accessed.
 217                   ;; We could use a single otherwise-unused point to mean NIL,
 218                   ;; but it would be confusing if in one table #xFFFF represents
 219                   ;; NIL and another #xF00D represents NIL.
 220                   `(let ((code (aref ,(!make-specialized-array
 221                                        256 (pick-type byte-to-code t)
 222                                        (substitute -1 nil byte-to-code))
 223                                      byte)))
 224                      (if (>= code 0) code))
 225                   ;; Every byte has a translation
 226                   `(aref ,(!make-specialized-array
 227                            256 (pick-type byte-to-code) byte-to-code)
 228                          byte))))
 229          (defun ,code-byte-name (code)
 230            (declare (optimize speed (safety 0))
 231                     (type char-code code))
 232            (if (< code ,lowest-non-equivalent-code)
 233                code
 234                (loop with code-to-byte-table =
 235                     ,(!make-specialized-array
 236                       (length sorted-lookup-table)
 237                       (pick-type sorted-lookup-table)
 238                       sorted-lookup-table)
 239                   with low = 0
 240                   with high = (- (length code-to-byte-table) 2)
 241                   while (< low high)
 242                   do (let ((mid (logandc2 (truncate (+ low high 2) 2) 1)))
 243                        (if (< code (aref code-to-byte-table mid))
 244                            (setf high (- mid 2))
 245                            (setf low mid)))
 246                   finally (return (if (eql code (aref code-to-byte-table low))
 247                                       (aref code-to-byte-table (1+ low))
 248                                       nil)))))))))
 249
 250 (declaim (inline get-latin-bytes))
 251 (defun get-latin-bytes (mapper external-format string pos)
 252   (let ((code (funcall mapper (char-code (char string pos)))))
 253     (declare (type (or null char-code) code))
 254     (values (cond
 255               ((and code (< code 256)) code)
 256               (t
 257                (encoding-error external-format string pos)))
 258             1)))
 259
 260 (declaim (inline string->latin%))
 261 (defun string->latin% (string sstart send get-bytes null-padding)
 262   (declare (optimize speed)
 263            (type simple-string string)
 264            (type index sstart send)
 265            (type (integer 0 1) null-padding)
 266            (type function get-bytes))
 267   ;; The latin encodings are all unibyte encodings, so just directly
 268   ;; compute the number of octets we're going to generate.
 269   (let ((octets (make-array (+ (- send sstart) null-padding)
 270                             ;; This takes care of any null padding the
 271                             ;; caller requests.
 272                             :initial-element 0
 273                             :element-type '(unsigned-byte 8)))
 274         (index 0)
 275         (error-position 0)
 276         (error-replacement))
 277     (tagbody
 278      :no-error
 279        (loop for pos of-type index from sstart below send
 280           do (let ((byte (funcall get-bytes string pos)))
 281                (typecase byte
 282                  ((unsigned-byte 8)
 283                   (locally (declare (optimize (sb!c::insert-array-bounds-checks 0)))
 284                     (setf (aref octets index) byte)))
 285                  ((simple-array (unsigned-byte 8) (*))
 286                   ;; KLUDGE: We ran into encoding errors.  Bail and do
 287                   ;; things the slow way (does anybody actually use this
 288                   ;; functionality besides our own test suite?).
 289                   (setf error-position pos error-replacement byte)
 290                   (go :error)))
 291                (incf index))
 292           finally (return-from string->latin% octets))
 293      :error
 294        ;; We have encoded INDEX octets so far and we ran into an
 295        ;; encoding error at ERROR-POSITION; the user has asked us to
 296        ;; replace the expected output with ERROR-REPLACEMENT.
 297        (let ((new-octets (make-array (* index 2)
 298                                      :element-type '(unsigned-byte 8)
 299                                      :adjustable t :fill-pointer index)))
 300          (replace new-octets octets)
 301          (flet ((extend (thing)
 302                  (typecase thing
 303                    ((unsigned-byte 8) (vector-push-extend thing new-octets))
 304                    ((simple-array (unsigned-byte 8) (*))
 305                     (dotimes (i (length thing))
 306                       (vector-push-extend (aref thing i) new-octets))))))
 307            (extend error-replacement)
 308            (loop for pos of-type index from (1+ error-position) below send
 309                  do (extend (funcall get-bytes string pos))
 310                  finally (return-from string->latin%
 311                            (progn
 312                              (unless (zerop null-padding)
 313                                (vector-push-extend 0 new-octets))
 314                              (copy-seq new-octets)))))))))
 315 \f
 316 ;;;; to-string conversions
 317
 318 ;;; from latin (including ascii)
 319
 320 (defmacro define-latin->string* (accessor type)
 321   (let ((name (make-od-name 'latin->string* accessor)))
 322     `(progn
 323       (declaim (inline ,name))
 324       (defun ,name (string sstart send array astart aend mapper)
 325         (declare (optimize speed (safety 0))
 326                  (type simple-string string)
 327                  (type ,type array)
 328                  (type array-range sstart send astart aend)
 329                  (function mapper))
 330         (loop for spos from sstart below send
 331            for apos from astart below aend
 332            do (setf (char string spos)
 333                     (code-char (funcall mapper (,accessor array apos))))
 334            finally (return (values string spos apos)))))))
 335 (instantiate-octets-definition define-latin->string*)
 336
 337 (defmacro define-latin->string (accessor type)
 338   (let ((name (make-od-name 'latin->string accessor)))
 339     `(progn
 340       (declaim (inline ,name))
 341       (defun ,name (array astart aend mapper)
 342         (declare (optimize speed (safety 0))
 343                  (type ,type array)
 344                  (type array-range astart aend)
 345                  (type function mapper))
 346         (let ((length (the array-range (- aend astart))))
 347           (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length
 348                                                             array astart aend
 349                                                             mapper)))))))
 350 (instantiate-octets-definition define-latin->string)
 351 \f
 352 ;;;; external formats
 353
 354 (defvar *default-external-format* nil)
 355
 356 (defun default-external-format ()
 357   (or *default-external-format*
 358       ;; On non-unicode, use iso-8859-1 instead of detecting it from
 359       ;; the locale settings. Defaulting to an external-format which
 360       ;; can represent characters that the CHARACTER type can't
 361       ;; doesn't seem very sensible.
 362       #!-sb-unicode
 363       (setf *default-external-format* :latin-1)
 364       (let ((external-format #!-win32 (intern (or #!-android
 365                                                   (alien-funcall
 366                                                    (extern-alien
 367                                                     "nl_langinfo"
 368                                                     (function (c-string :external-format :latin-1)
 369                                                               int))
 370                                                    sb!unix:codeset)
 371                                                   "LATIN-1")
 372                                               "KEYWORD")
 373                              #!+win32 (sb!win32::ansi-codepage)))
 374         (/show0 "cold-printing defaulted external-format:")
 375         #!+sb-show
 376         (cold-print external-format)
 377         (/show0 "matching to known aliases")
 378         (let ((entry (get-external-format external-format)))
 379           (cond
 380             (entry
 381              (/show0 "matched"))
 382             (t
 383              ;; FIXME! This WARN would try to do printing
 384              ;; before the streams have been initialized,
 385              ;; causing an infinite erroring loop. We should
 386              ;; either print it by calling to C, or delay the
 387              ;; warning until later. Since we're in freeze
 388              ;; right now, and the warning isn't really
 389              ;; essential, I'm doing what's least likely to
 390              ;; cause damage, and commenting it out. This
 391              ;; should be revisited after 0.9.17. -- JES,
 392              ;; 2006-09-21
 393              #+nil
 394              (warn "Invalid external-format ~A; using LATIN-1"
 395                    external-format)
 396              (setf external-format :latin-1))))
 397         (/show0 "/default external format ok")
 398         (setf *default-external-format* external-format))))
 399 \f
 400 ;;;; public interface
 401
 402 (defun maybe-defaulted-external-format (external-format)
 403   (get-external-format-or-lose (if (eq external-format :default)
 404                                    (default-external-format)
 405                                    external-format)))
 406
 407 (defun octets-to-string (vector &key (external-format :default) (start 0) end)
 408   (declare (type (vector (unsigned-byte 8)) vector))
 409   (with-array-data ((vector vector)
 410                     (start start)
 411                     (end end)
 412                     :check-fill-pointer t)
 413     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
 414     (let ((ef (maybe-defaulted-external-format external-format)))
 415       (funcall (ef-octets-to-string-fun ef) vector start end))))
 416
 417 (defun string-to-octets (string &key (external-format :default)
 418                          (start 0) end null-terminate)
 419   (declare (type string string))
 420   (with-array-data ((string string)
 421                     (start start)
 422                     (end end)
 423                     :check-fill-pointer t)
 424     (declare (type simple-string string))
 425     (let ((ef (maybe-defaulted-external-format external-format)))
 426       (funcall (ef-string-to-octets-fun ef) string start end
 427                (if null-terminate 1 0)))))
 428
 429 #!+sb-unicode
 430 (defvar +unicode-replacement-character+ (string (code-char #xfffd)))
 431 #!+sb-unicode
 432 (defun use-unicode-replacement-char (condition)
 433   (use-value +unicode-replacement-character+ condition))
 434
 435 ;;; Utilities that maybe should be exported
 436
 437 #!+sb-unicode
 438 (defmacro with-standard-replacement-character (&body body)
 439   `(handler-bind ((octet-encoding-error #'use-unicode-replacement-char))
 440     ,@body))
 441
 442 (defmacro with-default-decoding-replacement ((c) &body body)
 443   (let ((cname (gensym)))
 444   `(let ((,cname ,c))
 445     (handler-bind
 446         ((octet-decoding-error (lambda (c)
 447                                  (use-value ,cname c))))
 448       ,@body))))
 449
 450 ;;; This function was moved from 'fd-stream' because it depends on
 451 ;;; the various error classes, two of which are defined just above.
 452 (defun get-external-format (external-format)
 453   (flet ((keyword-external-format (keyword)
 454            (declare (type keyword keyword))
 455            (gethash keyword *external-formats*))
 456          (replacement-handlerify (entry replacement)
 457            (when entry
 458              (wrap-external-format-functions
 459               entry
 460               (lambda (fun)
 461                 (and fun
 462                      (lambda (&rest rest)
 463                        (declare (dynamic-extent rest))
 464                        (handler-bind
 465                            ((stream-decoding-error
 466                              (lambda (c)
 467                                (declare (ignore c))
 468                                (invoke-restart 'input-replacement replacement)))
 469                             (stream-encoding-error
 470                              (lambda (c)
 471                                (declare (ignore c))
 472                                (invoke-restart 'output-replacement replacement)))
 473                             (octets-encoding-error
 474                              (lambda (c) (use-value replacement c)))
 475                             (octet-decoding-error
 476                              (lambda (c) (use-value replacement c))))
 477                          (apply fun rest)))))))))
 478     (typecase external-format
 479       (keyword (keyword-external-format external-format))
 480       ((cons keyword)
 481        (let ((entry (keyword-external-format (car external-format)))
 482              (replacement (getf (cdr external-format) :replacement)))
 483          (if replacement
 484              (replacement-handlerify entry replacement)
 485              entry))))))
 486
 487 (defun unintern-init-only-stuff ()
 488   (let ((this-package (find-package "SB-IMPL")))
 489     (dolist (s '(char-class char-class2 char-class3
 490                  steve-splice))
 491       (unintern s this-package))
 492     (flet ((ends-with-p (s1 s2)
 493              (let ((diff (- (length s1) (length s2))))
 494                (and (>= diff 0) (string= s1 s2 :start1 diff)))))
 495       (do-symbols (s this-package)
 496         (let ((name (symbol-name s)))
 497           (if (and (macro-function s)
 498                    (eql (mismatch name "DEFINE-") 7)
 499                    (or (ends-with-p name "->STRING")
 500                        (ends-with-p name "->STRING*")))
 501               (unintern s this-package)))))))