Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / 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 (with-test (:name (eval :empty-let-is-not-toplevel))
266   (let ((sb-ext:*evaluator-mode* :compile))
267     (eval `(let ()
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
274   ;; interpreter mode.
275   #+sb-eval
276   (let ((sb-ext:*evaluator-mode* :interpret))
277     (eval `(let ()
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)))))
284
285 (with-test (:name (eval function-lambda-expression))
286   (assert (equal `(sb-int:named-lambda eval-fle-1 (x)
287                     (block eval-fle-1
288                       (+ x 1)))
289                  (function-lambda-expression
290                   (eval `(progn
291                            (defun eval-fle-1 (x) (+ x 1))
292                            #'eval-fle-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)))))))
296
297 ;;; success