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