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