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