tests/reader.pure.lisp

   1 ;;;; tests related to the Lisp reader
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package "CL-USER")
  15
  16 (load "compiler-test-util.lisp")
  17
  18 (assert (equal (symbol-name '#:|fd\sA|) "fdsA"))
  19
  20 ;;; Prior to sbcl-0.7.2.10, SBCL disobeyed the ANSI requirements on
  21 ;;; returning NIL for unset dispatch-macro-character functions. (bug
  22 ;;; 151, fixed by Alexey Dejenka sbcl-devel "bug 151" 2002-04-12)
  23 (assert (not (get-dispatch-macro-character #\# #\{)))
  24 (assert (not (get-dispatch-macro-character #\# #\0)))
  25 ;;; And we might as well test that we don't have any cross-compilation
  26 ;;; shebang residues left...
  27 (assert (not (get-dispatch-macro-character #\# #\!)))
  28 ;;; Also test that all the illegal sharp macro characters are
  29 ;;; recognized as being illegal.
  30 (loop for char in '(#\Backspace #\Tab #\Newline #\Linefeed
  31                     #\Page #\Return #\Space #\) #\<)
  32    do (assert (get-dispatch-macro-character #\# char)))
  33
  34 (assert (not (ignore-errors (get-dispatch-macro-character #\! #\0)
  35                             t)))
  36
  37 ;;; In sbcl-0.7.3, GET-MACRO-CHARACTER and SET-MACRO-CHARACTER didn't
  38 ;;; use NIL to represent the no-macro-attached-to-this-character case
  39 ;;; as ANSI says they should. (This problem is parallel to the
  40 ;;; GET-DISPATCH-MACRO misbehavior fixed in sbcl-0.7.2.10, but
  41 ;;; was fixed a little later.)
  42 (dolist (customizable-char
  43          ;; According to ANSI "2.1.4 Character Syntax Types", these
  44          ;; characters are reserved for the programmer.
  45          '(#\? #\! #\[ #\] #\{ #\}))
  46   ;; So they should have no macro-characterness.
  47   (multiple-value-bind (macro-fun non-terminating-p)
  48       (get-macro-character customizable-char)
  49     (assert (null macro-fun))
  50     ;; Also, in a bit of ANSI weirdness, NON-TERMINATING-P can be
  51     ;; true only when MACRO-FUN is true. (When the character
  52     ;; is not a macro character, it can be embedded in a token,
  53     ;; so it'd be more logical for NON-TERMINATING-P to be T in
  54     ;; this case; but ANSI says it's NIL in this case.
  55     (assert (null non-terminating-p))))
  56
  57 ;;; rudimentary test of SET-SYNTAX-FROM-CHAR, just to verify that it
  58 ;;; wasn't totally broken by the GET-MACRO-CHARACTER/SET-MACRO-CHARACTER
  59 ;;; fixes in 0.7.3.16
  60 (assert (= 123579 (read-from-string "123579")))
  61 (let ((*readtable* (copy-readtable)))
  62   (set-syntax-from-char #\7 #\;)
  63   (assert (= 1235 (read-from-string "123579"))))
  64
  65 ;;; PARSE-INTEGER must signal an error of type PARSE-ERROR if it is
  66 ;;; unable to parse an integer and :JUNK-ALLOWED is NIL.
  67 (macrolet ((assert-parse-error (form)
  68              `(multiple-value-bind (val cond)
  69                   (ignore-errors ,form)
  70                 (assert (null val))
  71                 (assert (typep cond 'parse-error)))))
  72   (assert-parse-error (parse-integer "    "))
  73   (assert-parse-error (parse-integer "12 a"))
  74   (assert-parse-error (parse-integer "12a"))
  75   (assert-parse-error (parse-integer "a"))
  76   (assert (= (parse-integer "12") 12))
  77   (assert (= (parse-integer "   12   ") 12))
  78   (assert (= (parse-integer "   12asdb" :junk-allowed t) 12)))
  79
  80 ;;; #A notation enforces that once one 0 dimension has been found, all
  81 ;;; subsequent ones are also 0.
  82 (assert (equal (array-dimensions (read-from-string "#3A()"))
  83                '(0 0 0)))
  84 (assert (equal (array-dimensions (read-from-string "#3A(())"))
  85                '(1 0 0)))
  86 (assert (equal (array-dimensions (read-from-string "#3A((() ()))"))
  87                '(1 2 0)))
  88
  89 ;;; Bug reported by Nikodemus Siivola on sbcl-devel 2003-07-21:
  90 ;;; package misconfiguration
  91 (assert (eq
  92          (handler-case (with-input-from-string (s "cl:") (read s))
  93            (end-of-file (c)
  94              (declare (ignore c))
  95              'good))
  96          'good))
  97
  98 ;;; Bugs found by Paul Dietz
  99 (assert (equal (multiple-value-list
 100                 (parse-integer "   123      "))
 101                '(123 12)))
 102
 103 (let* ((base "xxx 123  yyy")
 104        (intermediate (make-array 8 :element-type (array-element-type base)
 105                                  :displaced-to base
 106                                  :displaced-index-offset 2))
 107        (string (make-array 6 :element-type (array-element-type base)
 108                            :displaced-to intermediate
 109                            :displaced-index-offset 1)))
 110   (assert (equal (multiple-value-list
 111                   (parse-integer string))
 112                  '(123 6))))
 113
 114 (let ((*read-base* *read-base*))
 115   (dolist (float-string '(".9" ".9e9" ".9e+9" ".9e-9"
 116                           "-.9" "-.9e9" "-.9e+9" "-.9e-9"
 117                           "+.9" "+.9e9" "+.9e+9" "+.9e-9"
 118                           "0.9" "0.9e9" "0.9e+9" "0.9e-9"
 119                           "9.09" "9.09e9" "9.09e+9" "9.09e-9"
 120                           #|"9e9" could be integer|# "9e+9" "9e-9"))
 121     (loop for i from 2 to 36
 122           do (setq *read-base* i)
 123           do (assert (typep (read-from-string float-string)
 124                             *read-default-float-format*))
 125           do (assert (typep
 126                       (read-from-string (substitute #\E #\e float-string))
 127                       *read-default-float-format*))
 128           if (position #\e float-string)
 129           do (assert (typep
 130                       (read-from-string (substitute #\s #\e float-string))
 131                       'short-float))
 132           and do (assert (typep
 133                           (read-from-string (substitute #\S #\e float-string))
 134                           'short-float))
 135           and do (assert (typep
 136                           (read-from-string (substitute #\f #\e float-string))
 137                           'single-float))
 138           and do (assert (typep
 139                           (read-from-string (substitute #\F #\e float-string))
 140                           'single-float))
 141           and do (assert (typep
 142                           (read-from-string (substitute #\d #\e float-string))
 143                           'double-float))
 144           and do (assert (typep
 145                           (read-from-string (substitute #\D #\e float-string))
 146                           'double-float))
 147           and do (assert (typep
 148                           (read-from-string (substitute #\l #\e float-string))
 149                           'long-float))
 150           and do (assert (typep
 151                           (read-from-string (substitute #\L #\e float-string))
 152                           'long-float)))))
 153
 154 (let ((*read-base* *read-base*))
 155   (dolist (integer-string '("1." "2." "3." "4." "5." "6." "7." "8." "9." "0."))
 156     (loop for i from 2 to 36
 157           do (setq *read-base* i)
 158           do (assert (typep (read-from-string integer-string) 'integer)))))
 159
 160 (let ((*read-base* *read-base*))
 161   (dolist (symbol-string '("A." "a." "Z." "z."
 162
 163                            "+.9eA" "+.9ea"
 164
 165                            "0.A" "0.a" "0.Z" "0.z"
 166
 167                            #|"9eA" "9ea"|# "9e+A" "9e+a" "9e-A" "9e-a"
 168                            #|"Ae9" "ae9"|# "Ae+9" "ae+9" "Ae-9" "ae-9"
 169
 170                            "ee+9" "Ee+9" "eE+9" "EE+9"
 171                            "ee-9" "Ee-9" "eE-9" "EE-9"
 172
 173                            "A.0" "A.0e10" "a.0" "a.0e10"
 174
 175                            "1e1e+9"))
 176     (loop for i from 2 to 36
 177           do (setq *read-base* i)
 178           do (assert (typep (read-from-string symbol-string) 'symbol)))))
 179
 180 (let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~
 181 ")
 182       (standard-terminating-macro-chars "\"'(),;`")
 183       (standard-nonterminating-macro-chars "#"))
 184   (flet ((frob (char)
 185            (multiple-value-bind (fun non-terminating-p)
 186                (get-macro-character char)
 187              (cond
 188                ((find char standard-terminating-macro-chars)
 189                 (unless (and fun (not non-terminating-p))
 190                   (list char)))
 191                ((find char standard-nonterminating-macro-chars)
 192                 (unless (and fun non-terminating-p)
 193                   (list char)))
 194                (t (unless (and (not fun) (not non-terminating-p))
 195                     (list char)))))))
 196     (let ((*readtable* (copy-readtable nil)))
 197       (assert (null (loop for c across standard-chars append (frob c)))))))
 198
 199 (let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~
 200 ")
 201       (undefined-chars "!\"$%&,;>?@[]^_`~{}/dDeEfFgGhHiIjJkKlLmMnNqQtTuUvVwWyYzZ"))
 202   (flet ((frob (char)
 203            (let ((fun (get-dispatch-macro-character #\# char)))
 204              (cond
 205                ((find char undefined-chars)
 206                 (when fun (list char)))
 207                ((digit-char-p char 10)
 208                 (when fun (list char)))
 209                (t
 210                 (unless fun (list char)))))))
 211     (let ((*readtable* (copy-readtable nil)))
 212       (assert (null (loop for c across standard-chars append (frob c)))))))
 213
 214 (with-test (:name :copy-readtable-with-unicode-macro
 215                   :skipped-on (not :sb-unicode))
 216   (let ((rt (copy-readtable)))
 217     (set-macro-character (code-char #x100fa) #'error nil rt)
 218     (assert (plusp (hash-table-count (sb-impl::character-macro-hash-table rt))))
 219     (copy-readtable nil rt)
 220     (assert (null (get-macro-character #\UFC rt)))))
 221
 222 ;;; All these must return a primary value of NIL when *read-suppress* is T
 223 ;;; Reported by Bruno Haible on cmucl-imp 2004-10-25.
 224 (with-test (:name :read-suppress-char-macros)
 225   (let ((*read-suppress* t))
 226     (assert (null (read-from-string "(1 2 3)")))
 227     (assert (null (with-input-from-string (s "abc xyz)")
 228                     (read-delimited-list #\) s))))
 229     (assert (null (with-input-from-string (s "(1 2 3)")
 230                     (read-preserving-whitespace s))))
 231     (assert (null (with-input-from-string (s "(1 2 3)")
 232                     (read s))))
 233     ;; .. and it's better to avoid consing rather than produce an object and
 234     ;; throw it away, even though it's (mostly) indistinguishable to the user.
 235     (let ((input (make-string-input-stream "this-is-a-string! .")))
 236       (assert (string= (sb-impl::with-read-buffer ()
 237                          (sb-impl::read-string input #\!))
 238                        "")))))
 239
 240 ;;; System code that asks whether %READ-PRESERVING-WHITESPACE hit EOF
 241 ;;; mistook NIL as an object returned normally for NIL the default eof mark.
 242 (with-test (:name :read-preserving-whitespace-file-position)
 243   (multiple-value-bind (obj pos1) (read-from-string "NIL A")
 244     (declare (ignore obj))
 245     (multiple-value-bind (obj pos2) (read-from-string "NNN A")
 246       (declare (ignore obj))
 247       (assert (= pos1 pos2 4))))
 248   ;; This also affected *READ-SUPPRESS*. The root cause is the same,
 249   ;; but the rationale for why the change is valid is slightly subtle
 250   ;; on account of the vague if not weird implication regarding READ
 251   ;; that there might actually be differences in non-preservation of
 252   ;; whitespace based on *READ-SUPPRESS*. CLHS entry for READ:
 253   ;;  "When *read-suppress* is false, read throws away the delimiting
 254   ;;   character required by certain printed representations if it is a
 255   ;;   whitespace[2] character; but read preserves the character (using
 256   ;;   unread-char) if it is syntactically meaningful, because it could
 257   ;;   be the start of the next expression."
 258   ;; Why would it mention *read-supress* at all, unless the expectation
 259   ;; is that when suppressing you might /not/ throw away a space?
 260   ;; But it isn't "when-and-only-when" so we're certainly legal to
 261   ;; make the behavior identical regardless of *read-suppress*.
 262   (dolist (test '("#-q 1 2" "#+sbcl 1 2")) ; Two tests from lp#327790.
 263     (flet ((try (*read-suppress*)
 264              (with-input-from-string (s test)
 265                (read s)
 266                (file-position s))))
 267       (assert (= (try nil) (try t)))))
 268   ;; Check that conversion from local eof-object to user-specified eof
 269   ;; object is nearly perfectly immune to false positives.
 270   ;; The only remaining confusion is that
 271   ;;   (read-from-string "#.(code-header-ref (fun-code-header #'read) 6)")
 272   ;; returns NIL instead of (NIL) [subject to change depending on
 273   ;; what 6 should be] but that is too ridiculous to worry about.
 274   (assert (eq (read-from-string "#.sb-impl::*eof-object*")
 275               sb-impl::*eof-object*)))
 276
 277 ;;; EOF-ERROR-P defaults to true. Reported by Bruno Haible on
 278 ;;; cmucl-imp 2004-10-18.
 279 (multiple-value-bind (res err) (ignore-errors (read-from-string ""))
 280   (assert (not res))
 281   (assert (typep err 'end-of-file)))
 282
 283 (assert (equal '((0 . "A") (1 . "B"))
 284                (coerce (read-from-string "#((0 . \"A\") (1 . \"B\"))")
 285                        'list)))
 286
 287 ;;; parse-integer uses whitespace[1] not whitespace[2] as its
 288 ;;; definition of whitespace to skip.
 289 (let ((*readtable* (copy-readtable)))
 290   (set-syntax-from-char #\7 #\Space)
 291   (assert (= 710 (parse-integer "710"))))
 292
 293 (let ((*readtable* (copy-readtable)))
 294   (set-syntax-from-char #\7 #\Space)
 295   (assert (string= (format nil "~7D" 1) "      1")))
 296
 297 (with-test (:name :report-reader-error)
 298   ;; Apparently this wants to test the printing of the error string
 299   ;; otherwise we'd just use ASSERT-SIGNAL.
 300   (let ((symbol (find-symbol "DOES-NOT-EXIST" "CL-USER")))
 301     (declare (optimize safety)) ; don't flush PRINC-TO-STRING
 302     (assert (null symbol))
 303     (handler-case (read-from-string "CL-USER:DOES-NOT-EXIST")
 304      (reader-error (c) (princ-to-string c)))))
 305
 306 ;;; The GET-MACRO-CHARACTER in SBCL <= "1.0.34.2" bogusly computed its
 307 ;;; second return value relative to *READTABLE* rather than the passed
 308 ;;; readtable.
 309 (let* ((*readtable* (copy-readtable nil)))
 310   (set-syntax-from-char #\" #\A)
 311   (multiple-value-bind (reader-fn non-terminating-p)
 312       (get-macro-character #\" (copy-readtable nil))
 313     (declare (ignore reader-fn))
 314     (assert (not non-terminating-p))))
 315
 316 (with-test (:name :bug-309093)
 317   (assert (eq :error
 318               (handler-case
 319                   (read-from-string "`#2A((,(1+ 0) 0) (0 0))")
 320                 (reader-error ()
 321                   :error)))))
 322
 323 (with-test (:name :set-syntax-from-char-dispatch-macro-char)
 324   (let ((rt (copy-readtable)))
 325     (make-dispatch-macro-character #\! nil rt)
 326     (set-dispatch-macro-character #\! #\! (constantly 'bang^2) rt)
 327     (flet ((maybe-bang ()
 328              (let ((*readtable* rt))
 329                (read-from-string "!!"))))
 330       (assert (eq 'bang^2 (maybe-bang)))
 331       (set-syntax-from-char #\! #\! rt)
 332       (assert (eq '!! (maybe-bang))))))
 333
 334 (with-test (:name :read-in-package-syntax)
 335   (assert (equal '(sb-c::a (sb-kernel::x sb-kernel::y) sb-c::b)
 336                  (read-from-string "sb-c::(a sb-kernel::(x y) b)")))
 337   (assert (equal '(cl-user::yes-this-is-sbcl)
 338                  (read-from-string "cl-user::(#+sbcl yes-this-is-sbcl)")))
 339   #+sb-package-locks
 340   (assert (eq :violated!
 341               (handler-case
 342                   (read-from-string "cl::'foo")
 343                 (package-lock-violation ()
 344                   :violated!)))))
 345
 346 (with-test (:name :bug-309070)
 347   (with-timeout 10
 348     (assert-error (read-from-string "10e10000000000000000000")
 349                   sb-kernel:reader-impossible-number-error)))
 350
 351 (with-test (:name :bug-1095918)
 352   (assert (= (length `#3(1)) 3)))
 353
 354 (with-test (:name :obscure-reader-package-usage)
 355   ;; commit 8fd604 cause a bug in reading "::(foo bar)" which tried
 356   ;; to treat the package-designator as a string, but in this case
 357   ;; it is hardcoded to *keyword-package*.
 358   (assert (equal (read-from-string "::(foo bar)") '(:foo :bar))))
 359
 360 ;; I do not know the complete list of platforms for which this test
 361 ;; will not cons, but there were four different heap allocations
 362 ;; instead of using dx allocation or a recyclable resource:
 363 ;;  - most obviously, a 128-character buffer per invocation of READ
 364 ;;  - calling SUBSEQ for package names
 365 ;;  - multiple-value-call in WITH-CHAR-MACRO-RESULT
 366 ;;  - the initial cons cell in READ-LIST
 367 (with-test (:name :read-does-not-cons-per-se
 368                   :skipped-on (:or :interpreter (:not :x86-64)))
 369   (flet ((test-reading (string)
 370            (let ((s (make-string-input-stream string)))
 371              (read s) ; once outside the loop, to make A-SYMBOL
 372              (ctu:assert-no-consing
 373               (progn (file-position s 0)
 374                      (read s))
 375               40000))))
 376     ;; These each used to produce at least 20 MB of garbage,
 377     ;; a result of using 128-character (= 512 bytes for Unicode) buffers.
 378     ;; Now we use exactly one buffer, or maybe two for package + symbol-name.
 379     ;; There is no way to allow an allocation of precisely 512 bytes
 380     ;; without counting a whole allocation page against this test.
 381     ;; If you get unlucky, the tests might cons one SB-IMPL::TOKEN-BUFFER.
 382     ;; And if you get really unlucky, that might be the straw that breaks
 383     ;; the camel's back - forcing the use of a new GC page, which looks
 384     ;; like it consed 32768 bytes on the old page. Due to the allowable
 385     ;; tolerance in CHECK-CONSING, running the test more times than there
 386     ;; are bytes consed should pass for "no consing" because it's obviously
 387     ;; impossible to cons 1 byte per run.
 388     ;; If this still fails, it might be due to somebody changing the
 389     ;; backend-page-bytes to exceed 32KB. Not sure what to do about that.
 390     (test-reading "4.0s0")
 391     (test-reading "COMMON-LISP-USER::A-SYMBOL")
 392     (test-reading "()")
 393     (test-reading "#\\-") ; should not copy the token buffer
 394     ;; *READ-SUPPRESS* avoids creation of lists
 395     (test-reading "#-sbcl(a (b c (d (e) (f) g)) h i j . x . y baz) 5")
 396     ))
 397
 398 (with-test (:name :sharp-left-paren-empty-list)
 399   (assert (read-from-string "#0()")) ; edge case that works
 400   (assert (eq (handler-case (read-from-string "#3()")
 401                 (sb-int:simple-reader-error () :win))
 402               :win)))
 403
 404 (with-test (:name :sharp-star-empty-multiple-escapes)
 405   (assert (eq (handler-case (read-from-string "#*101||1")
 406                 (sb-int:simple-reader-error () :win))
 407               :win)))
 408
 409 ;;; The WITH-FAST-READ-BYTE macro accidentally left the package lock
 410 ;;; of FAST-READ-BYTE disabled during its body.
 411 (with-test (:name :fast-read-byte-package-lock
 412             :skipped-on (not :sb-package-locks))
 413   (let ((fun
 414          ;; Suppress the compiler output to avoid noise when running the
 415          ;; test. (There are a warning and an error about the package
 416          ;; lock violation and a note about FAST-READ-BYTE being
 417          ;; unused.) It's easy and more precise to test for the error
 418          ;; that the compiled function signals when it is called.
 419          (let ((*error-output* (make-broadcast-stream)))
 420            (compile nil
 421                     '(lambda ()
 422                       (sb-int:with-fast-read-byte (t *standard-input*)
 423                         ;; Signal an error if the symbol is locked.
 424                         (declare (special sb-int:fast-read-byte))))))))
 425     (assert-error (funcall fun) program-error)))
 426
 427 (with-test (:name :sharp-plus-requires-subform)
 428   (assert-error (read-from-string "(let ((foo 3) #+sbcl) wat)"))
 429   (assert-error (read-from-string "(let ((foo 3) #-brand-x) wat)")))
 430
 431 ;; Another test asserting that a signaled condition is printable
 432 (with-test (:name :impossible-number-error)
 433   (locally
 434    (declare (optimize safety)) ; don't flush PRINC-TO-STRING
 435    (princ-to-string (nth-value 1 (ignore-errors (READ-FROM-STRING "1/0"))))))
 436
 437 (with-test (:name :read-from-string-compiler-macro)
 438   ;; evaluation order should be the customary one. In particular,
 439   ;; do not assume that EOF-ERROR-P and EOF-VALUE are constants.
 440   (sb-int:collect ((l))
 441     (read-from-string "a" (l 'first) (l 'second) :start (progn (l 'third) 0))
 442     (assert (equal (l) '(first second third)))))
 443
 444 (with-test (:name :sharp-star-reader-error)
 445   (assert-error (read-from-string (format nil "#~D*" (1+ most-positive-fixnum))) reader-error))
 446
 447 (defun test1 (print &optional expect)
 448   (let ((*readtable* (copy-readtable nil)))
 449     (when print
 450       (format t "READTABLE-CASE  Input   Symbol-name~@
 451                  ----------------------------------~%"))
 452     (dolist (readtable-case '(:upcase :downcase :preserve :invert))
 453       (setf (readtable-case *readtable*) readtable-case)
 454       (dolist (input '("ZEBRA" "Zebra" "zebra"))
 455         (if print
 456             (format t "~&:~A~16T~A~24T~A"
 457                     (string-upcase readtable-case)
 458                     input
 459                     (symbol-name (read-from-string input)))
 460             (assert (string= (symbol-name (read-from-string input))
 461                              (pop expect))))))))
 462
 463 (defun test2 (print &optional expect)
 464   (let ((*readtable* (copy-readtable nil)))
 465     (when print
 466       (format t "READTABLE-CASE *PRINT-CASE*  Symbol-name  Output  Princ~@
 467                  --------------------------------------------------------~%"))
 468     (dolist (readtable-case '(:upcase :downcase :preserve :invert))
 469       (setf (readtable-case *readtable*) readtable-case)
 470       (dolist (*print-case* '(:upcase :downcase :capitalize))
 471         (dolist (symbol '(|ZEBRA| |Zebra| |zebra|))
 472           (if print
 473               (format t "~&:~A~15T:~A~29T~A~42T~A~50T~A"
 474                       (string-upcase readtable-case)
 475                       (string-upcase *print-case*)
 476                       (symbol-name symbol)
 477                       (prin1-to-string symbol)
 478                       (princ-to-string symbol))
 479               (progn
 480                 (assert (string= (prin1-to-string symbol) (pop expect)))
 481                 (assert (string= (princ-to-string symbol) (pop expect))))))))))
 482
 483 (with-test (:name :readtable-cases)
 484   (test1 nil '("ZEBRA" "ZEBRA" "ZEBRA"
 485                "zebra" "zebra" "zebra"
 486                "ZEBRA" "Zebra" "zebra"
 487                "zebra" "Zebra" "ZEBRA"))
 488   (test2 nil '("ZEBRA"   "ZEBRA"
 489                "|Zebra|" "Zebra"
 490                "|zebra|" "zebra"
 491                "zebra"   "zebra"
 492                "|Zebra|" "zebra"
 493                "|zebra|" "zebra"
 494                "Zebra"   "Zebra"
 495                "|Zebra|" "Zebra"
 496                "|zebra|" "zebra"
 497                "|ZEBRA|" "ZEBRA"
 498                "|Zebra|" "ZEBRA"
 499                "ZEBRA"   "ZEBRA"
 500                "|ZEBRA|" "ZEBRA"
 501                "|Zebra|" "Zebra"
 502                "zebra"   "zebra"
 503                "|ZEBRA|" "ZEBRA"
 504                "|Zebra|" "Zebra"
 505                "Zebra"   "Zebra"
 506                "ZEBRA"   "ZEBRA"
 507                "Zebra"   "Zebra"
 508                "zebra"   "zebra"
 509                "ZEBRA"   "ZEBRA"
 510                "Zebra"   "Zebra"
 511                "zebra"   "zebra"
 512                "ZEBRA"   "ZEBRA"
 513                "Zebra"   "Zebra"
 514                "zebra"   "zebra"
 515                "zebra"   "zebra"
 516                "Zebra"   "Zebra"
 517                "ZEBRA"   "ZEBRA"
 518                "zebra"   "zebra"
 519                "Zebra"   "Zebra"
 520                "ZEBRA"   "ZEBRA"
 521                "zebra"   "zebra"
 522                "Zebra"   "Zebra"
 523                "ZEBRA"   "ZEBRA")))
 524
 525 #+sb-unicode
 526 (with-test (:name :base-char-preference)
 527   (let* ((rt (copy-readtable))
 528          (*readtable* rt)
 529          (callcount 0))
 530     (flet ((expect (setting symbol-name-type string-type)
 531              (unless (eq setting :default)
 532                (setf (readtable-base-char-preference rt) setting))
 533              ;; Each test has to intern a new symbol of course.
 534              (let ((input (format nil "MAMALOOK~D" (incf callcount))))
 535                (assert (equal (type-of (symbol-name (read-from-string input)))
 536                               symbol-name-type))
 537                (assert (equal (type-of (read-from-string "\"Foobarbaz\""))
 538                               string-type)))
 539              ;; Also verify that COPY-READTABLE works
 540              (assert (eq (readtable-base-char-preference (copy-readtable rt))
 541                          (readtable-base-char-preference rt)))))
 542       ;; Verify correctness of the stated default as per the docstring
 543       (assert (eq (readtable-base-char-preference rt) :symbols))
 544       ;; Default: prefer base symbols, but CHARACTER strings.
 545       (expect :default '(simple-base-string 9) '(simple-array character (9)))
 546       ;; Prefer base strings, but CHARACTER strings for symbol names
 547       (expect :strings
 548               '(simple-array character (9))
 549               '(simple-base-string 9))
 550       ;; Prefer base-string for everything
 551       (expect :both '(simple-base-string 9) '(simple-base-string 9))
 552       ;; Prefer base-string for neither
 553       (expect nil
 554               '(simple-array character (9))
 555               '(simple-array character (9))))))