tests/external-format.pure.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 ;;; I have absolutely no idea what's going on with ppc64 little-endian,
  19 ;;; but this file's realtime is just ridiculous on the test machine
  20 ;;; and it totally dominates the time taken in parallel-exec:
  21 ;;;    big-endian:    real        0m3.265s
  22 ;;;    little-endian: real        2m53.039s
  23 ;;; Whereas, with this one file eliminated on ppc64le, the total wallclock
  24 ;;; time for parallel-exec (with 12 workers) is approximately 94 seconds
  25 ;;; on either machine. What is so horrible about our external-format codecs
  26 ;;; that it antagonizes the little-endian CPU so badly?
  27 #+(and ppc64 little-endian) (invoke-restart 'run-tests::skip-file)
  28
  29 (defmacro do-external-formats ((xf) &body body)
  30   (let ((nxf (gensym))
  31         (xfs (gensym))
  32         (xfsym (gensym)))
  33     `(sb-int:dovector (,nxf sb-impl::*external-formats*)
  34        (when ,nxf
  35          (let* ((,xfs (sb-int:ensure-list ,nxf))
  36                 (,xfsym (first (sb-impl::ef-names (car ,xfs)))))
  37            (dolist (,xf (append (list ,xfsym)
  38                                 (when (find :cr (cdr ,xfs) :key #'caar)
  39                                   (list (list ,xfsym :newline :cr)))
  40                                 (when (find :crlf (cdr ,xfs) :key #'caar)
  41                                   (list (list ,xfsym :newline :crlf)))))
  42              ,@body))))))
  43
  44 (defmacro with-ef-test (options &rest rest)
  45   (let* ((test-name (getf options :name))
  46          (ef-name (car (last test-name))))
  47     (if (sb-impl::get-external-format ef-name)
  48         `(with-test ,options ,@rest)
  49         `(format t "::: INFO: no external format named ~S~%" ',ef-name))))
  50
  51 (defvar *test-path* (scratch-file-name))
  52
  53 (flet ((s2o-file (string &key external-format)
  54          (with-open-file (s *test-path* :direction :output :if-exists :supersede
  55                             :external-format external-format)
  56            (write-sequence string s))
  57          (with-open-file (s *test-path* :direction :input :element-type '(unsigned-byte 8))
  58            (let* ((vector (make-array 10 :initial-element 0))
  59                   (count (read-sequence vector s)))
  60              (subseq vector 0 count))))
  61        (o2s-file (vector &key external-format)
  62          (with-open-file (s *test-path* :direction :output :if-exists :supersede
  63                             :element-type '(unsigned-byte 8))
  64            (write-sequence vector s))
  65          (with-open-file (s *test-path* :direction :input :external-format external-format)
  66            (let* ((string (make-string 10))
  67                   (count (read-sequence string s)))
  68              (subseq string 0 count)))))
  69 (with-test (:name (:external-format-options :ascii :file))
  70   (let ((string "?")
  71         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
  72     (assert (equalp (s2o-file string :external-format :ascii) #(63)))
  73     (assert (equalp (o2s-file octets :external-format :ascii) #(#\Nul #\Nul #\Nul #\Nul)))
  74     (assert (equalp (s2o-file string :external-format '(:ascii :replacement "?"))
  75                     #(63)))
  76     (assert (equalp (o2s-file octets :external-format '(:ascii :replacement "?"))
  77                     #(#\Nul #\Nul #\Nul #\Nul)))
  78     (assert (equalp (s2o-file string :external-format '(:ascii :newline :lf)) #(63)))
  79     (assert (equalp (o2s-file octets :external-format '(:ascii :newline :lf))
  80                     #(#\Nul #\Nul #\Nul #\Nul)))
  81     (assert (equalp (s2o-file string :external-format '(:ascii :newline :crlf)) #(63)))
  82     (assert (equalp (o2s-file octets :external-format '(:ascii :newline :crlf))
  83                     #(#\Nul #\Nul #\Nul #\Nul)))
  84     (assert-error (s2o-file string :external-format '(:ascii :replacment "?")))
  85     (assert-error (o2s-file octets :external-format '(:ascii :replacment "?")))
  86     (assert-error (s2o-file string :external-format '(:ascii :replacement #p"~")))
  87     (assert-error (o2s-file octets :external-format '(:ascii :replacement #p"~")))
  88     (assert-error (s2o-file string :external-format '(:ascii :nelwine :crlf)))
  89     (assert-error (o2s-file octets :external-format '(:ascii :nelwine :crlf)))
  90     (assert-error (s2o-file string :external-format '(:ascii :newline :clrf)))
  91     (assert-error (o2s-file octets :external-format '(:ascii :newline :clrf)))))
  92 (with-test (:name (:external-format-options :ascii :octets))
  93   (let ((string "?")
  94         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
  95     (assert (equalp (string-to-octets string :external-format :ascii) #(63)))
  96     (assert (equalp (octets-to-string octets :external-format :ascii) #(#\Nul #\Nul #\Nul #\Nul)))
  97     (assert (equalp (string-to-octets string :external-format '(:ascii :replacement "?"))
  98                     #(63)))
  99     (assert (equalp (octets-to-string octets :external-format '(:ascii :replacement "?"))
 100                     #(#\Nul #\Nul #\Nul #\Nul)))
 101     (assert (equalp (string-to-octets string :external-format '(:ascii :newline :lf)) #(63)))
 102     (assert (equalp (octets-to-string octets :external-format '(:ascii :newline :lf))
 103                     #(#\Nul #\Nul #\Nul #\Nul)))
 104     (assert (equalp (string-to-octets string :external-format '(:ascii :newline :crlf)) #(63)))
 105     (assert (equalp (octets-to-string octets :external-format '(:ascii :newline :crlf))
 106                     #(#\Nul #\Nul #\Nul #\Nul)))
 107     (assert-error (string-to-octets string :external-format '(:ascii :replacment "?")))
 108     (assert-error (octets-to-string octets :external-format '(:ascii :replacment "?")))
 109     (assert-error (string-to-octets string :external-format '(:ascii :replacement #p"~")))
 110     (assert-error (octets-to-string octets :external-format '(:ascii :replacement #p"~")))
 111     (assert-error (string-to-octets string :external-format '(:ascii :nelwine :crlf)))
 112     (assert-error (octets-to-string octets :external-format '(:ascii :nelwine :crlf)))
 113     (assert-error (string-to-octets string :external-format '(:ascii :newline :clrf)))
 114     (assert-error (octets-to-string octets :external-format '(:ascii :newline :clrf)))))
 115
 116 (with-test (:name (:external-format-options :latin-1 :file))
 117   (let ((string "?")
 118         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
 119     (assert (equalp (s2o-file string :external-format :latin-1) #(63)))
 120     (assert (equalp (o2s-file octets :external-format :latin-1) #(#\Nul #\Nul #\Nul #\Nul)))
 121     (assert (equalp (s2o-file string :external-format '(:latin-1 :replacement "?"))
 122                     #(63)))
 123     (assert (equalp (o2s-file octets :external-format '(:latin-1 :replacement "?"))
 124                     #(#\Nul #\Nul #\Nul #\Nul)))
 125     (assert (equalp (s2o-file string :external-format '(:latin-1 :newline :lf)) #(63)))
 126     (assert (equalp (o2s-file octets :external-format '(:latin-1 :newline :lf))
 127                     #(#\Nul #\Nul #\Nul #\Nul)))
 128     (assert (equalp (s2o-file string :external-format '(:latin-1 :newline :crlf)) #(63)))
 129     (assert (equalp (o2s-file octets :external-format '(:latin-1 :newline :crlf))
 130                     #(#\Nul #\Nul #\Nul #\Nul)))
 131     (assert-error (s2o-file string :external-format '(:latin-1 :replacment "?")))
 132     (assert-error (o2s-file octets :external-format '(:latin-1 :replacment "?")))
 133     (assert-error (s2o-file string :external-format '(:latin-1 :replacement #p"~")))
 134     (assert-error (o2s-file octets :external-format '(:latin-1 :replacement #p"~")))
 135     (assert-error (s2o-file string :external-format '(:latin-1 :nelwine :crlf)))
 136     (assert-error (o2s-file octets :external-format '(:latin-1 :nelwine :crlf)))
 137     (assert-error (s2o-file string :external-format '(:latin-1 :newline :clrf)))
 138     (assert-error (o2s-file octets :external-format '(:latin-1 :newline :clrf)))))
 139 (with-test (:name (:external-format-options :latin-1 :octets))
 140   (let ((string "?")
 141         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
 142     (assert (equalp (string-to-octets string :external-format :latin-1) #(63)))
 143     (assert (equalp (octets-to-string octets :external-format :latin-1) #(#\Nul #\Nul #\Nul #\Nul)))
 144     (assert (equalp (string-to-octets string :external-format '(:latin-1 :replacement "?"))
 145                     #(63)))
 146     (assert (equalp (octets-to-string octets :external-format '(:latin-1 :replacement "?"))
 147                     #(#\Nul #\Nul #\Nul #\Nul)))
 148     (assert (equalp (string-to-octets string :external-format '(:latin-1 :newline :lf)) #(63)))
 149     (assert (equalp (octets-to-string octets :external-format '(:latin-1 :newline :lf))
 150                     #(#\Nul #\Nul #\Nul #\Nul)))
 151     (assert (equalp (string-to-octets string :external-format '(:latin-1 :newline :crlf)) #(63)))
 152     (assert (equalp (octets-to-string octets :external-format '(:latin-1 :newline :crlf))
 153                     #(#\Nul #\Nul #\Nul #\Nul)))
 154     (assert-error (string-to-octets string :external-format '(:latin-1 :replacment "?")))
 155     (assert-error (octets-to-string octets :external-format '(:latin-1 :replacment "?")))
 156     (assert-error (string-to-octets string :external-format '(:latin-1 :replacement #p"~")))
 157     (assert-error (octets-to-string octets :external-format '(:latin-1 :replacement #p"~")))
 158     (assert-error (string-to-octets string :external-format '(:latin-1 :nelwine :crlf)))
 159     (assert-error (octets-to-string octets :external-format '(:latin-1 :nelwine :crlf)))
 160     (assert-error (string-to-octets string :external-format '(:latin-1 :newline :clrf)))
 161     (assert-error (octets-to-string octets :external-format '(:latin-1 :newline :clrf)))))
 162
 163 (with-test (:name (:external-format-options :utf-8 :file))
 164   (let ((string "?")
 165         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
 166     (assert (equalp (s2o-file string :external-format :utf-8) #(63)))
 167     (assert (equalp (o2s-file octets :external-format :utf-8) #(#\Nul #\Nul #\Nul #\Nul)))
 168     (assert (equalp (s2o-file string :external-format '(:utf-8 :replacement "?"))
 169                     #(63)))
 170     (assert (equalp (o2s-file octets :external-format '(:utf-8 :replacement "?"))
 171                     #(#\Nul #\Nul #\Nul #\Nul)))
 172     (assert (equalp (s2o-file string :external-format '(:utf-8 :newline :lf)) #(63)))
 173     (assert (equalp (o2s-file octets :external-format '(:utf-8 :newline :lf))
 174                     #(#\Nul #\Nul #\Nul #\Nul)))
 175     (assert (equalp (s2o-file string :external-format '(:utf-8 :newline :crlf)) #(63)))
 176     (assert (equalp (o2s-file octets :external-format '(:utf-8 :newline :crlf))
 177                     #(#\Nul #\Nul #\Nul #\Nul)))
 178     (assert-error (s2o-file string :external-format '(:utf-8 :replacment "?")))
 179     (assert-error (o2s-file octets :external-format '(:utf-8 :replacment "?")))
 180     (assert-error (s2o-file string :external-format '(:utf-8 :replacement #p"~")))
 181     (assert-error (o2s-file octets :external-format '(:utf-8 :replacement #p"~")))
 182     (assert-error (s2o-file string :external-format '(:utf-8 :nelwine :crlf)))
 183     (assert-error (o2s-file octets :external-format '(:utf-8 :nelwine :crlf)))
 184     (assert-error (s2o-file string :external-format '(:utf-8 :newline :clrf)))
 185     (assert-error (o2s-file octets :external-format '(:utf-8 :newline :clrf)))))
 186 (with-test (:name (:external-format-options :utf-8 :octets))
 187   (let ((string "?")
 188         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
 189     (assert (equalp (string-to-octets string :external-format :utf-8) #(63)))
 190     (assert (equalp (octets-to-string octets :external-format :utf-8) #(#\Nul #\Nul #\Nul #\Nul)))
 191     (assert (equalp (string-to-octets string :external-format '(:utf-8 :replacement "?"))
 192                     #(63)))
 193     (assert (equalp (octets-to-string octets :external-format '(:utf-8 :replacement "?"))
 194                     #(#\Nul #\Nul #\Nul #\Nul)))
 195     (assert (equalp (string-to-octets string :external-format '(:utf-8 :newline :lf)) #(63)))
 196     (assert (equalp (octets-to-string octets :external-format '(:utf-8 :newline :lf))
 197                     #(#\Nul #\Nul #\Nul #\Nul)))
 198     (assert (equalp (string-to-octets string :external-format '(:utf-8 :newline :crlf)) #(63)))
 199     (assert (equalp (octets-to-string octets :external-format '(:utf-8 :newline :crlf))
 200                     #(#\Nul #\Nul #\Nul #\Nul)))
 201     (assert-error (string-to-octets string :external-format '(:utf-8 :replacment "?")))
 202     (assert-error (octets-to-string octets :external-format '(:utf-8 :replacment "?")))
 203     (assert-error (string-to-octets string :external-format '(:utf-8 :replacement #p"~")))
 204     (assert-error (octets-to-string octets :external-format '(:utf-8 :replacement #p"~")))
 205     (assert-error (string-to-octets string :external-format '(:utf-8 :nelwine :crlf)))
 206     (assert-error (octets-to-string octets :external-format '(:utf-8 :nelwine :crlf)))
 207     (assert-error (string-to-octets string :external-format '(:utf-8 :newline :clrf)))
 208     (assert-error (octets-to-string octets :external-format '(:utf-8 :newline :clrf)))))
 209
 210 (with-test (:name (:external-format-options :gbk :file)
 211                   :skipped-on (or (not :sb-unicode) :unicode-lite))
 212   (let ((string "?")
 213         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
 214     (assert (equalp (s2o-file string :external-format :gbk) #(63)))
 215     (assert (equalp (o2s-file octets :external-format :gbk) #(#\Nul #\Nul #\Nul #\Nul)))
 216     (assert (equalp (s2o-file string :external-format '(:gbk :replacement "?"))
 217                     #(63)))
 218     (assert (equalp (o2s-file octets :external-format '(:gbk :replacement "?"))
 219                     #(#\Nul #\Nul #\Nul #\Nul)))
 220     (assert (equalp (s2o-file string :external-format '(:gbk :newline :lf)) #(63)))
 221     (assert (equalp (o2s-file octets :external-format '(:gbk :newline :lf))
 222                     #(#\Nul #\Nul #\Nul #\Nul)))
 223     (assert-error (s2o-file string :external-format '(:gbk :newline :crlf)))
 224     (assert-error (o2s-file octets :external-format '(:gbk :newline :crlf)))
 225     (assert-error (s2o-file string :external-format '(:gbk :replacment "?")))
 226     (assert-error (o2s-file octets :external-format '(:gbk :replacment "?")))
 227     (assert-error (s2o-file string :external-format '(:gbk :replacement #p"~")))
 228     (assert-error (o2s-file octets :external-format '(:gbk :replacement #p"~")))
 229     (assert-error (s2o-file string :external-format '(:gbk :nelwine :crlf)))
 230     (assert-error (o2s-file octets :external-format '(:gbk :nelwine :crlf)))
 231     (assert-error (s2o-file string :external-format '(:gbk :newline :clrf)))
 232     (assert-error (o2s-file octets :external-format '(:gbk :newline :clrf)))))
 233 (with-test (:name (:external-format-options :gbk :octets)
 234                   :skipped-on (or (not :sb-unicode) :unicode-lite))
 235   (let ((string "?")
 236         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
 237     (assert (equalp (string-to-octets string :external-format :gbk) #(63)))
 238     (assert (equalp (octets-to-string octets :external-format :gbk) #(#\Nul #\Nul #\Nul #\Nul)))
 239     (assert (equalp (string-to-octets string :external-format '(:gbk :replacement "?"))
 240                     #(63)))
 241     (assert (equalp (octets-to-string octets :external-format '(:gbk :replacement "?"))
 242                     #(#\Nul #\Nul #\Nul #\Nul)))
 243     (assert (equalp (string-to-octets string :external-format '(:gbk :newline :lf)) #(63)))
 244     (assert (equalp (octets-to-string octets :external-format '(:gbk :newline :lf))
 245                     #(#\Nul #\Nul #\Nul #\Nul)))
 246     (assert-error (string-to-octets string :external-format '(:gbk :newline :crlf)))
 247     (assert-error (octets-to-string octets :external-format '(:gbk :newline :crlf)))
 248     (assert-error (string-to-octets string :external-format '(:gbk :replacment "?")))
 249     (assert-error (octets-to-string octets :external-format '(:gbk :replacment "?")))
 250     (assert-error (string-to-octets string :external-format '(:gbk :replacement #p"~")))
 251     (assert-error (octets-to-string octets :external-format '(:gbk :replacement #p"~")))
 252     (assert-error (string-to-octets string :external-format '(:gbk :nelwine :crlf)))
 253     (assert-error (octets-to-string octets :external-format '(:gbk :nelwine :crlf)))
 254     (assert-error (string-to-octets string :external-format '(:gbk :newline :clrf)))
 255     (assert-error (octets-to-string octets :external-format '(:gbk :newline :clrf)))))
 256
 257 (with-test (:name (:external-format-options :ucs-2le :file)
 258                   :skipped-on (not :sb-unicode))
 259   (let ((string "?")
 260         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
 261     (assert (equalp (s2o-file string :external-format :ucs-2le) #(63 0)))
 262     (assert (equalp (o2s-file octets :external-format :ucs-2le) #(#\Nul #\Nul)))
 263     (assert (equalp (s2o-file string :external-format '(:ucs-2le :replacement "?"))
 264                     #(63 0)))
 265     (assert (equalp (o2s-file octets :external-format '(:ucs-2le :replacement "?"))
 266                     #(#\Nul #\Nul)))
 267     (assert (equalp (s2o-file string :external-format '(:ucs-2le :newline :lf)) #(63 0)))
 268     (assert (equalp (o2s-file octets :external-format '(:ucs-2le :newline :lf))
 269                     #(#\Nul #\Nul)))
 270     (assert-error (s2o-file string :external-format '(:ucs-2le :newline :crlf)))
 271     (assert-error (o2s-file octets :external-format '(:ucs-2le :newline :crlf)))
 272     (assert-error (s2o-file string :external-format '(:ucs-2le :replacment "?")))
 273     (assert-error (o2s-file octets :external-format '(:ucs-2le :replacment "?")))
 274     (assert-error (s2o-file string :external-format '(:ucs-2le :replacement #p"~")))
 275     (assert-error (o2s-file octets :external-format '(:ucs-2le :replacement #p"~")))
 276     (assert-error (s2o-file string :external-format '(:ucs-2le :nelwine :crlf)))
 277     (assert-error (o2s-file octets :external-format '(:ucs-2le :nelwine :crlf)))
 278     (assert-error (s2o-file string :external-format '(:ucs-2le :newline :clrf)))
 279     (assert-error (o2s-file octets :external-format '(:ucs-2le :newline :clrf)))))
 280 (with-test (:name (:external-format-options :ucs-2le :octets)
 281                   :skipped-on (not :sb-unicode))
 282   (let ((string "?")
 283         (octets (coerce '(0 0 0 0) '(vector (unsigned-byte 8)))))
 284     (assert (equalp (string-to-octets string :external-format :ucs-2le) #(63 0)))
 285     (assert (equalp (octets-to-string octets :external-format :ucs-2le) #(#\Nul #\Nul)))
 286     (assert (equalp (string-to-octets string :external-format '(:ucs-2le :replacement "?"))
 287                     #(63 0)))
 288     (assert (equalp (octets-to-string octets :external-format '(:ucs-2le :replacement "?"))
 289                     #(#\Nul #\Nul)))
 290     (assert (equalp (string-to-octets string :external-format '(:ucs-2le :newline :lf)) #(63 0)))
 291     (assert (equalp (octets-to-string octets :external-format '(:ucs-2le :newline :lf))
 292                     #(#\Nul #\Nul)))
 293     (assert-error (string-to-octets string :external-format '(:ucs-2le :newline :crlf)))
 294     (assert-error (octets-to-string octets :external-format '(:ucs-2le :newline :crlf)))
 295     (assert-error (string-to-octets string :external-format '(:ucs-2le :replacment "?")))
 296     (assert-error (octets-to-string octets :external-format '(:ucs-2le :replacment "?")))
 297     (assert-error (string-to-octets string :external-format '(:ucs-2le :replacement #p"~")))
 298     (assert-error (octets-to-string octets :external-format '(:ucs-2le :replacement #p"~")))
 299     (assert-error (string-to-octets string :external-format '(:ucs-2le :nelwine :crlf)))
 300     (assert-error (octets-to-string octets :external-format '(:ucs-2le :nelwine :crlf)))
 301     (assert-error (string-to-octets string :external-format '(:ucs-2le :newline :clrf)))
 302     (assert-error (octets-to-string octets :external-format '(:ucs-2le :newline :clrf)))))
 303 ) ; FLET
 304
 305 (with-test (:name :end-of-file)
 306   (do-external-formats (xf)
 307     (with-open-file (s #-win32 "/dev/null" #+win32 "nul" :direction :input :external-format xf)
 308       (assert (eq (read-char s nil s) s)))))
 309
 310 ;; Output routines must return the written element
 311 (with-test (:name :output-routine-retval :skipped-on :win32)
 312   (dolist (x sb-impl::*output-routines*)
 313     (with-open-file (f "/dev/null" :direction :output :if-exists :overwrite)
 314       (let ((arg (if (eq (car x) 'character) #\z 99))
 315             (fun (symbol-function (third x))))
 316         (assert (eql arg (funcall fun f arg)))))))
 317
 318 ;;; Test standard character read-write equivalency over all external formats.
 319 (macrolet
 320     ((frob ()
 321        (let ((tests nil))
 322          (do-external-formats (xf)
 323            (pushnew `(with-test (:name (:standard-character :read-write-equivalency ,xf))
 324                        (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
 325                          (with-open-file (s *test-path* :direction :output
 326                                             :if-exists :supersede :external-format ',xf)
 327                            (loop for character across standard-characters
 328                                  do (write-char character s)))
 329                          (with-open-file (s *test-path* :direction :input
 330                                             :external-format ',xf)
 331                            (loop for character across standard-characters
 332                                  do (let ((got (read-char s)))
 333                                       (unless (eql character got)
 334                                         (error "wanted ~S, got ~S" character got)))))))
 335                     tests :key #'cadr :test #'equal))
 336          `(progn ,@tests))))
 337   (frob))
 338
 339 #-sb-unicode
 340 (progn
 341   (delete-file *test-path*)
 342   (test-util:report-test-status)
 343   (invoke-restart 'run-tests::skip-file))
 344
 345 ;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with
 346 ;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are
 347 ;;; 8192 wide.
 348 (dotimes (width-1 4)
 349   (let ((character (code-char (elt '(1 #x81 #x801 #x10001) width-1))))
 350     (dotimes (offset (+ width-1 1))
 351       (with-open-file (s *test-path* :direction :output
 352                        :if-exists :supersede :external-format :utf-8)
 353         (dotimes (n offset)
 354           (write-char #\a s))
 355         (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
 356           (write-char character s)))
 357       (with-open-file (s *test-path* :direction :input
 358                        :external-format :utf-8)
 359         (dotimes (n offset)
 360           (assert (eql (read-char s) #\a)))
 361         (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
 362           (let ((got (read-char s)))
 363             (unless (eql got character)
 364               (error "wanted ~S, got ~S (~S)" character got n))))
 365         (assert (eql (read-char s nil s) s))))))
 366
 367 ;;; Test character decode restarts.
 368 (with-open-file (s *test-path* :direction :output
 369                  :if-exists :supersede :element-type '(unsigned-byte 8))
 370   (write-byte 65 s)
 371   (write-byte 66 s)
 372   (write-byte #xe0 s)
 373   (write-byte 67 s))
 374 (with-open-file (s *test-path* :direction :input
 375                  :external-format :utf-8)
 376   (let ((count 0))
 377     (handler-bind
 378         ((sb-int:character-decoding-error #'(lambda (decoding-error)
 379                                               (declare (ignore decoding-error))
 380                                               (when (> (incf count) 1)
 381                                                 (error "too many errors"))
 382                                               (invoke-restart
 383                                                'sb-int:attempt-resync))))
 384       (assert (equal (read-line s nil s) "ABC"))
 385       (assert (equal (read-line s nil s) s)))))
 386 (with-open-file (s *test-path* :direction :input
 387                  :external-format :utf-8)
 388   (let ((count 0))
 389     (handler-bind
 390         ((sb-int:character-decoding-error #'(lambda (decoding-error)
 391                                               (declare (ignore decoding-error))
 392                                               (when (> (incf count) 1)
 393                                                 (error "too many errors"))
 394                                               (invoke-restart
 395                                                'sb-int:force-end-of-file))))
 396       (assert (equal (read-line s nil s) "AB"))
 397       (setf count 0)
 398       (assert (equal (read-line s nil s) s)))))
 399
 400 ;;; And again with more data to account for buffering (this was briefly)
 401 ;;; broken in early 0.9.6.
 402 (with-open-file (s *test-path* :direction :output
 403                  :if-exists :supersede :element-type '(unsigned-byte 8))
 404   (let ((a (make-array 50
 405                        :element-type '(unsigned-byte 64)
 406                        :initial-contents (map 'list #'char-code
 407                                               "1234567890123456789012345678901234567890123456789."))))
 408     (setf (aref a 49) (char-code #\Newline))
 409     (dotimes (i 40)
 410       (write-sequence a s))
 411     (write-byte #xe0 s)
 412     (dotimes (i 40)
 413       (write-sequence a s))))
 414 (with-test (:name (:character-decode-large :attempt-resync))
 415   (with-open-file (s *test-path* :direction :input
 416                      :external-format :utf-8)
 417     (let ((count 0))
 418       (handler-bind
 419           ((sb-int:character-decoding-error (lambda (decoding-error)
 420                                               (declare (ignore decoding-error))
 421                                               (when (> (incf count) 1)
 422                                                 (error "too many errors"))
 423                                               (invoke-restart
 424                                                'sb-int:attempt-resync)))
 425            ;; The failure mode is an infinite loop, add a timeout to
 426            ;; detetct it.
 427            (sb-ext:timeout (lambda (condition)
 428                              (declare (ignore condition))
 429                              (error "Timeout"))))
 430         (sb-ext:with-timeout 5
 431           (dotimes (i 80)
 432             (assert (equal (read-line s nil s)
 433                            "1234567890123456789012345678901234567890123456789"))))))))
 434
 435 (with-test (:name (:character-decode-large :force-end-of-file))
 436   (with-open-file (s *test-path* :direction :input
 437                      :external-format :utf-8)
 438     (let ((count 0))
 439       (handler-bind
 440           ((sb-int:character-decoding-error (lambda (decoding-error)
 441                                               (declare (ignore decoding-error))
 442                                               (when (> (incf count) 1)
 443                                                 (error "too many errors"))
 444                                               (invoke-restart
 445                                                'sb-int:force-end-of-file)))
 446            ;; The failure mode is an infinite loop, add a timeout to detetct it.
 447            (sb-ext:timeout (lambda (condition)
 448                              (declare (ignore condition))
 449                              (error "Timeout"))))
 450         (sb-ext:with-timeout 5
 451           (dotimes (i 40)
 452             (assert (equal (read-line s nil s)
 453                            "1234567890123456789012345678901234567890123456789")))
 454           (setf count 0)
 455           (assert (equal (read-line s nil s) s)))))))
 456
 457 ;;; Test character encode restarts.
 458 (with-open-file (s *test-path* :direction :output
 459                  :if-exists :supersede :external-format :latin-1)
 460   (handler-bind
 461       ((sb-int:character-encoding-error #'(lambda (encoding-error)
 462                                             (declare (ignore encoding-error))
 463                                             (invoke-restart
 464                                              'sb-impl::output-nothing))))
 465     (write-char #\A s)
 466     (write-char #\B s)
 467     (write-char (code-char 322) s)
 468     (write-char #\C s)))
 469 (with-open-file (s *test-path* :direction :input
 470                  :external-format :latin-1)
 471   (assert (equal (read-line s nil s) "ABC"))
 472   (assert (equal (read-line s nil s) s)))
 473
 474 (with-open-file (s *test-path* :direction :output
 475                  :if-exists :supersede :external-format :latin-1)
 476   (handler-bind
 477       ((sb-int:character-encoding-error #'(lambda (encoding-error)
 478                                             (declare (ignore encoding-error))
 479                                             (invoke-restart
 480                                              'sb-impl::output-nothing))))
 481     (let ((string (make-array 4 :element-type 'character
 482                               :initial-contents `(#\A #\B ,(code-char 322)
 483                                                       #\C))))
 484       (write-string string s))))
 485 (with-open-file (s *test-path* :direction :input
 486                  :external-format :latin-1)
 487   (assert (equal (read-line s nil s) "ABC"))
 488   (assert (equal (read-line s nil s) s)))
 489
 490 ;;; Test skipping character-decode-errors in comments.
 491 (let* ((input (scratch-file-name "lisp"))
 492        (s (open input :direction :output
 493                       :if-exists :supersede :external-format :latin-1))
 494        (output))
 495   (unwind-protect
 496        (progn
 497          (write-string ";;; ABCD" s)
 498          (write-char (code-char 233) s)
 499          (terpri s)
 500          (close s)
 501          (let ((*error-output* (make-broadcast-stream)))
 502            (setq output
 503                  (compile-file input
 504                                :external-format :utf-8 :verbose nil))))
 505     (delete-file s)
 506     (let ((p (probe-file output)))
 507       (when p
 508         (delete-file p)))))
 509
 510 \f
 511 ;;;; KOI8-R external format
 512 #-unicode-lite
 513 (progn
 514 (with-open-file (s *test-path* :direction :output
 515                  :if-exists :supersede :external-format :koi8-r)
 516   (write-char (code-char #xB0) s)
 517   (assert (eq
 518            (handler-case
 519                (progn
 520                  (write-char (code-char #xBAAD) s)
 521                  :bad)
 522              (sb-int:character-encoding-error ()
 523                :good))
 524            :good)))
 525 (with-open-file (s *test-path* :direction :input
 526                  :element-type '(unsigned-byte 8))
 527   (let ((byte (read-byte s)))
 528     (assert (= (eval byte) #x9C))))
 529 (with-open-file (s *test-path* :direction :input
 530                  :external-format :koi8-r)
 531   (let ((char (read-char s)))
 532     (assert (= (char-code (eval char)) #xB0))))
 533
 534 (let* ((koi8-r-codes (coerce '(240 210 201 215 197 212 33) '(vector (unsigned-byte 8))))
 535        (uni-codes #(1055 1088 1080 1074 1077 1090 33))
 536
 537        (string (octets-to-string koi8-r-codes :external-format :koi8-r))
 538        (uni-decoded (map 'vector #'char-code string)))
 539   (declare (ignore uni-decoded))
 540   (assert (equalp (map 'vector #'char-code (octets-to-string koi8-r-codes :external-format :koi8-r))
 541                   uni-codes))
 542   (assert (equalp (string-to-octets (map 'string #'code-char uni-codes) :external-format :koi8-r)
 543                   koi8-r-codes)))
 544 )
 545
 546 \f
 547 ;;; tests of FILE-STRING-LENGTH
 548 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
 549   (do-external-formats (xf)
 550     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 551                        :external-format xf)
 552       (loop for x across standard-characters
 553             for position = (file-position s)
 554             for char-length = (file-string-length s x)
 555             do (write-char x s)
 556             do (assert (= (file-position s) (+ position char-length))))
 557       (let ((position (file-position s))
 558             (string-length (file-string-length s standard-characters)))
 559         (write-string standard-characters s)
 560         (assert (= (file-position s) (+ position string-length)))))))
 561
 562 (let ((char-codes '(0 1 255 256 511 512 1023 1024 2047 2048 4095 4096
 563                     8191 8192 16383 16384 32767 32768 65535 65536 131071
 564                     131072 262143 262144)))
 565   (with-open-file (s *test-path* :direction :output :if-exists :supersede
 566                      :external-format :utf-8)
 567     (dolist (code char-codes)
 568       (let* ((char (code-char code))
 569              (position (file-position s))
 570              (char-length (file-string-length s char)))
 571         (write-char char s)
 572         (assert (= (file-position s) (+ position char-length)))))
 573     (let* ((string (map 'string #'code-char char-codes))
 574            (position (file-position s))
 575            (string-length (file-string-length s string)))
 576       (write-string string s)
 577       (assert (= (file-position s) (+ position string-length))))))
 578 \f
 579
 580 ;;; See sbcl-devel "Subject: Bug in FILE-POSITION on UTF-8-encoded files"
 581 ;;; by Lutz Euler on 2006-03-05 for more details.
 582 (with-test (:name (:file-position :utf-8))
 583   (let ((path *test-path*))
 584     (with-open-file (s path
 585                        :direction :output
 586                        :if-exists :supersede
 587                        :element-type '(unsigned-byte 8))
 588       ;; Write #\*, encoded in UTF-8, to the file.
 589       (write-byte 42 s)
 590       ;; Append #\adiaeresis, encoded in UTF-8, to the file.
 591       (write-sequence '(195 164) s))
 592     (with-open-file (s path :external-format :utf-8)
 593       (read-char s)
 594       (let ((pos (file-position s))
 595             (char (read-char s)))
 596         #+nil
 597         (format t "read character with code ~a successfully from file position ~a~%"
 598                 (char-code char) pos)
 599         (file-position s pos)
 600         #+nil
 601         (format t "set file position back to ~a, trying to read-char again~%" pos)
 602         (let ((new-char (read-char s)))
 603           (assert (char= char new-char)))))
 604     (values)))
 605
 606 ;;; We used to call STREAM-EXTERNAL-FORMAT on the stream in the error
 607 ;;; when printing a coding error, but that didn't work if the stream
 608 ;;; was closed by the time the error was printed.  See sbcl-devel
 609 ;;; "Subject: Printing coding errors for closed streams" by Zach Beane
 610 ;;; on 2008-10-16 for more info.
 611 (with-test (:name (:character-coding-error-stream-external-format))
 612   (flet ((first-file-character ()
 613            (with-open-file (stream *test-path* :external-format :utf-8)
 614              (read-char stream))))
 615     (with-open-file (stream *test-path*
 616                             :direction :output
 617                             :if-exists :supersede
 618                             :element-type '(unsigned-byte 8))
 619       (write-byte 192 stream))
 620     (princ-to-string (nth-value 1 (ignore-errors (first-file-character))))))
 621
 622 ;;; External format support in SB-ALIEN
 623
 624 (with-test (:name (:sb-alien :vanilla))
 625   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 626       c-string
 627     (str c-string))
 628   (assert (equal "foo" (strdup "foo"))))
 629
 630 (with-test (:name (:sb-alien :utf-8 :utf-8))
 631   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 632       (c-string :external-format :utf-8)
 633     (str (c-string :external-format :utf-8)))
 634   (assert (equal "foo" (strdup "foo"))))
 635
 636 (with-test (:name (:sb-alien :latin-1 :utf-8))
 637   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 638       (c-string :external-format :latin-1)
 639     (str (c-string :external-format :utf-8)))
 640   (assert (= (length (strdup (string (code-char 246))))
 641              2)))
 642
 643 (with-test (:name (:sb-alien :utf-8 :latin-1))
 644   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 645       (c-string :external-format :utf-8)
 646     (str (c-string :external-format :latin-1)))
 647   (assert (equal (string (code-char 228))
 648                  (strdup (concatenate 'string
 649                                       (list (code-char 195))
 650                                       (list (code-char 164)))))))
 651
 652 (with-ef-test (:name (:sb-alien :ebcdic :ebcdic-us))
 653   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 654       (c-string :external-format :ebcdic-us)
 655     (str (c-string :external-format :ebcdic-us)))
 656   (assert (equal "foo" (strdup "foo"))))
 657
 658 (with-ef-test (:name (:sb-alien :latin-1 :ebcdic-us))
 659   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 660       (c-string :external-format :latin-1)
 661     (str (c-string :external-format :ebcdic-us)))
 662   (assert (not (equal "foo" (strdup "foo")))))
 663
 664 (with-ef-test (:name (:sb-alien :simple-base-string :ebcdic-us))
 665   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 666       (c-string :external-format :ebcdic-us
 667                 :element-type base-char)
 668     (str (c-string :external-format :ebcdic-us)))
 669   (assert (typep (strdup "foo") 'simple-base-string)))
 670
 671 (with-test (:name (:input-replacement :at-end-of-file))
 672   (dotimes (i 256)
 673     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 674       (write-byte i s))
 675     (handler-bind ((sb-int:character-decoding-error
 676                     (lambda (c)
 677                       (declare (ignore c))
 678                       (invoke-restart 'sb-impl::input-replacement #\?))))
 679       (with-open-file (s *test-path* :external-format :utf-8)
 680         (cond
 681           ((char= (read-char s) #\?)
 682            (assert (or (= i (char-code #\?)) (> i 127))))
 683           (t (assert (and (not (= i (char-code #\?))) (< i 128)))))))))
 684
 685 (with-ef-test (:name (:unibyte-invalid-codepoints :cp857))
 686   (dotimes (i 256)
 687     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 688       (write-byte i s))
 689     (with-open-file (s *test-path* :external-format :cp857)
 690       (handler-case (read-char s)
 691         (error () (assert (member i '(#xd5 #xe7 #xf2))))
 692         (:no-error (char) char (assert (not (member i '(#xd5 #xe7 #xf2)))))))))
 693
 694 (with-ef-test (:name (:unibyte-input-replacement :cp857))
 695   (dotimes (i 256)
 696     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 697       (write-byte i s))
 698     (with-open-file (s *test-path* :external-format '(:cp857 :replacement #\?))
 699       (let ((char (read-char s)))
 700         (cond
 701           ((eq char #\?)
 702            (assert (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))
 703           (t (assert (not (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))))))))
 704
 705 (with-ef-test (:name (:unibyte-output-replacement :cp857))
 706   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:cp857 :replacement #\?))
 707     (dotimes (i 256)
 708       (write-char (code-char i) s)))
 709   (with-open-file (s *test-path* :external-format '(:cp857))
 710     (let ((string (make-string 256)))
 711       (read-sequence string s)
 712       (dotimes (i 128)
 713         (assert (= (char-code (char string i)) i)))
 714       (assert (= 38 (count #\? string :start 128))))))
 715
 716 (with-test (:name (:unibyte-input-replacement :ascii))
 717   (dotimes (i 256)
 718     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 719       (write-byte i s))
 720     (with-open-file (s *test-path* :external-format '(:ascii :replacement #\?))
 721       (let ((char (read-char s)))
 722         (cond
 723           ((eq char #\?)
 724            (assert (or (= i (char-code #\?)) (> i 127))))
 725           (t (assert (and (< i 128) (not (= i (char-code #\?)))))))))))
 726
 727 (with-test (:name (:unibyte-output-replacement :ascii))
 728   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ascii :replacement #\?))
 729     (dotimes (i 256)
 730       (write-char (code-char i) s)))
 731   (with-open-file (s *test-path* :external-format '(:ascii))
 732     (let ((string (make-string 256)))
 733       (read-sequence string s)
 734       (dotimes (i 128)
 735         (assert (= (char-code (char string i)) i)))
 736       (assert (= 128 (count #\? string :start 128))))))
 737
 738 (with-test (:name (:unibyte-input-replacement :latin-1))
 739   (dotimes (i 256)
 740     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 741       (write-byte i s))
 742     (with-open-file (s *test-path* :external-format '(:latin-1 :replacement #\?))
 743       (let ((char (read-char s)))
 744         (assert (= (char-code char) i))))))
 745
 746 (with-test (:name (:unibyte-output-replacement :latin-1))
 747   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-1 :replacement #\?))
 748     (dotimes (i 257)
 749       (write-char (code-char i) s)))
 750   (with-open-file (s *test-path* :external-format '(:latin-1))
 751     (let ((string (make-string 257)))
 752       (read-sequence string s)
 753       (dotimes (i 256)
 754         (assert (= (char-code (char string i)) i)))
 755       (assert (char= #\? (char string 256))))))
 756 \f
 757 ;;; latin-2 tests
 758 (with-ef-test (:name (:unibyte-input-replacement :latin-2))
 759   (dotimes (i 256)
 760     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 761       (write-byte i s))
 762     (with-open-file (s *test-path* :external-format '(:latin-2 :replacement #\?))
 763       (let ((char (read-char s)))
 764         (cond
 765           ((< i #xa1) (assert (= (char-code char) i)))
 766           ;; FIXME: more tests
 767           )))))
 768
 769 (with-ef-test (:name (:unibyte-output-replacement :latin-2))
 770   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-2 :replacement #\?))
 771     (dotimes (i 256)
 772       (write-char (code-char i) s)))
 773   (with-open-file (s *test-path* :external-format '(:latin-2))
 774     (let ((string (make-string 256)))
 775       (read-sequence string s)
 776       (dotimes (i #xa1)
 777         (assert (= (char-code (char string i)) i)))
 778       (assert (= 57 (count #\? string :start #xa1))))))
 779 \f
 780 ;;; latin-3 tests
 781 (with-ef-test (:name (:unibyte-input-replacement :latin-3))
 782   (dotimes (i 256)
 783     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 784       (write-byte i s))
 785     (with-open-file (s *test-path* :external-format '(:latin-3 :replacement #\?))
 786       (let ((char (read-char s)))
 787         (cond
 788           ((eq char #\?)
 789            (assert #1=(or (= i (char-code #\?))
 790                           (member i '(#xa5 #xae #xbe #xc3 #xd0 #xe3 #xf0)))))
 791           (t (assert (not #1#))))))))
 792
 793 (with-ef-test (:name (:unibyte-output-replacement :latin-3))
 794   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-3 :replacement #\?))
 795     (dotimes (i 256)
 796       (write-char (code-char i) s)))
 797   (with-open-file (s *test-path* :external-format '(:latin-3))
 798     (let ((string (make-string 256)))
 799       (read-sequence string s)
 800       (dotimes (i #xa1)
 801         (assert (= (char-code (char string i)) i)))
 802       (assert (= 35 (count #\? string :start #xa1))))))
 803 \f
 804 ;;; latin-4 tests
 805 (with-ef-test (:name (:unibyte-input-replacement :latin-4))
 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 '(:latin-4 :replacement #\?))
 810       (let ((char (read-char s)))
 811         (cond
 812           ((< i #xa1) (assert (= (char-code char) i)))
 813           ;; FIXME: more tests
 814           )))))
 815
 816 (with-ef-test (:name (:unibyte-output-replacement :latin-4))
 817   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-4 :replacement #\?))
 818     (dotimes (i 256)
 819       (write-char (code-char i) s)))
 820   (with-open-file (s *test-path* :external-format '(:latin-4))
 821     (let ((string (make-string 256)))
 822       (read-sequence string s)
 823       (dotimes (i #xa1)
 824         (assert (= (char-code (char string i)) i)))
 825       (assert (= 50 (count #\? string :start #xa1))))))
 826 \f
 827 ;;; iso-8859-5 tests
 828 (with-ef-test (:name (:unibyte-input-replacement :iso-8859-5))
 829   (dotimes (i 256)
 830     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 831       (write-byte i s))
 832     (with-open-file (s *test-path* :external-format '(:iso-8859-5 :replacement #\?))
 833       (let ((char (read-char s)))
 834         (cond
 835           ((= (char-code char) i)
 836            (assert (or (< i #xa1) (= i #xad))))
 837           (t (assert (and (>= i #xa1) (/= i #xad)))))))))
 838
 839 (with-ef-test (:name (:unibyte-output-replacement :iso-8859-5))
 840   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-5 :replacement #\?))
 841     (dotimes (i 256)
 842       (write-char (code-char i) s)))
 843   (with-open-file (s *test-path* :external-format '(:iso-8859-5))
 844     (let ((string (make-string 256)))
 845       (read-sequence string s)
 846       (dotimes (i #xa1)
 847         (assert (= (char-code (char string i)) i)))
 848       (assert (= 93 (count #\? string :start #xa1))))))
 849 \f
 850 ;;; iso-8859-6 tests
 851 (with-ef-test (:name (:unibyte-input-replacement :iso-8859-6))
 852   (dotimes (i 256)
 853     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 854       (write-byte i s))
 855     (with-open-file (s *test-path* :external-format '(:iso-8859-6 :replacement #\?))
 856       (let ((char (read-char s)))
 857         (cond
 858           ((eq char #\?)
 859            (assert #1=(or (= i (char-code #\?))
 860                           (<= #xa1 i #xa3) (<= #xa5 i #xab) (<= #xae i #xba)
 861                           (<= #xbc i #xbe) (= i #xc0) (<= #xdb i #xdf)
 862                           (<= #xf3 i))))
 863           (t (assert (not #1#))))))))
 864
 865 (with-ef-test (:name (:unibyte-output-replacement :iso-8859-6))
 866   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-6 :replacement #\?))
 867     (dotimes (i 256)
 868       (write-char (code-char i) s)))
 869   (with-open-file (s *test-path* :external-format '(:iso-8859-6))
 870     (let ((string (make-string 256)))
 871       (read-sequence string s)
 872       (dotimes (i #xa1)
 873         (assert (= (char-code (char string i)) i)))
 874       (assert (= 93 (count #\? string :start #xa1))))))
 875 \f
 876 ;;; iso-8859-7 tests
 877 (with-ef-test (:name (:unibyte-input-replacement :iso-8859-7))
 878   (dotimes (i 256)
 879     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 880       (write-byte i s))
 881     (with-open-file (s *test-path* :external-format '(:iso-8859-7 :replacement #\?))
 882       (let ((char (read-char s)))
 883         (cond
 884           ((eq char #\?)
 885            (assert #1=(or (= i (char-code #\?))
 886                           (member i '(#xa4 #xa5 #xaa #xae #xd2 #xff)))))
 887           (t (assert (not #1#))))))))
 888
 889 (with-ef-test (:name (:unibyte-output-replacement :iso-8859-7))
 890   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-7 :replacement #\?))
 891     (dotimes (i 256)
 892       (write-char (code-char i) s)))
 893   (with-open-file (s *test-path* :external-format '(:iso-8859-7))
 894     (let ((string (make-string 256)))
 895       (read-sequence string s)
 896       (dotimes (i #xa1)
 897         (assert (= (char-code (char string i)) i)))
 898       (assert (= 80 (count #\? string :start #xa1))))))
 899 \f
 900 ;;; iso-8859-8 tests
 901 (with-ef-test (:name (:unibyte-input-replacement :iso-8859-8))
 902   (dotimes (i 256)
 903     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 904       (write-byte i s))
 905     (with-open-file (s *test-path* :external-format '(:iso-8859-8 :replacement #\?))
 906       (let ((char (read-char s)))
 907         (cond
 908           ((eq char #\?)
 909            (assert #1=(or (= i (char-code #\?))
 910                           (= i #xa1) (<= #xbf i #xde) (>= i #xfb))))
 911           (t (assert (not  #1#))))))))
 912
 913 (with-ef-test (:name (:unibyte-output-replacement :iso-8859-8))
 914   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-8 :replacement #\?))
 915     (dotimes (i 256)
 916       (write-char (code-char i) s)))
 917   (with-open-file (s *test-path* :external-format '(:iso-8859-8))
 918     (let ((string (make-string 256)))
 919       (read-sequence string s)
 920       (dotimes (i #xa1)
 921         (assert (= (char-code (char string i)) i)))
 922       (assert (= 67 (count #\? string :start #xa1))))))
 923 \f
 924 ;;; latin-5 tests
 925 (with-ef-test (:name (:unibyte-input-replacement :latin-5))
 926   (dotimes (i 256)
 927     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 928       (write-byte i s))
 929     (with-open-file (s *test-path* :external-format '(:latin-5 :replacement #\?))
 930       (let ((char (read-char s)))
 931         (assert (or (and (= (char-code char) i)
 932                          (not (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))))
 933                     (and (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))
 934                          (not (char= char #\?)))))))))
 935
 936 (with-ef-test (:name (:unibyte-output-replacement :latin-5))
 937   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-5 :replacement #\?))
 938     (dotimes (i 256)
 939       (write-char (code-char i) s)))
 940   (with-open-file (s *test-path* :external-format '(:latin-5))
 941     (let ((string (make-string 256)))
 942       (read-sequence string s)
 943       (dotimes (i #xd0)
 944         (assert (= (char-code (char string i)) i)))
 945       (assert (= 6 (count #\? string :start #xd0))))))
 946 \f
 947 ;;; latin-6 tests
 948 (with-ef-test (:name (:unibyte-input-replacement :latin-6))
 949   (dotimes (i 256)
 950     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 951       (write-byte i s))
 952     (with-open-file (s *test-path* :external-format '(:latin-6 :replacement #\?))
 953       (let ((char (read-char s)))
 954         (assert (or (= (char-code char) i)
 955                     (and (<= #xa1 i #xff)
 956                          (not (char= char #\?)))))))))
 957
 958 (with-ef-test (:name (:unibyte-output-replacement :latin-6))
 959   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-6 :replacement #\?))
 960     (dotimes (i 256)
 961       (write-char (code-char i) s)))
 962   (with-open-file (s *test-path* :external-format '(:latin-6))
 963     (let ((string (make-string 256)))
 964       (read-sequence string s)
 965       (dotimes (i #xa1)
 966         (assert (= (char-code (char string i)) i)))
 967       (assert (= 46 (count #\? string :start #xa1))))))
 968 \f
 969 ;;; iso-8859-11 tests
 970 (with-ef-test (:name (:unibyte-input-replacement :iso-8859-11))
 971   (dotimes (i 256)
 972     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 973       (write-byte i s))
 974     (with-open-file (s *test-path* :external-format '(:iso-8859-11 :replacement #\?))
 975       (let ((char (read-char s)))
 976         (cond
 977           ((eq char #\?)
 978            (assert (member i #1=`(,(char-code #\?) #xdb #xdc #xdd #xde #xfc #xfd #xfe #xff))))
 979           (t (assert (not (member i #1#)))))))))
 980
 981 (with-ef-test (:name (:unibyte-output-replacement :iso-8859-11))
 982   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-11 :replacement #\?))
 983     (dotimes (i 256)
 984       (write-char (code-char i) s)))
 985   (with-open-file (s *test-path* :external-format '(:iso-8859-11))
 986     (let ((string (make-string 256)))
 987       (read-sequence string s)
 988       (dotimes (i #xa1)
 989         (assert (= (char-code (char string i)) i)))
 990       (assert (= 95 (count #\? string :start #xa1))))))
 991 \f
 992 ;;; latin-7 tests
 993 (with-ef-test (:name (:unibyte-input-replacement :latin-7))
 994   (dotimes (i 256)
 995     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 996       (write-byte i s))
 997     (with-open-file (s *test-path* :external-format '(:latin-7 :replacement #\?))
 998       (let ((char (read-char s)))
 999         (assert (or (= (char-code char) i)
1000                     (and (<= #xa1 i #xff)
1001                          (not (char= char #\?)))))))))
1002
1003 (with-ef-test (:name (:unibyte-output-replacement :latin-7))
1004   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-7 :replacement #\?))
1005     (dotimes (i 256)
1006       (write-char (code-char i) s)))
1007   (with-open-file (s *test-path* :external-format '(:latin-7))
1008     (let ((string (make-string 256)))
1009       (read-sequence string s)
1010       (dotimes (i #xa1)
1011         (assert (= (char-code (char string i)) i)))
1012       (dolist (i '(#xd8 #xc6 #xf8 #xe6))
1013         (assert (char/= (char string i) #\?)))
1014       (assert (= 52 (count #\? string :start #xa1))))))
1015 \f
1016 ;;; latin-8 tests
1017 (with-ef-test (:name (:unibyte-input-replacement :latin-8))
1018   (dotimes (i 256)
1019     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1020       (write-byte i s))
1021     (with-open-file (s *test-path* :external-format '(:latin-8 :replacement #\?))
1022       (let ((char (read-char s)))
1023         (assert (or (= (char-code char) i)
1024                     (and (<= #xa1 i #xfe)
1025                          (not (char= char #\?)))))))))
1026
1027 (with-ef-test (:name (:unibyte-output-replacement :latin-8))
1028   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-8 :replacement #\?))
1029     (dotimes (i 256)
1030       (write-char (code-char i) s)))
1031   (with-open-file (s *test-path* :external-format '(:latin-8))
1032     (let ((string (make-string 256)))
1033       (read-sequence string s)
1034       (dotimes (i #xa1)
1035         (assert (= (char-code (char string i)) i)))
1036       (assert (= 31 (count #\? string :start #xa1))))))
1037 \f
1038 ;;; latin-9 tests
1039 (with-ef-test (:name (:unibyte-input-replacement :latin-9))
1040   (dotimes (i 256)
1041     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1042       (write-byte i s))
1043     (with-open-file (s *test-path* :external-format '(:latin-9 :replacement #\?))
1044       (let ((char (read-char s)))
1045         (assert (or (and (= (char-code char) i)
1046                          (not (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))))
1047                     (and (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))
1048                          (not (char= char #\?)))))))))
1049
1050 (with-ef-test (:name (:unibyte-output-replacement :latin-9))
1051   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-9 :replacement #\?))
1052     (dotimes (i 256)
1053       (write-char (code-char i) s)))
1054   (with-open-file (s *test-path* :external-format '(:latin-9))
1055     (let ((string (make-string 256)))
1056       (read-sequence string s)
1057       (dotimes (i #xa4)
1058         (assert (= (char-code (char string i)) i)))
1059       (assert (= 8 (count #\? string :start #xa4))))))
1060 \f
1061 ;;; koi8-r tests
1062 (with-ef-test (:name (:unibyte-input-replacement :koi8-r)
1063                   :skipped-on :unicode-lite)
1064   (dotimes (i 256)
1065     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1066       (write-byte i s))
1067     (with-open-file (s *test-path* :external-format '(:koi8-r :replacement #\?))
1068       (let ((char (read-char s)))
1069         (cond ((= (char-code char) i)
1070                (assert (< i 128)))
1071               (t (assert (> i 127))))))))
1072
1073 (with-ef-test (:name (:unibyte-output-replacement :koi8-r))
1074   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-r :replacement #\?))
1075     (dotimes (i 256)
1076       (write-char (code-char i) s)))
1077   (with-open-file (s *test-path* :external-format '(:koi8-r))
1078     (let ((string (make-string 256)))
1079       (read-sequence string s)
1080       (dotimes (i #x80)
1081         (assert (= (char-code (char string i)) i)))
1082       (assert (= 122 (count #\? string :start #x80))))))
1083 \f
1084 ;;; koi8-u tests
1085 (with-ef-test (:name (:unibyte-input-replacement :koi8-u))
1086   (dotimes (i 256)
1087     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1088       (write-byte i s))
1089     (with-open-file (s *test-path* :external-format '(:koi8-u :replacement #\?))
1090       (let ((char (read-char s)))
1091         (cond ((= (char-code char) i)
1092                (assert (< i 128)))
1093               (t (assert (> i 127))))))))
1094
1095 (with-ef-test (:name (:unibyte-output-replacement :koi8-u))
1096   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-u :replacement #\?))
1097     (dotimes (i 256)
1098       (write-char (code-char i) s)))
1099   (with-open-file (s *test-path* :external-format '(:koi8-u))
1100     (let ((string (make-string 256)))
1101       (read-sequence string s)
1102       (dotimes (i #x80)
1103         (assert (= (char-code (char string i)) i)))
1104       (assert (= 122 (count #\? string :start #x80))))))
1105 \f
1106 ;;; x-mac-cyrillic tests
1107 (with-ef-test (:name (:unibyte-input-replacement :x-mac-cyrillic))
1108   (dotimes (i 256)
1109     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1110       (write-byte i s))
1111     (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic :replacement #\?))
1112       (let ((char (read-char s)))
1113         (cond ((= (char-code char) i)
1114                (assert (or (< i 128) (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))
1115               (t (assert (and (> i 127)
1116                               (not (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))))))))
1117
1118 (with-ef-test (:name (:unibyte-output-replacement :x-mac-cyrillic))
1119   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:x-mac-cyrillic :replacement #\?))
1120     (dotimes (i 256)
1121       (write-char (code-char i) s)))
1122   (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic))
1123     (let ((string (make-string 256)))
1124       (read-sequence string s)
1125       (dotimes (i #x80)
1126         (assert (= (char-code (char string i)) i)))
1127       (assert (= 113 (count #\? string :start #x80))))))
1128 \f
1129 ;;; ucs-2 tests
1130 (with-test (:name (:multibyte :ucs2le))
1131   (let* ((size 120)
1132          (array (map-into (make-array size :element-type '(unsigned-byte 16))
1133                           (lambda () (random #x10000)))))
1134     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1135       (dotimes (i size)
1136         (write-byte (ldb (byte 8 0) (aref array i)) s)
1137         (write-byte (ldb (byte 8 8) (aref array i)) s)))
1138     (with-open-file (s *test-path* :external-format :ucs2le)
1139       (let ((string (make-string size)))
1140         (read-sequence string s)
1141         (dotimes (i size)
1142           (assert (= (char-code (char string i)) (aref array i))))))))
1143
1144 (with-test (:name (:multibyte :ucs2be))
1145   (let* ((size 120)
1146          (array (map-into (make-array size :element-type '(unsigned-byte 16))
1147                           (lambda () (random #x10000)))))
1148     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1149       (dotimes (i size)
1150         (write-byte (ldb (byte 8 8) (aref array i)) s)
1151         (write-byte (ldb (byte 8 0) (aref array i)) s)))
1152     (with-open-file (s *test-path* :external-format :ucs2be)
1153       (let ((string (make-string size)))
1154         (read-sequence string s)
1155         (dotimes (i size)
1156           (assert (= (char-code (char string i)) (aref array i))))))))
1157
1158 (with-test (:name (:multibyte :output-replacement :ucs2le))
1159   (let* ((size 1200)
1160          (string (map-into (make-string size)
1161                            (lambda () (code-char (random #x10000))))))
1162     (setf (char string 0) (code-char #x10001)
1163           (char string (1- size)) (code-char #x10002))
1164     (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2le :replacement #\replacement_character))
1165       (write-string string s))
1166     (with-open-file (s *test-path* :external-format :ucs2le)
1167       (let ((new (make-string size)))
1168         (read-sequence new s)
1169         (assert (char= (char new 0) #\replacement_character))
1170         (assert (char= (char new (1- size)) #\replacement_character))
1171         (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
1172
1173 (with-test (:name (:multibyte :output-replacement :ucs2be))
1174   (let* ((size 1200)
1175          (string (map-into (make-string size)
1176                            (lambda () (code-char (random #x10000))))))
1177     (setf (char string 0) (code-char #x10001)
1178           (char string (1- size)) (code-char #x10002))
1179     (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2be :replacement #\replacement_character))
1180       (write-string string s))
1181     (with-open-file (s *test-path* :external-format :ucs2be)
1182       (let ((new (make-string size)))
1183         (read-sequence new s)
1184         (assert (char= (char new 0) #\replacement_character))
1185         (assert (char= (char new (1- size)) #\replacement_character))
1186         (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
1187
1188 (with-test (:name (:multibyte :input-replacement :ucs4le))
1189   (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
1190     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1191       (write-sequence octets s))
1192     (with-open-file (s *test-path* :external-format '(:ucs4le :replacement #\replacement_character))
1193       (let ((string (read-line s)))
1194         (assert (char= (char string 0) (code-char #x10100)))
1195         (assert (char= (char string 1) #\replacement_character))))))
1196
1197 (with-test (:name (:multibyte :input-replacement :ucs4le))
1198   (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
1199     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
1200       (write-sequence octets s))
1201     (with-open-file (s *test-path* :external-format '(:ucs4be :replacement #\replacement_character))
1202       (let ((string (read-line s)))
1203         (assert (char= (char string 0) (code-char #x10100)))
1204         (assert (char= (char string 1) #\replacement_character))))))
1205 \f
1206 ;;; utf tests
1207 (with-test (:name (:utf-16le :roundtrip))
1208   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
1209     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1210                        :external-format :utf-16le)
1211       (write-string string s))
1212     (with-open-file (s *test-path* :external-format :utf-16le)
1213       (assert (string= string (read-line s))))))
1214 (with-test (:name (:utf-16be :roundtrip))
1215   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
1216     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1217                        :external-format :utf-16be)
1218       (write-string string s))
1219     (with-open-file (s *test-path* :external-format :utf-16be)
1220       (assert (string= string (read-line s))))))
1221 (with-test (:name (:utf-16le :encoding-error))
1222   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
1223     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1224                        :external-format '(:utf-16le :replacement #\?))
1225       (write-string string s))
1226     (with-open-file (s *test-path* :external-format :utf-16le)
1227       (assert (string= " ???? " (read-line s))))))
1228 (with-test (:name (:utf-16be :encoding-error))
1229   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
1230     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1231                        :external-format '(:utf-16be :replacement #\?))
1232       (write-string string s))
1233     (with-open-file (s *test-path* :external-format :utf-16be)
1234       (assert (string= " ???? " (read-line s))))))
1235
1236 (with-test (:name (:utf-32le :roundtrip))
1237   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
1238     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1239                        :external-format :utf-32le)
1240       (write-string string s))
1241     (with-open-file (s *test-path* :external-format :utf-32le)
1242       (assert (string= string (read-line s))))))
1243 (with-test (:name (:utf-32be :roundtrip))
1244   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
1245     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1246                        :external-format :utf-32be)
1247       (write-string string s))
1248     (with-open-file (s *test-path* :external-format :utf-32be)
1249       (assert (string= string (read-line s))))))
1250 (with-test (:name (:utf-32le :encoding-error))
1251   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
1252     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1253                        :external-format '(:utf-32le :replacement #\?))
1254       (write-string string s))
1255     (with-open-file (s *test-path* :external-format :utf-32le)
1256       (assert (string= " ???? " (read-line s))))))
1257 (with-test (:name (:utf-32be :encoding-error))
1258   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
1259     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1260                        :external-format '(:utf-32be :replacement #\?))
1261       (write-string string s))
1262     (with-open-file (s *test-path* :external-format :utf-32be)
1263       (assert (string= " ???? " (read-line s))))))
1264
1265 (with-test (:name :invalid-external-format)
1266   (labels ((test-error (e)
1267              (assert (typep e 'error))
1268              (unless (equal "Undefined external-format: :BAD-FORMAT"
1269                             (princ-to-string e))
1270                (error "Bad error:~%  ~A" e)))
1271            (test (direction)
1272              (test-error
1273               (handler-case
1274                   (open #-win32 "/dev/null" #+win32 "nul" :direction direction :external-format :bad-format
1275                         :if-exists :overwrite)
1276                 (error (e) e)))))
1277     (test :input)
1278     (test :output)
1279     (test :io)
1280     (test-error
1281      (handler-case
1282          (run-program "sh" '() :input :stream :external-format :bad-format)
1283        (error (e) e)))
1284     (test-error
1285      (handler-case
1286          (string-to-octets "foobar" :external-format :bad-format)
1287        (error (e) e)))
1288     (test-error
1289      (let ((octets (string-to-octets "foobar" :external-format :latin1)))
1290        (handler-case
1291            (octets-to-string octets :external-format :bad-format)
1292          (error (e) e))))))
1293
1294 (with-ef-test (:name (:lp713063 :euc-jp))
1295   (with-open-file (f *test-path*
1296                      :direction :output
1297                      :external-format '(:euc-jp :replacement #\?)
1298                      :if-exists :supersede)
1299     (write-string (make-string 3 :initial-element #\horizontal_bar) f))
1300   (assert (equal "???"
1301                  (with-open-file (f *test-path*
1302                                     :direction :input
1303                                     :external-format :euc-jp)
1304                    (read-line f)))))
1305
1306 ;; test for lp#659107
1307 (with-test (:name :cmdline-setq-external-format
1308                   :skipped-on (not :sb-unicode))
1309   (with-scratch-file (script "lisp")
1310     (with-open-file (stream script :direction :output
1311                                    :if-exists :supersede
1312                                    :if-does-not-exist :create
1313                                    :external-format :utf16le)
1314       (format stream "(defvar s \"what? ~A\"~%)" (name-char "GRINNING_FACE"))
1315       (format stream "(sb-ext:exit :code
1316  (if (and (string= (subseq s 0 6) \"what? \") (char= (char s 6) #\\grinning_face)) 0 1))~%"))
1317     (let ((process (run-program
1318                     sb-ext:*runtime-pathname*
1319                     (list "--core" sb-int:*core-string*
1320                           "--noinform" "--no-sysinit" "--no-userinit" "--noprint"
1321                           "--disable-debugger"
1322                           "--eval" "(setq *default-external-format* :utf16le)"
1323                           "--load" script)
1324                     :error t)))
1325         (assert (zerop (process-exit-code process))))))
1326
1327 (delete-file *test-path*)