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)