1 (defpackage :sb-cltl2-tests
2 (:use
:sb-cltl2
:cl
:sb-rt
))
3 (in-package :sb-cltl2-tests
)
8 (declare (special *x
*))
11 (deftest compiler-let
.1
13 (compiler-let ((*x
* :inner
))
14 (list *x
* (*x
*-value
))))
17 (defvar *expansions
* nil
)
18 (defmacro macroexpand-macro
(arg)
19 (push arg
*expansions
*)
22 (deftest macroexpand-all
.1
24 (macroexpand-all '(defmethod foo ((x fixnum
)) (1+ x
)))
28 (deftest macroexpand-all
.2
29 (let ((*expansions
* nil
))
30 (macroexpand-all '(list (macroexpand-macro 1)
31 (let (macroexpand-macro :no
)
32 (macroexpand-macro 2))))
33 (remove-duplicates (sort *expansions
* #'<)))
36 (deftest macroexpand-all
.3
37 (let ((*expansions
* nil
))
38 (compile nil
'(lambda ()
39 (macrolet ((foo (key &environment env
)
40 (macroexpand-all `(bar ,key
) env
)))
43 (push key
*expansions
*)
46 (remove-duplicates *expansions
*))
50 (multiple-value-bind (expansion macro-p
)
51 (macroexpand 'srlt env
)
52 (when macro-p
(eval expansion
))))
53 (defmacro testr
(&environment env
)
54 `',(getf (smv env
) nil
))
56 (deftest macroexpand-all
.4
57 (macroexpand-all '(symbol-macrolet ((srlt '(nil zool
))) (testr)))
58 (symbol-macrolet ((srlt '(nil zool
))) 'zool
))
60 (defmacro dinfo
(thing &environment env
)
61 `',(declaration-information thing env
))
64 `(macrolet ((frob (suffix answer
&optional declaration
)
65 `(deftest ,(intern (concatenate 'string
66 "DECLARATION-INFORMATION."
69 (locally (declare ,@(when declaration
71 (cadr (assoc ',',x
(dinfo optimize
))))
74 (frob ".0" 0 (optimize (,x
0)))
75 (frob ".1" 1 (optimize (,x
1)))
76 (frob ".2" 2 (optimize (,x
2)))
77 (frob ".3" 3 (optimize (,x
3)))
78 (frob ".IMPLICIT" 3 (optimize ,x
)))))
82 (def compilation-speed
)
85 (deftest declaration-information.muffle-conditions.default
86 (dinfo sb-ext
:muffle-conditions
)
88 (deftest declaration-information.muffle-conditions
.1
89 (locally (declare (sb-ext:muffle-conditions warning
))
90 (dinfo sb-ext
:muffle-conditions
))
92 (deftest declaration-information.muffle-conditions
.2
93 (locally (declare (sb-ext:muffle-conditions warning
))
94 (locally (declare (sb-ext:unmuffle-conditions style-warning
))
95 (let ((dinfo (dinfo sb-ext
:muffle-conditions
)))
98 (and (subtypep dinfo
'(and warning
(not style-warning
)))
99 (subtypep '(and warning
(not style-warning
)) dinfo
)))))))