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 ;; Undo default contribs mufflage so that DECLARATION-INFORMATION tests pass.
   9 sb-ext::(declaim (unmuffle-conditions compiler-note))
  10
  11 (defpackage :sb-cltl2-tests
  12   (:use :sb-cltl2 :cl :sb-rt :sb-ext :sb-kernel :sb-int))
  13
  14 (in-package :sb-cltl2-tests)
  15
  16 (rem-all-tests)
  17
  18 (defmacro *x*-value ()
  19   (declare (special *x*))
  20   *x*)
  21
  22 (deftest compiler-let.1
  23     (let ((*x* :outer))
  24       (compiler-let ((*x* :inner))
  25         (list *x* (*x*-value))))
  26   ;; See the X3J13 writeup for why the interpreter
  27   ;; might return (and does return) a different answer.
  28   #.(if (eq sb-ext:*evaluator-mode* :compile)
  29         '(:outer :inner)
  30         '(:inner :inner)))
  31
  32 (defvar *expansions* nil)
  33 (defmacro macroexpand-macro (arg)
  34   (push arg *expansions*)
  35   arg)
  36
  37 (deftest macroexpand-all.1
  38     (progn
  39       (macroexpand-all '(defmethod foo ((x fixnum)) (1+ x)))
  40       t)
  41   t)
  42
  43 (deftest macroexpand-all.2
  44     (let ((*expansions* nil))
  45       (macroexpand-all '(list (macroexpand-macro 1)
  46                          (let (macroexpand-macro :no)
  47                            (macroexpand-macro 2))))
  48       (remove-duplicates (sort *expansions* #'<)))
  49   (1 2))
  50
  51 (deftest macroexpand-all.3
  52     (let ((*expansions* nil))
  53       (compile nil '(lambda ()
  54                      (declare (muffle-conditions style-warning))
  55                      (macrolet ((foo (key &environment env)
  56                                   (macroexpand-all `(bar ,key) env)))
  57                        (foo
  58                         (macrolet ((bar (key)
  59                                      (push key *expansions*)
  60                                      key))
  61                           (foo 1))))))
  62       (remove-duplicates *expansions*))
  63   (1))
  64
  65 (defun smv (env)
  66   (multiple-value-bind (expansion macro-p)
  67       (macroexpand 'srlt env)
  68     (when macro-p (eval expansion))))
  69 (defmacro testr (&environment env)
  70   `',(getf (smv env) nil))
  71
  72 (deftest macroexpand-all.4
  73     (macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
  74   (symbol-macrolet ((srlt '(nil zool))) 'zool))
  75
  76 ;; Quasiquotation
  77 (deftest macroexpand-all.5
  78     ;; The second use of (W) is expanded to X, the first is untouched.
  79     ;; Use EQUALP explicitly because the RT tester's EQUALP-WITH-CASE
  80     ;; is not quite EQUALP with regard to structures.
  81     (equalp (macroexpand-all '(macrolet ((w () 'x))
  82                `(let ((y `(z ,(w) ,,(w)))) (g))))
  83             '(macrolet ((w () 'x)) `(let ((y `(z ,(w) ,,x))) (g))))
  84   t)
  85
  86 (deftest macroexpand-all.6
  87     ;; The subform (AND Z) in (PROGN `(F ,(WHEN X Y) . `(,B ,,(AND Z))))
  88     ;; is evaluable though unlikely to appear in real code. Unless F is a
  89     ;; macro, this form when evaluated does not comprise a well-formed sexpr.
  90     (equalp (macroexpand-all '(progn `(f ,(when x y) . `(,b ,,(and z)))))
  91             '(progn `(f ,(if x y) . `(,b ,,(the t z)))))
  92   t)
  93
  94 ;;; Symbol macros
  95 (define-symbol-macro global-symbol-macro xxx)
  96
  97 (deftest macroexpand-all.7
  98     (equalp (macroexpand-all 'global-symbol-macro) 'xxx)
  99   t)
 100 (deftest macroexpand-all.8
 101     (symbol-macrolet ((global-symbol-macro yyy))
 102       (macrolet ((frob (&environment env form)
 103                    `',(macroexpand-all form env)))
 104         (equalp (frob global-symbol-macro) 'yyy)))
 105   t)
 106 (deftest macroexpand-all.9
 107     (let ((global-symbol-macro 3))
 108       (macrolet ((frob (&environment env form)
 109                    `',(macroexpand-all form env)))
 110         (equalp (frob global-symbol-macro) 'global-symbol-macro)))
 111   t)
 112 (deftest macroexpand-all.10
 113     (macrolet ((frob (&environment env form)
 114                  `',(macroexpand-all form env)))
 115       (equalp (frob (let ((anything 1)) global-symbol-macro))
 116               '(let ((anything 1)) xxx)))
 117   t)
 118 (deftest macroexpand-all.11
 119     (macrolet ((frob (&environment env form)
 120                  `',(macroexpand-all form env)))
 121       (equalp (frob (let ((global-symbol-macro global-symbol-macro))
 122                       global-symbol-macro))
 123               '(let ((global-symbol-macro xxx)) global-symbol-macro)))
 124   t)
 125 (deftest macroexpand-all.12
 126     (macrolet ((frob (&environment env form)
 127                  `',(macroexpand-all form env)))
 128       (equalp (frob (symbol-macrolet ((global-symbol-macro 3))
 129                       global-symbol-macro))
 130               '(symbol-macrolet ((global-symbol-macro 3)) 3)))
 131   t)
 132 (deftest macroexpand-all.13
 133     (symbol-macrolet ((x y))
 134       (macrolet ((frob (&environment env form)
 135                    `',(macroexpand-all form env)))
 136         (equalp (frob (+ x x))
 137                 '(+ y y))))
 138   t)
 139 ;;;; DECLARATION-INFORMATION
 140
 141 (defmacro dinfo (thing &environment env)
 142   `',(declaration-information thing env))
 143
 144 (macrolet ((def (x)
 145                `(macrolet ((frob (suffix answer &optional declaration)
 146                             `(deftest ,(intern (concatenate 'string
 147                                                             "DECLARATION-INFORMATION."
 148                                                             (symbol-name ',x)
 149                                                             suffix))
 150                                (locally (declare ,@(when declaration
 151                                                          (list declaration)))
 152                                  (cadr (assoc ',',x (dinfo optimize))))
 153                               ,answer)))
 154                  (frob ".DEFAULT" 1)
 155                  (frob ".0" 0 (optimize (,x 0)))
 156                  (frob ".1" 1 (optimize (,x 1)))
 157                  (frob ".2" 2 (optimize (,x 2)))
 158                  (frob ".3" 3 (optimize (,x 3)))
 159                  (frob ".IMPLICIT" 3 (optimize ,x)))))
 160   (def speed)
 161   (def safety)
 162   (def debug)
 163   (def compilation-speed)
 164   (def space))
 165
 166
 167 (deftest declaration-information.restrict-compiler-policy.1
 168     (with-compilation-unit (:policy '(optimize) :override t)
 169       (restrict-compiler-policy 'speed 3)
 170       (eval '(cadr (assoc 'speed (dinfo optimize)))))
 171   3)
 172
 173 ;; This usage is esoteric, and the expected answer differs based on whether the
 174 ;; code is interpreted or compiled. Compiling RESTRICT-COMPILER-POLICY doesn't
 175 ;; actually do anything to affect the compiler since it is not a toplevel form
 176 ;; in an eval-when. (I suspect that it wouldn't normally be used this way)
 177 ;; But the interpreter calls it, which has an immediate visible effect.
 178 (deftest declaration-information.restrict-compiler-policy.2
 179     (with-compilation-unit (:policy '(optimize) :override t)
 180       (restrict-compiler-policy 'speed 3)
 181       (locally (declare (optimize (speed 2)))
 182         (cadr (assoc 'speed (dinfo optimize)))))
 183   ;; sb-rt doesn't eval the "expected result" form.
 184   #.(if (eq sb-ext:*evaluator-mode* :compile) 2 3))
 185
 186 (deftest declaration-information.restrict-compiler-policy.3
 187     (locally (declare (optimize (speed 2)))
 188       (with-compilation-unit (:policy '(optimize) :override t)
 189         (restrict-compiler-policy 'speed 3)
 190         (cadr (assoc 'speed (dinfo optimize)))))
 191   #.(if (eq sb-ext:*evaluator-mode* :compile) 2 3))
 192
 193 (deftest declaration-information.muffle-conditions.default
 194   (dinfo sb-ext:muffle-conditions)
 195   nil)
 196 (deftest declaration-information.muffle-conditions.1
 197   (locally (declare (sb-ext:muffle-conditions warning))
 198     (dinfo sb-ext:muffle-conditions))
 199   warning)
 200 (deftest declaration-information.muffle-conditions.2
 201   (let ((junk (dinfo sb-ext:muffle-conditions)))
 202     (declare (sb-ext:muffle-conditions warning))
 203     (locally (declare (sb-ext:unmuffle-conditions style-warning))
 204       (let ((dinfo (dinfo sb-ext:muffle-conditions)))
 205         (not
 206          (not
 207           (and (subtypep dinfo `(or (and warning (not style-warning))
 208                                     (and ,junk (not style-warning))))
 209                (subtypep '(and warning (not style-warning)) dinfo)))))))
 210   t)
 211
 212
 213 (declaim (declaration fubar))
 214
 215 (deftest declaration-information.declaration
 216     (if (member 'fubar (declaration-information 'declaration)) 'yay)
 217   yay)
 218
 219 ;;;; VARIABLE-INFORMATION
 220
 221 (defvar *foo*)
 222
 223 (defmacro var-info (var &environment env)
 224   (list 'quote (multiple-value-list (variable-information var env))))
 225
 226 (deftest variable-info.global-special/unbound
 227     (var-info *foo*)
 228   (:special nil nil))
 229
 230 (defvar *variable-info.global-special/unbound.deprecation*)
 231 (declaim (sb-ext:deprecated :early ("SBCL" "1.2.3")
 232           (variable *variable-info.global-special/unbound.deprecation* :replacement foo)))
 233 (deftest variable-info.global-special/unbound.deprecation
 234     (var-info *variable-info.global-special/unbound.deprecation*)
 235   (:special nil ((sb-ext:deprecated . (:state        :early
 236                                        :since        ("SBCL" "1.2.3")
 237                                        :replacements (foo))))))
 238
 239 (deftest variable-info.global-special/unbound/extra-decl
 240     (locally (declare (special *foo*))
 241       (var-info *foo*))
 242   (:special nil nil))
 243
 244 (deftest variable-info.global-special/bound
 245     (let ((*foo* t))
 246       (var-info *foo*))
 247   (:special nil nil))
 248
 249 (deftest variable-info.global-special/bound/extra-decl
 250     (let ((*foo* t))
 251       (declare (special *foo*))
 252       (var-info *foo*))
 253   (:special nil nil))
 254
 255 (deftest variable-info.local-special/unbound
 256     (locally (declare (special x))
 257       (var-info x))
 258   (:special nil nil))
 259
 260 (deftest variable-info.local-special/bound
 261     (let ((x 13))
 262       (declare (special x))
 263       (var-info x))
 264   (:special nil nil))
 265
 266 (deftest variable-info.local-special/shadowed
 267     (let ((x 3))
 268       (declare (special x))
 269       x
 270       (let ((x 3))
 271         x
 272         (var-info x)))
 273   (:lexical t nil))
 274
 275 (deftest variable-info.local-special/shadows-lexical
 276     (let ((x 3))
 277       (let ((x 3))
 278         (declare (special x))
 279         (var-info x)))
 280   (:special nil nil))
 281
 282 (deftest variable-info.lexical
 283     (let ((x 8))
 284       (var-info x))
 285   (:lexical t nil))
 286
 287 (deftest variable-info.lexical.type
 288     (let ((x 42))
 289       (declare (fixnum x))
 290       (var-info x))
 291   (:lexical t ((type . fixnum))))
 292
 293 (deftest variable-info.lexical.type.2
 294     (let ((x 42))
 295       (prog1
 296           (var-info x)
 297         (locally (declare (fixnum x))
 298           (assert (plusp x)))))
 299   (:lexical t nil))
 300
 301 (deftest variable-info.lexical.type.3
 302     (let ((x 42))
 303       (locally (declare (fixnum x))
 304         (var-info x)))
 305   (:lexical t ((type . fixnum))))
 306
 307 (deftest variable-info.ignore
 308     (let ((x 8))
 309       (declare (ignore x))
 310       (var-info x))
 311   (:lexical t ((ignore . t))))
 312
 313 (deftest variable-info.symbol-macro/local
 314     (symbol-macrolet ((x 8))
 315       (var-info x))
 316   (:symbol-macro t nil))
 317
 318 (define-symbol-macro my-symbol-macro t)
 319
 320 (deftest variable-info.symbol-macro/global
 321     (var-info my-symbol-macro)
 322   (:symbol-macro nil nil))
 323
 324 (deftest variable-info.undefined
 325     (var-info #:undefined)
 326   (nil nil nil))
 327
 328 (declaim (sb-ext:deprecated :early ("SBCL" "1.2.3")
 329           (variable *variable-info.undefined.deprecation* :replacement foo)))
 330 (deftest variable-info.undefined.deprecation
 331     (var-info *variable-info.undefined.deprecation*)
 332   (nil nil ((sb-ext:deprecated . (:state        :early
 333                                   :since        ("SBCL" "1.2.3")
 334                                   :replacements (foo))))))
 335
 336 (declaim (global this-is-global))
 337 (deftest global-variable
 338     (var-info this-is-global)
 339   (:global nil nil))
 340
 341 (defglobal this-is-global-too 42)
 342 (deftest global-variable.2
 343     (var-info this-is-global-too)
 344   (:global nil ((always-bound . t))))
 345
 346 (sb-alien:define-alien-variable "errno" sb-alien:int)
 347 (deftest alien-variable
 348     (var-info errno)
 349   (:alien nil nil))
 350
 351 (defglobal *variable-info.global.deprecation* 1)
 352 (declaim (sb-ext:deprecated :early ("SBCL" "1.2.3")
 353           (variable *variable-info.global.deprecation* :replacement foo)))
 354 (deftest variable-info.global.deprecation
 355     (var-info *variable-info.global.deprecation*)
 356   (:global nil ((always-bound . t)
 357                 (sb-ext:deprecated . (:state        :early
 358                                       :since        ("SBCL" "1.2.3")
 359                                       :replacements (foo))))))
 360
 361 ;;;; FUNCTION-INFORMATION
 362
 363 (defmacro fun-info (var &environment env)
 364   (list 'quote (multiple-value-list (function-information var env))))
 365
 366 (defun my-global-fun (x) x)
 367
 368 (deftest function-info.global/no-ftype
 369     (fun-info my-global-fun)
 370   (:function nil nil))
 371
 372 (declaim (ftype (function (cons) (values t &optional)) my-global-fun-2))
 373
 374 (defun my-global-fun-2 (x) x)
 375
 376 (deftest function-info.global/ftype
 377     (fun-info my-global-fun-2)
 378   (:function nil ((ftype . (function (cons) (values t &optional))))))
 379
 380 (defun function-info.global.deprecation ())
 381 (declaim (sb-ext:deprecated :early "1.2.3"
 382           (function function-info.global.deprecation :replacement foo)))
 383 (deftest function-info.global.deprecation
 384     (fun-info function-info.global.deprecation)
 385   (:function nil ((sb-ext:deprecated . (:state        :early
 386                                         :since        (nil "1.2.3")
 387                                         :replacements (foo))))))
 388
 389 (deftest function-info.global.deprecation.lexically-shadowed
 390     (flet ((function-info.global.deprecation ()))
 391       (fun-info function-info.global.deprecation))
 392   (:function t nil))
 393
 394 (defmacro my-macro (x) x)
 395
 396 (deftest function-info.macro
 397     (fun-info my-macro)
 398   (:macro nil nil))
 399
 400 (deftest function-info.macrolet
 401     (macrolet ((thingy () nil))
 402       (fun-info thingy))
 403   (:macro t nil))
 404
 405 (deftest function-info.special-form
 406     (fun-info progn)
 407   (:special-form  nil nil))
 408
 409 (deftest function-info.notinline/local
 410     (flet ((x (y) y))
 411       (declare (notinline x))
 412       (x 1)
 413       (fun-info x))
 414   (:function t ((inline . notinline))))
 415
 416 (declaim (notinline my-notinline))
 417 (defun my-notinline (x) x)
 418
 419 (deftest function-info.notinline/global
 420     (fun-info my-notinline)
 421   (:function nil ((inline . notinline))))
 422
 423 (declaim (inline my-inline))
 424 (defun my-inline (x) x)
 425
 426 (deftest function-info.inline/global
 427     (fun-info my-inline)
 428   (:function nil ((inline . inline))))
 429
 430 (deftest function-information.known-inline
 431     (locally (declare (inline identity))
 432       (fun-info identity))
 433   (:function nil ((inline . inline)
 434                   (ftype function (t) (values t &optional)))))
 435
 436 (deftest function-information.ftype
 437     (flet ((foo (x) x))
 438       (declare (ftype (sfunction (integer) integer) foo))
 439       (fun-info foo))
 440   (:function
 441    t
 442    ((ftype function (integer) (values integer &optional)))))
 443
 444 ;;;;; AUGMENT-ENVIRONMENT
 445
 446 (defmacro ct (form &environment env)
 447   (let ((toeval `(let ((lexenv (quote ,env)))
 448                    ,form)))
 449     `(quote ,(eval toeval))))
 450
 451
 452 (deftest augment-environment.variable1
 453     (multiple-value-bind (kind local alist)
 454         (variable-information
 455          'x
 456          (augment-environment nil :variable (list 'x) :declare '((type integer x))))
 457       (list kind local (cdr (assoc 'type alist))))
 458   (:lexical t integer))
 459
 460 (defvar *foo*)
 461
 462 (deftest augment-environment.variable2
 463     (identity (variable-information '*foo* (augment-environment nil :variable '(*foo*))))
 464   :lexical)
 465
 466 (deftest augment-environment.variable3
 467     (identity (variable-information 'foo (augment-environment nil :variable '(foo))))
 468   :lexical)
 469
 470 (deftest augment-environment.variable.special1
 471     (identity (variable-information 'x (augment-environment nil :variable '(x) :declare '((special x)))))
 472   :special)
 473
 474 (deftest augment-environment.variable.special12
 475     (locally (declare (special x))
 476       (ct
 477        (variable-information
 478         'x
 479         (identity (augment-environment lexenv :variable '(x))))))
 480   :lexical)
 481
 482 (deftest augment-environment.variable.special13
 483     (let* ((e1 (augment-environment nil :variable '(x) :declare '((special x))))
 484            (e2 (augment-environment e1  :variable '(x))))
 485       (identity (variable-information 'x e2)))
 486   :lexical)
 487
 488 (deftest augment-environment.variable.special.mask
 489     (let* ((e1 (augment-environment nil :variable '(x) :declare '((ignore x))))
 490            (e2 (augment-environment e1  :variable '(x))))
 491       (assoc 'ignore
 492              (nth 2 (multiple-value-list
 493                      (variable-information 'x e2)))))
 494   nil)
 495
 496 (deftest augment-environment.variable.ignore
 497     (variable-information
 498      'x
 499      (augment-environment nil
 500                           :variable '(x)
 501                           :declare  '((ignore x))))
 502   :lexical
 503   t
 504   ((ignore . t)))
 505
 506 (deftest augment-environment.function
 507     (function-information
 508      'foo
 509      (augment-environment nil
 510                           :function '(foo)
 511                           :declare  '((ftype (sfunction (integer) integer) foo))))
 512   :function
 513   t
 514   ((ftype function (integer) (values integer &optional))))
 515
 516
 517 (deftest augment-environment.macro
 518     (macroexpand '(mac feh)
 519                  (augment-environment
 520                   nil
 521                   :macro (list (list 'mac #'(lambda (form benv)
 522                                               (declare (ignore env))
 523                                               `(quote ,form ,form ,form))))))
 524   (quote (mac feh) (mac feh) (mac feh))
 525   t)
 526
 527 (deftest augment-environment.symbol-macro
 528     (macroexpand 'sym
 529                  (augment-environment
 530                   nil
 531                   :symbol-macro (list (list 'sym '(foo bar baz)))))
 532   (foo bar baz)
 533   t)
 534
 535 (deftest augment-environment.macro2
 536     (eval (macroexpand '(newcond
 537                          ((= 1 2) 'foo)
 538                          ((= 1 1) 'bar))
 539                        (augment-environment nil :macro (list (list 'newcond (macro-function 'cond))))))
 540   bar)
 541
 542
 543 (deftest augment-environment.nest
 544     (let ((x 1))
 545       (ct
 546        (let* ((e (augment-environment lexenv :variable '(y))))
 547          (list
 548           (variable-information 'x e)
 549           (variable-information 'y e)))))
 550   (:lexical :lexical))
 551
 552 (deftest augment-environment.nest2
 553     (symbol-macrolet ((x "x"))
 554       (ct
 555        (let* ((e (augment-environment lexenv :variable '(y))))
 556          (list
 557           (macroexpand 'x e)
 558           (variable-information 'y e)))))
 559   ("x" :lexical))
 560
 561 (deftest augment-environment.symbol-macro-var
 562     (let ((e (augment-environment
 563               nil
 564               :symbol-macro (list (list 'sym '(foo bar baz)))
 565               :variable '(x))))
 566       (list (macroexpand 'sym e)
 567             (variable-information 'x e)))
 568   ((foo bar baz)
 569    :lexical))
 570
 571 ;;;;; DEFINE-DECLARATION
 572
 573 (defmacro third-value (form)
 574   (sb-int::with-unique-names (a b c)
 575     `(multiple-value-bind (,a ,b ,c) ,form
 576        (declare (ignore ,a ,b))
 577        ,c)))
 578
 579 (deftest define-declaration.declare
 580     (progn
 581       (define-declaration zaphod (spec env)
 582         (declare (ignore env))
 583         (values :declare (cons 'zaphod spec)))
 584       (locally (declare (zaphod beblebrox))
 585          (locally (declare (zaphod and ford))
 586            (ct (declaration-information 'zaphod lexenv)))))
 587   (zaphod and ford))
 588
 589
 590 (deftest define-declaration.declare2
 591     (progn
 592       (define-declaration zaphod (spec env)
 593         (declare (ignore env))
 594         (values :declare (cons 'zaphod spec)))
 595       (locally
 596            (declare (zaphod beblebrox)
 597                     (special x))
 598          (ct (declaration-information 'zaphod lexenv))))
 599   (zaphod beblebrox))
 600
 601 (deftest define-declaration.variable
 602     (progn
 603       (define-declaration vogon (spec env)
 604         (declare (ignore env))
 605         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 606       (locally (declare (vogon poetry))
 607         (ct
 608          (assoc 'vogon-key
 609                 (third-value
 610                  (variable-information
 611                   'poetry
 612                   lexenv))))))
 613   (vogon-key . vogon-value))
 614
 615
 616 (deftest define-declaration.variable.special
 617     (progn
 618       (define-declaration vogon (spec env)
 619         (declare (ignore env))
 620         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 621       (let (x)
 622         (declare (vogon x))
 623         (declare (special x))
 624         (ct
 625          (assoc 'vogon-key
 626                 (third-value
 627                  (variable-information 'x lexenv))))))
 628   (vogon-key . vogon-value))
 629
 630 (deftest define-declaration.variable.special2
 631     (progn
 632       (define-declaration vogon (spec env)
 633         (declare (ignore env))
 634         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 635       (let (x)
 636         (declare (special x))
 637         (declare (vogon x))
 638         (ct
 639          (assoc 'vogon-key
 640                 (third-value
 641                  (variable-information 'x lexenv))))))
 642   (vogon-key . vogon-value))
 643
 644 (deftest define-declaration.variable.mask
 645     (progn
 646       (define-declaration vogon (spec env)
 647         (declare (ignore env))
 648         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 649       (let (x)
 650         (declare (vogon x))
 651         (let (x)
 652           (ct
 653            (assoc
 654             'vogon-key
 655             (third (multiple-value-list (variable-information 'x lexenv))))))))
 656   nil)
 657
 658 (deftest define-declaration.variable.macromask
 659     (progn
 660       (define-declaration vogon (spec env)
 661         (declare (ignore env))
 662         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 663       (let (x)
 664         (declare (vogon x))
 665         (symbol-macrolet ((x 42))
 666           (ct
 667            (assoc
 668             'vogon-key
 669             (third (multiple-value-list (variable-information 'x lexenv))))))))
 670   nil)
 671
 672 (deftest define-declaration.variable.macromask2
 673     (progn
 674       (define-declaration vogon (spec env)
 675         (declare (ignore env))
 676         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 677       (symbol-macrolet ((x 42))
 678         (declare (vogon x))
 679         (list
 680          (let (x)
 681            (ct
 682             (assoc
 683              'vogon-key
 684              (third (multiple-value-list (variable-information 'x lexenv))))))
 685          (ct
 686           (assoc
 687            'vogon-key
 688            (third (multiple-value-list (variable-information 'x lexenv))))))))
 689   (nil (vogon-key . vogon-value)))
 690
 691 (deftest define-declaration.variable.mask2
 692     (progn
 693       (define-declaration vogon-a (spec env)
 694         (declare (ignore env))
 695         (values :variable `((,(cadr spec) vogon-key a))))
 696       (define-declaration vogon-b (spec env)
 697         (declare (ignore env))
 698         (values :variable `((,(cadr spec) vogon-key b))))
 699       (let (x)
 700         (declare (vogon-a x))
 701         (let (x)
 702           (declare (vogon-b x)))
 703         (ct
 704          (assoc
 705           'vogon-key
 706           (third (multiple-value-list (variable-information 'x lexenv)))))))
 707   (vogon-key . a))
 708
 709 (deftest define-declaration.variable.specialmask
 710     (progn
 711       (define-declaration vogon (spec env)
 712         (declare (ignore env))
 713         (values :variable `((,(cadr spec) vogon-key vogon-value))))
 714       (locally
 715           (declare (vogon *foo*))
 716         (let (*foo*)
 717           (ct
 718            (assoc
 719             'vogon-key
 720             (third (multiple-value-list (variable-information '*foo* lexenv))))))))
 721   (vogon-key . vogon-value))
 722
 723
 724
 725 (deftest define-declaration.function
 726     (progn
 727       (define-declaration sad (spec env)
 728         (declare (ignore env))
 729         (values :function `((,(cadr spec) emotional-state sad))))
 730       (locally (declare (zaphod beblebrox))
 731         (locally (declare (sad robot))
 732           (ct
 733            (assoc 'emotional-state
 734                   (third-value (function-information
 735                                 'robot
 736                                 lexenv)))))))
 737   (emotional-state . sad))
 738
 739 (deftest define-declaration.function.lexical
 740     (progn
 741       (define-declaration sad (spec env)
 742         (declare (ignore env))
 743         (values :function `((,(cadr spec) emotional-state sad))))
 744       (flet ((robot nil))
 745         (locally (declare (sad robot))
 746           (ct
 747            (assoc 'emotional-state
 748                   (third-value (function-information
 749                                 'robot
 750                                 lexenv)))))))
 751   (emotional-state . sad))
 752
 753
 754 (deftest define-declaration.function.lexical2
 755     (progn
 756       (define-declaration sad (spec env)
 757         (declare (ignore env))
 758         (values :function `((,(cadr spec) emotional-state sad))))
 759       (labels ((robot nil))
 760         (declare (sad robot))
 761         (ct
 762          (assoc 'emotional-state
 763                 (third-value (function-information
 764                               'robot
 765                               lexenv))))))
 766   (emotional-state . sad))
 767
 768 (deftest define-declaration.function.mask
 769     (progn
 770       (define-declaration sad (spec env)
 771         (declare (ignore env))
 772         (values :function `((,(cadr spec) emotional-state sad))))
 773       (labels ((robot nil))
 774         (declare (sad robot))
 775         (labels ((robot nil))
 776           (ct
 777            (assoc 'emotional-state
 778                   (third-value (function-information
 779                                 'robot
 780                                 lexenv)))))))
 781   nil)
 782
 783
 784 (deftest define-declaration.function.mask2
 785     (progn
 786       (define-declaration sad (spec env)
 787         (declare (ignore env))
 788         (values :function `((,(cadr spec) emotional-state sad))))
 789       (locally
 790           (declare (sad robot))
 791         (labels ((robot nil))
 792           (ct
 793            (assoc 'emotional-state
 794                   (third-value (function-information
 795                                 'robot
 796                                 lexenv)))))))
 797   nil)
 798
 799 (deftest define-declaration.function2
 800     (progn
 801       (define-declaration happy (spec env)
 802         (declare (ignore env))
 803         (values :function `((,(cadr spec) emotional-state happy))))
 804       (locally (declare (zaphod beblebrox))
 805         (locally (declare (sad robot))
 806           (locally (declare (happy robot))
 807             (ct
 808              (assoc 'emotional-state
 809                     (third-value (function-information
 810                                   'robot
 811                                   lexenv))))))))
 812   (emotional-state . happy))
 813
 814 (deftest macroexpand-all.special-binding
 815     (let ((form '(macrolet ((v (x &environment env)
 816                              (sb-cltl2:variable-information x env)))
 817                   (let* ((x :foo)
 818                          (y (v x)))
 819                     (declare (special x))
 820                     (list y (v x))))))
 821       (list (eval form)
 822             (eval (sb-cltl2:macroexpand-all form))))
 823   ((:special :special) (:special :special)))
 824
 825 (deftest macroexpand-all.symbol-macro-shadowed
 826     (let ((form '(macrolet ((v (x &environment env)
 827                              (macroexpand x env)))
 828                   (symbol-macrolet ((x :bad))
 829                     (let* ((x :good)
 830                            (y (v x)))
 831                       y)))))
 832       (list (eval form)
 833             (eval (sb-cltl2:macroexpand-all form))))
 834   (:good :good))