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