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.
153 (let ((lexenv (sb!kernel::coerce-to-lexenv env)))
156 :vars (when (eql (caar macros) *key-to-walker-environment*)
157 (copy-tree (remove :lexical-var (fourth (cadar macros))
159 :funs (append (mapcar (lambda (f)
161 (sb!c::make-functional :lexenv lexenv)))
167 *key-to-walker-environment*)
168 (walker-info-to-bogo-fun (cadr m))
169 (coerce (cadr m) 'function))))
172 (defun environment-function (env fn)
174 (let ((entry (assoc fn (sb!c::lexenv-funs env) :test #'equal)))
176 (sb!c::functional-p (cdr entry))
179 (defun environment-macro (env macro)
181 (let ((entry (assoc macro (sb!c::lexenv-funs env) :test #'eq)))
183 (eq (cadr entry) 'sb!c::macro)
184 (if (eq macro *key-to-walker-environment*)
185 (values (bogo-fun-to-walker-info (cddr entry)))
186 (values (function-lambda-expression (cddr entry))))))))
188 ;;;; other environment hacking, not so SBCL-specific as the
189 ;;;; environment hacking in the previous section
191 (defmacro with-new-definition-in-environment
192 ((new-env old-env macrolet/flet/labels-form) &body body)
193 (let ((functions (make-symbol "Functions"))
194 (macros (make-symbol "Macros")))
195 `(let ((,functions ())
197 (ecase (car ,macrolet/flet/labels-form)
199 (dolist (fn (cadr ,macrolet/flet/labels-form))
200 (push fn ,functions)))
202 (dolist (mac (cadr ,macrolet/flet/labels-form))
203 (push (list (car mac)
204 (convert-macro-to-lambda (cadr mac)
209 (with-augmented-environment
210 (,new-env ,old-env :functions ,functions :macros ,macros)
213 (defun convert-macro-to-lambda (llist body env &optional (name "dummy macro"))
214 (let ((gensym (make-symbol name)))
215 (eval-in-lexenv `(defmacro ,gensym ,llist ,@body)
216 (sb!c::make-restricted-lexenv env))
217 (macro-function gensym)))
219 ;;;; the actual walker
221 ;;; As the walker walks over the code, it communicates information to
222 ;;; itself about the walk. This information includes the walk
223 ;;; function, variable bindings, declarations in effect etc. This
224 ;;; information is inherently lexical, so the walker passes it around
225 ;;; in the actual environment the walker passes to macroexpansion
226 ;;; functions. This is what makes the NESTED-WALK-FORM facility work
228 (defmacro walker-environment-bind ((var env &rest key-args)
230 `(with-augmented-environment
231 (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
234 (defvar *key-to-walker-environment* (gensym))
236 (defun env-lock (env)
237 (environment-macro env *key-to-walker-environment*))
239 (defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
241 (declarations nil decp)
242 (lexical-vars nil lexp))
243 (let ((lock (env-lock env)))
245 (list *key-to-walker-environment*
246 (list (if wfnp walk-function (car lock))
247 (if wfop walk-form (cadr lock))
248 (if decp declarations (caddr lock))
249 (if lexp lexical-vars (cadddr lock)))))))
251 (defun env-walk-function (env)
252 (car (env-lock env)))
254 (defun env-walk-form (env)
255 (cadr (env-lock env)))
257 (defun env-declarations (env)
258 (caddr (env-lock env)))
260 (defun env-var-type (var env)
261 (dolist (decl (env-declarations env) t)
262 (when (and (eq 'type (car decl)) (member var (cddr decl) :test 'eq))
263 (return (cadr decl)))))
265 (defun env-lexical-variables (env)
266 (cadddr (env-lock env)))
268 (defun note-declaration (declaration env)
269 (push declaration (caddr (env-lock env))))
271 (defun note-lexical-binding (thing env)
272 (push (list thing :lexical-var) (cadddr (env-lock env))))
274 (defun var-lexical-p (var env)
275 (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
276 (when (eq (cadar entry) :lexical-var)
279 (defun variable-symbol-macro-p (var env)
280 (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
281 (when (eq (cadar entry) 'sb!sys:macro)
284 (defun walked-var-declaration-p (declaration)
285 (member declaration '(sb!pcl::%class sb!pcl::%variable-rebinding special)))
287 (defun %var-declaration (declaration var env)
288 (let ((id (or (var-lexical-p var env) var)))
289 (dolist (decl (env-declarations env))
290 (when (and (eq (car decl) declaration)
294 (defun var-declaration (declaration var env)
295 (if (walked-var-declaration-p declaration)
296 (%var-declaration declaration var env)
297 (error "Not a variable declaration the walker cares about: ~S" declaration)))
300 (define-compiler-macro var-declaration (&whole form declaration var env
302 (if (sb!xc:constantp declaration lexenv)
303 (let ((decl (constant-form-value declaration lexenv)))
304 (if (walked-var-declaration-p decl)
305 `(%var-declaration ,declaration ,var ,env)
309 (defun var-special-p (var env)
310 (and (or (var-declaration 'special var env)
311 (var-globally-special-p var))
314 (defun var-globally-special-p (symbol)
315 (eq (info :variable :kind symbol) :special))
318 ;;;; handling of special forms
320 ;;; Here are some comments from the original PCL on the difficulty of
321 ;;; doing this portably across different CLTL1 implementations. This
322 ;;; is no longer directly relevant because this code now only runs on
323 ;;; SBCL, but the comments are retained for culture: they might help
324 ;;; explain some of the design decisions which were made in the code.
328 ;;; The set of special forms is purposely kept very small because
329 ;;; any program analyzing program (read code walker) must have
330 ;;; special knowledge about every type of special form. Such a
331 ;;; program needs no special knowledge about macros...
333 ;;; So all we have to do here is a define a way to store and retrieve
334 ;;; templates which describe how to walk the 24 special forms and we
337 ;;; Well, its a nice concept, and I have to admit to being naive
338 ;;; enough that I believed it for a while, but not everyone takes
339 ;;; having only 24 special forms as seriously as might be nice. There
340 ;;; are (at least) 3 ways to lose:
342 ;;; 1 - Implementation x implements a Common Lisp special form as
343 ;;; a macro which expands into a special form which:
344 ;;; - Is a common lisp special form (not likely)
345 ;;; - Is not a common lisp special form (on the 3600 IF --> COND).
347 ;;; * We can save ourselves from this case (second subcase really)
348 ;;; by checking to see whether there is a template defined for
349 ;;; something before we check to see whether we can macroexpand it.
351 ;;; 2 - Implementation x implements a Common Lisp macro as a special form.
353 ;;; * This is a screw, but not so bad, we save ourselves from it by
354 ;;; defining extra templates for the macros which are *likely* to
355 ;;; be implemented as special forms. [Note: As of sbcl-0.6.9, these
356 ;;; extra templates have been deleted, since this is not a problem
357 ;;; in SBCL and we no longer try to make this walker portable
358 ;;; across other possibly-broken CL implementations.]
360 ;;; 3 - Implementation x has a special form which is not on the list of
361 ;;; Common Lisp special forms.
363 ;;; * This is a bad sort of a screw and happens more than I would
364 ;;; like to think, especially in the implementations which provide
365 ;;; more than just Common Lisp (3600, Xerox etc.).
366 ;;; The fix is not terribly satisfactory, but will have to do for
367 ;;; now. There is a hook in get walker-template which can get a
368 ;;; template from the implementation's own walker. That template
369 ;;; has to be converted, and so it may be that the right way to do
370 ;;; this would actually be for that implementation to provide an
371 ;;; interface to its walker which looks like the interface to this
374 (defmacro get-walker-template-internal (x)
375 `(get ,x 'walker-template))
377 (defmacro define-walker-template (name
378 &optional (template '(nil repeat (eval))))
379 `(eval-when (:load-toplevel :execute)
380 (setf (get-walker-template-internal ',name) ',template)))
382 (defun get-walker-template (x context)
384 (get-walker-template-internal x))
385 ((and (listp x) (eq (car x) 'lambda))
386 '(lambda repeat (eval)))
388 ;; FIXME: In an ideal world we would do something similar to
389 ;; COMPILER-ERROR here, replacing the form within the walker
390 ;; with an error-signalling form. This is slightly less
391 ;; pretty, but informative non the less. Best is the enemy of
393 (error "Illegal function call in method body:~% ~S"
396 ;;;; the actual templates
398 ;;; ANSI special forms
399 (define-walker-template block (nil nil repeat (eval)))
400 (define-walker-template catch (nil eval repeat (eval)))
401 (define-walker-template declare walk-unexpected-declare)
402 (define-walker-template eval-when (nil quote repeat (eval)))
403 (define-walker-template flet walk-flet)
404 (define-walker-template function (nil call))
405 (define-walker-template go (nil quote))
406 (define-walker-template if walk-if)
407 (define-walker-template labels walk-labels)
408 (define-walker-template lambda walk-lambda)
409 (define-walker-template let walk-let)
410 (define-walker-template let* walk-let*)
411 (define-walker-template locally walk-locally)
412 (define-walker-template macrolet walk-macrolet)
413 (define-walker-template multiple-value-call (nil eval repeat (eval)))
414 (define-walker-template multiple-value-prog1 (nil return repeat (eval)))
415 (define-walker-template multiple-value-setq walk-multiple-value-setq)
416 (define-walker-template multiple-value-bind walk-multiple-value-bind)
417 (define-walker-template progn (nil repeat (eval)))
418 (define-walker-template progv (nil eval eval repeat (eval)))
419 (define-walker-template quote (nil quote))
420 (define-walker-template return-from (nil quote repeat (return)))
421 (define-walker-template setq walk-setq)
422 (define-walker-template symbol-macrolet walk-symbol-macrolet)
423 (define-walker-template tagbody walk-tagbody)
424 (define-walker-template the (nil quote eval))
425 (define-walker-template throw (nil eval eval))
426 (define-walker-template unwind-protect (nil return repeat (eval)))
428 ;;; SBCL-only special forms
429 (define-walker-template sb!ext:truly-the (nil quote eval))
430 ;;; FIXME: maybe we don't need this one any more, given that
431 ;;; NAMED-LAMBDA now expands into (FUNCTION (NAMED-LAMBDA ...))?
432 (define-walker-template named-lambda walk-named-lambda)
434 (defvar *walk-form-expand-macros-p* nil)
436 (defun walk-form (form
437 &optional environment
439 (lambda (subform context env)
440 (declare (ignore context env))
442 (walker-environment-bind (new-env environment :walk-function walk-function)
443 (walk-form-internal form :eval new-env)))
445 ;;; WALK-FORM-INTERNAL is the main driving function for the code
446 ;;; walker. It takes a form and the current context and walks the form
447 ;;; calling itself or the appropriate template recursively.
449 ;;; "It is recommended that a program-analyzing-program process a form
450 ;;; that is a list whose car is a symbol as follows:
452 ;;; 1. If the program has particular knowledge about the symbol,
453 ;;; process the form using special-purpose code. All of the
454 ;;; standard special forms should fall into this category.
455 ;;; 2. Otherwise, if MACRO-FUNCTION is true of the symbol apply
456 ;;; either MACROEXPAND or MACROEXPAND-1 and start over.
457 ;;; 3. Otherwise, assume it is a function call. "
458 (defun walk-form-internal (form context env)
459 ;; First apply the walk-function to perform whatever translation
460 ;; the user wants to this form. If the second value returned
461 ;; by walk-function is T then we don't recurse...
463 (multiple-value-bind (newform walk-no-more-p)
464 (funcall (env-walk-function env) form context env)
467 (walk-no-more-p newform)
468 ((not (eq form newform))
469 (walk-form-internal newform context env))
470 ((not (consp newform))
471 (let ((symmac (car (variable-symbol-macro-p newform env))))
473 (let* ((newnewform (walk-form-internal (cddr symmac)
477 (if (eq newnewform (cddr symmac))
478 (if *walk-form-expand-macros-p* newnewform newform)
480 (type (env-var-type newform env)))
483 `(the ,type ,resultform)))
486 (let* ((fn (car newform))
487 (template (get-walker-template fn newform)))
489 (if (symbolp template)
490 (funcall template newform context env)
491 (walk-template newform template context env))
492 (multiple-value-bind (newnewform macrop)
493 (walker-environment-bind
494 (new-env env :walk-form newform)
495 (%macroexpand-1 newform new-env))
498 (let ((newnewnewform (walk-form-internal newnewform
501 (if (eq newnewnewform newnewform)
502 (if *walk-form-expand-macros-p* newnewform newform)
506 (special-operator-p fn))
507 ;; This shouldn't happen, since this walker is now
508 ;; maintained as part of SBCL, so it should know
509 ;; about all the special forms that SBCL knows
511 (bug "unexpected special form ~S" fn))
513 ;; Otherwise, walk the form as if it's just a
514 ;; standard function call using a template for
515 ;; standard function call.
517 newnewform '(call repeat (eval)) context env))))))))))))
519 (defun walk-template (form template context env)
522 ((eval function test effect return)
523 (walk-form-internal form :eval env))
526 (walk-form-internal form :set env))
528 (cond ((legal-fun-name-p form)
530 (t (walk-form-internal form context env)))))
533 (walk-template-handle-repeat form
535 ;; For the case where nothing
536 ;; happens after the repeat
537 ;; optimize away the call to
539 (if (null (cddr template))
541 (nthcdr (- (length form)
549 (if (if (listp (cadr template))
550 (eval (cadr template))
551 (funcall (cadr template) form))
557 (walk-template form (cadr template) context env))
559 (cond ((atom form) form)
562 (car form) (car template) context env)
564 (cdr form) (cdr template) context env))))))))
566 (defun walk-template-handle-repeat (form template stop-form context env)
567 (if (eq form stop-form)
568 (walk-template form (cdr template) context env)
569 (walk-template-handle-repeat-1
570 form template (car template) stop-form context env)))
572 (defun walk-template-handle-repeat-1 (form template repeat-template
573 stop-form context env)
574 (cond ((null form) ())
576 (if (null repeat-template)
577 (walk-template stop-form (cdr template) context env)
578 (error "while handling code walker REPEAT:
579 ~%ran into STOP while still in REPEAT template")))
580 ((null repeat-template)
581 (walk-template-handle-repeat-1
582 form template (car template) stop-form context env))
585 (walk-template (car form) (car repeat-template) context env)
586 (walk-template-handle-repeat-1 (cdr form)
588 (cdr repeat-template)
593 (defun walk-repeat-eval (form env)
596 (walk-form-internal (car form) :eval env)
597 (walk-repeat-eval (cdr form) env))))
599 (defun recons (x car cdr)
600 (if (or (not (eq (car x) car))
601 (not (eq (cdr x) cdr)))
605 (defun relist (x &rest args)
608 (relist-internal x args nil)))
610 (defun relist* (x &rest args)
611 (relist-internal x args t))
613 (defun relist-internal (x args *p)
614 (if (null (cdr args))
617 (recons x (car args) nil))
620 (relist-internal (cdr x) (cdr args) *p))))
624 (defun walk-declarations (body fn env
625 &optional doc-string-p declarations old-body
626 &aux (form (car body)) macrop new-form)
627 (cond ((and (stringp form) ;might be a doc string
628 (cdr body) ;isn't the returned value
629 (null doc-string-p) ;no doc string yet
630 (null declarations)) ;no declarations yet
633 (walk-declarations (cdr body) fn env t)))
634 ((and (listp form) (eq (car form) 'declare))
635 ;; We got ourselves a real live declaration. Record it, look
637 (dolist (declaration (cdr form))
638 (let ((type (car declaration))
639 (name (cadr declaration))
640 (args (cddr declaration)))
641 (if (walked-var-declaration-p type)
642 (note-declaration `(,type
643 ,(or (var-lexical-p name env) name)
646 (note-declaration (sb!c::canonized-decl-spec declaration) env))
647 (push declaration declarations)))
651 (cdr body) fn env doc-string-p declarations)))
654 (null (get-walker-template (car form) form))
656 (multiple-value-setq (new-form macrop)
657 (%macroexpand-1 form env))
659 ;; This form was a call to a macro. Maybe it expanded
660 ;; into a declare? Recurse to find out.
661 (walk-declarations (recons body new-form (cdr body))
662 fn env doc-string-p declarations
665 ;; Now that we have walked and recorded the declarations,
666 ;; call the function our caller provided to expand the body.
667 ;; We call that function rather than passing the real-body
668 ;; back, because we are RECONSING up the new body.
669 (funcall fn (or old-body body) env))))
671 (defun walk-unexpected-declare (form context env)
672 (declare (ignore context env))
673 (warn "encountered ~S ~_in a place where a DECLARE was not expected"
677 (defun walk-arglist (arglist context env &optional (destructuringp nil)
679 (cond ((null arglist) ())
680 ((symbolp (setq arg (car arglist)))
681 (or (member arg sb!xc:lambda-list-keywords :test #'eq)
682 (note-lexical-binding arg env))
685 (walk-arglist (cdr arglist)
689 (not (member arg sb!xc:lambda-list-keywords))))))
691 (prog1 (recons arglist
693 (walk-arglist arg context env destructuringp)
696 (walk-form-internal (cadr arg) :eval env)
698 (walk-arglist (cdr arglist) context env nil))
699 (if (symbolp (car arg))
700 (note-lexical-binding (car arg) env)
701 (note-lexical-binding (cadar arg) env))
702 (or (null (cddr arg))
703 (not (symbolp (caddr arg)))
704 (note-lexical-binding (caddr arg) env))))
706 (error "can't understand something in the arglist ~S" arglist))))
708 (defun walk-let (form context env)
709 (walk-let/let* form context env nil))
711 (defun walk-let* (form context env)
712 (walk-let/let* form context env t))
714 (defun walk-let/let* (form context old-env sequentialp)
715 (walker-environment-bind (new-env old-env)
716 (let* ((let/let* (car form))
717 (bindings (cadr form))
720 (walk-bindings-1 bindings
726 (walk-declarations body #'walk-repeat-eval new-env)))
728 form let/let* walked-bindings walked-body))))
730 (defun walk-locally (form context old-env)
731 (declare (ignore context))
732 (walker-environment-bind (new-env old-env)
733 (let* ((locally (car form))
736 (walk-declarations body #'walk-repeat-eval new-env)))
738 form locally walked-body))))
740 (defun walk-multiple-value-setq (form context env)
741 (let ((vars (cadr form)))
742 (if (some (lambda (var)
743 (variable-symbol-macro-p var env))
745 (let* ((temps (mapcar (lambda (var)
746 (declare (ignore var))
749 (sets (mapcar (lambda (var temp) `(setq ,var ,temp))
752 (expanded `(multiple-value-bind ,temps ,(caddr form)
754 (walked (walk-form-internal expanded context env)))
755 (if (eq walked expanded)
758 (walk-template form '(nil (repeat (set)) eval) context env))))
760 (defun walk-multiple-value-bind (form context old-env)
761 (walker-environment-bind (new-env old-env)
762 (let* ((mvb (car form))
763 (bindings (cadr form))
764 (mv-form (walk-template (caddr form) 'eval context old-env))
770 (lambda (real-body real-env)
771 (setq walked-bindings
772 (walk-bindings-1 bindings
777 (walk-repeat-eval real-body real-env))
779 (relist* form mvb walked-bindings mv-form walked-body))))
781 (defun walk-bindings-1 (bindings old-env new-env context sequentialp)
783 (let ((binding (car bindings)))
785 (if (symbolp binding)
787 (note-lexical-binding binding new-env))
788 (prog1 (relist* binding
790 (walk-form-internal (cadr binding)
795 ;; Save cddr for DO/DO*; it is
796 ;; the next value form. Don't
797 ;; walk it now, though.
799 (note-lexical-binding (car binding) new-env)))
800 (walk-bindings-1 (cdr bindings)
806 (defun walk-bindings-2 (bindings walked-bindings context env)
808 (let ((binding (car bindings))
809 (walked-binding (car walked-bindings)))
811 (if (symbolp binding)
815 (cadr walked-binding)
816 (walk-template (cddr binding)
820 (walk-bindings-2 (cdr bindings)
821 (cdr walked-bindings)
825 (defun walk-lambda (form context old-env)
826 (walker-environment-bind (new-env old-env)
827 (let* ((arglist (cadr form))
829 (walked-arglist (walk-arglist arglist context new-env))
831 (walk-declarations body #'walk-repeat-eval new-env)))
837 (defun walk-named-lambda (form context old-env)
838 (walker-environment-bind (new-env old-env)
839 (let* ((name (second form))
840 (arglist (third form))
842 (walked-arglist (walk-arglist arglist context new-env))
844 (walk-declarations body #'walk-repeat-eval new-env)))
851 (defun walk-setq (form context env)
853 (let* ((expanded (let ((rforms nil)
855 (loop (when (null tail) (return (nreverse rforms)))
856 (let ((var (pop tail)) (val (pop tail)))
857 (push `(setq ,var ,val) rforms)))))
858 (walked (walk-repeat-eval expanded env)))
859 (if (eq expanded walked)
862 (let* ((var (cadr form))
864 (symmac (car (variable-symbol-macro-p var env))))
866 (let* ((type (env-var-type var env))
867 (expanded (if (eq t type)
868 `(setf ,(cddr symmac) ,val)
869 `(setf ,(cddr symmac) (the ,type ,val))))
870 (walked (walk-form-internal expanded context env)))
871 (if (eq expanded walked)
875 (walk-form-internal var :set env)
876 (walk-form-internal val :eval env))))))
878 (defun walk-symbol-macrolet (form context old-env)
879 (declare (ignore context))
880 (let* ((bindings (cadr form))
882 (walker-environment-bind
885 (append (mapcar (lambda (binding)
887 sb!sys:macro . ,(cadr binding)))
889 (env-lexical-variables old-env)))
890 (relist* form 'symbol-macrolet bindings
891 (walk-declarations body #'walk-repeat-eval new-env)))))
893 (defun walk-tagbody (form context env)
894 (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
896 (defun walk-tagbody-1 (form context env)
899 (walk-form-internal (car form)
900 (if (symbolp (car form)) 'quote context)
902 (walk-tagbody-1 (cdr form) context env))))
904 (defun walk-macrolet (form context old-env)
905 (walker-environment-bind (old-env old-env)
906 (walker-environment-bind (macro-env
908 :walk-function (env-walk-function old-env))
909 (labels ((walk-definitions (definitions)
911 (let ((definition (car definitions)))
915 (walk-arglist (cadr definition)
919 (walk-declarations (cddr definition)
922 (walk-definitions (cdr definitions)))))))
923 (with-new-definition-in-environment (new-env old-env form)
926 (walk-definitions (cadr form))
927 (walk-declarations (cddr form)
931 (defun walk-flet (form context old-env)
932 (walker-environment-bind (old-env old-env)
933 (labels ((walk-definitions (definitions)
934 (if (null definitions)
937 (walk-lambda (car definitions) context old-env)
938 (walk-definitions (cdr definitions))))))
942 (walk-definitions (cadr form))
943 (with-new-definition-in-environment (new-env old-env form)
944 (walk-declarations (cddr form)
948 (defun walk-labels (form context old-env)
949 (walker-environment-bind (old-env old-env)
950 (with-new-definition-in-environment (new-env old-env form)
951 (labels ((walk-definitions (definitions)
952 (if (null definitions)
955 (walk-lambda (car definitions) context new-env)
956 (walk-definitions (cdr definitions))))))
960 (walk-definitions (cadr form))
961 (walk-declarations (cddr form)
965 (defun walk-if (form context env)
966 (destructuring-bind (if predicate arm1 &optional arm2) form
967 (declare (ignore if)) ; should be 'IF
970 (walk-form-internal predicate context env)
971 (walk-form-internal arm1 context env)
972 (walk-form-internal arm2 context env))))
977 ;;; Here are some examples of the kinds of things you should be able
978 ;;; to do with your implementation of the macroexpansion environment
979 ;;; hacking mechanism.
981 ;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes
982 ;;; names of the macros and actual macroexpansion functions to use to
983 ;;; macroexpand them. The win about that is that for macros which want
984 ;;; to wrap several MACROLETs around their body, they can do this but
985 ;;; have the macroexpansion functions be compiled. See the WITH-RPUSH
988 ;;; If the implementation had a special way of communicating the
989 ;;; augmented environment back to the evaluator that would be totally
990 ;;; great. It would mean that we could just augment the environment
991 ;;; then pass control back to the implementations own compiler or
992 ;;; interpreter. We wouldn't have to call the actual walker. That
993 ;;; would make this much faster. Since the principal client of this is
994 ;;; defmethod it would make compiling defmethods faster and that would
995 ;;; certainly be a win.
997 (defmacro with-lexical-macros (macros &body body &environment old-env)
998 (with-augmented-environment (new-env old-env :macros macros)
999 (walk-form (cons 'progn body) :environment new-env)))
1001 (defun expand-rpush (form env)
1002 (declare (ignore env))
1003 `(push ,(caddr form) ,(cadr form)))
1005 (defmacro with-rpush (&body body)
1006 `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))