;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985 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.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;; 
;;; A simple code walker, based IN PART on: (roll the credits)
;;;   Larry Masinter's Masterscope
;;;   Moon's Common Lisp code walker
;;;   Gary Drescher's code walker
;;;   Larry Masinter's simple code walker
;;;   .
;;;   .
;;;   boy, thats fair (I hope).
;;;
;;; For now at least, this code walker really only does what PCL needs it to
;;; do.  Maybe it will grow up someday.
;;;

(in-package 'walker)

(export '(define-walker-template
	  walk-form
	  variable-lexical-p
	  variable-special-p
	  ))

;;; *walk-function* is the function being called on each sub-form as we walk.
;;; Normally it is supplied using the :walk-function keyword argument to
;;; walk-form, but it is OK to bind it around a call to walk-form-internal.
(defvar *walk-function*)

;;; *walk-form* is used by the IF template.  When the first argument to the
;;; if template is a list it will be evaluated with *walk-form* bound to the 
;;; form currently being walked.
(defvar *walk-form*)

;;; *declarations* is a list of the declarations currently in effect.
(defvar *declarations*)
	
;;; *lexical-variables* is a list of the variables bound in the current
;;; contour. In *lexical-variables* the cons whose car is the variable is
;;; meaningful in the sense that the cons whose car is the variable can be
;;; used to keep track of which contour the variable is bound in.
;;;
;;; Now isn't that just the cats pajamas.
;;;
(defvar *lexical-variables*)

;;; An environment of the kind that macroexpand-1 gets as its second
;;; argument.  In fact, that is exactly where it comes from.  This is kind of
;;; kludgy since Common Lisp is somewhat screwed up in this respect.
;;; Hopefully Common Lisp will fix this soon.  For more info see:
;;; MAKE-LEXICAL-ENVIRONMENT
(defvar *environment*)

;;;
;;; With new contour is used to enter a new lexical binding contour which
;;; inherits from the exisiting one.  I admit that using with-new-contour is
;;; often overkill.  It would suffice for the the walker to rebind
;;; *lexical-variables* and *declarations* when walking LET and rebind
;;; *environment* and *declarations* when walking MACROLET etc.
;;; WITH-NEW-CONTOUR is much more convenient and just as correct.
;;; 
(defmacro with-new-contour (&body body)
  `(let ((*declarations* ())			;If Common Lisp got an
						;unspecial declaration
						;this would need to be
						;re-worked.
         (*lexical-variables* *lexical-variables*)
         (*environment* *environment*))
     . ,body))

(defmacro note-lexical-binding (thing)
  `(push ,thing *lexical-variables*))

(defmacro note-declaration (declaration)
  `(push ,declaration *declarations*))


(defun variable-lexically-boundp (var)
  (if (not (boundp '*walk-function*))
      :unsure
      (values (member var *lexical-variables* :test (function eq))
	      (variable-special-p var) 't)))

(defun variable-lexical-p (var)
  (if (not (boundp '*walk-function*))
      :unsure
      (and (not (eq (variable-special-p var) 't))
	   (member var *lexical-variables* :test (function eq)))))

(defun variable-special-p (var)
  (if (not (boundp '*walk-function*))
      (or (variable-globally-special-p var) :unsure)
      (or (dolist (decl *declarations*)
	    (and (eq (car decl) 'special)
		 (member var (cdr decl) :test #'eq)
		 (return t)))
	  (variable-globally-special-p var))))

;;;
;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
;;; declared globally special.  Any particular CommonLisp implementation
;;; should customize this function accordingly and send their customization
;;; back.
;;;
;;; The default version of variable-globally-special-p is probably pretty
;;; slow, so it uses *globally-special-variables* as a cache to remember
;;; variables that it has already figured out are globally special.
;;;
;;; This would need to be reworked if an unspecial declaration got added to
;;; Common Lisp.
;;;
;;; Common Lisp nit:
;;;   variable-globally-special-p should be defined in Common Lisp.
;;;
#-(or Symbolics Lucid Xerox Excl KCL (and dec vax common) :CMU HP GCLisp TI
      pyramid)
(defvar *globally-special-variables* ())

(defun variable-globally-special-p (symbol)
  #+Symbolics                   (si:special-variable-p symbol)
  #+(or Lucid TI)               (get symbol 'special)
  #+Xerox                       (il:variable-globally-special-p symbol)
  #+(and dec vax common)        (get symbol 'system::globally-special)
  #+KCL			        (si:specialp symbol)
  #+excl                        (get symbol 'excl::.globally-special.)
  #+:CMU			(or (get symbol 'lisp::globally-special)
				    (get symbol
					 'clc::globally-special-in-compiler))
  #+HP                          (member (get symbol 'impl:vartype)
					'(impl:fluid impl:global)
					:test #'eq)
  #+:GCLISP                     (gclisp::special-p symbol)
  #+pyramid			(or (get symbol 'lisp::globally-special)
				    (get symbol
					 'clc::globally-special-in-compiler))
  #-(or Symbolics Lucid Xerox Excl KCL (and dec vax common) :CMU HP GCLisp TI
	pyramid)
  (or (not (null (member symbol *globally-special-variables* :test #'eq)))
      (when (eval `(flet ((ref () ,symbol))
		     (let ((,symbol '#,(list nil)))
		       (and (boundp ',symbol) (eq ,symbol (ref))))))
	(push symbol *globally-special-variables*)
	t)))


  ;;   
;;;;;; Handling of special forms (the infamous 24).
  ;;
;;;
;;; and I quote...
;;; 
;;;     The set of special forms is purposely kept very small because
;;;     any program analyzing program (read code walker) must have
;;;     special knowledge about every type of special form. Such a
;;;     program needs no special knowledge about macros...
;;;
;;; So all we have to do here is a define a way to store and retrieve
;;; templates which describe how to walk the 24 special forms and we are all
;;; set...
;;;
;;; Well, its a nice concept, and I have to admit to being naive enough that
;;; I believed it for a while, but not everyone takes having only 24 special
;;; forms as seriously as might be nice.  There are (at least) 3 ways to
;;; lose:
;;
;;;   1 - Implementation x implements a Common Lisp special form as a macro
;;;       which expands into a special form which:
;;;         - 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) by
;;;       checking to see if there is a template defined for something
;;;       before we check to see if we we can macroexpand it.
;;;
;;;   2 - Implementation x implements a Common Lisp macro as a special form.
;;;
;;;     * This is a screw, but not so bad, we save ourselves from it by
;;;       defining extra templates for the macros which are *likely* to
;;;       be implemented as special forms.  (DO, DO* ...)
;;;
;;;   3 - Implementation x has a special form which is not on the list of
;;;       Common Lisp special forms.
;;;
;;;     * This is a bad sort of a screw and happens more than I would like
;;;       to think, especially in the implementations which provide more
;;;       than just Common Lisp (3600, Xerox etc.).
;;;       The fix is not terribly staisfactory, but will have to do for
;;;       now.  There is a hook in get walker-template which can get a
;;;       template from the implementation's own walker.  That template
;;;       has to be converted, and so it may be that the right way to do
;;;       this would actually be for that implementation to provide an
;;;       interface to its walker which looks like the interface to this
;;;       walker.
;;;

(eval-when (compile load eval)

(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
  `(get ,x 'walker-template))		   ;Golden Common Lisp doesn't hack
					   ;compile time definition of macros
					   ;right for setf.

(defmacro define-walker-template (name template)
  `(eval-when (load eval)
     (setf (get-walker-template-internal ',name) ',template)))
)

(defun get-walker-template (x)
  (cond ((symbolp x)
	 (or (get-walker-template-internal x)
	     (get-implementation-dependent-walker-template x)))
	((and (listp x) (eq (car x) 'lambda))
	 '(lambda repeat (eval)))
	((and (listp x) (eq (car x) 'lambda))
	 '(call repeat (eval)))))

(defun get-implementation-dependent-walker-template (x)
  (declare (ignore x))
  ())


  ;;   
;;;;;; The actual templates
  ;;   

(define-walker-template BLOCK                (NIL NIL REPEAT (EVAL)))
(define-walker-template CATCH                (NIL EVAL REPEAT (EVAL)))
(define-walker-template COMPILER-LET         walk-compiler-let)
(define-walker-template DECLARE              walk-unexpected-declare)
(define-walker-template EVAL-WHEN            (NIL QUOTE REPEAT (EVAL)))
(define-walker-template FLET                 walk-flet/labels)
(define-walker-template FUNCTION             (NIL CALL))
(define-walker-template GO                   (NIL QUOTE))
(define-walker-template IF                   (NIL TEST RETURN RETURN))
(define-walker-template LABELS               walk-flet/labels)
(define-walker-template LAMBDA               walk-lambda)
(define-walker-template LET                  walk-let)
(define-walker-template LET*                 walk-let*)
(define-walker-template MACROLET             walk-macrolet)
(define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
(define-walker-template MULTIPLE-VALUE-SETQ  (NIL (REPEAT (SET)) EVAL))
(define-walker-template MULTIPLE-VALUE-BIND  walk-multiple-value-bind)
(define-walker-template PROGN                (NIL REPEAT (EVAL)))
(define-walker-template PROGV                (NIL EVAL EVAL REPEAT (EVAL)))
(define-walker-template QUOTE                (NIL QUOTE))
(define-walker-template RETURN-FROM          (NIL QUOTE REPEAT (RETURN)))
(define-walker-template SETQ                 (NIL REPEAT (SET EVAL)))
(define-walker-template TAGBODY              walk-tagbody)
(define-walker-template THE                  (NIL QUOTE EVAL))
(define-walker-template THROW                (NIL EVAL EVAL))
(define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))

;;; The new special form.
;(define-walker-template pcl::LOAD-TIME-EVAL       (NIL EVAL))

;;;
;;; And the extra templates...
;;;
(define-walker-template DO      walk-do)
(define-walker-template DO*     walk-do*)
(define-walker-template PROG    walk-prog)
(define-walker-template PROG*   walk-prog*)
(define-walker-template COND    (NIL REPEAT ((TEST REPEAT (EVAL)))))


  ;;   
;;;;;; WALK-FORM
  ;;   
;;;
;;; The main entry-point is walk-form, calls back in should use walk-form-internal.
;;; 

(defun walk-form (form &key ((:declarations *declarations*) ())
			    ((:lexical-variables *lexical-variables*) ())
			    ((:environment *environment*) ())
			    ((:walk-function *walk-function*)
			     #'(lambda (x y) (declare (ignore y)) x)))
  (walk-form-internal form 'eval))

;;;
;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
;;; takes a form and the current context and walks the form calling itself or
;;; the appropriate template recursively.
;;;
;;;   "It is recommended that a program-analyzing-program process a form
;;;    that is a list whose car is a symbol as follows:
;;;
;;;     1. If the program has particular knowledge about the symbol,
;;;        process the form using special-purpose code.  All of the
;;;        standard special forms should fall into this category.
;;;     2. Otherwise, if macro-function is true of the symbol apply
;;;        either macroexpand or macroexpand-1 and start over.
;;;     3. Otherwise, assume it is a function call. "
;;;     

(defun walk-form-internal (form context
			   &aux newform newnewform
				walk-no-more-p macrop
				fn template)
  ;; First apply the *walk-function* to perform whatever translation
  ;; the user wants to to this form.  If the second value returned
  ;; by *walk-function* is T then we don't recurse...
  (multiple-value-setq (newform walk-no-more-p)
    (funcall *walk-function* form context))
  (cond (walk-no-more-p newform)
	((not (eq form newform)) (walk-form-internal newform context))
	((not (consp newform)) newform)
	((setq template (get-walker-template (setq fn (car newform))))
         (if (symbolp template)
             (funcall template newform context)
             (walk-template newform template context)))
	((progn (multiple-value-setq (newnewform macrop)
		  (macroexpand-1 newform *environment*))
		macrop)
	 (walk-form-internal newnewform context))
	((and (symbolp fn)
	      (not (fboundp fn))
	      (special-form-p fn))
	 (error
	   "~S is a special form, not defined in the CommonLisp manual.~%~
            This code walker doesn't know how to walk it.  Please define a~%~
            template for this special form and try again."
	   fn))
	(t
         ;; Otherwise, walk the form as if its just a standard function
         ;; call using a template for standard function call.
         (walk-template newform '(call repeat (eval)) context))))

(defun walk-template (form template context)
  (if (atom template)
      (ecase template
        ((QUOTE NIL) form)
        ((EVAL FUNCTION TEST EFFECT RETURN)
         (walk-form-internal form :EVAL))
        (SET
          (walk-form-internal form :SET))
        ((LAMBDA CALL)
	 (if (symbolp form)
	     form
	     (walk-lambda form context))))
      (case (car template)
        (IF
          (let ((*walk-form* form))
            (walk-template form
			   (if (if (listp (cadr template))
				   (eval (cadr template))
				   (funcall (cadr template) form))
			       (caddr template)
			       (cadddr template))
			   context)))
        (REPEAT
          (walk-template-handle-repeat form
                                       (cdr template)
				       ;; For the case where nothing happens
				       ;; after the repeat optimize out the
				       ;; call to length.
				       (if (null (cddr template))
					   ()
					   (nthcdr (- (length form)
						      (length
							(cddr template)))
						   form))
                                       context))
        (REMOTE
          (walk-template form (cadr template) context))
        (otherwise
          (cond ((atom form) form)
                (t (recons form
                           (walk-template
			     (car form) (car template) context)
                           (walk-template
			     (cdr form) (cdr template) context))))))))

(defun walk-template-handle-repeat (form template stop-form context)
  (if (eq form stop-form)
      (walk-template form (cdr template) context)
      (walk-template-handle-repeat-1 form
				     template
				     (car template)
				     stop-form
				     context)))

(defun walk-template-handle-repeat-1 (form template repeat-template
					   stop-form context)
  (cond ((null form) ())
        ((eq form stop-form)
         (if (null repeat-template)
             (walk-template stop-form (cdr template) context)       
             (error "While handling repeat:
                     ~%~Ran into stop while still in repeat template.")))
        ((null repeat-template)
         (walk-template-handle-repeat-1
	   form template (car template) stop-form context))
        (t
         (recons form
                 (walk-template (car form) (car repeat-template) context)
                 (walk-template-handle-repeat-1 (cdr form)
						template
						(cdr repeat-template)
						stop-form
						context)))))

(defun recons (x car cdr)
  (if (or (not (eq (car x) car))
          (not (eq (cdr x) cdr)))
      (cons car cdr)
      x))

(defun relist* (x &rest args)
  (relist*-internal x args))

(defun relist*-internal (x args)
  (if (null (cdr args))
      (car args)
      (recons x (car args) (relist*-internal (cdr x) (cdr args)))))


  ;;   
;;;;;; Special walkers
  ;;

(defun walk-declarations (body fn
			       &optional doc-string-p declarations old-body
			       &aux (form (car body)) macrop new-form)
  (cond ((and (stringp form)			;might be a doc string
              (cdr body)			;isn't the returned value
              (null doc-string-p)		;no doc string yet
              (null declarations))		;no declarations yet
         (recons body
                 form
                 (walk-declarations (cdr body) fn t)))
        ((and (listp form) (eq (car form) 'declare))
         ;; Got ourselves a real live declaration.  Record it, look for more.
         (dolist (declaration (cdr form))
           (note-declaration declaration)
           (push declaration declarations))
         (recons body
                 form
                 (walk-declarations
		   (cdr body) fn doc-string-p declarations)))
        ((and form
	      (listp form)
	      (null (get-walker-template (car form)))
	      (progn
		(multiple-value-setq (new-form macrop)
				     (macroexpand-1 (car form) *environment*))
		macrop))
	 ;; This form was a call to a macro.  Maybe it expanded
	 ;; into a declare?  Recurse to find out.
	 (walk-declarations (recons body new-form (cdr body))
			    fn doc-string-p declarations
			    (or old-body body)))
	(t
	 ;; Now that we have walked and recorded the declarations,
	 ;; call the function our caller provided to expand the body.
	 ;; We call that function rather than passing the real-body
	 ;; back, because we are RECONSING up the new body.
	 (funcall fn (or old-body body)))))


(defun walk-unexpected-declare (form context)
  (declare (ignore context))
  (warn "Encountered declare ~S in a place where a declare was not expected."
	form)
  form)

(defun walk-arglist (arglist context &optional (destructuringp nil) &aux arg)
  (cond ((null arglist) ())
        ((symbolp (setq arg (car arglist)))
         (or (member arg lambda-list-keywords :test #'eq)
             (note-lexical-binding arg))
         (recons arglist
                 arg
                 (walk-arglist (cdr arglist)
                               context
                               (and destructuringp
				    (not (member arg lambda-list-keywords
						 :test #'eq))))))
        ((consp arg)
         (prog1 (if destructuringp
                    (walk-arglist arg context destructuringp)
                    (recons arglist
                            (relist* arg
                                     (car arg)
                                     (walk-form-internal (cadr arg) 'eval)
                                     (cddr arg))
                            (walk-arglist (cdr arglist) context nil)))
                (if (symbolp (car arg))
                    (note-lexical-binding (car arg))
                    (note-lexical-binding (cadar arg)))
                (or (null (cddr arg))
                    (not (symbolp (caddr arg)))
                    (note-lexical-binding arg))))
          (t
	   (error "Can't understand something in the arglist ~S" arglist))))

(defun walk-let (form context)
  (walk-let/let* form context nil))

(defun walk-let* (form context)
  (walk-let/let* form context t))

(defun walk-prog (form context)
  (walk-let/let* form context nil))

(defun walk-prog* (form context)
  (walk-let/let* form context t))

(defun walk-do (form context)
  (walk-do/do* form context nil))

(defun walk-do* (form context)
  (walk-do/do* form context t))

(defun walk-let/let* (form context sequentialp)
  (let ((old-declarations *declarations*)
	(old-lexical-variables *lexical-variables*))
    (with-new-contour
      (let* ((let/let* (car form))
             (bindings (cadr form))
             (body (cddr form))
             walked-bindings
             (walked-body
               (walk-declarations 
                 body
                 #'(lambda (real-body)
                     (setq walked-bindings
                           (walk-bindings-1 bindings
					    old-declarations
					    old-lexical-variables
					    context
					    sequentialp))
                     (walk-template real-body '(repeat (eval)) context)))))
        (relist*
	  form let/let* walked-bindings walked-body)))))

(defun walk-do/do* (form context sequentialp)
  (let ((old-declarations *declarations*)
	(old-lexical-variables *lexical-variables*))
    (with-new-contour
      (let* ((do/do* (car form))
             (bindings (cadr form))
             (end-test (caddr form))
             (body (cdddr form))
             walked-bindings
             (walked-body
               (walk-declarations
                 body
                 #'(lambda (real-body)
                     (setq walked-bindings
                           (walk-bindings-1 bindings
					    old-declarations
					    old-lexical-variables
					    context
					    sequentialp))
                     (walk-template real-body '(repeat (eval)) context)))))
        (relist* form
                 do/do*
                 (walk-bindings-2 bindings walked-bindings context)
                 (walk-template end-test '(test repeat (eval)) context)
                 walked-body)))))

(defun walk-multiple-value-bind (form context)
  (let ((old-declarations *declarations*)
	(old-lexical-variables *lexical-variables*))
    (with-new-contour
      (let* ((mvb (car form))
             (bindings (cadr form))
	     (mv-form (walk-template (caddr form) 'eval context))
             (body (cdddr form))
             walked-bindings
             (walked-body
               (walk-declarations 
                 body
                 #'(lambda (real-body)
                     (setq walked-bindings
                           (walk-bindings-1 bindings
					    old-declarations
					    old-lexical-variables
					    context
					    nil))
                     (walk-template real-body '(repeat (eval)) context)))))
        (relist* form mvb walked-bindings mv-form walked-body)))))
                            
(defun walk-bindings-1 (bindings old-declarations old-lexical-variables
				 context sequentialp)
  (and bindings
       (let ((binding (car bindings)))
         (recons bindings
                 (if (symbolp binding)
                     (prog1 binding
                            (note-lexical-binding binding))
                     (prog1 (let ((*declarations* old-declarations)
				  (*lexical-variables*
				    (if sequentialp
					*lexical-variables*
					old-lexical-variables)))
                              (relist* binding
                                       (car binding)
                                       (walk-form-internal (cadr binding)
							   context)
                                       (cddr binding)))	;save cddr for DO/DO*
						        ;it is the next value
						        ;form. Don't walk it
						        ;now though.
                            (note-lexical-binding (car binding))))
                 (walk-bindings-1 (cdr bindings)
				  old-declarations old-lexical-variables
				  context sequentialp)))))

(defun walk-bindings-2 (bindings walked-bindings context)
  (and bindings
       (let ((binding (car bindings))
             (walked-binding (car walked-bindings)))
         (recons bindings
		 (if (symbolp binding)
		     binding
		     (relist* binding
			      (car walked-binding)
			      (cadr walked-binding)
			      (walk-template (cddr binding) '(eval) context)))		 
                 (walk-bindings-2 (cdr bindings)
				  (cdr walked-bindings)
				  context)))))

(defun walk-lambda (form context)
  (with-new-contour    
    (let* ((arglist (cadr form))
           (body (cddr form))
           (walked-arglist nil)
           (walked-body
             (walk-declarations body
	       #'(lambda (real-body)
		   (setq walked-arglist (walk-arglist arglist context))
		   (walk-template real-body '(repeat (eval)) context)))))
      (relist* form
               (car form)
	       walked-arglist
               walked-body))))

(defun walk-tagbody (form context)
  (recons form (car form) (walk-tagbody-1 (cdr form) context)))

(defun walk-tagbody-1 (form context)
  (and form
       (recons form
               (walk-form-internal (car form)
				   (if (symbolp (car form)) 'quote context))
               (walk-tagbody-1 (cdr form) context))))

(defun walk-compiler-let (form context)
  (with-new-contour
    (let ((vars ())
	  (vals ()))
      (dolist (binding (cadr form))
	(cond ((symbolp binding) (push binding vars) (push nil vals))
	      (t
	       (push (car binding) vars)
	       (push (eval (cadr binding)) vals))))
      (relist* form
               (car form)
               (cadr form)
               (progv vars vals
                 (note-declaration (cons 'special vars))
                 (walk-template (cddr form) '(repeat (eval)) context))))))

(defun walk-macrolet (form context)
  (labels ((walk-definitions (definitions)
             (and (not (null definitions))
                  (let ((definition (car definitions)))
                    (recons definitions
                            (with-new-contour
                              (relist* definition
                                       (car definition)
                                       (walk-arglist (cadr definition)
						     context t)
                                       (walk-declarations (cddr definition)
					 #'(lambda (real-body)
					     (walk-template
					       real-body
					       '(repeat (eval))
					       context)))))
                            (walk-definitions (cdr definitions)))))))
    (with-new-contour
      (relist* form
               (car form)
               (walk-definitions (cadr form))
               (progn (setq *environment*
			    (make-lexical-environment form *environment*))
                      (walk-declarations (cddr form)
			#'(lambda (real-body)
			    (walk-template real-body
						    '(repeat (eval))
						    context))))))))

(defun walk-flet/labels (form context)
  (with-new-contour
    (labels ((walk-definitions (definitions)
               (if (null definitions)
                   ()
                   (recons definitions
                           (walk-lambda (car definitions) context)
                           (walk-definitions (cdr definitions)))))
             (update-environment ()
               (setq *environment*
		     (make-lexical-environment form *environment*))))
      (relist* form
               (car form)
               (ecase (car form)
                 (flet
                   (prog1 (walk-definitions (cadr form))
                          (update-environment)))
                 (labels
                   (update-environment)
                   (walk-definitions (cadr form))))
               (walk-declarations (cddr form)
		 #'(lambda (real-body)
		     (walk-template real-body '(repeat (eval)) context)))))))

;;; make-lexical-environemnt is kind of gross.  It would be less gross if
;;; EVAL took an environment argument.
;;;
;;; Common Lisp nit:
;;;    if Common Lisp should provide mechanisms for playing with
;;;    environments explicitly.  making them, finding out what
;;;    functions are bound in them etc.  Maybe compile should
;;;    take an environment argument too?
;;;    

#-(or GCLisp)
(defun make-lexical-environment (macrolet/flet/labels-form environment)
  (if (null (cadr macrolet/flet/labels-form))
      environment
      (evalhook (list (car macrolet/flet/labels-form)
		      (cadr macrolet/flet/labels-form)
		      ()			;Fake out macroexpansion which
						;may be looking for declares.
						;Actually, this should be a
						;no-op since declarations are
						;not allowed to appear here,
						;but...
		      (list 'make-lexical-environment-2))
		'make-lexical-environment-1
		()
		environment)))

(defun make-lexical-environment-1 (form env)
  (setq form (macroexpand form #-excl env
			       #+excl (cadr env)))
  (evalhook form  'make-lexical-environment-1 nil env))

(defmacro make-lexical-environment-2 (&environment env)
  (list 'quote (copy-tree env)))

#+GCLisp
(defun make-lexical-environment (mfl-form env)
  (do ((new-entries nil)
       (new-funcs (second mfl-form) (cdr new-funcs)))
      ((null new-funcs)
       (if (eq :compiler-menv (car env))
	   `(:compiler-menv ,@new-entries ,@(cdr env))
	   (append new-entries env)))
    (let ((lex-fn-entry
	    (ecase (car mfl-form)
	      ((flet labels) (cons (caar new-funcs) nil))
	      (macrolet
		(let* ((lisp::*defmacro-unrestricted-p* t)
		       (expander (cdr (lisp::defmac-trans
					(cadr (car new-funcs))
					(cddr (car new-funcs))))))
		  (declare (special lisp::*defmacro-unrestricted-p*))
		  (cons (caar new-funcs)
			(if (eq :compiler-menv (car env))
			    `(,(gensym) ,expander)
			    `(MACRO . ,expander))))))))
      (push lex-fn-entry new-entries))))

  ;;   
;;;;;; Tests tests tests
  ;;

#|

(defmacro take-it-out-for-a-test-walk (form)
  `(progn 
     (terpri)
     (terpri)
     (let ((copy-of-form (copy-tree ',form))
           (result (walk-form ',form :walk-function
                              '(lambda (x y)
                                 (format t "~&Form: ~S ~3T Context: ~A" x y)
                                 (when (symbolp x)
				   (multiple-value-bind (lexical special)
				       (variable-lexically-boundp x)
                                     (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.")))
       (#+Symbolics zl:grind-top-level
        #-Symbolics print
                                  result)
       result)))

(defun foo (&rest ignore) ())

(defmacro bar (x) `'(global-bar-expanded ,x))

(defun baz (&rest ignore) ())

(take-it-out-for-a-test-walk (foo arg1 arg2 arg3))
(take-it-out-for-a-test-walk (foo (baz 1 2) (baz 3 4 5)))

(take-it-out-for-a-test-walk (block block-name a b c))
(take-it-out-for-a-test-walk (block block-name (foo a) b c))

(take-it-out-for-a-test-walk (catch catch-tag (foo a) b c))
(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
(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))


(take-it-out-for-a-test-walk (flet ((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) (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 1))))

(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)))
	     :walk-function #'(lambda (form context)
				(when (and (symbolp form)
					   (variable-lexical-p form))
				  (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.")))

|#

()