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