X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=e8eb3827a1c158c7fef2f99bf0fa60a77dded09b;hb=HEAD;hp=13d4b695ebc04e9ba2247226b4b871ce0406df17;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 13d4b69..e8eb382 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -1,7 +1,8 @@ -;;;; a simple code walker for PCL +;;;; a simple code walker ;;;; -;;;; The code which implements the macroexpansion environment manipulation -;;;; mechanisms is in the first part of the file, the real walker follows it. +;;;; The code which implements the macroexpansion environment +;;;; manipulation mechanisms is in the first part of the file, the +;;;; real walker follows it. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -26,148 +27,218 @@ ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. -(in-package "SB-WALKER") +(in-package "SB!WALKER") -;;;; environment frobbing stuff +;;;; forward references + +(defvar *key-to-walker-environment*) + +;;;; environment hacking stuff, necessarily SBCL-specific ;;; Here in the original PCL were implementations of the -;;; implementation-specific environment hacking functions for each of the -;;; implementations this walker had been ported to. This functionality was -;;; originally factored out in order to make PCL portable from one Common Lisp -;;; to another. As of 19981107, that portability was fairly stale and (because -;;; of the scarcity of CLTL1 implementations and the strong interdependence of -;;; the rest of ANSI Common Lisp on the CLOS system) fairly irrelevant. It was -;;; fairly thoroughly put out of its misery by WHN in his quest to clean up the -;;; system enough that it can be built from scratch using any ANSI Common Lisp. +;;; implementation-specific environment hacking functions for each of +;;; the implementations this walker had been ported to. This +;;; functionality was originally factored out in order to make PCL +;;; portable from one Common Lisp to another. As of 19981107, that +;;; portability was fairly stale and (because of the scarcity of CLTL1 +;;; implementations and the strong interdependence of the rest of ANSI +;;; Common Lisp on the CLOS system) fairly irrelevant. It was fairly +;;; thoroughly put out of its misery by WHN in his quest to clean up +;;; the system enough that it can be built from scratch using any ANSI +;;; Common Lisp. ;;; -;;; This code just hacks 'macroexpansion environments'. That is, it is only -;;; concerned with the function binding of symbols in the environment. The -;;; walker needs to be able to tell if the symbol names a lexical macro or -;;; function, and it needs to be able to build environments which contain -;;; lexical macro or function bindings. It must be able, when walking a -;;; MACROLET, FLET or LABELS form to construct an environment which reflects -;;; the bindings created by that form. Note that the environment created -;;; does NOT have to be sufficient to evaluate the body, merely to walk its -;;; body. This means that definitions do not have to be supplied for lexical -;;; functions, only the fact that that function is bound is important. For -;;; macros, the macroexpansion function must be supplied. +;;; This code just hacks 'macroexpansion environments'. That is, it is +;;; only concerned with the function binding of symbols in the +;;; environment. The walker needs to be able to tell if the symbol +;;; names a lexical macro or function, and it needs to be able to +;;; build environments which contain lexical macro or function +;;; bindings. It must be able, when walking a MACROLET, FLET or LABELS +;;; form to construct an environment which reflects the bindings +;;; created by that form. Note that the environment created does NOT +;;; have to be sufficient to evaluate the body, merely to walk its +;;; body. This means that definitions do not have to be supplied for +;;; lexical functions, only the fact that that function is bound is +;;; important. For macros, the macroexpansion function must be +;;; supplied. ;;; -;;; This code is organized in a way that lets it work in implementations that -;;; stack cons their environments. That is reflected in the fact that the -;;; only operation that lets a user build a new environment is a WITH-BODY -;;; macro which executes its body with the specified symbol bound to the new -;;; environment. No code in this walker or in PCL will hold a pointer to -;;; these environments after the body returns. Other user code is free to do -;;; so in implementations where it works, but that code is not considered -;;; portable. +;;; This code is organized in a way that lets it work in +;;; implementations that stack cons their environments. That is +;;; reflected in the fact that the only operation that lets a user +;;; build a new environment is a WITH-BODY macro which executes its +;;; body with the specified symbol bound to the new environment. No +;;; code in this walker or in PCL will hold a pointer to these +;;; environments after the body returns. Other user code is free to do +;;; so in implementations where it works, but that code is not +;;; considered portable. ;;; ;;; There are 3 environment hacking tools. One macro, -;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new environments, and -;;; two functions, ENVIRONMENT-FUNCTION and ENVIRONMENT-MACRO, which are used -;;; to access the bindings of existing environments +;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new +;;; environments, and two functions, ENVIRONMENT-FUNCTION and +;;; ENVIRONMENT-MACRO, which are used to access the bindings of +;;; existing environments ;;; In SBCL, as in CMU CL before it, the environment is represented ;;; with a structure that holds alists for the functional things, -;;; variables, blocks, etc. Only the c::lexenv-functions slot is -;;; relevant. It holds: Alist (name . what), where What is either a -;;; Functional (a local function) or a list (MACRO . ) (a -;;; local macro, with the specifier expander.) Note that Name may be a -;;; (SETF ) function. +;;; variables, blocks, etc. Except for SYMBOL-MACROLET, only the +;;; SB!C::LEXENV-FUNS slot is relevant. It holds: Alist (Name . What), +;;; where What is either a functional (a local function) or a list +;;; (MACRO . ) (a local macro, with the specifier expander.) +;;; Note that Name may be a (SETF ) function. Accessors are +;;; defined below, eg (ENV-WALK-FUNCTION ENV). +;;; +;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND +;;; this code hides the WALKER version of an environment +;;; inside the SB!C::LEXENV structure. +;;; +;;; In CMUCL (and former SBCL), This used to be a list of lists of form +;;; ( MACRO . #) in the :functions slot +;;; in a C::LEXENV. +;;; This form was accepted by the compiler, but this was a crude hack, +;;; because the was used as a structure to hold the +;;; bits of interest, {function, form, declarations, lexical-variables}, +;;; a list, which was not really an interpreted function. +;;; Instead this list was COERCEd to a #! +;;; +;;; Instead, we now use a special sort of "function"-type for that +;;; information, because the functions slot in SB!C::LEXENV is +;;; supposed to have a list of elements. +;;; So, now we hide our bits of interest in the walker-info slot in +;;; our new BOGO-FUN. +;;; +;;; MACROEXPAND-1 and SB!INT:EVAL-IN-LEXENV are the only SBCL +;;; functions that get called with the constructed environment +;;; argument. + +(/show "walk.lisp 108") (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) + ,functions + ,macros))) ,@body)) -;;; KLUDGE: In CMU CL, when X was an arbitrary list, even one which did -;;; not name a function or describe a lambda expression, (EVAL -;;; `(FUNCTION ,X)) would still return a FUNCTION object, and no error -;;; would be signalled until/unless you tried to FUNCALL the resulting -;;; FUNCTION object. (This behavior was also present in (COERCE X -;;; 'FUNCTION), which was defined in terms of (EVAL `(FUNCTION ,X)).) -;;; This function provides roughly the same behavior as the old CMU CL -;;; (COERCE X 'FUNCTION), for the benefit of PCL code which relied -;;; on being able to coerce bogus things without raising errors -;;; as long as it never tried to actually call them. -(defun bogo-coerce-to-function (x) - (or (ignore-errors (coerce x 'function)) - (lambda (&rest rest) - (declare (ignore rest)) - (error "can't FUNCALL bogo-coerced-to-function ~S" x)))) - -(defun with-augmented-environment-internal (env functions macros) +;;; a unique tag to show that we're the intended caller of BOGO-FUN +(defvar *bogo-fun-magic-tag* + '(:bogo-fun-magic-tag)) + +;;; The interface of BOGO-FUNs (previously implemented as +;;; FUNCALLABLE-INSTANCEs) is just these two operations, so we can do +;;; them with ordinary closures. +;;; +;;; KLUDGE: BOGO-FUNs are sorta weird, and MNA and I have both hacked +;;; on this code without quite figuring out what they're for. (He +;;; changed them to work after some changes in the IR1 interpreter +;;; made functions not be built lazily, and I changed them so that +;;; they don't need FUNCALLABLE-INSTANCE stuff, so that the F-I stuff +;;; can become less general.) There may be further simplifications or +;;; clarifications which could be done. -- WHN 2001-10-19 +(defun walker-info-to-bogo-fun (walker-info) + (lambda (magic-tag &rest rest) + (aver (not rest)) ; else someone is using me in an unexpected way + (aver (eql magic-tag *bogo-fun-magic-tag*)) ; else ditto + walker-info)) +(defun bogo-fun-to-walker-info (bogo-fun) + (declare (type function bogo-fun)) + (funcall bogo-fun *bogo-fun-magic-tag*)) + +(defun with-augmented-environment-internal (env funs macros) ;; Note: In order to record the correct function definition, we ;; would have to create an interpreted closure, but the - ;; with-new-definition macro down below makes no distinction between + ;; WITH-NEW-DEFINITION macro down below makes no distinction between ;; FLET and LABELS, so we have no idea what to use for the ;; environment. So we just blow it off, 'cause anything real we do - ;; would be wrong. We still have to make an entry so we can tell - ;; functions from macros. - (let ((env (or env (sb-kernel:make-null-lexenv)))) - (sb-c::make-lexenv - :default env - :functions - (append (mapcar (lambda (f) - (cons (car f) (sb-c::make-functional :lexenv env))) - functions) - (mapcar (lambda (m) - (list* (car m) - 'sb-c::macro - (bogo-coerce-to-function (cadr m)))) - macros))))) + ;; would be wrong. But we still have to make an entry so we can tell + ;; functions from macros -- same for telling variables apart from + ;; symbol macros. + (let ((lexenv (sb!kernel::coerce-to-lexenv env))) + (sb!c::make-lexenv + :default lexenv + :vars (when (eql (caar macros) *key-to-walker-environment*) + (copy-tree (mapcar (lambda (b) + (let ((name (car b)) + (info (cadr b))) + (if (eq info :lexical-var) + (cons name + (if (var-special-p name env) + (sb!c::make-global-var + :kind :special + :%source-name name) + (sb!c::make-lambda-var + :%source-name name))) + b))) + (fourth (cadar macros))))) + :funs (append (mapcar (lambda (f) + (cons (car f) + (sb!c::make-functional :lexenv lexenv))) + funs) + (mapcar (lambda (m) + (list* (car m) + 'sb!c::macro + (if (eq (car m) + *key-to-walker-environment*) + (walker-info-to-bogo-fun (cadr m)) + (coerce (cadr m) 'function)))) + macros))))) (defun environment-function (env fn) (when env - (let ((entry (assoc fn (sb-c::lexenv-functions env) :test #'equal))) + (let ((entry (assoc fn (sb!c::lexenv-funs env) :test #'equal))) (and entry - (sb-c::functional-p (cdr entry)) - (cdr entry))))) + (sb!c::functional-p (cdr entry)) + (cdr entry))))) (defun environment-macro (env macro) (when env - (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq))) + (let ((entry (assoc macro (sb!c::lexenv-funs env) :test #'eq))) (and entry - (eq (cadr entry) 'sb-c::macro) - (function-lambda-expression (cddr entry)))))) + (eq (cadr entry) 'sb!c::macro) + (if (eq macro *key-to-walker-environment*) + (values (bogo-fun-to-walker-info (cddr entry))) + (values (function-lambda-expression (cddr entry)))))))) + +;;;; other environment hacking, not so SBCL-specific as the +;;;; environment hacking in the previous section (defmacro with-new-definition-in-environment - ((new-env old-env macrolet/flet/labels-form) &body body) + ((new-env old-env macrolet/flet/labels-form) &body body) (let ((functions (make-symbol "Functions")) - (macros (make-symbol "Macros"))) + (macros (make-symbol "Macros"))) `(let ((,functions ()) - (,macros ())) + (,macros ())) (ecase (car ,macrolet/flet/labels-form) - ((flet labels) - (dolist (fn (cadr ,macrolet/flet/labels-form)) - (push fn ,functions))) - ((macrolet) - (dolist (mac (cadr ,macrolet/flet/labels-form)) - (push (list (car mac) - (convert-macro-to-lambda (cadr mac) - (cddr mac) - (string (car mac)))) - ,macros)))) + ((flet labels) + (dolist (fn (cadr ,macrolet/flet/labels-form)) + (push fn ,functions))) + ((macrolet) + (dolist (mac (cadr ,macrolet/flet/labels-form)) + (push (list (car mac) + (convert-macro-to-lambda (cadr mac) + (cddr mac) + ,old-env + (string (car mac)))) + ,macros)))) (with-augmented-environment - (,new-env ,old-env :functions ,functions :macros ,macros) - ,@body)))) + (,new-env ,old-env :functions ,functions :macros ,macros) + ,@body)))) -(defun convert-macro-to-lambda (llist body &optional (name "dummy macro")) +(defun convert-macro-to-lambda (llist body env &optional (name "dummy macro")) (let ((gensym (make-symbol name))) - (eval `(defmacro ,gensym ,llist ,@body)) + (eval-in-lexenv `(defmacro ,gensym ,llist ,@body) + (sb!c::make-restricted-lexenv env)) (macro-function gensym))) -;;; Now comes the real walker. -;;; -;;; As the walker walks over the code, it communicates information to itself -;;; about the walk. This information includes the walk function, variable -;;; bindings, declarations in effect etc. This information is inherently -;;; lexical, so the walker passes it around in the actual environment the -;;; walker passes to macroexpansion functions. This is what makes the -;;; nested-walk-form facility work properly. +;;;; the actual walker + +;;; As the walker walks over the code, it communicates information to +;;; itself about the walk. This information includes the walk +;;; function, variable bindings, declarations in effect etc. This +;;; information is inherently lexical, so the walker passes it around +;;; in the actual environment the walker passes to macroexpansion +;;; functions. This is what makes the NESTED-WALK-FORM facility work +;;; properly. (defmacro walker-environment-bind ((var env &rest key-args) - &body body) + &body body) `(with-augmented-environment (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) .,body)) @@ -178,16 +249,16 @@ (environment-macro env *key-to-walker-environment*)) (defun walker-environment-bind-1 (env &key (walk-function nil wfnp) - (walk-form nil wfop) - (declarations nil decp) - (lexical-variables nil lexp)) - (let ((lock (environment-macro env *key-to-walker-environment*))) + (walk-form nil wfop) + (declarations nil decp) + (lexical-vars nil lexp)) + (let ((lock (env-lock env))) (list (list *key-to-walker-environment* - (list (if wfnp walk-function (car lock)) - (if wfop walk-form (cadr lock)) - (if decp declarations (caddr lock)) - (if lexp lexical-variables (cadddr lock))))))) + (list (if wfnp walk-function (car lock)) + (if wfop walk-form (cadr lock)) + (if decp declarations (caddr lock)) + (if lexp lexical-vars (cadddr lock))))))) (defun env-walk-function (env) (car (env-lock env))) @@ -198,50 +269,77 @@ (defun env-declarations (env) (caddr (env-lock env))) +(defun env-var-type (var env) + (dolist (decl (env-declarations env) t) + (when (and (eq 'type (car decl)) (member var (cddr decl) :test 'eq)) + (return (cadr decl))))) + (defun env-lexical-variables (env) (cadddr (env-lock env))) (defun note-declaration (declaration env) (push declaration (caddr (env-lock env)))) -(defun note-lexical-binding (thing env) +(defun note-var-binding (thing env) (push (list thing :lexical-var) (cadddr (env-lock env)))) -(defun variable-lexical-p (var env) - (let ((entry (member var (env-lexical-variables env) :key #'car))) +(defun var-lexical-p (var env) + (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq))) (when (eq (cadar entry) :lexical-var) entry))) (defun variable-symbol-macro-p (var env) - (let ((entry (member var (env-lexical-variables env) :key #'car))) - (when (eq (cadar entry) :macro) + (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq))) + (when (eq (cadar entry) 'sb!sys:macro) entry))) -(defvar *variable-declarations* '(special)) +(defun walked-var-declaration-p (declaration) + (member declaration '(sb!pcl::%class sb!pcl::%variable-rebinding special))) + +(defun %var-declaration (declaration var env) + (let ((id (or (var-lexical-p var env) var))) + (if (eq 'special declaration) + (dolist (decl (env-declarations env)) + (when (and (eq (car decl) declaration) + (or (member var (cdr decl)) + (and id (member id (cdr decl))))) + (return decl))) + (dolist (decl (env-declarations env)) + (when (and (eq (car decl) declaration) + (eq (cadr decl) id)) + (return decl)))))) + +(defun var-declaration (declaration var env) + (if (walked-var-declaration-p declaration) + (%var-declaration declaration var env) + (error "Not a variable declaration the walker cares about: ~S" declaration))) + +#-sb-xc-host +(define-compiler-macro var-declaration (&whole form declaration var env + &environment lexenv) + (if (sb!xc:constantp declaration lexenv) + (let ((decl (constant-form-value declaration lexenv))) + (if (walked-var-declaration-p decl) + `(%var-declaration ,declaration ,var ,env) + form)) + form)) + +(defun var-special-p (var env) + (and (or (var-declaration 'special var env) + (var-globally-special-p var)) + t)) + +(defun var-globally-special-p (symbol) + (eq (info :variable :kind symbol) :special)) -(defun variable-declaration (declaration var env) - (if (not (member declaration *variable-declarations*)) - (error "~S is not a recognized variable declaration." declaration) - (let ((id (or (variable-lexical-p var env) var))) - (dolist (decl (env-declarations env)) - (when (and (eq (car decl) declaration) - (eq (cadr decl) id)) - (return decl)))))) - -(defun variable-special-p (var env) - (or (not (null (variable-declaration 'special var env))) - (variable-globally-special-p var))) - -(defun variable-globally-special-p (symbol) - (eq (sb-int:info :variable :kind symbol) :special)) ;;;; handling of special forms -;;; Here are some comments from the original PCL on the difficulty of doing -;;; this portably across different CLTL1 implementations. This is no longer -;;; directly relevant because this code now only runs on SBCL, but the comments -;;; are retained for culture: they might help explain some of the design -;;; decisions which were made in the code. +;;; Here are some comments from the original PCL on the difficulty of +;;; doing this portably across different CLTL1 implementations. This +;;; is no longer directly relevant because this code now only runs on +;;; SBCL, but the comments are retained for culture: they might help +;;; explain some of the design decisions which were made in the code. ;;; ;;; and I quote... ;;; @@ -251,36 +349,39 @@ ;;; program needs no special knowledge about macros... ;;; ;;; So all we have to do here is a define a way to store and retrieve -;;; templates which describe how to walk the 24 special forms and we are all -;;; set... +;;; templates which describe how to walk the 24 special forms and we +;;; are all set... ;;; -;;; Well, its a nice concept, and I have to admit to being naive enough that -;;; I believed it for a while, but not everyone takes having only 24 special -;;; forms as seriously as might be nice. There are (at least) 3 ways to -;;; lose: +;;; Well, its a nice concept, and I have to admit to being naive +;;; enough that I believed it for a while, but not everyone takes +;;; having only 24 special forms as seriously as might be nice. There +;;; are (at least) 3 ways to lose: ;; -;;; 1 - Implementation x implements a Common Lisp special form as a macro -;;; which expands into a special form which: -;;; - Is a common lisp special form (not likely) -;;; - Is not a common lisp special form (on the 3600 IF --> COND). +;;; 1 - Implementation x implements a Common Lisp special form as +;;; a macro which expands into a special form which: +;;; - Is a common lisp special form (not likely) +;;; - Is not a common lisp special form (on the 3600 IF --> COND). ;;; -;;; * We can safe ourselves from this case (second subcase really) by -;;; checking to see whether there is a template defined for something -;;; before we check to see whether we can macroexpand it. +;;; * We can save ourselves from this case (second subcase really) +;;; by checking to see whether there is a template defined for +;;; something before we check to see whether we can macroexpand it. ;;; ;;; 2 - Implementation x implements a Common Lisp macro as a special form. ;;; ;;; * This is a screw, but not so bad, we save ourselves from it by ;;; defining extra templates for the macros which are *likely* to -;;; be implemented as special forms. (DO, DO* ...) +;;; be implemented as special forms. [Note: As of sbcl-0.6.9, these +;;; extra templates have been deleted, since this is not a problem +;;; in SBCL and we no longer try to make this walker portable +;;; across other possibly-broken CL implementations.] ;;; ;;; 3 - Implementation x has a special form which is not on the list of ;;; Common Lisp special forms. ;;; -;;; * This is a bad sort of a screw and happens more than I would like -;;; to think, especially in the implementations which provide more -;;; than just Common Lisp (3600, Xerox etc.). -;;; The fix is not terribly staisfactory, but will have to do for +;;; * This is a bad sort of a screw and happens more than I would +;;; like to think, especially in the implementations which provide +;;; more than just Common Lisp (3600, Xerox etc.). +;;; The fix is not terribly satisfactory, but will have to do for ;;; now. There is a hook in get walker-template which can get a ;;; template from the implementation's own walker. That template ;;; has to be converted, and so it may be that the right way to do @@ -288,168 +389,89 @@ ;;; interface to its walker which looks like the interface to this ;;; walker. -;;; FIXME: In SBCL, we probably don't need to put DEFMACROs inside EVAL-WHEN. -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because - `(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack - ;compile time definition of macros - ;right for setf. +(defmacro get-walker-template-internal (x) + `(get ,x 'walker-template)) (defmacro define-walker-template (name - &optional (template '(nil repeat (eval)))) + &optional (template '(nil repeat (eval)))) `(eval-when (:load-toplevel :execute) (setf (get-walker-template-internal ',name) ',template))) -) ; EVAL-WHEN - -(defun get-walker-template (x) +(defun get-walker-template (x context) (cond ((symbolp x) - (or (get-walker-template-internal x) - (get-implementation-dependent-walker-template x))) - ((and (listp x) (eq (car x) 'lambda)) - '(lambda repeat (eval))) - (t - (error "can't get template for ~S" x)))) - -;;; FIXME: This can go away in SBCL. -(defun get-implementation-dependent-walker-template (x) - (declare (ignore x)) - ()) + (get-walker-template-internal x)) + ((and (listp x) (eq (car x) 'lambda)) + '(lambda repeat (eval))) + (t + ;; FIXME: In an ideal world we would do something similar to + ;; COMPILER-ERROR here, replacing the form within the walker + ;; with an error-signalling form. This is slightly less + ;; pretty, but informative non the less. Best is the enemy of + ;; good, etc. + (error "Illegal function call in method body:~% ~S" + context)))) ;;;; the actual templates ;;; ANSI special forms -(define-walker-template block (nil nil repeat (eval))) -(define-walker-template catch (nil eval repeat (eval))) -(define-walker-template declare walk-unexpected-declare) -(define-walker-template eval-when (nil quote repeat (eval))) -(define-walker-template flet walk-flet) -(define-walker-template function (nil call)) -(define-walker-template go (nil quote)) -(define-walker-template if walk-if) -(define-walker-template labels walk-labels) -(define-walker-template lambda walk-lambda) -(define-walker-template let walk-let) -(define-walker-template let* walk-let*) -(define-walker-template locally walk-locally) -(define-walker-template macrolet walk-macrolet) +(define-walker-template block (nil nil repeat (eval))) +(define-walker-template catch (nil eval repeat (eval))) +(define-walker-template declare walk-unexpected-declare) +(define-walker-template eval-when (nil quote repeat (eval))) +(define-walker-template flet walk-flet) +(define-walker-template function (nil call)) +(define-walker-template go (nil quote)) +(define-walker-template if walk-if) +(define-walker-template labels walk-labels) +(define-walker-template lambda walk-lambda) +(define-walker-template let walk-let) +(define-walker-template let* walk-let*) +(define-walker-template locally walk-locally) +(define-walker-template macrolet walk-macrolet) (define-walker-template multiple-value-call (nil eval repeat (eval))) (define-walker-template multiple-value-prog1 (nil return repeat (eval))) (define-walker-template multiple-value-setq walk-multiple-value-setq) (define-walker-template multiple-value-bind walk-multiple-value-bind) -(define-walker-template progn (nil repeat (eval))) -(define-walker-template progv (nil eval eval repeat (eval))) -(define-walker-template quote (nil quote)) -(define-walker-template return-from (nil quote repeat (return))) -(define-walker-template setq walk-setq) +(define-walker-template progn (nil repeat (eval))) +(define-walker-template progv (nil eval eval repeat (eval))) +(define-walker-template quote (nil quote)) +(define-walker-template return-from (nil quote repeat (return))) +(define-walker-template setq walk-setq) (define-walker-template symbol-macrolet walk-symbol-macrolet) -(define-walker-template tagbody walk-tagbody) -(define-walker-template the (nil quote eval)) -(define-walker-template throw (nil eval eval)) +(define-walker-template tagbody walk-tagbody) +(define-walker-template the (nil quote eval)) +(define-walker-template throw (nil eval eval)) (define-walker-template unwind-protect (nil return repeat (eval))) ;;; SBCL-only special forms -(define-walker-template sb-ext:truly-the (nil quote eval)) - -;;; extra templates -(define-walker-template do walk-do) -(define-walker-template do* walk-do*) -(define-walker-template prog walk-prog) -(define-walker-template prog* walk-prog*) -(define-walker-template cond (nil repeat ((test repeat (eval))))) +(define-walker-template sb!ext:truly-the (nil quote eval)) +;;; FIXME: maybe we don't need this one any more, given that +;;; NAMED-LAMBDA now expands into (FUNCTION (NAMED-LAMBDA ...))? +(define-walker-template named-lambda walk-named-lambda) (defvar *walk-form-expand-macros-p* nil) -(defun macroexpand-all (form &optional environment) - (let ((*walk-form-expand-macros-p* t)) - (walk-form form environment))) - (defun walk-form (form - &optional environment - (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) + &optional environment + (walk-function + (lambda (subform context env) + (declare (ignore context env)) + subform))) (walker-environment-bind (new-env environment :walk-function walk-function) (walk-form-internal form :eval new-env))) -;;; NESTED-WALK-FORM provides an interface that allows nested macros, each -;;; of which must walk their body, to just do one walk of the body of the -;;; inner macro. That inner walk is done with a walk function which is the -;;; composition of the two walk functions. -;;; -;;; This facility works by having the walker annotate the environment that -;;; it passes to MACROEXPAND-1 to know which form is being macroexpanded. -;;; If then the &WHOLE argument to the macroexpansion function is eq to -;;; the ENV-WALK-FORM of the environment, NESTED-WALK-FORM can be certain -;;; that there are no intervening layers and that a nested walk is OK. -;;; -;;; KLUDGE: There are some semantic problems with this facility. In particular, -;;; if the outer walk function returns T as its WALK-NO-MORE-P value, this will -;;; prevent the inner walk function from getting a chance to walk the subforms -;;; of the form. This is almost never what you want, since it destroys the -;;; equivalence between this NESTED-WALK-FORM function and two separate -;;; WALK-FORMs. -(defun nested-walk-form (whole form - &optional environment - (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) - (if (eq whole (env-walk-form environment)) - (let ((outer-walk-function (env-walk-function environment))) - (throw whole - (walk-form - form - environment - #'(lambda (f c e) - ;; First loop to make sure the inner walk function - ;; has done all it wants to do with this form. - ;; Basically, what we are doing here is providing - ;; the same contract walk-form-internal normally - ;; provides to the inner walk function. - (let ((inner-result nil) - (inner-no-more-p nil) - (outer-result nil) - (outer-no-more-p nil)) - (loop - (multiple-value-setq (inner-result inner-no-more-p) - (funcall walk-function f c e)) - (cond (inner-no-more-p (return)) - ((not (eq inner-result f))) - ((not (consp inner-result)) (return)) - ((get-walker-template (car inner-result)) (return)) - (t - (multiple-value-bind (expansion macrop) - (walker-environment-bind - (new-env e :walk-form inner-result) - (macroexpand-1 inner-result new-env)) - (if macrop - (setq inner-result expansion) - (return))))) - (setq f inner-result)) - (multiple-value-setq (outer-result outer-no-more-p) - (funcall outer-walk-function - inner-result - c - e)) - (values outer-result - (and inner-no-more-p outer-no-more-p))))))) - (walk-form form environment walk-function))) - -;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It -;;; takes a form and the current context and walks the form calling itself or -;;; the appropriate template recursively. +;;; WALK-FORM-INTERNAL is the main driving function for the code +;;; walker. It takes a form and the current context and walks the form +;;; calling itself or the appropriate template recursively. ;;; ;;; "It is recommended that a program-analyzing-program process a form ;;; that is a list whose car is a symbol as follows: ;;; ;;; 1. If the program has particular knowledge about the symbol, -;;; process the form using special-purpose code. All of the -;;; standard special forms should fall into this category. -;;; 2. Otherwise, if macro-function is true of the symbol apply -;;; either macroexpand or macroexpand-1 and start over. +;;; process the form using special-purpose code. All of the +;;; standard special forms should fall into this category. +;;; 2. Otherwise, if MACRO-FUNCTION is true of the symbol apply +;;; either MACROEXPAND or MACROEXPAND-1 and start over. ;;; 3. Otherwise, assume it is a function call. " (defun walk-form-internal (form context env) ;; First apply the walk-function to perform whatever translation @@ -457,144 +479,144 @@ ;; by walk-function is T then we don't recurse... (catch form (multiple-value-bind (newform walk-no-more-p) - (funcall (env-walk-function env) form context env) + (funcall (env-walk-function env) form context env) (catch newform - (cond - (walk-no-more-p newform) - ((not (eq form newform)) - (walk-form-internal newform context env)) - ((not (consp newform)) - (let ((symmac (car (variable-symbol-macro-p newform env)))) - (if symmac - (let ((newnewform (walk-form-internal (cddr symmac) - context - env))) - (if (eq newnewform (cddr symmac)) - (if *walk-form-expand-macros-p* newnewform newform) - newnewform)) - newform))) - (t - (let* ((fn (car newform)) - (template (get-walker-template fn))) - (if template - (if (symbolp template) - (funcall template newform context env) - (walk-template newform template context env)) - (multiple-value-bind (newnewform macrop) - (walker-environment-bind - (new-env env :walk-form newform) - (macroexpand-1 newform new-env)) - (cond - (macrop - (let ((newnewnewform (walk-form-internal newnewform - context - env))) - (if (eq newnewnewform newnewform) - (if *walk-form-expand-macros-p* newnewform newform) - newnewnewform))) - ((and (symbolp fn) - (not (fboundp fn)) - (special-operator-p fn)) - ;; This shouldn't happen, since this walker is now - ;; maintained as part of SBCL, so it should know about all - ;; the special forms that SBCL knows about. - (error "unexpected special form ~S" fn)) - (t - ;; Otherwise, walk the form as if it's just a standard - ;; function call using a template for standard function - ;; call. - (walk-template - newnewform '(call repeat (eval)) context env)))))))))))) + (cond + (walk-no-more-p newform) + ((not (eq form newform)) + (walk-form-internal newform context env)) + ((not (consp newform)) + (let ((symmac (car (variable-symbol-macro-p newform env)))) + (if symmac + (let* ((newnewform (walk-form-internal (cddr symmac) + context + env)) + (resultform + (if (eq newnewform (cddr symmac)) + (if *walk-form-expand-macros-p* newnewform newform) + newnewform)) + (type (env-var-type newform env))) + (if (eq t type) + resultform + `(the ,type ,resultform))) + newform))) + (t + (let* ((fn (car newform)) + (template (get-walker-template fn newform))) + (if template + (if (symbolp template) + (funcall template newform context env) + (walk-template newform template context env)) + (multiple-value-bind (newnewform macrop) + (walker-environment-bind + (new-env env :walk-form newform) + (%macroexpand-1 newform new-env)) + (cond + (macrop + (let ((newnewnewform (walk-form-internal newnewform + context + env))) + (if (eq newnewnewform newnewform) + (if *walk-form-expand-macros-p* newnewform newform) + newnewnewform))) + ((and (symbolp fn) + (not (fboundp fn)) + (special-operator-p fn)) + ;; This shouldn't happen, since this walker is now + ;; maintained as part of SBCL, so it should know + ;; about all the special forms that SBCL knows + ;; about. + (bug "unexpected special form ~S" fn)) + (t + ;; Otherwise, walk the form as if it's just a + ;; standard function call using a template for + ;; standard function call. + (walk-template + newnewform '(call repeat (eval)) context env)))))))))))) (defun walk-template (form template context env) (if (atom template) (ecase template - ((eval function test effect return) - (walk-form-internal form :eval env)) - ((quote nil) form) - (set - (walk-form-internal form :set env)) - ((lambda call) - (cond ((or (symbolp form) - (and (listp form) - (= (length form) 2) - (eq (car form) 'setf))) - form) - (t (walk-form-internal form context env))))) + ((eval function test effect return) + (walk-form-internal form :eval env)) + ((quote nil) form) + (set + (walk-form-internal form :set env)) + ((lambda call) + (cond ((legal-fun-name-p form) + form) + (t (walk-form-internal form context env))))) (case (car template) - (repeat - (walk-template-handle-repeat form - (cdr template) - ;; For the case where nothing happens - ;; after the repeat optimize out the - ;; call to length. - (if (null (cddr template)) - () - (nthcdr (- (length form) - (length - (cddr template))) - form)) - context - env)) - (if - (walk-template form - (if (if (listp (cadr template)) - (eval (cadr template)) - (funcall (cadr template) form)) - (caddr template) - (cadddr template)) - context - env)) - (remote - (walk-template form (cadr template) context env)) - (otherwise - (cond ((atom form) form) - (t (recons form - (walk-template - (car form) (car template) context env) - (walk-template - (cdr form) (cdr template) context env)))))))) + (repeat + (walk-template-handle-repeat form + (cdr template) + ;; For the case where nothing + ;; happens after the repeat + ;; optimize away the call to + ;; LENGTH. + (if (null (cddr template)) + () + (nthcdr (- (length form) + (length + (cddr template))) + form)) + context + env)) + (if + (walk-template form + (if (if (listp (cadr template)) + (eval (cadr template)) + (funcall (cadr template) form)) + (caddr template) + (cadddr template)) + context + env)) + (remote + (walk-template form (cadr template) context env)) + (otherwise + (cond ((atom form) form) + (t (recons form + (walk-template + (car form) (car template) context env) + (walk-template + (cdr form) (cdr template) context env)))))))) (defun walk-template-handle-repeat (form template stop-form context env) (if (eq form stop-form) (walk-template form (cdr template) context env) - (walk-template-handle-repeat-1 form - template - (car template) - stop-form - context - env))) + (walk-template-handle-repeat-1 + form template (car template) stop-form context env))) (defun walk-template-handle-repeat-1 (form template repeat-template - stop-form context env) + stop-form context env) (cond ((null form) ()) - ((eq form stop-form) - (if (null repeat-template) - (walk-template stop-form (cdr template) context env) - (error "while handling code walker REPEAT: - ~%ran into STOP while still in REPEAT template"))) - ((null repeat-template) - (walk-template-handle-repeat-1 - form template (car template) stop-form context env)) - (t - (recons form - (walk-template (car form) (car repeat-template) context env) - (walk-template-handle-repeat-1 (cdr form) - template - (cdr repeat-template) - stop-form - context - env))))) + ((eq form stop-form) + (if (null repeat-template) + (walk-template stop-form (cdr template) context env) + (error "while handling code walker REPEAT: + ~%ran into STOP while still in REPEAT template"))) + ((null repeat-template) + (walk-template-handle-repeat-1 + form template (car template) stop-form context env)) + (t + (recons form + (walk-template (car form) (car repeat-template) context env) + (walk-template-handle-repeat-1 (cdr form) + template + (cdr repeat-template) + stop-form + context + env))))) (defun walk-repeat-eval (form env) (and form (recons form - (walk-form-internal (car form) :eval env) - (walk-repeat-eval (cdr form) env)))) + (walk-form-internal (car form) :eval env) + (walk-repeat-eval (cdr form) env)))) (defun recons (x car cdr) (if (or (not (eq (car x) car)) - (not (eq (cdr x) cdr))) + (not (eq (cdr x) cdr))) (cons car cdr) x)) @@ -604,102 +626,102 @@ (relist-internal x args nil))) (defun relist* (x &rest args) - (relist-internal x args 't)) + (relist-internal x args t)) (defun relist-internal (x args *p) (if (null (cdr args)) (if *p - (car args) - (recons x (car args) nil)) + (car args) + (recons x (car args) nil)) (recons x - (car args) - (relist-internal (cdr x) (cdr args) *p)))) + (car args) + (relist-internal (cdr x) (cdr args) *p)))) ;;;; special walkers (defun walk-declarations (body fn env - &optional doc-string-p declarations old-body - &aux (form (car body)) macrop new-form) - (cond ((and (stringp form) ;might be a doc string - (cdr body) ;isn't the returned value - (null doc-string-p) ;no doc string yet - (null declarations)) ;no declarations yet - (recons body - form - (walk-declarations (cdr body) fn env t))) - ((and (listp form) (eq (car form) 'declare)) - ;; We got ourselves a real live declaration. Record it, look for more. - (dolist (declaration (cdr form)) - (let ((type (car declaration)) - (name (cadr declaration)) - (args (cddr declaration))) - (if (member type *variable-declarations*) - (note-declaration `(,type - ,(or (variable-lexical-p name env) name) - ,.args) - env) - (note-declaration declaration env)) - (push declaration declarations))) - (recons body - form - (walk-declarations - (cdr body) fn env doc-string-p declarations))) - ((and form - (listp form) - (null (get-walker-template (car form))) - (progn - (multiple-value-setq (new-form macrop) - (macroexpand-1 form env)) - macrop)) - ;; This form was a call to a macro. Maybe it expanded - ;; into a declare? Recurse to find out. - (walk-declarations (recons body new-form (cdr body)) - fn env doc-string-p declarations - (or old-body body))) - (t - ;; Now that we have walked and recorded the declarations, - ;; call the function our caller provided to expand the body. - ;; We call that function rather than passing the real-body - ;; back, because we are RECONSING up the new body. - (funcall fn (or old-body body) env)))) + &optional doc-string-p declarations old-body + &aux (form (car body)) macrop new-form) + (cond ((and (stringp form) ;might be a doc string + (cdr body) ;isn't the returned value + (null doc-string-p) ;no doc string yet + (null declarations)) ;no declarations yet + (recons body + form + (walk-declarations (cdr body) fn env t))) + ((and (listp form) (eq (car form) 'declare)) + ;; We got ourselves a real live declaration. Record it, look + ;; for more. + (dolist (declaration (cdr form)) + (let ((type (car declaration)) + (name (cadr declaration)) + (args (cddr declaration))) + (if (walked-var-declaration-p type) + (note-declaration `(,type + ,(or (var-lexical-p name env) name) + ,.args) + env) + (note-declaration (sb!c::canonized-decl-spec declaration) env)) + (push declaration declarations))) + (recons body + form + (walk-declarations + (cdr body) fn env doc-string-p declarations))) + ((and form + (listp form) + (null (get-walker-template (car form) form)) + (progn + (multiple-value-setq (new-form macrop) + (%macroexpand-1 form env)) + macrop)) + ;; This form was a call to a macro. Maybe it expanded + ;; into a declare? Recurse to find out. + (walk-declarations (recons body new-form (cdr body)) + fn env doc-string-p declarations + (or old-body body))) + (t + ;; Now that we have walked and recorded the declarations, + ;; call the function our caller provided to expand the body. + ;; We call that function rather than passing the real-body + ;; back, because we are RECONSING up the new body. + (funcall fn (or old-body body) env)))) (defun walk-unexpected-declare (form context env) (declare (ignore context env)) - (warn "encountered DECLARE ~S in a place where a DECLARE was not expected" - form) + (warn "encountered ~S ~_in a place where a DECLARE was not expected" + form) form) (defun walk-arglist (arglist context env &optional (destructuringp nil) - &aux arg) + &aux arg) (cond ((null arglist) ()) - ((symbolp (setq arg (car arglist))) - (or (member arg lambda-list-keywords) - (note-lexical-binding arg env)) - (recons arglist - arg - (walk-arglist (cdr arglist) - context - env - (and destructuringp - (not (member arg - lambda-list-keywords)))))) - ((consp arg) - (prog1 (recons arglist - (if destructuringp - (walk-arglist arg context env destructuringp) - (relist* arg - (car arg) - (walk-form-internal (cadr arg) :eval env) - (cddr arg))) - (walk-arglist (cdr arglist) context env nil)) - (if (symbolp (car arg)) - (note-lexical-binding (car arg) env) - (note-lexical-binding (cadar arg) env)) - (or (null (cddr arg)) - (not (symbolp (caddr arg))) - (note-lexical-binding (caddr arg) env)))) - (t - (error "Can't understand something in the arglist ~S" arglist)))) + ((symbolp (setq arg (car arglist))) + (or (member arg sb!xc:lambda-list-keywords :test #'eq) + (note-var-binding arg env)) + (recons arglist + arg + (walk-arglist (cdr arglist) + context + env + (and destructuringp + (not (member arg sb!xc:lambda-list-keywords)))))) + ((consp arg) + (prog1 (recons arglist + (if destructuringp + (walk-arglist arg context env destructuringp) + (relist* arg + (car arg) + (walk-form-internal (cadr arg) :eval env) + (cddr arg))) + (walk-arglist (cdr arglist) context env nil)) + (if (symbolp (car arg)) + (note-var-binding (car arg) env) + (note-var-binding (cadar arg) env)) + (or (null (cddr arg)) + (not (symbolp (caddr arg))) + (note-var-binding (caddr arg) env)))) + (t + (error "can't understand something in the arglist ~S" arglist)))) (defun walk-let (form context env) (walk-let/let* form context env nil)) @@ -707,253 +729,189 @@ (defun walk-let* (form context env) (walk-let/let* form context env t)) -(defun walk-prog (form context env) - (walk-prog/prog* form context env nil)) - -(defun walk-prog* (form context env) - (walk-prog/prog* form context env t)) - -(defun walk-do (form context env) - (walk-do/do* form context env nil)) - -(defun walk-do* (form context env) - (walk-do/do* form context env t)) - (defun walk-let/let* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((let/let* (car form)) - (bindings (cadr form)) - (body (cddr form)) - (walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (bindings (cadr form)) + (body (cddr form)) + walked-bindings + (walked-body + (walk-declarations + body + (lambda (real-body real-env) + (setf walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walk-repeat-eval real-body real-env)) + new-env))) (relist* - form let/let* walked-bindings walked-body)))) + form let/let* walked-bindings walked-body)))) -(defun walk-locally (form context env) +(defun walk-locally (form context old-env) (declare (ignore context)) - (let* ((locally (car form)) - (body (cdr form)) - (walked-body - (walk-declarations body #'walk-repeat-eval env))) - (relist* - form locally walked-body))) - -(defun walk-prog/prog* (form context old-env sequentialp) - (walker-environment-bind (new-env old-env) - (let* ((possible-block-name (second form)) - (blocked-prog (and (symbolp possible-block-name) - (not (eq possible-block-name 'nil))))) - (multiple-value-bind (let/let* block-name bindings body) - (if blocked-prog - (values (car form) (cadr form) (caddr form) (cdddr form)) - (values (car form) nil (cadr form) (cddr form))) - (let* ((walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations - body - #'(lambda (real-body real-env) - (walk-tagbody-1 real-body context real-env)) - new-env))) - (if block-name - (relist* - form let/let* block-name walked-bindings walked-body) - (relist* - form let/let* walked-bindings walked-body))))))) - -(defun walk-do/do* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) - (let* ((do/do* (car form)) - (bindings (cadr form)) - (end-test (caddr form)) - (body (cdddr form)) - (walked-bindings (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) - (relist* form - do/do* - (walk-bindings-2 bindings walked-bindings context new-env) - (walk-template end-test '(test repeat (eval)) context new-env) - walked-body)))) - -(defun walk-let-if (form context env) - (let ((test (cadr form)) - (bindings (caddr form)) - (body (cdddr form))) - (walk-form-internal - `(let () - (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) - bindings))) - (flet ((.let-if-dummy. () ,@body)) - (if ,test - (let ,bindings (.let-if-dummy.)) - (.let-if-dummy.)))) - context - env))) + (let* ((locally (car form)) + (body (cdr form)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* + form locally walked-body)))) (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) - (if (some #'(lambda (var) - (variable-symbol-macro-p var env)) - vars) - (let* ((temps (mapcar #'(lambda (var) - (declare (ignore var)) - (gensym)) - vars)) - (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) - vars - temps)) - (expanded `(multiple-value-bind ,temps ,(caddr form) - ,@sets)) - (walked (walk-form-internal expanded context env))) - (if (eq walked expanded) - form - walked)) - (walk-template form '(nil (repeat (set)) eval) context env)))) + (if (some (lambda (var) + (variable-symbol-macro-p var env)) + vars) + (let* ((temps (mapcar (lambda (var) + (declare (ignore var)) + (gensym)) + vars)) + (sets (mapcar (lambda (var temp) `(setq ,var ,temp)) + vars + temps)) + (expanded `(multiple-value-bind ,temps ,(caddr form) + ,@sets)) + (walked (walk-form-internal expanded context env))) + (if (eq walked expanded) + form + walked)) + (walk-template form '(nil (repeat (set)) eval) context env)))) (defun walk-multiple-value-bind (form context old-env) (walker-environment-bind (new-env old-env) (let* ((mvb (car form)) - (bindings (cadr form)) - (mv-form (walk-template (caddr form) 'eval context old-env)) - (body (cdddr form)) - walked-bindings - (walked-body - (walk-declarations - body - #'(lambda (real-body real-env) - (setq walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - nil)) - (walk-repeat-eval real-body real-env)) - new-env))) + (bindings (cadr form)) + (mv-form (walk-template (caddr form) 'eval context old-env)) + (body (cdddr form)) + walked-bindings + (walked-body + (walk-declarations + body + (lambda (real-body real-env) + (setq walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + nil)) + (walk-repeat-eval real-body real-env)) + new-env))) (relist* form mvb walked-bindings mv-form walked-body)))) (defun walk-bindings-1 (bindings old-env new-env context sequentialp) (and bindings (let ((binding (car bindings))) - (recons bindings - (if (symbolp binding) - (prog1 binding - (note-lexical-binding binding new-env)) - (prog1 (relist* binding - (car binding) - (walk-form-internal (cadr binding) - context - (if sequentialp - new-env - old-env)) - (cddr binding)) ; Save cddr for DO/DO*; - ; it is the next value - ; form. Don't walk it - ; now though. - (note-lexical-binding (car binding) new-env))) - (walk-bindings-1 (cdr bindings) - old-env - new-env - context - sequentialp))))) + (recons bindings + (if (symbolp binding) + (prog1 binding + (note-var-binding binding new-env)) + (prog1 (relist* binding + (car binding) + (walk-form-internal (cadr binding) + context + (if sequentialp + new-env + old-env)) + ;; Save cddr for DO/DO*; it is + ;; the next value form. Don't + ;; walk it now, though. + (cddr binding)) + (note-var-binding (car binding) new-env))) + (walk-bindings-1 (cdr bindings) + old-env + new-env + context + sequentialp))))) (defun walk-bindings-2 (bindings walked-bindings context env) (and bindings (let ((binding (car bindings)) - (walked-binding (car walked-bindings))) - (recons bindings - (if (symbolp binding) - binding - (relist* binding - (car walked-binding) - (cadr walked-binding) - (walk-template (cddr binding) - '(eval) - context - env))) - (walk-bindings-2 (cdr bindings) - (cdr walked-bindings) - context - env))))) + (walked-binding (car walked-bindings))) + (recons bindings + (if (symbolp binding) + binding + (relist* binding + (car walked-binding) + (cadr walked-binding) + (walk-template (cddr binding) + '(eval) + context + env))) + (walk-bindings-2 (cdr bindings) + (cdr walked-bindings) + context + env))))) (defun walk-lambda (form context old-env) (walker-environment-bind (new-env old-env) (let* ((arglist (cadr form)) - (body (cddr form)) - (walked-arglist (walk-arglist arglist context new-env)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (body (cddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) (relist* form - (car form) - walked-arglist - walked-body)))) + (car form) + walked-arglist + walked-body)))) (defun walk-named-lambda (form context old-env) (walker-environment-bind (new-env old-env) - (let* ((name (cadr form)) - (arglist (caddr form)) - (body (cdddr form)) - (walked-arglist (walk-arglist arglist context new-env)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (let* ((name (second form)) + (arglist (third form)) + (body (cdddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) (relist* form - (car form) - name - walked-arglist - walked-body)))) + (car form) + name + walked-arglist + walked-body)))) (defun walk-setq (form context env) (if (cdddr form) (let* ((expanded (let ((rforms nil) - (tail (cdr form))) - (loop (when (null tail) (return (nreverse rforms))) - (let ((var (pop tail)) (val (pop tail))) - (push `(setq ,var ,val) rforms))))) - (walked (walk-repeat-eval expanded env))) - (if (eq expanded walked) - form - `(progn ,@walked))) + (tail (cdr form))) + (loop (when (null tail) (return (nreverse rforms))) + (let ((var (pop tail)) (val (pop tail))) + (push `(setq ,var ,val) rforms))))) + (walked (walk-repeat-eval expanded env))) + (if (eq expanded walked) + form + `(progn ,@walked))) (let* ((var (cadr form)) - (val (caddr form)) - (symmac (car (variable-symbol-macro-p var env)))) - (if symmac - (let* ((expanded `(setf ,(cddr symmac) ,val)) - (walked (walk-form-internal expanded context env))) - (if (eq expanded walked) - form - walked)) - (relist form 'setq - (walk-form-internal var :set env) - (walk-form-internal val :eval env)))))) + (val (caddr form)) + (symmac (car (variable-symbol-macro-p var env)))) + (if symmac + (let* ((type (env-var-type var env)) + (expanded (if (eq t type) + `(setf ,(cddr symmac) ,val) + `(setf ,(cddr symmac) (the ,type ,val)))) + (walked (walk-form-internal expanded context env))) + (if (eq expanded walked) + form + walked)) + (relist form 'setq + (walk-form-internal var :set env) + (walk-form-internal val :eval env)))))) (defun walk-symbol-macrolet (form context old-env) (declare (ignore context)) (let* ((bindings (cadr form)) - (body (cddr form))) + (body (cddr form))) (walker-environment-bind - (new-env old-env - :lexical-variables - (append (mapcar #'(lambda (binding) - `(,(car binding) - :macro . ,(cadr binding))) - bindings) - (env-lexical-variables old-env))) + (new-env old-env + :lexical-vars + (append (mapcar (lambda (binding) + `(,(car binding) + sb!sys:macro . ,(cadr binding))) + bindings) + (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings - (walk-declarations body #'walk-repeat-eval new-env))))) + (walk-declarations body #'walk-repeat-eval new-env))))) (defun walk-tagbody (form context env) (recons form (car form) (walk-tagbody-1 (cdr form) context env))) @@ -961,320 +919,112 @@ (defun walk-tagbody-1 (form context env) (and form (recons form - (walk-form-internal (car form) - (if (symbolp (car form)) 'quote context) - env) - (walk-tagbody-1 (cdr form) context env)))) + (walk-form-internal (car form) + (if (symbolp (car form)) 'quote context) + env) + (walk-tagbody-1 (cdr form) context env)))) (defun walk-macrolet (form context old-env) - (walker-environment-bind (macro-env - nil - :walk-function (env-walk-function old-env)) - (labels ((walk-definitions (definitions) - (and definitions - (let ((definition (car definitions))) - (recons definitions - (relist* definition - (car definition) - (walk-arglist (cadr definition) - context - macro-env - t) - (walk-declarations (cddr definition) - #'walk-repeat-eval - macro-env)) - (walk-definitions (cdr definitions))))))) - (with-new-definition-in-environment (new-env old-env form) - (relist* form - (car form) - (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (walker-environment-bind (old-env old-env) + (walker-environment-bind (macro-env + nil + :walk-function (env-walk-function old-env)) + (labels ((walk-definitions (definitions) + (and definitions + (let ((definition (car definitions))) + (recons definitions + (relist* definition + (car definition) + (walk-arglist (cadr definition) + context + macro-env + t) + (walk-declarations (cddr definition) + #'walk-repeat-eval + macro-env)) + (walk-definitions (cdr definitions))))))) + (with-new-definition-in-environment (new-env old-env form) + (relist* form + (car form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) (defun walk-flet (form context old-env) - (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context old-env) - (walk-definitions (cdr definitions)))))) - (recons form - (car form) - (recons (cdr form) - (walk-definitions (cadr form)) - (with-new-definition-in-environment (new-env old-env form) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) - -(defun walk-labels (form context old-env) - (with-new-definition-in-environment (new-env old-env form) + (walker-environment-bind (old-env old-env) (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context new-env) - (walk-definitions (cdr definitions)))))) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context old-env) + (walk-definitions (cdr definitions)))))) (recons form - (car form) - (recons (cdr form) - (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (with-new-definition-in-environment (new-env old-env form) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) + +(defun walk-labels (form context old-env) + (walker-environment-bind (old-env old-env) + (with-new-definition-in-environment (new-env old-env form) + (labels ((walk-definitions (definitions) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context new-env) + (walk-definitions (cdr definitions)))))) + (recons form + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) (defun walk-if (form context env) - (let ((predicate (cadr form)) - (arm1 (caddr form)) - (arm2 - (if (cddddr form) - ;; FIXME: This should go away now that we're no longer trying - ;; to support any old weird CLTL1. - (progn - (warn "In the form:~%~S~%~ - IF only accepts three arguments, you are using ~D.~%~ - It is true that some Common Lisps support this, but ~ - it is not~%~ - truly legal Common Lisp. For now, this code ~ - walker is interpreting ~%~ - the extra arguments as extra else clauses. ~ - Even if this is what~%~ - you intended, you should fix your source code." - form - (length (cdr form))) - (cons 'progn (cdddr form))) - (cadddr form)))) + (destructuring-bind (if predicate arm1 &optional arm2) form + (declare (ignore if)) ; should be 'IF (relist form - 'if - (walk-form-internal predicate context env) - (walk-form-internal arm1 context env) - (walk-form-internal arm2 context env)))) + 'if + (walk-form-internal predicate context env) + (walk-form-internal arm1 context env) + (walk-form-internal arm2 context env)))) -;;;; tests tests tests +;;;; examples #| -;;; Here are some examples of the kinds of things you should be able to do -;;; with your implementation of the macroexpansion environment hacking -;;; mechanism. +;;; Here are some examples of the kinds of things you should be able +;;; to do with your implementation of the macroexpansion environment +;;; hacking mechanism. ;;; -;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes names -;;; of the macros and actual macroexpansion functions to use to macroexpand -;;; them. The win about that is that for macros which want to wrap several -;;; MACROLETs around their body, they can do this but have the macroexpansion -;;; functions be compiled. See the WITH-RPUSH example. +;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes +;;; names of the macros and actual macroexpansion functions to use to +;;; macroexpand them. The win about that is that for macros which want +;;; to wrap several MACROLETs around their body, they can do this but +;;; have the macroexpansion functions be compiled. See the WITH-RPUSH +;;; example. ;;; -;;; If the implementation had a special way of communicating the augmented -;;; environment back to the evaluator that would be totally great. It would -;;; mean that we could just augment the environment then pass control back -;;; to the implementations own compiler or interpreter. We wouldn't have -;;; to call the actual walker. That would make this much faster. Since the -;;; principal client of this is defmethod it would make compiling defmethods -;;; faster and that would certainly be a win. +;;; If the implementation had a special way of communicating the +;;; augmented environment back to the evaluator that would be totally +;;; great. It would mean that we could just augment the environment +;;; then pass control back to the implementations own compiler or +;;; interpreter. We wouldn't have to call the actual walker. That +;;; would make this much faster. Since the principal client of this is +;;; defmethod it would make compiling defmethods faster and that would +;;; certainly be a win. (defmacro with-lexical-macros (macros &body body &environment old-env) (with-augmented-environment (new-env old-env :macros macros) (walk-form (cons 'progn body) :environment new-env))) (defun expand-rpush (form env) + (declare (ignore env)) `(push ,(caddr form) ,(cadr form))) (defmacro with-rpush (&body body) `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body)) - -;;; Unfortunately, I don't have an automatic tester for the walker. -;;; Instead there is this set of test cases with a description of -;;; how each one should go. -(defmacro take-it-out-for-a-test-walk (form) - `(take-it-out-for-a-test-walk-1 ',form)) - -(defun take-it-out-for-a-test-walk-1 (form) - (terpri) - (terpri) - (let ((copy-of-form (copy-tree form)) - (result (walk-form form nil - #'(lambda (x y env) - (format t "~&Form: ~S ~3T Context: ~A" x y) - (when (symbolp x) - (let ((lexical (variable-lexical-p x env)) - (special (variable-special-p x env))) - (when lexical - (format t ";~3T") - (format t "lexically bound")) - (when special - (format t ";~3T") - (format t "declared special")) - (when (boundp x) - (format t ";~3T") - (format t "bound: ~S " (eval x))))) - x)))) - (cond ((not (equal result copy-of-form)) - (format t "~%Warning: Result not EQUAL to copy of start.")) - ((not (eq result form)) - (format t "~%Warning: Result not EQ to copy of start."))) - (pprint result) - result)) - -(defmacro foo (&rest ignore) ''global-foo) - -(defmacro bar (&rest ignore) ''global-bar) - -(take-it-out-for-a-test-walk (list arg1 arg2 arg3)) -(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))) - -(take-it-out-for-a-test-walk (progn (foo) (bar 1))) - -(take-it-out-for-a-test-walk (block block-name a b c)) -(take-it-out-for-a-test-walk (block block-name (list a) b c)) - -(take-it-out-for-a-test-walk (catch catch-tag (list a) b c)) -;;; This is a fairly simple macrolet case. While walking the body of the -;;; macro, x should be lexically bound. In the body of the macrolet form -;;; itself, x should not be bound. -(take-it-out-for-a-test-walk - (macrolet ((foo (x) (list x) ''inner)) - x - (foo 1))) - -;;; A slightly more complex macrolet case. In the body of the macro x -;;; should not be lexically bound. In the body of the macrolet form itself -;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it -;;; tries to macroexpand the call to foo. -(take-it-out-for-a-test-walk - (let ((x 1)) - (macrolet ((foo () (list x) ''inner)) - x - (foo)))) - -(take-it-out-for-a-test-walk - (flet ((foo (x) (list x y)) - (bar (x) (list x y))) - (foo 1))) - -(take-it-out-for-a-test-walk - (let ((y 2)) - (flet ((foo (x) (list x y)) - (bar (x) (list x y))) - (foo 1)))) - -(take-it-out-for-a-test-walk - (labels ((foo (x) (bar x)) - (bar (x) (foo x))) - (foo 1))) - -(take-it-out-for-a-test-walk - (flet ((foo (x) (foo x))) - (foo 1))) - -(take-it-out-for-a-test-walk - (flet ((foo (x) (foo x))) - (flet ((bar (x) (foo x))) - (bar 1)))) - -(take-it-out-for-a-test-walk (prog () (declare (special a b)))) -(take-it-out-for-a-test-walk (let (a b c) - (declare (special a b)) - (foo a) b c)) -(take-it-out-for-a-test-walk (let (a b c) - (declare (special a) (special b)) - (foo a) b c)) -(take-it-out-for-a-test-walk (let (a b c) - (declare (special a)) - (declare (special b)) - (foo a) b c)) -(take-it-out-for-a-test-walk (let (a b c) - (declare (special a)) - (declare (special b)) - (let ((a 1)) - (foo a) b c))) -(take-it-out-for-a-test-walk (eval-when () - a - (foo a))) -(take-it-out-for-a-test-walk (eval-when (eval when load) - a - (foo a))) - -(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b))) -(take-it-out-for-a-test-walk (multiple-value-bind (a b) - (foo a b) - (declare (special a)) - (list a b))) -(take-it-out-for-a-test-walk (progn (function foo))) -(take-it-out-for-a-test-walk (progn a b (go a))) -(take-it-out-for-a-test-walk (if a b c)) -(take-it-out-for-a-test-walk (if a b)) -(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)) -(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b)) - 1 2)) -(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c))) -(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))) -(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) - (declare (special a b)) - (list a b c))) -(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) - (declare (special a b)) - (list a b c))) -(take-it-out-for-a-test-walk (let ((a 1) (b 2)) - (foo bar) - (declare (special a)) - (foo a b))) -(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)) -(take-it-out-for-a-test-walk (multiple-value-prog1 a b c)) -(take-it-out-for-a-test-walk (progn a b c)) -(take-it-out-for-a-test-walk (progv vars vals a b c)) -(take-it-out-for-a-test-walk (quote a)) -(take-it-out-for-a-test-walk (return-from block-name a b c)) -(take-it-out-for-a-test-walk (setq a 1)) -(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)) -(take-it-out-for-a-test-walk (tagbody a b c (go a))) -(take-it-out-for-a-test-walk (the foo (foo-form a b c))) -(take-it-out-for-a-test-walk (throw tag-form a)) -(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)) - -(defmacro flet-1 (a b) ''outer) -(defmacro labels-1 (a b) ''outer) - -(take-it-out-for-a-test-walk - (flet ((flet-1 (a b) () (flet-1 a b) (list a b))) - (flet-1 1 2) - (foo 1 2))) -(take-it-out-for-a-test-walk - (labels ((label-1 (a b) () (label-1 a b)(list a b))) - (label-1 1 2) - (foo 1 2))) -(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b))) - (macrolet-1 a b) - (foo 1 2))) - -(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a))) - (foo 1))) - -(take-it-out-for-a-test-walk (progn (bar 1) - (macrolet ((bar (a) - `(inner-bar-expanded ,a))) - (bar 2)))) - -(take-it-out-for-a-test-walk (progn (bar 1) - (macrolet ((bar (s) - (bar s) - `(inner-bar-expanded ,s))) - (bar 2)))) - -(take-it-out-for-a-test-walk (cond (a b) - ((foo bar) a (foo a)))) - -(let ((the-lexical-variables ())) - (walk-form '(let ((a 1) (b 2)) - #'(lambda (x) (list a b x y))) - () - #'(lambda (form context env) - (when (and (symbolp form) - (variable-lexical-p form env)) - (push form the-lexical-variables)) - form)) - (or (and (= (length the-lexical-variables) 3) - (member 'a the-lexical-variables) - (member 'b the-lexical-variables) - (member 'x the-lexical-variables)) - (error "Walker didn't do lexical variables of a closure properly."))) |#