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        `(handler-bind ((warning #'muffle-warning))
 109           (assert (eq (readable-struct-a (read-from-string ,string)) 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)")
 114   (frob "#S(READABLE-STRUCT #\\A T :A NIL)"))
 115 (macrolet
 116     ((frob (string)
 117        `(assert-error (read-from-string ,string) reader-error)))
 118   (frob "#S(READABLE-STRUCT . :A)")
 119   (frob "#S(READABLE-STRUCT :A . T)")
 120   (frob "#S(READABLE-STRUCT :A T . :A)")
 121   (frob "#S(READABLE-STRUCT :A T :A . T)"))
 122
 123 ;;; reported by Henrik Motakef
 124 (defpackage "")
 125 (assert (eq (symbol-package (read-from-string "||::FOO"))
 126             (find-package "")))
 127
 128 ;;; test nested reads, test case by Helmut Eller for cmucl
 129 (defclass my-in-stream (sb-gray:fundamental-character-input-stream)
 130   ((last-char :initarg :last-char)))
 131
 132 (let ((string " a ")
 133       (i 0))
 134   (defmethod sb-gray:stream-read-char ((s my-in-stream))
 135     (with-input-from-string (s "b") (read s))
 136     (with-slots (last-char) s
 137       (cond (last-char (prog1 last-char (setf last-char nil)))
 138              (t (prog1 (aref string i)
 139                   (setq i (mod (1+ i) (length string)))))))))
 140
 141 (defmethod sb-gray:stream-unread-char ((s my-in-stream) char)
 142   (setf (slot-value s 'last-char) char)
 143   nil)
 144
 145 (assert (eq 'a (read (make-instance 'my-in-stream :last-char nil))))
 146
 147 ;;; NIL as the last argument to SET-SYNTAX-FROM-CHAR in compiled code,
 148 ;;; reported by Levente Mészáros
 149 (let ((fun (compile nil '(lambda ()
 150                           (set-syntax-from-char #\{ #\( *readtable* nil)))))
 151   (funcall fun)
 152   (assert (equal '(:ok) (read-from-string "{:ok)"))))
 153
 154 (with-test (:name :bad-recursive-read)
 155   ;; This use to signal an unbound-variable error instead.
 156   (assert (eq :error
 157               (handler-case
 158                   (with-input-from-string (s "42")
 159                     (read s t nil t))
 160                 (reader-error ()
 161                   :error)))))
 162
 163 (with-test (:name :standard-readtable-modified)
 164   (macrolet ((test (form &optional op)
 165                `(assert
 166                  (eq :error
 167                      (handler-case
 168                          (progn ,form t)
 169                        (sb-int:standard-readtable-modified-error (e)
 170                          (declare (ignorable e))
 171                          ,@(when op
 172                             `((assert
 173                                (equal ,op (sb-kernel::standard-readtable-modified-operation e)))))
 174                          :error))))))
 175     (let ((rt *readtable*))
 176      (with-standard-io-syntax
 177        (let ((srt *readtable*))
 178          (test (setf (readtable-case srt) :preserve) '(setf readtable-case))
 179          (test (copy-readtable rt srt) 'copy-readtable)
 180          (test (set-syntax-from-char #\a #\a srt rt) 'set-syntax-from-char)
 181          (test (set-macro-character #\a (constantly t) t srt) 'set-macro-character)
 182          (test (make-dispatch-macro-character #\! t srt))
 183          (test (set-dispatch-macro-character #\# #\a (constantly t) srt) 'set-dispatch-macro-character))))))
 184
 185 (with-test (:name :reader-package-errors)
 186   (flet ((test (string)
 187            (handler-case
 188                (progn (read-from-string string) :feh)
 189              (error (e)
 190                (when (and (typep e 'reader-error) (typep e 'package-error))
 191                  (package-error-package e))))))
 192     (assert (equal "NO-SUCH-PKG" (test "no-such-pkg::foo")))
 193     (assert (eq (find-package :cl) (test "cl:no-such-sym")))))
 194
 195 ;; lp# 1012335 - also tested by 'READ-BOX above
 196 (handler-bind ((condition #'continue))
 197     (defun nil (stream char) (declare (ignore stream char)) 'foo!))
 198 (with-test (:name :set-macro-char-lazy-coerce-to-fun)
 199   (set-macro-character #\$ #'nil) ; #'NIL is a function
 200   (assert (eq (read-from-string "$") 'foo!))
 201
 202   (make-dispatch-macro-character #\$)
 203   (assert (set-dispatch-macro-character #\$ #\( 'read-metavar))
 204   (assert (eq (get-dispatch-macro-character #\$ #\() 'read-metavar))
 205   (assert (eq (handler-case (read-from-string "$(x)")
 206                 (undefined-function (c)
 207                   (if (eq (cell-error-name c) 'read-metavar) :win)))
 208               :win))
 209   (defun read-metavar (stream subchar arg)
 210     (declare (ignore subchar arg))
 211     (list :metavar (read stream t nil t)))
 212   (assert (equal (read-from-string "$(x)") '(:metavar x)))
 213
 214   (set-macro-character #\$ nil) ; 'NIL never designates a function
 215   (assert (eq (read-from-string "$") '$))
 216
 217   ;; Do not accept extended-function-designators.
 218   ;; (circumlocute to prevent a compile-time error)
 219   (let ((designator (eval ''(setf no-no-no))))
 220     (assert (eq (handler-case (set-macro-character #\$ designator)
 221                   (type-error () :ok))
 222                 :ok))
 223     (assert (eq (handler-case
 224                     (set-dispatch-macro-character #\# #\$ designator)
 225                   (type-error () :ok))
 226                 :ok))))
 227
 228 (defun cl-user::esoteric-load-thing ()
 229   ;; This LOAD-AS-SOURCE will fail if SET reads as the keyword :SET
 230   (let ((s (make-string-input-stream
 231             "(cl:in-package :cl-user) (set 'okey-dokey 3)")))
 232     (let ((*package* *package*))
 233       (sb-impl::load-as-source s :print nil :verbose nil))
 234     (assert (eql (symbol-value 'cl-user::okey-dokey) 3))))
 235
 236 (with-test (:name :reader-package-in-conditional)
 237   ;; Sharp-plus binds *package* but not *reader-package* so that if,
 238   ;; while reading the conditional expression itself, a read-time eval occurs
 239   ;; expressly changing *package*, it should do whan you mean,
 240   ;; though such usage is a little insane.
 241   (let ((value
 242          (read-from-string
 243           "(#+#.(cl:progn (cl-user::esoteric-load-thing) 'sbcl) hiyya hoho)")))
 244     (assert (equal value '(hiyya hoho)))))
 245
 246 #+sb-unicode
 247 (with-test (:name :unicode-dispatch-macros)
 248   (let ((*readtable* (copy-readtable)))
 249     (make-dispatch-macro-character (code-char #x266F)) ; musical sharp
 250     (set-dispatch-macro-character
 251      (code-char #x266F) (code-char #x221E) ; #\Infinity
 252      (lambda (stream char arg)
 253        (declare (ignore stream char arg))
 254        :infinity))
 255     (let ((x (read-from-string
 256               (map 'string #'code-char '(#x266F #x221E)))))
 257       (assert (eq x :infinity))
 258       (set-dispatch-macro-character (code-char #x266F) (code-char #x221E) nil)
 259       (assert (zerop (hash-table-count
 260                       (car (sb-impl::%dispatch-macro-char-table
 261                             (get-macro-character (code-char #x266F)))))))))
 262
 263   (let ((*readtable* (copy-readtable)))
 264     (make-dispatch-macro-character (code-char #xbeef))
 265     (set-dispatch-macro-character (code-char #xbeef) (code-char #xf00d)
 266                                   'beef-f00d)
 267     (set-dispatch-macro-character (code-char #xbeef) (code-char #xd00d)
 268                                   'beef-d00d)
 269     (set-syntax-from-char (code-char #xfeed) (code-char #xbeef)
 270                           *readtable* *readtable*)
 271     (assert (eq (get-dispatch-macro-character (code-char #xfeed)
 272                                               (code-char #xf00d))
 273                 'beef-f00d))
 274     (set-dispatch-macro-character (code-char #xfeed) (code-char #xf00d)
 275                                   'read-feed-food)
 276     (assert (eq (get-dispatch-macro-character (code-char #xbeef)
 277                                               (code-char #xf00d))
 278                 'beef-f00d))
 279     (set-dispatch-macro-character (code-char #xbeef) #\W 'read-beef-w)
 280     (assert (null (get-dispatch-macro-character (code-char #xfeed) #\W)))
 281     (set-syntax-from-char (code-char #xbeef) #\a)
 282     (set-syntax-from-char (code-char #xfeed) #\b)
 283     (set-syntax-from-char (code-char 35) #\a) ; sharp is dead
 284     (assert (null (sb-impl::dispatch-tables *readtable*))))
 285
 286   ;; Ensure the interface provided for named-readtables remains somewhat intact.
 287   (let ((*readtable* (copy-readtable)))
 288     (make-dispatch-macro-character #\@)
 289     (set-dispatch-macro-character #\@ #\a 'read-at-a)
 290     (set-dispatch-macro-character #\@ #\$ 'read-at-dollar)
 291     (set-dispatch-macro-character #\@ #\* #'sb-impl::sharp-star)
 292     ;; Enter exactly one character in the Unicode range because
 293     ;; iteratation order is arbitrary and assert would be fragile.
 294     ;; ASCII characters are naturally ordered by code.
 295     (set-dispatch-macro-character #\@ (code-char #x2010) 'read-blah)
 296     (let ((rt (copy-readtable *readtable*)))
 297       ;; Don't want to assert about all the standard noise,
 298       ;; and also don't want to kill the ability to write #\char
 299       (set-syntax-from-char #\# #\a rt)
 300       (assert (equal (sb-impl::dispatch-tables rt nil)
 301                      `((#\@ (#\A . read-at-a)
 302                             (#\* . ,#'sb-impl::sharp-star)
 303                             (#\$ . read-at-dollar)
 304                             (#\hyphen . read-blah))))))
 305     ;; this removes one entry rather than entering NIL in the hashtable
 306     (set-dispatch-macro-character #\@ (code-char #x2010) nil)
 307     (let ((rt (copy-readtable *readtable*)))
 308       (set-syntax-from-char #\# #\a rt)
 309       (assert (equal (sb-impl::dispatch-tables rt nil)
 310                      `((#\@ (#\A . read-at-a)
 311                             (#\* . ,#'sb-impl::sharp-star)
 312                             (#\$ . read-at-dollar))))))))
 313
 314 (with-test (:name :copy-dispatching-macro)
 315   (let ((*readtable* (copy-readtable)))
 316     (set-macro-character #\$ (get-macro-character #\#) t)
 317     (let ((foo (read-from-string "$(a b c)")))
 318       (assert (equalp foo #(a b c))))
 319     (set-dispatch-macro-character #\$ #\[
 320       (lambda (stream char arg)
 321         (declare (ignore char arg))
 322         (append '(:start) (read-delimited-list #\] stream t) '(:end))))
 323     (set-syntax-from-char #\] #\))
 324     (let ((foo (read-from-string "$[a b c]")))
 325       (assert (equal foo '(:start a b c :end))))
 326     ;; dispatch tables get shared. This behavior is SBCL-specific.
 327     (let ((foo (read-from-string "#[a b c]")))
 328       (assert (equal foo '(:start a b c :end))))))
 329
 330 ;;; THIS SHOULD BE LAST as it frobs the standard readtable
 331 (with-test (:name :set-macro-character-nil)
 332   (handler-bind ((sb-int:standard-readtable-modified-error #'continue))
 333
 334     (let ((fun (lambda (&rest args) (declare (ignore args)) 'ok)))
 335       ;; NIL means the standard readtable.
 336       (assert (eq t (set-macro-character #\~ fun nil nil)))
 337       (assert (eq fun (get-macro-character #\~ nil)))
 338       (assert (eq t (set-dispatch-macro-character #\# #\~ fun nil)))
 339       (assert (eq fun (get-dispatch-macro-character #\# #\~ nil))))))
 340
 341 ;;; success