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 frobbing stuff
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. Only the c::lexenv-functions slot is
79 ;;; relevant. It holds: Alist (name . what), where What is either a
80 ;;; Functional (a local function) or a list (MACRO . <function>) (a
81 ;;; local macro, with the specifier expander.) Note that Name may be a
82 ;;; (SETF <name>) function.
84 (defmacro with-augmented-environment
85 ((new-env old-env &key functions macros) &body body)
86 `(let ((,new-env (with-augmented-environment-internal ,old-env
91 ;;; KLUDGE: In CMU CL, when X was an arbitrary list, even one which
92 ;;; did not name a function or describe a lambda expression, calling
93 ;;; (EVAL `(FUNCTION ,X)) would still return a FUNCTION object, and no
94 ;;; error would be signalled until/unless you tried to FUNCALL the
95 ;;; resulting FUNCTION object. (This behavior was also present in
96 ;;; (COERCE X 'FUNCTION), which was defined in terms of (EVAL
97 ;;; `(FUNCTION ,X)).) This function provides roughly the same behavior
98 ;;; as the old CMU CL (COERCE X 'FUNCTION), for the benefit of PCL
99 ;;; code which relied on being able to coerce bogus things without
100 ;;; raising errors as long as it never tried to actually call them.
101 (defun bogo-coerce-to-function (x)
102 (or (ignore-errors (coerce x 'function))
104 (declare (ignore rest))
105 (error "can't FUNCALL bogo-coerced-to-function ~S" x))))
107 (defun with-augmented-environment-internal (env functions macros)
108 ;; Note: In order to record the correct function definition, we
109 ;; would have to create an interpreted closure, but the
110 ;; with-new-definition macro down below makes no distinction between
111 ;; FLET and LABELS, so we have no idea what to use for the
112 ;; environment. So we just blow it off, 'cause anything real we do
113 ;; would be wrong. We still have to make an entry so we can tell
114 ;; functions from macros.
115 (let ((env (or env (sb-kernel:make-null-lexenv))))
119 (append (mapcar (lambda (f)
120 (cons (car f) (sb-c::make-functional :lexenv env)))
125 (bogo-coerce-to-function (cadr m))))
128 (defun environment-function (env fn)
130 (let ((entry (assoc fn (sb-c::lexenv-functions env) :test #'equal)))
132 (sb-c::functional-p (cdr entry))
135 (defun environment-macro (env macro)
137 (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq)))
139 (eq (cadr entry) 'sb-c::macro)
140 (function-lambda-expression (cddr entry))))))
142 (defmacro with-new-definition-in-environment
143 ((new-env old-env macrolet/flet/labels-form) &body body)
144 (let ((functions (make-symbol "Functions"))
145 (macros (make-symbol "Macros")))
146 `(let ((,functions ())
148 (ecase (car ,macrolet/flet/labels-form)
150 (dolist (fn (cadr ,macrolet/flet/labels-form))
151 (push fn ,functions)))
153 (dolist (mac (cadr ,macrolet/flet/labels-form))
154 (push (list (car mac)
155 (convert-macro-to-lambda (cadr mac)
159 (with-augmented-environment
160 (,new-env ,old-env :functions ,functions :macros ,macros)
163 (defun convert-macro-to-lambda (llist body &optional (name "dummy macro"))
164 (let ((gensym (make-symbol name)))
165 (eval `(defmacro ,gensym ,llist ,@body))
166 (macro-function gensym)))
168 ;;; Now comes the real walker.
170 ;;; As the walker walks over the code, it communicates information to
171 ;;; itself about the walk. This information includes the walk
172 ;;; function, variable bindings, declarations in effect etc. This
173 ;;; information is inherently lexical, so the walker passes it around
174 ;;; in the actual environment the walker passes to macroexpansion
175 ;;; functions. This is what makes the NESTED-WALK-FORM facility work
177 (defmacro walker-environment-bind ((var env &rest key-args)
179 `(with-augmented-environment
180 (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
183 (defvar *key-to-walker-environment* (gensym))
185 (defun env-lock (env)
186 (environment-macro env *key-to-walker-environment*))
188 (defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
190 (declarations nil decp)
191 (lexical-variables nil lexp))
192 (let ((lock (environment-macro env *key-to-walker-environment*)))
194 (list *key-to-walker-environment*
195 (list (if wfnp walk-function (car lock))
196 (if wfop walk-form (cadr lock))
197 (if decp declarations (caddr lock))
198 (if lexp lexical-variables (cadddr lock)))))))
200 (defun env-walk-function (env)
201 (car (env-lock env)))
203 (defun env-walk-form (env)
204 (cadr (env-lock env)))
206 (defun env-declarations (env)
207 (caddr (env-lock env)))
209 (defun env-lexical-variables (env)
210 (cadddr (env-lock env)))
212 (defun note-declaration (declaration env)
213 (push declaration (caddr (env-lock env))))
215 (defun note-lexical-binding (thing env)
216 (push (list thing :lexical-var) (cadddr (env-lock env))))
218 (defun variable-lexical-p (var env)
219 (let ((entry (member var (env-lexical-variables env) :key #'car)))
220 (when (eq (cadar entry) :lexical-var)
223 (defun variable-symbol-macro-p (var env)
224 (let ((entry (member var (env-lexical-variables env) :key #'car)))
225 (when (eq (cadar entry) :macro)
228 (defvar *variable-declarations* '(special))
230 (defun variable-declaration (declaration var env)
231 (if (not (member declaration *variable-declarations*))
232 (error "~S is not a recognized variable declaration." declaration)
233 (let ((id (or (variable-lexical-p var env) var)))
234 (dolist (decl (env-declarations env))
235 (when (and (eq (car decl) declaration)
239 (defun variable-special-p (var env)
240 (or (not (null (variable-declaration 'special var env)))
241 (variable-globally-special-p var)))
243 (defun variable-globally-special-p (symbol)
244 (eq (sb-int:info :variable :kind symbol) :special))
246 ;;;; handling of special forms
248 ;;; Here are some comments from the original PCL on the difficulty of
249 ;;; doing this portably across different CLTL1 implementations. This
250 ;;; is no longer directly relevant because this code now only runs on
251 ;;; SBCL, but the comments are retained for culture: they might help
252 ;;; explain some of the design decisions which were made in the code.
256 ;;; The set of special forms is purposely kept very small because
257 ;;; any program analyzing program (read code walker) must have
258 ;;; special knowledge about every type of special form. Such a
259 ;;; program needs no special knowledge about macros...
261 ;;; So all we have to do here is a define a way to store and retrieve
262 ;;; templates which describe how to walk the 24 special forms and we
265 ;;; Well, its a nice concept, and I have to admit to being naive
266 ;;; enough that I believed it for a while, but not everyone takes
267 ;;; having only 24 special forms as seriously as might be nice. There
268 ;;; are (at least) 3 ways to lose:
270 ;;; 1 - Implementation x implements a Common Lisp special form as
271 ;;; a macro which expands into a special form which:
272 ;;; - Is a common lisp special form (not likely)
273 ;;; - Is not a common lisp special form (on the 3600 IF --> COND).
275 ;;; * We can safe ourselves from this case (second subcase really)
276 ;;; by checking to see whether there is a template defined for
277 ;;; something before we check to see whether we can macroexpand it.
279 ;;; 2 - Implementation x implements a Common Lisp macro as a special form.
281 ;;; * This is a screw, but not so bad, we save ourselves from it by
282 ;;; defining extra templates for the macros which are *likely* to
283 ;;; be implemented as special forms. [Note: As of sbcl-0.6.9, these
284 ;;; extra templates have been deleted, since this is not a problem
285 ;;; in SBCL and we no longer try to make this walker portable
286 ;;; across other possibly-broken CL implementations.]
288 ;;; 3 - Implementation x has a special form which is not on the list of
289 ;;; Common Lisp special forms.
291 ;;; * This is a bad sort of a screw and happens more than I would
292 ;;; like to think, especially in the implementations which provide
293 ;;; more than just Common Lisp (3600, Xerox etc.).
294 ;;; The fix is not terribly satisfactory, but will have to do for
295 ;;; now. There is a hook in get walker-template which can get a
296 ;;; template from the implementation's own walker. That template
297 ;;; has to be converted, and so it may be that the right way to do
298 ;;; this would actually be for that implementation to provide an
299 ;;; interface to its walker which looks like the interface to this
302 (defmacro get-walker-template-internal (x)
303 `(get ,x 'walker-template))
305 (defmacro define-walker-template (name
306 &optional (template '(nil repeat (eval))))
307 `(eval-when (:load-toplevel :execute)
308 (setf (get-walker-template-internal ',name) ',template)))
310 (defun get-walker-template (x)
312 (or (get-walker-template-internal x)
313 (get-implementation-dependent-walker-template x)))
314 ((and (listp x) (eq (car x) 'lambda))
315 '(lambda repeat (eval)))
317 (error "can't get template for ~S" x))))
319 ;;; FIXME: This can go away in SBCL.
320 (defun get-implementation-dependent-walker-template (x)
324 ;;;; the actual templates
326 ;;; ANSI special forms
327 (define-walker-template block (nil nil repeat (eval)))
328 (define-walker-template catch (nil eval repeat (eval)))
329 (define-walker-template declare walk-unexpected-declare)
330 (define-walker-template eval-when (nil quote repeat (eval)))
331 (define-walker-template flet walk-flet)
332 (define-walker-template function (nil call))
333 (define-walker-template go (nil quote))
334 (define-walker-template if walk-if)
335 (define-walker-template labels walk-labels)
336 (define-walker-template lambda walk-lambda)
337 (define-walker-template let walk-let)
338 (define-walker-template let* walk-let*)
339 (define-walker-template locally walk-locally)
340 (define-walker-template macrolet walk-macrolet)
341 (define-walker-template multiple-value-call (nil eval repeat (eval)))
342 (define-walker-template multiple-value-prog1 (nil return repeat (eval)))
343 (define-walker-template multiple-value-setq walk-multiple-value-setq)
344 (define-walker-template multiple-value-bind walk-multiple-value-bind)
345 (define-walker-template progn (nil repeat (eval)))
346 (define-walker-template progv (nil eval eval repeat (eval)))
347 (define-walker-template quote (nil quote))
348 (define-walker-template return-from (nil quote repeat (return)))
349 (define-walker-template setq walk-setq)
350 (define-walker-template symbol-macrolet walk-symbol-macrolet)
351 (define-walker-template tagbody walk-tagbody)
352 (define-walker-template the (nil quote eval))
353 (define-walker-template throw (nil eval eval))
354 (define-walker-template unwind-protect (nil return repeat (eval)))
356 ;;; SBCL-only special forms
357 (define-walker-template sb-ext:truly-the (nil quote eval))
359 (defvar *walk-form-expand-macros-p* nil)
361 (defun walk-form (form
362 &optional environment
364 #'(lambda (subform context env)
365 (declare (ignore context env))
367 (walker-environment-bind (new-env environment :walk-function walk-function)
368 (walk-form-internal form :eval new-env)))
370 ;;; WALK-FORM-INTERNAL is the main driving function for the code
371 ;;; walker. It takes a form and the current context and walks the form
372 ;;; calling itself or the appropriate template recursively.
374 ;;; "It is recommended that a program-analyzing-program process a form
375 ;;; that is a list whose car is a symbol as follows:
377 ;;; 1. If the program has particular knowledge about the symbol,
378 ;;; process the form using special-purpose code. All of the
379 ;;; standard special forms should fall into this category.
380 ;;; 2. Otherwise, if MACRO-FUNCTION is true of the symbol apply
381 ;;; either MACROEXPAND or MACROEXPAND-1 and start over.
382 ;;; 3. Otherwise, assume it is a function call. "
383 (defun walk-form-internal (form context env)
384 ;; First apply the walk-function to perform whatever translation
385 ;; the user wants to this form. If the second value returned
386 ;; by walk-function is T then we don't recurse...
388 (multiple-value-bind (newform walk-no-more-p)
389 (funcall (env-walk-function env) form context env)
392 (walk-no-more-p newform)
393 ((not (eq form newform))
394 (walk-form-internal newform context env))
395 ((not (consp newform))
396 (let ((symmac (car (variable-symbol-macro-p newform env))))
398 (let ((newnewform (walk-form-internal (cddr symmac)
401 (if (eq newnewform (cddr symmac))
402 (if *walk-form-expand-macros-p* newnewform newform)
406 (let* ((fn (car newform))
407 (template (get-walker-template fn)))
409 (if (symbolp template)
410 (funcall template newform context env)
411 (walk-template newform template context env))
412 (multiple-value-bind (newnewform macrop)
413 (walker-environment-bind
414 (new-env env :walk-form newform)
415 (macroexpand-1 newform new-env))
418 (let ((newnewnewform (walk-form-internal newnewform
421 (if (eq newnewnewform newnewform)
422 (if *walk-form-expand-macros-p* newnewform newform)
426 (special-operator-p fn))
427 ;; This shouldn't happen, since this walker is now
428 ;; maintained as part of SBCL, so it should know
429 ;; about all the special forms that SBCL knows
431 (error "unexpected special form ~S" fn))
433 ;; Otherwise, walk the form as if it's just a
434 ;; standard function call using a template for
435 ;; standard function call.
437 newnewform '(call repeat (eval)) context env))))))))))))
439 (defun walk-template (form template context env)
442 ((eval function test effect return)
443 (walk-form-internal form :eval env))
446 (walk-form-internal form :set env))
448 (cond ((or (symbolp form)
451 (eq (car form) 'setf)))
453 (t (walk-form-internal form context env)))))
456 (walk-template-handle-repeat form
458 ;; For the case where nothing
459 ;; happens after the repeat
460 ;; optimize away the call to
462 (if (null (cddr template))
464 (nthcdr (- (length form)
472 (if (if (listp (cadr template))
473 (eval (cadr template))
474 (funcall (cadr template) form))
480 (walk-template form (cadr template) context env))
482 (cond ((atom form) form)
485 (car form) (car template) context env)
487 (cdr form) (cdr template) context env))))))))
489 (defun walk-template-handle-repeat (form template stop-form context env)
490 (if (eq form stop-form)
491 (walk-template form (cdr template) context env)
492 (walk-template-handle-repeat-1 form
499 (defun walk-template-handle-repeat-1 (form template repeat-template
500 stop-form context env)
501 (cond ((null form) ())
503 (if (null repeat-template)
504 (walk-template stop-form (cdr template) context env)
505 (error "while handling code walker REPEAT:
506 ~%ran into STOP while still in REPEAT template")))
507 ((null repeat-template)
508 (walk-template-handle-repeat-1
509 form template (car template) stop-form context env))
512 (walk-template (car form) (car repeat-template) context env)
513 (walk-template-handle-repeat-1 (cdr form)
515 (cdr repeat-template)
520 (defun walk-repeat-eval (form env)
523 (walk-form-internal (car form) :eval env)
524 (walk-repeat-eval (cdr form) env))))
526 (defun recons (x car cdr)
527 (if (or (not (eq (car x) car))
528 (not (eq (cdr x) cdr)))
532 (defun relist (x &rest args)
535 (relist-internal x args nil)))
537 (defun relist* (x &rest args)
538 (relist-internal x args 't))
540 (defun relist-internal (x args *p)
541 (if (null (cdr args))
544 (recons x (car args) nil))
547 (relist-internal (cdr x) (cdr args) *p))))
551 (defun walk-declarations (body fn env
552 &optional doc-string-p declarations old-body
553 &aux (form (car body)) macrop new-form)
554 (cond ((and (stringp form) ;might be a doc string
555 (cdr body) ;isn't the returned value
556 (null doc-string-p) ;no doc string yet
557 (null declarations)) ;no declarations yet
560 (walk-declarations (cdr body) fn env t)))
561 ((and (listp form) (eq (car form) 'declare))
562 ;; We got ourselves a real live declaration. Record it, look
564 (dolist (declaration (cdr form))
565 (let ((type (car declaration))
566 (name (cadr declaration))
567 (args (cddr declaration)))
568 (if (member type *variable-declarations*)
569 (note-declaration `(,type
570 ,(or (variable-lexical-p name env) name)
573 (note-declaration declaration env))
574 (push declaration declarations)))
578 (cdr body) fn env doc-string-p declarations)))
581 (null (get-walker-template (car form)))
583 (multiple-value-setq (new-form macrop)
584 (macroexpand-1 form env))
586 ;; This form was a call to a macro. Maybe it expanded
587 ;; into a declare? Recurse to find out.
588 (walk-declarations (recons body new-form (cdr body))
589 fn env doc-string-p declarations
592 ;; Now that we have walked and recorded the declarations,
593 ;; call the function our caller provided to expand the body.
594 ;; We call that function rather than passing the real-body
595 ;; back, because we are RECONSING up the new body.
596 (funcall fn (or old-body body) env))))
598 (defun walk-unexpected-declare (form context env)
599 (declare (ignore context env))
600 (warn "encountered DECLARE ~S in a place where a DECLARE was not expected"
604 (defun walk-arglist (arglist context env &optional (destructuringp nil)
606 (cond ((null arglist) ())
607 ((symbolp (setq arg (car arglist)))
608 (or (member arg lambda-list-keywords)
609 (note-lexical-binding arg env))
612 (walk-arglist (cdr arglist)
617 lambda-list-keywords))))))
619 (prog1 (recons arglist
621 (walk-arglist arg context env destructuringp)
624 (walk-form-internal (cadr arg) :eval env)
626 (walk-arglist (cdr arglist) context env nil))
627 (if (symbolp (car arg))
628 (note-lexical-binding (car arg) env)
629 (note-lexical-binding (cadar arg) env))
630 (or (null (cddr arg))
631 (not (symbolp (caddr arg)))
632 (note-lexical-binding (caddr arg) env))))
634 (error "Can't understand something in the arglist ~S" arglist))))
636 (defun walk-let (form context env)
637 (walk-let/let* form context env nil))
639 (defun walk-let* (form context env)
640 (walk-let/let* form context env t))
642 (defun walk-prog (form context env)
643 (walk-prog/prog* form context env nil))
645 (defun walk-prog* (form context env)
646 (walk-prog/prog* form context env t))
648 (defun walk-do (form context env)
649 (walk-do/do* form context env nil))
651 (defun walk-do* (form context env)
652 (walk-do/do* form context env t))
654 (defun walk-let/let* (form context old-env sequentialp)
655 (walker-environment-bind (new-env old-env)
656 (let* ((let/let* (car form))
657 (bindings (cadr form))
660 (walk-bindings-1 bindings
666 (walk-declarations body #'walk-repeat-eval new-env)))
668 form let/let* walked-bindings walked-body))))
670 (defun walk-locally (form context env)
671 (declare (ignore context))
672 (let* ((locally (car form))
675 (walk-declarations body #'walk-repeat-eval env)))
677 form locally walked-body)))
679 (defun walk-prog/prog* (form context old-env sequentialp)
680 (walker-environment-bind (new-env old-env)
681 (let* ((possible-block-name (second form))
682 (blocked-prog (and (symbolp possible-block-name)
683 (not (eq possible-block-name 'nil)))))
684 (multiple-value-bind (let/let* block-name bindings body)
686 (values (car form) (cadr form) (caddr form) (cdddr form))
687 (values (car form) nil (cadr form) (cddr form)))
688 (let* ((walked-bindings
689 (walk-bindings-1 bindings
697 #'(lambda (real-body real-env)
698 (walk-tagbody-1 real-body context real-env))
702 form let/let* block-name walked-bindings walked-body)
704 form let/let* walked-bindings walked-body)))))))
706 (defun walk-do/do* (form context old-env sequentialp)
707 (walker-environment-bind (new-env old-env)
708 (let* ((do/do* (car form))
709 (bindings (cadr form))
710 (end-test (caddr form))
712 (walked-bindings (walk-bindings-1 bindings
718 (walk-declarations body #'walk-repeat-eval new-env)))
721 (walk-bindings-2 bindings walked-bindings context new-env)
722 (walk-template end-test '(test repeat (eval)) context new-env)
725 (defun walk-let-if (form context env)
726 (let ((test (cadr form))
727 (bindings (caddr form))
731 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
733 (flet ((.let-if-dummy. () ,@body))
735 (let ,bindings (.let-if-dummy.))
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 (cadr form))
840 (arglist (caddr 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* ((expanded `(setf ,(cddr symmac) ,val))
867 (walked (walk-form-internal expanded context env)))
868 (if (eq expanded walked)
872 (walk-form-internal var :set env)
873 (walk-form-internal val :eval env))))))
875 (defun walk-symbol-macrolet (form context old-env)
876 (declare (ignore context))
877 (let* ((bindings (cadr form))
879 (walker-environment-bind
882 (append (mapcar #'(lambda (binding)
884 :macro . ,(cadr binding)))
886 (env-lexical-variables old-env)))
887 (relist* form 'symbol-macrolet bindings
888 (walk-declarations body #'walk-repeat-eval new-env)))))
890 (defun walk-tagbody (form context env)
891 (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
893 (defun walk-tagbody-1 (form context env)
896 (walk-form-internal (car form)
897 (if (symbolp (car form)) 'quote context)
899 (walk-tagbody-1 (cdr form) context env))))
901 (defun walk-macrolet (form context old-env)
902 (walker-environment-bind (macro-env
904 :walk-function (env-walk-function old-env))
905 (labels ((walk-definitions (definitions)
907 (let ((definition (car definitions)))
911 (walk-arglist (cadr definition)
915 (walk-declarations (cddr definition)
918 (walk-definitions (cdr definitions)))))))
919 (with-new-definition-in-environment (new-env old-env form)
922 (walk-definitions (cadr form))
923 (walk-declarations (cddr form)
927 (defun walk-flet (form context old-env)
928 (labels ((walk-definitions (definitions)
929 (if (null definitions)
932 (walk-lambda (car definitions) context old-env)
933 (walk-definitions (cdr definitions))))))
937 (walk-definitions (cadr form))
938 (with-new-definition-in-environment (new-env old-env form)
939 (walk-declarations (cddr form)
943 (defun walk-labels (form context old-env)
944 (with-new-definition-in-environment (new-env old-env form)
945 (labels ((walk-definitions (definitions)
946 (if (null definitions)
949 (walk-lambda (car definitions) context new-env)
950 (walk-definitions (cdr definitions))))))
954 (walk-definitions (cadr form))
955 (walk-declarations (cddr form)
959 (defun walk-if (form context env)
960 (let ((predicate (cadr form))
964 ;; FIXME: This should go away now that we're no longer trying
965 ;; to support any old weird CLTL1.
967 (warn "In the form:~%~S~%~
968 IF only accepts three arguments, you are using ~D.~%~
969 It is true that some Common Lisps support this, but ~
971 truly legal Common Lisp. For now, this code ~
972 walker is interpreting ~%~
973 the extra arguments as extra else clauses. ~
974 Even if this is what~%~
975 you intended, you should fix your source code."
978 (cons 'progn (cdddr form)))
982 (walk-form-internal predicate context env)
983 (walk-form-internal arm1 context env)
984 (walk-form-internal arm2 context env))))
986 ;;;; tests tests tests
989 ;;; Here are some examples of the kinds of things you should be able
990 ;;; to do with your implementation of the macroexpansion environment
991 ;;; hacking mechanism.
993 ;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes
994 ;;; names of the macros and actual macroexpansion functions to use to
995 ;;; macroexpand them. The win about that is that for macros which want
996 ;;; to wrap several MACROLETs around their body, they can do this but
997 ;;; have the macroexpansion functions be compiled. See the WITH-RPUSH
1000 ;;; If the implementation had a special way of communicating the
1001 ;;; augmented environment back to the evaluator that would be totally
1002 ;;; great. It would mean that we could just augment the environment
1003 ;;; then pass control back to the implementations own compiler or
1004 ;;; interpreter. We wouldn't have to call the actual walker. That
1005 ;;; would make this much faster. Since the principal client of this is
1006 ;;; defmethod it would make compiling defmethods faster and that would
1007 ;;; certainly be a win.
1009 (defmacro with-lexical-macros (macros &body body &environment old-env)
1010 (with-augmented-environment (new-env old-env :macros macros)
1011 (walk-form (cons 'progn body) :environment new-env)))
1013 (defun expand-rpush (form env)
1014 `(push ,(caddr form) ,(cadr form)))
1016 (defmacro with-rpush (&body body)
1017 `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
1019 ;;; Unfortunately, I don't have an automatic tester for the walker.
1020 ;;; Instead there is this set of test cases with a description of
1021 ;;; how each one should go.
1022 (defmacro take-it-out-for-a-test-walk (form)
1023 `(take-it-out-for-a-test-walk-1 ',form))
1025 (defun take-it-out-for-a-test-walk-1 (form)
1028 (let ((copy-of-form (copy-tree form))
1029 (result (walk-form form nil
1031 (format t "~&Form: ~S ~3T Context: ~A" x y)
1033 (let ((lexical (variable-lexical-p x env))
1034 (special (variable-special-p x env)))
1037 (format t "lexically bound"))
1040 (format t "declared special"))
1043 (format t "bound: ~S " (eval x)))))
1045 (cond ((not (equal result copy-of-form))
1046 (format t "~%Warning: Result not EQUAL to copy of start."))
1047 ((not (eq result form))
1048 (format t "~%Warning: Result not EQ to copy of start.")))
1052 (defmacro foo (&rest ignore) ''global-foo)
1054 (defmacro bar (&rest ignore) ''global-bar)
1056 (take-it-out-for-a-test-walk (list arg1 arg2 arg3))
1057 (take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
1059 (take-it-out-for-a-test-walk (progn (foo) (bar 1)))
1061 (take-it-out-for-a-test-walk (block block-name a b c))
1062 (take-it-out-for-a-test-walk (block block-name (list a) b c))
1064 (take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
1065 ;;; This is a fairly simple macrolet case. While walking the body of the
1066 ;;; macro, x should be lexically bound. In the body of the macrolet form
1067 ;;; itself, x should not be bound.
1068 (take-it-out-for-a-test-walk
1069 (macrolet ((foo (x) (list x) ''inner))
1073 ;;; A slightly more complex macrolet case. In the body of the macro x
1074 ;;; should not be lexically bound. In the body of the macrolet form itself
1075 ;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it
1076 ;;; tries to macroexpand the call to foo.
1077 (take-it-out-for-a-test-walk
1079 (macrolet ((foo () (list x) ''inner))
1083 (take-it-out-for-a-test-walk
1084 (flet ((foo (x) (list x y))
1085 (bar (x) (list x y)))
1088 (take-it-out-for-a-test-walk
1090 (flet ((foo (x) (list x y))
1091 (bar (x) (list x y)))
1094 (take-it-out-for-a-test-walk
1095 (labels ((foo (x) (bar x))
1099 (take-it-out-for-a-test-walk
1100 (flet ((foo (x) (foo x)))
1103 (take-it-out-for-a-test-walk
1104 (flet ((foo (x) (foo x)))
1105 (flet ((bar (x) (foo x)))
1108 (take-it-out-for-a-test-walk (prog () (declare (special a b))))
1109 (take-it-out-for-a-test-walk (let (a b c)
1110 (declare (special a b))
1112 (take-it-out-for-a-test-walk (let (a b c)
1113 (declare (special a) (special b))
1115 (take-it-out-for-a-test-walk (let (a b c)
1116 (declare (special a))
1117 (declare (special b))
1119 (take-it-out-for-a-test-walk (let (a b c)
1120 (declare (special a))
1121 (declare (special b))
1124 (take-it-out-for-a-test-walk (eval-when ()
1127 (take-it-out-for-a-test-walk (eval-when (eval when load)
1131 (take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
1132 (take-it-out-for-a-test-walk (multiple-value-bind (a b)
1134 (declare (special a))
1136 (take-it-out-for-a-test-walk (progn (function foo)))
1137 (take-it-out-for-a-test-walk (progn a b (go a)))
1138 (take-it-out-for-a-test-walk (if a b c))
1139 (take-it-out-for-a-test-walk (if a b))
1140 (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
1141 (take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
1143 (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
1144 (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
1145 (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
1146 (declare (special a b))
1148 (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
1149 (declare (special a b))
1151 (take-it-out-for-a-test-walk (let ((a 1) (b 2))
1153 (declare (special a))
1155 (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
1156 (take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
1157 (take-it-out-for-a-test-walk (progn a b c))
1158 (take-it-out-for-a-test-walk (progv vars vals a b c))
1159 (take-it-out-for-a-test-walk (quote a))
1160 (take-it-out-for-a-test-walk (return-from block-name a b c))
1161 (take-it-out-for-a-test-walk (setq a 1))
1162 (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
1163 (take-it-out-for-a-test-walk (tagbody a b c (go a)))
1164 (take-it-out-for-a-test-walk (the foo (foo-form a b c)))
1165 (take-it-out-for-a-test-walk (throw tag-form a))
1166 (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
1168 (defmacro flet-1 (a b) ''outer)
1169 (defmacro labels-1 (a b) ''outer)
1171 (take-it-out-for-a-test-walk
1172 (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
1175 (take-it-out-for-a-test-walk
1176 (labels ((label-1 (a b) () (label-1 a b)(list a b)))
1179 (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
1183 (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
1186 (take-it-out-for-a-test-walk (progn (bar 1)
1188 `(inner-bar-expanded ,a)))
1191 (take-it-out-for-a-test-walk (progn (bar 1)
1194 `(inner-bar-expanded ,s)))
1197 (take-it-out-for-a-test-walk (cond (a b)
1198 ((foo bar) a (foo a))))
1200 (let ((the-lexical-variables ()))
1201 (walk-form '(let ((a 1) (b 2))
1202 #'(lambda (x) (list a b x y)))
1204 #'(lambda (form context env)
1205 (when (and (symbolp form)
1206 (variable-lexical-p form env))
1207 (push form the-lexical-variables))
1209 (or (and (= (length the-lexical-variables) 3)
1210 (member 'a the-lexical-variables)
1211 (member 'b the-lexical-variables)
1212 (member 'x the-lexical-variables))
1213 (error "Walker didn't do lexical variables of a closure properly.")))