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