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