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 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 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 88Form: ARG1 Context: EVAL 89Form: ARG2 Context: EVAL 90Form: 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 98Form: (CONS 1 2) Context: EVAL 99Form: 1 Context: EVAL 100Form: 2 Context: EVAL 101Form: (LIST 3 4 5) Context: EVAL 102Form: 3 Context: EVAL 103Form: 4 Context: EVAL 104Form: 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 112Form: (FOO) Context: EVAL 113Form: 'GLOBAL-FOO Context: EVAL 114Form: (BAR 1) Context: EVAL 115Form: '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 123Form: A Context: EVAL 124Form: B Context: EVAL 125Form: 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 133Form: (LIST A) Context: EVAL 134Form: A Context: EVAL 135Form: B Context: EVAL 136Form: 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 144Form: CATCH-TAG Context: EVAL 145Form: (LIST A) Context: EVAL 146Form: A Context: EVAL 147Form: B Context: EVAL 148Form: 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 166Form: (LIST X) Context: EVAL 167Form: X Context: EVAL; lexically bound 168Form: ''INNER Context: EVAL 169Form: X Context: EVAL 170Form: (FOO 1) Context: EVAL 171Form: '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 217Form: (LIST X Y) Context: EVAL 218Form: X Context: EVAL; lexically bound 219Form: Y Context: EVAL 220Form: (LIST X Y) Context: EVAL 221Form: X Context: EVAL; lexically bound 222Form: Y Context: EVAL 223Form: (FOO 1) Context: EVAL 224Form: 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 245Form: 2 Context: EVAL 246Form: (FLET ((FOO (X) 247 (LIST X Y)) 248 (BAR (X) 249 (LIST X Y))) 250 (FOO 1)) Context: EVAL 251Form: (LIST X Y) Context: EVAL 252Form: X Context: EVAL; lexically bound 253Form: Y Context: EVAL; lexically bound 254Form: (LIST X Y) Context: EVAL 255Form: X Context: EVAL; lexically bound 256Form: Y Context: EVAL; lexically bound 257Form: (FOO 1) Context: EVAL 258Form: 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 278Form: (BAR X) Context: EVAL 279Form: X Context: EVAL; lexically bound 280Form: (FOO X) Context: EVAL 281Form: X Context: EVAL; lexically bound 282Form: (FOO 1) Context: EVAL 283Form: 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 299Form: (FOO X) Context: EVAL 300Form: 'GLOBAL-FOO Context: EVAL 301Form: (FOO 1) Context: EVAL 302Form: 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 319Form: (FOO X) Context: EVAL 320Form: 'GLOBAL-FOO Context: EVAL 321Form: (FLET ((BAR (X) 322 (FOO X))) 323 (BAR 1)) Context: EVAL 324Form: (FOO X) Context: EVAL 325Form: X Context: EVAL; lexically bound 326Form: (BAR 1) Context: EVAL 327Form: 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 339Form: (BLOCK NIL 340 (LET () 341 (DECLARE (SPECIAL A B)) 342 (TAGBODY))) Context: EVAL 343Form: (LET () 344 (DECLARE (SPECIAL A B)) 345 (TAGBODY)) Context: EVAL 346Form: (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 360Form: (FOO A) Context: EVAL 361Form: 'GLOBAL-FOO Context: EVAL 362Form: B Context: EVAL; lexically bound; declared special 363Form: 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 381Form: (FOO A) Context: EVAL 382Form: 'GLOBAL-FOO Context: EVAL 383Form: B Context: EVAL; lexically bound; declared special 384Form: 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 404Form: (FOO A) Context: EVAL 405Form: 'GLOBAL-FOO Context: EVAL 406Form: B Context: EVAL; lexically bound; declared special 407Form: 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 430Form: (LET ((A 1)) 431 (FOO A) 432 B 433 C) Context: EVAL 434Form: 1 Context: EVAL 435Form: (FOO A) Context: EVAL 436Form: 'GLOBAL-FOO Context: EVAL 437Form: B Context: EVAL; lexically bound; declared special 438Form: 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 454Form: A Context: EVAL 455Form: (FOO A) Context: EVAL 456Form: '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 467Form: A Context: EVAL 468Form: (FOO A) Context: EVAL 469Form: 'GLOBAL-FOO Context: EVAL 470\(EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))"))) 471 472(test-util:with-test (:name (:walk multiple-value-bind)) 473 (assert (string=-modulo-tabspace 474 (with-output-to-string (*standard-output*) 475 (take-it-out-for-a-test-walk (multiple-value-bind (a b) 476 (foo a b) (list a b)))) 477 "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B)) Context: EVAL 478Form: (FOO A B) Context: EVAL 479Form: 'GLOBAL-FOO Context: EVAL 480Form: (LIST A B) Context: EVAL 481Form: A Context: EVAL; lexically bound 482Form: B Context: EVAL; lexically bound 483\(MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))"))) 484 485(test-util:with-test (:name (:walk multiple-value-bind special)) 486 (assert (string=-modulo-tabspace 487 (with-output-to-string (*standard-output*) 488 (take-it-out-for-a-test-walk (multiple-value-bind (a b) 489 (foo a b) 490 (declare (special a)) 491 (list a b)))) 492 "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B)) Context: EVAL 493Form: (FOO A B) Context: EVAL 494Form: 'GLOBAL-FOO Context: EVAL 495Form: (LIST A B) Context: EVAL 496Form: A Context: EVAL; lexically bound; declared special 497Form: B Context: EVAL; lexically bound 498\(MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))"))) 499 500(test-util:with-test (:name (:walk progn function)) 501 (assert (string=-modulo-tabspace 502 (with-output-to-string (*standard-output*) 503 (take-it-out-for-a-test-walk (progn (function foo)))) 504 "Form: (PROGN #'FOO) Context: EVAL 505Form: #'FOO Context: EVAL 506\(PROGN #'FOO)"))) 507 508(test-util:with-test (:name (:walk progn go)) 509 (assert (string=-modulo-tabspace 510 (with-output-to-string (*standard-output*) 511 (take-it-out-for-a-test-walk (progn a b (go a)))) 512 "Form: (PROGN A B (GO A)) Context: EVAL 513Form: A Context: EVAL 514Form: B Context: EVAL 515Form: (GO A) Context: EVAL 516\(PROGN A B (GO A))"))) 517 518(test-util:with-test (:name (:walk if 1)) 519 (assert (string=-modulo-tabspace 520 (with-output-to-string (*standard-output*) 521 (take-it-out-for-a-test-walk (if a b c))) 522 "Form: (IF A B C) Context: EVAL 523Form: A Context: EVAL 524Form: B Context: EVAL 525Form: C Context: EVAL 526\(IF A B C)"))) 527 528(test-util:with-test (:name (:walk if 2)) 529 (assert (string=-modulo-tabspace 530 (with-output-to-string (*standard-output*) 531 (take-it-out-for-a-test-walk (if a b))) 532 "Form: (IF A B) Context: EVAL 533Form: A Context: EVAL 534Form: B Context: EVAL 535Form: NIL Context: EVAL; bound: NIL 536\(IF A B)"))) 537 538(test-util:with-test (:name (:walk lambda)) 539 (assert (string=-modulo-tabspace 540 (with-output-to-string (*standard-output*) 541 (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))) 542 "Form: ((LAMBDA (A B) (LIST A B)) 1 2) Context: EVAL 543Form: (LAMBDA (A B) (LIST A B)) Context: EVAL 544Form: (LIST A B) Context: EVAL 545Form: A Context: EVAL; lexically bound 546Form: B Context: EVAL; lexically bound 547Form: 1 Context: EVAL 548Form: 2 Context: EVAL 549\((LAMBDA (A B) (LIST A B)) 1 2)"))) 550 551(test-util:with-test (:name (:walk lambda special)) 552 (assert (string=-modulo-tabspace 553 (with-output-to-string (*standard-output*) 554 (take-it-out-for-a-test-walk ((lambda (a b) 555 (declare (special a)) 556 (list a b)) 557 1 2))) 558 "Form: ((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2) Context: EVAL 559Form: (LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) Context: EVAL 560Form: (LIST A B) Context: EVAL 561Form: A Context: EVAL; lexically bound; declared special 562Form: B Context: EVAL; lexically bound 563Form: 1 Context: EVAL 564Form: 2 Context: EVAL 565\((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)"))) 566 567(test-util:with-test (:name (:walk let list)) 568 (assert (string=-modulo-tabspace 569 (with-output-to-string (*standard-output*) 570 (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) 571 (list a b c)))) 572 "Form: (LET ((A A) (B A) (C B)) 573 (LIST A B C)) Context: EVAL 574Form: A Context: EVAL 575Form: A Context: EVAL 576Form: B Context: EVAL 577Form: (LIST A B C) Context: EVAL 578Form: A Context: EVAL; lexically bound 579Form: B Context: EVAL; lexically bound 580Form: C Context: EVAL; lexically bound 581\(LET ((A A) (B A) (C B)) 582 (LIST A B C))"))) 583 584(test-util:with-test (:name (:walk let* list)) 585 (assert (string=-modulo-tabspace 586 (with-output-to-string (*standard-output*) 587 (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))) 588 "Form: (LET* ((A A) (B A) (C B)) 589 (LIST A B C)) Context: EVAL 590Form: A Context: EVAL 591Form: A Context: EVAL; lexically bound 592Form: B Context: EVAL; lexically bound 593Form: (LIST A B C) Context: EVAL 594Form: A Context: EVAL; lexically bound 595Form: B Context: EVAL; lexically bound 596Form: C Context: EVAL; lexically bound 597\(LET* ((A A) (B A) (C B)) 598 (LIST A B C))"))) 599 600(test-util:with-test (:name (:walk let special list)) 601 (assert (string=-modulo-tabspace 602 (with-output-to-string (*standard-output*) 603 (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) 604 (declare (special a b)) 605 (list a b c)))) 606 "Form: (LET ((A A) (B A) (C B)) 607 (DECLARE (SPECIAL A B)) 608 (LIST A B C)) Context: EVAL 609Form: A Context: EVAL 610Form: A Context: EVAL 611Form: B Context: EVAL 612Form: (LIST A B C) Context: EVAL 613Form: A Context: EVAL; lexically bound; declared special 614Form: B Context: EVAL; lexically bound; declared special 615Form: C Context: EVAL; lexically bound 616\(LET ((A A) (B A) (C B)) 617 (DECLARE (SPECIAL A B)) 618 (LIST A B C))"))) 619 620;;;; Bug in LET* walking! 621(test-util:with-test (:name (:walk let* special list :hairy-specials)) 622 (assert 623 (string=-modulo-tabspace 624 (with-output-to-string (*standard-output*) 625 (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) 626 (declare (special a b)) 627 (list a b c)))) 628 "Form: (LET* ((A A) (B A) (C B)) 629 (DECLARE (SPECIAL A B)) 630 (LIST A B C)) Context: EVAL 631 Form: A Context: EVAL 632 Form: A Context: EVAL; lexically bound; declared special 633 Form: B Context: EVAL; lexically bound; declared special 634 Form: (LIST A B C) Context: EVAL 635 Form: A Context: EVAL; lexically bound; declared special 636 Form: B Context: EVAL; lexically bound; declared special 637 Form: C Context: EVAL; lexically bound 638 (LET* ((A A) (B A) (C B)) 639 (DECLARE (SPECIAL A B)) 640 (LIST A B C))"))) 641 642(test-util:with-test (:name (:walk let special 5)) 643 (assert (string=-modulo-tabspace 644 (with-output-to-string (*standard-output*) 645 (take-it-out-for-a-test-walk (let ((a 1) (b 2)) 646 (foo bar) 647 (let () 648 (declare (special a)) 649 (foo a b))))) 650 "Form: (LET ((A 1) (B 2)) 651 (FOO BAR) 652 (LET () 653 (DECLARE (SPECIAL A)) 654 (FOO A B))) Context: EVAL 655Form: 1 Context: EVAL 656Form: 2 Context: EVAL 657Form: (FOO BAR) Context: EVAL 658Form: 'GLOBAL-FOO Context: EVAL 659Form: (LET () 660 (DECLARE (SPECIAL A)) 661 (FOO A B)) Context: EVAL 662Form: (FOO A B) Context: EVAL 663Form: 'GLOBAL-FOO Context: EVAL 664\(LET ((A 1) (B 2)) 665 (FOO BAR) 666 (LET () 667 (DECLARE (SPECIAL A)) 668 (FOO A B)))"))) 669 670(test-util:with-test (:name (:walk multiple-value-call)) 671 (assert (string=-modulo-tabspace 672 (with-output-to-string (*standard-output*) 673 (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))) 674 "Form: (MULTIPLE-VALUE-CALL #'FOO A B C) Context: EVAL 675Form: #'FOO Context: EVAL 676Form: A Context: EVAL 677Form: B Context: EVAL 678Form: C Context: EVAL 679\(MULTIPLE-VALUE-CALL #'FOO A B C)"))) 680 681(test-util:with-test (:name (:walk multiple-value-prog1)) 682 (assert (string=-modulo-tabspace 683 (with-output-to-string (*standard-output*) 684 (take-it-out-for-a-test-walk (multiple-value-prog1 a b c))) 685 "Form: (MULTIPLE-VALUE-PROG1 A B C) Context: EVAL 686Form: A Context: EVAL 687Form: B Context: EVAL 688Form: C Context: EVAL 689\(MULTIPLE-VALUE-PROG1 A B C)"))) 690 691(test-util:with-test (:name (:walk progn 2)) 692 (assert (string=-modulo-tabspace 693 (with-output-to-string (*standard-output*) 694 (take-it-out-for-a-test-walk (progn a b c))) 695 "Form: (PROGN A B C) Context: EVAL 696Form: A Context: EVAL 697Form: B Context: EVAL 698Form: C Context: EVAL 699\(PROGN A B C)"))) 700 701(test-util:with-test (:name (:walk progv)) 702 (assert (string=-modulo-tabspace 703 (with-output-to-string (*standard-output*) 704 (take-it-out-for-a-test-walk (progv vars vals a b c))) 705 "Form: (PROGV VARS VALS A B C) Context: EVAL 706Form: VARS Context: EVAL 707Form: VALS Context: EVAL 708Form: A Context: EVAL 709Form: B Context: EVAL 710Form: C Context: EVAL 711\(PROGV VARS VALS A B C)"))) 712 713(test-util:with-test (:name (:walk quote)) 714 (assert (string=-modulo-tabspace 715 (with-output-to-string (*standard-output*) 716 (take-it-out-for-a-test-walk (quote a))) 717 "Form: 'A Context: EVAL 718'A"))) 719 720(test-util:with-test (:name (:walk return-from)) 721 (assert (string=-modulo-tabspace 722 (with-output-to-string (*standard-output*) 723 (take-it-out-for-a-test-walk (return-from block-name a b c))) 724 "Form: (RETURN-FROM BLOCK-NAME A B C) Context: EVAL 725Form: A Context: EVAL 726Form: B Context: EVAL 727Form: C Context: EVAL 728\(RETURN-FROM BLOCK-NAME A B C)"))) 729 730 731(test-util:with-test (:name (:walk setq 1)) 732 (assert (string=-modulo-tabspace 733 (with-output-to-string (*standard-output*) 734 (take-it-out-for-a-test-walk (setq a 1))) 735 "Form: (SETQ A 1) Context: EVAL 736Form: A Context: SET 737Form: 1 Context: EVAL 738\(SETQ A 1)"))) 739(makunbound 'a) 740 741(test-util:with-test (:name (:walk setq 2)) 742 (assert (string=-modulo-tabspace 743 (with-output-to-string (*standard-output*) 744 (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))) 745 "Form: (SETQ A (FOO 1) B (BAR 2) C 3) Context: EVAL 746Form: (SETQ A (FOO 1)) Context: EVAL 747Form: A Context: SET 748Form: (FOO 1) Context: EVAL 749Form: 'GLOBAL-FOO Context: EVAL 750Form: (SETQ B (BAR 2)) Context: EVAL 751Form: B Context: SET 752Form: (BAR 2) Context: EVAL 753Form: 'GLOBAL-BAR Context: EVAL 754Form: (SETQ C 3) Context: EVAL 755Form: C Context: SET 756Form: 3 Context: EVAL 757\(SETQ A (FOO 1) B (BAR 2) C 3)"))) 758(makunbound 'a) 759(makunbound 'b) 760(makunbound 'c) 761 762(test-util:with-test (:name (:walk tagbody)) 763 (assert (string=-modulo-tabspace 764 (with-output-to-string (*standard-output*) 765 (take-it-out-for-a-test-walk (tagbody a b c (go a)))) 766 "Form: (TAGBODY A B C (GO A)) Context: EVAL 767Form: (GO A) Context: EVAL 768\(TAGBODY A B C (GO A))"))) 769 770(test-util:with-test (:name (:walk the)) 771 (assert (string=-modulo-tabspace 772 (with-output-to-string (*standard-output*) 773 (take-it-out-for-a-test-walk (the foo (foo-form a b c)))) 774 "Form: (THE FOO (FOO-FORM A B C)) Context: EVAL 775Form: (FOO-FORM A B C) Context: EVAL 776Form: A Context: EVAL 777Form: B Context: EVAL 778Form: C Context: EVAL 779\(THE FOO (FOO-FORM A B C))"))) 780 781(test-util:with-test (:name (:walk throw)) 782 (assert (string=-modulo-tabspace 783 (with-output-to-string (*standard-output*) 784 (take-it-out-for-a-test-walk (throw tag-form a))) 785 "Form: (THROW TAG-FORM A) Context: EVAL 786Form: TAG-FORM Context: EVAL 787Form: A Context: EVAL 788\(THROW TAG-FORM A)"))) 789 790(test-util:with-test (:name (:walk unwind-protect)) 791 (assert (string=-modulo-tabspace 792 (with-output-to-string (*standard-output*) 793 (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))) 794 "Form: (UNWIND-PROTECT (FOO A B) D E F) Context: EVAL 795Form: (FOO A B) Context: EVAL 796Form: 'GLOBAL-FOO Context: EVAL 797Form: D Context: EVAL 798Form: E Context: EVAL 799Form: F Context: EVAL 800\(UNWIND-PROTECT (FOO A B) D E F)"))) 801 802(defmacro flet-1 (a b) 803 (declare (ignore a b)) 804 ''outer) 805 806(defmacro labels-1 (a b) 807 (declare (ignore a b)) 808 ''outer) 809 810(test-util:with-test (:name (:walk flet defmacro)) 811 (assert (string=-modulo-tabspace 812 (with-output-to-string (*standard-output*) 813 (take-it-out-for-a-test-walk 814 (flet ((flet-1 (a b) () (flet-1 a b) (list a b))) 815 (flet-1 1 2) 816 (foo 1 2)))) 817 "Form: (FLET ((FLET-1 (A B) 818 NIL 819 (FLET-1 A B) 820 (LIST A B))) 821 (FLET-1 1 2) 822 (FOO 1 2)) Context: EVAL 823Form: NIL Context: EVAL; bound: NIL 824Form: (FLET-1 A B) Context: EVAL 825Form: 'OUTER Context: EVAL 826Form: (LIST A B) Context: EVAL 827Form: A Context: EVAL; lexically bound 828Form: B Context: EVAL; lexically bound 829Form: (FLET-1 1 2) Context: EVAL 830Form: 1 Context: EVAL 831Form: 2 Context: EVAL 832Form: (FOO 1 2) Context: EVAL 833Form: 'GLOBAL-FOO Context: EVAL 834\(FLET ((FLET-1 (A B) 835 NIL 836 (FLET-1 A B) 837 (LIST A B))) 838 (FLET-1 1 2) 839 (FOO 1 2))"))) 840 841(test-util:with-test (:name (:walk labels defmacro)) 842 (assert (string=-modulo-tabspace 843 (with-output-to-string (*standard-output*) 844 (take-it-out-for-a-test-walk 845 (labels ((label-1 (a b) () (label-1 a b)(list a b))) 846 (label-1 1 2) 847 (foo 1 2)))) 848 "Form: (LABELS ((LABEL-1 (A B) 849 NIL 850 (LABEL-1 A B) 851 (LIST A B))) 852 (LABEL-1 1 2) 853 (FOO 1 2)) Context: EVAL 854Form: NIL Context: EVAL; bound: NIL 855Form: (LABEL-1 A B) Context: EVAL 856Form: A Context: EVAL; lexically bound 857Form: B Context: EVAL; lexically bound 858Form: (LIST A B) Context: EVAL 859Form: A Context: EVAL; lexically bound 860Form: B Context: EVAL; lexically bound 861Form: (LABEL-1 1 2) Context: EVAL 862Form: 1 Context: EVAL 863Form: 2 Context: EVAL 864Form: (FOO 1 2) Context: EVAL 865Form: 'GLOBAL-FOO Context: EVAL 866\(LABELS ((LABEL-1 (A B) 867 NIL 868 (LABEL-1 A B) 869 (LIST A B))) 870 (LABEL-1 1 2) 871 (FOO 1 2))"))) 872 873(test-util:with-test (:name (:walk macrolet 1)) 874 (assert (string=-modulo-tabspace 875 (with-output-to-string (*standard-output*) 876 (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b))) 877 (macrolet-1 a b) 878 (foo 1 2)))) 879 "Form: (MACROLET ((MACROLET-1 (A B) 880 (LIST A B))) 881 (MACROLET-1 A B) 882 (FOO 1 2)) Context: EVAL 883Form: (LIST A B) Context: EVAL 884Form: A Context: EVAL; lexically bound 885Form: B Context: EVAL; lexically bound 886Form: (MACROLET-1 A B) Context: EVAL 887Form: (A B) Context: EVAL 888Form: B Context: EVAL 889Form: (FOO 1 2) Context: EVAL 890Form: 'GLOBAL-FOO Context: EVAL 891\(MACROLET ((MACROLET-1 (A B) 892 (LIST A B))) 893 (MACROLET-1 A B) 894 (FOO 1 2))"))) 895 896(test-util:with-test (:name (:walk macrolet 2)) 897 (assert (string=-modulo-tabspace 898 (with-output-to-string (*standard-output*) 899 (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a))) 900 (foo 1)))) 901 "Form: (MACROLET ((FOO (A) 902 `(INNER-FOO-EXPANDED ,A))) 903 (FOO 1)) Context: EVAL 904Form: `(INNER-FOO-EXPANDED ,A) Context: EVAL 905Form: (LIST 'INNER-FOO-EXPANDED A) Context: EVAL 906Form: 'INNER-FOO-EXPANDED Context: EVAL 907Form: A Context: EVAL; lexically bound 908Form: (FOO 1) Context: EVAL 909Form: (INNER-FOO-EXPANDED 1) Context: EVAL 910Form: 1 Context: EVAL 911\(MACROLET ((FOO (A) 912 `(INNER-FOO-EXPANDED ,A))) 913 (FOO 1))"))) 914 915(test-util:with-test (:name (:walk macrolet progn 1)) 916 (assert (string=-modulo-tabspace 917 (with-output-to-string (*standard-output*) 918 (take-it-out-for-a-test-walk (progn (bar 1) 919 (macrolet ((bar (a) 920 `(inner-bar-expanded ,a))) 921 (bar 2))))) 922 "Form: (PROGN 923 (BAR 1) 924 (MACROLET ((BAR (A) 925 `(INNER-BAR-EXPANDED ,A))) 926 (BAR 2))) Context: EVAL 927Form: (BAR 1) Context: EVAL 928Form: 'GLOBAL-BAR Context: EVAL 929Form: (MACROLET ((BAR (A) 930 `(INNER-BAR-EXPANDED ,A))) 931 (BAR 2)) Context: EVAL 932Form: `(INNER-BAR-EXPANDED ,A) Context: EVAL 933Form: (LIST 'INNER-BAR-EXPANDED A) Context: EVAL 934Form: 'INNER-BAR-EXPANDED Context: EVAL 935Form: A Context: EVAL; lexically bound 936Form: (BAR 2) Context: EVAL 937Form: (INNER-BAR-EXPANDED 2) Context: EVAL 938Form: 2 Context: EVAL 939\(PROGN 940 (BAR 1) 941 (MACROLET ((BAR (A) 942 `(INNER-BAR-EXPANDED ,A))) 943 (BAR 2)))"))) 944 945(test-util:with-test (:name (:walk macrolet progn 2)) 946 (assert (string=-modulo-tabspace 947 (with-output-to-string (*standard-output*) 948 (take-it-out-for-a-test-walk (progn (bar 1) 949 (macrolet ((bar (s) 950 (bar s) 951 `(inner-bar-expanded ,s))) 952 (bar 2))))) 953 "Form: (PROGN 954 (BAR 1) 955 (MACROLET ((BAR (S) 956 (BAR S) 957 `(INNER-BAR-EXPANDED ,S))) 958 (BAR 2))) Context: EVAL 959Form: (BAR 1) Context: EVAL 960Form: 'GLOBAL-BAR Context: EVAL 961Form: (MACROLET ((BAR (S) 962 (BAR S) 963 `(INNER-BAR-EXPANDED ,S))) 964 (BAR 2)) Context: EVAL 965Form: (BAR S) Context: EVAL 966Form: 'GLOBAL-BAR Context: EVAL 967Form: `(INNER-BAR-EXPANDED ,S) Context: EVAL 968Form: (LIST 'INNER-BAR-EXPANDED S) Context: EVAL 969Form: 'INNER-BAR-EXPANDED Context: EVAL 970Form: S Context: EVAL; lexically bound 971Form: (BAR 2) Context: EVAL 972Form: (INNER-BAR-EXPANDED 2) Context: EVAL 973Form: 2 Context: EVAL 974\(PROGN 975 (BAR 1) 976 (MACROLET ((BAR (S) 977 (BAR S) 978 `(INNER-BAR-EXPANDED ,S))) 979 (BAR 2)))"))) 980 981(test-util:with-test (:name (:walk cond)) 982 (assert (string=-modulo-tabspace 983 (with-output-to-string (*standard-output*) 984 (take-it-out-for-a-test-walk (cond (a b) 985 ((foo bar) a (foo a))))) 986 "Form: (COND (A B) ((FOO BAR) A (FOO A))) Context: EVAL 987Form: (IF A B (IF (FOO BAR) (PROGN A (FOO A)) NIL)) Context: EVAL 988Form: A Context: EVAL 989Form: B Context: EVAL 990Form: (IF (FOO BAR) (PROGN A (FOO A)) NIL) Context: EVAL 991Form: (FOO BAR) Context: EVAL 992Form: 'GLOBAL-FOO Context: EVAL 993Form: (PROGN A (FOO A)) Context: EVAL 994Form: A Context: EVAL 995Form: (FOO A) Context: EVAL 996Form: 'GLOBAL-FOO Context: EVAL 997Form: 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 1029Form: 'Y Context: EVAL 1030Form: (SETQ (X) 3) Context: EVAL 1031Form: (X) Context: SET 1032Form: 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 1048Form: A Context: EVAL 1049Form: A Context: EVAL; lexically bound; declared special 1050Form: B Context: EVAL; lexically bound 1051Form: C Context: EVAL; lexically bound 1052Form: (LIST A B C) Context: EVAL 1053Form: A Context: EVAL; lexically bound; declared special 1054Form: B Context: EVAL; lexically bound; declared special 1055Form: 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 1060;;;; more tests 1061 1062;;; Old PCL hung up on this. 1063(defmethod #:foo () 1064 (defun #:bar ())) 1065 1066