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 ;;; All these must return a primary value of NIL when *read-suppress* is T
 215 ;;; Reported by Bruno Haible on cmucl-imp 2004-10-25.
 216 (with-test (:name :read-suppress-char-macros)
 217   (let ((*read-suppress* t))
 218     (assert (null (read-from-string "(1 2 3)")))
 219     (assert (null (with-input-from-string (s "abc xyz)")
 220                     (read-delimited-list #\) s))))
 221     (assert (null (with-input-from-string (s "(1 2 3)")
 222                     (read-preserving-whitespace s))))
 223     (assert (null (with-input-from-string (s "(1 2 3)")
 224                     (read s))))
 225     ;; .. and it's better to avoid consing rather than produce an object and
 226     ;; throw it away, even though it's (mostly) indistinguishable to the user.
 227     (let ((input (make-string-input-stream "this-is-a-string! .")))
 228       (assert (string= (sb-impl::with-read-buffer ()
 229                          (sb-impl::read-string input #\!))
 230                        "")))))
 231
 232 ;;; System code that asks whether %READ-PRESERVING-WHITESPACE hit EOF
 233 ;;; mistook NIL as an object returned normally for NIL the default eof mark.
 234 (with-test (:name :read-preserving-whitespace-file-position)
 235   (multiple-value-bind (obj pos1) (read-from-string "NIL A")
 236     (declare (ignore obj))
 237     (multiple-value-bind (obj pos2) (read-from-string "NNN A")
 238       (declare (ignore obj))
 239       (assert (= pos1 pos2 4))))
 240   ;; This also affected *READ-SUPPRESS*. The root cause is the same,
 241   ;; but the rationale for why the change is valid is slightly subtle
 242   ;; on account of the vague if not weird implication regarding READ
 243   ;; that there might actually be differences in non-preservation of
 244   ;; whitespace based on *READ-SUPPRESS*. CLHS entry for READ:
 245   ;;  "When *read-suppress* is false, read throws away the delimiting
 246   ;;   character required by certain printed representations if it is a
 247   ;;   whitespace[2] character; but read preserves the character (using
 248   ;;   unread-char) if it is syntactically meaningful, because it could
 249   ;;   be the start of the next expression."
 250   ;; Why would it mention *read-supress* at all, unless the expectation
 251   ;; is that when suppressing you might /not/ throw away a space?
 252   ;; But it isn't "when-and-only-when" so we're certainly legal to
 253   ;; make the behavior identical regardless of *read-suppress*.
 254   (dolist (test '("#-q 1 2" "#+sbcl 1 2")) ; Two tests from lp#327790.
 255     (flet ((try (*read-suppress*)
 256              (with-input-from-string (s test)
 257                (read s)
 258                (file-position s))))
 259       (assert (= (try nil) (try t)))))
 260   ;; Check that conversion from local eof-object to user-specified eof
 261   ;; object is nearly perfectly immune to false positives.
 262   ;; The only remaining confusion is that
 263   ;;   (read-from-string "#.(code-header-ref (fun-code-header #'read) 6)")
 264   ;; returns NIL instead of (NIL) [subject to change depending on
 265   ;; what 6 should be] but that is too ridiculous to worry about.
 266   (assert (eq (read-from-string "#.sb-impl::*eof-object*")
 267               sb-impl::*eof-object*)))
 268
 269 ;;; EOF-ERROR-P defaults to true. Reported by Bruno Haible on
 270 ;;; cmucl-imp 2004-10-18.
 271 (multiple-value-bind (res err) (ignore-errors (read-from-string ""))
 272   (assert (not res))
 273   (assert (typep err 'end-of-file)))
 274
 275 (assert (equal '((0 . "A") (1 . "B"))
 276                (coerce (read-from-string "#((0 . \"A\") (1 . \"B\"))")
 277                        'list)))
 278
 279 ;;; parse-integer uses whitespace[1] not whitespace[2] as its
 280 ;;; definition of whitespace to skip.
 281 (let ((*readtable* (copy-readtable)))
 282   (set-syntax-from-char #\7 #\Space)
 283   (assert (= 710 (parse-integer "710"))))
 284
 285 (let ((*readtable* (copy-readtable)))
 286   (set-syntax-from-char #\7 #\Space)
 287   (assert (string= (format nil "~7D" 1) "      1")))
 288
 289 (let ((symbol (find-symbol "DOES-NOT-EXIST" "CL-USER")))
 290   (assert (null symbol))
 291   (handler-case
 292       (read-from-string "CL-USER:DOES-NOT-EXIST")
 293     (reader-error (c)
 294       (princ c))))
 295
 296 ;;; The GET-MACRO-CHARACTER in SBCL <= "1.0.34.2" bogusly computed its
 297 ;;; second return value relative to *READTABLE* rather than the passed
 298 ;;; readtable.
 299 (let* ((*readtable* (copy-readtable nil)))
 300   (set-syntax-from-char #\" #\A)
 301   (multiple-value-bind (reader-fn non-terminating-p)
 302       (get-macro-character #\" (copy-readtable nil))
 303     (declare (ignore reader-fn))
 304     (assert (not non-terminating-p))))
 305
 306 (with-test (:name :bug-309093)
 307   (assert (eq :error
 308               (handler-case
 309                   (read-from-string "`#2A((,(1+ 0) 0) (0 0))")
 310                 (reader-error ()
 311                   :error)))))
 312
 313 (with-test (:name :set-syntax-from-char-dispatch-macro-char)
 314   (let ((rt (copy-readtable)))
 315     (make-dispatch-macro-character #\! nil rt)
 316     (set-dispatch-macro-character #\! #\! (constantly 'bang^2) rt)
 317     (flet ((maybe-bang ()
 318              (let ((*readtable* rt))
 319                (read-from-string "!!"))))
 320       (assert (eq 'bang^2 (maybe-bang)))
 321       (set-syntax-from-char #\! #\! rt)
 322       (assert (eq '!! (maybe-bang))))))
 323
 324 (with-test (:name :read-in-package-syntax)
 325   (assert (equal '(sb-c::a (sb-kernel::x sb-kernel::y) sb-c::b)
 326                  (read-from-string "sb-c::(a sb-kernel::(x y) b)")))
 327   (assert (equal '(cl-user::yes-this-is-sbcl)
 328                  (read-from-string "cl-user::(#+sbcl yes-this-is-sbcl)")))
 329   #+sb-package-locks
 330   (assert (eq :violated!
 331               (handler-case
 332                   (read-from-string "cl::'foo")
 333                 (package-lock-violation ()
 334                   :violated!)))))
 335
 336 (with-test (:name :bug-309070)
 337   (with-timeout 10
 338     (assert-error (read-from-string "10e10000000000000000000")
 339                   sb-kernel:reader-impossible-number-error)))
 340
 341 (with-test (:name :bug-1095918)
 342   (assert (= (length `#3(1)) 3)))
 343
 344 (with-test (:name :obscure-reader-package-usage)
 345   ;; commit 8fd604 cause a bug in reading "::(foo bar)" which tried
 346   ;; to treat the package-designator as a string, but in this case
 347   ;; it is hardcoded to *keyword-package*.
 348   (assert (equal (read-from-string "::(foo bar)") '(:foo :bar))))
 349
 350 #+x86-64
 351 ;; I do not know the complete list of platforms for which this test
 352 ;; will not cons, but there were four different heap allocations
 353 ;; instead of using dx allocation or a recyclable resource:
 354 ;;  - most obviously, a 128-character buffer per invocation of READ
 355 ;;  - calling SUBSEQ for package names
 356 ;;  - multiple-value-call in WITH-CHAR-MACRO-RESULT
 357 ;;  - the initial cons cell in READ-LIST
 358 (with-test (:name :read-does-not-cons-per-se)
 359   (flet ((test-reading (string)
 360            (let ((s (make-string-input-stream string)))
 361              (read s) ; once outside the loop, to make A-SYMBOL
 362              (ctu:assert-no-consing
 363               (progn (file-position s 0)
 364                      (read s))
 365               40000))))
 366     ;; These each used to produce at least 20 MB of garbage,
 367     ;; a result of using 128-character (= 512 bytes for Unicode) buffers.
 368     ;; Now we use exactly one buffer, or maybe two for package + symbol-name.
 369     ;; There is no way to allow an allocation of precisely 512 bytes
 370     ;; without counting a whole allocation page against this test.
 371     ;; If you get unlucky, the tests might cons one SB-IMPL::TOKEN-BUFFER.
 372     ;; And if you get really unlucky, that might be the straw that breaks
 373     ;; the camel's back - forcing the use of a new GC page, which looks
 374     ;; like it consed 32768 bytes on the old page. Due to the allowable
 375     ;; tolerance in CHECK-CONSING, running the test more times than there
 376     ;; are bytes consed should pass for "no consing" because it's obviously
 377     ;; impossible to cons 1 byte per run.
 378     ;; If this still fails, it might be due to somebody changing the
 379     ;; backend-page-bytes to exceed 32KB. Not sure what to do about that.
 380     (test-reading "4.0s0")
 381     (test-reading "COMMON-LISP-USER::A-SYMBOL")
 382     (test-reading "()")
 383     (test-reading "#\\-") ; should not copy the token buffer
 384     ;; *READ-SUPPRESS* avoids creation of lists
 385     (test-reading "#-sbcl(a (b c (d (e) (f) g)) h i j . x . y baz) 5")
 386     ))
 387
 388 (with-test (:name :sharp-left-paren-empty-list)
 389   (assert (read-from-string "#0()")) ; edge case that works
 390   (assert (eq (handler-case (read-from-string "#3()")
 391                 (sb-int:simple-reader-error () :win))
 392               :win)))
 393
 394 (with-test (:name :sharp-star-empty-multiple-escapes)
 395   (assert (eq (handler-case (read-from-string "#*101||1")
 396                 (sb-int:simple-reader-error () :win))
 397               :win)))
 398
 399 ;;; The WITH-FAST-READ-BYTE macro accidentally left the package lock
 400 ;;; of FAST-READ-BYTE disabled during its body.
 401 (with-test (:name :fast-read-byte-package-lock
 402             :skipped-on '(not :sb-package-locks))
 403   (let ((fun
 404          ;; Suppress the compiler output to avoid noise when running the
 405          ;; test. (There are a warning and an error about the package
 406          ;; lock violation and a note about FAST-READ-BYTE being
 407          ;; unused.) It's easy and more precise to test for the error
 408          ;; that the compiled function signals when it is called.
 409          (let ((*error-output* (make-broadcast-stream)))
 410            (compile nil
 411                     '(lambda ()
 412                       (sb-int:with-fast-read-byte (t *standard-input*)
 413                         ;; Signal an error if the symbol is locked.
 414                         (declare (special sb-int:fast-read-byte))))))))
 415     (assert-error (funcall fun) program-error)))
 416
 417 (with-test (:name :sharp-plus-requires-subform)
 418   (assert-error (read-from-string "(let ((foo 3) #+sbcl) wat)"))
 419   (assert-error (read-from-string "(let ((foo 3) #-brand-x) wat)")))
 420
 421 (with-test (:name :impossible-number-error)
 422   (princ (nth-value 1 (ignore-errors (READ-FROM-STRING "1/0")))))