tests/walk.impure.lisp

   1 ;;;; tests for the code walker
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5
   6 ;;;; This software is derived from software originally released by Xerox
   7 ;;;; Corporation. Copyright and release statements follow. Later modifications
   8 ;;;; to the software are in the public domain and are provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  10 ;;;; information.
  11
  12 ;;;; copyright information from original PCL sources:
  13 ;;;;
  14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  15 ;;;; All rights reserved.
  16 ;;;;
  17 ;;;; Use and copying of this software and preparation of derivative works based
  18 ;;;; upon this software are permitted. Any distribution of this software or
  19 ;;;; derivative works must comply with all applicable United States export
  20 ;;;; control laws.
  21 ;;;;
  22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  23 ;;;; warranty about the software, its performance or its conformity to any
  24 ;;;; specification.
  25
  26 (in-package :sb-walker)
  27 \f
  28 ;;;; stuff based on the tests at the end of the original CMU CL
  29 ;;;; pcl/walk.lisp file
  30
  31 (defmacro take-it-out-for-a-test-walk (form)
  32   `(take-it-out-for-a-test-walk-1 ',form))
  33
  34 (defun take-it-out-for-a-test-walk-1 (form)
  35   (let ((copy-of-form (copy-tree form))
  36         (result (walk-form form nil
  37                   (lambda (x y env)
  38                     (format t "~&Form: ~S ~3T Context: ~A" x y)
  39                     (when (symbolp x)
  40                       (let ((lexical (var-lexical-p x env))
  41                             (special (var-special-p x env)))
  42                         (when lexical
  43                           (format t ";~3T")
  44                           (format t "lexically bound"))
  45                         (when special
  46                           (format t ";~3T")
  47                           (format t "declared special"))
  48                         (when (boundp x)
  49                           (format t ";~3T")
  50                           (format t "bound: ~S " (eval x)))))
  51                     x))))
  52     (cond ((not (equal result copy-of-form))
  53            (format t "~%Warning: Result not EQUAL to copy of start."))
  54           ((not (eq result form))
  55            (format t "~%Warning: Result not EQ to copy of start.")))
  56     (pprint result)
  57     nil))
  58
  59 (defmacro foo (&rest ignore)
  60   (declare (ignore ignore))
  61   ''global-foo)
  62
  63 (defmacro bar (&rest ignore)
  64   (declare (ignore ignore))
  65   ''global-bar)
  66
  67 (assert (equal
  68          (with-output-to-string (*standard-output*)
  69            (take-it-out-for-a-test-walk (list arg1 arg2 arg3)))
  70          "Form: (LIST ARG1 ARG2 ARG3)   Context: EVAL
  71 Form: ARG1   Context: EVAL
  72 Form: ARG2   Context: EVAL
  73 Form: ARG3   Context: EVAL
  74 (LIST ARG1 ARG2 ARG3)"))
  75
  76 (assert (equal
  77          (with-output-to-string (*standard-output*)
  78            (take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))))
  79          "Form: (LIST (CONS 1 2) (LIST 3 4 5))   Context: EVAL
  80 Form: (CONS 1 2)   Context: EVAL
  81 Form: 1   Context: EVAL
  82 Form: 2   Context: EVAL
  83 Form: (LIST 3 4 5)   Context: EVAL
  84 Form: 3   Context: EVAL
  85 Form: 4   Context: EVAL
  86 Form: 5   Context: EVAL
  87 (LIST (CONS 1 2) (LIST 3 4 5))"))
  88
  89 (assert (equal
  90          (with-output-to-string (*standard-output*)
  91            (take-it-out-for-a-test-walk (progn (foo) (bar 1))))
  92          "Form: (PROGN (FOO) (BAR 1))   Context: EVAL
  93 Form: (FOO)   Context: EVAL
  94 Form: 'GLOBAL-FOO   Context: EVAL
  95 Form: (BAR 1)   Context: EVAL
  96 Form: 'GLOBAL-BAR   Context: EVAL
  97 (PROGN (FOO) (BAR 1))"))
  98
  99 (assert (equal
 100          (with-output-to-string (*standard-output*)
 101            (take-it-out-for-a-test-walk (block block-name a b c)))
 102          "Form: (BLOCK BLOCK-NAME A B C)   Context: EVAL
 103 Form: A   Context: EVAL
 104 Form: B   Context: EVAL
 105 Form: C   Context: EVAL
 106 (BLOCK BLOCK-NAME A B C)"))
 107
 108 (assert (equal
 109          (with-output-to-string (*standard-output*)
 110            (take-it-out-for-a-test-walk (block block-name (list a) b c)))
 111          "Form: (BLOCK BLOCK-NAME (LIST A) B C)   Context: EVAL
 112 Form: (LIST A)   Context: EVAL
 113 Form: A   Context: EVAL
 114 Form: B   Context: EVAL
 115 Form: C   Context: EVAL
 116 (BLOCK BLOCK-NAME (LIST A) B C)"))
 117
 118 (assert (equal
 119          (with-output-to-string (*standard-output*)
 120            (take-it-out-for-a-test-walk (catch catch-tag (list a) b c)))
 121          "Form: (CATCH CATCH-TAG (LIST A) B C)   Context: EVAL
 122 Form: CATCH-TAG   Context: EVAL
 123 Form: (LIST A)   Context: EVAL
 124 Form: A   Context: EVAL
 125 Form: B   Context: EVAL
 126 Form: C   Context: EVAL
 127 (CATCH CATCH-TAG (LIST A) B C)"))
 128
 129 ;;; This is a fairly simple MACROLET case. While walking the body of the
 130 ;;; macro, X should be lexically bound. In the body of the MACROLET form
 131 ;;; itself, X should not be bound.
 132 (assert (equal
 133          (with-output-to-string (*standard-output*)
 134            (take-it-out-for-a-test-walk
 135             (macrolet ((foo (x) (list x) ''inner))
 136               x
 137               (foo 1))))
 138          "Form: (MACROLET ((FOO (X)
 139                    (LIST X)
 140                    ''INNER))
 141         X
 142         (FOO 1))   Context: EVAL
 143 Form: (LIST X)   Context: EVAL
 144 Form: X   Context: EVAL; lexically bound
 145 Form: ''INNER   Context: EVAL
 146 Form: X   Context: EVAL
 147 Form: (FOO 1)   Context: EVAL
 148 Form: 'INNER   Context: EVAL
 149 (MACROLET ((FOO (X)
 150              (LIST X)
 151              ''INNER))
 152   X
 153   (FOO 1))"))
 154
 155
 156 ;;; The original PCL documentation for this test said
 157 ;;;   A slightly more complex MACROLET case. In the body of the macro
 158 ;;;   X should not be lexically bound. In the body of the macrolet
 159 ;;;   form itself X should be bound. Note that THIS CASE WILL CAUSE AN
 160 ;;;   ERROR when it tries to macroexpand the call to FOO.
 161 ;;;
 162 ;;; This test is commented out in SBCL because ANSI says, in the
 163 ;;; definition of the special operator MACROLET,
 164 ;;;    The macro-expansion functions defined by MACROLET are defined
 165 ;;;    in the lexical environment in which the MACROLET form appears.
 166 ;;;    Declarations and MACROLET and SYMBOL-MACROLET definitions affect
 167 ;;;    the local macro definitions in a MACROLET, but the consequences
 168 ;;;    are undefined if the local macro definitions reference any
 169 ;;;    local variable or function bindings that are visible in that
 170 ;;;    lexical environment.
 171 ;;; Since the behavior is undefined, anything we do conforms.:-|
 172 ;;; This is of course less than ideal; see bug 124.
 173 #+nil
 174 (multiple-value-bind (res cond)
 175     (ignore-errors
 176       (take-it-out-for-a-test-walk
 177        (let ((x 1))
 178          (macrolet ((foo () (list x) ''inner))
 179            x
 180            (foo)))))
 181   (assert (and (null res) cond)))
 182
 183 (assert (equal
 184          (with-output-to-string (*standard-output*)
 185            (take-it-out-for-a-test-walk
 186             (flet ((foo (x) (list x y))
 187                    (bar (x) (list x y)))
 188               (foo 1))))
 189          "Form: (FLET ((FOO (X)
 190                (LIST X Y))
 191              (BAR (X)
 192                (LIST X Y)))
 193         (FOO 1))   Context: EVAL
 194 Form: (LIST X Y)   Context: EVAL
 195 Form: X   Context: EVAL; lexically bound
 196 Form: Y   Context: EVAL
 197 Form: (LIST X Y)   Context: EVAL
 198 Form: X   Context: EVAL; lexically bound
 199 Form: Y   Context: EVAL
 200 Form: (FOO 1)   Context: EVAL
 201 Form: 1   Context: EVAL
 202 (FLET ((FOO (X)
 203          (LIST X Y))
 204        (BAR (X)
 205          (LIST X Y)))
 206   (FOO 1))"))
 207
 208 (assert (equal
 209          (with-output-to-string (*standard-output*)
 210            (take-it-out-for-a-test-walk
 211             (let ((y 2))
 212               (flet ((foo (x) (list x y))
 213                      (bar (x) (list x y)))
 214                 (foo 1)))))
 215          "Form: (LET ((Y 2))
 216         (FLET ((FOO (X)
 217                  (LIST X Y))
 218                (BAR (X)
 219                  (LIST X Y)))
 220           (FOO 1)))   Context: EVAL
 221 Form: 2   Context: EVAL
 222 Form: (FLET ((FOO (X)
 223                (LIST X Y))
 224              (BAR (X)
 225                (LIST X Y)))
 226         (FOO 1))   Context: EVAL
 227 Form: (LIST X Y)   Context: EVAL
 228 Form: X   Context: EVAL; lexically bound
 229 Form: Y   Context: EVAL; lexically bound
 230 Form: (LIST X Y)   Context: EVAL
 231 Form: X   Context: EVAL; lexically bound
 232 Form: Y   Context: EVAL; lexically bound
 233 Form: (FOO 1)   Context: EVAL
 234 Form: 1   Context: EVAL
 235 (LET ((Y 2))
 236   (FLET ((FOO (X)
 237            (LIST X Y))
 238          (BAR (X)
 239            (LIST X Y)))
 240     (FOO 1)))"))
 241
 242 (assert (equal
 243          (with-output-to-string (*standard-output*)
 244            (take-it-out-for-a-test-walk
 245             (labels ((foo (x) (bar x))
 246                      (bar (x) (foo x)))
 247               (foo 1))))
 248          "Form: (LABELS ((FOO (X)
 249                  (BAR X))
 250                (BAR (X)
 251                  (FOO X)))
 252         (FOO 1))   Context: EVAL
 253 Form: (BAR X)   Context: EVAL
 254 Form: X   Context: EVAL; lexically bound
 255 Form: (FOO X)   Context: EVAL
 256 Form: X   Context: EVAL; lexically bound
 257 Form: (FOO 1)   Context: EVAL
 258 Form: 1   Context: EVAL
 259 (LABELS ((FOO (X)
 260            (BAR X))
 261          (BAR (X)
 262            (FOO X)))
 263   (FOO 1))"))
 264
 265 (assert (equal
 266          (with-output-to-string (*standard-output*)
 267            (take-it-out-for-a-test-walk
 268             (flet ((foo (x) (foo x)))
 269               (foo 1))))
 270          "Form: (FLET ((FOO (X)
 271                (FOO X)))
 272         (FOO 1))   Context: EVAL
 273 Form: (FOO X)   Context: EVAL
 274 Form: 'GLOBAL-FOO   Context: EVAL
 275 Form: (FOO 1)   Context: EVAL
 276 Form: 1   Context: EVAL
 277 (FLET ((FOO (X)
 278          (FOO X)))
 279   (FOO 1))"))
 280
 281 (assert (equal
 282          (with-output-to-string (*standard-output*)
 283            (take-it-out-for-a-test-walk
 284             (flet ((foo (x) (foo x)))
 285               (flet ((bar (x) (foo x)))
 286                 (bar 1)))))
 287          "Form: (FLET ((FOO (X)
 288                (FOO X)))
 289         (FLET ((BAR (X)
 290                  (FOO X)))
 291           (BAR 1)))   Context: EVAL
 292 Form: (FOO X)   Context: EVAL
 293 Form: 'GLOBAL-FOO   Context: EVAL
 294 Form: (FLET ((BAR (X)
 295                (FOO X)))
 296         (BAR 1))   Context: EVAL
 297 Form: (FOO X)   Context: EVAL
 298 Form: X   Context: EVAL; lexically bound
 299 Form: (BAR 1)   Context: EVAL
 300 Form: 1   Context: EVAL
 301 (FLET ((FOO (X)
 302          (FOO X)))
 303   (FLET ((BAR (X)
 304            (FOO X)))
 305     (BAR 1)))"))
 306
 307 (assert (equal
 308          (with-output-to-string (*standard-output*)
 309            (take-it-out-for-a-test-walk (prog () (declare (special a b)))))
 310          "Form: (PROG () (DECLARE (SPECIAL A B)))   Context: EVAL
 311 Form: (BLOCK NIL
 312         (LET ()
 313           (DECLARE (SPECIAL A B))
 314           (TAGBODY)))   Context: EVAL
 315 Form: (LET ()
 316         (DECLARE (SPECIAL A B))
 317         (TAGBODY))   Context: EVAL
 318 Form: (TAGBODY)   Context: EVAL
 319 (PROG () (DECLARE (SPECIAL A B)))"))
 320
 321 (assert (equal
 322          (with-output-to-string (*standard-output*)
 323            (take-it-out-for-a-test-walk (let (a b c)
 324                                           (declare (special a b))
 325                                           (foo a) b c)))
 326          "Form: (LET (A B C)
 327         (DECLARE (SPECIAL A B))
 328         (FOO A)
 329         B
 330         C)   Context: EVAL
 331 Form: (FOO A)   Context: EVAL
 332 Form: 'GLOBAL-FOO   Context: EVAL
 333 Form: B   Context: EVAL; lexically bound
 334 Form: C   Context: EVAL; lexically bound
 335 (LET (A B C)
 336   (DECLARE (SPECIAL A B))
 337   (FOO A)
 338   B
 339   C)"))
 340
 341 (assert (equal
 342 (with-output-to-string (*standard-output*)
 343   (take-it-out-for-a-test-walk (let (a b c)
 344                                  (declare (special a) (special b))
 345                                  (foo a) b c)))
 346 "Form: (LET (A B C)
 347         (DECLARE (SPECIAL A) (SPECIAL B))
 348         (FOO A)
 349         B
 350         C)   Context: EVAL
 351 Form: (FOO A)   Context: EVAL
 352 Form: 'GLOBAL-FOO   Context: EVAL
 353 Form: B   Context: EVAL; lexically bound; declared special
 354 Form: C   Context: EVAL; lexically bound
 355 (LET (A B C)
 356   (DECLARE (SPECIAL A) (SPECIAL B))
 357   (FOO A)
 358   B
 359   C)"))
 360
 361 (assert (equal
 362 (with-output-to-string (*standard-output*)
 363   (take-it-out-for-a-test-walk (let (a b c)
 364                                  (declare (special a))
 365                                  (declare (special b))
 366                                  (foo a) b c)))
 367 "Form: (LET (A B C)
 368         (DECLARE (SPECIAL A))
 369         (DECLARE (SPECIAL B))
 370         (FOO A)
 371         B
 372         C)   Context: EVAL
 373 Form: (FOO A)   Context: EVAL
 374 Form: 'GLOBAL-FOO   Context: EVAL
 375 Form: B   Context: EVAL; lexically bound; declared special
 376 Form: C   Context: EVAL; lexically bound
 377 (LET (A B C)
 378   (DECLARE (SPECIAL A))
 379   (DECLARE (SPECIAL B))
 380   (FOO A)
 381   B
 382   C)"))
 383
 384 (assert (equal
 385          (with-output-to-string (*standard-output*)
 386            (take-it-out-for-a-test-walk (let (a b c)
 387                                           (declare (special a))
 388                                           (declare (special b))
 389                                           (let ((a 1))
 390                                             (foo a) b c))))
 391 "Form: (LET (A B C)
 392         (DECLARE (SPECIAL A))
 393         (DECLARE (SPECIAL B))
 394         (LET ((A 1))
 395           (FOO A)
 396           B
 397           C))   Context: EVAL
 398 Form: (LET ((A 1))
 399         (FOO A)
 400         B
 401         C)   Context: EVAL
 402 Form: 1   Context: EVAL
 403 Form: (FOO A)   Context: EVAL
 404 Form: 'GLOBAL-FOO   Context: EVAL
 405 Form: B   Context: EVAL; lexically bound; declared special
 406 Form: C   Context: EVAL; lexically bound
 407 (LET (A B C)
 408   (DECLARE (SPECIAL A))
 409   (DECLARE (SPECIAL B))
 410   (LET ((A 1))
 411     (FOO A)
 412     B
 413     C))"))
 414
 415 (assert (equal
 416          (with-output-to-string (*standard-output*)
 417            (take-it-out-for-a-test-walk (eval-when ()
 418                                           a
 419                                           (foo a))))
 420          "Form: (EVAL-WHEN NIL A (FOO A))   Context: EVAL
 421 Form: A   Context: EVAL
 422 Form: (FOO A)   Context: EVAL
 423 Form: 'GLOBAL-FOO   Context: EVAL
 424 (EVAL-WHEN NIL A (FOO A))"))
 425
 426 (assert (equal
 427          (with-output-to-string (*standard-output*)
 428            (take-it-out-for-a-test-walk
 429             (eval-when (:execute :compile-toplevel :load-toplevel)
 430                                           a
 431                                           (foo a))))
 432          "Form: (EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))   Context: EVAL
 433 Form: A   Context: EVAL
 434 Form: (FOO A)   Context: EVAL
 435 Form: 'GLOBAL-FOO   Context: EVAL
 436 (EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))"))
 437
 438 (assert (equal
 439          (with-output-to-string (*standard-output*)
 440            (take-it-out-for-a-test-walk (multiple-value-bind (a b)
 441                                             (foo a b) (list a b))))
 442          "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))   Context: EVAL
 443 Form: (FOO A B)   Context: EVAL
 444 Form: 'GLOBAL-FOO   Context: EVAL
 445 Form: (LIST A B)   Context: EVAL
 446 Form: A   Context: EVAL; lexically bound
 447 Form: B   Context: EVAL; lexically bound
 448 (MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))"))
 449
 450 (assert (equal
 451          (with-output-to-string (*standard-output*)
 452            (take-it-out-for-a-test-walk (multiple-value-bind (a b)
 453                                             (foo a b)
 454                                           (declare (special a))
 455                                           (list a b))))
 456          "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))   Context: EVAL
 457 Form: (FOO A B)   Context: EVAL
 458 Form: 'GLOBAL-FOO   Context: EVAL
 459 Form: (LIST A B)   Context: EVAL
 460 Form: A   Context: EVAL; lexically bound
 461 Form: B   Context: EVAL; lexically bound
 462 (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))"))
 463
 464 (assert (equal
 465          (with-output-to-string (*standard-output*)
 466            (take-it-out-for-a-test-walk (progn (function foo))))
 467          "Form: (PROGN #'FOO)   Context: EVAL
 468 Form: #'FOO   Context: EVAL
 469 (PROGN #'FOO)"))
 470
 471 (assert (equal
 472          (with-output-to-string (*standard-output*)
 473            (take-it-out-for-a-test-walk (progn a b (go a))))
 474          "Form: (PROGN A B (GO A))   Context: EVAL
 475 Form: A   Context: EVAL
 476 Form: B   Context: EVAL
 477 Form: (GO A)   Context: EVAL
 478 (PROGN A B (GO A))"))
 479
 480 (assert (equal
 481          (with-output-to-string (*standard-output*)
 482            (take-it-out-for-a-test-walk (if a b c)))
 483          "Form: (IF A B C)   Context: EVAL
 484 Form: A   Context: EVAL
 485 Form: B   Context: EVAL
 486 Form: C   Context: EVAL
 487 (IF A B C)"))
 488
 489 (assert (equal
 490          (with-output-to-string (*standard-output*)
 491            (take-it-out-for-a-test-walk (if a b)))
 492          "Form: (IF A B)   Context: EVAL
 493 Form: A   Context: EVAL
 494 Form: B   Context: EVAL
 495 Form: NIL   Context: EVAL; bound: NIL
 496 (IF A B)"))
 497
 498 (assert (equal
 499          (with-output-to-string (*standard-output*)
 500            (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)))
 501          "Form: ((LAMBDA (A B) (LIST A B)) 1 2)   Context: EVAL
 502 Form: (LAMBDA (A B) (LIST A B))   Context: EVAL
 503 Form: (LIST A B)   Context: EVAL
 504 Form: A   Context: EVAL; lexically bound
 505 Form: B   Context: EVAL; lexically bound
 506 Form: 1   Context: EVAL
 507 Form: 2   Context: EVAL
 508 ((LAMBDA (A B) (LIST A B)) 1 2)"))
 509
 510 (assert (equal
 511          (with-output-to-string (*standard-output*)
 512            (take-it-out-for-a-test-walk ((lambda (a b)
 513                                            (declare (special a))
 514                                            (list a b))
 515                                          1 2)))
 516          "Form: ((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)   Context: EVAL
 517 Form: (LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B))   Context: EVAL
 518 Form: (LIST A B)   Context: EVAL
 519 Form: A   Context: EVAL; lexically bound; declared special
 520 Form: B   Context: EVAL; lexically bound
 521 Form: 1   Context: EVAL
 522 Form: 2   Context: EVAL
 523 ((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)"))
 524
 525 (assert (equal
 526          (with-output-to-string (*standard-output*)
 527            (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
 528                                           (list a b c))))
 529          "Form: (LET ((A A) (B A) (C B))
 530         (LIST A B C))   Context: EVAL
 531 Form: A   Context: EVAL
 532 Form: A   Context: EVAL
 533 Form: B   Context: EVAL
 534 Form: (LIST A B C)   Context: EVAL
 535 Form: A   Context: EVAL; lexically bound
 536 Form: B   Context: EVAL; lexically bound
 537 Form: C   Context: EVAL; lexically bound
 538 (LET ((A A) (B A) (C B))
 539   (LIST A B C))"))
 540
 541 (assert (equal
 542          (with-output-to-string (*standard-output*)
 543            (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))))
 544          "Form: (LET* ((A A) (B A) (C B))
 545         (LIST A B C))   Context: EVAL
 546 Form: A   Context: EVAL
 547 Form: A   Context: EVAL; lexically bound
 548 Form: B   Context: EVAL; lexically bound
 549 Form: (LIST A B C)   Context: EVAL
 550 Form: A   Context: EVAL; lexically bound
 551 Form: B   Context: EVAL; lexically bound
 552 Form: C   Context: EVAL; lexically bound
 553 (LET* ((A A) (B A) (C B))
 554   (LIST A B C))"))
 555
 556 (assert (equal
 557          (with-output-to-string (*standard-output*)
 558            (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
 559                                           (declare (special a b))
 560                                           (list a b c))))
 561          "Form: (LET ((A A) (B A) (C B))
 562         (DECLARE (SPECIAL A B))
 563         (LIST A B C))   Context: EVAL
 564 Form: A   Context: EVAL
 565 Form: A   Context: EVAL
 566 Form: B   Context: EVAL
 567 Form: (LIST A B C)   Context: EVAL
 568 Form: A   Context: EVAL; lexically bound; declared special
 569 Form: B   Context: EVAL; lexically bound
 570 Form: C   Context: EVAL; lexically bound
 571 (LET ((A A) (B A) (C B))
 572   (DECLARE (SPECIAL A B))
 573   (LIST A B C))"))
 574
 575 (assert (equal
 576          (with-output-to-string (*standard-output*)
 577            (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
 578                                           (declare (special a b))
 579                                           (list a b c))))
 580          "Form: (LET* ((A A) (B A) (C B))
 581         (DECLARE (SPECIAL A B))
 582         (LIST A B C))   Context: EVAL
 583 Form: A   Context: EVAL
 584 Form: A   Context: EVAL; lexically bound
 585 Form: B   Context: EVAL; lexically bound
 586 Form: (LIST A B C)   Context: EVAL
 587 Form: A   Context: EVAL; lexically bound; declared special
 588 Form: B   Context: EVAL; lexically bound
 589 Form: C   Context: EVAL; lexically bound
 590 (LET* ((A A) (B A) (C B))
 591   (DECLARE (SPECIAL A B))
 592   (LIST A B C))"))
 593
 594 (assert (equal
 595          (with-output-to-string (*standard-output*)
 596            (take-it-out-for-a-test-walk (let ((a 1) (b 2))
 597                                           (foo bar)
 598                                           (let ()
 599                                             (declare (special a))
 600                                             (foo a b)))))
 601          "Form: (LET ((A 1) (B 2))
 602         (FOO BAR)
 603         (LET ()
 604           (DECLARE (SPECIAL A))
 605           (FOO A B)))   Context: EVAL
 606 Form: 1   Context: EVAL
 607 Form: 2   Context: EVAL
 608 Form: (FOO BAR)   Context: EVAL
 609 Form: 'GLOBAL-FOO   Context: EVAL
 610 Form: (LET ()
 611         (DECLARE (SPECIAL A))
 612         (FOO A B))   Context: EVAL
 613 Form: (FOO A B)   Context: EVAL
 614 Form: 'GLOBAL-FOO   Context: EVAL
 615 (LET ((A 1) (B 2))
 616   (FOO BAR)
 617   (LET ()
 618     (DECLARE (SPECIAL A))
 619     (FOO A B)))"))
 620
 621 (assert (equal
 622          (with-output-to-string (*standard-output*)
 623            (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)))
 624          "Form: (MULTIPLE-VALUE-CALL #'FOO A B C)   Context: EVAL
 625 Form: #'FOO   Context: EVAL
 626 Form: A   Context: EVAL
 627 Form: B   Context: EVAL
 628 Form: C   Context: EVAL
 629 (MULTIPLE-VALUE-CALL #'FOO A B C)"))
 630
 631 (assert (equal
 632          (with-output-to-string (*standard-output*)
 633            (take-it-out-for-a-test-walk (multiple-value-prog1 a b c)))
 634          "Form: (MULTIPLE-VALUE-PROG1 A B C)   Context: EVAL
 635 Form: A   Context: EVAL
 636 Form: B   Context: EVAL
 637 Form: C   Context: EVAL
 638 (MULTIPLE-VALUE-PROG1 A B C)"))
 639
 640 (assert (equal
 641          (with-output-to-string (*standard-output*)
 642            (take-it-out-for-a-test-walk (progn a b c)))
 643          "Form: (PROGN A B C)   Context: EVAL
 644 Form: A   Context: EVAL
 645 Form: B   Context: EVAL
 646 Form: C   Context: EVAL
 647 (PROGN A B C)"))
 648
 649 (assert (equal
 650          (with-output-to-string (*standard-output*)
 651            (take-it-out-for-a-test-walk (progv vars vals a b c)))
 652          "Form: (PROGV VARS VALS A B C)   Context: EVAL
 653 Form: VARS   Context: EVAL
 654 Form: VALS   Context: EVAL
 655 Form: A   Context: EVAL
 656 Form: B   Context: EVAL
 657 Form: C   Context: EVAL
 658 (PROGV VARS VALS A B C)"))
 659
 660 (assert (equal
 661          (with-output-to-string (*standard-output*)
 662            (take-it-out-for-a-test-walk (quote a)))
 663          "Form: 'A   Context: EVAL
 664 'A"))
 665
 666 (assert (equal
 667          (with-output-to-string (*standard-output*)
 668            (take-it-out-for-a-test-walk (return-from block-name a b c)))
 669          "Form: (RETURN-FROM BLOCK-NAME A B C)   Context: EVAL
 670 Form: A   Context: EVAL
 671 Form: B   Context: EVAL
 672 Form: C   Context: EVAL
 673 (RETURN-FROM BLOCK-NAME A B C)"))
 674
 675 (assert (equal
 676          (with-output-to-string (*standard-output*)
 677            (take-it-out-for-a-test-walk (setq a 1)))
 678          "Form: (SETQ A 1)   Context: EVAL
 679 Form: A   Context: SET
 680 Form: 1   Context: EVAL
 681 (SETQ A 1)"))
 682 (makunbound 'a)
 683
 684 (assert (equal
 685          (with-output-to-string (*standard-output*)
 686            (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)))
 687          "Form: (SETQ A (FOO 1) B (BAR 2) C 3)   Context: EVAL
 688 Form: (SETQ A (FOO 1))   Context: EVAL
 689 Form: A   Context: SET
 690 Form: (FOO 1)   Context: EVAL
 691 Form: 'GLOBAL-FOO   Context: EVAL
 692 Form: (SETQ B (BAR 2))   Context: EVAL
 693 Form: B   Context: SET
 694 Form: (BAR 2)   Context: EVAL
 695 Form: 'GLOBAL-BAR   Context: EVAL
 696 Form: (SETQ C 3)   Context: EVAL
 697 Form: C   Context: SET
 698 Form: 3   Context: EVAL
 699 (SETQ A (FOO 1) B (BAR 2) C 3)"))
 700 (makunbound 'a)
 701 (makunbound 'b)
 702 (makunbound 'c)
 703
 704 (assert (equal
 705          (with-output-to-string (*standard-output*)
 706            (take-it-out-for-a-test-walk (tagbody a b c (go a))))
 707          "Form: (TAGBODY A B C (GO A))   Context: EVAL
 708 Form: A   Context: QUOTE
 709 Form: B   Context: QUOTE
 710 Form: C   Context: QUOTE
 711 Form: (GO A)   Context: EVAL
 712 (TAGBODY A B C (GO A))"))
 713
 714 (assert (equal
 715          (with-output-to-string (*standard-output*)
 716            (take-it-out-for-a-test-walk (the foo (foo-form a b c))))
 717          "Form: (THE FOO (FOO-FORM A B C))   Context: EVAL
 718 Form: (FOO-FORM A B C)   Context: EVAL
 719 Form: A   Context: EVAL
 720 Form: B   Context: EVAL
 721 Form: C   Context: EVAL
 722 (THE FOO (FOO-FORM A B C))"))
 723
 724 (assert (equal
 725          (with-output-to-string (*standard-output*)
 726            (take-it-out-for-a-test-walk (throw tag-form a)))
 727          "Form: (THROW TAG-FORM A)   Context: EVAL
 728 Form: TAG-FORM   Context: EVAL
 729 Form: A   Context: EVAL
 730 (THROW TAG-FORM A)"))
 731
 732 (assert (equal
 733          (with-output-to-string (*standard-output*)
 734            (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)))
 735          "Form: (UNWIND-PROTECT (FOO A B) D E F)   Context: EVAL
 736 Form: (FOO A B)   Context: EVAL
 737 Form: 'GLOBAL-FOO   Context: EVAL
 738 Form: D   Context: EVAL
 739 Form: E   Context: EVAL
 740 Form: F   Context: EVAL
 741 (UNWIND-PROTECT (FOO A B) D E F)"))
 742
 743 (defmacro flet-1 (a b)
 744   (declare (ignore a b))
 745   ''outer)
 746
 747 (defmacro labels-1 (a b)
 748   (declare (ignore a b))
 749   ''outer)
 750
 751 (assert (equal
 752          (with-output-to-string (*standard-output*)
 753            (take-it-out-for-a-test-walk
 754             (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
 755               (flet-1 1 2)
 756               (foo 1 2))))
 757          "Form: (FLET ((FLET-1 (A B)
 758                NIL
 759                (FLET-1 A B)
 760                (LIST A B)))
 761         (FLET-1 1 2)
 762         (FOO 1 2))   Context: EVAL
 763 Form: NIL   Context: EVAL; bound: NIL
 764 Form: (FLET-1 A B)   Context: EVAL
 765 Form: 'OUTER   Context: EVAL
 766 Form: (LIST A B)   Context: EVAL
 767 Form: A   Context: EVAL; lexically bound
 768 Form: B   Context: EVAL; lexically bound
 769 Form: (FLET-1 1 2)   Context: EVAL
 770 Form: 1   Context: EVAL
 771 Form: 2   Context: EVAL
 772 Form: (FOO 1 2)   Context: EVAL
 773 Form: 'GLOBAL-FOO   Context: EVAL
 774 (FLET ((FLET-1 (A B)
 775          NIL
 776          (FLET-1 A B)
 777          (LIST A B)))
 778   (FLET-1 1 2)
 779   (FOO 1 2))"))
 780
 781 (assert (equal
 782          (with-output-to-string (*standard-output*)
 783            (take-it-out-for-a-test-walk
 784             (labels ((label-1 (a b) () (label-1 a b)(list a b)))
 785               (label-1 1 2)
 786               (foo 1 2))))
 787          "Form: (LABELS ((LABEL-1 (A B)
 788                  NIL
 789                  (LABEL-1 A B)
 790                  (LIST A B)))
 791         (LABEL-1 1 2)
 792         (FOO 1 2))   Context: EVAL
 793 Form: NIL   Context: EVAL; bound: NIL
 794 Form: (LABEL-1 A B)   Context: EVAL
 795 Form: A   Context: EVAL; lexically bound
 796 Form: B   Context: EVAL; lexically bound
 797 Form: (LIST A B)   Context: EVAL
 798 Form: A   Context: EVAL; lexically bound
 799 Form: B   Context: EVAL; lexically bound
 800 Form: (LABEL-1 1 2)   Context: EVAL
 801 Form: 1   Context: EVAL
 802 Form: 2   Context: EVAL
 803 Form: (FOO 1 2)   Context: EVAL
 804 Form: 'GLOBAL-FOO   Context: EVAL
 805 (LABELS ((LABEL-1 (A B)
 806            NIL
 807            (LABEL-1 A B)
 808            (LIST A B)))
 809   (LABEL-1 1 2)
 810   (FOO 1 2))"))
 811
 812 (assert (equal
 813          (with-output-to-string (*standard-output*)
 814            (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
 815                                           (macrolet-1 a b)
 816                                           (foo 1 2))))
 817          "Form: (MACROLET ((MACROLET-1 (A B)
 818                    (LIST A B)))
 819         (MACROLET-1 A B)
 820         (FOO 1 2))   Context: EVAL
 821 Form: (LIST A B)   Context: EVAL
 822 Form: A   Context: EVAL; lexically bound
 823 Form: B   Context: EVAL; lexically bound
 824 Form: (MACROLET-1 A B)   Context: EVAL
 825 Form: (A B)   Context: EVAL
 826 Form: B   Context: EVAL
 827 Form: (FOO 1 2)   Context: EVAL
 828 Form: 'GLOBAL-FOO   Context: EVAL
 829 (MACROLET ((MACROLET-1 (A B)
 830              (LIST A B)))
 831   (MACROLET-1 A B)
 832   (FOO 1 2))"))
 833
 834 (assert (equal
 835          (with-output-to-string (*standard-output*)
 836            (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
 837                                           (foo 1))))
 838          "Form: (MACROLET ((FOO (A)
 839                    `(INNER-FOO-EXPANDED ,A)))
 840         (FOO 1))   Context: EVAL
 841 Form: `(INNER-FOO-EXPANDED ,A)   Context: EVAL
 842 Form: 'INNER-FOO-EXPANDED   Context: EVAL
 843 Form: A   Context: EVAL; lexically bound
 844 Form: (FOO 1)   Context: EVAL
 845 Form: (INNER-FOO-EXPANDED 1)   Context: EVAL
 846 Form: 1   Context: EVAL
 847 (MACROLET ((FOO (A)
 848              `(INNER-FOO-EXPANDED ,A)))
 849   (FOO 1))"))
 850
 851 (assert (equal
 852          (with-output-to-string (*standard-output*)
 853            (take-it-out-for-a-test-walk (progn (bar 1)
 854                                                (macrolet ((bar (a)
 855                                                             `(inner-bar-expanded ,a)))
 856                                                  (bar 2)))))
 857          "Form: (PROGN
 858        (BAR 1)
 859        (MACROLET ((BAR (A)
 860                     `(INNER-BAR-EXPANDED ,A)))
 861          (BAR 2)))   Context: EVAL
 862 Form: (BAR 1)   Context: EVAL
 863 Form: 'GLOBAL-BAR   Context: EVAL
 864 Form: (MACROLET ((BAR (A)
 865                    `(INNER-BAR-EXPANDED ,A)))
 866         (BAR 2))   Context: EVAL
 867 Form: `(INNER-BAR-EXPANDED ,A)   Context: EVAL
 868 Form: 'INNER-BAR-EXPANDED   Context: EVAL
 869 Form: A   Context: EVAL; lexically bound
 870 Form: (BAR 2)   Context: EVAL
 871 Form: (INNER-BAR-EXPANDED 2)   Context: EVAL
 872 Form: 2   Context: EVAL
 873 (PROGN
 874  (BAR 1)
 875  (MACROLET ((BAR (A)
 876               `(INNER-BAR-EXPANDED ,A)))
 877    (BAR 2)))"))
 878
 879 (assert (equal
 880          (with-output-to-string (*standard-output*)
 881            (take-it-out-for-a-test-walk (progn (bar 1)
 882                                                (macrolet ((bar (s)
 883                                                             (bar s)
 884                                                             `(inner-bar-expanded ,s)))
 885                                                  (bar 2)))))
 886          "Form: (PROGN
 887        (BAR 1)
 888        (MACROLET ((BAR (S)
 889                     (BAR S)
 890                     `(INNER-BAR-EXPANDED ,S)))
 891          (BAR 2)))   Context: EVAL
 892 Form: (BAR 1)   Context: EVAL
 893 Form: 'GLOBAL-BAR   Context: EVAL
 894 Form: (MACROLET ((BAR (S)
 895                    (BAR S)
 896                    `(INNER-BAR-EXPANDED ,S)))
 897         (BAR 2))   Context: EVAL
 898 Form: (BAR S)   Context: EVAL
 899 Form: 'GLOBAL-BAR   Context: EVAL
 900 Form: `(INNER-BAR-EXPANDED ,S)   Context: EVAL
 901 Form: 'INNER-BAR-EXPANDED   Context: EVAL
 902 Form: S   Context: EVAL; lexically bound
 903 Form: (BAR 2)   Context: EVAL
 904 Form: (INNER-BAR-EXPANDED 2)   Context: EVAL
 905 Form: 2   Context: EVAL
 906 (PROGN
 907  (BAR 1)
 908  (MACROLET ((BAR (S)
 909               (BAR S)
 910               `(INNER-BAR-EXPANDED ,S)))
 911    (BAR 2)))"))
 912
 913 (assert (equal
 914          (with-output-to-string (*standard-output*)
 915            (take-it-out-for-a-test-walk (cond (a b)
 916                                               ((foo bar) a (foo a)))))
 917          "Form: (COND (A B) ((FOO BAR) A (FOO A)))   Context: EVAL
 918 Form: (IF A (PROGN B) (COND ((FOO BAR) A (FOO A))))   Context: EVAL
 919 Form: A   Context: EVAL
 920 Form: (PROGN B)   Context: EVAL
 921 Form: B   Context: EVAL
 922 Form: (COND ((FOO BAR) A (FOO A)))   Context: EVAL
 923 Form: (IF (FOO BAR) (PROGN A (FOO A)) (COND))   Context: EVAL
 924 Form: (FOO BAR)   Context: EVAL
 925 Form: 'GLOBAL-FOO   Context: EVAL
 926 Form: (PROGN A (FOO A))   Context: EVAL
 927 Form: A   Context: EVAL
 928 Form: (FOO A)   Context: EVAL
 929 Form: 'GLOBAL-FOO   Context: EVAL
 930 Form: (COND)   Context: EVAL
 931 Form: NIL   Context: EVAL; bound: NIL
 932 (COND (A B) ((FOO BAR) A (FOO A)))"))
 933
 934 (assert (equal
 935          (with-output-to-string (*standard-output*)
 936            (let ((the-lexical-variables ()))
 937              (walk-form '(let ((a 1) (b 2))
 938                           (lambda (x) (list a b x y)))
 939                         ()
 940                         (lambda (form context env)
 941                           (declare (ignore context))
 942                           (when (and (symbolp form)
 943                                      (var-lexical-p form env))
 944                             (push form the-lexical-variables))
 945                           form))
 946              (or (and (= (length the-lexical-variables) 3)
 947                       (member 'a the-lexical-variables)
 948                       (member 'b the-lexical-variables)
 949                       (member 'x the-lexical-variables))
 950                  (error "Walker didn't do lexical variables of a closure properly."))))
 951          ""))
 952 \f
 953 ;; old PCL hung up on it
 954 (defmethod #:foo ()
 955   (defun #:bar ()))
 956 \f
 957 (quit :unix-status 104)