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