X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-cltl2%2Ftests.lisp;h=ec5e8c96df99cc2e9c946c1ae27f68d5863869c0;hb=c0578d9893429c9c0da80ea5920360e4621fddab;hp=19d5f0521003176424f9b6ec8cc936d435482909;hpb=724b51e6acb1fd0040de3751c9e4566e7a87ced3;p=sbcl.git

diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp
index 19d5f05..ec5e8c9 100644
--- a/contrib/sb-cltl2/tests.lisp
+++ b/contrib/sb-cltl2/tests.lisp
@@ -1,5 +1,13 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; The software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
 (defpackage :sb-cltl2-tests
-  (:use :sb-cltl2 :cl :sb-rt))
+  (:use :sb-cltl2 :cl :sb-rt :sb-ext))
+
 (in-package :sb-cltl2-tests)
 
 (rem-all-tests)
@@ -47,12 +55,227 @@
   (1))
 
 (defun smv (env)
-  (multiple-value-bind (expansion macro-p) 
-      (macroexpand 'srlt env) 
+  (multiple-value-bind (expansion macro-p)
+      (macroexpand 'srlt env)
     (when macro-p (eval expansion))))
-(defmacro testr (&environment env) 
+(defmacro testr (&environment env)
   `',(getf (smv env) nil))
 
 (deftest macroexpand-all.4
     (macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
   (symbol-macrolet ((srlt '(nil zool))) 'zool))
+
+(defmacro dinfo (thing &environment env)
+  `',(declaration-information thing env))
+
+(macrolet ((def (x)
+               `(macrolet ((frob (suffix answer &optional declaration)
+                            `(deftest ,(intern (concatenate 'string
+                                                            "DECLARATION-INFORMATION."
+                                                            (symbol-name ',x)
+                                                            suffix))
+                               (locally (declare ,@(when declaration
+                                                         (list declaration)))
+                                 (cadr (assoc ',',x (dinfo optimize))))
+                              ,answer)))
+                 (frob ".DEFAULT" 1)
+                 (frob ".0" 0 (optimize (,x 0)))
+                 (frob ".1" 1 (optimize (,x 1)))
+                 (frob ".2" 2 (optimize (,x 2)))
+                 (frob ".3" 3 (optimize (,x 3)))
+                 (frob ".IMPLICIT" 3 (optimize ,x)))))
+  (def speed)
+  (def safety)
+  (def debug)
+  (def compilation-speed)
+  (def space))
+
+(deftest declaration-information.muffle-conditions.default
+  (dinfo sb-ext:muffle-conditions)
+  nil)
+(deftest declaration-information.muffle-conditions.1
+  (locally (declare (sb-ext:muffle-conditions warning))
+    (dinfo sb-ext:muffle-conditions))
+  warning)
+(deftest declaration-information.muffle-conditions.2
+  (let ((junk (dinfo sb-ext:muffle-conditions)))
+    (declare (sb-ext:muffle-conditions warning))
+    (locally (declare (sb-ext:unmuffle-conditions style-warning))
+      (let ((dinfo (dinfo sb-ext:muffle-conditions)))
+        (not
+         (not
+          (and (subtypep dinfo `(or (and warning (not style-warning))
+                                    (and ,junk (not style-warning))))
+               (subtypep '(and warning (not style-warning)) dinfo)))))))
+  t)
+
+;;;; VARIABLE-INFORMATION
+
+(defvar *foo*)
+
+(defmacro var-info (var &environment env)
+  (list 'quote (multiple-value-list (variable-information var env))))
+
+(deftest variable-info.global-special/unbound
+    (var-info *foo*)
+  (:special nil nil))
+
+(deftest variable-info.global-special/unbound/extra-decl
+    (locally (declare (special *foo*))
+      (var-info *foo*))
+  (:special nil nil))
+
+(deftest variable-info.global-special/bound
+    (let ((*foo* t))
+      (var-info *foo*))
+  (:special nil nil))
+
+(deftest variable-info.global-special/bound/extra-decl
+    (let ((*foo* t))
+      (declare (special *foo*))
+      (var-info *foo*))
+  (:special nil nil))
+
+(deftest variable-info.local-special/unbound
+    (locally (declare (special x))
+      (var-info x))
+  (:special nil nil))
+
+(deftest variable-info.local-special/bound
+    (let ((x 13))
+      (declare (special x))
+      (var-info x))
+  (:special nil nil))
+
+(deftest variable-info.local-special/shadowed
+    (let ((x 3))
+      (declare (special x))
+      x
+      (let ((x 3))
+        x
+        (var-info x)))
+  (:lexical t nil))
+
+(deftest variable-info.local-special/shadows-lexical
+    (let ((x 3))
+      (let ((x 3))
+        (declare (special x))
+        (var-info x)))
+  (:special nil nil))
+
+(deftest variable-info.lexical
+    (let ((x 8))
+      (var-info x))
+  (:lexical t nil))
+
+(deftest variable-info.lexical.type
+    (let ((x 42))
+      (declare (fixnum x))
+      (var-info x))
+  (:lexical t ((type . fixnum))))
+
+(deftest variable-info.lexical.type.2
+    (let ((x 42))
+      (prog1
+          (var-info x)
+        (locally (declare (fixnum x))
+          (assert (plusp x)))))
+  (:lexical t nil))
+
+(deftest variable-info.lexical.type.2
+    (let ((x 42))
+      (locally (declare (fixnum x))
+        (var-info x)))
+  (:lexical t ((type . fixnum))))
+
+(deftest variable-info.ignore
+    (let ((x 8))
+      (declare (ignore x))
+      (var-info x))
+  (:lexical t ((ignore . t))))
+
+(deftest variable-info.symbol-macro/local
+    (symbol-macrolet ((x 8))
+      (var-info x))
+  (:symbol-macro t nil))
+
+(define-symbol-macro my-symbol-macro t)
+
+(deftest variable-info.symbol-macro/global
+    (var-info my-symbol-macro)
+  (:symbol-macro nil nil))
+
+(deftest variable-info.undefined
+    (var-info #:undefined)
+  (nil nil nil))
+
+(declaim (global this-is-global))
+(deftest global-variable
+    (var-info this-is-global)
+  (:global nil nil))
+
+(defglobal this-is-global-too 42)
+(deftest global-variable.2
+    (var-info this-is-global-too)
+  (:global nil ((always-bound . t))))
+
+;;;; FUNCTION-INFORMATION
+
+(defmacro fun-info (var &environment env)
+  (list 'quote (multiple-value-list (function-information var env))))
+
+(defun my-global-fun (x) x)
+
+(deftest function-info.global/no-ftype
+    (fun-info my-global-fun)
+  (:function nil nil))
+
+(declaim (ftype (function (cons) (values t &optional)) my-global-fun-2))
+
+(defun my-global-fun-2 (x) x)
+
+(deftest function-info.global/ftype
+    (fun-info my-global-fun-2)
+  (:function nil ((ftype function (cons) (values t &optional)))))
+
+(defmacro my-macro (x) x)
+
+(deftest function-info.macro
+    (fun-info my-macro)
+  (:macro nil nil))
+
+(deftest function-info.macrolet
+    (macrolet ((thingy () nil))
+      (fun-info thingy))
+  (:macro t nil))
+
+(deftest function-info.special-form
+    (fun-info progn)
+  (:special-form  nil nil))
+
+(deftest function-info.notinline/local
+    (flet ((x (y) y))
+      (declare (notinline x))
+      (x 1)
+      (fun-info x))
+  (:function t ((inline . notinline))))
+
+(declaim (notinline my-notinline))
+(defun my-notinline (x) x)
+
+(deftest function-info.notinline/global
+    (fun-info my-notinline)
+  (:function nil ((inline . notinline))))
+
+(declaim (inline my-inline))
+(defun my-inline (x) x)
+
+(deftest function-info.inline/global
+    (fun-info my-inline)
+  (:function nil ((inline . inline))))
+
+(deftest function-information.known-inline
+    (locally (declare (inline identity))
+      (fun-info identity))
+  (:function nil ((inline . inline)
+                  (ftype function (t) (values t &optional)))))