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