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