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