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