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