;;;; more information.
(defpackage :sb-cltl2-tests
- (:use :sb-cltl2 :cl :sb-rt))
+ (:use :sb-cltl2 :cl :sb-rt :sb-ext :sb-kernel :sb-int))
(in-package :sb-cltl2-tests)
(macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
(symbol-macrolet ((srlt '(nil zool))) 'zool))
+;;;; DECLARATION-INFORMATION
+
(defmacro dinfo (thing &environment env)
`',(declaration-information thing env))
(def compilation-speed)
(def space))
+
+(deftest declaration-information.restrict-compiler-policy.1
+ (with-compilation-unit (:policy '(optimize) :override t)
+ (restrict-compiler-policy 'speed 3)
+ (eval '(cadr (assoc 'speed (dinfo optimize)))))
+ 3)
+
+(deftest declaration-information.restrict-compiler-policy.2
+ (with-compilation-unit (:policy '(optimize) :override t)
+ (restrict-compiler-policy 'speed 3)
+ (locally (declare (optimize (speed 2)))
+ (cadr (assoc 'speed (dinfo optimize)))))
+ 2)
+
+(deftest declaration-information.restrict-compiler-policy.3
+ (locally (declare (optimize (speed 2)))
+ (with-compilation-unit (:policy '(optimize) :override t)
+ (restrict-compiler-policy 'speed 3)
+ (cadr (assoc 'speed (dinfo optimize)))))
+ 2)
+
(deftest declaration-information.muffle-conditions.default
(dinfo sb-ext:muffle-conditions)
nil)
(subtypep '(and warning (not style-warning)) dinfo)))))))
t)
+
+(declaim (declaration fubar))
+
+(deftest declaration-information.declaration
+ (if (member 'fubar (declaration-information 'declaration)) 'yay)
+ yay)
+
;;;; VARIABLE-INFORMATION
(defvar *foo*)
(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 #: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))))
+
+(sb-alien:define-alien-variable "errno" sb-alien:int)
+(deftest alien-variable
+ (var-info errno)
+ (:alien nil nil))
+
;;;; FUNCTION-INFORMATION
(defmacro fun-info (var &environment env)
(:function nil ((inline . inline)
(ftype function (t) (values t &optional)))))
+(deftest function-information.ftype
+ (flet ((foo (x) x))
+ (declare (ftype (sfunction (integer) integer) foo))
+ (fun-info foo))
+ (:function
+ t
+ ((ftype function (integer) (values integer &optional)))))
+
+;;;;; AUGMENT-ENVIRONMENT
+
+(defmacro ct (form &environment env)
+ (let ((toeval `(let ((lexenv (quote ,env)))
+ ,form)))
+ `(quote ,(eval toeval))))
+
+
+(deftest augment-environment.variable1
+ (multiple-value-bind (kind local alist)
+ (variable-information
+ 'x
+ (augment-environment nil :variable (list 'x) :declare '((type integer x))))
+ (list kind local (cdr (assoc 'type alist))))
+ (:lexical t integer))
+
+(defvar *foo*)
+
+(deftest augment-environment.variable2
+ (identity (variable-information '*foo* (augment-environment nil :variable '(*foo*))))
+ :lexical)
+
+(deftest augment-environment.variable3
+ (identity (variable-information 'foo (augment-environment nil :variable '(foo))))
+ :lexical)
+
+(deftest augment-environment.variable.special1
+ (identity (variable-information 'x (augment-environment nil :variable '(x) :declare '((special x)))))
+ :special)
+
+(deftest augment-environment.variable.special12
+ (locally (declare (special x))
+ (ct
+ (variable-information
+ 'x
+ (identity (augment-environment lexenv :variable '(x))))))
+ :lexical)
+
+(deftest augment-environment.variable.special13
+ (let* ((e1 (augment-environment nil :variable '(x) :declare '((special x))))
+ (e2 (augment-environment e1 :variable '(x))))
+ (identity (variable-information 'x e2)))
+ :lexical)
+
+(deftest augment-environment.variable.special.mask
+ (let* ((e1 (augment-environment nil :variable '(x) :declare '((ignore x))))
+ (e2 (augment-environment e1 :variable '(x))))
+ (assoc 'ignore
+ (nth 2 (multiple-value-list
+ (variable-information 'x e2)))))
+ nil)
+
+(deftest augment-environment.variable.ignore
+ (variable-information
+ 'x
+ (augment-environment nil
+ :variable '(x)
+ :declare '((ignore x))))
+ :lexical
+ t
+ ((ignore . t)))
+
+(deftest augment-environment.function
+ (function-information
+ 'foo
+ (augment-environment nil
+ :function '(foo)
+ :declare '((ftype (sfunction (integer) integer) foo))))
+ :function
+ t
+ ((ftype function (integer) (values integer &optional))))
+
+
+(deftest augment-environment.macro
+ (macroexpand '(mac feh)
+ (augment-environment
+ nil
+ :macro (list (list 'mac #'(lambda (form benv)
+ (declare (ignore env))
+ `(quote ,form ,form ,form))))))
+ (quote (mac feh) (mac feh) (mac feh))
+ t)
+
+(deftest augment-environment.symbol-macro
+ (macroexpand 'sym
+ (augment-environment
+ nil
+ :symbol-macro (list (list 'sym '(foo bar baz)))))
+ (foo bar baz)
+ t)
+
+(deftest augment-environment.macro2
+ (eval (macroexpand '(newcond
+ ((= 1 2) 'foo)
+ ((= 1 1) 'bar))
+ (augment-environment nil :macro (list (list 'newcond (macro-function 'cond))))))
+ bar)
+
+
+(deftest augment-environment.nest
+ (let ((x 1))
+ (ct
+ (let* ((e (augment-environment lexenv :variable '(y))))
+ (list
+ (variable-information 'x e)
+ (variable-information 'y e)))))
+ (:lexical :lexical))
+
+(deftest augment-environment.nest2
+ (symbol-macrolet ((x "x"))
+ (ct
+ (let* ((e (augment-environment lexenv :variable '(y))))
+ (list
+ (macroexpand 'x e)
+ (variable-information 'y e)))))
+ ("x" :lexical))
+
+(deftest augment-environment.symbol-macro-var
+ (let ((e (augment-environment
+ nil
+ :symbol-macro (list (list 'sym '(foo bar baz)))
+ :variable '(x))))
+ (list (macroexpand 'sym e)
+ (variable-information 'x e)))
+ ((foo bar baz)
+ :lexical))
+
+
+
+;;;;; DEFINE-DECLARATION
+
+(defmacro third-value (form)
+ (sb-int::with-unique-names (a b c)
+ `(multiple-value-bind (,a ,b ,c) ,form
+ (declare (ignore ,a ,b))
+ ,c)))
+
+(deftest define-declaration.declare
+ (progn
+ (define-declaration zaphod (spec env)
+ (declare (ignore env))
+ (values :declare (cons 'zaphod spec)))
+ (locally (declare (zaphod beblebrox))
+ (locally (declare (zaphod and ford))
+ (ct (declaration-information 'zaphod lexenv)))))
+ (zaphod and ford))
+
+
+(deftest define-declaration.declare2
+ (progn
+ (define-declaration zaphod (spec env)
+ (declare (ignore env))
+ (values :declare (cons 'zaphod spec)))
+ (locally
+ (declare (zaphod beblebrox)
+ (special x))
+ (ct (declaration-information 'zaphod lexenv))))
+ (zaphod beblebrox))
+
+(deftest define-declaration.variable
+ (progn
+ (define-declaration vogon (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key vogon-value))))
+ (locally (declare (vogon poetry))
+ (ct
+ (assoc 'vogon-key
+ (third-value
+ (variable-information
+ 'poetry
+ lexenv))))))
+ (vogon-key . vogon-value))
+
+
+(deftest define-declaration.variable.special
+ (progn
+ (define-declaration vogon (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key vogon-value))))
+ (let (x)
+ (declare (vogon x))
+ (declare (special x))
+ (ct
+ (assoc 'vogon-key
+ (third-value
+ (variable-information 'x lexenv))))))
+ (vogon-key . vogon-value))
+
+(deftest define-declaration.variable.special2
+ (progn
+ (define-declaration vogon (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key vogon-value))))
+ (let (x)
+ (declare (special x))
+ (declare (vogon x))
+ (ct
+ (assoc 'vogon-key
+ (third-value
+ (variable-information 'x lexenv))))))
+ (vogon-key . vogon-value))
+
+(deftest define-declaration.variable.mask
+ (progn
+ (define-declaration vogon (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key vogon-value))))
+ (let (x)
+ (declare (vogon x))
+ (let (x)
+ (ct
+ (assoc
+ 'vogon-key
+ (third (multiple-value-list (variable-information 'x lexenv))))))))
+ nil)
+
+(deftest define-declaration.variable.macromask
+ (progn
+ (define-declaration vogon (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key vogon-value))))
+ (let (x)
+ (declare (vogon x))
+ (symbol-macrolet ((x 42))
+ (ct
+ (assoc
+ 'vogon-key
+ (third (multiple-value-list (variable-information 'x lexenv))))))))
+ nil)
+
+(deftest define-declaration.variable.macromask2
+ (progn
+ (define-declaration vogon (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key vogon-value))))
+ (symbol-macrolet ((x 42))
+ (declare (vogon x))
+ (list
+ (let (x)
+ (ct
+ (assoc
+ 'vogon-key
+ (third (multiple-value-list (variable-information 'x lexenv))))))
+ (ct
+ (assoc
+ 'vogon-key
+ (third (multiple-value-list (variable-information 'x lexenv))))))))
+ (nil (vogon-key . vogon-value)))
+
+(deftest define-declaration.variable.mask2
+ (progn
+ (define-declaration vogon-a (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key a))))
+ (define-declaration vogon-b (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key b))))
+ (let (x)
+ (declare (vogon-a x))
+ (let (x)
+ (declare (vogon-b x)))
+ (ct
+ (assoc
+ 'vogon-key
+ (third (multiple-value-list (variable-information 'x lexenv)))))))
+ (vogon-key . a))
+
+(deftest define-declaration.variable.specialmask
+ (progn
+ (define-declaration vogon (spec env)
+ (declare (ignore env))
+ (values :variable `((,(cadr spec) vogon-key vogon-value))))
+ (locally
+ (declare (vogon *foo*))
+ (let (*foo*)
+ (ct
+ (assoc
+ 'vogon-key
+ (third (multiple-value-list (variable-information '*foo* lexenv))))))))
+ (vogon-key . vogon-value))
+
+
+
+(deftest define-declaration.function
+ (progn
+ (define-declaration sad (spec env)
+ (declare (ignore env))
+ (values :function `((,(cadr spec) emotional-state sad))))
+ (locally (declare (zaphod beblebrox))
+ (locally (declare (sad robot))
+ (ct
+ (assoc 'emotional-state
+ (third-value (function-information
+ 'robot
+ lexenv)))))))
+ (emotional-state . sad))
+
+(deftest define-declaration.function.lexical
+ (progn
+ (define-declaration sad (spec env)
+ (declare (ignore env))
+ (values :function `((,(cadr spec) emotional-state sad))))
+ (flet ((robot nil))
+ (locally (declare (sad robot))
+ (ct
+ (assoc 'emotional-state
+ (third-value (function-information
+ 'robot
+ lexenv)))))))
+ (emotional-state . sad))
+
+
+(deftest define-declaration.function.lexical2
+ (progn
+ (define-declaration sad (spec env)
+ (declare (ignore env))
+ (values :function `((,(cadr spec) emotional-state sad))))
+ (labels ((robot nil))
+ (declare (sad robot))
+ (ct
+ (assoc 'emotional-state
+ (third-value (function-information
+ 'robot
+ lexenv))))))
+ (emotional-state . sad))
+
+(deftest define-declaration.function.mask
+ (progn
+ (define-declaration sad (spec env)
+ (declare (ignore env))
+ (values :function `((,(cadr spec) emotional-state sad))))
+ (labels ((robot nil))
+ (declare (sad robot))
+ (labels ((robot nil))
+ (ct
+ (assoc 'emotional-state
+ (third-value (function-information
+ 'robot
+ lexenv)))))))
+ nil)
+
+
+(deftest define-declaration.function.mask2
+ (progn
+ (define-declaration sad (spec env)
+ (declare (ignore env))
+ (values :function `((,(cadr spec) emotional-state sad))))
+ (locally
+ (declare (sad robot))
+ (labels ((robot nil))
+ (ct
+ (assoc 'emotional-state
+ (third-value (function-information
+ 'robot
+ lexenv)))))))
+ nil)
+
+(deftest define-declaration.function2
+ (progn
+ (define-declaration happy (spec env)
+ (declare (ignore env))
+ (values :function `((,(cadr spec) emotional-state happy))))
+ (locally (declare (zaphod beblebrox))
+ (locally (declare (sad robot))
+ (locally (declare (happy robot))
+ (ct
+ (assoc 'emotional-state
+ (third-value (function-information
+ 'robot
+ lexenv))))))))
+ (emotional-state . happy))
projects / sbcl.git / blobdiff