src/pcl/walk.lisp

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