src/pcl/walk.lisp

   1 ;;;; a simple code walker for PCL
   2 ;;;;
   3 ;;;; The code which implements the macroexpansion environment manipulation
   4 ;;;; mechanisms is in the first part of the file, the real walker follows it.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8
   9 ;;;; This software is derived from software originally released by Xerox
  10 ;;;; Corporation. Copyright and release statements follow. Later modifications
  11 ;;;; to the software are in the public domain and are provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  13 ;;;; information.
  14
  15 ;;;; copyright information from original PCL sources:
  16 ;;;;
  17 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  18 ;;;; All rights reserved.
  19 ;;;;
  20 ;;;; Use and copying of this software and preparation of derivative works based
  21 ;;;; upon this software are permitted. Any distribution of this software or
  22 ;;;; derivative works must comply with all applicable United States export
  23 ;;;; control laws.
  24 ;;;;
  25 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  26 ;;;; warranty about the software, its performance or its conformity to any
  27 ;;;; specification.
  28
  29 (in-package "SB-WALKER")
  30 \f
  31 ;;;; environment frobbing stuff
  32
  33 ;;; Here in the original PCL were implementations of the
  34 ;;; implementation-specific environment hacking functions for each of the
  35 ;;; implementations this walker had been ported to. This functionality was
  36 ;;; originally factored out in order to make PCL portable from one Common Lisp
  37 ;;; to another. As of 19981107, that portability was fairly stale and (because
  38 ;;; of the scarcity of CLTL1 implementations and the strong interdependence of
  39 ;;; the rest of ANSI Common Lisp on the CLOS system) fairly irrelevant. It was
  40 ;;; fairly thoroughly put out of its misery by WHN in his quest to clean up the
  41 ;;; system enough that it can be built from scratch using any ANSI Common Lisp.
  42 ;;;
  43 ;;; This code just hacks 'macroexpansion environments'. That is, it is only
  44 ;;; concerned with the function binding of symbols in the environment. The
  45 ;;; walker needs to be able to tell if the symbol names a lexical macro or
  46 ;;; function, and it needs to be able to build environments which contain
  47 ;;; lexical macro or function bindings. It must be able, when walking a
  48 ;;; MACROLET, FLET or LABELS form to construct an environment which reflects
  49 ;;; the bindings created by that form. Note that the environment created
  50 ;;; does NOT have to be sufficient to evaluate the body, merely to walk its
  51 ;;; body. This means that definitions do not have to be supplied for lexical
  52 ;;; functions, only the fact that that function is bound is important. For
  53 ;;; macros, the macroexpansion function must be supplied.
  54 ;;;
  55 ;;; This code is organized in a way that lets it work in implementations that
  56 ;;; stack cons their environments. That is reflected in the fact that the
  57 ;;; only operation that lets a user build a new environment is a WITH-BODY
  58 ;;; macro which executes its body with the specified symbol bound to the new
  59 ;;; environment. No code in this walker or in PCL will hold a pointer to
  60 ;;; these environments after the body returns. Other user code is free to do
  61 ;;; so in implementations where it works, but that code is not considered
  62 ;;; portable.
  63 ;;;
  64 ;;; There are 3 environment hacking tools. One macro,
  65 ;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new environments, and
  66 ;;; two functions, ENVIRONMENT-FUNCTION and ENVIRONMENT-MACRO, which are used
  67 ;;; to access the bindings of existing environments
  68
  69 ;;; In SBCL, as in CMU CL before it, the environment is represented
  70 ;;; with a structure that holds alists for the functional things,
  71 ;;; variables, blocks, etc. Only the c::lexenv-functions slot is
  72 ;;; relevant. It holds: Alist (name . what), where What is either a
  73 ;;; Functional (a local function) or a list (MACRO . <function>) (a
  74 ;;; local macro, with the specifier expander.) Note that Name may be a
  75 ;;; (SETF <name>) function.
  76
  77 (defmacro with-augmented-environment
  78     ((new-env old-env &key functions macros) &body body)
  79   `(let ((,new-env (with-augmented-environment-internal ,old-env
  80                                                         ,functions
  81                                                         ,macros)))
  82      ,@body))
  83
  84 ;;; KLUDGE: In CMU CL, when X was an arbitrary list, even one which did
  85 ;;; not name a function or describe a lambda expression, (EVAL
  86 ;;; `(FUNCTION ,X)) would still return a FUNCTION object, and no error
  87 ;;; would be signalled until/unless you tried to FUNCALL the resulting
  88 ;;; FUNCTION object. (This behavior was also present in (COERCE X
  89 ;;; 'FUNCTION), which was defined in terms of (EVAL `(FUNCTION ,X)).)
  90 ;;; This function provides roughly the same behavior as the old CMU CL
  91 ;;; (COERCE X 'FUNCTION), for the benefit of PCL code which relied
  92 ;;; on being able to coerce bogus things without raising errors
  93 ;;; as long as it never tried to actually call them.
  94 (defun bogo-coerce-to-function (x)
  95   (or (ignore-errors (coerce x 'function))
  96       (lambda (&rest rest)
  97         (declare (ignore rest))
  98         (error "can't FUNCALL bogo-coerced-to-function ~S" x))))
  99
 100 (defun with-augmented-environment-internal (env functions macros)
 101   ;; Note: In order to record the correct function definition, we
 102   ;; would have to create an interpreted closure, but the
 103   ;; with-new-definition macro down below makes no distinction between
 104   ;; FLET and LABELS, so we have no idea what to use for the
 105   ;; environment. So we just blow it off, 'cause anything real we do
 106   ;; would be wrong. We still have to make an entry so we can tell
 107   ;; functions from macros.
 108   (let ((env (or env (sb-kernel:make-null-lexenv))))
 109     (sb-c::make-lexenv
 110       :default env
 111       :functions
 112       (append (mapcar (lambda (f)
 113                         (cons (car f) (sb-c::make-functional :lexenv env)))
 114                       functions)
 115               (mapcar (lambda (m)
 116                         (list* (car m)
 117                                'sb-c::macro
 118                                (bogo-coerce-to-function (cadr m))))
 119                       macros)))))
 120
 121 (defun environment-function (env fn)
 122   (when env
 123     (let ((entry (assoc fn (sb-c::lexenv-functions env) :test #'equal)))
 124       (and entry
 125            (sb-c::functional-p (cdr entry))
 126            (cdr entry)))))
 127
 128 (defun environment-macro (env macro)
 129   (when env
 130     (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq)))
 131       (and entry
 132            (eq (cadr entry) 'sb-c::macro)
 133            (function-lambda-expression (cddr entry))))))
 134
 135 (defmacro with-new-definition-in-environment
 136           ((new-env old-env macrolet/flet/labels-form) &body body)
 137   (let ((functions (make-symbol "Functions"))
 138         (macros (make-symbol "Macros")))
 139     `(let ((,functions ())
 140            (,macros ()))
 141        (ecase (car ,macrolet/flet/labels-form)
 142          ((flet labels)
 143           (dolist (fn (cadr ,macrolet/flet/labels-form))
 144             (push fn ,functions)))
 145          ((macrolet)
 146           (dolist (mac (cadr ,macrolet/flet/labels-form))
 147             (push (list (car mac)
 148                         (convert-macro-to-lambda (cadr mac)
 149                                                  (cddr mac)
 150                                                  (string (car mac))))
 151                   ,macros))))
 152        (with-augmented-environment
 153               (,new-env ,old-env :functions ,functions :macros ,macros)
 154          ,@body))))
 155
 156 (defun convert-macro-to-lambda (llist body &optional (name "dummy macro"))
 157   (let ((gensym (make-symbol name)))
 158     (eval `(defmacro ,gensym ,llist ,@body))
 159     (macro-function gensym)))
 160 \f
 161 ;;; Now comes the real walker.
 162 ;;;
 163 ;;; As the walker walks over the code, it communicates information to itself
 164 ;;; about the walk. This information includes the walk function, variable
 165 ;;; bindings, declarations in effect etc. This information is inherently
 166 ;;; lexical, so the walker passes it around in the actual environment the
 167 ;;; walker passes to macroexpansion functions. This is what makes the
 168 ;;; nested-walk-form facility work properly.
 169 (defmacro walker-environment-bind ((var env &rest key-args)
 170                                       &body body)
 171   `(with-augmented-environment
 172      (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
 173      .,body))
 174
 175 (defvar *key-to-walker-environment* (gensym))
 176
 177 (defun env-lock (env)
 178   (environment-macro env *key-to-walker-environment*))
 179
 180 (defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
 181                                            (walk-form nil wfop)
 182                                            (declarations nil decp)
 183                                            (lexical-variables nil lexp))
 184   (let ((lock (environment-macro env *key-to-walker-environment*)))
 185     (list
 186       (list *key-to-walker-environment*
 187             (list (if wfnp walk-function     (car lock))
 188                   (if wfop walk-form     (cadr lock))
 189                   (if decp declarations      (caddr lock))
 190                   (if lexp lexical-variables (cadddr lock)))))))
 191
 192 (defun env-walk-function (env)
 193   (car (env-lock env)))
 194
 195 (defun env-walk-form (env)
 196   (cadr (env-lock env)))
 197
 198 (defun env-declarations (env)
 199   (caddr (env-lock env)))
 200
 201 (defun env-lexical-variables (env)
 202   (cadddr (env-lock env)))
 203
 204 (defun note-declaration (declaration env)
 205   (push declaration (caddr (env-lock env))))
 206
 207 (defun note-lexical-binding (thing env)
 208   (push (list thing :lexical-var) (cadddr (env-lock env))))
 209
 210 (defun variable-lexical-p (var env)
 211   (let ((entry (member var (env-lexical-variables env) :key #'car)))
 212     (when (eq (cadar entry) :lexical-var)
 213       entry)))
 214
 215 (defun variable-symbol-macro-p (var env)
 216   (let ((entry (member var (env-lexical-variables env) :key #'car)))
 217     (when (eq (cadar entry) :macro)
 218       entry)))
 219
 220 (defvar *variable-declarations* '(special))
 221
 222 (defun variable-declaration (declaration var env)
 223   (if (not (member declaration *variable-declarations*))
 224       (error "~S is not a recognized variable declaration." declaration)
 225       (let ((id (or (variable-lexical-p var env) var)))
 226         (dolist (decl (env-declarations env))
 227           (when (and (eq (car decl) declaration)
 228                      (eq (cadr decl) id))
 229             (return decl))))))
 230
 231 (defun variable-special-p (var env)
 232   (or (not (null (variable-declaration 'special var env)))
 233       (variable-globally-special-p var)))
 234
 235 (defun variable-globally-special-p (symbol)
 236   (eq (sb-int:info :variable :kind symbol) :special))
 237 \f
 238 ;;;; handling of special forms
 239
 240 ;;; Here are some comments from the original PCL on the difficulty of doing
 241 ;;; this portably across different CLTL1 implementations. This is no longer
 242 ;;; directly relevant because this code now only runs on SBCL, but the comments
 243 ;;; are retained for culture: they might help explain some of the design
 244 ;;; decisions which were made in the code.
 245 ;;;
 246 ;;; and I quote...
 247 ;;;
 248 ;;;     The set of special forms is purposely kept very small because
 249 ;;;     any program analyzing program (read code walker) must have
 250 ;;;     special knowledge about every type of special form. Such a
 251 ;;;     program needs no special knowledge about macros...
 252 ;;;
 253 ;;; So all we have to do here is a define a way to store and retrieve
 254 ;;; templates which describe how to walk the 24 special forms and we are all
 255 ;;; set...
 256 ;;;
 257 ;;; Well, its a nice concept, and I have to admit to being naive enough that
 258 ;;; I believed it for a while, but not everyone takes having only 24 special
 259 ;;; forms as seriously as might be nice. There are (at least) 3 ways to
 260 ;;; lose:
 261 ;;
 262 ;;;   1 - Implementation x implements a Common Lisp special form as a macro
 263 ;;;       which expands into a special form which:
 264 ;;;      - Is a common lisp special form (not likely)
 265 ;;;      - Is not a common lisp special form (on the 3600 IF --> COND).
 266 ;;;
 267 ;;;     * We can safe ourselves from this case (second subcase really) by
 268 ;;;       checking to see whether there is a template defined for something
 269 ;;;       before we check to see whether we can macroexpand it.
 270 ;;;
 271 ;;;   2 - Implementation x implements a Common Lisp macro as a special form.
 272 ;;;
 273 ;;;     * This is a screw, but not so bad, we save ourselves from it by
 274 ;;;       defining extra templates for the macros which are *likely* to
 275 ;;;       be implemented as special forms. (DO, DO* ...)
 276 ;;;
 277 ;;;   3 - Implementation x has a special form which is not on the list of
 278 ;;;       Common Lisp special forms.
 279 ;;;
 280 ;;;     * This is a bad sort of a screw and happens more than I would like
 281 ;;;       to think, especially in the implementations which provide more
 282 ;;;       than just Common Lisp (3600, Xerox etc.).
 283 ;;;       The fix is not terribly staisfactory, but will have to do for
 284 ;;;       now. There is a hook in get walker-template which can get a
 285 ;;;       template from the implementation's own walker. That template
 286 ;;;       has to be converted, and so it may be that the right way to do
 287 ;;;       this would actually be for that implementation to provide an
 288 ;;;       interface to its walker which looks like the interface to this
 289 ;;;       walker.
 290
 291 ;;; FIXME: In SBCL, we probably don't need to put DEFMACROs inside EVAL-WHEN.
 292 (eval-when (:compile-toplevel :load-toplevel :execute)
 293
 294 (defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
 295   `(get ,x 'walker-template))              ;Golden Common Lisp doesn't hack
 296                                            ;compile time definition of macros
 297                                            ;right for setf.
 298
 299 (defmacro define-walker-template (name
 300                                   &optional (template '(nil repeat (eval))))
 301   `(eval-when (:load-toplevel :execute)
 302      (setf (get-walker-template-internal ',name) ',template)))
 303
 304 ) ; EVAL-WHEN
 305
 306 (defun get-walker-template (x)
 307   (cond ((symbolp x)
 308          (or (get-walker-template-internal x)
 309              (get-implementation-dependent-walker-template x)))
 310         ((and (listp x) (eq (car x) 'lambda))
 311          '(lambda repeat (eval)))
 312         (t
 313          (error "can't get template for ~S" x))))
 314
 315 ;;; FIXME: This can go away in SBCL.
 316 (defun get-implementation-dependent-walker-template (x)
 317   (declare (ignore x))
 318   ())
 319 \f
 320 ;;;; the actual templates
 321
 322 ;;; ANSI special forms
 323 (define-walker-template block           (nil nil repeat (eval)))
 324 (define-walker-template catch           (nil eval repeat (eval)))
 325 (define-walker-template declare       walk-unexpected-declare)
 326 (define-walker-template eval-when           (nil quote repeat (eval)))
 327 (define-walker-template flet             walk-flet)
 328 (define-walker-template function             (nil call))
 329 (define-walker-template go                 (nil quote))
 330 (define-walker-template if                 walk-if)
 331 (define-walker-template labels         walk-labels)
 332 (define-walker-template lambda         walk-lambda)
 333 (define-walker-template let               walk-let)
 334 (define-walker-template let*             walk-let*)
 335 (define-walker-template locally       walk-locally)
 336 (define-walker-template macrolet             walk-macrolet)
 337 (define-walker-template multiple-value-call  (nil eval repeat (eval)))
 338 (define-walker-template multiple-value-prog1 (nil return repeat (eval)))
 339 (define-walker-template multiple-value-setq  walk-multiple-value-setq)
 340 (define-walker-template multiple-value-bind  walk-multiple-value-bind)
 341 (define-walker-template progn           (nil repeat (eval)))
 342 (define-walker-template progv           (nil eval eval repeat (eval)))
 343 (define-walker-template quote           (nil quote))
 344 (define-walker-template return-from       (nil quote repeat (return)))
 345 (define-walker-template setq             walk-setq)
 346 (define-walker-template symbol-macrolet      walk-symbol-macrolet)
 347 (define-walker-template tagbody       walk-tagbody)
 348 (define-walker-template the               (nil quote eval))
 349 (define-walker-template throw           (nil eval eval))
 350 (define-walker-template unwind-protect       (nil return repeat (eval)))
 351
 352 ;;; SBCL-only special forms
 353 (define-walker-template sb-ext:truly-the       (nil quote eval))
 354
 355 ;;; extra templates
 356 (define-walker-template do      walk-do)
 357 (define-walker-template do*     walk-do*)
 358 (define-walker-template prog    walk-prog)
 359 (define-walker-template prog*   walk-prog*)
 360 (define-walker-template cond    (nil repeat ((test repeat (eval)))))
 361 \f
 362 (defvar *walk-form-expand-macros-p* nil)
 363
 364 (defun macroexpand-all (form &optional environment)
 365   (let ((*walk-form-expand-macros-p* t))
 366     (walk-form form environment)))
 367
 368 (defun walk-form (form
 369                   &optional environment
 370                             (walk-function
 371                               #'(lambda (subform context env)
 372                                   (declare (ignore context env))
 373                                   subform)))
 374   (walker-environment-bind (new-env environment :walk-function walk-function)
 375     (walk-form-internal form :eval new-env)))
 376
 377 ;;; NESTED-WALK-FORM provides an interface that allows nested macros, each
 378 ;;; of which must walk their body, to just do one walk of the body of the
 379 ;;; inner macro. That inner walk is done with a walk function which is the
 380 ;;; composition of the two walk functions.
 381 ;;;
 382 ;;; This facility works by having the walker annotate the environment that
 383 ;;; it passes to MACROEXPAND-1 to know which form is being macroexpanded.
 384 ;;; If then the &WHOLE argument to the macroexpansion function is eq to
 385 ;;; the ENV-WALK-FORM of the environment, NESTED-WALK-FORM can be certain
 386 ;;; that there are no intervening layers and that a nested walk is OK.
 387 ;;;
 388 ;;; KLUDGE: There are some semantic problems with this facility. In particular,
 389 ;;; if the outer walk function returns T as its WALK-NO-MORE-P value, this will
 390 ;;; prevent the inner walk function from getting a chance to walk the subforms
 391 ;;; of the form. This is almost never what you want, since it destroys the
 392 ;;; equivalence between this NESTED-WALK-FORM function and two separate
 393 ;;; WALK-FORMs.
 394 (defun nested-walk-form (whole form
 395                          &optional environment
 396                                    (walk-function
 397                                      #'(lambda (subform context env)
 398                                          (declare (ignore context env))
 399                                          subform)))
 400   (if (eq whole (env-walk-form environment))
 401       (let ((outer-walk-function (env-walk-function environment)))
 402         (throw whole
 403           (walk-form
 404             form
 405             environment
 406             #'(lambda (f c e)
 407                 ;; First loop to make sure the inner walk function
 408                 ;; has done all it wants to do with this form.
 409                 ;; Basically, what we are doing here is providing
 410                 ;; the same contract walk-form-internal normally
 411                 ;; provides to the inner walk function.
 412                 (let ((inner-result nil)
 413                       (inner-no-more-p nil)
 414                       (outer-result nil)
 415                       (outer-no-more-p nil))
 416                   (loop
 417                     (multiple-value-setq (inner-result inner-no-more-p)
 418                                          (funcall walk-function f c e))
 419                     (cond (inner-no-more-p (return))
 420                           ((not (eq inner-result f)))
 421                           ((not (consp inner-result)) (return))
 422                           ((get-walker-template (car inner-result)) (return))
 423                           (t
 424                            (multiple-value-bind (expansion macrop)
 425                                (walker-environment-bind
 426                                      (new-env e :walk-form inner-result)
 427                                  (macroexpand-1 inner-result new-env))
 428                              (if macrop
 429                                  (setq inner-result expansion)
 430                                  (return)))))
 431                     (setq f inner-result))
 432                   (multiple-value-setq (outer-result outer-no-more-p)
 433                                        (funcall outer-walk-function
 434                                                 inner-result
 435                                                 c
 436                                                 e))
 437                   (values outer-result
 438                           (and inner-no-more-p outer-no-more-p)))))))
 439       (walk-form form environment walk-function)))
 440
 441 ;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
 442 ;;; takes a form and the current context and walks the form calling itself or
 443 ;;; the appropriate template recursively.
 444 ;;;
 445 ;;;   "It is recommended that a program-analyzing-program process a form
 446 ;;;    that is a list whose car is a symbol as follows:
 447 ;;;
 448 ;;;     1. If the program has particular knowledge about the symbol,
 449 ;;;     process the form using special-purpose code. All of the
 450 ;;;     standard special forms should fall into this category.
 451 ;;;     2. Otherwise, if macro-function is true of the symbol apply
 452 ;;;     either macroexpand or macroexpand-1 and start over.
 453 ;;;     3. Otherwise, assume it is a function call. "
 454 (defun walk-form-internal (form context env)
 455   ;; First apply the walk-function to perform whatever translation
 456   ;; the user wants to this form. If the second value returned
 457   ;; by walk-function is T then we don't recurse...
 458   (catch form
 459     (multiple-value-bind (newform walk-no-more-p)
 460         (funcall (env-walk-function env) form context env)
 461       (catch newform
 462         (cond
 463          (walk-no-more-p newform)
 464          ((not (eq form newform))
 465           (walk-form-internal newform context env))
 466          ((not (consp newform))
 467           (let ((symmac (car (variable-symbol-macro-p newform env))))
 468             (if symmac
 469                 (let ((newnewform (walk-form-internal (cddr symmac)
 470                                                       context
 471                                                       env)))
 472                   (if (eq newnewform (cddr symmac))
 473                       (if *walk-form-expand-macros-p* newnewform newform)
 474                       newnewform))
 475                 newform)))
 476          (t
 477           (let* ((fn (car newform))
 478                  (template (get-walker-template fn)))
 479             (if template
 480                 (if (symbolp template)
 481                     (funcall template newform context env)
 482                     (walk-template newform template context env))
 483                 (multiple-value-bind (newnewform macrop)
 484                     (walker-environment-bind
 485                         (new-env env :walk-form newform)
 486                       (macroexpand-1 newform new-env))
 487                   (cond
 488                    (macrop
 489                     (let ((newnewnewform (walk-form-internal newnewform
 490                                                              context
 491                                                              env)))
 492                       (if (eq newnewnewform newnewform)
 493                           (if *walk-form-expand-macros-p* newnewform newform)
 494                           newnewnewform)))
 495                    ((and (symbolp fn)
 496                          (not (fboundp fn))
 497                          (special-operator-p fn))
 498                     ;; This shouldn't happen, since this walker is now
 499                     ;; maintained as part of SBCL, so it should know about all
 500                     ;; the special forms that SBCL knows about.
 501                     (error "unexpected special form ~S" fn))
 502                    (t
 503                     ;; Otherwise, walk the form as if it's just a standard
 504                     ;; function call using a template for standard function
 505                     ;; call.
 506                     (walk-template
 507                      newnewform '(call repeat (eval)) context env))))))))))))
 508
 509 (defun walk-template (form template context env)
 510   (if (atom template)
 511       (ecase template
 512         ((eval function test effect return)
 513          (walk-form-internal form :eval env))
 514         ((quote nil) form)
 515         (set
 516           (walk-form-internal form :set env))
 517         ((lambda call)
 518          (cond ((or (symbolp form)
 519                     (and (listp form)
 520                          (= (length form) 2)
 521                          (eq (car form) 'setf)))
 522                 form)
 523                (t (walk-form-internal form context env)))))
 524       (case (car template)
 525         (repeat
 526           (walk-template-handle-repeat form
 527                                        (cdr template)
 528                                        ;; For the case where nothing happens
 529                                        ;; after the repeat optimize out the
 530                                        ;; call to length.
 531                                        (if (null (cddr template))
 532                                            ()
 533                                            (nthcdr (- (length form)
 534                                                       (length
 535                                                         (cddr template)))
 536                                                    form))
 537                                        context
 538                                        env))
 539         (if
 540           (walk-template form
 541                          (if (if (listp (cadr template))
 542                                  (eval (cadr template))
 543                                  (funcall (cadr template) form))
 544                              (caddr template)
 545                              (cadddr template))
 546                          context
 547                          env))
 548         (remote
 549           (walk-template form (cadr template) context env))
 550         (otherwise
 551           (cond ((atom form) form)
 552                 (t (recons form
 553                            (walk-template
 554                              (car form) (car template) context env)
 555                            (walk-template
 556                              (cdr form) (cdr template) context env))))))))
 557
 558 (defun walk-template-handle-repeat (form template stop-form context env)
 559   (if (eq form stop-form)
 560       (walk-template form (cdr template) context env)
 561       (walk-template-handle-repeat-1 form
 562                                      template
 563                                      (car template)
 564                                      stop-form
 565                                      context
 566                                      env)))
 567
 568 (defun walk-template-handle-repeat-1 (form template repeat-template
 569                                            stop-form context env)
 570   (cond ((null form) ())
 571         ((eq form stop-form)
 572          (if (null repeat-template)
 573              (walk-template stop-form (cdr template) context env)
 574              (error "while handling code walker REPEAT:
 575                      ~%ran into STOP while still in REPEAT template")))
 576         ((null repeat-template)
 577          (walk-template-handle-repeat-1
 578            form template (car template) stop-form context env))
 579         (t
 580          (recons form
 581                  (walk-template (car form) (car repeat-template) context env)
 582                  (walk-template-handle-repeat-1 (cdr form)
 583                                                 template
 584                                                 (cdr repeat-template)
 585                                                 stop-form
 586                                                 context
 587                                                 env)))))
 588
 589 (defun walk-repeat-eval (form env)
 590   (and form
 591        (recons form
 592                (walk-form-internal (car form) :eval env)
 593                (walk-repeat-eval (cdr form) env))))
 594
 595 (defun recons (x car cdr)
 596   (if (or (not (eq (car x) car))
 597           (not (eq (cdr x) cdr)))
 598       (cons car cdr)
 599       x))
 600
 601 (defun relist (x &rest args)
 602   (if (null args)
 603       nil
 604       (relist-internal x args nil)))
 605
 606 (defun relist* (x &rest args)
 607   (relist-internal x args 't))
 608
 609 (defun relist-internal (x args *p)
 610   (if (null (cdr args))
 611       (if *p
 612           (car args)
 613           (recons x (car args) nil))
 614       (recons x
 615               (car args)
 616               (relist-internal (cdr x) (cdr args) *p))))
 617 \f
 618 ;;;; special walkers
 619
 620 (defun walk-declarations (body fn env
 621                                &optional doc-string-p declarations old-body
 622                                &aux (form (car body)) macrop new-form)
 623   (cond ((and (stringp form)                    ;might be a doc string
 624               (cdr body)                        ;isn't the returned value
 625               (null doc-string-p)               ;no doc string yet
 626               (null declarations))              ;no declarations yet
 627          (recons body
 628                  form
 629                  (walk-declarations (cdr body) fn env t)))
 630         ((and (listp form) (eq (car form) 'declare))
 631          ;; We got ourselves a real live declaration. Record it, look for more.
 632          (dolist (declaration (cdr form))
 633            (let ((type (car declaration))
 634                  (name (cadr declaration))
 635                  (args (cddr declaration)))
 636              (if (member type *variable-declarations*)
 637                  (note-declaration `(,type
 638                                      ,(or (variable-lexical-p name env) name)
 639                                      ,.args)
 640                                    env)
 641                  (note-declaration declaration env))
 642              (push declaration declarations)))
 643          (recons body
 644                  form
 645                  (walk-declarations
 646                    (cdr body) fn env doc-string-p declarations)))
 647         ((and form
 648               (listp form)
 649               (null (get-walker-template (car form)))
 650               (progn
 651                 (multiple-value-setq (new-form macrop)
 652                                      (macroexpand-1 form env))
 653                 macrop))
 654          ;; This form was a call to a macro. Maybe it expanded
 655          ;; into a declare?  Recurse to find out.
 656          (walk-declarations (recons body new-form (cdr body))
 657                             fn env doc-string-p declarations
 658                             (or old-body body)))
 659         (t
 660          ;; Now that we have walked and recorded the declarations,
 661          ;; call the function our caller provided to expand the body.
 662          ;; We call that function rather than passing the real-body
 663          ;; back, because we are RECONSING up the new body.
 664          (funcall fn (or old-body body) env))))
 665
 666 (defun walk-unexpected-declare (form context env)
 667   (declare (ignore context env))
 668   (warn "encountered DECLARE ~S in a place where a DECLARE was not expected"
 669         form)
 670   form)
 671
 672 (defun walk-arglist (arglist context env &optional (destructuringp nil)
 673                                          &aux arg)
 674   (cond ((null arglist) ())
 675         ((symbolp (setq arg (car arglist)))
 676          (or (member arg lambda-list-keywords)
 677              (note-lexical-binding arg env))
 678          (recons arglist
 679                  arg
 680                  (walk-arglist (cdr arglist)
 681                                context
 682                                env
 683                                (and destructuringp
 684                                     (not (member arg
 685                                                  lambda-list-keywords))))))
 686         ((consp arg)
 687          (prog1 (recons arglist
 688                         (if destructuringp
 689                             (walk-arglist arg context env destructuringp)
 690                             (relist* arg
 691                                      (car arg)
 692                                      (walk-form-internal (cadr arg) :eval env)
 693                                      (cddr arg)))
 694                         (walk-arglist (cdr arglist) context env nil))
 695                 (if (symbolp (car arg))
 696                     (note-lexical-binding (car arg) env)
 697                     (note-lexical-binding (cadar arg) env))
 698                 (or (null (cddr arg))
 699                     (not (symbolp (caddr arg)))
 700                     (note-lexical-binding (caddr arg) env))))
 701           (t
 702            (error "Can't understand something in the arglist ~S" arglist))))
 703
 704 (defun walk-let (form context env)
 705   (walk-let/let* form context env nil))
 706
 707 (defun walk-let* (form context env)
 708   (walk-let/let* form context env t))
 709
 710 (defun walk-prog (form context env)
 711   (walk-prog/prog* form context env nil))
 712
 713 (defun walk-prog* (form context env)
 714   (walk-prog/prog* form context env t))
 715
 716 (defun walk-do (form context env)
 717   (walk-do/do* form context env nil))
 718
 719 (defun walk-do* (form context env)
 720   (walk-do/do* form context env t))
 721
 722 (defun walk-let/let* (form context old-env sequentialp)
 723   (walker-environment-bind (new-env old-env)
 724     (let* ((let/let* (car form))
 725            (bindings (cadr form))
 726            (body (cddr form))
 727            (walked-bindings
 728              (walk-bindings-1 bindings
 729                               old-env
 730                               new-env
 731                               context
 732                               sequentialp))
 733            (walked-body
 734              (walk-declarations body #'walk-repeat-eval new-env)))
 735       (relist*
 736         form let/let* walked-bindings walked-body))))
 737
 738 (defun walk-locally (form context env)
 739   (declare (ignore context))
 740   (let* ((locally (car form))
 741          (body (cdr form))
 742          (walked-body
 743           (walk-declarations body #'walk-repeat-eval env)))
 744     (relist*
 745      form locally walked-body)))
 746
 747 (defun walk-prog/prog* (form context old-env sequentialp)
 748   (walker-environment-bind (new-env old-env)
 749     (let* ((possible-block-name (second form))
 750            (blocked-prog (and (symbolp possible-block-name)
 751                               (not (eq possible-block-name 'nil)))))
 752       (multiple-value-bind (let/let* block-name bindings body)
 753           (if blocked-prog
 754               (values (car form) (cadr form) (caddr form) (cdddr form))
 755               (values (car form) nil         (cadr  form) (cddr  form)))
 756         (let* ((walked-bindings
 757                  (walk-bindings-1 bindings
 758                                   old-env
 759                                   new-env
 760                                   context
 761                                   sequentialp))
 762                (walked-body
 763                  (walk-declarations
 764                    body
 765                    #'(lambda (real-body real-env)
 766                        (walk-tagbody-1 real-body context real-env))
 767                    new-env)))
 768           (if block-name
 769               (relist*
 770                 form let/let* block-name walked-bindings walked-body)
 771               (relist*
 772                 form let/let* walked-bindings walked-body)))))))
 773
 774 (defun walk-do/do* (form context old-env sequentialp)
 775   (walker-environment-bind (new-env old-env)
 776     (let* ((do/do* (car form))
 777            (bindings (cadr form))
 778            (end-test (caddr form))
 779            (body (cdddr form))
 780            (walked-bindings (walk-bindings-1 bindings
 781                                              old-env
 782                                              new-env
 783                                              context
 784                                              sequentialp))
 785            (walked-body
 786              (walk-declarations body #'walk-repeat-eval new-env)))
 787       (relist* form
 788                do/do*
 789                (walk-bindings-2 bindings walked-bindings context new-env)
 790                (walk-template end-test '(test repeat (eval)) context new-env)
 791                walked-body))))
 792
 793 (defun walk-let-if (form context env)
 794   (let ((test (cadr form))
 795         (bindings (caddr form))
 796         (body (cdddr form)))
 797     (walk-form-internal
 798       `(let ()
 799          (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
 800                                      bindings)))
 801          (flet ((.let-if-dummy. () ,@body))
 802            (if ,test
 803                (let ,bindings (.let-if-dummy.))
 804                (.let-if-dummy.))))
 805       context
 806       env)))
 807
 808 (defun walk-multiple-value-setq (form context env)
 809   (let ((vars (cadr form)))
 810     (if (some #'(lambda (var)
 811                   (variable-symbol-macro-p var env))
 812               vars)
 813         (let* ((temps (mapcar #'(lambda (var)
 814                                   (declare (ignore var))
 815                                   (gensym))
 816                               vars))
 817                (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp))
 818                              vars
 819                              temps))
 820                (expanded `(multiple-value-bind ,temps ,(caddr form)
 821                              ,@sets))
 822                (walked (walk-form-internal expanded context env)))
 823           (if (eq walked expanded)
 824               form
 825               walked))
 826         (walk-template form '(nil (repeat (set)) eval) context env))))
 827
 828 (defun walk-multiple-value-bind (form context old-env)
 829   (walker-environment-bind (new-env old-env)
 830     (let* ((mvb (car form))
 831            (bindings (cadr form))
 832            (mv-form (walk-template (caddr form) 'eval context old-env))
 833            (body (cdddr form))
 834            walked-bindings
 835            (walked-body
 836              (walk-declarations
 837                body
 838                #'(lambda (real-body real-env)
 839                    (setq walked-bindings
 840                          (walk-bindings-1 bindings
 841                                           old-env
 842                                           new-env
 843                                           context
 844                                           nil))
 845                    (walk-repeat-eval real-body real-env))
 846                new-env)))
 847       (relist* form mvb walked-bindings mv-form walked-body))))
 848
 849 (defun walk-bindings-1 (bindings old-env new-env context sequentialp)
 850   (and bindings
 851        (let ((binding (car bindings)))
 852          (recons bindings
 853                  (if (symbolp binding)
 854                      (prog1 binding
 855                             (note-lexical-binding binding new-env))
 856                      (prog1 (relist* binding
 857                                      (car binding)
 858                                      (walk-form-internal (cadr binding)
 859                                                          context
 860                                                          (if sequentialp
 861                                                              new-env
 862                                                              old-env))
 863                                      (cddr binding))    ; Save cddr for DO/DO*;
 864                                                         ; it is the next value
 865                                                         ; form. Don't walk it
 866                                                         ; now though.
 867                             (note-lexical-binding (car binding) new-env)))
 868                  (walk-bindings-1 (cdr bindings)
 869                                   old-env
 870                                   new-env
 871                                   context
 872                                   sequentialp)))))
 873
 874 (defun walk-bindings-2 (bindings walked-bindings context env)
 875   (and bindings
 876        (let ((binding (car bindings))
 877              (walked-binding (car walked-bindings)))
 878          (recons bindings
 879                  (if (symbolp binding)
 880                      binding
 881                      (relist* binding
 882                               (car walked-binding)
 883                               (cadr walked-binding)
 884                               (walk-template (cddr binding)
 885                                              '(eval)
 886                                              context
 887                                              env)))
 888                  (walk-bindings-2 (cdr bindings)
 889                                   (cdr walked-bindings)
 890                                   context
 891                                   env)))))
 892
 893 (defun walk-lambda (form context old-env)
 894   (walker-environment-bind (new-env old-env)
 895     (let* ((arglist (cadr form))
 896            (body (cddr form))
 897            (walked-arglist (walk-arglist arglist context new-env))
 898            (walked-body
 899              (walk-declarations body #'walk-repeat-eval new-env)))
 900       (relist* form
 901                (car form)
 902                walked-arglist
 903                walked-body))))
 904
 905 (defun walk-named-lambda (form context old-env)
 906   (walker-environment-bind (new-env old-env)
 907     (let* ((name (cadr form))
 908            (arglist (caddr form))
 909            (body (cdddr form))
 910            (walked-arglist (walk-arglist arglist context new-env))
 911            (walked-body
 912              (walk-declarations body #'walk-repeat-eval new-env)))
 913       (relist* form
 914                (car form)
 915                name
 916                walked-arglist
 917                walked-body))))
 918
 919 (defun walk-setq (form context env)
 920   (if (cdddr form)
 921       (let* ((expanded (let ((rforms nil)
 922                              (tail (cdr form)))
 923                          (loop (when (null tail) (return (nreverse rforms)))
 924                                (let ((var (pop tail)) (val (pop tail)))
 925                                  (push `(setq ,var ,val) rforms)))))
 926              (walked (walk-repeat-eval expanded env)))
 927         (if (eq expanded walked)
 928             form
 929             `(progn ,@walked)))
 930       (let* ((var (cadr form))
 931              (val (caddr form))
 932              (symmac (car (variable-symbol-macro-p var env))))
 933         (if symmac
 934             (let* ((expanded `(setf ,(cddr symmac) ,val))
 935                    (walked (walk-form-internal expanded context env)))
 936               (if (eq expanded walked)
 937                   form
 938                   walked))
 939             (relist form 'setq
 940                     (walk-form-internal var :set env)
 941                     (walk-form-internal val :eval env))))))
 942
 943 (defun walk-symbol-macrolet (form context old-env)
 944   (declare (ignore context))
 945   (let* ((bindings (cadr form))
 946          (body (cddr form)))
 947     (walker-environment-bind
 948         (new-env old-env
 949                  :lexical-variables
 950                  (append (mapcar #'(lambda (binding)
 951                                      `(,(car binding)
 952                                        :macro . ,(cadr binding)))
 953                                  bindings)
 954                          (env-lexical-variables old-env)))
 955       (relist* form 'symbol-macrolet bindings
 956                (walk-declarations body #'walk-repeat-eval new-env)))))
 957
 958 (defun walk-tagbody (form context env)
 959   (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
 960
 961 (defun walk-tagbody-1 (form context env)
 962   (and form
 963        (recons form
 964                (walk-form-internal (car form)
 965                                    (if (symbolp (car form)) 'quote context)
 966                                    env)
 967                (walk-tagbody-1 (cdr form) context env))))
 968
 969 (defun walk-macrolet (form context old-env)
 970   (walker-environment-bind (macro-env
 971                             nil
 972                             :walk-function (env-walk-function old-env))
 973     (labels ((walk-definitions (definitions)
 974                (and definitions
 975                     (let ((definition (car definitions)))
 976                       (recons definitions
 977                               (relist* definition
 978                                        (car definition)
 979                                        (walk-arglist (cadr definition)
 980                                                      context
 981                                                      macro-env
 982                                                      t)
 983                                        (walk-declarations (cddr definition)
 984                                                           #'walk-repeat-eval
 985                                                           macro-env))
 986                               (walk-definitions (cdr definitions)))))))
 987       (with-new-definition-in-environment (new-env old-env form)
 988         (relist* form
 989                  (car form)
 990                  (walk-definitions (cadr form))
 991                  (walk-declarations (cddr form)
 992                                     #'walk-repeat-eval
 993                                     new-env))))))
 994
 995 (defun walk-flet (form context old-env)
 996   (labels ((walk-definitions (definitions)
 997              (if (null definitions)
 998                  ()
 999                  (recons definitions
1000                          (walk-lambda (car definitions) context old-env)
1001                          (walk-definitions (cdr definitions))))))
1002     (recons form
1003             (car form)
1004             (recons (cdr form)
1005                     (walk-definitions (cadr form))
1006                     (with-new-definition-in-environment (new-env old-env form)
1007                       (walk-declarations (cddr form)
1008                                          #'walk-repeat-eval
1009                                          new-env))))))
1010
1011 (defun walk-labels (form context old-env)
1012   (with-new-definition-in-environment (new-env old-env form)
1013     (labels ((walk-definitions (definitions)
1014                (if (null definitions)
1015                    ()
1016                    (recons definitions
1017                            (walk-lambda (car definitions) context new-env)
1018                            (walk-definitions (cdr definitions))))))
1019       (recons form
1020               (car form)
1021               (recons (cdr form)
1022                       (walk-definitions (cadr form))
1023                       (walk-declarations (cddr form)
1024                                          #'walk-repeat-eval
1025                                          new-env))))))
1026
1027 (defun walk-if (form context env)
1028   (let ((predicate (cadr form))
1029         (arm1 (caddr form))
1030         (arm2
1031           (if (cddddr form)
1032               ;; FIXME: This should go away now that we're no longer trying
1033               ;; to support any old weird CLTL1.
1034               (progn
1035                 (warn "In the form:~%~S~%~
1036                        IF only accepts three arguments, you are using ~D.~%~
1037                        It is true that some Common Lisps support this, but ~
1038                        it is not~%~
1039                        truly legal Common Lisp. For now, this code ~
1040                        walker is interpreting ~%~
1041                        the extra arguments as extra else clauses. ~
1042                        Even if this is what~%~
1043                        you intended, you should fix your source code."
1044                       form
1045                       (length (cdr form)))
1046                 (cons 'progn (cdddr form)))
1047               (cadddr form))))
1048     (relist form
1049             'if
1050             (walk-form-internal predicate context env)
1051             (walk-form-internal arm1 context env)
1052             (walk-form-internal arm2 context env))))
1053 \f
1054 ;;;; tests tests tests
1055
1056 #|
1057 ;;; Here are some examples of the kinds of things you should be able to do
1058 ;;; with your implementation of the macroexpansion environment hacking
1059 ;;; mechanism.
1060 ;;;
1061 ;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes names
1062 ;;; of the macros and actual macroexpansion functions to use to macroexpand
1063 ;;; them. The win about that is that for macros which want to wrap several
1064 ;;; MACROLETs around their body, they can do this but have the macroexpansion
1065 ;;; functions be compiled. See the WITH-RPUSH example.
1066 ;;;
1067 ;;; If the implementation had a special way of communicating the augmented
1068 ;;; environment back to the evaluator that would be totally great. It would
1069 ;;; mean that we could just augment the environment then pass control back
1070 ;;; to the implementations own compiler or interpreter. We wouldn't have
1071 ;;; to call the actual walker. That would make this much faster. Since the
1072 ;;; principal client of this is defmethod it would make compiling defmethods
1073 ;;; faster and that would certainly be a win.
1074
1075 (defmacro with-lexical-macros (macros &body body &environment old-env)
1076   (with-augmented-environment (new-env old-env :macros macros)
1077     (walk-form (cons 'progn body) :environment new-env)))
1078
1079 (defun expand-rpush (form env)
1080   `(push ,(caddr form) ,(cadr form)))
1081
1082 (defmacro with-rpush (&body body)
1083   `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
1084
1085 ;;; Unfortunately, I don't have an automatic tester for the walker.
1086 ;;; Instead there is this set of test cases with a description of
1087 ;;; how each one should go.
1088 (defmacro take-it-out-for-a-test-walk (form)
1089   `(take-it-out-for-a-test-walk-1 ',form))
1090
1091 (defun take-it-out-for-a-test-walk-1 (form)
1092   (terpri)
1093   (terpri)
1094   (let ((copy-of-form (copy-tree form))
1095         (result (walk-form form nil
1096                   #'(lambda (x y env)
1097                       (format t "~&Form: ~S ~3T Context: ~A" x y)
1098                       (when (symbolp x)
1099                         (let ((lexical (variable-lexical-p x env))
1100                               (special (variable-special-p x env)))
1101                           (when lexical
1102                             (format t ";~3T")
1103                             (format t "lexically bound"))
1104                           (when special
1105                             (format t ";~3T")
1106                             (format t "declared special"))
1107                           (when (boundp x)
1108                             (format t ";~3T")
1109                             (format t "bound: ~S " (eval x)))))
1110                       x))))
1111     (cond ((not (equal result copy-of-form))
1112            (format t "~%Warning: Result not EQUAL to copy of start."))
1113           ((not (eq result form))
1114            (format t "~%Warning: Result not EQ to copy of start.")))
1115     (pprint result)
1116     result))
1117
1118 (defmacro foo (&rest ignore) ''global-foo)
1119
1120 (defmacro bar (&rest ignore) ''global-bar)
1121
1122 (take-it-out-for-a-test-walk (list arg1 arg2 arg3))
1123 (take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
1124
1125 (take-it-out-for-a-test-walk (progn (foo) (bar 1)))
1126
1127 (take-it-out-for-a-test-walk (block block-name a b c))
1128 (take-it-out-for-a-test-walk (block block-name (list a) b c))
1129
1130 (take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
1131 ;;; This is a fairly simple macrolet case. While walking the body of the
1132 ;;; macro, x should be lexically bound. In the body of the macrolet form
1133 ;;; itself, x should not be bound.
1134 (take-it-out-for-a-test-walk
1135   (macrolet ((foo (x) (list x) ''inner))
1136     x
1137     (foo 1)))
1138
1139 ;;; A slightly more complex macrolet case. In the body of the macro x
1140 ;;; should not be lexically bound. In the body of the macrolet form itself
1141 ;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it
1142 ;;; tries to macroexpand the call to foo.
1143 (take-it-out-for-a-test-walk
1144      (let ((x 1))
1145        (macrolet ((foo () (list x) ''inner))
1146          x
1147          (foo))))
1148
1149 (take-it-out-for-a-test-walk
1150   (flet ((foo (x) (list x y))
1151          (bar (x) (list x y)))
1152     (foo 1)))
1153
1154 (take-it-out-for-a-test-walk
1155   (let ((y 2))
1156     (flet ((foo (x) (list x y))
1157            (bar (x) (list x y)))
1158       (foo 1))))
1159
1160 (take-it-out-for-a-test-walk
1161   (labels ((foo (x) (bar x))
1162            (bar (x) (foo x)))
1163     (foo 1)))
1164
1165 (take-it-out-for-a-test-walk
1166   (flet ((foo (x) (foo x)))
1167     (foo 1)))
1168
1169 (take-it-out-for-a-test-walk
1170   (flet ((foo (x) (foo x)))
1171     (flet ((bar (x) (foo x)))
1172       (bar 1))))
1173
1174 (take-it-out-for-a-test-walk (prog () (declare (special a b))))
1175 (take-it-out-for-a-test-walk (let (a b c)
1176                                (declare (special a b))
1177                                (foo a) b c))
1178 (take-it-out-for-a-test-walk (let (a b c)
1179                                (declare (special a) (special b))
1180                                (foo a) b c))
1181 (take-it-out-for-a-test-walk (let (a b c)
1182                                (declare (special a))
1183                                (declare (special b))
1184                                (foo a) b c))
1185 (take-it-out-for-a-test-walk (let (a b c)
1186                                (declare (special a))
1187                                (declare (special b))
1188                                (let ((a 1))
1189                                  (foo a) b c)))
1190 (take-it-out-for-a-test-walk (eval-when ()
1191                                a
1192                                (foo a)))
1193 (take-it-out-for-a-test-walk (eval-when (eval when load)
1194                                a
1195                                (foo a)))
1196
1197 (take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
1198 (take-it-out-for-a-test-walk (multiple-value-bind (a b)
1199                                  (foo a b)
1200                                (declare (special a))
1201                                (list a b)))
1202 (take-it-out-for-a-test-walk (progn (function foo)))
1203 (take-it-out-for-a-test-walk (progn a b (go a)))
1204 (take-it-out-for-a-test-walk (if a b c))
1205 (take-it-out-for-a-test-walk (if a b))
1206 (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
1207 (take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
1208                               1 2))
1209 (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
1210 (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
1211 (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
1212                                (declare (special a b))
1213                                (list a b c)))
1214 (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
1215                                (declare (special a b))
1216                                (list a b c)))
1217 (take-it-out-for-a-test-walk (let ((a 1) (b 2))
1218                                (foo bar)
1219                                (declare (special a))
1220                                (foo a b)))
1221 (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
1222 (take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
1223 (take-it-out-for-a-test-walk (progn a b c))
1224 (take-it-out-for-a-test-walk (progv vars vals a b c))
1225 (take-it-out-for-a-test-walk (quote a))
1226 (take-it-out-for-a-test-walk (return-from block-name a b c))
1227 (take-it-out-for-a-test-walk (setq a 1))
1228 (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
1229 (take-it-out-for-a-test-walk (tagbody a b c (go a)))
1230 (take-it-out-for-a-test-walk (the foo (foo-form a b c)))
1231 (take-it-out-for-a-test-walk (throw tag-form a))
1232 (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
1233
1234 (defmacro flet-1 (a b) ''outer)
1235 (defmacro labels-1 (a b) ''outer)
1236
1237 (take-it-out-for-a-test-walk
1238   (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
1239     (flet-1 1 2)
1240     (foo 1 2)))
1241 (take-it-out-for-a-test-walk
1242   (labels ((label-1 (a b) () (label-1 a b)(list a b)))
1243     (label-1 1 2)
1244     (foo 1 2)))
1245 (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
1246                                (macrolet-1 a b)
1247                                (foo 1 2)))
1248
1249 (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
1250                                (foo 1)))
1251
1252 (take-it-out-for-a-test-walk (progn (bar 1)
1253                                     (macrolet ((bar (a)
1254                                                  `(inner-bar-expanded ,a)))
1255                                       (bar 2))))
1256
1257 (take-it-out-for-a-test-walk (progn (bar 1)
1258                                     (macrolet ((bar (s)
1259                                                  (bar s)
1260                                                  `(inner-bar-expanded ,s)))
1261                                       (bar 2))))
1262
1263 (take-it-out-for-a-test-walk (cond (a b)
1264                                    ((foo bar) a (foo a))))
1265
1266 (let ((the-lexical-variables ()))
1267   (walk-form '(let ((a 1) (b 2))
1268                 #'(lambda (x) (list a b x y)))
1269              ()
1270              #'(lambda (form context env)
1271                  (when (and (symbolp form)
1272                             (variable-lexical-p form env))
1273                    (push form the-lexical-variables))
1274                  form))
1275   (or (and (= (length the-lexical-variables) 3)
1276            (member 'a the-lexical-variables)
1277            (member 'b the-lexical-variables)
1278            (member 'x the-lexical-variables))
1279       (error "Walker didn't do lexical variables of a closure properly.")))
1280 |#