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