0.8.18.25:
[sbcl.git] / contrib / sb-cltl2 / tests.lisp
1 (defpackage :sb-cltl2-tests
2   (:use :sb-cltl2 :cl :sb-rt))
3 (in-package :sb-cltl2-tests)
4
5 (rem-all-tests)
6
7 (defmacro *x*-value ()
8   (declare (special *x*))
9   *x*)
10
11 (deftest compiler-let.1
12     (let ((*x* :outer))
13       (compiler-let ((*x* :inner))
14         (list *x* (*x*-value))))
15   (:outer :inner))
16
17 (defvar *expansions* nil)
18 (defmacro macroexpand-macro (arg)
19   (push arg *expansions*)
20   arg)
21
22 (deftest macroexpand-all.1
23     (progn
24       (macroexpand-all '(defmethod foo ((x fixnum)) (1+ x)))
25       t)
26   t)
27
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* #'<)))
34   (1 2))
35
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)))
41                        (foo
42                         (macrolet ((bar (key)
43                                      (push key *expansions*)
44                                      key))
45                           (foo 1))))))
46       (remove-duplicates *expansions*))
47   (1))
48
49 (defun smv (env)
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))
55
56 (deftest macroexpand-all.4
57     (macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
58   (symbol-macrolet ((srlt '(nil zool))) 'zool))
59
60 (defmacro dinfo (thing &environment env)
61   `',(declaration-information thing env))
62
63 (macrolet ((def (x)
64                `(macrolet ((frob (suffix answer &optional declaration)
65                             `(deftest ,(intern (concatenate 'string
66                                                             "DECLARATION-INFORMATION."
67                                                             (symbol-name ',x)
68                                                             suffix))
69                                (locally (declare ,@(when declaration
70                                                          (list declaration)))
71                                  (cadr (assoc ',',x (dinfo optimize))))
72                               ,answer)))
73                  (frob ".DEFAULT" 1)
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)))))
79   (def speed)
80   (def safety)
81   (def debug)
82   (def compilation-speed)
83   (def space))
84
85 (deftest declaration-information.muffle-conditions.default
86   (dinfo sb-ext:muffle-conditions)
87   nil)
88 (deftest declaration-information.muffle-conditions.1
89   (locally (declare (sb-ext:muffle-conditions warning))
90     (dinfo sb-ext:muffle-conditions))
91   warning)
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)))
96         (not
97          (not
98           (and (subtypep dinfo '(and warning (not style-warning)))
99                (subtypep '(and warning (not style-warning)) dinfo)))))))
100   t)