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