tests/eval.impure.lisp

   1 ;;;; various tests of EVAL with side effects
   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 ;;;; Note: this stuff gets loaded in (by LOAD) and is therefore
  15 ;;;; evaluated by EVAL, rather than compiled and then loaded; this is
  16 ;;;; why this idiom (a sequence of top-level forms) works as a test of
  17 ;;;; EVAL.
  18
  19 (cl:in-package :cl-user)
  20
  21 (load "assertoid.lisp")
  22 (use-package "ASSERTOID")
  23
  24 ;;; Until sbcl-0.7.9.x, EVAL was not correctly treating LOCALLY,
  25 ;;; MACROLET and SYMBOL-MACROLET, which should preserve top-levelness
  26 ;;; of their body forms:
  27
  28 ;;; LOCALLY
  29 (locally (defstruct locally-struct a (b t)))
  30
  31 (let ((x (make-locally-struct :a 1)))
  32   (assert (eql (locally-struct-a x) 1))
  33   (assert (eql (locally-struct-b x) t)))
  34
  35 (locally
  36   (defmacro locally-macro (x) `(+ ,x 1))
  37   (assert (= (locally-macro 3) 4)))
  38
  39 (locally (declare (special x))
  40   (defun locally-special-test ()
  41     x)
  42   (defun locally-special-test-aux ()
  43     (let ((x 1))
  44       (declare (special x))
  45       (locally-special-test)))
  46   (assert (= (locally-special-test-aux) 1)))
  47
  48 ;;; MACROLET
  49 (macrolet ()
  50   (defstruct macrolet-struct a (b t)))
  51
  52 (let ((x (make-macrolet-struct :a 1)))
  53   (assert (eql (macrolet-struct-a x) 1))
  54   (assert (eql (macrolet-struct-b x) t)))
  55
  56 (macrolet ()
  57   (defmacro macrolet-macro (x) `(+ ,x 1))
  58   (assert (= (macrolet-macro 3) 4)))
  59
  60 (locally (declare (special x))
  61   (defun macrolet-special-test ()
  62     x)
  63   (defun macrolet-special-test-aux ()
  64     (let ((x 1))
  65       (declare (special x))
  66       (macrolet-special-test)))
  67   (assert (= (macrolet-special-test-aux) 1)))
  68
  69 (macrolet ((foo (x) `(macrolet-bar ,x)))
  70   (defmacro macrolet-bar (x) `(+ ,x 1))
  71   (assert (= (foo 1) 2)))
  72
  73 ;;; SYMBOL-MACROLET
  74 (symbol-macrolet ()
  75   (defstruct symbol-macrolet-struct a (b t)))
  76
  77 (let ((x (make-symbol-macrolet-struct :a 1)))
  78   (assert (eql (symbol-macrolet-struct-a x) 1))
  79   (assert (eql (symbol-macrolet-struct-b x) t)))
  80
  81 (symbol-macrolet ()
  82   (defmacro symbol-macrolet-macro (x) `(+ ,x 1))
  83   (assert (= (symbol-macrolet-macro 3) 4)))
  84
  85 (locally (declare (special x))
  86   (defun symbol-macrolet-special-test ()
  87     x)
  88   (defun symbol-macrolet-special-test-aux ()
  89     (let ((x 1))
  90       (declare (special x))
  91       (symbol-macrolet-special-test)))
  92   (assert (= (symbol-macrolet-special-test-aux) 1)))
  93
  94 (symbol-macrolet ((foo (symbol-macrolet-bar 1)))
  95   (defmacro symbol-macrolet-bar (x) `(+ ,x 1))
  96   (assert (= foo 2)))
  97
  98 ;;; Bug reported by Paul Dietz: CONSTANTP on a self-evaluating object
  99 ;;; must return T
 100 (assert (constantp (find-class 'symbol)))
 101 (assert (constantp #p""))
 102
 103 ;;; More CONSTANTP tests
 104 ;;;              form                   constantp sb-int:constant-form-value
 105 (dolist (test '((t                      t         t)
 106                 (x                      nil)
 107                 ('x                     t         x)
 108                 (:keyword               t         :keyword)
 109                 (42                     t         42)
 110                 ((if t :ok x)           t         :ok)
 111                 ((if t x :no)           nil)
 112                 ((progn
 113                    (error "oops")
 114                    t)                   nil)
 115                 ((progn 1 2 3)          t         3)
 116                 ((block foo :good)      t         :good)
 117                 ((block foo
 118                    (return-from foo t)) nil)
 119                 ((progv
 120                      (list (gensym))
 121                      '(1)
 122                    (+ 1))               nil)
 123                 ((progv
 124                      '(x)
 125                      (list (random 2))
 126                    x)                   nil)
 127                 ((progv
 128                      '(x)
 129                      '(1)
 130                    (1+ x))              t         2)
 131                 ((progv '(x) '(t)
 132                    (if x 1 2))          t         1)
 133                 ((unwind-protect 1 nil) t         1)
 134                 ((unwind-protect 1
 135                    (xxx))               nil)
 136                 ((the integer 1)        t         1)
 137                 ((the integer (+ 1 1))  t         2)
 138                 ((the integer (foo))    nil)
 139                 ((the symbol 1)         nil)
 140                 ((the "bad type" 1)     nil)
 141                 ((multiple-value-prog1
 142                      (+ 1 1)
 143                    :nada)               t         2)
 144                 ((multiple-value-prog1
 145                      :nada
 146                    (/ 1 0))             nil)
 147                 ((/ 1 0)                nil)
 148                 ((/ 1 1)                t         1)
 149                 ((+ 1 2)                t         3)))
 150   (destructuring-bind (form c &optional v) test
 151     (assert (eql (constantp form) c))
 152     (when c
 153       (assert (eql v (sb-int:constant-form-value form))))))
 154
 155 ;;; DEFPARAMETER must assign a dynamic variable
 156 (let ((var (gensym)))
 157   (assert (equal (eval `(list (let ((,var 1))
 158                                 (defparameter ,var 2)
 159                                 ,var)
 160                               ,var))
 161                  '(1 2))))
 162
 163 ;;; Bug 264: SYMBOL-MACROLET did not check for a bound SPECIAL
 164 ;;; declaration
 165 (assert (raises-error? (progv '(foo) '(1)
 166                          (eval '(symbol-macrolet ((foo 3))
 167                                  (declare (special foo))
 168                                  foo)))
 169                        error))
 170
 171 ;;; MAKE-PACKAGE (and other &key functions) should signal an error
 172 ;;; when given a NIL key.  This is kind of a compiler test really, but
 173 ;;; this'll do as a resting place.
 174 (handler-case
 175     (eval '(make-package "FOO" nil nil))
 176   (error () :ok)
 177   (:no-error (c) (error "MAKE-PACKAGE succeeded: ~S" c)))
 178
 179 ;;; FUNCTION
 180 (defun function-eq-test ()
 181   'ok)
 182 (trace function-eq-test)
 183 (assert (eq (eval '(function function-eq-test))
 184             (funcall (compile nil '(lambda () (function function-eq-test))))))
 185
 186 ;;; No extra output, please
 187 (assert (equal ".."
 188                (with-output-to-string (*standard-output*)
 189                  (eval '(progn (princ ".") (let ((x 42)) t) (princ "."))))))
 190
 191 ;;; IF
 192 (defun true () t)
 193 (defun false () nil)
 194 (defmacro oops () (throw :oops (list)))
 195 (defun test-eval (ok form) (assert (eq ok (catch :oops (eval form)))))
 196 (test-eval t '(if (false) (oops) t))
 197 (test-eval t '(if (true) t (oops)))
 198 (test-eval nil '(if (not (if (false) t)) (oops)))
 199
 200 ;;; TAGBODY
 201
 202 ;;; As of SBCL 1.0.1.8, TAGBODY should not accept duplicate go tags,
 203 ;;; yet choked on two duplicate tags.  Note that this test asserts a
 204 ;;; failure.
 205 (with-test (:name :tagbody-dual-go-tags)
 206   (progn
 207     (defun tagbody-dual-go-tags ()
 208       (restart-case
 209           (handler-bind ((error (lambda (c)
 210                                   (declare (ignore c))
 211                                   (invoke-restart 'NOT-AN-ERROR))))
 212             (tagbody :A :A) nil)
 213         (NOT-AN-ERROR () t)))
 214     (assert (tagbody-dual-go-tags))))
 215
 216 ;;; Ensure that NIL is a valid go tag.
 217 (with-test (:name :tagbody-nil-is-valid-tag)
 218   (progn
 219     (defun tagbody-nil-is-valid-tag ()
 220       (tagbody (go NIL) NIL) t)
 221     (assert (tagbody-nil-is-valid-tag))))
 222
 223 ;;; top-level DECLARE is formally undefined, but we want it to raise
 224 ;;; an error rather than silently return NIL.
 225 (defvar *scratch*)
 226 (with-test (:name :toplevel-declare)
 227   (assert (raises-error? (eval '(declare (type pathname *scratch*))))))
 228
 229 (with-test (:name (eval no-compiler-notes))
 230   (handler-bind ((sb-ext:compiler-note #'error))
 231     (let ((sb-ext:*evaluator-mode* :compile))
 232       (eval '(let ((x 42))
 233               (if nil x)))
 234       (eval '(let ((* 13))
 235               (let ((x 42)
 236                     (y *))
 237                 (declare (optimize speed))
 238                 (+ x y)))))))
 239
 240 (with-test (:name :bug-238)
 241   (let ((sb-ext:*evaluator-mode* :compile))
 242     (handler-bind ((sb-ext:compiler-note #'error))
 243       (eval '(defclass bug-238 () ()))
 244       (eval '(defmethod bug-238 ((x bug-238) (bug-238 bug-238))
 245               (call-next-method)))
 246       (eval '(handler-case
 247               (with-input-from-string (*query-io* "    no")
 248                 (yes-or-no-p))
 249               (simple-type-error () 'error)))
 250       t)))
 251
 252 (with-test (:name :bug-524707 :skipped-on '(not :sb-eval))
 253   (let ((*evaluator-mode* :interpret)
 254         (lambda-form '(lambda (x) (declare (fixnum x)) (1+ x))))
 255     (let ((fun (eval lambda-form)))
 256       (assert (equal lambda-form (function-lambda-expression fun))))))
 257
 258 (with-test (:name (eval :source-context-in-compiler))
 259   (let ((noise (with-output-to-string (*error-output*)
 260                  (let ((*evaluator-mode* :compile))
 261                    (eval `(defun source-context-test (x) y))))))
 262     (with-input-from-string (s noise)
 263       (assert (equal "; in: DEFUN SOURCE-CONTEXT-TEST" (read-line s))))))
 264
 265 ;;; success