1.0.23.9: extend pa_alloc to accept a page_type_flag
[sbcl.git] / contrib / sb-cltl2 / tests.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; The software is in the public domain and is provided with
5 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
6 ;;;; more information.
7
8 (defpackage :sb-cltl2-tests
9   (:use :sb-cltl2 :cl :sb-rt))
10
11 (in-package :sb-cltl2-tests)
12
13 (rem-all-tests)
14
15 (defmacro *x*-value ()
16   (declare (special *x*))
17   *x*)
18
19 (deftest compiler-let.1
20     (let ((*x* :outer))
21       (compiler-let ((*x* :inner))
22         (list *x* (*x*-value))))
23   (:outer :inner))
24
25 (defvar *expansions* nil)
26 (defmacro macroexpand-macro (arg)
27   (push arg *expansions*)
28   arg)
29
30 (deftest macroexpand-all.1
31     (progn
32       (macroexpand-all '(defmethod foo ((x fixnum)) (1+ x)))
33       t)
34   t)
35
36 (deftest macroexpand-all.2
37     (let ((*expansions* nil))
38       (macroexpand-all '(list (macroexpand-macro 1)
39                          (let (macroexpand-macro :no)
40                            (macroexpand-macro 2))))
41       (remove-duplicates (sort *expansions* #'<)))
42   (1 2))
43
44 (deftest macroexpand-all.3
45     (let ((*expansions* nil))
46       (compile nil '(lambda ()
47                      (macrolet ((foo (key &environment env)
48                                   (macroexpand-all `(bar ,key) env)))
49                        (foo
50                         (macrolet ((bar (key)
51                                      (push key *expansions*)
52                                      key))
53                           (foo 1))))))
54       (remove-duplicates *expansions*))
55   (1))
56
57 (defun smv (env)
58   (multiple-value-bind (expansion macro-p)
59       (macroexpand 'srlt env)
60     (when macro-p (eval expansion))))
61 (defmacro testr (&environment env)
62   `',(getf (smv env) nil))
63
64 (deftest macroexpand-all.4
65     (macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
66   (symbol-macrolet ((srlt '(nil zool))) 'zool))
67
68 (defmacro dinfo (thing &environment env)
69   `',(declaration-information thing env))
70
71 (macrolet ((def (x)
72                `(macrolet ((frob (suffix answer &optional declaration)
73                             `(deftest ,(intern (concatenate 'string
74                                                             "DECLARATION-INFORMATION."
75                                                             (symbol-name ',x)
76                                                             suffix))
77                                (locally (declare ,@(when declaration
78                                                          (list declaration)))
79                                  (cadr (assoc ',',x (dinfo optimize))))
80                               ,answer)))
81                  (frob ".DEFAULT" 1)
82                  (frob ".0" 0 (optimize (,x 0)))
83                  (frob ".1" 1 (optimize (,x 1)))
84                  (frob ".2" 2 (optimize (,x 2)))
85                  (frob ".3" 3 (optimize (,x 3)))
86                  (frob ".IMPLICIT" 3 (optimize ,x)))))
87   (def speed)
88   (def safety)
89   (def debug)
90   (def compilation-speed)
91   (def space))
92
93 (deftest declaration-information.muffle-conditions.default
94   (dinfo sb-ext:muffle-conditions)
95   nil)
96 (deftest declaration-information.muffle-conditions.1
97   (locally (declare (sb-ext:muffle-conditions warning))
98     (dinfo sb-ext:muffle-conditions))
99   warning)
100 (deftest declaration-information.muffle-conditions.2
101   (let ((junk (dinfo sb-ext:muffle-conditions)))
102     (declare (sb-ext:muffle-conditions warning))
103     (locally (declare (sb-ext:unmuffle-conditions style-warning))
104       (let ((dinfo (dinfo sb-ext:muffle-conditions)))
105         (not
106          (not
107           (and (subtypep dinfo `(or (and warning (not style-warning))
108                                     (and ,junk (not style-warning))))
109                (subtypep '(and warning (not style-warning)) dinfo)))))))
110   t)
111
112 ;;;; VARIABLE-INFORMATION
113
114 (defvar *foo*)
115
116 (defmacro var-info (var &environment env)
117   (list 'quote (multiple-value-list (variable-information var env))))
118
119 (deftest variable-info.global-special/unbound
120     (var-info *foo*)
121   (:special nil nil))
122
123 (deftest variable-info.global-special/unbound/extra-decl
124     (locally (declare (special *foo*))
125       (var-info *foo*))
126   (:special nil nil))
127
128 (deftest variable-info.global-special/bound
129     (let ((*foo* t))
130       (var-info *foo*))
131   (:special nil nil))
132
133 (deftest variable-info.global-special/bound/extra-decl
134     (let ((*foo* t))
135       (declare (special *foo*))
136       (var-info *foo*))
137   (:special nil nil))
138
139 (deftest variable-info.local-special/unbound
140     (locally (declare (special x))
141       (var-info x))
142   (:special nil nil))
143
144 (deftest variable-info.local-special/bound
145     (let ((x 13))
146       (declare (special x))
147       (var-info x))
148   (:special nil nil))
149
150 (deftest variable-info.local-special/shadowed
151     (let ((x 3))
152       (declare (special x))
153       x
154       (let ((x 3))
155         x
156         (var-info x)))
157   (:lexical t nil))
158
159 (deftest variable-info.local-special/shadows-lexical
160     (let ((x 3))
161       (let ((x 3))
162         (declare (special x))
163         (var-info x)))
164   (:special nil nil))
165
166 (deftest variable-info.lexical
167     (let ((x 8))
168       (var-info x))
169   (:lexical t nil))
170
171 (deftest variable-info.lexical.type
172     (let ((x 42))
173       (declare (fixnum x))
174       (var-info x))
175   (:lexical t ((type . fixnum))))
176
177 (deftest variable-info.lexical.type.2
178     (let ((x 42))
179       (prog1
180           (var-info x)
181         (locally (declare (fixnum x))
182           (assert (plusp x)))))
183   (:lexical t nil))
184
185 (deftest variable-info.lexical.type.2
186     (let ((x 42))
187       (locally (declare (fixnum x))
188         (var-info x)))
189   (:lexical t ((type . fixnum))))
190
191 (deftest variable-info.ignore
192     (let ((x 8))
193       (declare (ignore x))
194       (var-info x))
195   (:lexical t ((ignore . t))))
196
197 (deftest variable-info.symbol-macro/local
198     (symbol-macrolet ((x 8))
199       (var-info x))
200   (:symbol-macro t nil))
201
202 (define-symbol-macro my-symbol-macro t)
203
204 (deftest variable-info.symbol-macro/global
205     (var-info my-symbol-macro)
206   (:symbol-macro nil nil))
207
208 (deftest variable-info.undefined
209     (var-info #:undefined)
210   (nil nil nil))
211
212 ;;;; FUNCTION-INFORMATION
213
214 (defmacro fun-info (var &environment env)
215   (list 'quote (multiple-value-list (function-information var env))))
216
217 (defun my-global-fun (x) x)
218
219 (deftest function-info.global/no-ftype
220     (fun-info my-global-fun)
221   (:function nil nil))
222
223 (declaim (ftype (function (cons) (values t &optional)) my-global-fun-2))
224
225 (defun my-global-fun-2 (x) x)
226
227 (deftest function-info.global/ftype
228     (fun-info my-global-fun-2)
229   (:function nil ((ftype function (cons) (values t &optional)))))
230
231 (defmacro my-macro (x) x)
232
233 (deftest function-info.macro
234     (fun-info my-macro)
235   (:macro nil nil))
236
237 (deftest function-info.macrolet
238     (macrolet ((thingy () nil))
239       (fun-info thingy))
240   (:macro t nil))
241
242 (deftest function-info.special-form
243     (fun-info progn)
244   (:special-form  nil nil))
245
246 (deftest function-info.notinline/local
247     (flet ((x (y) y))
248       (declare (notinline x))
249       (x 1)
250       (fun-info x))
251   (:function t ((inline . notinline))))
252
253 (declaim (notinline my-notinline))
254 (defun my-notinline (x) x)
255
256 (deftest function-info.notinline/global
257     (fun-info my-notinline)
258   (:function nil ((inline . notinline))))
259
260 (declaim (inline my-inline))
261 (defun my-inline (x) x)
262
263 (deftest function-info.inline/global
264     (fun-info my-inline)
265   (:function nil ((inline . inline))))
266
267 (deftest function-information.known-inline
268     (locally (declare (inline identity))
269       (fun-info identity))
270   (:function nil ((inline . inline)
271                   (ftype function (t) (values t &optional)))))
272