src/pcl/walk.lisp

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