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 hacking stuff, necessarily SBCL-specific
  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. Except for SYMBOL-MACROLET, only the
  79 ;;; SB-C::LEXENV-FUNS slot is relevant. It holds: Alist (Name . What),
  80 ;;; where What is either a functional (a local function) or a list
  81 ;;; (MACRO . <function>) (a local macro, with the specifier expander.)
  82 ;;; Note that Name may be a (SETF <name>) function. Accessors are
  83 ;;; defined below, eg (ENV-WALK-FUNCTION ENV).
  84 ;;;
  85 ;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND
  86 ;;; this code hides the WALKER version of an environment
  87 ;;; inside the SB-C::LEXENV structure.
  88 ;;;
  89 ;;; In CMUCL (and former SBCL), This used to be a list of lists of form
  90 ;;; (<gensym-name> MACRO . #<interpreted-function>) in the :functions slot
  91 ;;; in a C::LEXENV.
  92 ;;; This form was accepted by the compiler, but this was a crude hack,
  93 ;;; because the <interpreted-function> was used as a structure to hold the
  94 ;;; bits of interest, {function, form, declarations, lexical-variables},
  95 ;;; a list, which was not really an interpreted function.
  96 ;;; Instead this list was COERCEd to a #<FUNCTION ...>!
  97 ;;;
  98 ;;; Instead, we now use a special sort of "function"-type for that
  99 ;;; information, because the functions slot in SB-C::LEXENV is
 100 ;;; supposed to have a list of <Name MACRO . #<function> elements.
 101 ;;; So, now we hide our bits of interest in the walker-info slot in
 102 ;;; our new BOGO-FUN.
 103 ;;;
 104 ;;; MACROEXPAND-1 and SB-INT:EVAL-IN-LEXENV are the only SBCL
 105 ;;; functions that get called with the constructed environment
 106 ;;; argument.
 107
 108 (/show "walk.lisp 108")
 109
 110 (defmacro with-augmented-environment
 111     ((new-env old-env &key functions macros) &body body)
 112   `(let ((,new-env (with-augmented-environment-internal ,old-env
 113                                                         ,functions
 114                                                         ,macros)))
 115      ,@body))
 116
 117 ;;; a unique tag to show that we're the intended caller of BOGO-FUN
 118 (defvar *bogo-fun-magic-tag*
 119   '(:bogo-fun-magic-tag))
 120
 121 ;;; The interface of BOGO-FUNs (previously implemented as
 122 ;;; FUNCALLABLE-INSTANCEs) is just these two operations, so we can do
 123 ;;; them with ordinary closures.
 124 ;;;
 125 ;;; KLUDGE: BOGO-FUNs are sorta weird, and MNA and I have both hacked
 126 ;;; on this code without quite figuring out what they're for. (He
 127 ;;; changed them to work after some changes in the IR1 interpreter
 128 ;;; made functions not be built lazily, and I changed them so that
 129 ;;; they don't need FUNCALLABLE-INSTANCE stuff, so that the F-I stuff
 130 ;;; can become less general.) There may be further simplifications or
 131 ;;; clarifications which could be done. -- WHN 2001-10-19
 132 (defun walker-info-to-bogo-fun (walker-info)
 133   (lambda (magic-tag &rest rest)
 134     (aver (not rest)) ; else someone is using me in an unexpected way
 135     (aver (eql magic-tag *bogo-fun-magic-tag*)) ; else ditto
 136     walker-info))
 137 (defun bogo-fun-to-walker-info (bogo-fun)
 138   (declare (type function bogo-fun))
 139   (funcall bogo-fun *bogo-fun-magic-tag*))
 140
 141 (defun with-augmented-environment-internal (env funs macros)
 142   ;; Note: In order to record the correct function definition, we
 143   ;; would have to create an interpreted closure, but the
 144   ;; WITH-NEW-DEFINITION macro down below makes no distinction between
 145   ;; FLET and LABELS, so we have no idea what to use for the
 146   ;; environment. So we just blow it off, 'cause anything real we do
 147   ;; would be wrong. But we still have to make an entry so we can tell
 148   ;; functions from macros.
 149   (let ((lexenv (sb-kernel::coerce-to-lexenv env)))
 150     (sb-c::make-lexenv
 151       :default lexenv
 152       :funs (append (mapcar (lambda (f)
 153                               (cons (car f)
 154                                     (sb-c::make-functional :lexenv lexenv)))
 155                             funs)
 156                     (mapcar (lambda (m)
 157                               (list* (car m)
 158                                      'sb-c::macro
 159                                      (if (eq (car m)
 160                                              *key-to-walker-environment*)
 161                                          (walker-info-to-bogo-fun (cadr m))
 162                                          (coerce (cadr m) 'function))))
 163                             macros)))))
 164
 165 (defun environment-function (env fn)
 166   (when env
 167     (let ((entry (assoc fn (sb-c::lexenv-funs env) :test #'equal)))
 168       (and entry
 169            (sb-c::functional-p (cdr entry))
 170            (cdr entry)))))
 171
 172 (defun environment-macro (env macro)
 173   (when env
 174     (let ((entry (assoc macro (sb-c::lexenv-funs env) :test #'eq)))
 175       (and entry
 176            (eq (cadr entry) 'sb-c::macro)
 177            (if (eq macro *key-to-walker-environment*)
 178                (values (bogo-fun-to-walker-info (cddr entry)))
 179                (values (function-lambda-expression (cddr entry))))))))
 180 \f
 181 ;;;; other environment hacking, not so SBCL-specific as the
 182 ;;;; environment hacking in the previous section
 183
 184 (defmacro with-new-definition-in-environment
 185           ((new-env old-env macrolet/flet/labels-form) &body body)
 186   (let ((functions (make-symbol "Functions"))
 187         (macros (make-symbol "Macros")))
 188     `(let ((,functions ())
 189            (,macros ()))
 190        (ecase (car ,macrolet/flet/labels-form)
 191          ((flet labels)
 192           (dolist (fn (cadr ,macrolet/flet/labels-form))
 193             (push fn ,functions)))
 194          ((macrolet)
 195           (dolist (mac (cadr ,macrolet/flet/labels-form))
 196             (push (list (car mac)
 197                         (convert-macro-to-lambda (cadr mac)
 198                                                  (cddr mac)
 199                                                  ,old-env
 200                                                  (string (car mac))))
 201                   ,macros))))
 202        (with-augmented-environment
 203               (,new-env ,old-env :functions ,functions :macros ,macros)
 204          ,@body))))
 205
 206 (defun convert-macro-to-lambda (llist body env &optional (name "dummy macro"))
 207   (let ((gensym (make-symbol name)))
 208     (eval-in-lexenv `(defmacro ,gensym ,llist ,@body)
 209                     (sb-c::make-restricted-lexenv env))
 210     (macro-function gensym)))
 211 \f
 212 ;;;; the actual walker
 213
 214 ;;; As the walker walks over the code, it communicates information to
 215 ;;; itself about the walk. This information includes the walk
 216 ;;; function, variable bindings, declarations in effect etc. This
 217 ;;; information is inherently lexical, so the walker passes it around
 218 ;;; in the actual environment the walker passes to macroexpansion
 219 ;;; functions. This is what makes the NESTED-WALK-FORM facility work
 220 ;;; properly.
 221 (defmacro walker-environment-bind ((var env &rest key-args)
 222                                       &body body)
 223   `(with-augmented-environment
 224      (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
 225      .,body))
 226
 227 (defvar *key-to-walker-environment* (gensym))
 228
 229 (defun env-lock (env)
 230   (environment-macro env *key-to-walker-environment*))
 231
 232 (defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
 233                                            (walk-form nil wfop)
 234                                            (declarations nil decp)
 235                                            (lexical-variables nil lexp))
 236   (let ((lock (environment-macro env *key-to-walker-environment*)))
 237     (list
 238       (list *key-to-walker-environment*
 239             (list (if wfnp walk-function     (car lock))
 240                   (if wfop walk-form     (cadr lock))
 241                   (if decp declarations      (caddr lock))
 242                   (if lexp lexical-variables (cadddr lock)))))))
 243
 244 (defun env-walk-function (env)
 245   (car (env-lock env)))
 246
 247 (defun env-walk-form (env)
 248   (cadr (env-lock env)))
 249
 250 (defun env-declarations (env)
 251   (caddr (env-lock env)))
 252
 253 (defun env-lexical-variables (env)
 254   (cadddr (env-lock env)))
 255
 256 (defun note-declaration (declaration env)
 257   (push declaration (caddr (env-lock env))))
 258
 259 (defun note-lexical-binding (thing env)
 260   (push (list thing :lexical-var) (cadddr (env-lock env))))
 261
 262 (defun var-lexical-p (var env)
 263   (let ((entry (member var (env-lexical-variables env) :key #'car)))
 264     (when (eq (cadar entry) :lexical-var)
 265       entry)))
 266
 267 (defun variable-symbol-macro-p (var env)
 268   (let ((entry (member var (env-lexical-variables env) :key #'car)))
 269     (when (eq (cadar entry) 'sb-sys:macro)
 270       entry)))
 271
 272 (defvar *var-declarations* '(special))
 273
 274 (defun var-declaration (declaration var env)
 275   (if (not (member declaration *var-declarations*))
 276       (error "~S is not a recognized variable declaration." declaration)
 277       (let ((id (or (var-lexical-p var env) var)))
 278         (dolist (decl (env-declarations env))
 279           (when (and (eq (car decl) declaration)
 280                      (eq (cadr decl) id))
 281             (return decl))))))
 282
 283 (defun var-special-p (var env)
 284   (or (not (null (var-declaration 'special var env)))
 285       (var-globally-special-p var)))
 286
 287 (defun var-globally-special-p (symbol)
 288   (eq (info :variable :kind symbol) :special))
 289 \f
 290 ;;;; handling of special forms
 291
 292 ;;; Here are some comments from the original PCL on the difficulty of
 293 ;;; doing this portably across different CLTL1 implementations. This
 294 ;;; is no longer directly relevant because this code now only runs on
 295 ;;; SBCL, but the comments are retained for culture: they might help
 296 ;;; explain some of the design decisions which were made in the code.
 297 ;;;
 298 ;;; and I quote...
 299 ;;;
 300 ;;;     The set of special forms is purposely kept very small because
 301 ;;;     any program analyzing program (read code walker) must have
 302 ;;;     special knowledge about every type of special form. Such a
 303 ;;;     program needs no special knowledge about macros...
 304 ;;;
 305 ;;; So all we have to do here is a define a way to store and retrieve
 306 ;;; templates which describe how to walk the 24 special forms and we
 307 ;;; are all set...
 308 ;;;
 309 ;;; Well, its a nice concept, and I have to admit to being naive
 310 ;;; enough that I believed it for a while, but not everyone takes
 311 ;;; having only 24 special forms as seriously as might be nice. There
 312 ;;; are (at least) 3 ways to lose:
 313 ;;
 314 ;;;   1 - Implementation x implements a Common Lisp special form as
 315 ;;;       a macro which expands into a special form which:
 316 ;;;      - Is a common lisp special form (not likely)
 317 ;;;      - Is not a common lisp special form (on the 3600 IF --> COND).
 318 ;;;
 319 ;;;     * We can safe ourselves from this case (second subcase really)
 320 ;;;       by checking to see whether there is a template defined for
 321 ;;;       something before we check to see whether we can macroexpand it.
 322 ;;;
 323 ;;;   2 - Implementation x implements a Common Lisp macro as a special form.
 324 ;;;
 325 ;;;     * This is a screw, but not so bad, we save ourselves from it by
 326 ;;;       defining extra templates for the macros which are *likely* to
 327 ;;;       be implemented as special forms. [Note: As of sbcl-0.6.9, these
 328 ;;;       extra templates have been deleted, since this is not a problem
 329 ;;;       in SBCL and we no longer try to make this walker portable
 330 ;;;       across other possibly-broken CL implementations.]
 331 ;;;
 332 ;;;   3 - Implementation x has a special form which is not on the list of
 333 ;;;       Common Lisp special forms.
 334 ;;;
 335 ;;;     * This is a bad sort of a screw and happens more than I would
 336 ;;;       like to think, especially in the implementations which provide
 337 ;;;       more than just Common Lisp (3600, Xerox etc.).
 338 ;;;       The fix is not terribly satisfactory, but will have to do for
 339 ;;;       now. There is a hook in get walker-template which can get a
 340 ;;;       template from the implementation's own walker. That template
 341 ;;;       has to be converted, and so it may be that the right way to do
 342 ;;;       this would actually be for that implementation to provide an
 343 ;;;       interface to its walker which looks like the interface to this
 344 ;;;       walker.
 345
 346 (defmacro get-walker-template-internal (x)
 347   `(get ,x 'walker-template))
 348
 349 (defmacro define-walker-template (name
 350                                   &optional (template '(nil repeat (eval))))
 351   `(eval-when (:load-toplevel :execute)
 352      (setf (get-walker-template-internal ',name) ',template)))
 353
 354 (defun get-walker-template (x)
 355   (cond ((symbolp x)
 356          (get-walker-template-internal x))
 357         ((and (listp x) (eq (car x) 'lambda))
 358          '(lambda repeat (eval)))
 359         (t
 360          (error "can't get template for ~S" x))))
 361 \f
 362 ;;;; the actual templates
 363
 364 ;;; ANSI special forms
 365 (define-walker-template block                (nil nil repeat (eval)))
 366 (define-walker-template catch                (nil eval repeat (eval)))
 367 (define-walker-template declare              walk-unexpected-declare)
 368 (define-walker-template eval-when            (nil quote repeat (eval)))
 369 (define-walker-template flet                 walk-flet)
 370 (define-walker-template function             (nil call))
 371 (define-walker-template go                   (nil quote))
 372 (define-walker-template if                   walk-if)
 373 (define-walker-template labels               walk-labels)
 374 (define-walker-template lambda               walk-lambda)
 375 (define-walker-template let                  walk-let)
 376 (define-walker-template let*                 walk-let*)
 377 (define-walker-template locally              walk-locally)
 378 (define-walker-template macrolet             walk-macrolet)
 379 (define-walker-template multiple-value-call  (nil eval repeat (eval)))
 380 (define-walker-template multiple-value-prog1 (nil return repeat (eval)))
 381 (define-walker-template multiple-value-setq  walk-multiple-value-setq)
 382 (define-walker-template multiple-value-bind  walk-multiple-value-bind)
 383 (define-walker-template progn                (nil repeat (eval)))
 384 (define-walker-template progv                (nil eval eval repeat (eval)))
 385 (define-walker-template quote                (nil quote))
 386 (define-walker-template return-from          (nil quote repeat (return)))
 387 (define-walker-template setq                 walk-setq)
 388 (define-walker-template symbol-macrolet      walk-symbol-macrolet)
 389 (define-walker-template tagbody              walk-tagbody)
 390 (define-walker-template the                  (nil quote eval))
 391 (define-walker-template throw                (nil eval eval))
 392 (define-walker-template unwind-protect       (nil return repeat (eval)))
 393
 394 ;;; SBCL-only special forms
 395 (define-walker-template sb-ext:truly-the     (nil quote eval))
 396 \f
 397 (defvar *walk-form-expand-macros-p* nil)
 398
 399 (defun walk-form (form
 400                   &optional environment
 401                             (walk-function
 402                              (lambda (subform context env)
 403                                (declare (ignore context env))
 404                                subform)))
 405   (walker-environment-bind (new-env environment :walk-function walk-function)
 406     (walk-form-internal form :eval new-env)))
 407
 408 ;;; WALK-FORM-INTERNAL is the main driving function for the code
 409 ;;; walker. It takes a form and the current context and walks the form
 410 ;;; calling itself or the appropriate template recursively.
 411 ;;;
 412 ;;;   "It is recommended that a program-analyzing-program process a form
 413 ;;;    that is a list whose car is a symbol as follows:
 414 ;;;
 415 ;;;     1. If the program has particular knowledge about the symbol,
 416 ;;;        process the form using special-purpose code. All of the
 417 ;;;        standard special forms should fall into this category.
 418 ;;;     2. Otherwise, if MACRO-FUNCTION is true of the symbol apply
 419 ;;;        either MACROEXPAND or MACROEXPAND-1 and start over.
 420 ;;;     3. Otherwise, assume it is a function call. "
 421 (defun walk-form-internal (form context env)
 422   ;; First apply the walk-function to perform whatever translation
 423   ;; the user wants to this form. If the second value returned
 424   ;; by walk-function is T then we don't recurse...
 425   (catch form
 426     (multiple-value-bind (newform walk-no-more-p)
 427         (funcall (env-walk-function env) form context env)
 428       (catch newform
 429         (cond
 430          (walk-no-more-p newform)
 431          ((not (eq form newform))
 432           (walk-form-internal newform context env))
 433          ((not (consp newform))
 434           (let ((symmac (car (variable-symbol-macro-p newform env))))
 435             (if symmac
 436                 (let ((newnewform (walk-form-internal (cddr symmac)
 437                                                       context
 438                                                       env)))
 439                   (if (eq newnewform (cddr symmac))
 440                       (if *walk-form-expand-macros-p* newnewform newform)
 441                       newnewform))
 442                 newform)))
 443          (t
 444           (let* ((fn (car newform))
 445                  (template (get-walker-template fn)))
 446             (if template
 447                 (if (symbolp template)
 448                     (funcall template newform context env)
 449                     (walk-template newform template context env))
 450                 (multiple-value-bind (newnewform macrop)
 451                     (walker-environment-bind
 452                         (new-env env :walk-form newform)
 453                       (macroexpand-1 newform new-env))
 454                   (cond
 455                    (macrop
 456                     (let ((newnewnewform (walk-form-internal newnewform
 457                                                              context
 458                                                              env)))
 459                       (if (eq newnewnewform newnewform)
 460                           (if *walk-form-expand-macros-p* newnewform newform)
 461                           newnewnewform)))
 462                    ((and (symbolp fn)
 463                          (not (fboundp fn))
 464                          (special-operator-p fn))
 465                     ;; This shouldn't happen, since this walker is now
 466                     ;; maintained as part of SBCL, so it should know
 467                     ;; about all the special forms that SBCL knows
 468                     ;; about.
 469                     (error "unexpected special form ~S" fn))
 470                    (t
 471                     ;; Otherwise, walk the form as if it's just a
 472                     ;; standard function call using a template for
 473                     ;; standard function call.
 474                     (walk-template
 475                      newnewform '(call repeat (eval)) context env))))))))))))
 476
 477 (defun walk-template (form template context env)
 478   (if (atom template)
 479       (ecase template
 480         ((eval function test effect return)
 481          (walk-form-internal form :eval env))
 482         ((quote nil) form)
 483         (set
 484           (walk-form-internal form :set env))
 485         ((lambda call)
 486          (cond ((or (symbolp form)
 487                     (and (listp form)
 488                          (= (length form) 2)
 489                          (eq (car form) 'setf)))
 490                 form)
 491                (t (walk-form-internal form context env)))))
 492       (case (car template)
 493         (repeat
 494           (walk-template-handle-repeat form
 495                                        (cdr template)
 496                                        ;; For the case where nothing
 497                                        ;; happens after the repeat
 498                                        ;; optimize away the call to
 499                                        ;; LENGTH.
 500                                        (if (null (cddr template))
 501                                            ()
 502                                            (nthcdr (- (length form)
 503                                                       (length
 504                                                         (cddr template)))
 505                                                    form))
 506                                        context
 507                                        env))
 508         (if
 509           (walk-template form
 510                          (if (if (listp (cadr template))
 511                                  (eval (cadr template))
 512                                  (funcall (cadr template) form))
 513                              (caddr template)
 514                              (cadddr template))
 515                          context
 516                          env))
 517         (remote
 518           (walk-template form (cadr template) context env))
 519         (otherwise
 520           (cond ((atom form) form)
 521                 (t (recons form
 522                            (walk-template
 523                              (car form) (car template) context env)
 524                            (walk-template
 525                              (cdr form) (cdr template) context env))))))))
 526
 527 (defun walk-template-handle-repeat (form template stop-form context env)
 528   (if (eq form stop-form)
 529       (walk-template form (cdr template) context env)
 530       (walk-template-handle-repeat-1 form
 531                                      template
 532                                      (car template)
 533                                      stop-form
 534                                      context
 535                                      env)))
 536
 537 (defun walk-template-handle-repeat-1 (form template repeat-template
 538                                            stop-form context env)
 539   (cond ((null form) ())
 540         ((eq form stop-form)
 541          (if (null repeat-template)
 542              (walk-template stop-form (cdr template) context env)
 543              (error "while handling code walker REPEAT:
 544                      ~%ran into STOP while still in REPEAT template")))
 545         ((null repeat-template)
 546          (walk-template-handle-repeat-1
 547            form template (car template) stop-form context env))
 548         (t
 549          (recons form
 550                  (walk-template (car form) (car repeat-template) context env)
 551                  (walk-template-handle-repeat-1 (cdr form)
 552                                                 template
 553                                                 (cdr repeat-template)
 554                                                 stop-form
 555                                                 context
 556                                                 env)))))
 557
 558 (defun walk-repeat-eval (form env)
 559   (and form
 560        (recons form
 561                (walk-form-internal (car form) :eval env)
 562                (walk-repeat-eval (cdr form) env))))
 563
 564 (defun recons (x car cdr)
 565   (if (or (not (eq (car x) car))
 566           (not (eq (cdr x) cdr)))
 567       (cons car cdr)
 568       x))
 569
 570 (defun relist (x &rest args)
 571   (if (null args)
 572       nil
 573       (relist-internal x args nil)))
 574
 575 (defun relist* (x &rest args)
 576   (relist-internal x args t))
 577
 578 (defun relist-internal (x args *p)
 579   (if (null (cdr args))
 580       (if *p
 581           (car args)
 582           (recons x (car args) nil))
 583       (recons x
 584               (car args)
 585               (relist-internal (cdr x) (cdr args) *p))))
 586 \f
 587 ;;;; special walkers
 588
 589 (defun walk-declarations (body fn env
 590                                &optional doc-string-p declarations old-body
 591                                &aux (form (car body)) macrop new-form)
 592   (cond ((and (stringp form)                    ;might be a doc string
 593               (cdr body)                        ;isn't the returned value
 594               (null doc-string-p)               ;no doc string yet
 595               (null declarations))              ;no declarations yet
 596          (recons body
 597                  form
 598                  (walk-declarations (cdr body) fn env t)))
 599         ((and (listp form) (eq (car form) 'declare))
 600          ;; We got ourselves a real live declaration. Record it, look
 601          ;; for more.
 602          (dolist (declaration (cdr form))
 603            (let ((type (car declaration))
 604                  (name (cadr declaration))
 605                  (args (cddr declaration)))
 606              (if (member type *var-declarations*)
 607                  (note-declaration `(,type
 608                                      ,(or (var-lexical-p name env) name)
 609                                      ,.args)
 610                                    env)
 611                  (note-declaration declaration env))
 612              (push declaration declarations)))
 613          (recons body
 614                  form
 615                  (walk-declarations
 616                    (cdr body) fn env doc-string-p declarations)))
 617         ((and form
 618               (listp form)
 619               (null (get-walker-template (car form)))
 620               (progn
 621                 (multiple-value-setq (new-form macrop)
 622                                      (macroexpand-1 form env))
 623                 macrop))
 624          ;; This form was a call to a macro. Maybe it expanded
 625          ;; into a declare?  Recurse to find out.
 626          (walk-declarations (recons body new-form (cdr body))
 627                             fn env doc-string-p declarations
 628                             (or old-body body)))
 629         (t
 630          ;; Now that we have walked and recorded the declarations,
 631          ;; call the function our caller provided to expand the body.
 632          ;; We call that function rather than passing the real-body
 633          ;; back, because we are RECONSING up the new body.
 634          (funcall fn (or old-body body) env))))
 635
 636 (defun walk-unexpected-declare (form context env)
 637   (declare (ignore context env))
 638   (warn "encountered ~S ~_in a place where a DECLARE was not expected"
 639         form)
 640   form)
 641
 642 (defun walk-arglist (arglist context env &optional (destructuringp nil)
 643                                          &aux arg)
 644   (cond ((null arglist) ())
 645         ((symbolp (setq arg (car arglist)))
 646          (or (member arg lambda-list-keywords)
 647              (note-lexical-binding arg env))
 648          (recons arglist
 649                  arg
 650                  (walk-arglist (cdr arglist)
 651                                context
 652                                env
 653                                (and destructuringp
 654                                     (not (member arg
 655                                                  lambda-list-keywords))))))
 656         ((consp arg)
 657          (prog1 (recons arglist
 658                         (if destructuringp
 659                             (walk-arglist arg context env destructuringp)
 660                             (relist* arg
 661                                      (car arg)
 662                                      (walk-form-internal (cadr arg) :eval env)
 663                                      (cddr arg)))
 664                         (walk-arglist (cdr arglist) context env nil))
 665                 (if (symbolp (car arg))
 666                     (note-lexical-binding (car arg) env)
 667                     (note-lexical-binding (cadar arg) env))
 668                 (or (null (cddr arg))
 669                     (not (symbolp (caddr arg)))
 670                     (note-lexical-binding (caddr arg) env))))
 671           (t
 672            (error "can't understand something in the arglist ~S" arglist))))
 673
 674 (defun walk-let (form context env)
 675   (walk-let/let* form context env nil))
 676
 677 (defun walk-let* (form context env)
 678   (walk-let/let* form context env t))
 679
 680 (defun walk-let/let* (form context old-env sequentialp)
 681   (walker-environment-bind (new-env old-env)
 682     (let* ((let/let* (car form))
 683            (bindings (cadr form))
 684            (body (cddr form))
 685            (walked-bindings
 686              (walk-bindings-1 bindings
 687                               old-env
 688                               new-env
 689                               context
 690                               sequentialp))
 691            (walked-body
 692              (walk-declarations body #'walk-repeat-eval new-env)))
 693       (relist*
 694         form let/let* walked-bindings walked-body))))
 695
 696 (defun walk-locally (form context env)
 697   (declare (ignore context))
 698   (let* ((locally (car form))
 699          (body (cdr form))
 700          (walked-body
 701           (walk-declarations body #'walk-repeat-eval env)))
 702     (relist*
 703      form locally walked-body)))
 704
 705 (defun walk-let-if (form context env)
 706   (let ((test (cadr form))
 707         (bindings (caddr form))
 708         (body (cdddr form)))
 709     (walk-form-internal
 710       `(let ()
 711          (declare (special ,@(mapcar (lambda (x) (if (listp x) (car x) x))
 712                                      bindings)))
 713          (flet ((.let-if-dummy. () ,@body))
 714            (if ,test
 715                (let ,bindings (.let-if-dummy.))
 716                (.let-if-dummy.))))
 717       context
 718       env)))
 719
 720 (defun walk-multiple-value-setq (form context env)
 721   (let ((vars (cadr form)))
 722     (if (some (lambda (var)
 723                 (variable-symbol-macro-p var env))
 724               vars)
 725         (let* ((temps (mapcar (lambda (var)
 726                                 (declare (ignore var))
 727                                 (gensym))
 728                               vars))
 729                (sets (mapcar (lambda (var temp) `(setq ,var ,temp))
 730                              vars
 731                              temps))
 732                (expanded `(multiple-value-bind ,temps ,(caddr form)
 733                              ,@sets))
 734                (walked (walk-form-internal expanded context env)))
 735           (if (eq walked expanded)
 736               form
 737               walked))
 738         (walk-template form '(nil (repeat (set)) eval) context env))))
 739
 740 (defun walk-multiple-value-bind (form context old-env)
 741   (walker-environment-bind (new-env old-env)
 742     (let* ((mvb (car form))
 743            (bindings (cadr form))
 744            (mv-form (walk-template (caddr form) 'eval context old-env))
 745            (body (cdddr form))
 746            walked-bindings
 747            (walked-body
 748              (walk-declarations
 749                body
 750                (lambda (real-body real-env)
 751                  (setq walked-bindings
 752                        (walk-bindings-1 bindings
 753                                         old-env
 754                                         new-env
 755                                         context
 756                                         nil))
 757                  (walk-repeat-eval real-body real-env))
 758                new-env)))
 759       (relist* form mvb walked-bindings mv-form walked-body))))
 760
 761 (defun walk-bindings-1 (bindings old-env new-env context sequentialp)
 762   (and bindings
 763        (let ((binding (car bindings)))
 764          (recons bindings
 765                  (if (symbolp binding)
 766                      (prog1 binding
 767                             (note-lexical-binding binding new-env))
 768                      (prog1 (relist* binding
 769                                      (car binding)
 770                                      (walk-form-internal (cadr binding)
 771                                                          context
 772                                                          (if sequentialp
 773                                                              new-env
 774                                                              old-env))
 775                                      ;; Save cddr for DO/DO*; it is
 776                                      ;; the next value form. Don't
 777                                      ;; walk it now, though.
 778                                      (cddr binding))
 779                             (note-lexical-binding (car binding) new-env)))
 780                  (walk-bindings-1 (cdr bindings)
 781                                   old-env
 782                                   new-env
 783                                   context
 784                                   sequentialp)))))
 785
 786 (defun walk-bindings-2 (bindings walked-bindings context env)
 787   (and bindings
 788        (let ((binding (car bindings))
 789              (walked-binding (car walked-bindings)))
 790          (recons bindings
 791                  (if (symbolp binding)
 792                      binding
 793                      (relist* binding
 794                               (car walked-binding)
 795                               (cadr walked-binding)
 796                               (walk-template (cddr binding)
 797                                              '(eval)
 798                                              context
 799                                              env)))
 800                  (walk-bindings-2 (cdr bindings)
 801                                   (cdr walked-bindings)
 802                                   context
 803                                   env)))))
 804
 805 (defun walk-lambda (form context old-env)
 806   (walker-environment-bind (new-env old-env)
 807     (let* ((arglist (cadr form))
 808            (body (cddr form))
 809            (walked-arglist (walk-arglist arglist context new-env))
 810            (walked-body
 811              (walk-declarations body #'walk-repeat-eval new-env)))
 812       (relist* form
 813                (car form)
 814                walked-arglist
 815                walked-body))))
 816
 817 (defun walk-setq (form context env)
 818   (if (cdddr form)
 819       (let* ((expanded (let ((rforms nil)
 820                              (tail (cdr form)))
 821                          (loop (when (null tail) (return (nreverse rforms)))
 822                                (let ((var (pop tail)) (val (pop tail)))
 823                                  (push `(setq ,var ,val) rforms)))))
 824              (walked (walk-repeat-eval expanded env)))
 825         (if (eq expanded walked)
 826             form
 827             `(progn ,@walked)))
 828       (let* ((var (cadr form))
 829              (val (caddr form))
 830              (symmac (car (variable-symbol-macro-p var env))))
 831         (if symmac
 832             (let* ((expanded `(setf ,(cddr symmac) ,val))
 833                    (walked (walk-form-internal expanded context env)))
 834               (if (eq expanded walked)
 835                   form
 836                   walked))
 837             (relist form 'setq
 838                     (walk-form-internal var :set env)
 839                     (walk-form-internal val :eval env))))))
 840
 841 (defun walk-symbol-macrolet (form context old-env)
 842   (declare (ignore context))
 843   (let* ((bindings (cadr form))
 844          (body (cddr form)))
 845     (walker-environment-bind
 846         (new-env old-env
 847                  :lexical-variables
 848                  (append (mapcar (lambda (binding)
 849                                    `(,(car binding)
 850                                      sb-sys:macro . ,(cadr binding)))
 851                                  bindings)
 852                          (env-lexical-variables old-env)))
 853       (relist* form 'symbol-macrolet bindings
 854                (walk-declarations body #'walk-repeat-eval new-env)))))
 855
 856 (defun walk-tagbody (form context env)
 857   (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
 858
 859 (defun walk-tagbody-1 (form context env)
 860   (and form
 861        (recons form
 862                (walk-form-internal (car form)
 863                                    (if (symbolp (car form)) 'quote context)
 864                                    env)
 865                (walk-tagbody-1 (cdr form) context env))))
 866
 867 (defun walk-macrolet (form context old-env)
 868   (walker-environment-bind (macro-env
 869                             nil
 870                             :walk-function (env-walk-function old-env))
 871     (labels ((walk-definitions (definitions)
 872                (and definitions
 873                     (let ((definition (car definitions)))
 874                       (recons definitions
 875                               (relist* definition
 876                                        (car definition)
 877                                        (walk-arglist (cadr definition)
 878                                                      context
 879                                                      macro-env
 880                                                      t)
 881                                        (walk-declarations (cddr definition)
 882                                                           #'walk-repeat-eval
 883                                                           macro-env))
 884                               (walk-definitions (cdr definitions)))))))
 885       (with-new-definition-in-environment (new-env old-env form)
 886         (relist* form
 887                  (car form)
 888                  (walk-definitions (cadr form))
 889                  (walk-declarations (cddr form)
 890                                     #'walk-repeat-eval
 891                                     new-env))))))
 892
 893 (defun walk-flet (form context old-env)
 894   (labels ((walk-definitions (definitions)
 895              (if (null definitions)
 896                  ()
 897                  (recons definitions
 898                          (walk-lambda (car definitions) context old-env)
 899                          (walk-definitions (cdr definitions))))))
 900     (recons form
 901             (car form)
 902             (recons (cdr form)
 903                     (walk-definitions (cadr form))
 904                     (with-new-definition-in-environment (new-env old-env form)
 905                       (walk-declarations (cddr form)
 906                                          #'walk-repeat-eval
 907                                          new-env))))))
 908
 909 (defun walk-labels (form context old-env)
 910   (with-new-definition-in-environment (new-env old-env form)
 911     (labels ((walk-definitions (definitions)
 912                (if (null definitions)
 913                    ()
 914                    (recons definitions
 915                            (walk-lambda (car definitions) context new-env)
 916                            (walk-definitions (cdr definitions))))))
 917       (recons form
 918               (car form)
 919               (recons (cdr form)
 920                       (walk-definitions (cadr form))
 921                       (walk-declarations (cddr form)
 922                                          #'walk-repeat-eval
 923                                          new-env))))))
 924
 925 (defun walk-if (form context env)
 926   (destructuring-bind (if predicate arm1 &optional arm2) form
 927     (declare (ignore if)) ; should be 'IF
 928     (relist form
 929             'if
 930             (walk-form-internal predicate context env)
 931             (walk-form-internal arm1 context env)
 932             (walk-form-internal arm2 context env))))
 933 \f
 934 ;;;; examples
 935
 936 #|
 937 ;;; Here are some examples of the kinds of things you should be able
 938 ;;; to do with your implementation of the macroexpansion environment
 939 ;;; hacking mechanism.
 940 ;;;
 941 ;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes
 942 ;;; names of the macros and actual macroexpansion functions to use to
 943 ;;; macroexpand them. The win about that is that for macros which want
 944 ;;; to wrap several MACROLETs around their body, they can do this but
 945 ;;; have the macroexpansion functions be compiled. See the WITH-RPUSH
 946 ;;; example.
 947 ;;;
 948 ;;; If the implementation had a special way of communicating the
 949 ;;; augmented environment back to the evaluator that would be totally
 950 ;;; great. It would mean that we could just augment the environment
 951 ;;; then pass control back to the implementations own compiler or
 952 ;;; interpreter. We wouldn't have to call the actual walker. That
 953 ;;; would make this much faster. Since the principal client of this is
 954 ;;; defmethod it would make compiling defmethods faster and that would
 955 ;;; certainly be a win.
 956
 957 (defmacro with-lexical-macros (macros &body body &environment old-env)
 958   (with-augmented-environment (new-env old-env :macros macros)
 959     (walk-form (cons 'progn body) :environment new-env)))
 960
 961 (defun expand-rpush (form env)
 962   (declare (ignore env))
 963   `(push ,(caddr form) ,(cadr form)))
 964
 965 (defmacro with-rpush (&body body)
 966   `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
 967 |#