1 ;;;; a simple code walker for PCL
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 ;;;; environment hacking stuff, necessarily SBCL-specific
34 ;;; Here in the original PCL were implementations of the
35 ;;; implementation-specific environment hacking functions for each of
36 ;;; the implementations this walker had been ported to. This
37 ;;; functionality was originally factored out in order to make PCL
38 ;;; portable from one Common Lisp to another. As of 19981107, that
39 ;;; portability was fairly stale and (because of the scarcity of CLTL1
40 ;;; implementations and the strong interdependence of the rest of ANSI
41 ;;; Common Lisp on the CLOS system) fairly irrelevant. It was fairly
42 ;;; thoroughly put out of its misery by WHN in his quest to clean up
43 ;;; the system enough that it can be built from scratch using any ANSI
46 ;;; This code just hacks 'macroexpansion environments'. That is, it is
47 ;;; only concerned with the function binding of symbols in the
48 ;;; environment. The walker needs to be able to tell if the symbol
49 ;;; names a lexical macro or function, and it needs to be able to
50 ;;; build environments which contain lexical macro or function
51 ;;; bindings. It must be able, when walking a MACROLET, FLET or LABELS
52 ;;; form to construct an environment which reflects the bindings
53 ;;; created by that form. Note that the environment created does NOT
54 ;;; have to be sufficient to evaluate the body, merely to walk its
55 ;;; body. This means that definitions do not have to be supplied for
56 ;;; lexical functions, only the fact that that function is bound is
57 ;;; important. For macros, the macroexpansion function must be
60 ;;; This code is organized in a way that lets it work in
61 ;;; implementations that stack cons their environments. That is
62 ;;; reflected in the fact that the only operation that lets a user
63 ;;; build a new environment is a WITH-BODY macro which executes its
64 ;;; body with the specified symbol bound to the new environment. No
65 ;;; code in this walker or in PCL will hold a pointer to these
66 ;;; environments after the body returns. Other user code is free to do
67 ;;; so in implementations where it works, but that code is not
68 ;;; considered portable.
70 ;;; There are 3 environment hacking tools. One macro,
71 ;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new
72 ;;; environments, and two functions, ENVIRONMENT-FUNCTION and
73 ;;; ENVIRONMENT-MACRO, which are used to access the bindings of
74 ;;; existing environments
76 ;;; In SBCL, as in CMU CL before it, the environment is represented
77 ;;; with a structure that holds alists for the functional things,
78 ;;; variables, blocks, etc.
79 ;;; Except for SYMBOL-MACROLET, only the SB-C::LEXENV-FUNCTIONS slot
80 ;;; is relevant. It holds: Alist (Name . What), where What is either
81 ;;; a functional (a local function) or a list (MACRO . <function>) (a
82 ;;; local macro, with the specifier expander.) Note that Name may be a
83 ;;; (SETF <name>) function.
84 ;;; Accessors are defined below, eg (ENV-WALK-FUNCTION ENV).
86 ;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND
87 ;;; this code hides the WALKER version of an environment
88 ;;; inside the SB-C::LEXENV structure.
90 ;;; In CMUCL (and former SBCL), This used to be a list of lists of form
91 ;;; (<gensym-name> MACRO . #<interpreted-function>) in the :functions slot
93 ;;; This form was accepted by the compiler, but this was a crude hack,
94 ;;; because the <interpreted-function> was used as a structure to hold the
95 ;;; bits of interest, {function, form, declarations, lexical-variables},
96 ;;; a list, which was not really an interpreted function.
97 ;;; Instead this list was COERCEd to a #<FUNCTION ...>!
99 ;;; Instead, we now use a special sort of "function"-type for that information,
100 ;;; because the functions slot in SB-C::LEXENV is supposed to have a list of
101 ;;; <Name MACRO . #<function> elements.
102 ;;; So, now we hide our bits of interest in the walker-info slot in our new
105 ;;; MACROEXPAND-1 is the only SBCL function that gets called with the
106 ;;; constructed environment argument.
108 (defmacro with-augmented-environment
109 ((new-env old-env &key functions macros) &body body)
110 `(let ((,new-env (with-augmented-environment-internal ,old-env
115 (defstruct (bogo-function
116 (:alternate-metaclass sb-kernel:funcallable-instance
117 sb-kernel:funcallable-structure-class
118 sb-kernel:make-funcallable-structure-class)
119 (:type sb-kernel:funcallable-structure)
121 (walker-info (required-argument) :type list))
123 (defun walker-info-to-bogo-function (x)
124 (make-bogo-function :walker-info x))
126 (defun bogo-function-to-walker-info (x)
127 (bogo-function-walker-info x))
129 (defun with-augmented-environment-internal (env functions macros)
130 ;; Note: In order to record the correct function definition, we
131 ;; would have to create an interpreted closure, but the
132 ;; WITH-NEW-DEFINITION macro down below makes no distinction between
133 ;; FLET and LABELS, so we have no idea what to use for the
134 ;; environment. So we just blow it off, 'cause anything real we do
135 ;; would be wrong. But we still have to make an entry so we can tell
136 ;; functions from macros.
137 (let ((env (or env (sb-kernel:make-null-lexenv))))
141 (append (mapcar (lambda (f)
142 (cons (car f) (sb-c::make-functional :lexenv env)))
147 (if (eq (car m) *key-to-walker-environment*)
148 (walker-info-to-bogo-function (cadr m))
149 (coerce (cadr m) 'function))))
152 (defun environment-function (env fn)
154 (let ((entry (assoc fn (sb-c::lexenv-functions env) :test #'equal)))
156 (sb-c::functional-p (cdr entry))
159 (defun environment-macro (env macro)
161 (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq)))
163 (eq (cadr entry) 'sb-c::macro)
164 (if (eq macro *key-to-walker-environment*)
165 (values (bogo-function-to-walker-info (cddr entry)))
166 (values (function-lambda-expression (cddr entry))))))))
168 ;;;; other environment hacking, not so SBCL-specific as the
169 ;;;; environment hacking in the previous section
171 (defmacro with-new-definition-in-environment
172 ((new-env old-env macrolet/flet/labels-form) &body body)
173 (let ((functions (make-symbol "Functions"))
174 (macros (make-symbol "Macros")))
175 `(let ((,functions ())
177 (ecase (car ,macrolet/flet/labels-form)
179 (dolist (fn (cadr ,macrolet/flet/labels-form))
180 (push fn ,functions)))
182 (dolist (mac (cadr ,macrolet/flet/labels-form))
183 (push (list (car mac)
184 (convert-macro-to-lambda (cadr mac)
188 (with-augmented-environment
189 (,new-env ,old-env :functions ,functions :macros ,macros)
192 (defun convert-macro-to-lambda (llist body &optional (name "dummy macro"))
193 (let ((gensym (make-symbol name)))
194 (eval `(defmacro ,gensym ,llist ,@body))
195 (macro-function gensym)))
197 ;;;; the actual walker
199 ;;; As the walker walks over the code, it communicates information to
200 ;;; itself about the walk. This information includes the walk
201 ;;; function, variable bindings, declarations in effect etc. This
202 ;;; information is inherently lexical, so the walker passes it around
203 ;;; in the actual environment the walker passes to macroexpansion
204 ;;; functions. This is what makes the NESTED-WALK-FORM facility work
206 (defmacro walker-environment-bind ((var env &rest key-args)
208 `(with-augmented-environment
209 (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
212 (defvar *key-to-walker-environment* (gensym))
214 (defun env-lock (env)
215 (environment-macro env *key-to-walker-environment*))
217 (defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
219 (declarations nil decp)
220 (lexical-variables nil lexp))
221 (let ((lock (environment-macro env *key-to-walker-environment*)))
223 (list *key-to-walker-environment*
224 (list (if wfnp walk-function (car lock))
225 (if wfop walk-form (cadr lock))
226 (if decp declarations (caddr lock))
227 (if lexp lexical-variables (cadddr lock)))))))
229 (defun env-walk-function (env)
230 (car (env-lock env)))
232 (defun env-walk-form (env)
233 (cadr (env-lock env)))
235 (defun env-declarations (env)
236 (caddr (env-lock env)))
238 (defun env-lexical-variables (env)
239 (cadddr (env-lock env)))
241 (defun note-declaration (declaration env)
242 (push declaration (caddr (env-lock env))))
244 (defun note-lexical-binding (thing env)
245 (push (list thing :lexical-var) (cadddr (env-lock env))))
247 (defun variable-lexical-p (var env)
248 (let ((entry (member var (env-lexical-variables env) :key #'car)))
249 (when (eq (cadar entry) :lexical-var)
252 (defun variable-symbol-macro-p (var env)
253 (let ((entry (member var (env-lexical-variables env) :key #'car)))
254 (when (eq (cadar entry) :macro)
257 (defvar *variable-declarations* '(special))
259 (defun variable-declaration (declaration var env)
260 (if (not (member declaration *variable-declarations*))
261 (error "~S is not a recognized variable declaration." declaration)
262 (let ((id (or (variable-lexical-p var env) var)))
263 (dolist (decl (env-declarations env))
264 (when (and (eq (car decl) declaration)
268 (defun variable-special-p (var env)
269 (or (not (null (variable-declaration 'special var env)))
270 (variable-globally-special-p var)))
272 (defun variable-globally-special-p (symbol)
273 (eq (info :variable :kind symbol) :special))
275 ;;;; handling of special forms
277 ;;; Here are some comments from the original PCL on the difficulty of
278 ;;; doing this portably across different CLTL1 implementations. This
279 ;;; is no longer directly relevant because this code now only runs on
280 ;;; SBCL, but the comments are retained for culture: they might help
281 ;;; explain some of the design decisions which were made in the code.
285 ;;; The set of special forms is purposely kept very small because
286 ;;; any program analyzing program (read code walker) must have
287 ;;; special knowledge about every type of special form. Such a
288 ;;; program needs no special knowledge about macros...
290 ;;; So all we have to do here is a define a way to store and retrieve
291 ;;; templates which describe how to walk the 24 special forms and we
294 ;;; Well, its a nice concept, and I have to admit to being naive
295 ;;; enough that I believed it for a while, but not everyone takes
296 ;;; having only 24 special forms as seriously as might be nice. There
297 ;;; are (at least) 3 ways to lose:
299 ;;; 1 - Implementation x implements a Common Lisp special form as
300 ;;; a macro which expands into a special form which:
301 ;;; - Is a common lisp special form (not likely)
302 ;;; - Is not a common lisp special form (on the 3600 IF --> COND).
304 ;;; * We can safe ourselves from this case (second subcase really)
305 ;;; by checking to see whether there is a template defined for
306 ;;; something before we check to see whether we can macroexpand it.
308 ;;; 2 - Implementation x implements a Common Lisp macro as a special form.
310 ;;; * This is a screw, but not so bad, we save ourselves from it by
311 ;;; defining extra templates for the macros which are *likely* to
312 ;;; be implemented as special forms. [Note: As of sbcl-0.6.9, these
313 ;;; extra templates have been deleted, since this is not a problem
314 ;;; in SBCL and we no longer try to make this walker portable
315 ;;; across other possibly-broken CL implementations.]
317 ;;; 3 - Implementation x has a special form which is not on the list of
318 ;;; Common Lisp special forms.
320 ;;; * This is a bad sort of a screw and happens more than I would
321 ;;; like to think, especially in the implementations which provide
322 ;;; more than just Common Lisp (3600, Xerox etc.).
323 ;;; The fix is not terribly satisfactory, but will have to do for
324 ;;; now. There is a hook in get walker-template which can get a
325 ;;; template from the implementation's own walker. That template
326 ;;; has to be converted, and so it may be that the right way to do
327 ;;; this would actually be for that implementation to provide an
328 ;;; interface to its walker which looks like the interface to this
331 (defmacro get-walker-template-internal (x)
332 `(get ,x 'walker-template))
334 (defmacro define-walker-template (name
335 &optional (template '(nil repeat (eval))))
336 `(eval-when (:load-toplevel :execute)
337 (setf (get-walker-template-internal ',name) ',template)))
339 (defun get-walker-template (x)
341 (get-walker-template-internal x))
342 ((and (listp x) (eq (car x) 'lambda))
343 '(lambda repeat (eval)))
345 (error "can't get template for ~S" x))))
347 ;;;; the actual templates
349 ;;; ANSI special forms
350 (define-walker-template block (nil nil repeat (eval)))
351 (define-walker-template catch (nil eval repeat (eval)))
352 (define-walker-template declare walk-unexpected-declare)
353 (define-walker-template eval-when (nil quote repeat (eval)))
354 (define-walker-template flet walk-flet)
355 (define-walker-template function (nil call))
356 (define-walker-template go (nil quote))
357 (define-walker-template if walk-if)
358 (define-walker-template labels walk-labels)
359 (define-walker-template lambda walk-lambda)
360 (define-walker-template let walk-let)
361 (define-walker-template let* walk-let*)
362 (define-walker-template locally walk-locally)
363 (define-walker-template macrolet walk-macrolet)
364 (define-walker-template multiple-value-call (nil eval repeat (eval)))
365 (define-walker-template multiple-value-prog1 (nil return repeat (eval)))
366 (define-walker-template multiple-value-setq walk-multiple-value-setq)
367 (define-walker-template multiple-value-bind walk-multiple-value-bind)
368 (define-walker-template progn (nil repeat (eval)))
369 (define-walker-template progv (nil eval eval repeat (eval)))
370 (define-walker-template quote (nil quote))
371 (define-walker-template return-from (nil quote repeat (return)))
372 (define-walker-template setq walk-setq)
373 (define-walker-template symbol-macrolet walk-symbol-macrolet)
374 (define-walker-template tagbody walk-tagbody)
375 (define-walker-template the (nil quote eval))
376 (define-walker-template throw (nil eval eval))
377 (define-walker-template unwind-protect (nil return repeat (eval)))
379 ;;; SBCL-only special forms
380 (define-walker-template sb-ext:truly-the (nil quote eval))
382 (defvar *walk-form-expand-macros-p* nil)
384 (defun walk-form (form
385 &optional environment
387 (lambda (subform context env)
388 (declare (ignore context env))
390 (walker-environment-bind (new-env environment :walk-function walk-function)
391 (walk-form-internal form :eval new-env)))
393 ;;; WALK-FORM-INTERNAL is the main driving function for the code
394 ;;; walker. It takes a form and the current context and walks the form
395 ;;; calling itself or the appropriate template recursively.
397 ;;; "It is recommended that a program-analyzing-program process a form
398 ;;; that is a list whose car is a symbol as follows:
400 ;;; 1. If the program has particular knowledge about the symbol,
401 ;;; process the form using special-purpose code. All of the
402 ;;; standard special forms should fall into this category.
403 ;;; 2. Otherwise, if MACRO-FUNCTION is true of the symbol apply
404 ;;; either MACROEXPAND or MACROEXPAND-1 and start over.
405 ;;; 3. Otherwise, assume it is a function call. "
406 (defun walk-form-internal (form context env)
407 ;; First apply the walk-function to perform whatever translation
408 ;; the user wants to this form. If the second value returned
409 ;; by walk-function is T then we don't recurse...
411 (multiple-value-bind (newform walk-no-more-p)
412 (funcall (env-walk-function env) form context env)
415 (walk-no-more-p newform)
416 ((not (eq form newform))
417 (walk-form-internal newform context env))
418 ((not (consp newform))
419 (let ((symmac (car (variable-symbol-macro-p newform env))))
421 (let ((newnewform (walk-form-internal (cddr symmac)
424 (if (eq newnewform (cddr symmac))
425 (if *walk-form-expand-macros-p* newnewform newform)
429 (let* ((fn (car newform))
430 (template (get-walker-template fn)))
432 (if (symbolp template)
433 (funcall template newform context env)
434 (walk-template newform template context env))
435 (multiple-value-bind (newnewform macrop)
436 (walker-environment-bind
437 (new-env env :walk-form newform)
438 (macroexpand-1 newform new-env))
441 (let ((newnewnewform (walk-form-internal newnewform
444 (if (eq newnewnewform newnewform)
445 (if *walk-form-expand-macros-p* newnewform newform)
449 (special-operator-p fn))
450 ;; This shouldn't happen, since this walker is now
451 ;; maintained as part of SBCL, so it should know
452 ;; about all the special forms that SBCL knows
454 (error "unexpected special form ~S" fn))
456 ;; Otherwise, walk the form as if it's just a
457 ;; standard function call using a template for
458 ;; standard function call.
460 newnewform '(call repeat (eval)) context env))))))))))))
462 (defun walk-template (form template context env)
465 ((eval function test effect return)
466 (walk-form-internal form :eval env))
469 (walk-form-internal form :set env))
471 (cond ((or (symbolp form)
474 (eq (car form) 'setf)))
476 (t (walk-form-internal form context env)))))
479 (walk-template-handle-repeat form
481 ;; For the case where nothing
482 ;; happens after the repeat
483 ;; optimize away the call to
485 (if (null (cddr template))
487 (nthcdr (- (length form)
495 (if (if (listp (cadr template))
496 (eval (cadr template))
497 (funcall (cadr template) form))
503 (walk-template form (cadr template) context env))
505 (cond ((atom form) form)
508 (car form) (car template) context env)
510 (cdr form) (cdr template) context env))))))))
512 (defun walk-template-handle-repeat (form template stop-form context env)
513 (if (eq form stop-form)
514 (walk-template form (cdr template) context env)
515 (walk-template-handle-repeat-1 form
522 (defun walk-template-handle-repeat-1 (form template repeat-template
523 stop-form context env)
524 (cond ((null form) ())
526 (if (null repeat-template)
527 (walk-template stop-form (cdr template) context env)
528 (error "while handling code walker REPEAT:
529 ~%ran into STOP while still in REPEAT template")))
530 ((null repeat-template)
531 (walk-template-handle-repeat-1
532 form template (car template) stop-form context env))
535 (walk-template (car form) (car repeat-template) context env)
536 (walk-template-handle-repeat-1 (cdr form)
538 (cdr repeat-template)
543 (defun walk-repeat-eval (form env)
546 (walk-form-internal (car form) :eval env)
547 (walk-repeat-eval (cdr form) env))))
549 (defun recons (x car cdr)
550 (if (or (not (eq (car x) car))
551 (not (eq (cdr x) cdr)))
555 (defun relist (x &rest args)
558 (relist-internal x args nil)))
560 (defun relist* (x &rest args)
561 (relist-internal x args t))
563 (defun relist-internal (x args *p)
564 (if (null (cdr args))
567 (recons x (car args) nil))
570 (relist-internal (cdr x) (cdr args) *p))))
574 (defun walk-declarations (body fn env
575 &optional doc-string-p declarations old-body
576 &aux (form (car body)) macrop new-form)
577 (cond ((and (stringp form) ;might be a doc string
578 (cdr body) ;isn't the returned value
579 (null doc-string-p) ;no doc string yet
580 (null declarations)) ;no declarations yet
583 (walk-declarations (cdr body) fn env t)))
584 ((and (listp form) (eq (car form) 'declare))
585 ;; We got ourselves a real live declaration. Record it, look
587 (dolist (declaration (cdr form))
588 (let ((type (car declaration))
589 (name (cadr declaration))
590 (args (cddr declaration)))
591 (if (member type *variable-declarations*)
592 (note-declaration `(,type
593 ,(or (variable-lexical-p name env) name)
596 (note-declaration declaration env))
597 (push declaration declarations)))
601 (cdr body) fn env doc-string-p declarations)))
604 (null (get-walker-template (car form)))
606 (multiple-value-setq (new-form macrop)
607 (macroexpand-1 form env))
609 ;; This form was a call to a macro. Maybe it expanded
610 ;; into a declare? Recurse to find out.
611 (walk-declarations (recons body new-form (cdr body))
612 fn env doc-string-p declarations
615 ;; Now that we have walked and recorded the declarations,
616 ;; call the function our caller provided to expand the body.
617 ;; We call that function rather than passing the real-body
618 ;; back, because we are RECONSING up the new body.
619 (funcall fn (or old-body body) env))))
621 (defun walk-unexpected-declare (form context env)
622 (declare (ignore context env))
623 (warn "encountered DECLARE ~S in a place where a DECLARE was not expected"
627 (defun walk-arglist (arglist context env &optional (destructuringp nil)
629 (cond ((null arglist) ())
630 ((symbolp (setq arg (car arglist)))
631 (or (member arg lambda-list-keywords)
632 (note-lexical-binding arg env))
635 (walk-arglist (cdr arglist)
640 lambda-list-keywords))))))
642 (prog1 (recons arglist
644 (walk-arglist arg context env destructuringp)
647 (walk-form-internal (cadr arg) :eval env)
649 (walk-arglist (cdr arglist) context env nil))
650 (if (symbolp (car arg))
651 (note-lexical-binding (car arg) env)
652 (note-lexical-binding (cadar arg) env))
653 (or (null (cddr arg))
654 (not (symbolp (caddr arg)))
655 (note-lexical-binding (caddr arg) env))))
657 (error "can't understand something in the arglist ~S" arglist))))
659 (defun walk-let (form context env)
660 (walk-let/let* form context env nil))
662 (defun walk-let* (form context env)
663 (walk-let/let* form context env t))
665 (defun walk-let/let* (form context old-env sequentialp)
666 (walker-environment-bind (new-env old-env)
667 (let* ((let/let* (car form))
668 (bindings (cadr form))
671 (walk-bindings-1 bindings
677 (walk-declarations body #'walk-repeat-eval new-env)))
679 form let/let* walked-bindings walked-body))))
681 (defun walk-locally (form context env)
682 (declare (ignore context))
683 (let* ((locally (car form))
686 (walk-declarations body #'walk-repeat-eval env)))
688 form locally walked-body)))
690 (defun walk-let-if (form context env)
691 (let ((test (cadr form))
692 (bindings (caddr form))
696 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
698 (flet ((.let-if-dummy. () ,@body))
700 (let ,bindings (.let-if-dummy.))
705 (defun walk-multiple-value-setq (form context env)
706 (let ((vars (cadr form)))
707 (if (some #'(lambda (var)
708 (variable-symbol-macro-p var env))
710 (let* ((temps (mapcar #'(lambda (var)
711 (declare (ignore var))
714 (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp))
717 (expanded `(multiple-value-bind ,temps ,(caddr form)
719 (walked (walk-form-internal expanded context env)))
720 (if (eq walked expanded)
723 (walk-template form '(nil (repeat (set)) eval) context env))))
725 (defun walk-multiple-value-bind (form context old-env)
726 (walker-environment-bind (new-env old-env)
727 (let* ((mvb (car form))
728 (bindings (cadr form))
729 (mv-form (walk-template (caddr form) 'eval context old-env))
735 #'(lambda (real-body real-env)
736 (setq walked-bindings
737 (walk-bindings-1 bindings
742 (walk-repeat-eval real-body real-env))
744 (relist* form mvb walked-bindings mv-form walked-body))))
746 (defun walk-bindings-1 (bindings old-env new-env context sequentialp)
748 (let ((binding (car bindings)))
750 (if (symbolp binding)
752 (note-lexical-binding binding new-env))
753 (prog1 (relist* binding
755 (walk-form-internal (cadr binding)
760 ;; Save cddr for DO/DO*; it is
761 ;; the next value form. Don't
762 ;; walk it now, though.
764 (note-lexical-binding (car binding) new-env)))
765 (walk-bindings-1 (cdr bindings)
771 (defun walk-bindings-2 (bindings walked-bindings context env)
773 (let ((binding (car bindings))
774 (walked-binding (car walked-bindings)))
776 (if (symbolp binding)
780 (cadr walked-binding)
781 (walk-template (cddr binding)
785 (walk-bindings-2 (cdr bindings)
786 (cdr walked-bindings)
790 (defun walk-lambda (form context old-env)
791 (walker-environment-bind (new-env old-env)
792 (let* ((arglist (cadr form))
794 (walked-arglist (walk-arglist arglist context new-env))
796 (walk-declarations body #'walk-repeat-eval new-env)))
802 (defun walk-named-lambda (form context old-env)
803 (walker-environment-bind (new-env old-env)
804 (let* ((name (cadr form))
805 (arglist (caddr form))
807 (walked-arglist (walk-arglist arglist context new-env))
809 (walk-declarations body #'walk-repeat-eval new-env)))
816 (defun walk-setq (form context env)
818 (let* ((expanded (let ((rforms nil)
820 (loop (when (null tail) (return (nreverse rforms)))
821 (let ((var (pop tail)) (val (pop tail)))
822 (push `(setq ,var ,val) rforms)))))
823 (walked (walk-repeat-eval expanded env)))
824 (if (eq expanded walked)
827 (let* ((var (cadr form))
829 (symmac (car (variable-symbol-macro-p var env))))
831 (let* ((expanded `(setf ,(cddr symmac) ,val))
832 (walked (walk-form-internal expanded context env)))
833 (if (eq expanded walked)
837 (walk-form-internal var :set env)
838 (walk-form-internal val :eval env))))))
840 (defun walk-symbol-macrolet (form context old-env)
841 (declare (ignore context))
842 (let* ((bindings (cadr form))
844 (walker-environment-bind
847 (append (mapcar #'(lambda (binding)
849 :macro . ,(cadr binding)))
851 (env-lexical-variables old-env)))
852 (relist* form 'symbol-macrolet bindings
853 (walk-declarations body #'walk-repeat-eval new-env)))))
855 (defun walk-tagbody (form context env)
856 (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
858 (defun walk-tagbody-1 (form context env)
861 (walk-form-internal (car form)
862 (if (symbolp (car form)) 'quote context)
864 (walk-tagbody-1 (cdr form) context env))))
866 (defun walk-macrolet (form context old-env)
867 (walker-environment-bind (macro-env
869 :walk-function (env-walk-function old-env))
870 (labels ((walk-definitions (definitions)
872 (let ((definition (car definitions)))
876 (walk-arglist (cadr definition)
880 (walk-declarations (cddr definition)
883 (walk-definitions (cdr definitions)))))))
884 (with-new-definition-in-environment (new-env old-env form)
887 (walk-definitions (cadr form))
888 (walk-declarations (cddr form)
892 (defun walk-flet (form context old-env)
893 (labels ((walk-definitions (definitions)
894 (if (null definitions)
897 (walk-lambda (car definitions) context old-env)
898 (walk-definitions (cdr definitions))))))
902 (walk-definitions (cadr form))
903 (with-new-definition-in-environment (new-env old-env form)
904 (walk-declarations (cddr form)
908 (defun walk-labels (form context old-env)
909 (with-new-definition-in-environment (new-env old-env form)
910 (labels ((walk-definitions (definitions)
911 (if (null definitions)
914 (walk-lambda (car definitions) context new-env)
915 (walk-definitions (cdr definitions))))))
919 (walk-definitions (cadr form))
920 (walk-declarations (cddr form)
924 (defun walk-if (form context env)
925 (destructuring-bind (if predicate arm1 &optional arm2) form
926 (declare (ignore if)) ; should be 'IF
929 (walk-form-internal predicate context env)
930 (walk-form-internal arm1 context env)
931 (walk-form-internal arm2 context env))))
936 ;;; Here are some examples of the kinds of things you should be able
937 ;;; to do with your implementation of the macroexpansion environment
938 ;;; hacking mechanism.
940 ;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes
941 ;;; names of the macros and actual macroexpansion functions to use to
942 ;;; macroexpand them. The win about that is that for macros which want
943 ;;; to wrap several MACROLETs around their body, they can do this but
944 ;;; have the macroexpansion functions be compiled. See the WITH-RPUSH
947 ;;; If the implementation had a special way of communicating the
948 ;;; augmented environment back to the evaluator that would be totally
949 ;;; great. It would mean that we could just augment the environment
950 ;;; then pass control back to the implementations own compiler or
951 ;;; interpreter. We wouldn't have to call the actual walker. That
952 ;;; would make this much faster. Since the principal client of this is
953 ;;; defmethod it would make compiling defmethods faster and that would
954 ;;; certainly be a win.
956 (defmacro with-lexical-macros (macros &body body &environment old-env)
957 (with-augmented-environment (new-env old-env :macros macros)
958 (walk-form (cons 'progn body) :environment new-env)))
960 (defun expand-rpush (form env)
961 (declare (ignore env))
962 `(push ,(caddr form) ,(cadr form)))
964 (defmacro with-rpush (&body body)
965 `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))