From 853b48ca4085b8ad9831edb9b06935a0977c0800 Mon Sep 17 00:00:00 2001
From: William Harold Newman <william.newman@airmail.net>
Date: Wed, 1 Aug 2001 17:39:39 +0000
Subject: [PATCH] 0.6.12.60: 	merged MNA clean-up-PCL-code-walker patch

---
 src/pcl/low.lisp       |    2 +-
 src/pcl/walk.lisp      |  369 ++++---------------
 tests/walk.impure.lisp |  940 ++++++++++++++++++++++++++++++++++++++++++++++++
 version.lisp-expr      |    2 +-
 4 files changed, 1005 insertions(+), 308 deletions(-)
 create mode 100644 tests/walk.impure.lisp

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index 099e48c..98174f3 100644
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -194,7 +194,7 @@
 	 ;; lets not do this...
 	 #+nil
 	 (let ((header (sb-kernel:%closure-function fcn)))
-	   (setf (sb-c::%function-name header) new-name))
+	   (setf (sb-kernel:%function-name header) new-name))
 
 	 ;; XXX Maybe add better scheme here someday.
 	 fcn)))
diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index e30ca28..c8e0eb8 100644
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -29,7 +29,7 @@
 
 (in-package "SB-WALKER")
 
-;;;; environment frobbing stuff
+;;;; environment hacking stuff, necessarily SBCL-specific
 
 ;;; Here in the original PCL were implementations of the
 ;;; implementation-specific environment hacking functions for each of
@@ -75,11 +75,35 @@
 
 ;;; In SBCL, as in CMU CL before it, the environment is represented
 ;;; with a structure that holds alists for the functional things,
-;;; variables, blocks, etc. Only the c::lexenv-functions slot is
-;;; relevant. It holds: Alist (name . what), where What is either a
-;;; Functional (a local function) or a list (MACRO . <function>) (a
+;;; variables, blocks, etc.
+;;; Except for SYMBOL-MACROLET, only the SB-C::LEXENV-FUNCTIONS slot
+;;; is relevant. It holds: Alist (Name . What), where What is either
+;;; a functional (a local function) or a list (MACRO . <function>) (a
 ;;; local macro, with the specifier expander.) Note that Name may be a
 ;;; (SETF <name>) function.
+;;; Accessors are defined below, eg (ENV-WALK-FUNCTION ENV).
+;;;
+;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND
+;;; this code hides the WALKER version of an environment
+;;; inside the SB-C::LEXENV structure.
+;;;
+;;; In CMUCL (and former SBCL), This used to be a list of lists of form
+;;; (<gensym-name> MACRO . #<interpreted-function>) in the :functions slot
+;;; in a C::LEXENV.
+;;; This form was accepted by the compiler, but this was a crude hack,
+;;; because the <interpreted-function> was used as a structure to hold the
+;;; bits of interest, {function, form, declarations, lexical-variables},
+;;; a list, which was not really an interpreted function.
+;;; Instead this list was COERCEd to a #<FUNCTION ...>!
+;;;
+;;; Instead, we now use a special sort of "function"-type for that information,
+;;; because the functions slot in SB-C::LEXENV is supposed to have a list of
+;;; <Name MACRO . #<function> elements.
+;;; So, now we hide our bits of interest in the walker-info slot in our new
+;;; BOGO-FUNCTION.
+;;;
+;;; MACROEXPAND-1 is the only SBCL function that gets called with the
+;;; constructed environment argument.
 
 (defmacro with-augmented-environment
     ((new-env old-env &key functions macros) &body body)
@@ -88,29 +112,27 @@
 							,macros)))
      ,@body))
 
-;;; KLUDGE: In CMU CL, when X was an arbitrary list, even one which
-;;; did not name a function or describe a lambda expression, calling
-;;; (EVAL `(FUNCTION ,X)) would still return a FUNCTION object, and no
-;;; error would be signalled until/unless you tried to FUNCALL the
-;;; resulting FUNCTION object. (This behavior was also present in
-;;; (COERCE X 'FUNCTION), which was defined in terms of (EVAL
-;;; `(FUNCTION ,X)).) This function provides roughly the same behavior
-;;; as the old CMU CL (COERCE X 'FUNCTION), for the benefit of PCL
-;;; code which relied on being able to coerce bogus things without
-;;; raising errors as long as it never tried to actually call them.
-(defun bogo-coerce-to-function (x)
-  (or (ignore-errors (coerce x 'function))
-      (lambda (&rest rest)
-	(declare (ignore rest))
-	(error "can't FUNCALL bogo-coerced-to-function ~S" x))))
+(defstruct (bogo-function
+	    (:alternate-metaclass sb-kernel:funcallable-instance
+				  sb-kernel:funcallable-structure-class
+				  sb-kernel:make-funcallable-structure-class)
+	    (:type sb-kernel:funcallable-structure)
+	    (:copier nil))
+  (walker-info (required-argument) :type list))
 
+(defun walker-info-to-bogo-function (x)
+  (make-bogo-function :walker-info x))
+
+(defun bogo-function-to-walker-info (x)
+  (bogo-function-walker-info x))
+   
 (defun with-augmented-environment-internal (env functions macros)
   ;; Note: In order to record the correct function definition, we
   ;; would have to create an interpreted closure, but the
-  ;; with-new-definition macro down below makes no distinction between
+  ;; WITH-NEW-DEFINITION macro down below makes no distinction between
   ;; FLET and LABELS, so we have no idea what to use for the
   ;; environment. So we just blow it off, 'cause anything real we do
-  ;; would be wrong. We still have to make an entry so we can tell
+  ;; would be wrong. But we still have to make an entry so we can tell
   ;; functions from macros.
   (let ((env (or env (sb-kernel:make-null-lexenv))))
     (sb-c::make-lexenv
@@ -122,8 +144,10 @@
 	      (mapcar (lambda (m)
 			(list* (car m)
 			       'sb-c::macro
-			       (bogo-coerce-to-function (cadr m))))
-		      macros)))))
+                               (if (eq (car m) *key-to-walker-environment*)
+                                 (walker-info-to-bogo-function (cadr m))
+                                 (coerce (cadr m) 'function))))
+                      macros)))))
 
 (defun environment-function (env fn)
   (when env
@@ -137,7 +161,12 @@
     (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq)))
       (and entry
 	   (eq (cadr entry) 'sb-c::macro)
-	   (values (function-lambda-expression (cddr entry)))))))
+           (if (eq macro *key-to-walker-environment*)
+             (values (bogo-function-to-walker-info (cddr entry)))
+             (values (function-lambda-expression (cddr entry))))))))
+
+;;;; other environment hacking, not so SBCL-specific as the
+;;;; environment hacking in the previous section
 
 (defmacro with-new-definition-in-environment
 	  ((new-env old-env macrolet/flet/labels-form) &body body)
@@ -165,8 +194,8 @@
     (eval `(defmacro ,gensym ,llist ,@body))
     (macro-function gensym)))
 
-;;; Now comes the real walker.
-;;;
+;;;; the actual walker
+
 ;;; As the walker walks over the code, it communicates information to
 ;;; itself about the walk. This information includes the walk
 ;;; function, variable bindings, declarations in effect etc. This
@@ -314,7 +343,6 @@
 	 '(lambda repeat (eval)))
 	(t
 	 (error "can't get template for ~S" x))))
-
 
 ;;;; the actual templates
 
@@ -356,9 +384,9 @@
 (defun walk-form (form
 		  &optional environment
 			    (walk-function
-			      #'(lambda (subform context env)
-				  (declare (ignore context env))
-				  subform)))
+			     (lambda (subform context env)
+			       (declare (ignore context env))
+			       subform)))
   (walker-environment-bind (new-env environment :walk-function walk-function)
     (walk-form-internal form :eval new-env)))
 
@@ -634,18 +662,6 @@
 (defun walk-let* (form context env)
   (walk-let/let* form context env t))
 
-(defun walk-prog (form context env)
-  (walk-prog/prog* form context env nil))
-
-(defun walk-prog* (form context env)
-  (walk-prog/prog* form context env t))
-
-(defun walk-do (form context env)
-  (walk-do/do* form context env nil))
-
-(defun walk-do* (form context env)
-  (walk-do/do* form context env t))
-
 (defun walk-let/let* (form context old-env sequentialp)
   (walker-environment-bind (new-env old-env)
     (let* ((let/let* (car form))
@@ -671,52 +687,6 @@
     (relist*
      form locally walked-body)))
 
-(defun walk-prog/prog* (form context old-env sequentialp)
-  (walker-environment-bind (new-env old-env)
-    (let* ((possible-block-name (second form))
-	   (blocked-prog (and (symbolp possible-block-name)
-			      (not (eq possible-block-name nil)))))
-      (multiple-value-bind (let/let* block-name bindings body)
-	  (if blocked-prog
-	      (values (car form) (cadr form) (caddr form) (cdddr form))
-	      (values (car form) nil	     (cadr  form) (cddr  form)))
-	(let* ((walked-bindings
-		 (walk-bindings-1 bindings
-				  old-env
-				  new-env
-				  context
-				  sequentialp))
-	       (walked-body
-		 (walk-declarations
-		   body
-		   #'(lambda (real-body real-env)
-		       (walk-tagbody-1 real-body context real-env))
-		   new-env)))
-	  (if block-name
-	      (relist*
-		form let/let* block-name walked-bindings walked-body)
-	      (relist*
-		form let/let* walked-bindings walked-body)))))))
-
-(defun walk-do/do* (form context old-env sequentialp)
-  (walker-environment-bind (new-env old-env)
-    (let* ((do/do* (car form))
-	   (bindings (cadr form))
-	   (end-test (caddr form))
-	   (body (cdddr form))
-	   (walked-bindings (walk-bindings-1 bindings
-					     old-env
-					     new-env
-					     context
-					     sequentialp))
-	   (walked-body
-	     (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist* form
-	       do/do*
-	       (walk-bindings-2 bindings walked-bindings context new-env)
-	       (walk-template end-test '(test repeat (eval)) context new-env)
-	       walked-body))))
-
 (defun walk-let-if (form context env)
   (let ((test (cadr form))
 	(bindings (caddr form))
@@ -952,33 +922,15 @@
 					 new-env))))))
 
 (defun walk-if (form context env)
-  (let ((predicate (cadr form))
-	(arm1 (caddr form))
-	(arm2
-	  (if (cddddr form)
-	      ;; FIXME: This should go away now that we're no longer trying
-	      ;; to support any old weird CLTL1.
-	      (progn
-		(warn "In the form:~%~S~%~
-		       IF only accepts three arguments, you are using ~D.~%~
-		       It is true that some Common Lisps support this, but ~
-		       it is not~%~
-		       truly legal Common Lisp. For now, this code ~
-		       walker is interpreting ~%~
-		       the extra arguments as extra else clauses. ~
-		       Even if this is what~%~
-		       you intended, you should fix your source code."
-		      form
-		      (length (cdr form)))
-		(cons 'progn (cdddr form)))
-	      (cadddr form))))
+  (destructuring-bind (if predicate arm1 &optional arm2) form
+    (declare (ignore if)) ; should be 'IF
     (relist form
 	    'if
 	    (walk-form-internal predicate context env)
 	    (walk-form-internal arm1 context env)
 	    (walk-form-internal arm2 context env))))
 
-;;;; tests tests tests
+;;;; examples
 
 #|
 ;;; Here are some examples of the kinds of things you should be able
@@ -1006,204 +958,9 @@
     (walk-form (cons 'progn body) :environment new-env)))
 
 (defun expand-rpush (form env)
+  (declare (ignore env))
   `(push ,(caddr form) ,(cadr form)))
 
 (defmacro with-rpush (&body body)
   `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
-
-;;; 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.")))
-|#
+|#
\ No newline at end of file
diff --git a/tests/walk.impure.lisp b/tests/walk.impure.lisp
new file mode 100644
index 0000000..6ce7968
--- /dev/null
+++ b/tests/walk.impure.lisp
@@ -0,0 +1,940 @@
+;;;; tests for the code walker
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package :sb-walker)
+
+;;;; stuff based on the tests at the end of the original CMU CL
+;;;; pcl/walk.lisp file
+
+(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)
+  (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)
+    nil))
+
+(defmacro foo (&rest ignore)
+  (declare (ignore ignore))
+  ''global-foo)
+
+(defmacro bar (&rest ignore)
+  (declare (ignore ignore))
+  ''global-bar)
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (list arg1 arg2 arg3)))
+         "Form: (LIST ARG1 ARG2 ARG3)   Context: EVAL
+Form: ARG1   Context: EVAL
+Form: ARG2   Context: EVAL
+Form: ARG3   Context: EVAL
+(LIST ARG1 ARG2 ARG3)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))))
+         "Form: (LIST (CONS 1 2) (LIST 3 4 5))   Context: EVAL
+Form: (CONS 1 2)   Context: EVAL
+Form: 1   Context: EVAL
+Form: 2   Context: EVAL
+Form: (LIST 3 4 5)   Context: EVAL
+Form: 3   Context: EVAL
+Form: 4   Context: EVAL
+Form: 5   Context: EVAL
+(LIST (CONS 1 2) (LIST 3 4 5))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (progn (foo) (bar 1))))
+         "Form: (PROGN (FOO) (BAR 1))   Context: EVAL
+Form: (FOO)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (BAR 1)   Context: EVAL
+Form: 'GLOBAL-BAR   Context: EVAL
+(PROGN (FOO) (BAR 1))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (block block-name a b c)))
+         "Form: (BLOCK BLOCK-NAME A B C)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(BLOCK BLOCK-NAME A B C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (block block-name (list a) b c)))
+         "Form: (BLOCK BLOCK-NAME (LIST A) B C)   Context: EVAL
+Form: (LIST A)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(BLOCK BLOCK-NAME (LIST A) B C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (catch catch-tag (list a) b c)))
+         "Form: (CATCH CATCH-TAG (LIST A) B C)   Context: EVAL
+Form: CATCH-TAG   Context: EVAL
+Form: (LIST A)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(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.
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk
+            (macrolet ((foo (x) (list x) ''inner))
+              x
+              (foo 1))))
+         "Form: (MACROLET ((FOO (X)
+                   (LIST X)
+                   ''INNER))
+        X
+        (FOO 1))   Context: EVAL
+Form: (LIST X)   Context: EVAL
+Form: X   Context: EVAL; lexically bound
+Form: ''INNER   Context: EVAL
+Form: X   Context: EVAL
+Form: (FOO 1)   Context: EVAL
+Form: 'INNER   Context: EVAL
+(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.
+
+(multiple-value-bind (res cond)
+    (ignore-errors
+      (take-it-out-for-a-test-walk
+       (let ((x 1))
+         (macrolet ((foo () (list x) ''inner))
+           x
+           (foo)))))
+  (assert (and (null res) cond)))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk
+            (flet ((foo (x) (list x y))
+                   (bar (x) (list x y)))
+              (foo 1))))
+         "Form: (FLET ((FOO (X)
+               (LIST X Y))
+             (BAR (X)
+               (LIST X Y)))
+        (FOO 1))   Context: EVAL
+Form: (LIST X Y)   Context: EVAL
+Form: X   Context: EVAL; lexically bound
+Form: Y   Context: EVAL
+Form: (LIST X Y)   Context: EVAL
+Form: X   Context: EVAL; lexically bound
+Form: Y   Context: EVAL
+Form: (FOO 1)   Context: EVAL
+Form: 1   Context: EVAL
+(FLET ((FOO (X)
+         (LIST X Y))
+       (BAR (X)
+         (LIST X Y)))
+  (FOO 1))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk
+            (let ((y 2))
+              (flet ((foo (x) (list x y))
+                     (bar (x) (list x y)))
+                (foo 1)))))
+         "Form: (LET ((Y 2))
+        (FLET ((FOO (X)
+                 (LIST X Y))
+               (BAR (X)
+                 (LIST X Y)))
+          (FOO 1)))   Context: EVAL
+Form: 2   Context: EVAL
+Form: (FLET ((FOO (X)
+               (LIST X Y))
+             (BAR (X)
+               (LIST X Y)))
+        (FOO 1))   Context: EVAL
+Form: (LIST X Y)   Context: EVAL
+Form: X   Context: EVAL; lexically bound
+Form: Y   Context: EVAL; lexically bound
+Form: (LIST X Y)   Context: EVAL
+Form: X   Context: EVAL; lexically bound
+Form: Y   Context: EVAL; lexically bound
+Form: (FOO 1)   Context: EVAL
+Form: 1   Context: EVAL
+(LET ((Y 2))
+  (FLET ((FOO (X)
+           (LIST X Y))
+         (BAR (X)
+           (LIST X Y)))
+    (FOO 1)))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk
+            (labels ((foo (x) (bar x))
+                     (bar (x) (foo x)))
+              (foo 1))))
+         "Form: (LABELS ((FOO (X)
+                 (BAR X))
+               (BAR (X)
+                 (FOO X)))
+        (FOO 1))   Context: EVAL
+Form: (BAR X)   Context: EVAL
+Form: X   Context: EVAL; lexically bound
+Form: (FOO X)   Context: EVAL
+Form: X   Context: EVAL; lexically bound
+Form: (FOO 1)   Context: EVAL
+Form: 1   Context: EVAL
+(LABELS ((FOO (X)
+           (BAR X))
+         (BAR (X)
+           (FOO X)))
+  (FOO 1))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk
+            (flet ((foo (x) (foo x)))
+              (foo 1))))
+         "Form: (FLET ((FOO (X)
+               (FOO X)))
+        (FOO 1))   Context: EVAL
+Form: (FOO X)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (FOO 1)   Context: EVAL
+Form: 1   Context: EVAL
+(FLET ((FOO (X)
+         (FOO X)))
+  (FOO 1))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk
+            (flet ((foo (x) (foo x)))
+              (flet ((bar (x) (foo x)))
+                (bar 1)))))
+         "Form: (FLET ((FOO (X)
+               (FOO X)))
+        (FLET ((BAR (X)
+                 (FOO X)))
+          (BAR 1)))   Context: EVAL
+Form: (FOO X)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (FLET ((BAR (X)
+               (FOO X)))
+        (BAR 1))   Context: EVAL
+Form: (FOO X)   Context: EVAL
+Form: X   Context: EVAL; lexically bound
+Form: (BAR 1)   Context: EVAL
+Form: 1   Context: EVAL
+(FLET ((FOO (X)
+         (FOO X)))
+  (FLET ((BAR (X)
+           (FOO X)))
+    (BAR 1)))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (prog () (declare (special a b)))))
+         "Form: (PROG () (DECLARE (SPECIAL A B)))   Context: EVAL
+Form: (BLOCK NIL
+        (LET ()
+          (DECLARE (SPECIAL A B))
+          (TAGBODY)))   Context: EVAL
+Form: (LET ()
+        (DECLARE (SPECIAL A B))
+        (TAGBODY))   Context: EVAL
+Form: (TAGBODY)   Context: EVAL
+(PROG () (DECLARE (SPECIAL A B)))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (let (a b c)
+                                          (declare (special a b))
+                                          (foo a) b c)))
+         "Form: (LET (A B C)
+        (DECLARE (SPECIAL A B))
+        (FOO A)
+        B
+        C)   Context: EVAL
+Form: (FOO A)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: B   Context: EVAL; lexically bound
+Form: C   Context: EVAL; lexically bound
+(LET (A B C)
+  (DECLARE (SPECIAL A B))
+  (FOO A)
+  B
+  C)"))
+
+(assert (equal
+(with-output-to-string (*standard-output*)
+  (take-it-out-for-a-test-walk (let (a b c)
+                                 (declare (special a) (special b))
+                                 (foo a) b c)))
+"Form: (LET (A B C)
+        (DECLARE (SPECIAL A) (SPECIAL B))
+        (FOO A)
+        B
+        C)   Context: EVAL
+Form: (FOO A)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: B   Context: EVAL; lexically bound; declared special
+Form: C   Context: EVAL; lexically bound
+(LET (A B C)
+  (DECLARE (SPECIAL A) (SPECIAL B))
+  (FOO A)
+  B
+  C)"))
+
+(assert (equal
+(with-output-to-string (*standard-output*)
+  (take-it-out-for-a-test-walk (let (a b c)
+                                 (declare (special a))
+                                 (declare (special b))
+                                 (foo a) b c)))
+"Form: (LET (A B C)
+        (DECLARE (SPECIAL A))
+        (DECLARE (SPECIAL B))
+        (FOO A)
+        B
+        C)   Context: EVAL
+Form: (FOO A)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: B   Context: EVAL; lexically bound; declared special
+Form: C   Context: EVAL; lexically bound
+(LET (A B C)
+  (DECLARE (SPECIAL A))
+  (DECLARE (SPECIAL B))
+  (FOO A)
+  B
+  C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (let (a b c)
+                                          (declare (special a))
+                                          (declare (special b))
+                                          (let ((a 1))
+                                            (foo a) b c))))
+"Form: (LET (A B C)
+        (DECLARE (SPECIAL A))
+        (DECLARE (SPECIAL B))
+        (LET ((A 1))
+          (FOO A)
+          B
+          C))   Context: EVAL
+Form: (LET ((A 1))
+        (FOO A)
+        B
+        C)   Context: EVAL
+Form: 1   Context: EVAL
+Form: (FOO A)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: B   Context: EVAL; lexically bound; declared special
+Form: C   Context: EVAL; lexically bound
+(LET (A B C)
+  (DECLARE (SPECIAL A))
+  (DECLARE (SPECIAL B))
+  (LET ((A 1))
+    (FOO A)
+    B
+    C))"))
+         
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (eval-when ()
+                                          a
+                                          (foo a))))
+         "Form: (EVAL-WHEN NIL A (FOO A))   Context: EVAL
+Form: A   Context: EVAL
+Form: (FOO A)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+(EVAL-WHEN NIL A (FOO A))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk
+            (eval-when (:execute :compile-toplevel :load-toplevel)
+                                          a
+                                          (foo a))))
+         "Form: (EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))   Context: EVAL
+Form: A   Context: EVAL
+Form: (FOO A)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+(EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (multiple-value-bind (a b)
+                                            (foo a b) (list a b))))
+         "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))   Context: EVAL
+Form: (FOO A B)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (LIST A B)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+(MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (multiple-value-bind (a b)
+                                            (foo a b)
+                                          (declare (special a))
+                                          (list a b))))
+         "Form: (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))   Context: EVAL
+Form: (FOO A B)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (LIST A B)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+(MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (progn (function foo))))
+         "Form: (PROGN #'FOO)   Context: EVAL
+Form: #'FOO   Context: EVAL
+(PROGN #'FOO)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (progn a b (go a))))
+         "Form: (PROGN A B (GO A))   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: (GO A)   Context: EVAL
+(PROGN A B (GO A))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (if a b c)))
+         "Form: (IF A B C)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(IF A B C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (if a b)))
+         "Form: (IF A B)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: NIL   Context: EVAL; bound: NIL 
+(IF A B)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)))
+         "Form: ((LAMBDA (A B) (LIST A B)) 1 2)   Context: EVAL
+Form: (LAMBDA (A B) (LIST A B))   Context: EVAL
+Form: (LIST A B)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: 1   Context: EVAL
+Form: 2   Context: EVAL
+((LAMBDA (A B) (LIST A B)) 1 2)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk ((lambda (a b)
+                                           (declare (special a))
+                                           (list a b))
+                                         1 2)))
+         "Form: ((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)   Context: EVAL
+Form: (LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B))   Context: EVAL
+Form: (LIST A B)   Context: EVAL
+Form: A   Context: EVAL; lexically bound; declared special
+Form: B   Context: EVAL; lexically bound
+Form: 1   Context: EVAL
+Form: 2   Context: EVAL
+((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
+                                          (list a b c))))
+         "Form: (LET ((A A) (B A) (C B))
+        (LIST A B C))   Context: EVAL
+Form: A   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: (LIST A B C)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: C   Context: EVAL; lexically bound
+(LET ((A A) (B A) (C B))
+  (LIST A B C))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))))
+         "Form: (LET* ((A A) (B A) (C B))
+        (LIST A B C))   Context: EVAL
+Form: A   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: (LIST A B C)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: C   Context: EVAL; lexically bound
+(LET* ((A A) (B A) (C B))
+  (LIST A B C))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
+                                          (declare (special a b))
+                                          (list a b c))))
+         "Form: (LET ((A A) (B A) (C B))
+        (DECLARE (SPECIAL A B))
+        (LIST A B C))   Context: EVAL
+Form: A   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: (LIST A B C)   Context: EVAL
+Form: A   Context: EVAL; lexically bound; declared special
+Form: B   Context: EVAL; lexically bound
+Form: C   Context: EVAL; lexically bound
+(LET ((A A) (B A) (C B))
+  (DECLARE (SPECIAL A B))
+  (LIST A B C))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
+                                          (declare (special a b))
+                                          (list a b c))))
+         "Form: (LET* ((A A) (B A) (C B))
+        (DECLARE (SPECIAL A B))
+        (LIST A B C))   Context: EVAL
+Form: A   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: (LIST A B C)   Context: EVAL
+Form: A   Context: EVAL; lexically bound; declared special
+Form: B   Context: EVAL; lexically bound
+Form: C   Context: EVAL; lexically bound
+(LET* ((A A) (B A) (C B))
+  (DECLARE (SPECIAL A B))
+  (LIST A B C))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (let ((a 1) (b 2))
+                                          (foo bar)
+                                          (let ()
+                                            (declare (special a))
+                                            (foo a b)))))
+         "Form: (LET ((A 1) (B 2))
+        (FOO BAR)
+        (LET ()
+          (DECLARE (SPECIAL A))
+          (FOO A B)))   Context: EVAL
+Form: 1   Context: EVAL
+Form: 2   Context: EVAL
+Form: (FOO BAR)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (LET ()
+        (DECLARE (SPECIAL A))
+        (FOO A B))   Context: EVAL
+Form: (FOO A B)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+(LET ((A 1) (B 2))
+  (FOO BAR)
+  (LET ()
+    (DECLARE (SPECIAL A))
+    (FOO A B)))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)))
+         "Form: (MULTIPLE-VALUE-CALL #'FOO A B C)   Context: EVAL
+Form: #'FOO   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(MULTIPLE-VALUE-CALL #'FOO A B C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (multiple-value-prog1 a b c)))
+         "Form: (MULTIPLE-VALUE-PROG1 A B C)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(MULTIPLE-VALUE-PROG1 A B C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (progn a b c)))
+         "Form: (PROGN A B C)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(PROGN A B C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (progv vars vals a b c)))
+         "Form: (PROGV VARS VALS A B C)   Context: EVAL
+Form: VARS   Context: EVAL
+Form: VALS   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(PROGV VARS VALS A B C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (quote a)))
+         "Form: 'A   Context: EVAL
+'A"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (return-from block-name a b c)))
+         "Form: (RETURN-FROM BLOCK-NAME A B C)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(RETURN-FROM BLOCK-NAME A B C)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (setq a 1)))
+         "Form: (SETQ A 1)   Context: EVAL
+Form: A   Context: SET
+Form: 1   Context: EVAL
+(SETQ A 1)"))
+(makunbound 'a)
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)))
+         "Form: (SETQ A (FOO 1) B (BAR 2) C 3)   Context: EVAL
+Form: (SETQ A (FOO 1))   Context: EVAL
+Form: A   Context: SET
+Form: (FOO 1)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (SETQ B (BAR 2))   Context: EVAL
+Form: B   Context: SET
+Form: (BAR 2)   Context: EVAL
+Form: 'GLOBAL-BAR   Context: EVAL
+Form: (SETQ C 3)   Context: EVAL
+Form: C   Context: SET
+Form: 3   Context: EVAL
+(SETQ A (FOO 1) B (BAR 2) C 3)"))
+(makunbound 'a)
+(makunbound 'b)
+(makunbound 'c)
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (tagbody a b c (go a))))
+         "Form: (TAGBODY A B C (GO A))   Context: EVAL
+Form: A   Context: QUOTE
+Form: B   Context: QUOTE
+Form: C   Context: QUOTE
+Form: (GO A)   Context: EVAL
+(TAGBODY A B C (GO A))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (the foo (foo-form a b c))))
+         "Form: (THE FOO (FOO-FORM A B C))   Context: EVAL
+Form: (FOO-FORM A B C)   Context: EVAL
+Form: A   Context: EVAL
+Form: B   Context: EVAL
+Form: C   Context: EVAL
+(THE FOO (FOO-FORM A B C))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (throw tag-form a)))
+         "Form: (THROW TAG-FORM A)   Context: EVAL
+Form: TAG-FORM   Context: EVAL
+Form: A   Context: EVAL
+(THROW TAG-FORM A)"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)))
+         "Form: (UNWIND-PROTECT (FOO A B) D E F)   Context: EVAL
+Form: (FOO A B)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: D   Context: EVAL
+Form: E   Context: EVAL
+Form: F   Context: EVAL
+(UNWIND-PROTECT (FOO A B) D E F)"))
+
+(defmacro flet-1 (a b)
+  (declare (ignore a b))
+  ''outer)
+
+(defmacro labels-1 (a b)
+  (declare (ignore a b))
+  ''outer)
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (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))))
+         "Form: (FLET ((FLET-1 (A B)
+               NIL
+               (FLET-1 A B)
+               (LIST A B)))
+        (FLET-1 1 2)
+        (FOO 1 2))   Context: EVAL
+Form: NIL   Context: EVAL; bound: NIL 
+Form: (FLET-1 A B)   Context: EVAL
+Form: 'OUTER   Context: EVAL
+Form: (LIST A B)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: (FLET-1 1 2)   Context: EVAL
+Form: 1   Context: EVAL
+Form: 2   Context: EVAL
+Form: (FOO 1 2)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+(FLET ((FLET-1 (A B)
+         NIL
+         (FLET-1 A B)
+         (LIST A B)))
+  (FLET-1 1 2)
+  (FOO 1 2))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (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))))
+         "Form: (LABELS ((LABEL-1 (A B)
+                 NIL
+                 (LABEL-1 A B)
+                 (LIST A B)))
+        (LABEL-1 1 2)
+        (FOO 1 2))   Context: EVAL
+Form: NIL   Context: EVAL; bound: NIL 
+Form: (LABEL-1 A B)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: (LIST A B)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: (LABEL-1 1 2)   Context: EVAL
+Form: 1   Context: EVAL
+Form: 2   Context: EVAL
+Form: (FOO 1 2)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+(LABELS ((LABEL-1 (A B)
+           NIL
+           (LABEL-1 A B)
+           (LIST A B)))
+  (LABEL-1 1 2)
+  (FOO 1 2))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
+                                          (macrolet-1 a b)
+                                          (foo 1 2))))
+         "Form: (MACROLET ((MACROLET-1 (A B)
+                   (LIST A B)))
+        (MACROLET-1 A B)
+        (FOO 1 2))   Context: EVAL
+Form: (LIST A B)   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound
+Form: (MACROLET-1 A B)   Context: EVAL
+Form: (A B)   Context: EVAL
+Form: B   Context: EVAL
+Form: (FOO 1 2)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+(MACROLET ((MACROLET-1 (A B)
+             (LIST A B)))
+  (MACROLET-1 A B)
+  (FOO 1 2))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
+                                          (foo 1))))
+         "Form: (MACROLET ((FOO (A)
+                   `(INNER-FOO-EXPANDED ,A)))
+        (FOO 1))   Context: EVAL
+Form: `(INNER-FOO-EXPANDED ,A)   Context: EVAL
+Form: 'INNER-FOO-EXPANDED   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: (FOO 1)   Context: EVAL
+Form: (INNER-FOO-EXPANDED 1)   Context: EVAL
+Form: 1   Context: EVAL
+(MACROLET ((FOO (A)
+             `(INNER-FOO-EXPANDED ,A)))
+  (FOO 1))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (progn (bar 1)
+                                               (macrolet ((bar (a)
+                                                            `(inner-bar-expanded ,a)))
+                                                 (bar 2)))))
+         "Form: (PROGN
+       (BAR 1)
+       (MACROLET ((BAR (A)
+                    `(INNER-BAR-EXPANDED ,A)))
+         (BAR 2)))   Context: EVAL
+Form: (BAR 1)   Context: EVAL
+Form: 'GLOBAL-BAR   Context: EVAL
+Form: (MACROLET ((BAR (A)
+                   `(INNER-BAR-EXPANDED ,A)))
+        (BAR 2))   Context: EVAL
+Form: `(INNER-BAR-EXPANDED ,A)   Context: EVAL
+Form: 'INNER-BAR-EXPANDED   Context: EVAL
+Form: A   Context: EVAL; lexically bound
+Form: (BAR 2)   Context: EVAL
+Form: (INNER-BAR-EXPANDED 2)   Context: EVAL
+Form: 2   Context: EVAL
+(PROGN
+ (BAR 1)
+ (MACROLET ((BAR (A)
+              `(INNER-BAR-EXPANDED ,A)))
+   (BAR 2)))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (progn (bar 1)
+                                               (macrolet ((bar (s)
+                                                            (bar s)
+                                                            `(inner-bar-expanded ,s)))
+                                                 (bar 2)))))
+         "Form: (PROGN
+       (BAR 1)
+       (MACROLET ((BAR (S)
+                    (BAR S)
+                    `(INNER-BAR-EXPANDED ,S)))
+         (BAR 2)))   Context: EVAL
+Form: (BAR 1)   Context: EVAL
+Form: 'GLOBAL-BAR   Context: EVAL
+Form: (MACROLET ((BAR (S)
+                   (BAR S)
+                   `(INNER-BAR-EXPANDED ,S)))
+        (BAR 2))   Context: EVAL
+Form: (BAR S)   Context: EVAL
+Form: 'GLOBAL-BAR   Context: EVAL
+Form: `(INNER-BAR-EXPANDED ,S)   Context: EVAL
+Form: 'INNER-BAR-EXPANDED   Context: EVAL
+Form: S   Context: EVAL; lexically bound
+Form: (BAR 2)   Context: EVAL
+Form: (INNER-BAR-EXPANDED 2)   Context: EVAL
+Form: 2   Context: EVAL
+(PROGN
+ (BAR 1)
+ (MACROLET ((BAR (S)
+              (BAR S)
+              `(INNER-BAR-EXPANDED ,S)))
+   (BAR 2)))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (take-it-out-for-a-test-walk (cond (a b)
+                                              ((foo bar) a (foo a)))))
+         "Form: (COND (A B) ((FOO BAR) A (FOO A)))   Context: EVAL
+Form: (IF A (PROGN B) (COND ((FOO BAR) A (FOO A))))   Context: EVAL
+Form: A   Context: EVAL
+Form: (PROGN B)   Context: EVAL
+Form: B   Context: EVAL
+Form: (COND ((FOO BAR) A (FOO A)))   Context: EVAL
+Form: (IF (FOO BAR) (PROGN A (FOO A)) (COND))   Context: EVAL
+Form: (FOO BAR)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (PROGN A (FOO A))   Context: EVAL
+Form: A   Context: EVAL
+Form: (FOO A)   Context: EVAL
+Form: 'GLOBAL-FOO   Context: EVAL
+Form: (COND)   Context: EVAL
+Form: NIL   Context: EVAL; bound: NIL 
+(COND (A B) ((FOO BAR) A (FOO A)))"))
+
+(assert (equal
+         (with-output-to-string (*standard-output*)
+           (let ((the-lexical-variables ()))
+             (walk-form '(let ((a 1) (b 2))
+                          #'(lambda (x) (list a b x y)))
+                        ()
+                        #'(lambda (form context env)
+                            (declare (ignore context))
+                            (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."))))
+         ""))
+
+(quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index 753e5a1..2400f6d 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -16,4 +16,4 @@
 ;;; four numeric fields, is used for versions which aren't released
 ;;; but correspond only to CVS tags or snapshots.
 
-"0.6.12.59"
+"0.6.12.60"
-- 
1.7.10.4