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 (variable-lexical-p x env))
  41                               (special (variable-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 ;;; A slightly more complex MACROLET case. In the body of the macro X
 157 ;;; should not be lexically bound. In the body of the macrolet form itself
 158 ;;; X should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it
 159 ;;; tries to macroexpand the call to FOO.
 160
 161 #+nil ; FIXME: broken under 0.pre7.15
 162 (multiple-value-bind (res cond)
 163     (ignore-errors
 164       (take-it-out-for-a-test-walk
 165        (let ((x 1))
 166          (macrolet ((foo () (list x) ''inner))
 167            x
 168            (foo)))))
 169   (assert (and (null res) cond)))
 170
 171 (assert (equal
 172          (with-output-to-string (*standard-output*)
 173            (take-it-out-for-a-test-walk
 174             (flet ((foo (x) (list x y))
 175                    (bar (x) (list x y)))
 176               (foo 1))))
 177          "Form: (FLET ((FOO (X)
 178                (LIST X Y))
 179              (BAR (X)
 180                (LIST X Y)))
 181         (FOO 1))   Context: EVAL
 182 Form: (LIST X Y)   Context: EVAL
 183 Form: X   Context: EVAL; lexically bound
 184 Form: Y   Context: EVAL
 185 Form: (LIST X Y)   Context: EVAL
 186 Form: X   Context: EVAL; lexically bound
 187 Form: Y   Context: EVAL
 188 Form: (FOO 1)   Context: EVAL
 189 Form: 1   Context: EVAL
 190 (FLET ((FOO (X)
 191          (LIST X Y))
 192        (BAR (X)
 193          (LIST X Y)))
 194   (FOO 1))"))
 195
 196 (assert (equal
 197          (with-output-to-string (*standard-output*)
 198            (take-it-out-for-a-test-walk
 199             (let ((y 2))
 200               (flet ((foo (x) (list x y))
 201                      (bar (x) (list x y)))
 202                 (foo 1)))))
 203          "Form: (LET ((Y 2))
 204         (FLET ((FOO (X)
 205                  (LIST X Y))
 206                (BAR (X)
 207                  (LIST X Y)))
 208           (FOO 1)))   Context: EVAL
 209 Form: 2   Context: EVAL
 210 Form: (FLET ((FOO (X)
 211                (LIST X Y))
 212              (BAR (X)
 213                (LIST X Y)))
 214         (FOO 1))   Context: EVAL
 215 Form: (LIST X Y)   Context: EVAL
 216 Form: X   Context: EVAL; lexically bound
 217 Form: Y   Context: EVAL; lexically bound
 218 Form: (LIST X Y)   Context: EVAL
 219 Form: X   Context: EVAL; lexically bound
 220 Form: Y   Context: EVAL; lexically bound
 221 Form: (FOO 1)   Context: EVAL
 222 Form: 1   Context: EVAL
 223 (LET ((Y 2))
 224   (FLET ((FOO (X)
 225            (LIST X Y))
 226          (BAR (X)
 227            (LIST X Y)))
 228     (FOO 1)))"))
 229
 230 (assert (equal
 231          (with-output-to-string (*standard-output*)
 232            (take-it-out-for-a-test-walk
 233             (labels ((foo (x) (bar x))
 234                      (bar (x) (foo x)))
 235               (foo 1))))
 236          "Form: (LABELS ((FOO (X)
 237                  (BAR X))
 238                (BAR (X)
 239                  (FOO X)))
 240         (FOO 1))   Context: EVAL
 241 Form: (BAR X)   Context: EVAL
 242 Form: X   Context: EVAL; lexically bound
 243 Form: (FOO X)   Context: EVAL
 244 Form: X   Context: EVAL; lexically bound
 245 Form: (FOO 1)   Context: EVAL
 246 Form: 1   Context: EVAL
 247 (LABELS ((FOO (X)
 248            (BAR X))
 249          (BAR (X)
 250            (FOO X)))
 251   (FOO 1))"))
 252
 253 (assert (equal
 254          (with-output-to-string (*standard-output*)
 255            (take-it-out-for-a-test-walk
 256             (flet ((foo (x) (foo x)))
 257               (foo 1))))
 258          "Form: (FLET ((FOO (X)
 259                (FOO X)))
 260         (FOO 1))   Context: EVAL
 261 Form: (FOO X)   Context: EVAL
 262 Form: 'GLOBAL-FOO   Context: EVAL
 263 Form: (FOO 1)   Context: EVAL
 264 Form: 1   Context: EVAL
 265 (FLET ((FOO (X)
 266          (FOO X)))
 267   (FOO 1))"))
 268
 269 (assert (equal
 270          (with-output-to-string (*standard-output*)
 271            (take-it-out-for-a-test-walk
 272             (flet ((foo (x) (foo x)))
 273               (flet ((bar (x) (foo x)))
 274                 (bar 1)))))
 275          "Form: (FLET ((FOO (X)
 276                (FOO X)))
 277         (FLET ((BAR (X)
 278                  (FOO X)))
 279           (BAR 1)))   Context: EVAL
 280 Form: (FOO X)   Context: EVAL
 281 Form: 'GLOBAL-FOO   Context: EVAL
 282 Form: (FLET ((BAR (X)
 283                (FOO X)))
 284         (BAR 1))   Context: EVAL
 285 Form: (FOO X)   Context: EVAL
 286 Form: X   Context: EVAL; lexically bound
 287 Form: (BAR 1)   Context: EVAL
 288 Form: 1   Context: EVAL
 289 (FLET ((FOO (X)
 290          (FOO X)))
 291   (FLET ((BAR (X)
 292            (FOO X)))
 293     (BAR 1)))"))
 294
 295 (assert (equal
 296          (with-output-to-string (*standard-output*)
 297            (take-it-out-for-a-test-walk (prog () (declare (special a b)))))
 298          "Form: (PROG () (DECLARE (SPECIAL A B)))   Context: EVAL
 299 Form: (BLOCK NIL
 300         (LET ()
 301           (DECLARE (SPECIAL A B))
 302           (TAGBODY)))   Context: EVAL
 303 Form: (LET ()
 304         (DECLARE (SPECIAL A B))
 305         (TAGBODY))   Context: EVAL
 306 Form: (TAGBODY)   Context: EVAL
 307 (PROG () (DECLARE (SPECIAL A B)))"))
 308
 309 (assert (equal
 310          (with-output-to-string (*standard-output*)
 311            (take-it-out-for-a-test-walk (let (a b c)
 312                                           (declare (special a b))
 313                                           (foo a) b c)))
 314          "Form: (LET (A B C)
 315         (DECLARE (SPECIAL A B))
 316         (FOO A)
 317         B
 318         C)   Context: EVAL
 319 Form: (FOO A)   Context: EVAL
 320 Form: 'GLOBAL-FOO   Context: EVAL
 321 Form: B   Context: EVAL; lexically bound
 322 Form: C   Context: EVAL; lexically bound
 323 (LET (A B C)
 324   (DECLARE (SPECIAL A B))
 325   (FOO A)
 326   B
 327   C)"))
 328
 329 (assert (equal
 330 (with-output-to-string (*standard-output*)
 331   (take-it-out-for-a-test-walk (let (a b c)
 332                                  (declare (special a) (special b))
 333                                  (foo a) b c)))
 334 "Form: (LET (A B C)
 335         (DECLARE (SPECIAL A) (SPECIAL B))
 336         (FOO A)
 337         B
 338         C)   Context: EVAL
 339 Form: (FOO A)   Context: EVAL
 340 Form: 'GLOBAL-FOO   Context: EVAL
 341 Form: B   Context: EVAL; lexically bound; declared special
 342 Form: C   Context: EVAL; lexically bound
 343 (LET (A B C)
 344   (DECLARE (SPECIAL A) (SPECIAL B))
 345   (FOO A)
 346   B
 347   C)"))
 348
 349 (assert (equal
 350 (with-output-to-string (*standard-output*)
 351   (take-it-out-for-a-test-walk (let (a b c)
 352                                  (declare (special a))
 353                                  (declare (special b))
 354                                  (foo a) b c)))
 355 "Form: (LET (A B C)
 356         (DECLARE (SPECIAL A))
 357         (DECLARE (SPECIAL B))
 358         (FOO A)
 359         B
 360         C)   Context: EVAL
 361 Form: (FOO A)   Context: EVAL
 362 Form: 'GLOBAL-FOO   Context: EVAL
 363 Form: B   Context: EVAL; lexically bound; declared special
 364 Form: C   Context: EVAL; lexically bound
 365 (LET (A B C)
 366   (DECLARE (SPECIAL A))
 367   (DECLARE (SPECIAL B))
 368   (FOO A)
 369   B
 370   C)"))
 371
 372 (assert (equal
 373          (with-output-to-string (*standard-output*)
 374            (take-it-out-for-a-test-walk (let (a b c)
 375                                           (declare (special a))
 376                                           (declare (special b))
 377                                           (let ((a 1))
 378                                             (foo a) b c))))
 379 "Form: (LET (A B C)
 380         (DECLARE (SPECIAL A))
 381         (DECLARE (SPECIAL B))
 382         (LET ((A 1))
 383           (FOO A)
 384           B
 385           C))   Context: EVAL
 386 Form: (LET ((A 1))
 387         (FOO A)
 388         B
 389         C)   Context: EVAL
 390 Form: 1   Context: EVAL
 391 Form: (FOO A)   Context: EVAL
 392 Form: 'GLOBAL-FOO   Context: EVAL
 393 Form: B   Context: EVAL; lexically bound; declared special
 394 Form: C   Context: EVAL; lexically bound
 395 (LET (A B C)
 396   (DECLARE (SPECIAL A))
 397   (DECLARE (SPECIAL B))
 398   (LET ((A 1))
 399     (FOO A)
 400     B
 401     C))"))
 402
 403 (assert (equal
 404          (with-output-to-string (*standard-output*)
 405            (take-it-out-for-a-test-walk (eval-when ()
 406                                           a
 407                                           (foo a))))
 408          "Form: (EVAL-WHEN NIL A (FOO A))   Context: EVAL
 409 Form: A   Context: EVAL
 410 Form: (FOO A)   Context: EVAL
 411 Form: 'GLOBAL-FOO   Context: EVAL
 412 (EVAL-WHEN NIL A (FOO A))"))
 413
 414 (assert (equal
 415          (with-output-to-string (*standard-output*)
 416            (take-it-out-for-a-test-walk
 417             (eval-when (:execute :compile-toplevel :load-toplevel)
 418                                           a
 419                                           (foo a))))
 420          "Form: (EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) 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 (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))"))
 425
 426 (assert (equal
 427          (with-output-to-string (*standard-output*)
 428            (take-it-out-for-a-test-walk (multiple-value-bind (a b)
 429                                             (foo a b) (list a b))))
 430          "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))   Context: EVAL
 431 Form: (FOO A B)   Context: EVAL
 432 Form: 'GLOBAL-FOO   Context: EVAL
 433 Form: (LIST A B)   Context: EVAL
 434 Form: A   Context: EVAL; lexically bound
 435 Form: B   Context: EVAL; lexically bound
 436 (MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))"))
 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)
 442                                           (declare (special a))
 443                                           (list a b))))
 444          "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))   Context: EVAL
 445 Form: (FOO A B)   Context: EVAL
 446 Form: 'GLOBAL-FOO   Context: EVAL
 447 Form: (LIST A B)   Context: EVAL
 448 Form: A   Context: EVAL; lexically bound
 449 Form: B   Context: EVAL; lexically bound
 450 (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))"))
 451
 452 (assert (equal
 453          (with-output-to-string (*standard-output*)
 454            (take-it-out-for-a-test-walk (progn (function foo))))
 455          "Form: (PROGN #'FOO)   Context: EVAL
 456 Form: #'FOO   Context: EVAL
 457 (PROGN #'FOO)"))
 458
 459 (assert (equal
 460          (with-output-to-string (*standard-output*)
 461            (take-it-out-for-a-test-walk (progn a b (go a))))
 462          "Form: (PROGN A B (GO A))   Context: EVAL
 463 Form: A   Context: EVAL
 464 Form: B   Context: EVAL
 465 Form: (GO A)   Context: EVAL
 466 (PROGN A B (GO A))"))
 467
 468 (assert (equal
 469          (with-output-to-string (*standard-output*)
 470            (take-it-out-for-a-test-walk (if a b c)))
 471          "Form: (IF A B C)   Context: EVAL
 472 Form: A   Context: EVAL
 473 Form: B   Context: EVAL
 474 Form: C   Context: EVAL
 475 (IF A B C)"))
 476
 477 (assert (equal
 478          (with-output-to-string (*standard-output*)
 479            (take-it-out-for-a-test-walk (if a b)))
 480          "Form: (IF A B)   Context: EVAL
 481 Form: A   Context: EVAL
 482 Form: B   Context: EVAL
 483 Form: NIL   Context: EVAL; bound: NIL
 484 (IF A B)"))
 485
 486 (assert (equal
 487          (with-output-to-string (*standard-output*)
 488            (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)))
 489          "Form: ((LAMBDA (A B) (LIST A B)) 1 2)   Context: EVAL
 490 Form: (LAMBDA (A B) (LIST A B))   Context: EVAL
 491 Form: (LIST A B)   Context: EVAL
 492 Form: A   Context: EVAL; lexically bound
 493 Form: B   Context: EVAL; lexically bound
 494 Form: 1   Context: EVAL
 495 Form: 2   Context: EVAL
 496 ((LAMBDA (A B) (LIST A B)) 1 2)"))
 497
 498 (assert (equal
 499          (with-output-to-string (*standard-output*)
 500            (take-it-out-for-a-test-walk ((lambda (a b)
 501                                            (declare (special a))
 502                                            (list a b))
 503                                          1 2)))
 504          "Form: ((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)   Context: EVAL
 505 Form: (LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B))   Context: EVAL
 506 Form: (LIST A B)   Context: EVAL
 507 Form: A   Context: EVAL; lexically bound; declared special
 508 Form: B   Context: EVAL; lexically bound
 509 Form: 1   Context: EVAL
 510 Form: 2   Context: EVAL
 511 ((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)"))
 512
 513 (assert (equal
 514          (with-output-to-string (*standard-output*)
 515            (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
 516                                           (list a b c))))
 517          "Form: (LET ((A A) (B A) (C B))
 518         (LIST A B C))   Context: EVAL
 519 Form: A   Context: EVAL
 520 Form: A   Context: EVAL
 521 Form: B   Context: EVAL
 522 Form: (LIST A B C)   Context: EVAL
 523 Form: A   Context: EVAL; lexically bound
 524 Form: B   Context: EVAL; lexically bound
 525 Form: C   Context: EVAL; lexically bound
 526 (LET ((A A) (B A) (C B))
 527   (LIST A B C))"))
 528
 529 (assert (equal
 530          (with-output-to-string (*standard-output*)
 531            (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))))
 532          "Form: (LET* ((A A) (B A) (C B))
 533         (LIST A B C))   Context: EVAL
 534 Form: A   Context: EVAL
 535 Form: A   Context: EVAL; lexically bound
 536 Form: B   Context: EVAL; lexically bound
 537 Form: (LIST A B C)   Context: EVAL
 538 Form: A   Context: EVAL; lexically bound
 539 Form: B   Context: EVAL; lexically bound
 540 Form: C   Context: EVAL; lexically bound
 541 (LET* ((A A) (B A) (C B))
 542   (LIST A B C))"))
 543
 544 (assert (equal
 545          (with-output-to-string (*standard-output*)
 546            (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
 547                                           (declare (special a b))
 548                                           (list a b c))))
 549          "Form: (LET ((A A) (B A) (C B))
 550         (DECLARE (SPECIAL A B))
 551         (LIST A B C))   Context: EVAL
 552 Form: A   Context: EVAL
 553 Form: A   Context: EVAL
 554 Form: B   Context: EVAL
 555 Form: (LIST A B C)   Context: EVAL
 556 Form: A   Context: EVAL; lexically bound; declared special
 557 Form: B   Context: EVAL; lexically bound
 558 Form: C   Context: EVAL; lexically bound
 559 (LET ((A A) (B A) (C B))
 560   (DECLARE (SPECIAL A B))
 561   (LIST A B C))"))
 562
 563 (assert (equal
 564          (with-output-to-string (*standard-output*)
 565            (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
 566                                           (declare (special a b))
 567                                           (list a b c))))
 568          "Form: (LET* ((A A) (B A) (C B))
 569         (DECLARE (SPECIAL A B))
 570         (LIST A B C))   Context: EVAL
 571 Form: A   Context: EVAL
 572 Form: A   Context: EVAL; lexically bound
 573 Form: B   Context: EVAL; lexically bound
 574 Form: (LIST A B C)   Context: EVAL
 575 Form: A   Context: EVAL; lexically bound; declared special
 576 Form: B   Context: EVAL; lexically bound
 577 Form: C   Context: EVAL; lexically bound
 578 (LET* ((A A) (B A) (C B))
 579   (DECLARE (SPECIAL A B))
 580   (LIST A B C))"))
 581
 582 (assert (equal
 583          (with-output-to-string (*standard-output*)
 584            (take-it-out-for-a-test-walk (let ((a 1) (b 2))
 585                                           (foo bar)
 586                                           (let ()
 587                                             (declare (special a))
 588                                             (foo a b)))))
 589          "Form: (LET ((A 1) (B 2))
 590         (FOO BAR)
 591         (LET ()
 592           (DECLARE (SPECIAL A))
 593           (FOO A B)))   Context: EVAL
 594 Form: 1   Context: EVAL
 595 Form: 2   Context: EVAL
 596 Form: (FOO BAR)   Context: EVAL
 597 Form: 'GLOBAL-FOO   Context: EVAL
 598 Form: (LET ()
 599         (DECLARE (SPECIAL A))
 600         (FOO A B))   Context: EVAL
 601 Form: (FOO A B)   Context: EVAL
 602 Form: 'GLOBAL-FOO   Context: EVAL
 603 (LET ((A 1) (B 2))
 604   (FOO BAR)
 605   (LET ()
 606     (DECLARE (SPECIAL A))
 607     (FOO A B)))"))
 608
 609 (assert (equal
 610          (with-output-to-string (*standard-output*)
 611            (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)))
 612          "Form: (MULTIPLE-VALUE-CALL #'FOO A B C)   Context: EVAL
 613 Form: #'FOO   Context: EVAL
 614 Form: A   Context: EVAL
 615 Form: B   Context: EVAL
 616 Form: C   Context: EVAL
 617 (MULTIPLE-VALUE-CALL #'FOO A B C)"))
 618
 619 (assert (equal
 620          (with-output-to-string (*standard-output*)
 621            (take-it-out-for-a-test-walk (multiple-value-prog1 a b c)))
 622          "Form: (MULTIPLE-VALUE-PROG1 A B C)   Context: EVAL
 623 Form: A   Context: EVAL
 624 Form: B   Context: EVAL
 625 Form: C   Context: EVAL
 626 (MULTIPLE-VALUE-PROG1 A B C)"))
 627
 628 (assert (equal
 629          (with-output-to-string (*standard-output*)
 630            (take-it-out-for-a-test-walk (progn a b c)))
 631          "Form: (PROGN A B C)   Context: EVAL
 632 Form: A   Context: EVAL
 633 Form: B   Context: EVAL
 634 Form: C   Context: EVAL
 635 (PROGN A B C)"))
 636
 637 (assert (equal
 638          (with-output-to-string (*standard-output*)
 639            (take-it-out-for-a-test-walk (progv vars vals a b c)))
 640          "Form: (PROGV VARS VALS A B C)   Context: EVAL
 641 Form: VARS   Context: EVAL
 642 Form: VALS   Context: EVAL
 643 Form: A   Context: EVAL
 644 Form: B   Context: EVAL
 645 Form: C   Context: EVAL
 646 (PROGV VARS VALS A B C)"))
 647
 648 (assert (equal
 649          (with-output-to-string (*standard-output*)
 650            (take-it-out-for-a-test-walk (quote a)))
 651          "Form: 'A   Context: EVAL
 652 'A"))
 653
 654 (assert (equal
 655          (with-output-to-string (*standard-output*)
 656            (take-it-out-for-a-test-walk (return-from block-name a b c)))
 657          "Form: (RETURN-FROM BLOCK-NAME A B C)   Context: EVAL
 658 Form: A   Context: EVAL
 659 Form: B   Context: EVAL
 660 Form: C   Context: EVAL
 661 (RETURN-FROM BLOCK-NAME A B C)"))
 662
 663 (assert (equal
 664          (with-output-to-string (*standard-output*)
 665            (take-it-out-for-a-test-walk (setq a 1)))
 666          "Form: (SETQ A 1)   Context: EVAL
 667 Form: A   Context: SET
 668 Form: 1   Context: EVAL
 669 (SETQ A 1)"))
 670 (makunbound 'a)
 671
 672 (assert (equal
 673          (with-output-to-string (*standard-output*)
 674            (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)))
 675          "Form: (SETQ A (FOO 1) B (BAR 2) C 3)   Context: EVAL
 676 Form: (SETQ A (FOO 1))   Context: EVAL
 677 Form: A   Context: SET
 678 Form: (FOO 1)   Context: EVAL
 679 Form: 'GLOBAL-FOO   Context: EVAL
 680 Form: (SETQ B (BAR 2))   Context: EVAL
 681 Form: B   Context: SET
 682 Form: (BAR 2)   Context: EVAL
 683 Form: 'GLOBAL-BAR   Context: EVAL
 684 Form: (SETQ C 3)   Context: EVAL
 685 Form: C   Context: SET
 686 Form: 3   Context: EVAL
 687 (SETQ A (FOO 1) B (BAR 2) C 3)"))
 688 (makunbound 'a)
 689 (makunbound 'b)
 690 (makunbound 'c)
 691
 692 (assert (equal
 693          (with-output-to-string (*standard-output*)
 694            (take-it-out-for-a-test-walk (tagbody a b c (go a))))
 695          "Form: (TAGBODY A B C (GO A))   Context: EVAL
 696 Form: A   Context: QUOTE
 697 Form: B   Context: QUOTE
 698 Form: C   Context: QUOTE
 699 Form: (GO A)   Context: EVAL
 700 (TAGBODY A B C (GO A))"))
 701
 702 (assert (equal
 703          (with-output-to-string (*standard-output*)
 704            (take-it-out-for-a-test-walk (the foo (foo-form a b c))))
 705          "Form: (THE FOO (FOO-FORM A B C))   Context: EVAL
 706 Form: (FOO-FORM A B C)   Context: EVAL
 707 Form: A   Context: EVAL
 708 Form: B   Context: EVAL
 709 Form: C   Context: EVAL
 710 (THE FOO (FOO-FORM A B C))"))
 711
 712 (assert (equal
 713          (with-output-to-string (*standard-output*)
 714            (take-it-out-for-a-test-walk (throw tag-form a)))
 715          "Form: (THROW TAG-FORM A)   Context: EVAL
 716 Form: TAG-FORM   Context: EVAL
 717 Form: A   Context: EVAL
 718 (THROW TAG-FORM A)"))
 719
 720 (assert (equal
 721          (with-output-to-string (*standard-output*)
 722            (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)))
 723          "Form: (UNWIND-PROTECT (FOO A B) D E F)   Context: EVAL
 724 Form: (FOO A B)   Context: EVAL
 725 Form: 'GLOBAL-FOO   Context: EVAL
 726 Form: D   Context: EVAL
 727 Form: E   Context: EVAL
 728 Form: F   Context: EVAL
 729 (UNWIND-PROTECT (FOO A B) D E F)"))
 730
 731 (defmacro flet-1 (a b)
 732   (declare (ignore a b))
 733   ''outer)
 734
 735 (defmacro labels-1 (a b)
 736   (declare (ignore a b))
 737   ''outer)
 738
 739 (assert (equal
 740          (with-output-to-string (*standard-output*)
 741            (take-it-out-for-a-test-walk
 742             (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
 743               (flet-1 1 2)
 744               (foo 1 2))))
 745          "Form: (FLET ((FLET-1 (A B)
 746                NIL
 747                (FLET-1 A B)
 748                (LIST A B)))
 749         (FLET-1 1 2)
 750         (FOO 1 2))   Context: EVAL
 751 Form: NIL   Context: EVAL; bound: NIL
 752 Form: (FLET-1 A B)   Context: EVAL
 753 Form: 'OUTER   Context: EVAL
 754 Form: (LIST A B)   Context: EVAL
 755 Form: A   Context: EVAL; lexically bound
 756 Form: B   Context: EVAL; lexically bound
 757 Form: (FLET-1 1 2)   Context: EVAL
 758 Form: 1   Context: EVAL
 759 Form: 2   Context: EVAL
 760 Form: (FOO 1 2)   Context: EVAL
 761 Form: 'GLOBAL-FOO   Context: EVAL
 762 (FLET ((FLET-1 (A B)
 763          NIL
 764          (FLET-1 A B)
 765          (LIST A B)))
 766   (FLET-1 1 2)
 767   (FOO 1 2))"))
 768
 769 (assert (equal
 770          (with-output-to-string (*standard-output*)
 771            (take-it-out-for-a-test-walk
 772             (labels ((label-1 (a b) () (label-1 a b)(list a b)))
 773               (label-1 1 2)
 774               (foo 1 2))))
 775          "Form: (LABELS ((LABEL-1 (A B)
 776                  NIL
 777                  (LABEL-1 A B)
 778                  (LIST A B)))
 779         (LABEL-1 1 2)
 780         (FOO 1 2))   Context: EVAL
 781 Form: NIL   Context: EVAL; bound: NIL
 782 Form: (LABEL-1 A B)   Context: EVAL
 783 Form: A   Context: EVAL; lexically bound
 784 Form: B   Context: EVAL; lexically bound
 785 Form: (LIST A B)   Context: EVAL
 786 Form: A   Context: EVAL; lexically bound
 787 Form: B   Context: EVAL; lexically bound
 788 Form: (LABEL-1 1 2)   Context: EVAL
 789 Form: 1   Context: EVAL
 790 Form: 2   Context: EVAL
 791 Form: (FOO 1 2)   Context: EVAL
 792 Form: 'GLOBAL-FOO   Context: EVAL
 793 (LABELS ((LABEL-1 (A B)
 794            NIL
 795            (LABEL-1 A B)
 796            (LIST A B)))
 797   (LABEL-1 1 2)
 798   (FOO 1 2))"))
 799
 800 (assert (equal
 801          (with-output-to-string (*standard-output*)
 802            (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
 803                                           (macrolet-1 a b)
 804                                           (foo 1 2))))
 805          "Form: (MACROLET ((MACROLET-1 (A B)
 806                    (LIST A B)))
 807         (MACROLET-1 A B)
 808         (FOO 1 2))   Context: EVAL
 809 Form: (LIST A B)   Context: EVAL
 810 Form: A   Context: EVAL; lexically bound
 811 Form: B   Context: EVAL; lexically bound
 812 Form: (MACROLET-1 A B)   Context: EVAL
 813 Form: (A B)   Context: EVAL
 814 Form: B   Context: EVAL
 815 Form: (FOO 1 2)   Context: EVAL
 816 Form: 'GLOBAL-FOO   Context: EVAL
 817 (MACROLET ((MACROLET-1 (A B)
 818              (LIST A B)))
 819   (MACROLET-1 A B)
 820   (FOO 1 2))"))
 821
 822 (assert (equal
 823          (with-output-to-string (*standard-output*)
 824            (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
 825                                           (foo 1))))
 826          "Form: (MACROLET ((FOO (A)
 827                    `(INNER-FOO-EXPANDED ,A)))
 828         (FOO 1))   Context: EVAL
 829 Form: `(INNER-FOO-EXPANDED ,A)   Context: EVAL
 830 Form: 'INNER-FOO-EXPANDED   Context: EVAL
 831 Form: A   Context: EVAL; lexically bound
 832 Form: (FOO 1)   Context: EVAL
 833 Form: (INNER-FOO-EXPANDED 1)   Context: EVAL
 834 Form: 1   Context: EVAL
 835 (MACROLET ((FOO (A)
 836              `(INNER-FOO-EXPANDED ,A)))
 837   (FOO 1))"))
 838
 839 (assert (equal
 840          (with-output-to-string (*standard-output*)
 841            (take-it-out-for-a-test-walk (progn (bar 1)
 842                                                (macrolet ((bar (a)
 843                                                             `(inner-bar-expanded ,a)))
 844                                                  (bar 2)))))
 845          "Form: (PROGN
 846        (BAR 1)
 847        (MACROLET ((BAR (A)
 848                     `(INNER-BAR-EXPANDED ,A)))
 849          (BAR 2)))   Context: EVAL
 850 Form: (BAR 1)   Context: EVAL
 851 Form: 'GLOBAL-BAR   Context: EVAL
 852 Form: (MACROLET ((BAR (A)
 853                    `(INNER-BAR-EXPANDED ,A)))
 854         (BAR 2))   Context: EVAL
 855 Form: `(INNER-BAR-EXPANDED ,A)   Context: EVAL
 856 Form: 'INNER-BAR-EXPANDED   Context: EVAL
 857 Form: A   Context: EVAL; lexically bound
 858 Form: (BAR 2)   Context: EVAL
 859 Form: (INNER-BAR-EXPANDED 2)   Context: EVAL
 860 Form: 2   Context: EVAL
 861 (PROGN
 862  (BAR 1)
 863  (MACROLET ((BAR (A)
 864               `(INNER-BAR-EXPANDED ,A)))
 865    (BAR 2)))"))
 866
 867 (assert (equal
 868          (with-output-to-string (*standard-output*)
 869            (take-it-out-for-a-test-walk (progn (bar 1)
 870                                                (macrolet ((bar (s)
 871                                                             (bar s)
 872                                                             `(inner-bar-expanded ,s)))
 873                                                  (bar 2)))))
 874          "Form: (PROGN
 875        (BAR 1)
 876        (MACROLET ((BAR (S)
 877                     (BAR S)
 878                     `(INNER-BAR-EXPANDED ,S)))
 879          (BAR 2)))   Context: EVAL
 880 Form: (BAR 1)   Context: EVAL
 881 Form: 'GLOBAL-BAR   Context: EVAL
 882 Form: (MACROLET ((BAR (S)
 883                    (BAR S)
 884                    `(INNER-BAR-EXPANDED ,S)))
 885         (BAR 2))   Context: EVAL
 886 Form: (BAR S)   Context: EVAL
 887 Form: 'GLOBAL-BAR   Context: EVAL
 888 Form: `(INNER-BAR-EXPANDED ,S)   Context: EVAL
 889 Form: 'INNER-BAR-EXPANDED   Context: EVAL
 890 Form: S   Context: EVAL; lexically bound
 891 Form: (BAR 2)   Context: EVAL
 892 Form: (INNER-BAR-EXPANDED 2)   Context: EVAL
 893 Form: 2   Context: EVAL
 894 (PROGN
 895  (BAR 1)
 896  (MACROLET ((BAR (S)
 897               (BAR S)
 898               `(INNER-BAR-EXPANDED ,S)))
 899    (BAR 2)))"))
 900
 901 (assert (equal
 902          (with-output-to-string (*standard-output*)
 903            (take-it-out-for-a-test-walk (cond (a b)
 904                                               ((foo bar) a (foo a)))))
 905          "Form: (COND (A B) ((FOO BAR) A (FOO A)))   Context: EVAL
 906 Form: (IF A (PROGN B) (COND ((FOO BAR) A (FOO A))))   Context: EVAL
 907 Form: A   Context: EVAL
 908 Form: (PROGN B)   Context: EVAL
 909 Form: B   Context: EVAL
 910 Form: (COND ((FOO BAR) A (FOO A)))   Context: EVAL
 911 Form: (IF (FOO BAR) (PROGN A (FOO A)) (COND))   Context: EVAL
 912 Form: (FOO BAR)   Context: EVAL
 913 Form: 'GLOBAL-FOO   Context: EVAL
 914 Form: (PROGN A (FOO A))   Context: EVAL
 915 Form: A   Context: EVAL
 916 Form: (FOO A)   Context: EVAL
 917 Form: 'GLOBAL-FOO   Context: EVAL
 918 Form: (COND)   Context: EVAL
 919 Form: NIL   Context: EVAL; bound: NIL
 920 (COND (A B) ((FOO BAR) A (FOO A)))"))
 921
 922 (assert (equal
 923          (with-output-to-string (*standard-output*)
 924            (let ((the-lexical-variables ()))
 925              (walk-form '(let ((a 1) (b 2))
 926                           #'(lambda (x) (list a b x y)))
 927                         ()
 928                         #'(lambda (form context env)
 929                             (declare (ignore context))
 930                             (when (and (symbolp form)
 931                                        (variable-lexical-p form env))
 932                               (push form the-lexical-variables))
 933                             form))
 934              (or (and (= (length the-lexical-variables) 3)
 935                       (member 'a the-lexical-variables)
 936                       (member 'b the-lexical-variables)
 937                       (member 'x the-lexical-variables))
 938                  (error "Walker didn't do lexical variables of a closure properly."))))
 939          ""))
 940 \f
 941 (quit :unix-status 104)