+;;;; 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)
(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.3
+ (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)))))
projects / sbcl.git / blobdiff