;;; 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 . <function>) (a
-;;; local macro, with the specifier expander.) Note that Name may be a
-;;; (SETF <name>) 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 . <function>) (a local macro, with the specifier expander.)
+;;; Note that Name may be a (SETF <name>) 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
;;; information, because the functions slot in SB-C::LEXENV is
;;; supposed to have a list of <Name MACRO . #<function> 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.
+;;; 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")
,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 with-augmented-environment-internal (env functions macros)
+(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
(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))))))))
\f
;;;; other environment hacking, not so SBCL-specific as the
(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)))
\f
;;;; the actual walker
(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 *var-declarations* '(special))
(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)
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)
:lexical-variables
(append (mapcar (lambda (binding)
`(,(car binding)
- :macro . ,(cadr binding)))
+ sb-sys:macro . ,(cadr binding)))
bindings)
(env-lexical-variables old-env)))
(relist* form 'symbol-macrolet bindings
projects / sbcl.git / blobdiff