0.8.20.21:
[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 ;;; DEFPARAMETER must assign a dynamic variable
104 (let ((var (gensym)))
105   (assert (equal (eval `(list (let ((,var 1))
106                                 (defparameter ,var 2)
107                                 ,var)
108                               ,var))
109                  '(1 2))))
110
111 ;;; Bug 264: SYMBOL-MACROLET did not check for a bound SPECIAL
112 ;;; declaration
113 (assert (raises-error? (progv '(foo) '(1)
114                          (eval '(symbol-macrolet ((foo 3))
115                                  (declare (special foo))
116                                  foo)))
117                        error))
118
119 ;;; MAKE-PACKAGE (and other &key functions) should signal an error
120 ;;; when given a NIL key.  This is kind of a compiler test really, but
121 ;;; this'll do as a resting place.
122 (handler-case
123     (eval '(make-package "FOO" nil nil))
124   (error () :ok)
125   (:no-error (c) (error "MAKE-PACKAGE succeeded: ~S" c)))
126
127 ;;; FUNCTION
128 (defun function-eq-test ()
129   'ok)
130 (trace function-eq-test)
131 (assert (eq (eval '(function function-eq-test))
132             (funcall (compile nil '(lambda () (function function-eq-test))))))
133
134 ;;; success
135 (sb-ext:quit :unix-status 104)