tests/reader.impure.lisp

   1 ;;;; tests related to the Lisp reader
   2
   3 ;;;; This file is impure because we want to modify the readtable and stuff.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; While most of SBCL is derived from the CMU CL system, the test
   9 ;;;; files (like this one) were written from scratch after the fork
  10 ;;;; from CMU CL.
  11 ;;;;
  12 ;;;; This software is in the public domain and is provided with
  13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  14 ;;;; more information.
  15
  16 (load "assertoid.lisp")
  17 (use-package "ASSERTOID")
  18
  19 ;;; Test that symbols are properly normalized in SB-UNICODE builds
  20 #+sb-unicode
  21 (with-test (:name (:normalizing-reader)
  22                   :skipped-on '(not :sb-unicode))
  23   (labels ((str (&rest chars)
  24              (coerce chars 'string))
  25            (symbol (&rest chars)
  26              (read-from-string (apply #'str chars))))
  27     (assert (eq :a :a))
  28     (assert (eq :a :A))
  29     (assert (eq (symbol #\UF984) (symbol #\U6FFE)))
  30     (make-package "BAFFLE")
  31     (intern "C" "BAFFLE")
  32     (assert (eq (symbol #\b #\a #\f #\f #\l #\e #\: #\: #\c)
  33                 (symbol #\b #\a #\UFB04 #\e #\: #\: #\c)))
  34     (assert (not (eq (symbol #\| #\f #\f #\l #\|) (symbol #\| #\UFB04 #\|))))
  35     (assert (not (eq (symbol #\\ #\U32C0) (symbol #\1 #\U6708))))
  36     (assert (eq (symbol #\U32C0) (symbol #\1 #\U6708)))
  37     (let ((*readtable* (copy-readtable)))
  38       (setf (sb-ext:readtable-normalization *readtable*) nil)
  39       (assert (not (eq (symbol #\b #\a #\f #\f #\l #\e)
  40                        (symbol #\b #\a #\UFB04 #\e))))
  41       (assert (not (eq (symbol #\U32C0) (symbol #\1 #\U6708)))))))
  42
  43 ;;; Bug 30, involving mistakes in binding the read table, made this
  44 ;;; code fail.
  45 (defun read-vector (stream char)
  46   (declare (ignorable char))
  47   (coerce (read-delimited-list #\] stream t) 'vector))
  48 (set-macro-character #\[ #'read-vector nil)
  49 (set-macro-character #\] (get-macro-character #\)) nil)
  50 (multiple-value-bind (res pos)
  51     (read-from-string "[1 2 3]") ; ==> #(1 2 3), 7
  52   (assert (equalp res #(1 2 3)))
  53   (assert (= pos 7)))
  54 (multiple-value-bind (res pos)
  55     (read-from-string "#\\x") ; ==> #\x, 3
  56   (assert (equalp res #\x))
  57   (assert (= pos 3)))
  58 (multiple-value-bind (res pos)
  59     (read-from-string "[#\\x]")
  60   (assert (equalp res #(#\x)))
  61   (assert (= pos 5)))
  62
  63 ;;; Bug 51b. (try to throw READER-ERRORs when the reader encounters
  64 ;;; dubious input)
  65 (assert-error (read-from-string "1e1000") reader-error)
  66 (assert-error (read-from-string "1/0") reader-error)
  67
  68 ;;; Bug reported by Antonio Martinez on comp.lang.lisp 2003-02-03 in
  69 ;;; message <b32da960.0302030640.7d6fc610@posting.google.com>: reading
  70 ;;; circular instances of CLOS classes didn't work:
  71 (defclass box ()
  72   ((value :initarg :value :reader value)))
  73 (defun read-box (stream char)
  74   (declare (ignore char))
  75   (let ((objects (read-delimited-list #\] stream t)))
  76     (unless (= 1 (length objects))
  77       (error "Unknown box reader syntax"))
  78     (make-instance 'box :value (first objects))))
  79 (set-macro-character #\[ 'read-box)
  80 (assert (eq (get-macro-character #\[) 'read-box)) ; not #'READ-BOX
  81 (set-syntax-from-char #\] #\))
  82 (multiple-value-bind (res pos)
  83     (read-from-string "#1=[#1#]")
  84   (assert (eq (value res) res))
  85   (assert (= pos 8)))
  86 ;;; much, much, later (in Feb 2007), CSR noticed that the problem
  87 ;;; still exists for funcallable instances.
  88 (defclass funcallable-box (box sb-mop:funcallable-standard-object) ()
  89   (:metaclass sb-mop:funcallable-standard-class))
  90 (defun read-funcallable-box (stream char)
  91   (declare (ignore char))
  92   (let ((objects (read-delimited-list #\} stream t)))
  93     (unless (= 1 (length objects))
  94       (error "Unknown box reader syntax"))
  95     (make-instance 'funcallable-box :value (first objects))))
  96 (set-macro-character #\{ 'read-funcallable-box)
  97 (set-syntax-from-char #\} #\))
  98 (multiple-value-bind (res pos)
  99     (read-from-string "#1={#1#}")
 100   (assert (eq (value res) res))
 101   (assert (= pos 8)))
 102
 103 ;;; CSR managed to break the #S reader macro in the process of merging
 104 ;;; SB-PCL:CLASS and CL:CLASS -- make sure it works
 105 (defstruct readable-struct a)
 106 (macrolet
 107     ((frob (string)
 108        `(assert (eq (readable-struct-a (read-from-string ,string)) t))))
 109   (frob "#S(READABLE-STRUCT :A T)")
 110   (frob "#S(READABLE-STRUCT A T)")
 111   (frob "#S(READABLE-STRUCT \"A\" T)")
 112   (frob "#S(READABLE-STRUCT #\\A T)")
 113   (frob "#S(READABLE-STRUCT #\\A T :A NIL)"))
 114 (macrolet
 115     ((frob (string)
 116        `(assert-error (read-from-string ,string) reader-error)))
 117   (frob "#S(READABLE-STRUCT . :A)")
 118   (frob "#S(READABLE-STRUCT :A . T)")
 119   (frob "#S(READABLE-STRUCT :A T . :A)")
 120   (frob "#S(READABLE-STRUCT :A T :A . T)"))
 121
 122 ;;; reported by Henrik Motakef
 123 (defpackage "")
 124 (assert (eq (symbol-package (read-from-string "||::FOO"))
 125             (find-package "")))
 126
 127 ;;; test nested reads, test case by Helmut Eller for cmucl
 128 (defclass my-in-stream (sb-gray:fundamental-character-input-stream)
 129   ((last-char :initarg :last-char)))
 130
 131 (let ((string " a ")
 132       (i 0))
 133   (defmethod sb-gray:stream-read-char ((s my-in-stream))
 134     (with-input-from-string (s "b") (read s))
 135     (with-slots (last-char) s
 136       (cond (last-char (prog1 last-char (setf last-char nil)))
 137              (t (prog1 (aref string i)
 138                   (setq i (mod (1+ i) (length string)))))))))
 139
 140 (defmethod sb-gray:stream-unread-char ((s my-in-stream) char)
 141   (setf (slot-value s 'last-char) char)
 142   nil)
 143
 144 (assert (eq 'a (read (make-instance 'my-in-stream :last-char nil))))
 145
 146 ;;; NIL as the last argument to SET-SYNTAX-FROM-CHAR in compiled code,
 147 ;;; reported by Levente Mészáros
 148 (let ((fun (compile nil '(lambda ()
 149                           (set-syntax-from-char #\{ #\( *readtable* nil)))))
 150   (funcall fun)
 151   (assert (equal '(:ok) (read-from-string "{:ok)"))))
 152
 153 (with-test (:name :bad-recursive-read)
 154   ;; This use to signal an unbound-variable error instead.
 155   (assert (eq :error
 156               (handler-case
 157                   (with-input-from-string (s "42")
 158                     (read s t nil t))
 159                 (reader-error ()
 160                   :error)))))
 161
 162 (with-test (:name :standard-readtable-modified)
 163   (macrolet ((test (form &optional op)
 164                `(assert
 165                  (eq :error
 166                      (handler-case
 167                          (progn ,form t)
 168                        (sb-int:standard-readtable-modified-error (e)
 169                          (declare (ignorable e))
 170                          ,@(when op
 171                             `((assert
 172                                (equal ,op (sb-kernel::standard-readtable-modified-operation e)))))
 173                          :error))))))
 174     (let ((rt *readtable*))
 175      (with-standard-io-syntax
 176        (let ((srt *readtable*))
 177          (test (setf (readtable-case srt) :preserve) '(setf readtable-case))
 178          (test (copy-readtable rt srt) 'copy-readtable)
 179          (test (set-syntax-from-char #\a #\a srt rt) 'set-syntax-from-char)
 180          (test (set-macro-character #\a (constantly t) t srt) 'set-macro-character)
 181          (test (make-dispatch-macro-character #\! t srt))
 182          (test (set-dispatch-macro-character #\# #\a (constantly t) srt) 'set-dispatch-macro-character))))))
 183
 184 (with-test (:name :reader-package-errors)
 185   (flet ((test (string)
 186            (handler-case
 187                (progn (read-from-string string) :feh)
 188              (error (e)
 189                (when (and (typep e 'reader-error) (typep e 'package-error))
 190                  (package-error-package e))))))
 191     (assert (equal "NO-SUCH-PKG" (test "no-such-pkg::foo")))
 192     (assert (eq (find-package :cl) (test "cl:no-such-sym")))))
 193
 194 ;; lp# 1012335 - also tested by 'READ-BOX above
 195 (handler-bind ((condition #'continue))
 196     (defun nil (stream char) (declare (ignore stream char)) 'foo!))
 197 (with-test (:name :set-macro-char-lazy-coerce-to-fun)
 198   (set-macro-character #\$ #'nil) ; #'NIL is a function
 199   (assert (eq (read-from-string "$") 'foo!))
 200
 201   (make-dispatch-macro-character #\$)
 202   (assert (set-dispatch-macro-character #\$ #\( 'read-metavar))
 203   (assert (eq (get-dispatch-macro-character #\$ #\() 'read-metavar))
 204   (assert (eq (handler-case (read-from-string "$(x)")
 205                 (undefined-function (c)
 206                   (if (eq (cell-error-name c) 'read-metavar) :win)))
 207               :win))
 208   (defun read-metavar (stream subchar arg)
 209     (declare (ignore subchar arg))
 210     (list :metavar (read stream t nil t)))
 211   (assert (equal (read-from-string "$(x)") '(:metavar x)))
 212
 213   (set-macro-character #\$ nil) ; 'NIL never designates a function
 214   (assert (eq (read-from-string "$") '$))
 215
 216   ;; Do not accept extended-function-designators.
 217   ;; (circumlocute to prevent a compile-time error)
 218   (let ((designator (eval ''(setf no-no-no))))
 219     (assert (eq (handler-case (set-macro-character #\$ designator)
 220                   (type-error () :ok))
 221                 :ok))
 222     (assert (eq (handler-case
 223                     (set-dispatch-macro-character #\# #\$ designator)
 224                   (type-error () :ok))
 225                 :ok))))
 226
 227 (defun cl-user::esoteric-load-thing ()
 228   ;; This LOAD-AS-SOURCE will fail if PRINT1 reads as the keyword :PRIN1
 229   (let ((s (make-string-input-stream
 230             "(cl:in-package :cl-user) (prin1 'okey-dokey)")))
 231     (let ((*package* *package*))
 232       (sb-impl::load-as-source s :print t :verbose t))))
 233
 234 (with-test (:name :reader-package-in-conditional)
 235   ;; Sharp-plus binds *package* but not *reader-package* so that if,
 236   ;; while reading the conditional expression itself, a read-time eval occurs
 237   ;; expressly changing *package*, it should do whan you mean,
 238   ;; though such usage is a little insane.
 239   (let ((value
 240          (read-from-string
 241           "(#+#.(cl:progn (cl-user::esoteric-load-thing) 'sbcl) hiyya hoho)")))
 242     (assert (equal value '(hiyya hoho)))))
 243
 244 #+sb-unicode
 245 (with-test (:name :unicode-dispatch-macros)
 246   (let ((*readtable* (copy-readtable)))
 247     (make-dispatch-macro-character (code-char #x266F)) ; musical sharp
 248     (set-dispatch-macro-character
 249      (code-char #x266F) (code-char #x221E) ; #\Infinity
 250      (lambda (stream char arg)
 251        (declare (ignore stream char arg))
 252        :infinity))
 253     (let ((x (read-from-string
 254               (map 'string #'code-char '(#x266F #x221E)))))
 255       (assert (eq x :infinity))
 256       (set-dispatch-macro-character (code-char #x266F) (code-char #x221E) nil)
 257       (assert (zerop (hash-table-count
 258                       (car (sb-impl::%dispatch-macro-char-table
 259                             (get-macro-character (code-char #x266F)))))))))
 260
 261   (let ((*readtable* (copy-readtable)))
 262     (make-dispatch-macro-character (code-char #xbeef))
 263     (set-dispatch-macro-character (code-char #xbeef) (code-char #xf00d)
 264                                   'beef-f00d)
 265     (set-dispatch-macro-character (code-char #xbeef) (code-char #xd00d)
 266                                   'beef-d00d)
 267     (set-syntax-from-char (code-char #xfeed) (code-char #xbeef)
 268                           *readtable* *readtable*)
 269     (assert (eq (get-dispatch-macro-character (code-char #xfeed)
 270                                               (code-char #xf00d))
 271                 'beef-f00d))
 272     (set-dispatch-macro-character (code-char #xfeed) (code-char #xf00d)
 273                                   'read-feed-food)
 274     (assert (eq (get-dispatch-macro-character (code-char #xbeef)
 275                                               (code-char #xf00d))
 276                 'beef-f00d))
 277     (set-dispatch-macro-character (code-char #xbeef) #\W 'read-beef-w)
 278     (assert (null (get-dispatch-macro-character (code-char #xfeed) #\W)))
 279     (set-syntax-from-char (code-char #xbeef) #\a)
 280     (set-syntax-from-char (code-char #xfeed) #\b)
 281     (set-syntax-from-char (code-char 35) #\a) ; sharp is dead
 282     (assert (null (sb-impl::dispatch-tables *readtable*))))
 283
 284   ;; Ensure the interface provided for named-readtables remains somewhat intact.
 285   (let ((*readtable* (copy-readtable)))
 286     (make-dispatch-macro-character #\@)
 287     (set-dispatch-macro-character #\@ #\a 'read-at-a)
 288     (set-dispatch-macro-character #\@ #\$ 'read-at-dollar)
 289     (set-dispatch-macro-character #\@ #\* #'sb-impl::sharp-star)
 290     ;; Enter exactly one character in the Unicode range because
 291     ;; iteratation order is arbitrary and assert would be fragile.
 292     ;; ASCII characters are naturally ordered by code.
 293     (set-dispatch-macro-character #\@ (code-char #x2010) 'read-blah)
 294     (let ((rt (copy-readtable *readtable*)))
 295       ;; Don't want to assert about all the standard noise,
 296       ;; and also don't want to kill the ability to write #\char
 297       (set-syntax-from-char #\# #\a rt)
 298       (assert (equal (sb-impl::dispatch-tables rt nil)
 299                      `((#\@ (#\A . read-at-a)
 300                             (#\* . ,#'sb-impl::sharp-star)
 301                             (#\$ . read-at-dollar)
 302                             (#\hyphen . read-blah))))))
 303     ;; this removes one entry rather than entering NIL in the hashtable
 304     (set-dispatch-macro-character #\@ (code-char #x2010) nil)
 305     (let ((rt (copy-readtable *readtable*)))
 306       (set-syntax-from-char #\# #\a rt)
 307       (assert (equal (sb-impl::dispatch-tables rt nil)
 308                      `((#\@ (#\A . read-at-a)
 309                             (#\* . ,#'sb-impl::sharp-star)
 310                             (#\$ . read-at-dollar))))))))
 311
 312 (with-test (:name :copy-dispatching-macro)
 313   (let ((*readtable* (copy-readtable)))
 314     (set-macro-character #\$ (get-macro-character #\#) t)
 315     (let ((foo (read-from-string "$(a b c)")))
 316       (assert (equalp foo #(a b c))))
 317     (set-dispatch-macro-character #\$ #\[
 318       (lambda (stream char arg)
 319         (declare (ignore char arg))
 320         (append '(:start) (read-delimited-list #\] stream t) '(:end))))
 321     (set-syntax-from-char #\] #\))
 322     (let ((foo (read-from-string "$[a b c]")))
 323       (assert (equal foo '(:start a b c :end))))
 324     ;; dispatch tables get shared. This behavior is SBCL-specific.
 325     (let ((foo (read-from-string "#[a b c]")))
 326       (assert (equal foo '(:start a b c :end))))))
 327
 328 ;;; THIS SHOULD BE LAST as it frobs the standard readtable
 329 (with-test (:name :set-macro-character-nil)
 330   (handler-bind ((sb-int:standard-readtable-modified-error #'continue))
 331
 332     (let ((fun (lambda (&rest args) (declare (ignore args)) 'ok)))
 333       ;; NIL means the standard readtable.
 334       (assert (eq t (set-macro-character #\~ fun nil nil)))
 335       (assert (eq fun (get-macro-character #\~ nil)))
 336       (assert (eq t (set-dispatch-macro-character #\# #\~ fun nil)))
 337       (assert (eq fun (get-dispatch-macro-character #\# #\~ nil))))))
 338
 339 ;;; success