+;;;; 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 :sb-kernel :sb-int))
+
(in-package :sb-cltl2-tests)
(rem-all-tests)
(foo 1))))))
(remove-duplicates *expansions*))
(1))
+
+(defun smv (env)
+ (multiple-value-bind (expansion macro-p)
+ (macroexpand 'srlt env)
+ (when macro-p (eval expansion))))
+(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))
+
+;;;; DECLARATION-INFORMATION
+
+(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.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)
+(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)
+
+
+(declaim (declaration fubar))
+
+(deftest declaration-information.declaration
+ (if (member 'fubar (declaration-information 'declaration)) 'yay)
+ yay)
+
+;;;; 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))))
+
+(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)
+ (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)))))
+
+(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))
+
+(deftest macroexpand-all.special-binding
+ (let ((form '(macrolet ((v (x &environment env)
+ (sb-cltl2:variable-information x env)))
+ (let* ((x :foo)
+ (y (v x)))
+ (declare (special x))
+ (list y (v x))))))
+ (list (eval form)
+ (eval (sb-cltl2:macroexpand-all form))))
+ ((:special :special) (:special :special)))
+
+(deftest macroexpand-all.symbol-macro-shadowed
+ (let ((form '(macrolet ((v (x &environment env)
+ (macroexpand x env)))
+ (symbol-macrolet ((x :bad))
+ (let* ((x :good)
+ (y (v x)))
+ y)))))
+ (list (eval form)
+ (eval (sb-cltl2:macroexpand-all form))))
+ (:good :good))
projects / sbcl.git / blobdiff