1 ;;;; a simple code walker
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.
7 ;;;; This software is part of the SBCL system. See the README file for
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
16 ;;;; copyright information from original PCL sources:
18 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
19 ;;;; All rights reserved.
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
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
30 (in-package "SB!WALKER")
32 ;;;; forward references
34 (defvar *key-to-walker-environment
*)
36 ;;;; environment hacking stuff, necessarily SBCL-specific
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
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
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.
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
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).
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.
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
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 ...>!
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.
108 ;;; MACROEXPAND-1 and SB!INT:EVAL-IN-LEXENV are the only SBCL
109 ;;; functions that get called with the constructed environment
112 (/show
"walk.lisp 108")
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
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
))
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.
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
141 (defun bogo-fun-to-walker-info (bogo-fun)
142 (declare (type function bogo-fun
))
143 (funcall bogo-fun
*bogo-fun-magic-tag
*))
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
154 (let ((lexenv (sb!kernel
:coerce-to-lexenv env
)))
157 :vars
(when (eql (caar macros
) *key-to-walker-environment
*)
158 (copy-tree (mapcar (lambda (b)
161 (if (eq info
:lexical-var
)
163 (if (var-special-p name env
)
164 (sb!c
::make-global-var
167 (sb!c
::make-lambda-var
168 :%source-name name
)))
170 (fourth (cadar macros
)))))
171 :funs
(append (mapcar (lambda (f)
173 (sb!c
::make-functional
:lexenv lexenv
)))
179 *key-to-walker-environment
*)
180 (walker-info-to-bogo-fun (cadr m
))
181 (coerce (cadr m
) 'function
))))
184 (defun environment-function (env fn
)
186 (let ((entry (assoc fn
(sb!c
::lexenv-funs env
) :test
#'equal
)))
188 (sb!c
::functional-p
(cdr entry
))
191 (defun environment-macro (env macro
)
193 (let ((entry (assoc macro
(sb!c
::lexenv-funs env
) :test
#'eq
)))
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
))))))))
200 ;;;; other environment hacking, not so SBCL-specific as the
201 ;;;; environment hacking in the previous section
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
())
209 (ecase (car ,macrolet
/flet
/labels-form
)
211 (dolist (fn (cadr ,macrolet
/flet
/labels-form
))
212 (push fn
,functions
)))
214 (dolist (mac (cadr ,macrolet
/flet
/labels-form
))
215 (push (list (car mac
)
216 (convert-macro-to-lambda (cadr mac
)
221 (with-augmented-environment
222 (,new-env
,old-env
:functions
,functions
:macros
,macros
)
225 (defun convert-macro-to-lambda (llist body env
&optional
(name "dummy macro"))
226 (declare (ignorable llist body env name
))
227 #+sb-xc-host
(error "CONVERT-MACRO-TO-LAMBDA called") ; no EVAL-IN-LEXENV
229 (let ((gensym (make-symbol name
)))
230 (eval-in-lexenv `(defmacro ,gensym
,llist
,@body
)
231 (sb!c
::make-restricted-lexenv env
))
232 (macro-function gensym
)))
234 ;;;; the actual walker
236 ;;; As the walker walks over the code, it communicates information to
237 ;;; itself about the walk. This information includes the walk
238 ;;; function, variable bindings, declarations in effect etc. This
239 ;;; information is inherently lexical, so the walker passes it around
240 ;;; in the actual environment the walker passes to macroexpansion
242 (defmacro walker-environment-bind
((var env
&rest key-args
)
244 `(with-augmented-environment
245 (,var
,env
:macros
(walker-environment-bind-1 ,env
,.key-args
))
248 (defvar *key-to-walker-environment
* (gensym))
250 (defun env-lock (env)
251 (environment-macro env
*key-to-walker-environment
*))
253 (defun walker-environment-bind-1 (env &key
(walk-function nil wfnp
)
255 (declarations nil decp
)
256 (lexical-vars nil lexp
))
257 (let ((lock (env-lock env
)))
259 (list *key-to-walker-environment
*
260 (list (if wfnp walk-function
(car lock
))
261 (if wfop walk-form
(cadr lock
))
262 (if decp declarations
(caddr lock
))
263 (if lexp lexical-vars
(cadddr lock
)))))))
265 (defun env-walk-function (env)
266 (car (env-lock env
)))
268 (defun env-walk-form (env)
269 (cadr (env-lock env
)))
271 (defun env-declarations (env)
272 (caddr (env-lock env
)))
274 (defun env-var-type (var env
)
275 (dolist (decl (env-declarations env
) t
)
276 (when (and (eq 'type
(car decl
)) (member var
(cddr decl
) :test
'eq
))
277 (return (cadr decl
)))))
279 (defun env-lexical-variables (env)
280 (cadddr (env-lock env
)))
282 (defun note-declaration (declaration env
)
283 (push declaration
(caddr (env-lock env
))))
285 (defun note-var-binding (thing env
)
286 (push (list thing
:lexical-var
) (cadddr (env-lock env
))))
288 (defun var-lexical-p (var env
)
289 (let ((entry (member var
(env-lexical-variables env
) :key
#'car
:test
#'eq
)))
290 (when (eq (cadar entry
) :lexical-var
)
291 (return-from var-lexical-p entry
)))
292 ;; if we're finding something in the real lexenv, we don't have a
293 ;; bound declaration and so we specifically don't want to return
294 ;; a special object that declarations can attach to, just the name.
295 (and env
(find var
(mapcar #'car
(sb!c
::lexenv-vars env
)))))
297 (defun variable-symbol-macro-p (var env
)
298 ;; FIXME: crufty return convention
299 (let ((entry (or (member var
(env-lexical-variables env
) :key
#'car
:test
#'eq
)
300 (and env
(member var
(sb!c
::lexenv-vars env
) :key
#'car
:test
#'eq
)))))
301 (when (and (consp (cdar entry
)) (eq (cadar entry
) 'sb
!sys
:macro
))
302 (return-from variable-symbol-macro-p entry
))
304 (when (var-globally-symbol-macro-p var
)
305 (list (list* var
'sb
!sys
:macro
(info :variable
:macro-expansion var
)))))))
307 (defun var-globally-symbol-macro-p (var)
308 (eq (info :variable
:kind var
) :macro
))
310 (defun walked-var-declaration-p (declaration)
311 (member declaration
'(sb!pcl
::%class sb
!pcl
::%variable-rebinding special
)))
313 (defun %var-declaration
(declaration var env
)
314 (let ((id (or (var-lexical-p var env
) var
)))
315 (if (eq 'special declaration
)
316 (dolist (decl (env-declarations env
))
317 (when (and (eq (car decl
) declaration
)
318 (or (member var
(cdr decl
))
319 (and id
(member id
(cdr decl
)))))
321 (dolist (decl (env-declarations env
))
322 (when (and (eq (car decl
) declaration
)
326 (defun var-declaration (declaration var env
)
327 (if (walked-var-declaration-p declaration
)
328 (%var-declaration declaration var env
)
329 (error "Not a variable declaration the walker cares about: ~S" declaration
)))
332 (define-compiler-macro var-declaration
(&whole form declaration var env
334 (if (sb!xc
:constantp declaration lexenv
)
335 (let ((decl (constant-form-value declaration lexenv
)))
336 (if (walked-var-declaration-p decl
)
337 `(%var-declaration
,declaration
,var
,env
)
341 (defun var-special-p (var env
)
342 (and (or (var-declaration 'special var env
)
343 (var-globally-special-p var
))
346 (defun var-globally-special-p (symbol)
347 (eq (info :variable
:kind symbol
) :special
))
350 ;;;; handling of special forms
352 ;;; Here are some comments from the original PCL on the difficulty of
353 ;;; doing this portably across different CLTL1 implementations. This
354 ;;; is no longer directly relevant because this code now only runs on
355 ;;; SBCL, but the comments are retained for culture: they might help
356 ;;; explain some of the design decisions which were made in the code.
360 ;;; The set of special forms is purposely kept very small because
361 ;;; any program analyzing program (read code walker) must have
362 ;;; special knowledge about every type of special form. Such a
363 ;;; program needs no special knowledge about macros...
365 ;;; So all we have to do here is a define a way to store and retrieve
366 ;;; templates which describe how to walk the 24 special forms and we
369 ;;; Well, its a nice concept, and I have to admit to being naive
370 ;;; enough that I believed it for a while, but not everyone takes
371 ;;; having only 24 special forms as seriously as might be nice. There
372 ;;; are (at least) 3 ways to lose:
374 ;;; 1 - Implementation x implements a Common Lisp special form as
375 ;;; a macro which expands into a special form which:
376 ;;; - Is a common lisp special form (not likely)
377 ;;; - Is not a common lisp special form (on the 3600 IF --> COND).
379 ;;; * We can save ourselves from this case (second subcase really)
380 ;;; by checking to see whether there is a template defined for
381 ;;; something before we check to see whether we can macroexpand it.
383 ;;; 2 - Implementation x implements a Common Lisp macro as a special form.
385 ;;; * This is a screw, but not so bad, we save ourselves from it by
386 ;;; defining extra templates for the macros which are *likely* to
387 ;;; be implemented as special forms. [Note: As of sbcl-0.6.9, these
388 ;;; extra templates have been deleted, since this is not a problem
389 ;;; in SBCL and we no longer try to make this walker portable
390 ;;; across other possibly-broken CL implementations.]
392 ;;; 3 - Implementation x has a special form which is not on the list of
393 ;;; Common Lisp special forms.
395 ;;; * This is a bad sort of a screw and happens more than I would
396 ;;; like to think, especially in the implementations which provide
397 ;;; more than just Common Lisp (3600, Xerox etc.).
398 ;;; The fix is not terribly satisfactory, but will have to do for
399 ;;; now. There is a hook in get walker-template which can get a
400 ;;; template from the implementation's own walker. That template
401 ;;; has to be converted, and so it may be that the right way to do
402 ;;; this would actually be for that implementation to provide an
403 ;;; interface to its walker which looks like the interface to this
406 (defmacro get-walker-template-internal
(x)
407 `(get ,x
'walker-template
))
409 (defmacro define-walker-template
(name
410 &optional
(template '(nil repeat
(eval))))
411 `(setf (get-walker-template-internal ',name
) ',template
))
413 (defun get-walker-template (x context
)
415 (get-walker-template-internal x
))
416 ((and (listp x
) (eq (car x
) 'lambda
))
417 '(lambda repeat
(eval)))
419 ;; FIXME: In an ideal world we would do something similar to
420 ;; COMPILER-ERROR here, replacing the form within the walker
421 ;; with an error-signalling form. This is slightly less
422 ;; pretty, but informative non the less. Best is the enemy of
424 (error "Illegal function call in method body:~% ~S"
427 ;;;; the actual templates
429 ;;; ANSI special forms
430 (define-walker-template block
(nil nil repeat
(eval)))
431 (define-walker-template catch
(nil eval repeat
(eval)))
432 (define-walker-template declare walk-unexpected-declare
)
433 (define-walker-template eval-when
(nil quote repeat
(eval)))
434 (define-walker-template flet walk-flet
)
435 (define-walker-template function
(nil call
))
436 (define-walker-template go
(nil quote
))
437 (define-walker-template if walk-if
)
438 (define-walker-template labels walk-labels
)
439 (define-walker-template lambda walk-lambda
)
440 (define-walker-template let walk-let
)
441 (define-walker-template let
* walk-let
*)
442 (define-walker-template load-time-value walk-load-time-value
)
443 (define-walker-template locally walk-locally
)
444 (define-walker-template macrolet walk-macrolet
)
445 (define-walker-template multiple-value-call
(nil eval repeat
(eval)))
446 (define-walker-template multiple-value-prog1
(nil return repeat
(eval)))
447 (define-walker-template multiple-value-setq walk-multiple-value-setq
)
448 (define-walker-template multiple-value-bind walk-multiple-value-bind
)
449 (define-walker-template progn
(nil repeat
(eval)))
450 (define-walker-template progv
(nil eval eval repeat
(eval)))
451 (define-walker-template quote
(nil quote
))
452 (define-walker-template return-from
(nil quote repeat
(return)))
453 (define-walker-template setq walk-setq
)
454 (define-walker-template symbol-macrolet walk-symbol-macrolet
)
455 (define-walker-template tagbody walk-tagbody
)
456 (define-walker-template the
(nil quote eval
))
457 (define-walker-template throw
(nil eval eval
))
458 (define-walker-template unwind-protect
(nil return repeat
(eval)))
460 ;;; SBCL-only special forms
461 (define-walker-template truly-the
(nil quote eval
))
462 ;;; FIXME: maybe we don't need this one any more, given that
463 ;;; NAMED-LAMBDA now expands into (FUNCTION (NAMED-LAMBDA ...))?
464 (define-walker-template named-lambda walk-named-lambda
)
466 (defvar *walk-form-expand-macros-p
* nil
)
468 (defun walk-form (form
469 &optional environment
471 (lambda (subform context env
)
472 (declare (ignore context env
))
474 #!+(and sb-fasteval
(host-feature sb-xc
))
475 (when (typep environment
'sb
!interpreter
:basic-env
)
476 (setq environment
(sb!interpreter
:lexenv-from-env environment
)))
477 (walker-environment-bind (new-env environment
:walk-function walk-function
)
478 (walk-form-internal form
:eval new-env
)))
480 ;;; WALK-FORM-INTERNAL is the main driving function for the code
481 ;;; walker. It takes a form and the current context and walks the form
482 ;;; calling itself or the appropriate template recursively.
484 ;;; "It is recommended that a program-analyzing-program process a form
485 ;;; that is a list whose car is a symbol as follows:
487 ;;; 1. If the program has particular knowledge about the symbol,
488 ;;; process the form using special-purpose code. All of the
489 ;;; standard special forms should fall into this category.
490 ;;; 2. Otherwise, if MACRO-FUNCTION is true of the symbol apply
491 ;;; either MACROEXPAND or MACROEXPAND-1 and start over.
492 ;;; 3. Otherwise, assume it is a function call. "
493 (defun walk-form-internal (form context env
)
494 (declare (type (member :eval
:set
) context
))
495 ;; First apply the walk-function to perform whatever translation
496 ;; the user wants to this form. If the second value returned
497 ;; by walk-function is T then we don't recurse...
499 (multiple-value-bind (newform walk-no-more-p
)
500 (funcall (env-walk-function env
) form context env
)
503 (walk-no-more-p newform
)
504 ((not (eq form newform
))
505 (walk-form-internal newform context env
))
506 ((and (not (consp newform
))
507 (or (eql context
:eval
)
509 (let ((symmac (car (variable-symbol-macro-p newform env
))))
511 (let* ((newnewform (walk-form-internal (cddr symmac
)
515 (if (eq newnewform
(cddr symmac
))
516 (if *walk-form-expand-macros-p
* newnewform newform
)
518 (type (env-var-type newform env
)))
521 `(the ,type
,resultform
)))
523 ((eql context
:set
) newform
)
525 (let* ((fn (car newform
))
526 (template (get-walker-template fn newform
)))
528 (if (symbolp template
)
529 (funcall template newform context env
)
530 (walk-template newform template context env
))
531 (multiple-value-bind (newnewform macrop
)
532 (walker-environment-bind
533 (new-env env
:walk-form newform
)
534 (%macroexpand-1 newform new-env
))
537 (let ((newnewnewform (walk-form-internal newnewform
540 (if (eq newnewnewform newnewform
)
541 (if *walk-form-expand-macros-p
* newnewform newform
)
544 (special-operator-p fn
))
545 ;; This shouldn't happen, since this walker is now
546 ;; maintained as part of SBCL, so it should know
547 ;; about all the special forms that SBCL knows
549 (bug "unexpected special form ~S" fn
))
551 ;; Otherwise, walk the form as if it's just a
552 ;; standard function call using a template for
553 ;; standard function call.
555 newnewform
'(call repeat
(eval)) context env
))))))))))))
557 (defun walk-template (form template context env
)
560 ((eval function test effect return
)
561 (walk-form-internal form
:eval env
))
564 (walk-form-internal form
:set env
))
566 (cond ((legal-fun-name-p form
)
568 (t (walk-form-internal form context env
)))))
571 (walk-template-handle-repeat form
573 ;; For the case where nothing
574 ;; happens after the repeat
575 ;; optimize away the call to
577 (if (null (cddr template
))
579 (nthcdr (- (length form
)
587 (if (if (listp (cadr template
))
588 (eval (cadr template
))
589 (funcall (cadr template
) form
))
595 (walk-template form
(cadr template
) context env
))
597 (cond ((atom form
) form
)
600 (car form
) (car template
) context env
)
602 (cdr form
) (cdr template
) context env
))))))))
604 (defun walk-template-handle-repeat (form template stop-form context env
)
605 (if (eq form stop-form
)
606 (walk-template form
(cdr template
) context env
)
607 (walk-template-handle-repeat-1
608 form template
(car template
) stop-form context env
)))
610 (defun walk-template-handle-repeat-1 (form template repeat-template
611 stop-form context env
)
612 (cond ((null form
) ())
614 (if (null repeat-template
)
615 (walk-template stop-form
(cdr template
) context env
)
616 (error "while handling code walker REPEAT:
617 ~%ran into STOP while still in REPEAT template")))
618 ((null repeat-template
)
619 (walk-template-handle-repeat-1
620 form template
(car template
) stop-form context env
))
623 (walk-template (car form
) (car repeat-template
) context env
)
624 (walk-template-handle-repeat-1 (cdr form
)
626 (cdr repeat-template
)
631 (defun walk-repeat-eval (form env
)
634 (walk-form-internal (car form
) :eval env
)
635 (walk-repeat-eval (cdr form
) env
))))
637 (defun recons (x car cdr
)
638 (if (or (not (eq (car x
) car
))
639 (not (eq (cdr x
) cdr
)))
643 (defun relist (x &rest args
)
646 (relist-internal x args nil
)))
648 (defun relist* (x &rest args
)
649 (relist-internal x args t
))
651 (defun relist-internal (x args
*p
)
652 (if (null (cdr args
))
655 (recons x
(car args
) nil
))
658 (relist-internal (cdr x
) (cdr args
) *p
))))
662 (defun walk-declarations (body fn env
663 &optional doc-string-p declarations old-body
664 &aux
(form (car body
)) macrop new-form
)
665 (cond ((and (stringp form
) ;might be a doc string
666 (cdr body
) ;isn't the returned value
667 (null doc-string-p
) ;no doc string yet
668 (null declarations
)) ;no declarations yet
671 (walk-declarations (cdr body
) fn env t
)))
672 ((and (listp form
) (eq (car form
) 'declare
))
673 ;; We got ourselves a real live declaration. Record it, look
675 (dolist (declaration (cdr form
))
676 (let ((type (car declaration
))
677 (name (cadr declaration
))
678 (args (cddr declaration
)))
679 (if (walked-var-declaration-p type
)
680 (note-declaration `(,type
681 ,(or (var-lexical-p name env
) name
)
684 (note-declaration (sb!c
::canonized-decl-spec declaration
) env
))
685 (push declaration declarations
)))
689 (cdr body
) fn env doc-string-p declarations
)))
692 (null (get-walker-template (car form
) form
))
694 (multiple-value-setq (new-form macrop
)
695 (%macroexpand-1 form env
))
697 ;; This form was a call to a macro. Maybe it expanded
698 ;; into a declare? Recurse to find out.
699 (walk-declarations (recons body new-form
(cdr body
))
700 fn env doc-string-p declarations
703 ;; Now that we have walked and recorded the declarations,
704 ;; call the function our caller provided to expand the body.
705 ;; We call that function rather than passing the real-body
706 ;; back, because we are RECONSING up the new body.
707 (funcall fn
(or old-body body
) env
))))
709 (defun walk-unexpected-declare (form context env
)
710 (declare (ignore context env
))
711 (warn "encountered ~S ~_in a place where a DECLARE was not expected"
715 (defun walk-arglist (arglist context env
&optional
(destructuringp nil
)
717 (cond ((null arglist
) ())
718 ((symbolp (setq arg
(car arglist
)))
719 (or (member arg sb
!xc
:lambda-list-keywords
:test
#'eq
)
720 (note-var-binding arg env
))
723 (walk-arglist (cdr arglist
)
727 (not (member arg sb
!xc
:lambda-list-keywords
))))))
729 (prog1 (recons arglist
731 (walk-arglist arg context env destructuringp
)
734 (walk-form-internal (cadr arg
) :eval env
)
736 (walk-arglist (cdr arglist
) context env nil
))
737 (if (symbolp (car arg
))
738 (note-var-binding (car arg
) env
)
739 (note-var-binding (cadar arg
) env
))
740 (or (null (cddr arg
))
741 (not (symbolp (caddr arg
)))
742 (note-var-binding (caddr arg
) env
))))
744 (error "can't understand something in the arglist ~S" arglist
))))
746 (defun walk-let (form context env
)
747 (walker-environment-bind (new-env env
)
748 (let* ((let (car form
))
749 (bindings (cadr form
))
755 (lambda (real-body real-env
)
756 (setf walked-bindings
757 (walk-bindings-1 bindings env new-env context
))
758 (walk-repeat-eval real-body real-env
))
760 (relist* form let walked-bindings walked-body
))))
762 (defun let*-binding-name
(binding)
763 (if (symbolp binding
)
767 (defun let*-binding-init
(binding)
768 (if (or (symbolp binding
)
769 (null (cdr binding
)))
773 (defun let*-bindings
(bindings &aux names inits
(seen (make-hash-table)))
774 (dolist (binding (reverse bindings
) (values names inits
))
775 (let ((name (let*-binding-name binding
)))
776 (push (cons name
(gethash name seen
)) names
)
777 (setf (gethash name seen
) t
)
778 (push (let*-binding-init binding
) inits
))))
780 (defun walk-let* (form context env
)
781 (walker-environment-bind (new-env env
)
782 (let ((let* (car form
))
783 (bindings (cadr form
))
785 (multiple-value-bind (names inits
) (let*-bindings bindings
)
786 (multiple-value-bind (newbody decls doc
) (parse-body body nil
)
787 (declare (ignore newbody
))
789 (labels ((maybe-process-and-munge-declaration (name declaration env
)
790 (if (walked-var-declaration-p (car declaration
))
791 (case (car declaration
)
792 (special (if (find name
(cdr declaration
))
794 (note-declaration `(special ,(var-lexical-p name env
)) env
)
795 (cons 'special
(remove name
(cdr declaration
))))
797 (t (if (eql name
(cadr declaration
))
799 (note-declaration `(,(car declaration
)
800 ,(var-lexical-p name env
)
801 ,@(cddr declaration
))
806 (walk-let*-bindings
(bindings names inits
)
809 (let ((name (car names
))
812 (if (eql init
'no-init
)
813 (prog1 (car bindings
)
814 (note-var-binding (car name
) new-env
))
816 (relist (car bindings
)
818 (walk-form-internal init context new-env
))
819 (note-var-binding (car name
) new-env
)))
821 (setf decls
(mapcar (lambda (d)
823 (mapcar (lambda (dd) (maybe-process-and-munge-declaration (car name
) dd new-env
))
826 (walk-let*-bindings
(cdr bindings
) (cdr names
) (cdr inits
))))))
828 (walk-let*-bindings bindings names inits
)
829 (walk-declarations body
(lambda (form env
) (walk-repeat-eval form env
)) new-env
))))))))
831 (defun walk-load-time-value (form context env
)
832 (destructuring-bind (ltv val
&optional read-only-p
) form
833 (declare (ignore ltv
))
836 ;; this is wrong: VAL is handled differently depending on
837 ;; whether we're in EVAL, COMPILE or COMPILE-FILE, and
838 ;; (after macroexpansion) is evaluated in the null lexical
839 ;; environment. The macro semantics are the same in each
840 ;; case, but VAR-LEXICAL-P can be tricked into giving the
842 (walk-form-internal val context env
)
843 (walk-form-internal read-only-p context env
))))
845 (defun walk-locally (form context env
)
846 (declare (ignore context
))
847 (walker-environment-bind (new-env env
)
848 (let* ((locally (car form
))
851 (walk-declarations body
#'walk-repeat-eval new-env
)))
853 form locally walked-body
))))
855 (defun walk-multiple-value-setq (form context env
)
856 (let ((vars (cadr form
)))
857 (if (some (lambda (var)
858 (variable-symbol-macro-p var env
))
860 (let* ((temps (mapcar (lambda (var)
861 (declare (ignore var
))
864 (sets (mapcar (lambda (var temp
) `(setq ,var
,temp
))
867 (expanded `(multiple-value-bind ,temps
,(caddr form
)
869 (walked (walk-form-internal expanded context env
)))
870 (if (eq walked expanded
)
873 (walk-template form
'(nil (repeat (set)) eval
) context env
))))
875 (defun walk-multiple-value-bind (form context old-env
)
876 (walker-environment-bind (new-env old-env
)
877 (let* ((mvb (car form
))
878 (bindings (cadr form
))
879 (mv-form (walk-template (caddr form
) 'eval context old-env
))
885 (lambda (real-body real-env
)
886 (setq walked-bindings
887 (walk-bindings-1 bindings old-env new-env context
))
888 (walk-repeat-eval real-body real-env
))
890 (relist* form mvb walked-bindings mv-form walked-body
))))
892 (defun walk-bindings-1 (bindings old-env new-env context
)
894 (let ((binding (car bindings
)))
896 (if (symbolp binding
)
898 (note-var-binding binding new-env
))
899 (prog1 (relist binding
902 (cadr binding
) context old-env
))
903 (note-var-binding (car binding
) new-env
)))
904 (walk-bindings-1 (cdr bindings
) old-env new-env context
)))))
906 (defun walk-lambda (form context old-env
)
907 (walker-environment-bind (new-env old-env
)
908 (let* ((arglist (cadr form
))
910 (walked-arglist (walk-arglist arglist context new-env
))
912 (walk-declarations body
#'walk-repeat-eval new-env
)))
918 (defun walk-named-lambda (form context old-env
)
919 (walker-environment-bind (new-env old-env
)
920 (let* ((name (second form
))
921 (arglist (third form
))
923 (walked-arglist (walk-arglist arglist context new-env
))
925 (walk-declarations body
#'walk-repeat-eval new-env
)))
932 (defun walk-setq (form context env
)
934 (let* ((expanded (let ((rforms nil
)
936 (loop (when (null tail
) (return (nreverse rforms
)))
937 (let ((var (pop tail
)) (val (pop tail
)))
938 (push `(setq ,var
,val
) rforms
)))))
939 (walked (walk-repeat-eval expanded env
)))
940 (if (eq expanded walked
)
943 (let* ((var (cadr form
))
945 (symmac (car (variable-symbol-macro-p var env
))))
947 (let* ((type (env-var-type var env
))
948 (expanded (if (eq t type
)
949 `(setf ,(cddr symmac
) ,val
)
950 `(setf ,(cddr symmac
) (the ,type
,val
))))
951 (walked (walk-form-internal expanded context env
)))
952 (if (eq expanded walked
)
956 (walk-form-internal var
:set env
)
957 (walk-form-internal val
:eval env
))))))
959 (defun walk-symbol-macrolet (form context old-env
)
960 (declare (ignore context
))
961 (let* ((bindings (cadr form
))
963 (walker-environment-bind
966 (append (mapcar (lambda (binding)
968 sb
!sys
:macro .
,(cadr binding
)))
970 (env-lexical-variables old-env
)))
971 (relist* form
'symbol-macrolet bindings
972 (walk-declarations body
#'walk-repeat-eval new-env
)))))
974 (defun walk-tagbody (form context env
)
975 (recons form
(car form
) (walk-tagbody-1 (cdr form
) context env
)))
977 (defun walk-tagbody-1 (form context env
)
980 (if (or (symbolp (car form
)) (integerp (car form
)))
981 (walk-template (car form
) 'quote context env
)
982 (walk-form-internal (car form
) context env
))
983 (walk-tagbody-1 (cdr form
) context env
))))
985 (defun walk-macrolet (form context old-env
)
986 (walker-environment-bind (old-env old-env
)
987 (walker-environment-bind (macro-env
989 :walk-function
(env-walk-function old-env
))
990 (labels ((walk-definitions (definitions)
992 (let ((definition (car definitions
)))
996 (walk-arglist (cadr definition
)
1000 (walk-declarations (cddr definition
)
1003 (walk-definitions (cdr definitions
)))))))
1004 (with-new-definition-in-environment (new-env old-env form
)
1007 (walk-definitions (cadr form
))
1008 (walk-declarations (cddr form
)
1012 (defun walk-flet (form context old-env
)
1013 (walker-environment-bind (old-env old-env
)
1014 (labels ((walk-definitions (definitions)
1015 (if (null definitions
)
1018 (walk-lambda (car definitions
) context old-env
)
1019 (walk-definitions (cdr definitions
))))))
1023 (walk-definitions (cadr form
))
1024 (with-new-definition-in-environment (new-env old-env form
)
1025 (walk-declarations (cddr form
)
1029 (defun walk-labels (form context old-env
)
1030 (walker-environment-bind (old-env old-env
)
1031 (with-new-definition-in-environment (new-env old-env form
)
1032 (labels ((walk-definitions (definitions)
1033 (if (null definitions
)
1036 (walk-lambda (car definitions
) context new-env
)
1037 (walk-definitions (cdr definitions
))))))
1041 (walk-definitions (cadr form
))
1042 (walk-declarations (cddr form
)
1046 (defun walk-if (form context env
)
1047 (destructuring-bind (if predicate arm1
&optional arm2
) form
1048 (declare (ignore if
)) ; should be 'IF
1051 (walk-form-internal predicate context env
)
1052 (walk-form-internal arm1 context env
)
1053 (walk-form-internal arm2 context env
))))
1058 ;;; Here are some examples of the kinds of things you should be able
1059 ;;; to do with your implementation of the macroexpansion environment
1060 ;;; hacking mechanism.
1062 ;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes
1063 ;;; names of the macros and actual macroexpansion functions to use to
1064 ;;; macroexpand them. The win about that is that for macros which want
1065 ;;; to wrap several MACROLETs around their body, they can do this but
1066 ;;; have the macroexpansion functions be compiled. See the WITH-RPUSH
1069 ;;; If the implementation had a special way of communicating the
1070 ;;; augmented environment back to the evaluator that would be totally
1071 ;;; great. It would mean that we could just augment the environment
1072 ;;; then pass control back to the implementations own compiler or
1073 ;;; interpreter. We wouldn't have to call the actual walker. That
1074 ;;; would make this much faster. Since the principal client of this is
1075 ;;; defmethod it would make compiling defmethods faster and that would
1076 ;;; certainly be a win.
1078 (defmacro with-lexical-macros
(macros &body body
&environment old-env
)
1079 (with-augmented-environment (new-env old-env
:macros macros
)
1080 (walk-form (cons 'progn body
) :environment new-env
)))
1082 (defun expand-rpush (form env
)
1083 (declare (ignore env
))
1084 `(push ,(caddr form
) ,(cadr form
)))
1086 (defmacro with-rpush
(&body body
)
1087 `(with-lexical-macros ,(list (list 'rpush
#'expand-rpush
)) ,@body
))