1 ;;;; various tests of EVAL with side effects
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
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
19 (cl:in-package :cl-user)
21 (load "assertoid.lisp")
22 (use-package "ASSERTOID")
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:
29 (locally (defstruct locally-struct a (b t)))
31 (let ((x (make-locally-struct :a 1)))
32 (assert (eql (locally-struct-a x) 1))
33 (assert (eql (locally-struct-b x) t)))
36 (defmacro locally-macro (x) `(+ ,x 1))
37 (assert (= (locally-macro 3) 4)))
39 (locally (declare (special x))
40 (defun locally-special-test ()
42 (defun locally-special-test-aux ()
45 (locally-special-test)))
46 (assert (= (locally-special-test-aux) 1)))
50 (defstruct macrolet-struct a (b t)))
52 (let ((x (make-macrolet-struct :a 1)))
53 (assert (eql (macrolet-struct-a x) 1))
54 (assert (eql (macrolet-struct-b x) t)))
57 (defmacro macrolet-macro (x) `(+ ,x 1))
58 (assert (= (macrolet-macro 3) 4)))
60 (locally (declare (special x))
61 (defun macrolet-special-test ()
63 (defun macrolet-special-test-aux ()
66 (macrolet-special-test)))
67 (assert (= (macrolet-special-test-aux) 1)))
69 (macrolet ((foo (x) `(macrolet-bar ,x)))
70 (defmacro macrolet-bar (x) `(+ ,x 1))
71 (assert (= (foo 1) 2)))
75 (defstruct symbol-macrolet-struct a (b t)))
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)))
82 (defmacro symbol-macrolet-macro (x) `(+ ,x 1))
83 (assert (= (symbol-macrolet-macro 3) 4)))
85 (locally (declare (special x))
86 (defun symbol-macrolet-special-test ()
88 (defun symbol-macrolet-special-test-aux ()
91 (symbol-macrolet-special-test)))
92 (assert (= (symbol-macrolet-special-test-aux) 1)))
94 (symbol-macrolet ((foo (symbol-macrolet-bar 1)))
95 (defmacro symbol-macrolet-bar (x) `(+ ,x 1))
98 ;;; Bug reported by Paul Dietz: CONSTANTP on a self-evaluating object
100 (assert (constantp (find-class 'symbol)))
101 (assert (constantp #p""))
103 ;;; More CONSTANTP tests
104 ;;; form constantp sb-int:constant-form-value
105 (dolist (test '((t t t)
108 (:keyword t :keyword)
116 ((block foo :good) t :good)
118 (return-from foo t)) nil)
133 ((unwind-protect 1 nil) t 1)
136 ((the integer 1) t 1)
137 ((the integer (+ 1 1)) t 2)
138 ((the integer (foo)) nil)
140 ((the "bad type" 1) nil)
141 ((multiple-value-prog1
144 ((multiple-value-prog1
150 (destructuring-bind (form c &optional v) test
151 (assert (eql (constantp form) c))
153 (assert (eql v (sb-int:constant-form-value form))))))
155 ;;; DEFPARAMETER must assign a dynamic variable
156 (let ((var (gensym)))
157 (assert (equal (eval `(list (let ((,var 1))
158 (defparameter ,var 2)
163 ;;; Bug 264: SYMBOL-MACROLET did not check for a bound SPECIAL
165 (assert (raises-error? (progv '(foo) '(1)
166 (eval '(symbol-macrolet ((foo 3))
167 (declare (special foo))
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.
175 (eval '(make-package "FOO" nil nil))
177 (:no-error (c) (error "MAKE-PACKAGE succeeded: ~S" c)))
180 (defun function-eq-test ()
182 (trace function-eq-test)
183 (assert (eq (eval '(function function-eq-test))
184 (funcall (compile nil '(lambda () (function function-eq-test))))))
186 ;;; No extra output, please
188 (with-output-to-string (*standard-output*)
189 (eval '(progn (princ ".") (let ((x 42)) t) (princ "."))))))
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)))
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
205 (with-test (:name :tagbody-dual-go-tags)
207 (defun tagbody-dual-go-tags ()
209 (handler-bind ((error (lambda (c)
211 (invoke-restart 'NOT-AN-ERROR))))
213 (NOT-AN-ERROR () t)))
214 (assert (tagbody-dual-go-tags))))
216 ;;; Ensure that NIL is a valid go tag.
217 (with-test (:name :tagbody-nil-is-valid-tag)
219 (defun tagbody-nil-is-valid-tag ()
220 (tagbody (go NIL) NIL) t)
221 (assert (tagbody-nil-is-valid-tag))))
223 ;;; top-level DECLARE is formally undefined, but we want it to raise
224 ;;; an error rather than silently return NIL.
226 (with-test (:name :toplevel-declare)
227 (assert (raises-error? (eval '(declare (type pathname *scratch*))))))
229 (with-test (:name (eval :no-compiler-notes))
230 (handler-bind ((sb-ext:compiler-note #'error))
231 (let ((sb-ext:*evaluator-mode* :compile))
237 (declare (optimize speed))
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))
247 (with-input-from-string (*query-io* " no")
249 (simple-type-error () 'error)))
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))))))
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))))))
265 (with-test (:name (eval :empty-let-is-not-toplevel))
266 (let ((sb-ext:*evaluator-mode* :compile))
268 (defmacro empty-let-is-not-toplevel-x () :macro)
269 (defun empty-let-is-not-toplevel-fun ()
270 (empty-let-is-not-toplevel-x))))
271 (eval `(defun empty-let-is-not-toplevel-x () :fun))
272 (assert (eq :fun (empty-let-is-not-toplevel-fun))))
273 ;; While at it, test that we get the late binding under
276 (let ((sb-ext:*evaluator-mode* :interpret))
278 (defmacro empty-let-is-not-toplevel-x () :macro)
279 (defun empty-let-is-not-toplevel-fun ()
280 (empty-let-is-not-toplevel-x))))
281 (assert (eq :macro (empty-let-is-not-toplevel-fun)))
282 (eval `(defun empty-let-is-not-toplevel-x () :fun))
283 (assert (eq :fun (empty-let-is-not-toplevel-fun)))))
285 (with-test (:name (eval function-lambda-expression))
286 (assert (equal `(sb-int:named-lambda eval-fle-1 (x)
289 (function-lambda-expression
291 (defun eval-fle-1 (x) (+ x 1))
293 (assert (equal `(lambda (x y z) (+ x 1 y z))
294 (function-lambda-expression
295 (eval `(lambda (x y z) (+ x 1 y z)))))))