1 ;;;; tests for the code walker
3 ;;;; This software is part of the SBCL system. See the README file for
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
12 ;;;; copyright information from original PCL sources:
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
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
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
26 (in-package :sb-walker
)
28 ;;;; utilities to support tests
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)
38 (defun string=-modulo-tabspace
(x y
)
39 (string= (string-modulo-tabspace x
)
40 (string-modulo-tabspace y
)))
42 ;;;; tests based on stuff at the end of the original CMU CL
43 ;;;; pcl/walk.lisp file
45 (defmacro take-it-out-for-a-test-walk
(form)
46 `(take-it-out-for-a-test-walk-1 ',form
))
48 (defun take-it-out-for-a-test-walk-1 (form)
49 (let ((copy-of-form (copy-tree form
))
50 (result (walk-form form nil
52 (format t
"~&Form: ~S ~3T Context: ~A" x y
)
54 (let ((lexical (var-lexical-p x env
))
55 (special (var-special-p x env
)))
58 (format t
"lexically bound"))
61 (format t
"declared special"))
64 (format t
"bound: ~S " (eval x
)))))
66 (cond ((not (equal result copy-of-form
))
67 (format t
"~%Warning: Result not EQUAL to copy of start."))
68 ((not (eq result form
))
69 (format t
"~%Warning: Result not EQ to copy of start.")))
73 (defmacro foo
(&rest ignore
)
74 (declare (ignore ignore
))
77 (defmacro bar
(&rest ignore
)
78 (declare (ignore ignore
))
81 (test-util:with-test
(:name
(:walk list
))
82 (assert (string=-modulo-tabspace
83 (with-output-to-string (*standard-output
*)
84 (take-it-out-for-a-test-walk (list arg1 arg2 arg3
)))
85 "Form: (LIST ARG1 ARG2 ARG3) Context: EVAL
86 Form: ARG1 Context: EVAL
87 Form: ARG2 Context: EVAL
88 Form: ARG3 Context: EVAL
89 \(LIST ARG1 ARG2 ARG3)")))
91 (test-util:with-test
(:name
(:walk list cons
))
92 (assert (string=-modulo-tabspace
93 (with-output-to-string (*standard-output
*)
94 (take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))))
95 "Form: (LIST (CONS 1 2) (LIST 3 4 5)) Context: EVAL
96 Form: (CONS 1 2) Context: EVAL
99 Form: (LIST 3 4 5) Context: EVAL
100 Form: 3 Context: EVAL
101 Form: 4 Context: EVAL
102 Form: 5 Context: EVAL
103 \(LIST (CONS 1 2) (LIST 3 4 5))")))
105 (test-util:with-test
(:name
(:walk progn
1))
106 (assert (string=-modulo-tabspace
107 (with-output-to-string (*standard-output
*)
108 (take-it-out-for-a-test-walk (progn (foo) (bar 1))))
109 "Form: (PROGN (FOO) (BAR 1)) Context: EVAL
110 Form: (FOO) Context: EVAL
111 Form: 'GLOBAL-FOO Context: EVAL
112 Form: (BAR 1) Context: EVAL
113 Form: 'GLOBAL-BAR Context: EVAL
114 \(PROGN (FOO) (BAR 1))")))
116 (test-util:with-test
(:name
(:walk block
))
117 (assert (string=-modulo-tabspace
118 (with-output-to-string (*standard-output
*)
119 (take-it-out-for-a-test-walk (block block-name a b c
)))
120 "Form: (BLOCK BLOCK-NAME A B C) Context: EVAL
121 Form: A Context: EVAL
122 Form: B Context: EVAL
123 Form: C Context: EVAL
124 \(BLOCK BLOCK-NAME A B C)")))
126 (test-util:with-test
(:name
(:walk block list
))
127 (assert (string=-modulo-tabspace
128 (with-output-to-string (*standard-output
*)
129 (take-it-out-for-a-test-walk (block block-name
(list a
) b c
)))
130 "Form: (BLOCK BLOCK-NAME (LIST A) B C) Context: EVAL
131 Form: (LIST A) Context: EVAL
132 Form: A Context: EVAL
133 Form: B Context: EVAL
134 Form: C Context: EVAL
135 \(BLOCK BLOCK-NAME (LIST A) B C)")))
137 (test-util:with-test
(:name
(:walk catch list
))
138 (assert (string=-modulo-tabspace
139 (with-output-to-string (*standard-output
*)
140 (take-it-out-for-a-test-walk (catch catch-tag
(list a
) b c
)))
141 "Form: (CATCH CATCH-TAG (LIST A) B C) Context: EVAL
142 Form: CATCH-TAG Context: EVAL
143 Form: (LIST A) Context: EVAL
144 Form: A Context: EVAL
145 Form: B Context: EVAL
146 Form: C Context: EVAL
147 \(CATCH CATCH-TAG (LIST A) B C)")))
149 ;;; This is a fairly simple MACROLET case. While walking the body of the
150 ;;; macro, X should be lexically bound. In the body of the MACROLET form
151 ;;; itself, X should not be bound.
152 (test-util:with-test
(:name
(:walk macrolet
))
153 (assert (string=-modulo-tabspace
154 (with-output-to-string (*standard-output
*)
155 (take-it-out-for-a-test-walk
156 (macrolet ((foo (x) (list x
) ''inner
))
159 "Form: (MACROLET ((FOO (X)
163 (FOO 1)) Context: EVAL
164 Form: (LIST X) Context: EVAL
165 Form: X Context: EVAL; lexically bound
166 Form: ''INNER Context: EVAL
167 Form: X Context: EVAL
168 Form: (FOO 1) Context: EVAL
169 Form: 'INNER Context: EVAL
176 ;;; The original PCL documentation for this test said
177 ;;; A slightly more complex MACROLET case. In the body of the macro
178 ;;; X should not be lexically bound. In the body of the macrolet
179 ;;; form itself X should be bound. Note that THIS CASE WILL CAUSE AN
180 ;;; ERROR when it tries to macroexpand the call to FOO.
182 ;;; This test is commented out in SBCL because ANSI says, in the
183 ;;; definition of the special operator MACROLET,
184 ;;; The macro-expansion functions defined by MACROLET are defined
185 ;;; in the lexical environment in which the MACROLET form appears.
186 ;;; Declarations and MACROLET and SYMBOL-MACROLET definitions affect
187 ;;; the local macro definitions in a MACROLET, but the consequences
188 ;;; are undefined if the local macro definitions reference any
189 ;;; local variable or function bindings that are visible in that
190 ;;; lexical environment.
191 ;;; Since the behavior is undefined, anything we do conforms.:-|
192 ;;; This is of course less than ideal; see bug 124.
194 (multiple-value-bind (res cond
)
196 (take-it-out-for-a-test-walk
198 (macrolet ((foo () (list x
) ''inner
))
201 (assert (and (null res
) cond
)))
203 (test-util:with-test
(:name
(:walk flet
1))
204 (assert (string=-modulo-tabspace
205 (with-output-to-string (*standard-output
*)
206 (take-it-out-for-a-test-walk
207 (flet ((foo (x) (list x y
))
208 (bar (x) (list x y
)))
210 "Form: (FLET ((FOO (X)
214 (FOO 1)) Context: EVAL
215 Form: (LIST X Y) Context: EVAL
216 Form: X Context: EVAL; lexically bound
217 Form: Y Context: EVAL
218 Form: (LIST X Y) Context: EVAL
219 Form: X Context: EVAL; lexically bound
220 Form: Y Context: EVAL
221 Form: (FOO 1) Context: EVAL
222 Form: 1 Context: EVAL
229 (test-util:with-test
(:name
(:walk let flet
))
230 (assert (string=-modulo-tabspace
231 (with-output-to-string (*standard-output
*)
232 (take-it-out-for-a-test-walk
234 (flet ((foo (x) (list x y
))
235 (bar (x) (list x y
)))
242 (FOO 1))) Context: EVAL
243 Form: 2 Context: EVAL
244 Form: (FLET ((FOO (X)
248 (FOO 1)) Context: EVAL
249 Form: (LIST X Y) Context: EVAL
250 Form: X Context: EVAL; lexically bound
251 Form: Y Context: EVAL; lexically bound
252 Form: (LIST X Y) Context: EVAL
253 Form: X Context: EVAL; lexically bound
254 Form: Y Context: EVAL; lexically bound
255 Form: (FOO 1) Context: EVAL
256 Form: 1 Context: EVAL
264 (test-util:with-test
(:name
(:walk labels
))
265 (assert (string=-modulo-tabspace
266 (with-output-to-string (*standard-output
*)
267 (take-it-out-for-a-test-walk
268 (labels ((foo (x) (bar x
))
271 "Form: (LABELS ((FOO (X)
275 (FOO 1)) Context: EVAL
276 Form: (BAR X) Context: EVAL
277 Form: X Context: EVAL; lexically bound
278 Form: (FOO X) Context: EVAL
279 Form: X Context: EVAL; lexically bound
280 Form: (FOO 1) Context: EVAL
281 Form: 1 Context: EVAL
288 (test-util:with-test
(:name
(:walk flet
2))
289 (assert (string=-modulo-tabspace
290 (with-output-to-string (*standard-output
*)
291 (take-it-out-for-a-test-walk
292 (flet ((foo (x) (foo x
)))
294 "Form: (FLET ((FOO (X)
296 (FOO 1)) Context: EVAL
297 Form: (FOO X) Context: EVAL
298 Form: 'GLOBAL-FOO Context: EVAL
299 Form: (FOO 1) Context: EVAL
300 Form: 1 Context: EVAL
305 (test-util:with-test
(:name
(:walk flet
3))
306 (assert (string=-modulo-tabspace
307 (with-output-to-string (*standard-output
*)
308 (take-it-out-for-a-test-walk
309 (flet ((foo (x) (foo x
)))
310 (flet ((bar (x) (foo x
)))
312 "Form: (FLET ((FOO (X)
316 (BAR 1))) Context: EVAL
317 Form: (FOO X) Context: EVAL
318 Form: 'GLOBAL-FOO Context: EVAL
319 Form: (FLET ((BAR (X)
321 (BAR 1)) Context: EVAL
322 Form: (FOO X) Context: EVAL
323 Form: X Context: EVAL; lexically bound
324 Form: (BAR 1) Context: EVAL
325 Form: 1 Context: EVAL
332 (test-util:with-test
(:name
(:walk progn special
))
333 (assert (string=-modulo-tabspace
334 (with-output-to-string (*standard-output
*)
335 (take-it-out-for-a-test-walk (prog () (declare (special a b
)))))
336 "Form: (PROG () (DECLARE (SPECIAL A B))) Context: EVAL
339 (DECLARE (SPECIAL A B))
340 (TAGBODY))) Context: EVAL
342 (DECLARE (SPECIAL A B))
343 (TAGBODY)) Context: EVAL
344 Form: (TAGBODY) Context: EVAL
345 \(PROG () (DECLARE (SPECIAL A B)))")))
347 (test-util:with-test
(:name
(:walk let special
1))
348 (assert (string=-modulo-tabspace
349 (with-output-to-string (*standard-output
*)
350 (take-it-out-for-a-test-walk (let (a b c
)
351 (declare (special a b
))
354 (DECLARE (SPECIAL A B))
358 Form: (FOO A) Context: EVAL
359 Form: 'GLOBAL-FOO Context: EVAL
360 Form: B Context: EVAL; lexically bound; declared special
361 Form: C Context: EVAL; lexically bound
363 (DECLARE (SPECIAL A B))
368 (test-util:with-test
(:name
(:walk let special
2))
369 (assert (string=-modulo-tabspace
370 (with-output-to-string (*standard-output
*)
371 (take-it-out-for-a-test-walk (let (a b c
)
372 (declare (special a
) (special b
))
375 (DECLARE (SPECIAL A) (SPECIAL B))
379 Form: (FOO A) Context: EVAL
380 Form: 'GLOBAL-FOO Context: EVAL
381 Form: B Context: EVAL; lexically bound; declared special
382 Form: C Context: EVAL; lexically bound
384 (DECLARE (SPECIAL A) (SPECIAL B))
389 (test-util:with-test
(:name
(:walk let special
3))
390 (assert (string=-modulo-tabspace
391 (with-output-to-string (*standard-output
*)
392 (take-it-out-for-a-test-walk (let (a b c
)
393 (declare (special a
))
394 (declare (special b
))
397 (DECLARE (SPECIAL A))
398 (DECLARE (SPECIAL B))
402 Form: (FOO A) Context: EVAL
403 Form: 'GLOBAL-FOO Context: EVAL
404 Form: B Context: EVAL; lexically bound; declared special
405 Form: C Context: EVAL; lexically bound
407 (DECLARE (SPECIAL A))
408 (DECLARE (SPECIAL B))
413 (test-util:with-test
(:name
(:walk let special
4))
414 (assert (string=-modulo-tabspace
415 (with-output-to-string (*standard-output
*)
416 (take-it-out-for-a-test-walk (let (a b c
)
417 (declare (special a
))
418 (declare (special b
))
422 (DECLARE (SPECIAL A))
423 (DECLARE (SPECIAL B))
432 Form: 1 Context: EVAL
433 Form: (FOO A) Context: EVAL
434 Form: 'GLOBAL-FOO Context: EVAL
435 Form: B Context: EVAL; lexically bound; declared special
436 Form: C Context: EVAL; lexically bound
438 (DECLARE (SPECIAL A))
439 (DECLARE (SPECIAL B))
445 (test-util:with-test
(:name
(:walk eval-when
1))
446 (assert (string=-modulo-tabspace
447 (with-output-to-string (*standard-output
*)
448 (take-it-out-for-a-test-walk (eval-when ()
451 "Form: (EVAL-WHEN NIL A (FOO A)) Context: EVAL
452 Form: A Context: EVAL
453 Form: (FOO A) Context: EVAL
454 Form: 'GLOBAL-FOO Context: EVAL
455 \(EVAL-WHEN NIL A (FOO A))")))
457 (test-util:with-test
(:name
(:walk eval-when
2))
458 (assert (string=-modulo-tabspace
459 (with-output-to-string (*standard-output
*)
460 (take-it-out-for-a-test-walk
461 (eval-when (:execute
:compile-toplevel
:load-toplevel
)
464 "Form: (EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A)) Context: EVAL
465 Form: A Context: EVAL
466 Form: (FOO A) Context: EVAL
467 Form: 'GLOBAL-FOO Context: EVAL
468 \(EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))")))
470 (test-util:with-test
(:name
(:walk multiple-value-bind
))
471 (assert (string=-modulo-tabspace
472 (with-output-to-string (*standard-output
*)
473 (take-it-out-for-a-test-walk (multiple-value-bind (a b
)
474 (foo a b
) (list a b
))))
475 "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B)) Context: EVAL
476 Form: (FOO A B) Context: EVAL
477 Form: 'GLOBAL-FOO Context: EVAL
478 Form: (LIST A B) Context: EVAL
479 Form: A Context: EVAL; lexically bound
480 Form: B Context: EVAL; lexically bound
481 \(MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))")))
483 (test-util:with-test
(:name
(:walk multiple-value-bind special
))
484 (assert (string=-modulo-tabspace
485 (with-output-to-string (*standard-output
*)
486 (take-it-out-for-a-test-walk (multiple-value-bind (a b
)
488 (declare (special a
))
490 "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B)) Context: EVAL
491 Form: (FOO A B) Context: EVAL
492 Form: 'GLOBAL-FOO Context: EVAL
493 Form: (LIST A B) Context: EVAL
494 Form: A Context: EVAL; lexically bound; declared special
495 Form: B Context: EVAL; lexically bound
496 \(MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))")))
498 (test-util:with-test
(:name
(:walk progn function
))
499 (assert (string=-modulo-tabspace
500 (with-output-to-string (*standard-output
*)
501 (take-it-out-for-a-test-walk (progn (function foo
))))
502 "Form: (PROGN #'FOO) Context: EVAL
503 Form: #'FOO Context: EVAL
506 (test-util:with-test
(:name
(:walk progn go
))
507 (assert (string=-modulo-tabspace
508 (with-output-to-string (*standard-output
*)
509 (take-it-out-for-a-test-walk (progn a b
(go a
))))
510 "Form: (PROGN A B (GO A)) Context: EVAL
511 Form: A Context: EVAL
512 Form: B Context: EVAL
513 Form: (GO A) Context: EVAL
514 \(PROGN A B (GO A))")))
516 (test-util:with-test
(:name
(:walk if
1))
517 (assert (string=-modulo-tabspace
518 (with-output-to-string (*standard-output
*)
519 (take-it-out-for-a-test-walk (if a b c
)))
520 "Form: (IF A B C) Context: EVAL
521 Form: A Context: EVAL
522 Form: B Context: EVAL
523 Form: C Context: EVAL
526 (test-util:with-test
(:name
(:walk if
2))
527 (assert (string=-modulo-tabspace
528 (with-output-to-string (*standard-output
*)
529 (take-it-out-for-a-test-walk (if a b
)))
530 "Form: (IF A B) Context: EVAL
531 Form: A Context: EVAL
532 Form: B Context: EVAL
533 Form: NIL Context: EVAL; bound: NIL
536 (test-util:with-test
(:name
(:walk lambda
))
537 (assert (string=-modulo-tabspace
538 (with-output-to-string (*standard-output
*)
539 (take-it-out-for-a-test-walk ((lambda (a b
) (list a b
)) 1 2)))
540 "Form: ((LAMBDA (A B) (LIST A B)) 1 2) Context: EVAL
541 Form: (LAMBDA (A B) (LIST A B)) Context: EVAL
542 Form: (LIST A B) Context: EVAL
543 Form: A Context: EVAL; lexically bound
544 Form: B Context: EVAL; lexically bound
545 Form: 1 Context: EVAL
546 Form: 2 Context: EVAL
547 \((LAMBDA (A B) (LIST A B)) 1 2)")))
549 (test-util:with-test
(:name
(:walk lambda special
))
550 (assert (string=-modulo-tabspace
551 (with-output-to-string (*standard-output
*)
552 (take-it-out-for-a-test-walk ((lambda (a b
)
553 (declare (special a
))
556 "Form: ((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2) Context: EVAL
557 Form: (LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) Context: EVAL
558 Form: (LIST A B) Context: EVAL
559 Form: A Context: EVAL; lexically bound; declared special
560 Form: B Context: EVAL; lexically bound
561 Form: 1 Context: EVAL
562 Form: 2 Context: EVAL
563 \((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)")))
565 (test-util:with-test
(:name
(:walk let list
))
566 (assert (string=-modulo-tabspace
567 (with-output-to-string (*standard-output
*)
568 (take-it-out-for-a-test-walk (let ((a a
) (b a
) (c b
))
570 "Form: (LET ((A A) (B A) (C B))
571 (LIST A B C)) Context: EVAL
572 Form: A Context: EVAL
573 Form: A Context: EVAL
574 Form: B Context: EVAL
575 Form: (LIST A B C) Context: EVAL
576 Form: A Context: EVAL; lexically bound
577 Form: B Context: EVAL; lexically bound
578 Form: C Context: EVAL; lexically bound
579 \(LET ((A A) (B A) (C B))
582 (test-util:with-test
(:name
(:walk let
* list
))
583 (assert (string=-modulo-tabspace
584 (with-output-to-string (*standard-output
*)
585 (take-it-out-for-a-test-walk (let* ((a a
) (b a
) (c b
)) (list a b c
))))
586 "Form: (LET* ((A A) (B A) (C B))
587 (LIST A B C)) Context: EVAL
588 Form: A Context: EVAL
589 Form: A Context: EVAL; lexically bound
590 Form: B Context: EVAL; lexically bound
591 Form: (LIST A B C) Context: EVAL
592 Form: A Context: EVAL; lexically bound
593 Form: B Context: EVAL; lexically bound
594 Form: C Context: EVAL; lexically bound
595 \(LET* ((A A) (B A) (C B))
598 (test-util:with-test
(:name
(:walk let special list
))
599 (assert (string=-modulo-tabspace
600 (with-output-to-string (*standard-output
*)
601 (take-it-out-for-a-test-walk (let ((a a
) (b a
) (c b
))
602 (declare (special a b
))
604 "Form: (LET ((A A) (B A) (C B))
605 (DECLARE (SPECIAL A B))
606 (LIST A B C)) Context: EVAL
607 Form: A Context: EVAL
608 Form: A Context: EVAL
609 Form: B Context: EVAL
610 Form: (LIST A B C) Context: EVAL
611 Form: A Context: EVAL; lexically bound; declared special
612 Form: B Context: EVAL; lexically bound; declared special
613 Form: C Context: EVAL; lexically bound
614 \(LET ((A A) (B A) (C B))
615 (DECLARE (SPECIAL A B))
618 ;;;; Bug in LET* walking!
619 (test-util:with-test
(:name
(:walk let
* special list
:hairy-specials
)
622 (string=-modulo-tabspace
623 (with-output-to-string (*standard-output
*)
624 (take-it-out-for-a-test-walk (let* ((a a
) (b a
) (c b
))
625 (declare (special a b
))
627 "Form: (LET* ((A A) (B A) (C B))
628 (DECLARE (SPECIAL A B))
629 (LIST A B C)) Context: EVAL
630 Form: A Context: EVAL
631 Form: A Context: EVAL; lexically bound; declared special
632 Form: B Context: EVAL; lexically bound; declared special
633 Form: (LIST A B C) Context: EVAL
634 Form: A Context: EVAL; lexically bound; declared special
635 Form: B Context: EVAL; lexically bound; declared special
636 Form: C Context: EVAL; lexically bound
637 (LET* ((A A) (B A) (C B))
638 (DECLARE (SPECIAL A B))
641 (test-util:with-test
(:name
(:walk let special
5))
642 (assert (string=-modulo-tabspace
643 (with-output-to-string (*standard-output
*)
644 (take-it-out-for-a-test-walk (let ((a 1) (b 2))
647 (declare (special a
))
649 "Form: (LET ((A 1) (B 2))
652 (DECLARE (SPECIAL A))
653 (FOO A B))) Context: EVAL
654 Form: 1 Context: EVAL
655 Form: 2 Context: EVAL
656 Form: (FOO BAR) Context: EVAL
657 Form: 'GLOBAL-FOO Context: EVAL
659 (DECLARE (SPECIAL A))
660 (FOO A B)) Context: EVAL
661 Form: (FOO A B) Context: EVAL
662 Form: 'GLOBAL-FOO Context: EVAL
666 (DECLARE (SPECIAL A))
669 (test-util:with-test
(:name
(:walk multiple-value-call
))
670 (assert (string=-modulo-tabspace
671 (with-output-to-string (*standard-output
*)
672 (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c
)))
673 "Form: (MULTIPLE-VALUE-CALL #'FOO A B C) Context: EVAL
674 Form: #'FOO Context: EVAL
675 Form: A Context: EVAL
676 Form: B Context: EVAL
677 Form: C Context: EVAL
678 \(MULTIPLE-VALUE-CALL #'FOO A B C)")))
680 (test-util:with-test
(:name
(:walk multiple-value-prog1
))
681 (assert (string=-modulo-tabspace
682 (with-output-to-string (*standard-output
*)
683 (take-it-out-for-a-test-walk (multiple-value-prog1 a b c
)))
684 "Form: (MULTIPLE-VALUE-PROG1 A B C) Context: EVAL
685 Form: A Context: EVAL
686 Form: B Context: EVAL
687 Form: C Context: EVAL
688 \(MULTIPLE-VALUE-PROG1 A B C)")))
690 (test-util:with-test
(:name
(:walk progn
2))
691 (assert (string=-modulo-tabspace
692 (with-output-to-string (*standard-output
*)
693 (take-it-out-for-a-test-walk (progn a b c
)))
694 "Form: (PROGN A B C) Context: EVAL
695 Form: A Context: EVAL
696 Form: B Context: EVAL
697 Form: C Context: EVAL
700 (test-util:with-test
(:name
(:walk progv
))
701 (assert (string=-modulo-tabspace
702 (with-output-to-string (*standard-output
*)
703 (take-it-out-for-a-test-walk (progv vars vals a b c
)))
704 "Form: (PROGV VARS VALS A B C) Context: EVAL
705 Form: VARS Context: EVAL
706 Form: VALS Context: EVAL
707 Form: A Context: EVAL
708 Form: B Context: EVAL
709 Form: C Context: EVAL
710 \(PROGV VARS VALS A B C)")))
712 (test-util:with-test
(:name
(:walk quote
))
713 (assert (string=-modulo-tabspace
714 (with-output-to-string (*standard-output
*)
715 (take-it-out-for-a-test-walk (quote a
)))
716 "Form: 'A Context: EVAL
719 (test-util:with-test
(:name
(:walk return-from
))
720 (assert (string=-modulo-tabspace
721 (with-output-to-string (*standard-output
*)
722 (take-it-out-for-a-test-walk (return-from block-name a b c
)))
723 "Form: (RETURN-FROM BLOCK-NAME A B C) Context: EVAL
724 Form: A Context: EVAL
725 Form: B Context: EVAL
726 Form: C Context: EVAL
727 \(RETURN-FROM BLOCK-NAME A B C)")))
730 (test-util:with-test
(:name
(:walk setq
1))
731 (assert (string=-modulo-tabspace
732 (with-output-to-string (*standard-output
*)
733 (take-it-out-for-a-test-walk (setq a
1)))
734 "Form: (SETQ A 1) Context: EVAL
736 Form: 1 Context: EVAL
740 (test-util:with-test
(:name
(:walk setq
2))
741 (assert (string=-modulo-tabspace
742 (with-output-to-string (*standard-output
*)
743 (take-it-out-for-a-test-walk (setq a
(foo 1) b
(bar 2) c
3)))
744 "Form: (SETQ A (FOO 1) B (BAR 2) C 3) Context: EVAL
745 Form: (SETQ A (FOO 1)) Context: EVAL
747 Form: (FOO 1) Context: EVAL
748 Form: 'GLOBAL-FOO Context: EVAL
749 Form: (SETQ B (BAR 2)) Context: EVAL
751 Form: (BAR 2) Context: EVAL
752 Form: 'GLOBAL-BAR Context: EVAL
753 Form: (SETQ C 3) Context: EVAL
755 Form: 3 Context: EVAL
756 \(SETQ A (FOO 1) B (BAR 2) C 3)")))
761 (test-util:with-test
(:name
(:walk tagbody
))
762 (assert (string=-modulo-tabspace
763 (with-output-to-string (*standard-output
*)
764 (take-it-out-for-a-test-walk (tagbody a b c
(go a
))))
765 "Form: (TAGBODY A B C (GO A)) Context: EVAL
766 Form: (GO A) Context: EVAL
767 \(TAGBODY A B C (GO A))")))
769 (test-util:with-test
(:name
(:walk the
))
770 (assert (string=-modulo-tabspace
771 (with-output-to-string (*standard-output
*)
772 (take-it-out-for-a-test-walk (the foo
(foo-form a b c
))))
773 "Form: (THE FOO (FOO-FORM A B C)) Context: EVAL
774 Form: (FOO-FORM A B C) Context: EVAL
775 Form: A Context: EVAL
776 Form: B Context: EVAL
777 Form: C Context: EVAL
778 \(THE FOO (FOO-FORM A B C))")))
780 (test-util:with-test
(:name
(:walk throw
))
781 (assert (string=-modulo-tabspace
782 (with-output-to-string (*standard-output
*)
783 (take-it-out-for-a-test-walk (throw tag-form a
)))
784 "Form: (THROW TAG-FORM A) Context: EVAL
785 Form: TAG-FORM Context: EVAL
786 Form: A Context: EVAL
787 \(THROW TAG-FORM A)")))
789 (test-util:with-test
(:name
(:walk unwind-protect
))
790 (assert (string=-modulo-tabspace
791 (with-output-to-string (*standard-output
*)
792 (take-it-out-for-a-test-walk (unwind-protect (foo a b
) d e f
)))
793 "Form: (UNWIND-PROTECT (FOO A B) D E F) Context: EVAL
794 Form: (FOO A B) Context: EVAL
795 Form: 'GLOBAL-FOO Context: EVAL
796 Form: D Context: EVAL
797 Form: E Context: EVAL
798 Form: F Context: EVAL
799 \(UNWIND-PROTECT (FOO A B) D E F)")))
801 (defmacro flet-1
(a b
)
802 (declare (ignore a b
))
805 (defmacro labels-1
(a b
)
806 (declare (ignore a b
))
809 (test-util:with-test
(:name
(:walk flet defmacro
))
810 (assert (string=-modulo-tabspace
811 (with-output-to-string (*standard-output
*)
812 (take-it-out-for-a-test-walk
813 (flet ((flet-1 (a b
) () (flet-1 a b
) (list a b
)))
816 "Form: (FLET ((FLET-1 (A B)
821 (FOO 1 2)) Context: EVAL
822 Form: NIL Context: EVAL; bound: NIL
823 Form: (FLET-1 A B) Context: EVAL
824 Form: 'OUTER Context: EVAL
825 Form: (LIST A B) Context: EVAL
826 Form: A Context: EVAL; lexically bound
827 Form: B Context: EVAL; lexically bound
828 Form: (FLET-1 1 2) Context: EVAL
829 Form: 1 Context: EVAL
830 Form: 2 Context: EVAL
831 Form: (FOO 1 2) Context: EVAL
832 Form: 'GLOBAL-FOO Context: EVAL
833 \(FLET ((FLET-1 (A B)
840 (test-util:with-test
(:name
(:walk labels defmacro
))
841 (assert (string=-modulo-tabspace
842 (with-output-to-string (*standard-output
*)
843 (take-it-out-for-a-test-walk
844 (labels ((label-1 (a b
) () (label-1 a b
)(list a b
)))
847 "Form: (LABELS ((LABEL-1 (A B)
852 (FOO 1 2)) Context: EVAL
853 Form: NIL Context: EVAL; bound: NIL
854 Form: (LABEL-1 A B) Context: EVAL
855 Form: A Context: EVAL; lexically bound
856 Form: B Context: EVAL; lexically bound
857 Form: (LIST A B) Context: EVAL
858 Form: A Context: EVAL; lexically bound
859 Form: B Context: EVAL; lexically bound
860 Form: (LABEL-1 1 2) Context: EVAL
861 Form: 1 Context: EVAL
862 Form: 2 Context: EVAL
863 Form: (FOO 1 2) Context: EVAL
864 Form: 'GLOBAL-FOO Context: EVAL
865 \(LABELS ((LABEL-1 (A B)
872 (test-util:with-test
(:name
(:walk macrolet
1))
873 (assert (string=-modulo-tabspace
874 (with-output-to-string (*standard-output
*)
875 (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b
) (list a b
)))
878 "Form: (MACROLET ((MACROLET-1 (A B)
881 (FOO 1 2)) Context: EVAL
882 Form: (LIST A B) Context: EVAL
883 Form: A Context: EVAL; lexically bound
884 Form: B Context: EVAL; lexically bound
885 Form: (MACROLET-1 A B) Context: EVAL
886 Form: (A B) Context: EVAL
887 Form: B Context: EVAL
888 Form: (FOO 1 2) Context: EVAL
889 Form: 'GLOBAL-FOO Context: EVAL
890 \(MACROLET ((MACROLET-1 (A B)
895 (test-util:with-test
(:name
(:walk macrolet
2))
896 (assert (string=-modulo-tabspace
897 (with-output-to-string (*standard-output
*)
898 (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a
)))
900 "Form: (MACROLET ((FOO (A)
901 `(INNER-FOO-EXPANDED ,A)))
902 (FOO 1)) Context: EVAL
903 Form: `(INNER-FOO-EXPANDED ,A) Context: EVAL
904 Form: (LIST 'INNER-FOO-EXPANDED A) Context: EVAL
905 Form: 'INNER-FOO-EXPANDED Context: EVAL
906 Form: A Context: EVAL; lexically bound
907 Form: (FOO 1) Context: EVAL
908 Form: (INNER-FOO-EXPANDED 1) Context: EVAL
909 Form: 1 Context: EVAL
911 `(INNER-FOO-EXPANDED ,A)))
914 (test-util:with-test
(:name
(:walk macrolet progn
1))
915 (assert (string=-modulo-tabspace
916 (with-output-to-string (*standard-output
*)
917 (take-it-out-for-a-test-walk (progn (bar 1)
919 `(inner-bar-expanded ,a
)))
924 `(INNER-BAR-EXPANDED ,A)))
925 (BAR 2))) Context: EVAL
926 Form: (BAR 1) Context: EVAL
927 Form: 'GLOBAL-BAR Context: EVAL
928 Form: (MACROLET ((BAR (A)
929 `(INNER-BAR-EXPANDED ,A)))
930 (BAR 2)) Context: EVAL
931 Form: `(INNER-BAR-EXPANDED ,A) Context: EVAL
932 Form: (LIST 'INNER-BAR-EXPANDED A) Context: EVAL
933 Form: 'INNER-BAR-EXPANDED Context: EVAL
934 Form: A Context: EVAL; lexically bound
935 Form: (BAR 2) Context: EVAL
936 Form: (INNER-BAR-EXPANDED 2) Context: EVAL
937 Form: 2 Context: EVAL
941 `(INNER-BAR-EXPANDED ,A)))
944 (test-util:with-test
(:name
(:walk macrolet progn
2))
945 (assert (string=-modulo-tabspace
946 (with-output-to-string (*standard-output
*)
947 (take-it-out-for-a-test-walk (progn (bar 1)
950 `(inner-bar-expanded ,s
)))
956 `(INNER-BAR-EXPANDED ,S)))
957 (BAR 2))) Context: EVAL
958 Form: (BAR 1) Context: EVAL
959 Form: 'GLOBAL-BAR Context: EVAL
960 Form: (MACROLET ((BAR (S)
962 `(INNER-BAR-EXPANDED ,S)))
963 (BAR 2)) Context: EVAL
964 Form: (BAR S) Context: EVAL
965 Form: 'GLOBAL-BAR Context: EVAL
966 Form: `(INNER-BAR-EXPANDED ,S) Context: EVAL
967 Form: (LIST 'INNER-BAR-EXPANDED S) Context: EVAL
968 Form: 'INNER-BAR-EXPANDED Context: EVAL
969 Form: S Context: EVAL; lexically bound
970 Form: (BAR 2) Context: EVAL
971 Form: (INNER-BAR-EXPANDED 2) Context: EVAL
972 Form: 2 Context: EVAL
977 `(INNER-BAR-EXPANDED ,S)))
980 (test-util:with-test
(:name
(:walk cond
))
981 (assert (string=-modulo-tabspace
982 (with-output-to-string (*standard-output
*)
983 (take-it-out-for-a-test-walk (cond (a b
)
984 ((foo bar
) a
(foo a
)))))
985 "Form: (COND (A B) ((FOO BAR) A (FOO A))) Context: EVAL
986 Form: (IF A (PROGN B) (COND ((FOO BAR) A (FOO A)))) Context: EVAL
987 Form: A Context: EVAL
988 Form: (PROGN B) Context: EVAL
989 Form: B Context: EVAL
990 Form: (COND ((FOO BAR) A (FOO A))) Context: EVAL
991 Form: (IF (FOO BAR) (PROGN A (FOO A)) NIL) Context: EVAL
992 Form: (FOO BAR) Context: EVAL
993 Form: 'GLOBAL-FOO Context: EVAL
994 Form: (PROGN A (FOO A)) Context: EVAL
995 Form: A Context: EVAL
996 Form: (FOO A) Context: EVAL
997 Form: 'GLOBAL-FOO Context: EVAL
998 Form: NIL Context: EVAL; bound: NIL
999 \(COND (A B) ((FOO BAR) A (FOO A)))")))
1001 (test-util:with-test
(:name
(:walk let lambda
))
1002 (assert (string=-modulo-tabspace
1003 (with-output-to-string (*standard-output
*)
1004 (let ((the-lexical-variables ()))
1005 (walk-form '(let ((a 1) (b 2))
1006 (lambda (x) (list a b x y
)))
1008 (lambda (form context env
)
1009 (declare (ignore context
))
1010 (when (and (symbolp form
)
1011 (var-lexical-p form env
))
1012 (push form the-lexical-variables
))
1014 (or (and (= (length the-lexical-variables
) 3)
1015 (member 'a the-lexical-variables
)
1016 (member 'b the-lexical-variables
)
1017 (member 'x the-lexical-variables
))
1018 (error "Walker didn't do lexical variables of a closure properly."))))
1021 (test-util:with-test
(:name
(:walk setq
:macro
))
1022 (assert (string=-modulo-tabspace
1023 (with-output-to-string (*standard-output
*)
1024 (take-it-out-for-a-test-walk
1025 (macrolet ((x () 'y
))
1027 "Form: (MACROLET ((X ()
1029 (SETQ (X) 3)) Context: EVAL
1030 Form: 'Y Context: EVAL
1031 Form: (SETQ (X) 3) Context: EVAL
1032 Form: (X) Context: SET
1033 Form: 3 Context: EVAL
1041 ;;; Old PCL hung up on this.