X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=db24948dc7c1a60d125fbca8e3db862ba9408bde;hb=138ba28006d97560d270d8da3cf3c99012e9053d;hp=869d2681993818114016fda35c889bd1feaa108e;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 869d268..db24948 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -75,13 +75,12 @@ ;;; 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 @@ -100,7 +99,7 @@ ;;; 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. +;;; our new BOGO-FUN. ;;; ;;; MACROEXPAND-1 is the only SBCL function that gets called with the ;;; constructed environment argument. @@ -114,31 +113,31 @@ ,macros))) ,@body)) -;;; a unique tag to show that we're the intended caller of BOGO-FUNCTION -(defvar *bogo-function-magic-tag* - '(:bogo-function-magic-tag)) +;;; 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-FUNCTIONs (previously implemented as -;;; FUNCALLABLE-INSTANCES) is just these two operations, so we can -;;; do them with ordinary closures. +;;; 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-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 +;;; 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-function (walker-info) +(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-function-magic-tag*)) ; else ditto + (aver (eql magic-tag *bogo-fun-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 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 functions macros) +(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 @@ -149,32 +148,33 @@ (let ((lexenv (sb-kernel::coerce-to-lexenv env))) (sb-c::make-lexenv :default lexenv - :functions - (append (mapcar (lambda (f) - (cons (car f) (sb-c::make-functional :lexenv lexenv))) - 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))))) + :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))))) (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) (if (eq macro *key-to-walker-environment*) - (values (bogo-function-to-walker-info (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 @@ -632,7 +632,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) @@ -705,7 +705,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 @@ -716,14 +716,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) @@ -744,14 +744,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)))) @@ -811,20 +811,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) @@ -856,9 +842,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) + :macro . ,(cadr binding))) bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings