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