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 ;;; Until sbcl-0.7.9.x, EVAL was not correctly treating LOCALLY,
20 ;;; MACROLET and SYMBOL-MACROLET, which should preserve top-levelness
21 ;;; of their body forms:
24 (locally (defstruct locally-struct a
(b t
)))
26 (let ((x (make-locally-struct :a
1)))
27 (assert (eql (locally-struct-a x
) 1))
28 (assert (eql (locally-struct-b x
) t
)))
31 (defmacro locally-macro
(x) `(+ ,x
1))
32 (assert (= (locally-macro 3) 4)))
34 (locally (declare (special x
))
35 (defun locally-special-test ()
37 (defun locally-special-test-aux ()
40 (locally-special-test)))
41 (assert (= (locally-special-test-aux) 1)))
45 (defstruct macrolet-struct a
(b t
)))
47 (let ((x (make-macrolet-struct :a
1)))
48 (assert (eql (macrolet-struct-a x
) 1))
49 (assert (eql (macrolet-struct-b x
) t
)))
52 (defmacro macrolet-macro
(x) `(+ ,x
1))
53 (assert (= (macrolet-macro 3) 4)))
55 (locally (declare (special x
))
56 (defun macrolet-special-test ()
58 (defun macrolet-special-test-aux ()
61 (macrolet-special-test)))
62 (assert (= (macrolet-special-test-aux) 1)))
64 (macrolet ((foo (x) `(macrolet-bar ,x
)))
65 (defmacro macrolet-bar
(x) `(+ ,x
1))
66 (assert (= (foo 1) 2)))
70 (defstruct symbol-macrolet-struct a
(b t
)))
72 (let ((x (make-symbol-macrolet-struct :a
1)))
73 (assert (eql (symbol-macrolet-struct-a x
) 1))
74 (assert (eql (symbol-macrolet-struct-b x
) t
)))
77 (defmacro symbol-macrolet-macro
(x) `(+ ,x
1))
78 (assert (= (symbol-macrolet-macro 3) 4)))
80 (locally (declare (special x
))
81 (defun symbol-macrolet-special-test ()
83 (defun symbol-macrolet-special-test-aux ()
86 (symbol-macrolet-special-test)))
87 (assert (= (symbol-macrolet-special-test-aux) 1)))
89 (symbol-macrolet ((foo (symbol-macrolet-bar 1)))
90 (defmacro symbol-macrolet-bar
(x) `(+ ,x
1))
93 ;;; Bug reported by Paul Dietz: CONSTANTP on a self-evaluating object
95 (assert (constantp (find-class 'symbol
)))
96 (assert (constantp #p
""))
98 ;;; More CONSTANTP tests
99 ;;; form constantp sb-int:constant-form-value
100 (dolist (test '((t t t
)
103 (:keyword t
:keyword
)
111 ((block foo
:good
) t
:good
)
113 (return-from foo t
)) nil
)
128 ((unwind-protect 1 nil
) t
1)
131 ((the integer
1) t
1)
132 ((the integer
(+ 1 1)) t
2)
133 ((the integer
(foo)) nil
)
135 ((the "bad type" 1) nil
)
136 ((multiple-value-prog1
139 ((multiple-value-prog1
145 (destructuring-bind (form c
&optional v
) test
146 (assert (eql (constantp form
) c
))
148 (assert (eql v
(sb-int:constant-form-value form
))))))
150 ;;; DEFPARAMETER must assign a dynamic variable
151 (let ((var (gensym)))
152 (assert (equal (eval `(list (let ((,var
1))
153 (defparameter ,var
2)
158 ;;; Bug 264: SYMBOL-MACROLET did not check for a bound SPECIAL
160 (assert-error (progv '(foo) '(1)
161 (eval '(symbol-macrolet ((foo 3))
162 (declare (special foo
))
166 ;;; MAKE-PACKAGE (and other &key functions) should signal an error
167 ;;; when given a NIL key. This is kind of a compiler test really, but
168 ;;; this'll do as a resting place.
170 (eval '(make-package "FOO" nil nil
))
172 (:no-error
(c) (error "MAKE-PACKAGE succeeded: ~S" c
)))
175 (defun function-eq-test ()
177 (trace function-eq-test
)
178 (assert (eq (eval '(function function-eq-test
))
179 (funcall (compile nil
'(lambda () (function function-eq-test
))))))
181 ;;; No extra output, please
183 (with-output-to-string (*standard-output
*)
184 (eval '(progn (princ ".") (let ((x 42)) t
) (princ "."))))))
189 (defmacro oops
() (throw :oops
(list)))
190 (defun test-eval (ok form
) (assert (eq ok
(catch :oops
(eval form
)))))
191 (test-eval t
'(if (false) (oops) t
))
192 (test-eval t
'(if (true) t
(oops)))
193 (test-eval nil
'(if (not (if (false) t
)) (oops)))
197 ;;; As of SBCL 1.0.1.8, TAGBODY should not accept duplicate go tags,
198 ;;; yet choked on two duplicate tags. Note that this test asserts a
200 (with-test (:name
:tagbody-dual-go-tags
)
202 (defun tagbody-dual-go-tags ()
204 (handler-bind ((error (lambda (c)
206 (invoke-restart 'NOT-AN-ERROR
))))
208 (NOT-AN-ERROR () t
)))
209 (assert (tagbody-dual-go-tags))))
211 ;;; Ensure that NIL is a valid go tag.
212 (with-test (:name
:tagbody-nil-is-valid-tag
)
214 (defun tagbody-nil-is-valid-tag ()
215 (tagbody (go NIL
) NIL
) t
)
216 (assert (tagbody-nil-is-valid-tag))))
218 ;;; top-level DECLARE is formally undefined, but we want it to raise
219 ;;; an error rather than silently return NIL.
221 (with-test (:name
:toplevel-declare
)
222 (assert-error (eval '(declare (type pathname
*scratch
*)))))
224 (with-test (:name
(eval :no-compiler-notes
))
225 (handler-bind ((sb-ext:compiler-note
#'error
))
226 (let ((sb-ext:*evaluator-mode
* :compile
))
232 (declare (optimize speed
))
235 (with-test (:name
:bug-238
)
236 (let ((sb-ext:*evaluator-mode
* :compile
))
237 (handler-bind ((sb-ext:compiler-note
#'error
))
238 (eval '(defclass bug-238
() ()))
239 (eval '(defmethod bug-238 ((x bug-238
) (bug-238 bug-238
))
242 (with-input-from-string (*query-io
* " no")
244 (simple-type-error () 'error
)))
247 (with-test (:name
:bug-524707
:skipped-on
(not :sb-eval
))
248 (let ((*evaluator-mode
* :interpret
)
249 (lambda-form '(lambda (x) (declare (fixnum x
)) (1+ x
))))
250 (let ((fun (eval lambda-form
)))
251 (assert (equal lambda-form
(function-lambda-expression fun
))))))
253 (with-test (:name
(eval :source-context-in-compiler
))
254 (let ((noise (with-output-to-string (*error-output
*)
255 (let ((*evaluator-mode
* :compile
))
256 (eval `(defun source-context-test (x) y
))))))
257 (with-input-from-string (s noise
)
258 (assert (equal "; in: DEFUN SOURCE-CONTEXT-TEST" (read-line s
))))))
260 (with-test (:name
(eval :empty-let-is-not-toplevel
))
261 (let ((sb-ext:*evaluator-mode
* :compile
))
263 (defmacro empty-let-is-not-toplevel-x
() :macro
)
264 (defun empty-let-is-not-toplevel-fun ()
265 (empty-let-is-not-toplevel-x))))
266 (eval `(defun empty-let-is-not-toplevel-x () :fun
))
267 (assert (eq :fun
(empty-let-is-not-toplevel-fun))))
268 ;; While at it, test that we get the late binding under
271 (let ((sb-ext:*evaluator-mode
* :interpret
))
273 (defmacro empty-let-is-not-toplevel-x
() :macro
)
274 (defun empty-let-is-not-toplevel-fun ()
275 (empty-let-is-not-toplevel-x))))
276 (assert (eq :macro
(empty-let-is-not-toplevel-fun)))
277 (eval `(defun empty-let-is-not-toplevel-x () :fun
))
278 (assert (eq :fun
(empty-let-is-not-toplevel-fun)))))
280 (with-test (:name
(eval function-lambda-expression
))
281 (assert (equal (function-lambda-expression
283 (defun eval-fle-1 (x) (+ x
1))
286 `(sb-int:named-lambda eval-fle-1
(x)
293 (assert (equal (function-lambda-expression
294 (eval `(lambda (x y z
) (+ x
1 y z
))))
295 `(lambda (x y z
) (+ x
1 y z
)))))
297 (with-test (:name
(:bug-573747 eval
:compile
))
298 (let ((*out
* (make-string-output-stream))
299 (sb-ext:*evaluator-mode
* :compile
))
300 (declare (special *out
*))
301 (assert-error (eval '(declare (print "foo" *out
*))))
302 (assert (string= (get-output-stream-string *out
*) ""))))
304 (with-test (:name
(:bug-573747 eval
:interpret
))
305 (let ((*out
* (make-string-output-stream))
306 #+(or sb-eval sb-fasteval
) (sb-ext:*evaluator-mode
* :interpret
))
307 (declare (special *out
*))
308 (assert-error (eval '(declare (print "foo" *out
*))))
309 (assert (string= (get-output-stream-string *out
*) ""))))
311 (with-test (:name
:the-keyword-not-borked
)
312 (assert (the (or integer keyword
) :foo
)))
314 ;; If the DEFUN macro produces a style-warning, it needs to perform the
315 ;; effect of defun no matter what. The style-warning comes from an EVAL-WHEN,
316 ;; not as part of the execution-time behavior of %DEFUN because it is neither
317 ;; polite nor useful to issue a warning about the co-existence of a DEFSETF
318 ;; and DEFUN SETF after compile-time. The other viable alternative would have
319 ;; been to remove the :EXECUTE situation from the expansion of DEFUN
320 ;; where it signal to warning.
321 (with-test (:name
:handler-case-does-not-bork-defun
)
322 (defsetf bar set-bar
)
323 (handler-case (defun (setf bar
) (newval x
) (declare (ignore newval x
)))
324 (style-warning () 'drat
))
325 (assert (fboundp '(setf bar
))))