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