external-format.impure.lisp

   1 ;;;; This file is for testing external-format functionality, using
   2 ;;;; test machinery which might have side effects (e.g.  executing
   3 ;;;; DEFUN, writing files).  Note that the tests here reach into
   4 ;;;; unexported functionality, and should not be used as a guide for
   5 ;;;; users.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; While most of SBCL is derived from the CMU CL system, the test
  11 ;;;; files (like this one) were written from scratch after the fork
  12 ;;;; from CMU CL.
  13 ;;;;
  14 ;;;; This software is in the public domain and is provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  16 ;;;; more information.
  17
  18 (defmacro do-external-formats ((xf &optional result) &body body)
  19   (let ((nxf (gensym)))
  20     `(loop for ,nxf being the hash-values of sb-impl::*external-formats*
  21         do (let ((,xf (first (sb-impl::ef-names ,nxf))))
  22              ,@body))))
  23
  24 (defvar *test-path* "external-format-test.tmp")
  25
  26 (with-test (:name :end-of-file)
  27   (do-external-formats (xf)
  28     (with-open-file (s #-win32 "/dev/null" #+win32 "nul" :direction :input :external-format xf)
  29       (assert (eq (read-char s nil s) s)))))
  30
  31 ;;; Test standard character read-write equivalency over all external formats.
  32 (macrolet
  33     ((frob ()
  34        (let ((tests nil))
  35          (do-external-formats (xf)
  36            (pushnew `(with-test (:name (:standard-character :read-write-equivalency ,xf))
  37                        (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
  38                          (with-open-file (s *test-path* :direction :output
  39                                             :if-exists :supersede :external-format ,xf)
  40                            (loop for character across standard-characters
  41                                  do (write-char character s)))
  42                          (with-open-file (s *test-path* :direction :input
  43                                             :external-format ,xf)
  44                            (loop for character across standard-characters
  45                                  do (let ((got (read-char s)))
  46                                       (unless (eql character got)
  47                                         (error "wanted ~S, got ~S" character got)))))))
  48                     tests :key #'cadr :test #'equal))
  49          `(progn ,@tests))))
  50   (frob))
  51
  52 (delete-file *test-path*)
  53 #-sb-unicode
  54 (progn
  55   (test-util:report-test-status)
  56   (sb-ext:exit :code 104))
  57
  58 ;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with
  59 ;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are
  60 ;;; 4096 wide.
  61 (dotimes (width-1 4)
  62   (let ((character (code-char (elt '(1 #x81 #x801 #x10001) width-1))))
  63     (dotimes (offset (+ width-1 1))
  64       (with-open-file (s *test-path* :direction :output
  65                        :if-exists :supersede :external-format :utf-8)
  66         (dotimes (n offset)
  67           (write-char #\a s))
  68         (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
  69           (write-char character s)))
  70       (with-open-file (s *test-path* :direction :input
  71                        :external-format :utf-8)
  72         (dotimes (n offset)
  73           (assert (eql (read-char s) #\a)))
  74         (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
  75           (let ((got (read-char s)))
  76             (unless (eql got character)
  77               (error "wanted ~S, got ~S (~S)" character got n))))
  78         (assert (eql (read-char s nil s) s))))))
  79
  80 ;;; Test character decode restarts.
  81 (with-open-file (s *test-path* :direction :output
  82                  :if-exists :supersede :element-type '(unsigned-byte 8))
  83   (write-byte 65 s)
  84   (write-byte 66 s)
  85   (write-byte #xe0 s)
  86   (write-byte 67 s))
  87 (with-open-file (s *test-path* :direction :input
  88                  :external-format :utf-8)
  89   (let ((count 0))
  90     (handler-bind
  91         ((sb-int:character-decoding-error #'(lambda (decoding-error)
  92                                               (declare (ignore decoding-error))
  93                                               (when (> (incf count) 1)
  94                                                 (error "too many errors"))
  95                                               (invoke-restart
  96                                                'sb-int:attempt-resync))))
  97       (assert (equal (read-line s nil s) "ABC"))
  98       (assert (equal (read-line s nil s) s)))))
  99 (with-open-file (s *test-path* :direction :input
 100                  :external-format :utf-8)
 101   (let ((count 0))
 102     (handler-bind
 103         ((sb-int:character-decoding-error #'(lambda (decoding-error)
 104                                               (declare (ignore decoding-error))
 105                                               (when (> (incf count) 1)
 106                                                 (error "too many errors"))
 107                                               (invoke-restart
 108                                                'sb-int:force-end-of-file))))
 109       (assert (equal (read-line s nil s) "AB"))
 110       (setf count 0)
 111       (assert (equal (read-line s nil s) s)))))
 112
 113 ;;; And again with more data to account for buffering (this was briefly)
 114 ;;; broken in early 0.9.6.
 115 (with-open-file (s *test-path* :direction :output
 116                  :if-exists :supersede :element-type '(unsigned-byte 8))
 117   (let ((a (make-array 50
 118                        :element-type '(unsigned-byte 64)
 119                        :initial-contents (map 'list #'char-code
 120                                               "1234567890123456789012345678901234567890123456789."))))
 121     (setf (aref a 49) (char-code #\Newline))
 122     (dotimes (i 40)
 123       (write-sequence a s))
 124     (write-byte #xe0 s)
 125     (dotimes (i 40)
 126       (write-sequence a s))))
 127 (with-test (:name (:character-decode-large :attempt-resync)
 128                   :fails-on :win32)
 129   (with-open-file (s *test-path* :direction :input
 130                      :external-format :utf-8)
 131     (let ((count 0))
 132       (handler-bind
 133           ((sb-int:character-decoding-error (lambda (decoding-error)
 134                                               (declare (ignore decoding-error))
 135                                               (when (> (incf count) 1)
 136                                                 (error "too many errors"))
 137                                               (invoke-restart
 138                                                'sb-int:attempt-resync)))
 139            ;; The failure mode is an infinite loop, add a timeout to
 140            ;; detetct it.
 141            (sb-ext:timeout (lambda () (error "Timeout"))))
 142         (sb-ext:with-timeout 5
 143           (dotimes (i 80)
 144             (assert (equal (read-line s nil s)
 145                            "1234567890123456789012345678901234567890123456789"))))))))
 146
 147 (with-test (:name (:character-decode-large :force-end-of-file))
 148   (with-open-file (s *test-path* :direction :input
 149                      :external-format :utf-8)
 150     (let ((count 0))
 151       (handler-bind
 152           ((sb-int:character-decoding-error (lambda (decoding-error)
 153                                               (declare (ignore decoding-error))
 154                                               (when (> (incf count) 1)
 155                                                 (error "too many errors"))
 156                                               (invoke-restart
 157                                                'sb-int:force-end-of-file)))
 158            ;; The failure mode is an infinite loop, add a timeout to detetct it.
 159            (sb-ext:timeout (lambda () (error "Timeout"))))
 160         (sb-ext:with-timeout 5
 161           (dotimes (i 40)
 162             (assert (equal (read-line s nil s)
 163                            "1234567890123456789012345678901234567890123456789")))
 164           (setf count 0)
 165           (assert (equal (read-line s nil s) s)))))))
 166
 167 ;;; Test character encode restarts.
 168 (with-open-file (s *test-path* :direction :output
 169                  :if-exists :supersede :external-format :latin-1)
 170   (handler-bind
 171       ((sb-int:character-encoding-error #'(lambda (encoding-error)
 172                                             (declare (ignore encoding-error))
 173                                             (invoke-restart
 174                                              'sb-impl::output-nothing))))
 175     (write-char #\A s)
 176     (write-char #\B s)
 177     (write-char (code-char 322) s)
 178     (write-char #\C s)))
 179 (with-open-file (s *test-path* :direction :input
 180                  :external-format :latin-1)
 181   (assert (equal (read-line s nil s) "ABC"))
 182   (assert (equal (read-line s nil s) s)))
 183
 184 (with-open-file (s *test-path* :direction :output
 185                  :if-exists :supersede :external-format :latin-1)
 186   (handler-bind
 187       ((sb-int:character-encoding-error #'(lambda (encoding-error)
 188                                             (declare (ignore encoding-error))
 189                                             (invoke-restart
 190                                              'sb-impl::output-nothing))))
 191     (let ((string (make-array 4 :element-type 'character
 192                               :initial-contents `(#\A #\B ,(code-char 322)
 193                                                       #\C))))
 194       (write-string string s))))
 195 (with-open-file (s *test-path* :direction :input
 196                  :external-format :latin-1)
 197   (assert (equal (read-line s nil s) "ABC"))
 198   (assert (equal (read-line s nil s) s)))
 199
 200 ;;; Test skipping character-decode-errors in comments.
 201 (let ((s (open "external-format-test.lisp" :direction :output
 202                :if-exists :supersede :external-format :latin-1)))
 203   (unwind-protect
 204        (progn
 205          (write-string ";;; ABCD" s)
 206          (write-char (code-char 233) s)
 207          (terpri s)
 208          (close s)
 209          (compile-file "external-format-test.lisp" :external-format :utf-8))
 210     (delete-file s)
 211     (let ((p (probe-file (compile-file-pathname "external-format-test.lisp"))))
 212       (when p
 213         (delete-file p)))))
 214
 215 \f
 216 ;;;; KOI8-R external format
 217 (with-open-file (s *test-path* :direction :output
 218                  :if-exists :supersede :external-format :koi8-r)
 219   (write-char (code-char #xB0) s)
 220   (assert (eq
 221            (handler-case
 222                (progn
 223                  (write-char (code-char #xBAAD) s)
 224                  :bad)
 225              (sb-int:character-encoding-error ()
 226                :good))
 227            :good)))
 228 (with-open-file (s *test-path* :direction :input
 229                  :element-type '(unsigned-byte 8))
 230   (let ((byte (read-byte s)))
 231     (assert (= (eval byte) #x9C))))
 232 (with-open-file (s *test-path* :direction :input
 233                  :external-format :koi8-r)
 234   (let ((char (read-char s)))
 235     (assert (= (char-code (eval char)) #xB0))))
 236 (delete-file *test-path*)
 237
 238 (let* ((koi8-r-codes (coerce '(240 210 201 215 197 212 33) '(vector (unsigned-byte 8))))
 239        (uni-codes #(1055 1088 1080 1074 1077 1090 33))
 240
 241        (string (octets-to-string koi8-r-codes :external-format :koi8-r))
 242        (uni-decoded (map 'vector #'char-code string)))
 243   (assert (equalp (map 'vector #'char-code (octets-to-string koi8-r-codes :external-format :koi8-r))
 244                   uni-codes))
 245   (assert (equalp (string-to-octets (map 'string #'code-char uni-codes) :external-format :koi8-r)
 246                   koi8-r-codes)))
 247 \f
 248 ;;; tests of FILE-STRING-LENGTH
 249 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
 250   (do-external-formats (xf)
 251     (with-open-file (s *test-path* :direction :output
 252                        :external-format xf)
 253       (loop for x across standard-characters
 254             for position = (file-position s)
 255             for char-length = (file-string-length s x)
 256             do (write-char x s)
 257             do (assert (= (file-position s) (+ position char-length))))
 258       (let ((position (file-position s))
 259             (string-length (file-string-length s standard-characters)))
 260         (write-string standard-characters s)
 261         (assert (= (file-position s) (+ position string-length)))))
 262     (delete-file *test-path*)))
 263
 264 (let ((char-codes '(0 1 255 256 511 512 1023 1024 2047 2048 4095 4096
 265                     8191 8192 16383 16384 32767 32768 65535 65536 131071
 266                     131072 262143 262144)))
 267   (with-open-file (s *test-path* :direction :output
 268                      :external-format :utf-8)
 269     (dolist (code char-codes)
 270       (let* ((char (code-char code))
 271              (position (file-position s))
 272              (char-length (file-string-length s char)))
 273         (write-char char s)
 274         (assert (= (file-position s) (+ position char-length)))))
 275     (let* ((string (map 'string #'code-char char-codes))
 276            (position (file-position s))
 277            (string-length (file-string-length s string)))
 278       (write-string string s)
 279       (assert (= (file-position s) (+ position string-length))))))
 280 \f
 281
 282 ;;; See sbcl-devel "Subject: Bug in FILE-POSITION on UTF-8-encoded files"
 283 ;;; by Lutz Euler on 2006-03-05 for more details.
 284 (with-test (:name (:file-position :utf-8))
 285   (let ((path *test-path*))
 286     (with-open-file (s path
 287                        :direction :output
 288                        :if-exists :supersede
 289                        :element-type '(unsigned-byte 8))
 290       ;; Write #\*, encoded in UTF-8, to the file.
 291       (write-byte 42 s)
 292       ;; Append #\adiaeresis, encoded in UTF-8, to the file.
 293       (write-sequence '(195 164) s))
 294     (with-open-file (s path :external-format :utf-8)
 295       (read-char s)
 296       (let ((pos (file-position s))
 297             (char (read-char s)))
 298         (format t "read character with code ~a successfully from file position ~a~%"
 299                 (char-code char) pos)
 300         (file-position s pos)
 301         (format t "set file position back to ~a, trying to read-char again~%" pos)
 302         (let ((new-char (read-char s)))
 303           (assert (char= char new-char)))))
 304     (values)))
 305 (delete-file *test-path*)
 306
 307 ;;; We used to call STREAM-EXTERNAL-FORMAT on the stream in the error
 308 ;;; when printing a coding error, but that didn't work if the stream
 309 ;;; was closed by the time the error was printed.  See sbcl-devel
 310 ;;; "Subject: Printing coding errors for closed streams" by Zach Beane
 311 ;;; on 2008-10-16 for more info.
 312 (with-test (:name (:character-coding-error-stream-external-format))
 313   (flet ((first-file-character ()
 314            (with-open-file (stream *test-path* :external-format :utf-8)
 315              (read-char stream))))
 316     (with-open-file (stream *test-path*
 317                             :direction :output
 318                             :if-exists :supersede
 319                             :element-type '(unsigned-byte 8))
 320       (write-byte 192 stream))
 321     (princ-to-string (nth-value 1 (ignore-errors (first-file-character))))))
 322 (delete-file *test-path*)
 323
 324 ;;; External format support in SB-ALIEN
 325
 326 (with-test (:name (:sb-alien :vanilla))
 327   (define-alien-routine strdup c-string (str c-string))
 328   (assert (equal "foo" (strdup "foo"))))
 329
 330 (with-test (:name (:sb-alien :utf-8 :utf-8))
 331   (define-alien-routine strdup (c-string :external-format :utf-8)
 332     (str (c-string :external-format :utf-8)))
 333   (assert (equal "foo" (strdup "foo"))))
 334
 335 (with-test (:name (:sb-alien :latin-1 :utf-8))
 336   (define-alien-routine strdup (c-string :external-format :latin-1)
 337     (str (c-string :external-format :utf-8)))
 338   (assert (= (length (strdup (string (code-char 246))))
 339              2)))
 340
 341 (with-test (:name (:sb-alien :utf-8 :latin-1))
 342   (define-alien-routine strdup (c-string :external-format :utf-8)
 343     (str (c-string :external-format :latin-1)))
 344   (assert (equal (string (code-char 228))
 345                  (strdup (concatenate 'string
 346                                       (list (code-char 195))
 347                                       (list (code-char 164)))))))
 348
 349 (with-test (:name (:sb-alien :ebcdic :ebcdic))
 350   (define-alien-routine strdup (c-string :external-format :ebcdic-us)
 351     (str (c-string :external-format :ebcdic-us)))
 352   (assert (equal "foo" (strdup "foo"))))
 353
 354 (with-test (:name (:sb-alien :latin-1 :ebcdic))
 355   (define-alien-routine strdup (c-string :external-format :latin-1)
 356     (str (c-string :external-format :ebcdic-us)))
 357   (assert (not (equal "foo" (strdup "foo")))))
 358
 359 (with-test (:name (:sb-alien :simple-base-string))
 360   (define-alien-routine strdup (c-string :external-format :ebcdic-us
 361                                          :element-type base-char)
 362     (str (c-string :external-format :ebcdic-us)))
 363   (assert (typep (strdup "foo") 'simple-base-string)))
 364
 365 (with-test (:name (:input-replacement :at-end-of-file))
 366   (dotimes (i 256)
 367     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 368       (write-byte i s))
 369     (handler-bind ((sb-int:character-decoding-error
 370                     (lambda (c)
 371                       (invoke-restart 'sb-impl::input-replacement #\?))))
 372       (with-open-file (s *test-path* :external-format :utf-8)
 373         (cond
 374           ((char= (read-char s) #\?)
 375            (assert (or (= i (char-code #\?)) (> i 127))))
 376           (t (assert (and (not (= i (char-code #\?))) (< i 128)))))))))
 377
 378 (with-test (:name (:unibyte-invalid-codepoints :cp857))
 379   (dotimes (i 256)
 380     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 381       (write-byte i s))
 382     (with-open-file (s *test-path* :external-format :cp857)
 383       (handler-case (read-char s)
 384         (error () (assert (member i '(#xd5 #xe7 #xf2))))
 385         (:no-error (char) (assert (not (member i '(#xd5 #xe7 #xf2)))))))))
 386 (delete-file *test-path*)
 387
 388 (with-test (:name (:unibyte-input-replacement :cp857))
 389   (dotimes (i 256)
 390     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 391       (write-byte i s))
 392     (with-open-file (s *test-path* :external-format '(:cp857 :replacement #\?))
 393       (let ((char (read-char s)))
 394         (cond
 395           ((eq char #\?)
 396            (assert (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))
 397           (t (assert (not (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))))))))
 398 (delete-file *test-path*)
 399
 400 (with-test (:name (:unibyte-output-replacement :cp857))
 401   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:cp857 :replacement #\?))
 402     (dotimes (i 256)
 403       (write-char (code-char i) s)))
 404   (with-open-file (s *test-path* :external-format '(:cp857))
 405     (let ((string (make-string 256)))
 406       (read-sequence string s)
 407       (dotimes (i 128)
 408         (assert (= (char-code (char string i)) i)))
 409       (assert (= 38 (count #\? string :start 128))))))
 410 (delete-file *test-path*)
 411
 412 (with-test (:name (:unibyte-input-replacement :ascii))
 413   (dotimes (i 256)
 414     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 415       (write-byte i s))
 416     (with-open-file (s *test-path* :external-format '(:ascii :replacement #\?))
 417       (let ((char (read-char s)))
 418         (cond
 419           ((eq char #\?)
 420            (assert (or (= i (char-code #\?)) (> i 127))))
 421           (t (assert (and (< i 128) (not (= i (char-code #\?)))))))))))
 422 (delete-file *test-path*)
 423
 424 (with-test (:name (:unibyte-output-replacement :ascii))
 425   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ascii :replacement #\?))
 426     (dotimes (i 256)
 427       (write-char (code-char i) s)))
 428   (with-open-file (s *test-path* :external-format '(:ascii))
 429     (let ((string (make-string 256)))
 430       (read-sequence string s)
 431       (dotimes (i 128)
 432         (assert (= (char-code (char string i)) i)))
 433       (assert (= 128 (count #\? string :start 128))))))
 434 (delete-file *test-path*)
 435
 436 (with-test (:name (:unibyte-input-replacement :latin-1))
 437   (dotimes (i 256)
 438     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 439       (write-byte i s))
 440     (with-open-file (s *test-path* :external-format '(:latin-1 :replacement #\?))
 441       (let ((char (read-char s)))
 442         (assert (= (char-code char) i))))))
 443 (delete-file *test-path*)
 444
 445 (with-test (:name (:unibyte-output-replacement :latin-1))
 446   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-1 :replacement #\?))
 447     (dotimes (i 257)
 448       (write-char (code-char i) s)))
 449   (with-open-file (s *test-path* :external-format '(:latin-1))
 450     (let ((string (make-string 257)))
 451       (read-sequence string s)
 452       (dotimes (i 256)
 453         (assert (= (char-code (char string i)) i)))
 454       (assert (char= #\? (char string 256))))))
 455 (delete-file *test-path*)
 456 \f
 457 ;;; latin-2 tests
 458 (with-test (:name (:unibyte-input-replacement :latin-2))
 459   (dotimes (i 256)
 460     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 461       (write-byte i s))
 462     (with-open-file (s *test-path* :external-format '(:latin-2 :replacement #\?))
 463       (let ((char (read-char s)))
 464         (cond
 465           ((< i #xa1) (assert (= (char-code char) i)))
 466           ;; FIXME: more tests
 467           )))))
 468 (delete-file *test-path*)
 469
 470 (with-test (:name (:unibyte-output-replacement :latin-2))
 471   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-2 :replacement #\?))
 472     (dotimes (i 256)
 473       (write-char (code-char i) s)))
 474   (with-open-file (s *test-path* :external-format '(:latin-2))
 475     (let ((string (make-string 256)))
 476       (read-sequence string s)
 477       (dotimes (i #xa1)
 478         (assert (= (char-code (char string i)) i)))
 479       (assert (= 57 (count #\? string :start #xa1))))))
 480 (delete-file *test-path*)
 481 \f
 482 ;;; latin-3 tests
 483 (with-test (:name (:unibyte-input-replacement :latin-3))
 484   (dotimes (i 256)
 485     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 486       (write-byte i s))
 487     (with-open-file (s *test-path* :external-format '(:latin-3 :replacement #\?))
 488       (let ((char (read-char s)))
 489         (cond
 490           ((eq char #\?)
 491            (assert #1=(or (= i (char-code #\?))
 492                           (member i '(#xa5 #xae #xbe #xc3 #xd0 #xe3 #xf0)))))
 493           (t (assert (not #1#))))))))
 494 (delete-file *test-path*)
 495
 496 (with-test (:name (:unibyte-output-replacement :latin-3))
 497   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-3 :replacement #\?))
 498     (dotimes (i 256)
 499       (write-char (code-char i) s)))
 500   (with-open-file (s *test-path* :external-format '(:latin-3))
 501     (let ((string (make-string 256)))
 502       (read-sequence string s)
 503       (dotimes (i #xa1)
 504         (assert (= (char-code (char string i)) i)))
 505       (assert (= 35 (count #\? string :start #xa1))))))
 506 (delete-file *test-path*)
 507 \f
 508 ;;; latin-4 tests
 509 (with-test (:name (:unibyte-input-replacement :latin-4))
 510   (dotimes (i 256)
 511     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 512       (write-byte i s))
 513     (with-open-file (s *test-path* :external-format '(:latin-4 :replacement #\?))
 514       (let ((char (read-char s)))
 515         (cond
 516           ((< i #xa1) (assert (= (char-code char) i)))
 517           ;; FIXME: more tests
 518           )))))
 519 (delete-file *test-path*)
 520
 521 (with-test (:name (:unibyte-output-replacement :latin-4))
 522   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-4 :replacement #\?))
 523     (dotimes (i 256)
 524       (write-char (code-char i) s)))
 525   (with-open-file (s *test-path* :external-format '(:latin-4))
 526     (let ((string (make-string 256)))
 527       (read-sequence string s)
 528       (dotimes (i #xa1)
 529         (assert (= (char-code (char string i)) i)))
 530       (assert (= 50 (count #\? string :start #xa1))))))
 531 (delete-file *test-path*)
 532 \f
 533 ;;; iso-8859-5 tests
 534 (with-test (:name (:unibyte-input-replacement :iso-8859-5))
 535   (dotimes (i 256)
 536     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 537       (write-byte i s))
 538     (with-open-file (s *test-path* :external-format '(:iso-8859-5 :replacement #\?))
 539       (let ((char (read-char s)))
 540         (cond
 541           ((= (char-code char) i)
 542            (assert (or (< i #xa1) (= i #xad))))
 543           (t (assert (and (>= i #xa1) (/= i #xad)))))))))
 544 (delete-file *test-path*)
 545
 546 (with-test (:name (:unibyte-output-replacement :iso-8859-5))
 547   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-5 :replacement #\?))
 548     (dotimes (i 256)
 549       (write-char (code-char i) s)))
 550   (with-open-file (s *test-path* :external-format '(:iso-8859-5))
 551     (let ((string (make-string 256)))
 552       (read-sequence string s)
 553       (dotimes (i #xa1)
 554         (assert (= (char-code (char string i)) i)))
 555       (assert (= 93 (count #\? string :start #xa1))))))
 556 (delete-file *test-path*)
 557 \f
 558 ;;; iso-8859-6 tests
 559 (with-test (:name (:unibyte-input-replacement :iso-8859-6))
 560   (dotimes (i 256)
 561     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 562       (write-byte i s))
 563     (with-open-file (s *test-path* :external-format '(:iso-8859-6 :replacement #\?))
 564       (let ((char (read-char s)))
 565         (cond
 566           ((eq char #\?)
 567            (assert #1=(or (= i (char-code #\?))
 568                           (<= #xa1 i #xa3) (<= #xa5 i #xab) (<= #xae i #xba)
 569                           (<= #xbc i #xbe) (= i #xc0) (<= #xdb i #xdf)
 570                           (<= #xf3 i))))
 571           (t (assert (not #1#))))))))
 572 (delete-file *test-path*)
 573
 574 (with-test (:name (:unibyte-output-replacement :iso-8859-6))
 575   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-6 :replacement #\?))
 576     (dotimes (i 256)
 577       (write-char (code-char i) s)))
 578   (with-open-file (s *test-path* :external-format '(:iso-8859-6))
 579     (let ((string (make-string 256)))
 580       (read-sequence string s)
 581       (dotimes (i #xa1)
 582         (assert (= (char-code (char string i)) i)))
 583       (assert (= 93 (count #\? string :start #xa1))))))
 584 (delete-file *test-path*)
 585 \f
 586 ;;; iso-8859-7 tests
 587 (with-test (:name (:unibyte-input-replacement :iso-8859-7))
 588   (dotimes (i 256)
 589     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 590       (write-byte i s))
 591     (with-open-file (s *test-path* :external-format '(:iso-8859-7 :replacement #\?))
 592       (let ((char (read-char s)))
 593         (cond
 594           ((eq char #\?)
 595            (assert #1=(or (= i (char-code #\?))
 596                           (member i '(#xa4 #xa5 #xaa #xae #xd2 #xff)))))
 597           (t (assert (not #1#))))))))
 598 (delete-file *test-path*)
 599
 600 (with-test (:name (:unibyte-output-replacement :iso-8859-7))
 601   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-7 :replacement #\?))
 602     (dotimes (i 256)
 603       (write-char (code-char i) s)))
 604   (with-open-file (s *test-path* :external-format '(:iso-8859-7))
 605     (let ((string (make-string 256)))
 606       (read-sequence string s)
 607       (dotimes (i #xa1)
 608         (assert (= (char-code (char string i)) i)))
 609       (assert (= 80 (count #\? string :start #xa1))))))
 610 (delete-file *test-path*)
 611 \f
 612 ;;; iso-8859-8 tests
 613 (with-test (:name (:unibyte-input-replacement :iso-8859-8))
 614   (dotimes (i 256)
 615     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 616       (write-byte i s))
 617     (with-open-file (s *test-path* :external-format '(:iso-8859-8 :replacement #\?))
 618       (let ((char (read-char s)))
 619         (cond
 620           ((eq char #\?)
 621            (assert #1=(or (= i (char-code #\?))
 622                           (= i #xa1) (<= #xbf i #xde) (>= i #xfb))))
 623           (t (assert (not  #1#))))))))
 624 (delete-file *test-path*)
 625
 626 (with-test (:name (:unibyte-output-replacement :iso-8859-8))
 627   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-8 :replacement #\?))
 628     (dotimes (i 256)
 629       (write-char (code-char i) s)))
 630   (with-open-file (s *test-path* :external-format '(:iso-8859-8))
 631     (let ((string (make-string 256)))
 632       (read-sequence string s)
 633       (dotimes (i #xa1)
 634         (assert (= (char-code (char string i)) i)))
 635       (assert (= 67 (count #\? string :start #xa1))))))
 636 (delete-file *test-path*)
 637 \f
 638 ;;; latin-5 tests
 639 (with-test (:name (:unibyte-input-replacement :latin-5))
 640   (dotimes (i 256)
 641     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 642       (write-byte i s))
 643     (with-open-file (s *test-path* :external-format '(:latin-5 :replacement #\?))
 644       (let ((char (read-char s)))
 645         (assert (or (and (= (char-code char) i)
 646                          (not (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))))
 647                     (and (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))
 648                          (not (char= char #\?)))))))))
 649 (delete-file *test-path*)
 650
 651 (with-test (:name (:unibyte-output-replacement :latin-5))
 652   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-5 :replacement #\?))
 653     (dotimes (i 256)
 654       (write-char (code-char i) s)))
 655   (with-open-file (s *test-path* :external-format '(:latin-5))
 656     (let ((string (make-string 256)))
 657       (read-sequence string s)
 658       (dotimes (i #xd0)
 659         (assert (= (char-code (char string i)) i)))
 660       (assert (= 6 (count #\? string :start #xd0))))))
 661 (delete-file *test-path*)
 662 \f
 663 ;;; latin-6 tests
 664 (with-test (:name (:unibyte-input-replacement :latin-6))
 665   (dotimes (i 256)
 666     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 667       (write-byte i s))
 668     (with-open-file (s *test-path* :external-format '(:latin-6 :replacement #\?))
 669       (let ((char (read-char s)))
 670         (assert (or (= (char-code char) i)
 671                     (and (<= #xa1 i #xff)
 672                          (not (char= char #\?)))))))))
 673 (delete-file *test-path*)
 674
 675 (with-test (:name (:unibyte-output-replacement :latin-6))
 676   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-6 :replacement #\?))
 677     (dotimes (i 256)
 678       (write-char (code-char i) s)))
 679   (with-open-file (s *test-path* :external-format '(:latin-6))
 680     (let ((string (make-string 256)))
 681       (read-sequence string s)
 682       (dotimes (i #xa1)
 683         (assert (= (char-code (char string i)) i)))
 684       (assert (= 46 (count #\? string :start #xa1))))))
 685 (delete-file *test-path*)
 686 \f
 687 ;;; iso-8859-11 tests
 688 (with-test (:name (:unibyte-input-replacement :iso-8859-11))
 689   (dotimes (i 256)
 690     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 691       (write-byte i s))
 692     (with-open-file (s *test-path* :external-format '(:iso-8859-11 :replacement #\?))
 693       (let ((char (read-char s)))
 694         (cond
 695           ((eq char #\?)
 696            (assert (member i #1=`(,(char-code #\?) #xdb #xdc #xdd #xde #xfc #xfd #xfe #xff))))
 697           (t (assert (not (member i #1#)))))))))
 698 (delete-file *test-path*)
 699
 700 (with-test (:name (:unibyte-output-replacement :iso-8859-11))
 701   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-11 :replacement #\?))
 702     (dotimes (i 256)
 703       (write-char (code-char i) s)))
 704   (with-open-file (s *test-path* :external-format '(:iso-8859-11))
 705     (let ((string (make-string 256)))
 706       (read-sequence string s)
 707       (dotimes (i #xa1)
 708         (assert (= (char-code (char string i)) i)))
 709       (assert (= 95 (count #\? string :start #xa1))))))
 710 (delete-file *test-path*)
 711 \f
 712 ;;; latin-7 tests
 713 (with-test (:name (:unibyte-input-replacement :latin-7))
 714   (dotimes (i 256)
 715     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 716       (write-byte i s))
 717     (with-open-file (s *test-path* :external-format '(:latin-7 :replacement #\?))
 718       (let ((char (read-char s)))
 719         (assert (or (= (char-code char) i)
 720                     (and (<= #xa1 i #xff)
 721                          (not (char= char #\?)))))))))
 722 (delete-file *test-path*)
 723
 724 (with-test (:name (:unibyte-output-replacement :latin-7))
 725   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-7 :replacement #\?))
 726     (dotimes (i 256)
 727       (write-char (code-char i) s)))
 728   (with-open-file (s *test-path* :external-format '(:latin-7))
 729     (let ((string (make-string 256)))
 730       (read-sequence string s)
 731       (dotimes (i #xa1)
 732         (assert (= (char-code (char string i)) i)))
 733       (dolist (i '(#xd8 #xc6 #xf8 #xe6))
 734         (assert (char/= (char string i) #\?)))
 735       (assert (= 52 (count #\? string :start #xa1))))))
 736 (delete-file *test-path*)
 737 \f
 738 ;;; latin-8 tests
 739 (with-test (:name (:unibyte-input-replacement :latin-8))
 740   (dotimes (i 256)
 741     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 742       (write-byte i s))
 743     (with-open-file (s *test-path* :external-format '(:latin-8 :replacement #\?))
 744       (let ((char (read-char s)))
 745         (assert (or (= (char-code char) i)
 746                     (and (<= #xa1 i #xfe)
 747                          (not (char= char #\?)))))))))
 748 (delete-file *test-path*)
 749
 750 (with-test (:name (:unibyte-output-replacement :latin-8))
 751   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-8 :replacement #\?))
 752     (dotimes (i 256)
 753       (write-char (code-char i) s)))
 754   (with-open-file (s *test-path* :external-format '(:latin-8))
 755     (let ((string (make-string 256)))
 756       (read-sequence string s)
 757       (dotimes (i #xa1)
 758         (assert (= (char-code (char string i)) i)))
 759       (assert (= 31 (count #\? string :start #xa1))))))
 760 (delete-file *test-path*)
 761 \f
 762 ;;; latin-9 tests
 763 (with-test (:name (:unibyte-input-replacement :latin-9))
 764   (dotimes (i 256)
 765     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 766       (write-byte i s))
 767     (with-open-file (s *test-path* :external-format '(:latin-9 :replacement #\?))
 768       (let ((char (read-char s)))
 769         (assert (or (and (= (char-code char) i)
 770                          (not (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))))
 771                     (and (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))
 772                          (not (char= char #\?)))))))))
 773 (delete-file *test-path*)
 774
 775 (with-test (:name (:unibyte-output-replacement :latin-9))
 776   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-9 :replacement #\?))
 777     (dotimes (i 256)
 778       (write-char (code-char i) s)))
 779   (with-open-file (s *test-path* :external-format '(:latin-9))
 780     (let ((string (make-string 256)))
 781       (read-sequence string s)
 782       (dotimes (i #xa4)
 783         (assert (= (char-code (char string i)) i)))
 784       (assert (= 8 (count #\? string :start #xa4))))))
 785 (delete-file *test-path*)
 786 \f
 787 ;;; koi8-r tests
 788 (with-test (:name (:unibyte-input-replacement :koi8-r))
 789   (dotimes (i 256)
 790     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 791       (write-byte i s))
 792     (with-open-file (s *test-path* :external-format '(:koi8-r :replacement #\?))
 793       (let ((char (read-char s)))
 794         (cond ((= (char-code char) i)
 795                (assert (< i 128)))
 796               (t (assert (> i 127))))))))
 797 (delete-file *test-path*)
 798
 799 (with-test (:name (:unibyte-output-replacement :koi8-r))
 800   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-r :replacement #\?))
 801     (dotimes (i 256)
 802       (write-char (code-char i) s)))
 803   (with-open-file (s *test-path* :external-format '(:koi8-r))
 804     (let ((string (make-string 256)))
 805       (read-sequence string s)
 806       (dotimes (i #x80)
 807         (assert (= (char-code (char string i)) i)))
 808       (assert (= 122 (count #\? string :start #x80))))))
 809 (delete-file *test-path*)
 810 \f
 811 ;;; koi8-u tests
 812 (with-test (:name (:unibyte-input-replacement :koi8-u))
 813   (dotimes (i 256)
 814     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 815       (write-byte i s))
 816     (with-open-file (s *test-path* :external-format '(:koi8-u :replacement #\?))
 817       (let ((char (read-char s)))
 818         (cond ((= (char-code char) i)
 819                (assert (< i 128)))
 820               (t (assert (> i 127))))))))
 821 (delete-file *test-path*)
 822
 823 (with-test (:name (:unibyte-output-replacement :koi8-u))
 824   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-u :replacement #\?))
 825     (dotimes (i 256)
 826       (write-char (code-char i) s)))
 827   (with-open-file (s *test-path* :external-format '(:koi8-u))
 828     (let ((string (make-string 256)))
 829       (read-sequence string s)
 830       (dotimes (i #x80)
 831         (assert (= (char-code (char string i)) i)))
 832       (assert (= 122 (count #\? string :start #x80))))))
 833 (delete-file *test-path*)
 834 \f
 835 ;;; x-mac-cyrillic tests
 836 (with-test (:name (:unibyte-input-replacement :x-mac-cyrillic))
 837   (dotimes (i 256)
 838     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 839       (write-byte i s))
 840     (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic :replacement #\?))
 841       (let ((char (read-char s)))
 842         (cond ((= (char-code char) i)
 843                (assert (or (< i 128) (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))
 844               (t (assert (and (> i 127)
 845                               (not (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))))))))
 846 (delete-file *test-path*)
 847
 848 (with-test (:name (:unibyte-output-replacement :x-mac-cyrillic))
 849   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:x-mac-cyrillic :replacement #\?))
 850     (dotimes (i 256)
 851       (write-char (code-char i) s)))
 852   (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic))
 853     (let ((string (make-string 256)))
 854       (read-sequence string s)
 855       (dotimes (i #x80)
 856         (assert (= (char-code (char string i)) i)))
 857       (assert (= 113 (count #\? string :start #x80))))))
 858 (delete-file *test-path*)
 859 \f
 860 ;;; ucs-2 tests
 861 (with-test (:name (:multibyte :ucs2le))
 862   (let* ((size 120)
 863          (array (map-into (make-array size :element-type '(unsigned-byte 16))
 864                           (lambda () (random #x10000)))))
 865     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 866       (dotimes (i size)
 867         (write-byte (ldb (byte 8 0) (aref array i)) s)
 868         (write-byte (ldb (byte 8 8) (aref array i)) s)))
 869     (with-open-file (s *test-path* :external-format :ucs2le)
 870       (let ((string (make-string size)))
 871         (read-sequence string s)
 872         (dotimes (i size)
 873           (assert (= (char-code (char string i)) (aref array i))))))))
 874
 875 (with-test (:name (:multibyte :ucs2be))
 876   (let* ((size 120)
 877          (array (map-into (make-array size :element-type '(unsigned-byte 16))
 878                           (lambda () (random #x10000)))))
 879     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 880       (dotimes (i size)
 881         (write-byte (ldb (byte 8 8) (aref array i)) s)
 882         (write-byte (ldb (byte 8 0) (aref array i)) s)))
 883     (with-open-file (s *test-path* :external-format :ucs2be)
 884       (let ((string (make-string size)))
 885         (read-sequence string s)
 886         (dotimes (i size)
 887           (assert (= (char-code (char string i)) (aref array i))))))))
 888
 889 (with-test (:name (:multibyte :output-replacement :ucs2le))
 890   (let* ((size 1200)
 891          (string (map-into (make-string size)
 892                            (lambda () (code-char (random #x10000))))))
 893     (setf (char string 0) (code-char #x10001)
 894           (char string (1- size)) (code-char #x10002))
 895     (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2le :replacement #\replacement_character))
 896       (write-string string s))
 897     (with-open-file (s *test-path* :external-format :ucs2le)
 898       (let ((new (make-string size)))
 899         (read-sequence new s)
 900         (assert (char= (char new 0) #\replacement_character))
 901         (assert (char= (char new (1- size)) #\replacement_character))
 902         (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
 903
 904 (with-test (:name (:multibyte :output-replacement :ucs2be))
 905   (let* ((size 1200)
 906          (string (map-into (make-string size)
 907                            (lambda () (code-char (random #x10000))))))
 908     (setf (char string 0) (code-char #x10001)
 909           (char string (1- size)) (code-char #x10002))
 910     (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2be :replacement #\replacement_character))
 911       (write-string string s))
 912     (with-open-file (s *test-path* :external-format :ucs2be)
 913       (let ((new (make-string size)))
 914         (read-sequence new s)
 915         (assert (char= (char new 0) #\replacement_character))
 916         (assert (char= (char new (1- size)) #\replacement_character))
 917         (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
 918
 919 (with-test (:name (:multibyte :input-replacement :ucs4le))
 920   (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
 921     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 922       (write-sequence octets s))
 923     (with-open-file (s *test-path* :external-format '(:ucs4le :replacement #\replacement_character))
 924       (let ((string (read-line s)))
 925         (assert (char= (char string 0) (code-char #x10100)))
 926         (assert (char= (char string 1) #\replacement_character))))))
 927
 928 (with-test (:name (:multibyte :input-replacement :ucs4le))
 929   (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
 930     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 931       (write-sequence octets s))
 932     (with-open-file (s *test-path* :external-format '(:ucs4be :replacement #\replacement_character))
 933       (let ((string (read-line s)))
 934         (assert (char= (char string 0) (code-char #x10100)))
 935         (assert (char= (char string 1) #\replacement_character))))))
 936 \f
 937 ;;; utf tests
 938 (with-test (:name (:utf-16le :roundtrip))
 939   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
 940     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 941                        :external-format :utf-16le)
 942       (write-string string s))
 943     (with-open-file (s *test-path* :external-format :utf-16le)
 944       (assert (string= string (read-line s))))))
 945 (with-test (:name (:utf-16be :roundtrip))
 946   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
 947     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 948                        :external-format :utf-16be)
 949       (write-string string s))
 950     (with-open-file (s *test-path* :external-format :utf-16be)
 951       (assert (string= string (read-line s))))))
 952 (with-test (:name (:utf-16le :encoding-error))
 953   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
 954     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 955                        :external-format '(:utf-16le :replacement #\?))
 956       (write-string string s))
 957     (with-open-file (s *test-path* :external-format :utf-16le)
 958       (assert (string= " ???? " (read-line s))))))
 959 (with-test (:name (:utf-16be :encoding-error))
 960   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
 961     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 962                        :external-format '(:utf-16be :replacement #\?))
 963       (write-string string s))
 964     (with-open-file (s *test-path* :external-format :utf-16be)
 965       (assert (string= " ???? " (read-line s))))))
 966
 967 (with-test (:name (:utf-32le :roundtrip))
 968   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
 969     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 970                        :external-format :utf-32le)
 971       (write-string string s))
 972     (with-open-file (s *test-path* :external-format :utf-32le)
 973       (assert (string= string (read-line s))))))
 974 (with-test (:name (:utf-32be :roundtrip))
 975   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
 976     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 977                        :external-format :utf-32be)
 978       (write-string string s))
 979     (with-open-file (s *test-path* :external-format :utf-32be)
 980       (assert (string= string (read-line s))))))
 981 (with-test (:name (:utf-32le :encoding-error))
 982   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
 983     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 984                        :external-format '(:utf-32le :replacement #\?))
 985       (write-string string s))
 986     (with-open-file (s *test-path* :external-format :utf-32le)
 987       (assert (string= " ???? " (read-line s))))))
 988 (with-test (:name (:utf-32be :encoding-error))
 989   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
 990     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 991                        :external-format '(:utf-32be :replacement #\?))
 992       (write-string string s))
 993     (with-open-file (s *test-path* :external-format :utf-32be)
 994       (assert (string= " ???? " (read-line s))))))
 995
 996 (with-test (:name :invalid-external-format :fails-on :win32)
 997   (labels ((test-error (e)
 998              (assert (typep e 'error))
 999              (unless (equal "Undefined external-format: :BAD-FORMAT"
1000                             (princ-to-string e))
1001                (error "Bad error:~%  ~A" e)))
1002            (test (direction)
1003              (test-error
1004               (handler-case
1005                   (open "/dev/null" :direction direction :external-format :bad-format
1006                         :if-exists :overwrite)
1007                 (error (e) e)))))
1008     (test :input)
1009     (test :output)
1010     (test :io)
1011     (test-error
1012      (handler-case
1013          (run-program "sh" '() :input :stream :external-format :bad-format)
1014        (error (e) e)))
1015     (test-error
1016      (handler-case
1017          (string-to-octets "foobar" :external-format :bad-format)
1018        (error (e) e)))
1019     (test-error
1020      (let ((octets (string-to-octets "foobar" :external-format :latin1)))
1021        (handler-case
1022            (octets-to-string octets :external-format :bad-format)
1023          (error (e) e))))))
1024
1025 (with-test (:name :lp713063)
1026   (with-open-file (f *test-path*
1027                      :direction :output
1028                      :external-format '(:euc-jp :replacement #\?)
1029                      :if-exists :supersede)
1030     (write-string (make-string 3 :initial-element #\horizontal_bar) f))
1031   (assert (equal "???"
1032                  (with-open-file (f *test-path*
1033                                     :direction :input
1034                                     :external-format :euc-jp)
1035                    (read-line f))))
1036   (delete-file *test-path*))
1037 \f
1038 ;;;; success