X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=39beb2e3ce4fca980fff3bc6f746d2d4fbdbea9b;hb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;hp=ab7aef897808cb87276c8931b4428425b67e8357;hpb=77360ee4a1f94c41b807be7ad0e8687199fceef1;p=sbcl.git

diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index ab7aef8..39beb2e 100644
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -1,4 +1,4 @@
-;;;; a simple code walker for PCL
+;;;; a simple code walker
 ;;;;
 ;;;; The code which implements the macroexpansion environment
 ;;;; manipulation mechanisms is in the first part of the file, the
@@ -27,9 +27,13 @@
 ;;;; warranty about the software, its performance or its conformity to any
 ;;;; specification.
 
-(in-package "SB-WALKER")
+(in-package "SB!WALKER")
 
-;;;; environment frobbing stuff
+;;;; forward references
+
+(defvar *key-to-walker-environment*)
+
+;;;; 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 +79,37 @@
 
 ;;; 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
-;;; local macro, with the specifier expander.) Note that Name may be a
-;;; (SETF <name>) function.
+;;; variables, blocks, etc. Except for SYMBOL-MACROLET, only the
+;;; SB!C::LEXENV-FUNS 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-FUN.
+;;;
+;;; MACROEXPAND-1 and SB!INT:EVAL-IN-LEXENV are the only SBCL
+;;; functions that get called with the constructed environment
+;;; argument.
+
+(/show "walk.lisp 108")
 
 (defmacro with-augmented-environment
     ((new-env old-env &key functions macros) &body body)
@@ -88,56 +118,72 @@
 							,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))))
-
-(defun with-augmented-environment-internal (env functions macros)
+;;; a unique tag to show that we're the intended caller of BOGO-FUN
+(defvar *bogo-fun-magic-tag*
+  '(:bogo-fun-magic-tag))
+
+;;; The interface of BOGO-FUNs (previously implemented as
+;;; FUNCALLABLE-INSTANCEs) is just these two operations, so we can do
+;;; them with ordinary closures.
+;;;
+;;; KLUDGE: BOGO-FUNs are sorta weird, and MNA and I have both hacked
+;;; on this code without quite figuring out what they're for. (He
+;;; changed them to work after some changes in the IR1 interpreter
+;;; made functions not be built lazily, and I changed them so that
+;;; they don't need FUNCALLABLE-INSTANCE stuff, so that the F-I stuff
+;;; can become less general.) There may be further simplifications or
+;;; clarifications which could be done. -- WHN 2001-10-19
+(defun walker-info-to-bogo-fun (walker-info)
+  (lambda (magic-tag &rest rest)
+    (aver (not rest)) ; else someone is using me in an unexpected way
+    (aver (eql magic-tag *bogo-fun-magic-tag*)) ; else ditto
+    walker-info))
+(defun bogo-fun-to-walker-info (bogo-fun)
+  (declare (type function bogo-fun))
+  (funcall bogo-fun *bogo-fun-magic-tag*))
+
+(defun with-augmented-environment-internal (env funs 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
-      :default env
-      :functions
-      (append (mapcar (lambda (f)
-			(cons (car f) (sb-c::make-functional :lexenv env)))
-		      functions)
-	      (mapcar (lambda (m)
-			(list* (car m)
-			       'sb-c::macro
-			       (bogo-coerce-to-function (cadr m))))
-		      macros)))))
+  (let ((lexenv (sb!kernel::coerce-to-lexenv env)))
+    (sb!c::make-lexenv
+     :default lexenv
+     :funs (append (mapcar (lambda (f)
+			     (cons (car f)
+				   (sb!c::make-functional :lexenv lexenv)))
+			   funs)
+		   (mapcar (lambda (m)
+			     (list* (car m)
+				    'sb!c::macro
+				    (if (eq (car m)
+					    *key-to-walker-environment*)
+					(walker-info-to-bogo-fun (cadr m))
+					(coerce (cadr m) 'function))))
+			   macros)))))
 
 (defun environment-function (env fn)
   (when env
-    (let ((entry (assoc fn (sb-c::lexenv-functions env) :test #'equal)))
+    (let ((entry (assoc fn (sb!c::lexenv-funs env) :test #'equal)))
       (and entry
-	   (sb-c::functional-p (cdr entry))
+	   (sb!c::functional-p (cdr entry))
 	   (cdr entry)))))
 
 (defun environment-macro (env macro)
   (when env
-    (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq)))
+    (let ((entry (assoc macro (sb!c::lexenv-funs env) :test #'eq)))
       (and entry
-	   (eq (cadr entry) 'sb-c::macro)
-	   (function-lambda-expression (cddr entry))))))
+	   (eq (cadr entry) 'sb!c::macro)
+           (if (eq macro *key-to-walker-environment*)
+	       (values (bogo-fun-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)
@@ -154,19 +200,21 @@
 	    (push (list (car mac)
 			(convert-macro-to-lambda (cadr mac)
 						 (cddr mac)
+						 ,old-env
 						 (string (car mac))))
 		  ,macros))))
        (with-augmented-environment
 	      (,new-env ,old-env :functions ,functions :macros ,macros)
 	 ,@body))))
 
-(defun convert-macro-to-lambda (llist body &optional (name "dummy macro"))
+(defun convert-macro-to-lambda (llist body env &optional (name "dummy macro"))
   (let ((gensym (make-symbol name)))
-    (eval `(defmacro ,gensym ,llist ,@body))
+    (eval-in-lexenv `(defmacro ,gensym ,llist ,@body)
+		    (sb!c::make-restricted-lexenv env))
     (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
@@ -193,7 +241,7 @@
     (list
       (list *key-to-walker-environment*
 	    (list (if wfnp walk-function     (car lock))
-		  (if wfop walk-form	 (cadr lock))
+		  (if wfop walk-form         (cadr lock))
 		  (if decp declarations      (caddr lock))
 		  (if lexp lexical-variables (cadddr lock)))))))
 
@@ -215,33 +263,33 @@
 (defun note-lexical-binding (thing env)
   (push (list thing :lexical-var) (cadddr (env-lock env))))
 
-(defun variable-lexical-p (var env)
+(defun var-lexical-p (var env)
   (let ((entry (member var (env-lexical-variables env) :key #'car)))
     (when (eq (cadar entry) :lexical-var)
       entry)))
 
 (defun variable-symbol-macro-p (var env)
   (let ((entry (member var (env-lexical-variables env) :key #'car)))
-    (when (eq (cadar entry) :macro)
+    (when (eq (cadar entry) 'sb!sys:macro)
       entry)))
 
-(defvar *variable-declarations* '(special))
+(defvar *var-declarations* '(special))
 
-(defun variable-declaration (declaration var env)
-  (if (not (member declaration *variable-declarations*))
+(defun var-declaration (declaration var env)
+  (if (not (member declaration *var-declarations*))
       (error "~S is not a recognized variable declaration." declaration)
-      (let ((id (or (variable-lexical-p var env) var)))
+      (let ((id (or (var-lexical-p var env) var)))
 	(dolist (decl (env-declarations env))
 	  (when (and (eq (car decl) declaration)
 		     (eq (cadr decl) id))
 	    (return decl))))))
 
-(defun variable-special-p (var env)
-  (or (not (null (variable-declaration 'special var env)))
-      (variable-globally-special-p var)))
+(defun var-special-p (var env)
+  (or (not (null (var-declaration 'special var env)))
+      (var-globally-special-p var)))
 
-(defun variable-globally-special-p (symbol)
-  (eq (sb-int:info :variable :kind symbol) :special))
+(defun var-globally-special-p (symbol)
+  (eq (info :variable :kind symbol) :special))
 
 ;;;; handling of special forms
 
@@ -272,7 +320,7 @@
 ;;;	 - Is a common lisp special form (not likely)
 ;;;	 - Is not a common lisp special form (on the 3600 IF --> COND).
 ;;;
-;;;     * We can safe ourselves from this case (second subcase really)
+;;;     * We can save ourselves from this case (second subcase really)
 ;;;       by checking to see whether there is a template defined for 
 ;;;       something before we check to see whether we can macroexpand it.
 ;;;
@@ -309,17 +357,11 @@
 
 (defun get-walker-template (x)
   (cond ((symbolp x)
-	 (or (get-walker-template-internal x)
-	     (get-implementation-dependent-walker-template x)))
+         (get-walker-template-internal x))
 	((and (listp x) (eq (car x) 'lambda))
 	 '(lambda repeat (eval)))
 	(t
 	 (error "can't get template for ~S" x))))
-
-;;; FIXME: This can go away in SBCL.
-(defun get-implementation-dependent-walker-template (x)
-  (declare (ignore x))
-  ())
 
 ;;;; the actual templates
 
@@ -354,16 +396,16 @@
 (define-walker-template unwind-protect       (nil return repeat (eval)))
 
 ;;; SBCL-only special forms
-(define-walker-template sb-ext:truly-the     (nil quote eval))
+(define-walker-template sb!ext:truly-the     (nil quote eval))
 
 (defvar *walk-form-expand-macros-p* nil)
 
 (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)))
 
@@ -412,7 +454,7 @@
 		(multiple-value-bind (newnewform macrop)
 		    (walker-environment-bind
 			(new-env env :walk-form newform)
-		      (macroexpand-1 newform new-env))
+		      (sb-xc:macroexpand-1 newform new-env))
 		  (cond
 		   (macrop
 		    (let ((newnewnewform (walk-form-internal newnewform
@@ -428,7 +470,7 @@
 		    ;; maintained as part of SBCL, so it should know
 		    ;; about all the special forms that SBCL knows
 		    ;; about.
-		    (error "unexpected special form ~S" fn))
+		    (bug "unexpected special form ~S" fn))
 		   (t
 		    ;; Otherwise, walk the form as if it's just a
 		    ;; standard function call using a template for
@@ -445,10 +487,7 @@
 	(set
 	  (walk-form-internal form :set env))
 	((lambda call)
-	 (cond ((or (symbolp form)
-		    (and (listp form)
-			 (= (length form) 2)
-			 (eq (car form) 'setf)))
+	 (cond ((legal-fun-name-p form)
 		form)
 	       (t (walk-form-internal form context env)))))
       (case (car template)
@@ -535,7 +574,7 @@
       (relist-internal x args nil)))
 
 (defun relist* (x &rest args)
-  (relist-internal x args 't))
+  (relist-internal x args t))
 
 (defun relist-internal (x args *p)
   (if (null (cdr args))
@@ -565,9 +604,9 @@
 	   (let ((type (car declaration))
 		 (name (cadr declaration))
 		 (args (cddr declaration)))
-	     (if (member type *variable-declarations*)
+	     (if (member type *var-declarations*)
 		 (note-declaration `(,type
-				     ,(or (variable-lexical-p name env) name)
+				     ,(or (var-lexical-p name env) name)
 				     ,.args)
 				   env)
 		 (note-declaration declaration env))
@@ -581,7 +620,7 @@
 	      (null (get-walker-template (car form)))
 	      (progn
 		(multiple-value-setq (new-form macrop)
-				     (macroexpand-1 form env))
+				     (sb-xc:macroexpand-1 form env))
 		macrop))
 	 ;; This form was a call to a macro. Maybe it expanded
 	 ;; into a declare?  Recurse to find out.
@@ -597,7 +636,7 @@
 
 (defun walk-unexpected-declare (form context env)
   (declare (ignore context env))
-  (warn "encountered DECLARE ~S in a place where a DECLARE was not expected"
+  (warn "encountered ~S ~_in a place where a DECLARE was not expected"
 	form)
   form)
 
@@ -631,7 +670,7 @@
 		    (not (symbolp (caddr arg)))
 		    (note-lexical-binding (caddr arg) env))))
 	  (t
-	   (error "Can't understand something in the arglist ~S" arglist))))
+	   (error "can't understand something in the arglist ~S" arglist))))
 
 (defun walk-let (form context env)
   (walk-let/let* form context env nil))
@@ -639,18 +678,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))
@@ -676,59 +703,13 @@
     (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))
 	(body (cdddr form)))
     (walk-form-internal
       `(let ()
-	 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
+	 (declare (special ,@(mapcar (lambda (x) (if (listp x) (car x) x))
 				     bindings)))
 	 (flet ((.let-if-dummy. () ,@body))
 	   (if ,test
@@ -739,14 +720,14 @@
 
 (defun walk-multiple-value-setq (form context env)
   (let ((vars (cadr form)))
-    (if (some #'(lambda (var)
-		  (variable-symbol-macro-p var env))
+    (if (some (lambda (var)
+		(variable-symbol-macro-p var env))
 	      vars)
-	(let* ((temps (mapcar #'(lambda (var)
-				  (declare (ignore var))
-				  (gensym))
+	(let* ((temps (mapcar (lambda (var)
+				(declare (ignore var))
+				(gensym))
 			      vars))
-	       (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp))
+	       (sets (mapcar (lambda (var temp) `(setq ,var ,temp))
 			     vars
 			     temps))
 	       (expanded `(multiple-value-bind ,temps ,(caddr form)
@@ -767,14 +748,14 @@
 	   (walked-body
 	     (walk-declarations
 	       body
-	       #'(lambda (real-body real-env)
-		   (setq walked-bindings
-			 (walk-bindings-1 bindings
-					  old-env
-					  new-env
-					  context
-					  nil))
-		   (walk-repeat-eval real-body real-env))
+	       (lambda (real-body real-env)
+		 (setq walked-bindings
+		       (walk-bindings-1 bindings
+					old-env
+					new-env
+					context
+					nil))
+		 (walk-repeat-eval real-body real-env))
 	       new-env)))
       (relist* form mvb walked-bindings mv-form walked-body))))
 
@@ -834,20 +815,6 @@
 	       walked-arglist
 	       walked-body))))
 
-(defun walk-named-lambda (form context old-env)
-  (walker-environment-bind (new-env old-env)
-    (let* ((name (cadr form))
-	   (arglist (caddr form))
-	   (body (cdddr form))
-	   (walked-arglist (walk-arglist arglist context new-env))
-	   (walked-body
-	     (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist* form
-	       (car form)
-	       name
-	       walked-arglist
-	       walked-body))))
-
 (defun walk-setq (form context env)
   (if (cdddr form)
       (let* ((expanded (let ((rforms nil)
@@ -879,9 +846,9 @@
     (walker-environment-bind
 	(new-env old-env
 		 :lexical-variables
-		 (append (mapcar #'(lambda (binding)
-				     `(,(car binding)
-				       :macro . ,(cadr binding)))
+		 (append (mapcar (lambda (binding)
+				   `(,(car binding)
+				     sb!sys:macro . ,(cadr binding)))
 				 bindings)
 			 (env-lexical-variables old-env)))
       (relist* form 'symbol-macrolet bindings
@@ -957,33 +924,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
@@ -1011,204 +960,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