X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=869d2681993818114016fda35c889bd1feaa108e;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=6f5177070ba89de0876b1cba496a1221c96f600c;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 6f51770..869d268 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -96,15 +96,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-FUNCTION. ;;; ;;; MACROEXPAND-1 is the only SBCL function that gets 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 @@ -112,19 +114,29 @@ ,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)) +;;; a unique tag to show that we're the intended caller of BOGO-FUNCTION +(defvar *bogo-function-magic-tag* + '(:bogo-function-magic-tag)) -(defun bogo-function-to-walker-info (x) - (bogo-function-walker-info x)) +;;; The interface of BOGO-FUNCTIONs (previously implemented as +;;; FUNCALLABLE-INSTANCES) is just these two operations, so we can +;;; do them with ordinary closures. +;;; +;;; KLUDGE: BOGO-FUNCTIONS are sorta weird, and MNA and I have both +;;; hacked on this code without really 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-function (walker-info) + (lambda (magic-tag &rest rest) + (aver (not rest)) ; else someone is using me in an unexpected way + (aver (eql magic-tag *bogo-function-magic-tag*)) ; else ditto + walker-info)) +(defun bogo-function-to-walker-info (bogo-function) + (declare (type function bogo-function)) + (funcall bogo-function *bogo-function-magic-tag*)) (defun with-augmented-environment-internal (env functions macros) ;; Note: In order to record the correct function definition, we @@ -145,8 +157,8 @@ (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)))) + (walker-info-to-bogo-function (cadr m)) + (coerce (cadr m) 'function)))) macros))))) (defun environment-function (env fn) @@ -162,8 +174,8 @@ (and entry (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-function-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 @@ -244,7 +256,7 @@ (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))) @@ -254,22 +266,22 @@ (when (eq (cadar entry) :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 @@ -588,9 +600,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))