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