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