1 ;;;; a simple code walker for PCL
3 ;;;; The code which implements the macroexpansion environment manipulation
4 ;;;; mechanisms is in the first part of the file, the real walker follows it.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from software originally released by Xerox
10 ;;;; Corporation. Copyright and release statements follow. Later modifications
11 ;;;; to the software are in the public domain and are provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
15 ;;;; copyright information from original PCL sources:
17 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
18 ;;;; All rights reserved.
20 ;;;; Use and copying of this software and preparation of derivative works based
21 ;;;; upon this software are permitted. Any distribution of this software or
22 ;;;; derivative works must comply with all applicable United States export
25 ;;;; This software is made available AS IS, and Xerox Corporation makes no
26 ;;;; warranty about the software, its performance or its conformity to any
29 (in-package "SB-WALKER")
34 ;;;; environment frobbing stuff
36 ;;; Here in the original PCL were implementations of the
37 ;;; implementation-specific environment hacking functions for each of the
38 ;;; implementations this walker had been ported to. This functionality was
39 ;;; originally factored out in order to make PCL portable from one Common Lisp
40 ;;; to another. As of 19981107, that portability was fairly stale and (because
41 ;;; of the scarcity of CLTL1 implementations and the strong interdependence of
42 ;;; the rest of ANSI Common Lisp on the CLOS system) fairly irrelevant. It was
43 ;;; fairly thoroughly put out of its misery by WHN in his quest to clean up the
44 ;;; system enough that it can be built from scratch using any ANSI Common Lisp.
46 ;;; This code just hacks 'macroexpansion environments'. That is, it is only
47 ;;; concerned with the function binding of symbols in the environment. The
48 ;;; walker needs to be able to tell if the symbol names a lexical macro or
49 ;;; function, and it needs to be able to build environments which contain
50 ;;; lexical macro or function bindings. It must be able, when walking a
51 ;;; MACROLET, FLET or LABELS form to construct an environment which reflects
52 ;;; the bindings created by that form. Note that the environment created
53 ;;; does NOT have to be sufficient to evaluate the body, merely to walk its
54 ;;; body. This means that definitions do not have to be supplied for lexical
55 ;;; functions, only the fact that that function is bound is important. For
56 ;;; macros, the macroexpansion function must be supplied.
58 ;;; This code is organized in a way that lets it work in implementations that
59 ;;; stack cons their environments. That is reflected in the fact that the
60 ;;; only operation that lets a user build a new environment is a WITH-BODY
61 ;;; macro which executes its body with the specified symbol bound to the new
62 ;;; environment. No code in this walker or in PCL will hold a pointer to
63 ;;; these environments after the body returns. Other user code is free to do
64 ;;; so in implementations where it works, but that code is not considered
67 ;;; There are 3 environment hacking tools. One macro,
68 ;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new environments, and
69 ;;; two functions, ENVIRONMENT-FUNCTION and ENVIRONMENT-MACRO, which are used
70 ;;; to access the bindings of existing environments
72 ;;; In SBCL, as in CMU CL before it, the environment is represented
73 ;;; with a structure that holds alists for the functional things,
74 ;;; variables, blocks, etc. Only the c::lexenv-functions slot is
75 ;;; relevant. It holds: Alist (name . what), where What is either a
76 ;;; Functional (a local function) or a list (MACRO . <function>) (a
77 ;;; local macro, with the specifier expander.) Note that Name may be a
78 ;;; (SETF <name>) function.
80 (defmacro with-augmented-environment
81 ((new-env old-env &key functions macros) &body body)
82 `(let ((,new-env (with-augmented-environment-internal ,old-env
87 ;;; KLUDGE: In CMU CL, when X was an arbitrary list, even one which did
88 ;;; not name a function or describe a lambda expression, (EVAL
89 ;;; `(FUNCTION ,X)) would still return a FUNCTION object, and no error
90 ;;; would be signalled until/unless you tried to FUNCALL the resulting
91 ;;; FUNCTION object. (This behavior was also present in (COERCE X
92 ;;; 'FUNCTION), which was defined in terms of (EVAL `(FUNCTION ,X)).)
93 ;;; This function provides roughly the same behavior as the old CMU CL
94 ;;; (COERCE X 'FUNCTION), for the benefit of PCL code which relied
95 ;;; on being able to coerce bogus things without raising errors
96 ;;; as long as it never tried to actually call them.
97 (defun bogo-coerce-to-function (x)
98 (or (ignore-errors (coerce x 'function))
100 (declare (ignore rest))
101 (error "can't FUNCALL bogo-coerced-to-function ~S" x))))
103 (defun with-augmented-environment-internal (env functions macros)
104 ;; Note: In order to record the correct function definition, we
105 ;; would have to create an interpreted closure, but the
106 ;; with-new-definition macro down below makes no distinction between
107 ;; FLET and LABELS, so we have no idea what to use for the
108 ;; environment. So we just blow it off, 'cause anything real we do
109 ;; would be wrong. We still have to make an entry so we can tell
110 ;; functions from macros.
111 (let ((env (or env (sb-kernel:make-null-lexenv))))
115 (append (mapcar (lambda (f)
116 (cons (car f) (sb-c::make-functional :lexenv env)))
121 (bogo-coerce-to-function (cadr m))))
124 (defun environment-function (env fn)
126 (let ((entry (assoc fn (sb-c::lexenv-functions env) :test #'equal)))
128 (sb-c::functional-p (cdr entry))
131 (defun environment-macro (env macro)
133 (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq)))
135 (eq (cadr entry) 'sb-c::macro)
136 (function-lambda-expression (cddr entry))))))
138 (defmacro with-new-definition-in-environment
139 ((new-env old-env macrolet/flet/labels-form) &body body)
140 (let ((functions (make-symbol "Functions"))
141 (macros (make-symbol "Macros")))
142 `(let ((,functions ())
144 (ecase (car ,macrolet/flet/labels-form)
146 (dolist (fn (cadr ,macrolet/flet/labels-form))
147 (push fn ,functions)))
149 (dolist (mac (cadr ,macrolet/flet/labels-form))
150 (push (list (car mac)
151 (convert-macro-to-lambda (cadr mac)
155 (with-augmented-environment
156 (,new-env ,old-env :functions ,functions :macros ,macros)
159 (defun convert-macro-to-lambda (llist body &optional (name "dummy macro"))
160 (let ((gensym (make-symbol name)))
161 (eval `(defmacro ,gensym ,llist ,@body))
162 (macro-function gensym)))
164 ;;; Now comes the real walker.
166 ;;; As the walker walks over the code, it communicates information to itself
167 ;;; about the walk. This information includes the walk function, variable
168 ;;; bindings, declarations in effect etc. This information is inherently
169 ;;; lexical, so the walker passes it around in the actual environment the
170 ;;; walker passes to macroexpansion functions. This is what makes the
171 ;;; nested-walk-form facility work properly.
172 (defmacro walker-environment-bind ((var env &rest key-args)
174 `(with-augmented-environment
175 (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
178 (defvar *key-to-walker-environment* (gensym))
180 (defun env-lock (env)
181 (environment-macro env *key-to-walker-environment*))
183 (defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
185 (declarations nil decp)
186 (lexical-variables nil lexp))
187 (let ((lock (environment-macro env *key-to-walker-environment*)))
189 (list *key-to-walker-environment*
190 (list (if wfnp walk-function (car lock))
191 (if wfop walk-form (cadr lock))
192 (if decp declarations (caddr lock))
193 (if lexp lexical-variables (cadddr lock)))))))
195 (defun env-walk-function (env)
196 (car (env-lock env)))
198 (defun env-walk-form (env)
199 (cadr (env-lock env)))
201 (defun env-declarations (env)
202 (caddr (env-lock env)))
204 (defun env-lexical-variables (env)
205 (cadddr (env-lock env)))
207 (defun note-declaration (declaration env)
208 (push declaration (caddr (env-lock env))))
210 (defun note-lexical-binding (thing env)
211 (push (list thing :lexical-var) (cadddr (env-lock env))))
213 (defun variable-lexical-p (var env)
214 (let ((entry (member var (env-lexical-variables env) :key #'car)))
215 (when (eq (cadar entry) :lexical-var)
218 (defun variable-symbol-macro-p (var env)
219 (let ((entry (member var (env-lexical-variables env) :key #'car)))
220 (when (eq (cadar entry) :macro)
223 (defvar *variable-declarations* '(special))
225 (defun variable-declaration (declaration var env)
226 (if (not (member declaration *variable-declarations*))
227 (error "~S is not a recognized variable declaration." declaration)
228 (let ((id (or (variable-lexical-p var env) var)))
229 (dolist (decl (env-declarations env))
230 (when (and (eq (car decl) declaration)
234 (defun variable-special-p (var env)
235 (or (not (null (variable-declaration 'special var env)))
236 (variable-globally-special-p var)))
238 (defun variable-globally-special-p (symbol)
239 (eq (sb-int:info :variable :kind symbol) :special))
241 ;;;; handling of special forms
243 ;;; Here are some comments from the original PCL on the difficulty of doing
244 ;;; this portably across different CLTL1 implementations. This is no longer
245 ;;; directly relevant because this code now only runs on SBCL, but the comments
246 ;;; are retained for culture: they might help explain some of the design
247 ;;; decisions which were made in the code.
251 ;;; The set of special forms is purposely kept very small because
252 ;;; any program analyzing program (read code walker) must have
253 ;;; special knowledge about every type of special form. Such a
254 ;;; program needs no special knowledge about macros...
256 ;;; So all we have to do here is a define a way to store and retrieve
257 ;;; templates which describe how to walk the 24 special forms and we are all
260 ;;; Well, its a nice concept, and I have to admit to being naive enough that
261 ;;; I believed it for a while, but not everyone takes having only 24 special
262 ;;; forms as seriously as might be nice. There are (at least) 3 ways to
265 ;;; 1 - Implementation x implements a Common Lisp special form as a macro
266 ;;; which expands into a special form which:
267 ;;; - Is a common lisp special form (not likely)
268 ;;; - Is not a common lisp special form (on the 3600 IF --> COND).
270 ;;; * We can safe ourselves from this case (second subcase really) by
271 ;;; checking to see whether there is a template defined for something
272 ;;; before we check to see whether we can macroexpand it.
274 ;;; 2 - Implementation x implements a Common Lisp macro as a special form.
276 ;;; * This is a screw, but not so bad, we save ourselves from it by
277 ;;; defining extra templates for the macros which are *likely* to
278 ;;; be implemented as special forms. (DO, DO* ...)
280 ;;; 3 - Implementation x has a special form which is not on the list of
281 ;;; Common Lisp special forms.
283 ;;; * This is a bad sort of a screw and happens more than I would like
284 ;;; to think, especially in the implementations which provide more
285 ;;; than just Common Lisp (3600, Xerox etc.).
286 ;;; The fix is not terribly staisfactory, but will have to do for
287 ;;; now. There is a hook in get walker-template which can get a
288 ;;; template from the implementation's own walker. That template
289 ;;; has to be converted, and so it may be that the right way to do
290 ;;; this would actually be for that implementation to provide an
291 ;;; interface to its walker which looks like the interface to this
294 ;;; FIXME: In SBCL, we probably don't need to put DEFMACROs inside EVAL-WHEN.
295 (eval-when (:compile-toplevel :load-toplevel :execute)
297 (defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
298 `(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack
299 ;compile time definition of macros
302 (defmacro define-walker-template (name
303 &optional (template '(nil repeat (eval))))
304 `(eval-when (:load-toplevel :execute)
305 (setf (get-walker-template-internal ',name) ',template)))
309 (defun get-walker-template (x)
311 (or (get-walker-template-internal x)
312 (get-implementation-dependent-walker-template x)))
313 ((and (listp x) (eq (car x) 'lambda))
314 '(lambda repeat (eval)))
316 (error "can't get template for ~S" x))))
318 ;;; FIXME: This can go away in SBCL.
319 (defun get-implementation-dependent-walker-template (x)
323 ;;;; the actual templates
325 ;;; ANSI special forms
326 (define-walker-template block (nil nil repeat (eval)))
327 (define-walker-template catch (nil eval repeat (eval)))
328 (define-walker-template declare walk-unexpected-declare)
329 (define-walker-template eval-when (nil quote repeat (eval)))
330 (define-walker-template flet walk-flet)
331 (define-walker-template function (nil call))
332 (define-walker-template go (nil quote))
333 (define-walker-template if walk-if)
334 (define-walker-template labels walk-labels)
335 (define-walker-template lambda walk-lambda)
336 (define-walker-template let walk-let)
337 (define-walker-template let* walk-let*)
338 (define-walker-template locally walk-locally)
339 (define-walker-template macrolet walk-macrolet)
340 (define-walker-template multiple-value-call (nil eval repeat (eval)))
341 (define-walker-template multiple-value-prog1 (nil return repeat (eval)))
342 (define-walker-template multiple-value-setq walk-multiple-value-setq)
343 (define-walker-template multiple-value-bind walk-multiple-value-bind)
344 (define-walker-template progn (nil repeat (eval)))
345 (define-walker-template progv (nil eval eval repeat (eval)))
346 (define-walker-template quote (nil quote))
347 (define-walker-template return-from (nil quote repeat (return)))
348 (define-walker-template setq walk-setq)
349 (define-walker-template symbol-macrolet walk-symbol-macrolet)
350 (define-walker-template tagbody walk-tagbody)
351 (define-walker-template the (nil quote eval))
352 (define-walker-template throw (nil eval eval))
353 (define-walker-template unwind-protect (nil return repeat (eval)))
355 ;;; SBCL-only special forms
356 (define-walker-template sb-ext:truly-the (nil quote eval))
359 (define-walker-template do walk-do)
360 (define-walker-template do* walk-do*)
361 (define-walker-template prog walk-prog)
362 (define-walker-template prog* walk-prog*)
363 (define-walker-template cond (nil repeat ((test repeat (eval)))))
365 (defvar *walk-form-expand-macros-p* nil)
367 (defun macroexpand-all (form &optional environment)
368 (let ((*walk-form-expand-macros-p* t))
369 (walk-form form environment)))
371 (defun walk-form (form
372 &optional environment
374 #'(lambda (subform context env)
375 (declare (ignore context env))
377 (walker-environment-bind (new-env environment :walk-function walk-function)
378 (walk-form-internal form :eval new-env)))
380 ;;; NESTED-WALK-FORM provides an interface that allows nested macros, each
381 ;;; of which must walk their body, to just do one walk of the body of the
382 ;;; inner macro. That inner walk is done with a walk function which is the
383 ;;; composition of the two walk functions.
385 ;;; This facility works by having the walker annotate the environment that
386 ;;; it passes to MACROEXPAND-1 to know which form is being macroexpanded.
387 ;;; If then the &WHOLE argument to the macroexpansion function is eq to
388 ;;; the ENV-WALK-FORM of the environment, NESTED-WALK-FORM can be certain
389 ;;; that there are no intervening layers and that a nested walk is OK.
391 ;;; KLUDGE: There are some semantic problems with this facility. In particular,
392 ;;; if the outer walk function returns T as its WALK-NO-MORE-P value, this will
393 ;;; prevent the inner walk function from getting a chance to walk the subforms
394 ;;; of the form. This is almost never what you want, since it destroys the
395 ;;; equivalence between this NESTED-WALK-FORM function and two separate
397 (defun nested-walk-form (whole form
398 &optional environment
400 #'(lambda (subform context env)
401 (declare (ignore context env))
403 (if (eq whole (env-walk-form environment))
404 (let ((outer-walk-function (env-walk-function environment)))
410 ;; First loop to make sure the inner walk function
411 ;; has done all it wants to do with this form.
412 ;; Basically, what we are doing here is providing
413 ;; the same contract walk-form-internal normally
414 ;; provides to the inner walk function.
415 (let ((inner-result nil)
416 (inner-no-more-p nil)
418 (outer-no-more-p nil))
420 (multiple-value-setq (inner-result inner-no-more-p)
421 (funcall walk-function f c e))
422 (cond (inner-no-more-p (return))
423 ((not (eq inner-result f)))
424 ((not (consp inner-result)) (return))
425 ((get-walker-template (car inner-result)) (return))
427 (multiple-value-bind (expansion macrop)
428 (walker-environment-bind
429 (new-env e :walk-form inner-result)
430 (macroexpand-1 inner-result new-env))
432 (setq inner-result expansion)
434 (setq f inner-result))
435 (multiple-value-setq (outer-result outer-no-more-p)
436 (funcall outer-walk-function
441 (and inner-no-more-p outer-no-more-p)))))))
442 (walk-form form environment walk-function)))
444 ;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
445 ;;; takes a form and the current context and walks the form calling itself or
446 ;;; the appropriate template recursively.
448 ;;; "It is recommended that a program-analyzing-program process a form
449 ;;; that is a list whose car is a symbol as follows:
451 ;;; 1. If the program has particular knowledge about the symbol,
452 ;;; process the form using special-purpose code. All of the
453 ;;; standard special forms should fall into this category.
454 ;;; 2. Otherwise, if macro-function is true of the symbol apply
455 ;;; either macroexpand or macroexpand-1 and start over.
456 ;;; 3. Otherwise, assume it is a function call. "
457 (defun walk-form-internal (form context env)
458 ;; First apply the walk-function to perform whatever translation
459 ;; the user wants to this form. If the second value returned
460 ;; by walk-function is T then we don't recurse...
462 (multiple-value-bind (newform walk-no-more-p)
463 (funcall (env-walk-function env) form context env)
466 (walk-no-more-p newform)
467 ((not (eq form newform))
468 (walk-form-internal newform context env))
469 ((not (consp newform))
470 (let ((symmac (car (variable-symbol-macro-p newform env))))
472 (let ((newnewform (walk-form-internal (cddr symmac)
475 (if (eq newnewform (cddr symmac))
476 (if *walk-form-expand-macros-p* newnewform newform)
480 (let* ((fn (car newform))
481 (template (get-walker-template fn)))
483 (if (symbolp template)
484 (funcall template newform context env)
485 (walk-template newform template context env))
486 (multiple-value-bind (newnewform macrop)
487 (walker-environment-bind
488 (new-env env :walk-form newform)
489 (macroexpand-1 newform new-env))
492 (let ((newnewnewform (walk-form-internal newnewform
495 (if (eq newnewnewform newnewform)
496 (if *walk-form-expand-macros-p* newnewform newform)
500 (special-operator-p fn))
501 ;; This shouldn't happen, since this walker is now
502 ;; maintained as part of SBCL, so it should know about all
503 ;; the special forms that SBCL knows about.
504 (error "unexpected special form ~S" fn))
506 ;; Otherwise, walk the form as if it's just a standard
507 ;; function call using a template for standard function
510 newnewform '(call repeat (eval)) context env))))))))))))
512 (defun walk-template (form template context env)
515 ((eval function test effect return)
516 (walk-form-internal form :eval env))
519 (walk-form-internal form :set env))
521 (cond ((or (symbolp form)
524 (eq (car form) 'setf)))
526 (t (walk-form-internal form context env)))))
529 (walk-template-handle-repeat form
531 ;; For the case where nothing happens
532 ;; after the repeat optimize out the
534 (if (null (cddr template))
536 (nthcdr (- (length form)
544 (if (if (listp (cadr template))
545 (eval (cadr template))
546 (funcall (cadr template) form))
552 (walk-template form (cadr template) context env))
554 (cond ((atom form) form)
557 (car form) (car template) context env)
559 (cdr form) (cdr template) context env))))))))
561 (defun walk-template-handle-repeat (form template stop-form context env)
562 (if (eq form stop-form)
563 (walk-template form (cdr template) context env)
564 (walk-template-handle-repeat-1 form
571 (defun walk-template-handle-repeat-1 (form template repeat-template
572 stop-form context env)
573 (cond ((null form) ())
575 (if (null repeat-template)
576 (walk-template stop-form (cdr template) context env)
577 (error "while handling code walker REPEAT:
578 ~%ran into STOP while still in REPEAT template")))
579 ((null repeat-template)
580 (walk-template-handle-repeat-1
581 form template (car template) stop-form context env))
584 (walk-template (car form) (car repeat-template) context env)
585 (walk-template-handle-repeat-1 (cdr form)
587 (cdr repeat-template)
592 (defun walk-repeat-eval (form env)
595 (walk-form-internal (car form) :eval env)
596 (walk-repeat-eval (cdr form) env))))
598 (defun recons (x car cdr)
599 (if (or (not (eq (car x) car))
600 (not (eq (cdr x) cdr)))
604 (defun relist (x &rest args)
607 (relist-internal x args nil)))
609 (defun relist* (x &rest args)
610 (relist-internal x args 't))
612 (defun relist-internal (x args *p)
613 (if (null (cdr args))
616 (recons x (car args) nil))
619 (relist-internal (cdr x) (cdr args) *p))))
623 (defun walk-declarations (body fn env
624 &optional doc-string-p declarations old-body
625 &aux (form (car body)) macrop new-form)
626 (cond ((and (stringp form) ;might be a doc string
627 (cdr body) ;isn't the returned value
628 (null doc-string-p) ;no doc string yet
629 (null declarations)) ;no declarations yet
632 (walk-declarations (cdr body) fn env t)))
633 ((and (listp form) (eq (car form) 'declare))
634 ;; We got ourselves a real live declaration. Record it, look for more.
635 (dolist (declaration (cdr form))
636 (let ((type (car declaration))
637 (name (cadr declaration))
638 (args (cddr declaration)))
639 (if (member type *variable-declarations*)
640 (note-declaration `(,type
641 ,(or (variable-lexical-p name env) name)
644 (note-declaration declaration env))
645 (push declaration declarations)))
649 (cdr body) fn env doc-string-p declarations)))
652 (null (get-walker-template (car form)))
654 (multiple-value-setq (new-form macrop)
655 (macroexpand-1 form env))
657 ;; This form was a call to a macro. Maybe it expanded
658 ;; into a declare? Recurse to find out.
659 (walk-declarations (recons body new-form (cdr body))
660 fn env doc-string-p declarations
663 ;; Now that we have walked and recorded the declarations,
664 ;; call the function our caller provided to expand the body.
665 ;; We call that function rather than passing the real-body
666 ;; back, because we are RECONSING up the new body.
667 (funcall fn (or old-body body) env))))
669 (defun walk-unexpected-declare (form context env)
670 (declare (ignore context env))
671 (warn "encountered DECLARE ~S in a place where a DECLARE was not expected"
675 (defun walk-arglist (arglist context env &optional (destructuringp nil)
677 (cond ((null arglist) ())
678 ((symbolp (setq arg (car arglist)))
679 (or (member arg lambda-list-keywords)
680 (note-lexical-binding arg env))
683 (walk-arglist (cdr arglist)
688 lambda-list-keywords))))))
690 (prog1 (recons arglist
692 (walk-arglist arg context env destructuringp)
695 (walk-form-internal (cadr arg) :eval env)
697 (walk-arglist (cdr arglist) context env nil))
698 (if (symbolp (car arg))
699 (note-lexical-binding (car arg) env)
700 (note-lexical-binding (cadar arg) env))
701 (or (null (cddr arg))
702 (not (symbolp (caddr arg)))
703 (note-lexical-binding (caddr arg) env))))
705 (error "Can't understand something in the arglist ~S" arglist))))
707 (defun walk-let (form context env)
708 (walk-let/let* form context env nil))
710 (defun walk-let* (form context env)
711 (walk-let/let* form context env t))
713 (defun walk-prog (form context env)
714 (walk-prog/prog* form context env nil))
716 (defun walk-prog* (form context env)
717 (walk-prog/prog* form context env t))
719 (defun walk-do (form context env)
720 (walk-do/do* form context env nil))
722 (defun walk-do* (form context env)
723 (walk-do/do* form context env t))
725 (defun walk-let/let* (form context old-env sequentialp)
726 (walker-environment-bind (new-env old-env)
727 (let* ((let/let* (car form))
728 (bindings (cadr form))
731 (walk-bindings-1 bindings
737 (walk-declarations body #'walk-repeat-eval new-env)))
739 form let/let* walked-bindings walked-body))))
741 (defun walk-locally (form context env)
742 (declare (ignore context))
743 (let* ((locally (car form))
746 (walk-declarations body #'walk-repeat-eval env)))
748 form locally walked-body)))
750 (defun walk-prog/prog* (form context old-env sequentialp)
751 (walker-environment-bind (new-env old-env)
752 (let* ((possible-block-name (second form))
753 (blocked-prog (and (symbolp possible-block-name)
754 (not (eq possible-block-name 'nil)))))
755 (multiple-value-bind (let/let* block-name bindings body)
757 (values (car form) (cadr form) (caddr form) (cdddr form))
758 (values (car form) nil (cadr form) (cddr form)))
759 (let* ((walked-bindings
760 (walk-bindings-1 bindings
768 #'(lambda (real-body real-env)
769 (walk-tagbody-1 real-body context real-env))
773 form let/let* block-name walked-bindings walked-body)
775 form let/let* walked-bindings walked-body)))))))
777 (defun walk-do/do* (form context old-env sequentialp)
778 (walker-environment-bind (new-env old-env)
779 (let* ((do/do* (car form))
780 (bindings (cadr form))
781 (end-test (caddr form))
783 (walked-bindings (walk-bindings-1 bindings
789 (walk-declarations body #'walk-repeat-eval new-env)))
792 (walk-bindings-2 bindings walked-bindings context new-env)
793 (walk-template end-test '(test repeat (eval)) context new-env)
796 (defun walk-let-if (form context env)
797 (let ((test (cadr form))
798 (bindings (caddr form))
802 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
804 (flet ((.let-if-dummy. () ,@body))
806 (let ,bindings (.let-if-dummy.))
811 (defun walk-multiple-value-setq (form context env)
812 (let ((vars (cadr form)))
813 (if (some #'(lambda (var)
814 (variable-symbol-macro-p var env))
816 (let* ((temps (mapcar #'(lambda (var)
817 (declare (ignore var))
820 (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp))
823 (expanded `(multiple-value-bind ,temps ,(caddr form)
825 (walked (walk-form-internal expanded context env)))
826 (if (eq walked expanded)
829 (walk-template form '(nil (repeat (set)) eval) context env))))
831 (defun walk-multiple-value-bind (form context old-env)
832 (walker-environment-bind (new-env old-env)
833 (let* ((mvb (car form))
834 (bindings (cadr form))
835 (mv-form (walk-template (caddr form) 'eval context old-env))
841 #'(lambda (real-body real-env)
842 (setq walked-bindings
843 (walk-bindings-1 bindings
848 (walk-repeat-eval real-body real-env))
850 (relist* form mvb walked-bindings mv-form walked-body))))
852 (defun walk-bindings-1 (bindings old-env new-env context sequentialp)
854 (let ((binding (car bindings)))
856 (if (symbolp binding)
858 (note-lexical-binding binding new-env))
859 (prog1 (relist* binding
861 (walk-form-internal (cadr binding)
866 (cddr binding)) ; Save cddr for DO/DO*;
867 ; it is the next value
868 ; form. Don't walk it
870 (note-lexical-binding (car binding) new-env)))
871 (walk-bindings-1 (cdr bindings)
877 (defun walk-bindings-2 (bindings walked-bindings context env)
879 (let ((binding (car bindings))
880 (walked-binding (car walked-bindings)))
882 (if (symbolp binding)
886 (cadr walked-binding)
887 (walk-template (cddr binding)
891 (walk-bindings-2 (cdr bindings)
892 (cdr walked-bindings)
896 (defun walk-lambda (form context old-env)
897 (walker-environment-bind (new-env old-env)
898 (let* ((arglist (cadr form))
900 (walked-arglist (walk-arglist arglist context new-env))
902 (walk-declarations body #'walk-repeat-eval new-env)))
908 (defun walk-named-lambda (form context old-env)
909 (walker-environment-bind (new-env old-env)
910 (let* ((name (cadr form))
911 (arglist (caddr form))
913 (walked-arglist (walk-arglist arglist context new-env))
915 (walk-declarations body #'walk-repeat-eval new-env)))
922 (defun walk-setq (form context env)
924 (let* ((expanded (let ((rforms nil)
926 (loop (when (null tail) (return (nreverse rforms)))
927 (let ((var (pop tail)) (val (pop tail)))
928 (push `(setq ,var ,val) rforms)))))
929 (walked (walk-repeat-eval expanded env)))
930 (if (eq expanded walked)
933 (let* ((var (cadr form))
935 (symmac (car (variable-symbol-macro-p var env))))
937 (let* ((expanded `(setf ,(cddr symmac) ,val))
938 (walked (walk-form-internal expanded context env)))
939 (if (eq expanded walked)
943 (walk-form-internal var :set env)
944 (walk-form-internal val :eval env))))))
946 (defun walk-symbol-macrolet (form context old-env)
947 (declare (ignore context))
948 (let* ((bindings (cadr form))
950 (walker-environment-bind
953 (append (mapcar #'(lambda (binding)
955 :macro . ,(cadr binding)))
957 (env-lexical-variables old-env)))
958 (relist* form 'symbol-macrolet bindings
959 (walk-declarations body #'walk-repeat-eval new-env)))))
961 (defun walk-tagbody (form context env)
962 (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
964 (defun walk-tagbody-1 (form context env)
967 (walk-form-internal (car form)
968 (if (symbolp (car form)) 'quote context)
970 (walk-tagbody-1 (cdr form) context env))))
972 (defun walk-macrolet (form context old-env)
973 (walker-environment-bind (macro-env
975 :walk-function (env-walk-function old-env))
976 (labels ((walk-definitions (definitions)
978 (let ((definition (car definitions)))
982 (walk-arglist (cadr definition)
986 (walk-declarations (cddr definition)
989 (walk-definitions (cdr definitions)))))))
990 (with-new-definition-in-environment (new-env old-env form)
993 (walk-definitions (cadr form))
994 (walk-declarations (cddr form)
998 (defun walk-flet (form context old-env)
999 (labels ((walk-definitions (definitions)
1000 (if (null definitions)
1003 (walk-lambda (car definitions) context old-env)
1004 (walk-definitions (cdr definitions))))))
1008 (walk-definitions (cadr form))
1009 (with-new-definition-in-environment (new-env old-env form)
1010 (walk-declarations (cddr form)
1014 (defun walk-labels (form context old-env)
1015 (with-new-definition-in-environment (new-env old-env form)
1016 (labels ((walk-definitions (definitions)
1017 (if (null definitions)
1020 (walk-lambda (car definitions) context new-env)
1021 (walk-definitions (cdr definitions))))))
1025 (walk-definitions (cadr form))
1026 (walk-declarations (cddr form)
1030 (defun walk-if (form context env)
1031 (let ((predicate (cadr form))
1035 ;; FIXME: This should go away now that we're no longer trying
1036 ;; to support any old weird CLTL1.
1038 (warn "In the form:~%~S~%~
1039 IF only accepts three arguments, you are using ~D.~%~
1040 It is true that some Common Lisps support this, but ~
1042 truly legal Common Lisp. For now, this code ~
1043 walker is interpreting ~%~
1044 the extra arguments as extra else clauses. ~
1045 Even if this is what~%~
1046 you intended, you should fix your source code."
1048 (length (cdr form)))
1049 (cons 'progn (cdddr form)))
1053 (walk-form-internal predicate context env)
1054 (walk-form-internal arm1 context env)
1055 (walk-form-internal arm2 context env))))
1057 ;;;; tests tests tests
1060 ;;; Here are some examples of the kinds of things you should be able to do
1061 ;;; with your implementation of the macroexpansion environment hacking
1064 ;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes names
1065 ;;; of the macros and actual macroexpansion functions to use to macroexpand
1066 ;;; them. The win about that is that for macros which want to wrap several
1067 ;;; MACROLETs around their body, they can do this but have the macroexpansion
1068 ;;; functions be compiled. See the WITH-RPUSH example.
1070 ;;; If the implementation had a special way of communicating the augmented
1071 ;;; environment back to the evaluator that would be totally great. It would
1072 ;;; mean that we could just augment the environment then pass control back
1073 ;;; to the implementations own compiler or interpreter. We wouldn't have
1074 ;;; to call the actual walker. That would make this much faster. Since the
1075 ;;; principal client of this is defmethod it would make compiling defmethods
1076 ;;; faster and that would certainly be a win.
1078 (defmacro with-lexical-macros (macros &body body &environment old-env)
1079 (with-augmented-environment (new-env old-env :macros macros)
1080 (walk-form (cons 'progn body) :environment new-env)))
1082 (defun expand-rpush (form env)
1083 `(push ,(caddr form) ,(cadr form)))
1085 (defmacro with-rpush (&body body)
1086 `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
1088 ;;; Unfortunately, I don't have an automatic tester for the walker.
1089 ;;; Instead there is this set of test cases with a description of
1090 ;;; how each one should go.
1091 (defmacro take-it-out-for-a-test-walk (form)
1092 `(take-it-out-for-a-test-walk-1 ',form))
1094 (defun take-it-out-for-a-test-walk-1 (form)
1097 (let ((copy-of-form (copy-tree form))
1098 (result (walk-form form nil
1100 (format t "~&Form: ~S ~3T Context: ~A" x y)
1102 (let ((lexical (variable-lexical-p x env))
1103 (special (variable-special-p x env)))
1106 (format t "lexically bound"))
1109 (format t "declared special"))
1112 (format t "bound: ~S " (eval x)))))
1114 (cond ((not (equal result copy-of-form))
1115 (format t "~%Warning: Result not EQUAL to copy of start."))
1116 ((not (eq result form))
1117 (format t "~%Warning: Result not EQ to copy of start.")))
1121 (defmacro foo (&rest ignore) ''global-foo)
1123 (defmacro bar (&rest ignore) ''global-bar)
1125 (take-it-out-for-a-test-walk (list arg1 arg2 arg3))
1126 (take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
1128 (take-it-out-for-a-test-walk (progn (foo) (bar 1)))
1130 (take-it-out-for-a-test-walk (block block-name a b c))
1131 (take-it-out-for-a-test-walk (block block-name (list a) b c))
1133 (take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
1134 ;;; This is a fairly simple macrolet case. While walking the body of the
1135 ;;; macro, x should be lexically bound. In the body of the macrolet form
1136 ;;; itself, x should not be bound.
1137 (take-it-out-for-a-test-walk
1138 (macrolet ((foo (x) (list x) ''inner))
1142 ;;; A slightly more complex macrolet case. In the body of the macro x
1143 ;;; should not be lexically bound. In the body of the macrolet form itself
1144 ;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it
1145 ;;; tries to macroexpand the call to foo.
1146 (take-it-out-for-a-test-walk
1148 (macrolet ((foo () (list x) ''inner))
1152 (take-it-out-for-a-test-walk
1153 (flet ((foo (x) (list x y))
1154 (bar (x) (list x y)))
1157 (take-it-out-for-a-test-walk
1159 (flet ((foo (x) (list x y))
1160 (bar (x) (list x y)))
1163 (take-it-out-for-a-test-walk
1164 (labels ((foo (x) (bar x))
1168 (take-it-out-for-a-test-walk
1169 (flet ((foo (x) (foo x)))
1172 (take-it-out-for-a-test-walk
1173 (flet ((foo (x) (foo x)))
1174 (flet ((bar (x) (foo x)))
1177 (take-it-out-for-a-test-walk (prog () (declare (special a b))))
1178 (take-it-out-for-a-test-walk (let (a b c)
1179 (declare (special a b))
1181 (take-it-out-for-a-test-walk (let (a b c)
1182 (declare (special a) (special b))
1184 (take-it-out-for-a-test-walk (let (a b c)
1185 (declare (special a))
1186 (declare (special b))
1188 (take-it-out-for-a-test-walk (let (a b c)
1189 (declare (special a))
1190 (declare (special b))
1193 (take-it-out-for-a-test-walk (eval-when ()
1196 (take-it-out-for-a-test-walk (eval-when (eval when load)
1200 (take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
1201 (take-it-out-for-a-test-walk (multiple-value-bind (a b)
1203 (declare (special a))
1205 (take-it-out-for-a-test-walk (progn (function foo)))
1206 (take-it-out-for-a-test-walk (progn a b (go a)))
1207 (take-it-out-for-a-test-walk (if a b c))
1208 (take-it-out-for-a-test-walk (if a b))
1209 (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
1210 (take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
1212 (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
1213 (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
1214 (take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
1215 (declare (special a b))
1217 (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
1218 (declare (special a b))
1220 (take-it-out-for-a-test-walk (let ((a 1) (b 2))
1222 (declare (special a))
1224 (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
1225 (take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
1226 (take-it-out-for-a-test-walk (progn a b c))
1227 (take-it-out-for-a-test-walk (progv vars vals a b c))
1228 (take-it-out-for-a-test-walk (quote a))
1229 (take-it-out-for-a-test-walk (return-from block-name a b c))
1230 (take-it-out-for-a-test-walk (setq a 1))
1231 (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
1232 (take-it-out-for-a-test-walk (tagbody a b c (go a)))
1233 (take-it-out-for-a-test-walk (the foo (foo-form a b c)))
1234 (take-it-out-for-a-test-walk (throw tag-form a))
1235 (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
1237 (defmacro flet-1 (a b) ''outer)
1238 (defmacro labels-1 (a b) ''outer)
1240 (take-it-out-for-a-test-walk
1241 (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
1244 (take-it-out-for-a-test-walk
1245 (labels ((label-1 (a b) () (label-1 a b)(list a b)))
1248 (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
1252 (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
1255 (take-it-out-for-a-test-walk (progn (bar 1)
1257 `(inner-bar-expanded ,a)))
1260 (take-it-out-for-a-test-walk (progn (bar 1)
1263 `(inner-bar-expanded ,s)))
1266 (take-it-out-for-a-test-walk (cond (a b)
1267 ((foo bar) a (foo a))))
1269 (let ((the-lexical-variables ()))
1270 (walk-form '(let ((a 1) (b 2))
1271 #'(lambda (x) (list a b x y)))
1273 #'(lambda (form context env)
1274 (when (and (symbolp form)
1275 (variable-lexical-p form env))
1276 (push form the-lexical-variables))
1278 (or (and (= (length the-lexical-variables) 3)
1279 (member 'a the-lexical-variables)
1280 (member 'b the-lexical-variables)
1281 (member 'x the-lexical-variables))
1282 (error "Walker didn't do lexical variables of a closure properly.")))