X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=05d7f511d01909efca1038eb3c529f356b17bf7f;hb=eadecfd6fd102f5c8eda32770153ceed2f9f3b70;hp=c8e0eb81633fcc7d7ee102faa03111d33f78cc56;hpb=853b48ca4085b8ad9831edb9b06935a0977c0800;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index c8e0eb8..05d7f51 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -1,4 +1,4 @@ -;;;; 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 @@ -27,7 +27,11 @@ ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. -(in-package "SB-WALKER") +(in-package "SB!WALKER") + +;;;; forward references + +(defvar *key-to-walker-environment*) ;;;; environment hacking stuff, necessarily SBCL-specific @@ -75,17 +79,16 @@ ;;; 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. -;;; Except for SYMBOL-MACROLET, only the SB-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. -;;; Accessors are defined below, eg (ENV-WALK-FUNCTION ENV). +;;; 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. +;;; 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 @@ -96,14 +99,17 @@ ;;; 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-FUNCTION. +;;; 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 is the only SBCL function that gets called with the -;;; constructed environment argument. +;;; 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) @@ -112,21 +118,31 @@ ,macros))) ,@body)) -(defstruct (bogo-function - (:alternate-metaclass sb-kernel:funcallable-instance - sb-kernel:funcallable-structure-class - sb-kernel:make-funcallable-structure-class) - (:type sb-kernel:funcallable-structure) - (:copier nil)) - (walker-info (required-argument) :type list)) - -(defun walker-info-to-bogo-function (x) - (make-bogo-function :walker-info x)) - -(defun bogo-function-to-walker-info (x) - (bogo-function-walker-info 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 @@ -134,36 +150,37 @@ ;; environment. So we just blow it off, 'cause anything real we do ;; would be wrong. But 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 - (if (eq (car m) *key-to-walker-environment*) - (walker-info-to-bogo-function (cadr m)) - (coerce (cadr m) 'function)))) - macros))))) + (let ((lexenv (sb!kernel::coerce-to-lexenv env))) + (sb!c::make-lexenv + :default lexenv + :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)) + (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) + (eq (cadr entry) 'sb!c::macro) (if (eq macro *key-to-walker-environment*) - (values (bogo-function-to-walker-info (cddr entry))) - (values (function-lambda-expression (cddr entry)))))))) + (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 @@ -183,15 +200,17 @@ (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)))) -(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))) ;;;; the actual walker @@ -222,7 +241,7 @@ (list (list *key-to-walker-environment* (list (if wfnp walk-function (car lock)) - (if wfop walk-form (cadr lock)) + (if wfop walk-form (cadr lock)) (if decp declarations (caddr lock)) (if lexp lexical-variables (cadddr lock))))))) @@ -244,32 +263,32 @@ (defun note-lexical-binding (thing env) (push (list thing :lexical-var) (cadddr (env-lock env)))) -(defun variable-lexical-p (var env) +(defun var-lexical-p (var env) (let ((entry (member var (env-lexical-variables env) :key #'car))) (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) + (when (eq (cadar entry) 'sb!sys:macro) entry))) -(defvar *variable-declarations* '(special)) +(defvar *var-declarations* '(special)) -(defun variable-declaration (declaration var env) - (if (not (member declaration *variable-declarations*)) +(defun var-declaration (declaration var env) + (if (not (member declaration *var-declarations*)) (error "~S is not a recognized variable declaration." declaration) - (let ((id (or (variable-lexical-p var env) var))) + (let ((id (or (var-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 var-special-p (var env) + (or (not (null (var-declaration 'special var env))) + (var-globally-special-p var))) -(defun variable-globally-special-p (symbol) +(defun var-globally-special-p (symbol) (eq (info :variable :kind symbol) :special)) ;;;; handling of special forms @@ -301,7 +320,7 @@ ;;; - 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) +;;; * 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. ;;; @@ -377,7 +396,7 @@ (define-walker-template unwind-protect (nil return repeat (eval))) ;;; SBCL-only special forms -(define-walker-template sb-ext:truly-the (nil quote eval)) +(define-walker-template sb!ext:truly-the (nil quote eval)) (defvar *walk-form-expand-macros-p* nil) @@ -435,7 +454,7 @@ (multiple-value-bind (newnewform macrop) (walker-environment-bind (new-env env :walk-form newform) - (macroexpand-1 newform new-env)) + (sb-xc:macroexpand-1 newform new-env)) (cond (macrop (let ((newnewnewform (walk-form-internal newnewform @@ -451,7 +470,7 @@ ;; maintained as part of SBCL, so it should know ;; about all the special forms that SBCL knows ;; about. - (error "unexpected special form ~S" fn)) + (bug "unexpected special form ~S" fn)) (t ;; Otherwise, walk the form as if it's just a ;; standard function call using a template for @@ -588,9 +607,9 @@ (let ((type (car declaration)) (name (cadr declaration)) (args (cddr declaration))) - (if (member type *variable-declarations*) + (if (member type *var-declarations*) (note-declaration `(,type - ,(or (variable-lexical-p name env) name) + ,(or (var-lexical-p name env) name) ,.args) env) (note-declaration declaration env)) @@ -604,7 +623,7 @@ (null (get-walker-template (car form))) (progn (multiple-value-setq (new-form macrop) - (macroexpand-1 form env)) + (sb-xc:macroexpand-1 form env)) macrop)) ;; This form was a call to a macro. Maybe it expanded ;; into a declare? Recurse to find out. @@ -620,7 +639,7 @@ (defun walk-unexpected-declare (form context env) (declare (ignore context env)) - (warn "encountered DECLARE ~S in a place where a DECLARE was not expected" + (warn "encountered ~S ~_in a place where a DECLARE was not expected" form) form) @@ -693,7 +712,7 @@ (body (cdddr form))) (walk-form-internal `(let () - (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) + (declare (special ,@(mapcar (lambda (x) (if (listp x) (car x) x)) bindings))) (flet ((.let-if-dummy. () ,@body)) (if ,test @@ -704,14 +723,14 @@ (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) - (if (some #'(lambda (var) - (variable-symbol-macro-p var env)) + (if (some (lambda (var) + (variable-symbol-macro-p var env)) vars) - (let* ((temps (mapcar #'(lambda (var) - (declare (ignore var)) - (gensym)) + (let* ((temps (mapcar (lambda (var) + (declare (ignore var)) + (gensym)) vars)) - (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) + (sets (mapcar (lambda (var temp) `(setq ,var ,temp)) vars temps)) (expanded `(multiple-value-bind ,temps ,(caddr form) @@ -732,14 +751,14 @@ (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)) + (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)))) @@ -799,20 +818,6 @@ 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))) - (relist* form - (car form) - name - walked-arglist - walked-body)))) - (defun walk-setq (form context env) (if (cdddr form) (let* ((expanded (let ((rforms nil) @@ -844,9 +849,9 @@ (walker-environment-bind (new-env old-env :lexical-variables - (append (mapcar #'(lambda (binding) - `(,(car binding) - :macro . ,(cadr binding))) + (append (mapcar (lambda (binding) + `(,(car binding) + sb!sys:macro . ,(cadr binding))) bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings