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