Clean up listify-rest-args VOP on x86-64.
[sbcl.git] / tests / defglobal.impure.lisp
1 ;;;; DEFGLOBAL and related tests
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 (proclaim '(special *foo*))
15
16 (defun eval* (form)
17   (let ((*evaluator-mode* :interpret))
18     (eval form)))
19
20 (defun unbound-marker ()
21   (sb-c::%primitive sb-c:make-unbound-marker))
22
23 (defun assert-foo-not-checked (fun)
24   (let* ((marker (unbound-marker))
25          (*foo* marker))
26     (assert (eq marker (funcall fun)))))
27
28 (defun assert-foo-checked (fun)
29   (let* ((marker (unbound-marker))
30          (*foo* marker))
31     (assert (eq :error
32                 (handler-case
33                     (funcall fun)
34                   (unbound-variable (e)
35                     (assert (eq '*foo* (cell-error-name e)))
36                     :error))))))
37
38 (with-test (:name :unbound-cannot-be-always-bound)
39   (assert (eq :error
40               (handler-case
41                   (proclaim '(sb-ext:always-bound *foo*))
42                 (error () :error)))))
43
44 (set '*foo* t)
45 (proclaim '(sb-ext:always-bound *foo*))
46
47 (defun foo-safe ()
48   (declare (optimize (safety 3)))
49   *foo*)
50
51 (with-test (:name :always-bound-elides-boundness-checking)
52   (assert-foo-not-checked #'foo-safe))
53
54 (with-test (:name :cannot-unbind-always-bound)
55   (assert (eq :oops
56               (handler-case
57                   (makunbound '*foo*)
58                 (error () :oops)))))
59
60 (defun can-globalize-p (x)
61   (handler-case
62       (progn (proclaim `(sb-ext:global ,x)) t)
63     (error () nil)))
64
65 (with-test (:name :cannot-proclaim-special-global)
66   (assert (not (can-globalize-p '*foo*))))
67
68 (define-symbol-macro sm 42)
69 (with-test (:name :cannot-proclaim-symbol-macro-global)
70   (assert (not (can-globalize-p 'sm))))
71
72 (defconstant con 13)
73 (with-test (:name :cannot-proclaim-constant-global)
74   (assert (not (can-globalize-p 'con))))
75
76 (with-test (:name :proclaim-global)
77   (assert (can-globalize-p '.bar.)))
78
79 (defun bar1 () .bar.)
80 (with-test (:name :global-does-not-imply-always-bound)
81   (assert (eq '.bar.
82               (handler-case
83                   (bar1)
84                 (unbound-variable (e)
85                   (cell-error-name e))))))
86
87 (with-test (:name :set-global)
88   (setf .bar. 7)
89   (assert (= 7 (bar1)))
90   (setf .bar. 123)
91   (assert (= 123 (bar1))))
92
93 (with-test (:name :cannot-bind-globals)
94   (assert (eq :nope
95               (handler-case
96                   (eval* '(let ((.bar. 6)) .bar.))
97                 (error () :nope))))
98   (assert (eq :nope
99              (handler-case
100                  (funcall (compile nil `(lambda ()
101                                           (let ((.bar. 5)) .bar.))))
102                (error () :nope)))))
103
104 (with-test (:name :cannot-define-globals-as-symmacs)
105   (assert (eq :nope
106               (handler-case
107                   (eval* '(define-symbol-macro .bar. 0))
108                 (error () :nope))))
109   (assert (eq :nope
110             (handler-case
111                 (eval* `(symbol-macrolet ((.bar. 11)) .bar.))
112               (error () :nope))))
113   (assert (eq :nope
114               (handler-case
115                   (funcall (compile nil `(lambda ()
116                                            (symbol-macrolet ((.bar. 11)) .bar.))))
117                 (error () :nope)))))
118
119 ;;; Cannot proclaim or declare a global as special
120 (with-test (:name :cannot-declare-global-special)
121   (assert (eq :nope
122               (handler-case (proclaim '(special .bar. 666))
123                 (error () :nope))))
124   (assert (eq :nope
125               (handler-case
126                   (funcall (compile nil `(lambda ()
127                                            (declare (special .bar.))
128                                            .bar.)))
129                 (error () :nope))))
130   (assert (eq :nope
131               (handler-case (eval `(locally (declare (special .bar.)) .bar.))
132                 (error () :nope)))))
133
134 ;;; Dead globals get bound checks
135 (declaim (global this-is-unbound))
136 (with-test (:name :dead-unbound-global)
137   (assert (eq :error
138               (handler-case
139                   (funcall (compile nil
140                                     '(lambda ()
141                                       this-is-unbound
142                                       42)))
143                 (unbound-variable ()
144                   :error)))))
145
146 (defun compile-form (form)
147   (let* ((lisp "defglobal-impure-tmp.lisp"))
148     (unwind-protect
149          (progn
150            (with-open-file (f lisp :direction :output)
151              (prin1 form f))
152            (multiple-value-bind (fasl warn fail) (compile-file lisp)
153              (declare (ignore warn))
154              (when fail
155                (error "compiling ~S failed" form))
156              fasl))
157       (ignore-errors (delete-file lisp)))))
158
159 (defvar *counter*)
160 (with-test (:name :defconstant-evals)
161   (let* ((*counter* 0)
162          (fasl (compile-form `(defglobal .counter-1. (incf *counter*)))))
163     (assert (= 1 *counter*))
164     (assert (= 1 (symbol-value '.counter-1.)))
165     (assert (eq :global (sb-int:info :variable :kind '.counter-1.)))
166     (unwind-protect
167          (load fasl)
168       (ignore-errors (delete-file fasl)))
169     (assert (= 1 *counter*))
170     (assert (= 1 (symbol-value '.counter-1.))))
171
172   (set '.counter-2. :bound)
173   (let* ((*counter* 0)
174          (fasl (compile-form `(defglobal .counter-2. (incf *counter*)))))
175     (assert (= 0 *counter*))
176     (assert (eq :bound (symbol-value '.counter-2.)))
177     (assert (eq :global (sb-int:info :variable :kind '.counter-2.)))
178     (unwind-protect
179          (load fasl)
180       (ignore-errors (delete-file fasl)))
181     (assert (= 0 *counter*))
182     (assert (eq :bound (symbol-value '.counter-2.))))
183
184   ;; This is a *really* dirty trick...
185   (let* ((*counter* 0)
186          (fasl (let ((.counter-3. :nasty))
187                  (declare (special .counter-3.))
188                  (compile-form `(defglobal .counter-3. (incf *counter*))))))
189     (assert (= 0 *counter*))
190     (assert (not (boundp '.counter-3.)))
191     (assert (eq :global (sb-int:info :variable :kind '.counter-3.)))
192     (unwind-protect
193          (load fasl)
194       (ignore-errors (delete-file fasl)))
195     (assert (= 1 *counter*))
196     (assert (= 1 (symbol-value '.counter-3.)))))
197
198 (with-test (:name :defglobal-refers-to-defglobal)
199   (let ((fasl (compile-form `(progn
200                                (defglobal **global-1** :fii)
201                                (defglobal **global-2** **global-1**)))))
202     (load fasl)
203     (assert (eq (symbol-value '**global-1**) (symbol-value '**global-2**)))
204     (assert (eq :fii (symbol-value '**global-1**)))))