-
-;;; Unfortunately, I don't have an automatic tester for the walker.
-;;; Instead there is this set of test cases with a description of
-;;; how each one should go.
-(defmacro take-it-out-for-a-test-walk (form)
- `(take-it-out-for-a-test-walk-1 ',form))
-
-(defun take-it-out-for-a-test-walk-1 (form)
- (terpri)
- (terpri)
- (let ((copy-of-form (copy-tree form))
- (result (walk-form form nil
- #'(lambda (x y env)
- (format t "~&Form: ~S ~3T Context: ~A" x y)
- (when (symbolp x)
- (let ((lexical (variable-lexical-p x env))
- (special (variable-special-p x env)))
- (when lexical
- (format t ";~3T")
- (format t "lexically bound"))
- (when special
- (format t ";~3T")
- (format t "declared special"))
- (when (boundp x)
- (format t ";~3T")
- (format t "bound: ~S " (eval x)))))
- x))))
- (cond ((not (equal result copy-of-form))
- (format t "~%Warning: Result not EQUAL to copy of start."))
- ((not (eq result form))
- (format t "~%Warning: Result not EQ to copy of start.")))
- (pprint result)
- result))
-
-(defmacro foo (&rest ignore) ''global-foo)
-
-(defmacro bar (&rest ignore) ''global-bar)
-
-(take-it-out-for-a-test-walk (list arg1 arg2 arg3))
-(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
-
-(take-it-out-for-a-test-walk (progn (foo) (bar 1)))
-
-(take-it-out-for-a-test-walk (block block-name a b c))
-(take-it-out-for-a-test-walk (block block-name (list a) b c))
-
-(take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
-;;; This is a fairly simple macrolet case. While walking the body of the
-;;; macro, x should be lexically bound. In the body of the macrolet form
-;;; itself, x should not be bound.
-(take-it-out-for-a-test-walk
- (macrolet ((foo (x) (list x) ''inner))
- x
- (foo 1)))
-
-;;; A slightly more complex macrolet case. In the body of the macro x
-;;; should not be lexically bound. In the body of the macrolet form itself
-;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it
-;;; tries to macroexpand the call to foo.
-(take-it-out-for-a-test-walk
- (let ((x 1))
- (macrolet ((foo () (list x) ''inner))
- x
- (foo))))
-
-(take-it-out-for-a-test-walk
- (flet ((foo (x) (list x y))
- (bar (x) (list x y)))
- (foo 1)))
-
-(take-it-out-for-a-test-walk
- (let ((y 2))
- (flet ((foo (x) (list x y))
- (bar (x) (list x y)))
- (foo 1))))
-
-(take-it-out-for-a-test-walk
- (labels ((foo (x) (bar x))
- (bar (x) (foo x)))
- (foo 1)))
-
-(take-it-out-for-a-test-walk
- (flet ((foo (x) (foo x)))
- (foo 1)))
-
-(take-it-out-for-a-test-walk
- (flet ((foo (x) (foo x)))
- (flet ((bar (x) (foo x)))
- (bar 1))))
-
-(take-it-out-for-a-test-walk (prog () (declare (special a b))))
-(take-it-out-for-a-test-walk (let (a b c)
- (declare (special a b))
- (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
- (declare (special a) (special b))
- (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
- (declare (special a))
- (declare (special b))
- (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
- (declare (special a))
- (declare (special b))
- (let ((a 1))
- (foo a) b c)))
-(take-it-out-for-a-test-walk (eval-when ()
- a
- (foo a)))
-(take-it-out-for-a-test-walk (eval-when (eval when load)
- a
- (foo a)))
-
-(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
-(take-it-out-for-a-test-walk (multiple-value-bind (a b)
- (foo a b)
- (declare (special a))
- (list a b)))
-(take-it-out-for-a-test-walk (progn (function foo)))
-(take-it-out-for-a-test-walk (progn a b (go a)))
-(take-it-out-for-a-test-walk (if a b c))
-(take-it-out-for-a-test-walk (if a b))
-(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
-(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
- 1 2))
-(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
-(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
-(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
- (declare (special a b))
- (list a b c)))
-(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
- (declare (special a b))
- (list a b c)))
-(take-it-out-for-a-test-walk (let ((a 1) (b 2))
- (foo bar)
- (declare (special a))
- (foo a b)))
-(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
-(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
-(take-it-out-for-a-test-walk (progn a b c))
-(take-it-out-for-a-test-walk (progv vars vals a b c))
-(take-it-out-for-a-test-walk (quote a))
-(take-it-out-for-a-test-walk (return-from block-name a b c))
-(take-it-out-for-a-test-walk (setq a 1))
-(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
-(take-it-out-for-a-test-walk (tagbody a b c (go a)))
-(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
-(take-it-out-for-a-test-walk (throw tag-form a))
-(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
-
-(defmacro flet-1 (a b) ''outer)
-(defmacro labels-1 (a b) ''outer)
-
-(take-it-out-for-a-test-walk
- (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
- (flet-1 1 2)
- (foo 1 2)))
-(take-it-out-for-a-test-walk
- (labels ((label-1 (a b) () (label-1 a b)(list a b)))
- (label-1 1 2)
- (foo 1 2)))
-(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
- (macrolet-1 a b)
- (foo 1 2)))
-
-(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
- (foo 1)))
-
-(take-it-out-for-a-test-walk (progn (bar 1)
- (macrolet ((bar (a)
- `(inner-bar-expanded ,a)))
- (bar 2))))
-
-(take-it-out-for-a-test-walk (progn (bar 1)
- (macrolet ((bar (s)
- (bar s)
- `(inner-bar-expanded ,s)))
- (bar 2))))
-
-(take-it-out-for-a-test-walk (cond (a b)
- ((foo bar) a (foo a))))
-
-(let ((the-lexical-variables ()))
- (walk-form '(let ((a 1) (b 2))
- #'(lambda (x) (list a b x y)))
- ()
- #'(lambda (form context env)
- (when (and (symbolp form)
- (variable-lexical-p form env))
- (push form the-lexical-variables))
- form))
- (or (and (= (length the-lexical-variables) 3)
- (member 'a the-lexical-variables)
- (member 'b the-lexical-variables)
- (member 'x the-lexical-variables))
- (error "Walker didn't do lexical variables of a closure properly.")))