;;;;
;;;; The code which implements the macroexpansion environment
;;;; manipulation mechanisms is in the first part of the file, the
;;;;
;;;; The code which implements the macroexpansion environment
;;;; manipulation mechanisms is in the first part of the file, the
;;; 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
;;; 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
;;; 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
;;; 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
;;;
;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND
;;; this code hides the WALKER version of an environment
;;;
;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND
;;; this code hides the WALKER version of an environment
;;;
;;; In CMUCL (and former SBCL), This used to be a list of lists of form
;;; (<gensym-name> MACRO . #<interpreted-function>) in the :functions slot
;;;
;;; In CMUCL (and former SBCL), This used to be a list of lists of form
;;; (<gensym-name> MACRO . #<interpreted-function>) in the :functions slot
;;; Instead this list was COERCEd to a #<FUNCTION ...>!
;;;
;;; Instead, we now use a special sort of "function"-type for that
;;; Instead this list was COERCEd to a #<FUNCTION ...>!
;;;
;;; Instead, we now use a special sort of "function"-type for that
;;; 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-FUN.
;;;
;;; 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-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.
(defun bogo-fun-to-walker-info (bogo-fun)
(declare (type function bogo-fun))
(funcall bogo-fun *bogo-fun-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 funs macros)
;; Note: In order to record the correct function definition, we
;; would have to create an interpreted closure, but the
(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
;; 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.
;; 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 ((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)))))
+ (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)))))
(if (eq macro *key-to-walker-environment*)
(values (bogo-fun-to-walker-info (cddr entry)))
(values (function-lambda-expression (cddr entry))))))))
(if (eq macro *key-to-walker-environment*)
(values (bogo-fun-to-walker-info (cddr entry)))
(values (function-lambda-expression (cddr entry))))))))
(string (car mac))))
,macros))))
(with-augmented-environment
(,new-env ,old-env :functions ,functions :macros ,macros)
,@body))))
(string (car mac))))
,macros))))
(with-augmented-environment
(,new-env ,old-env :functions ,functions :macros ,macros)
,@body))))
- (eval `(defmacro ,gensym ,llist ,@body))
+ (eval-in-lexenv `(defmacro ,gensym ,llist ,@body)
+ (sb!c::make-restricted-lexenv env))
(defun variable-symbol-macro-p (var env)
(let ((entry (member var (env-lexical-variables env) :key #'car)))
(defun variable-symbol-macro-p (var env)
(let ((entry (member var (env-lexical-variables env) :key #'car)))
;;; - Is a common lisp special form (not likely)
;;; - Is not a common lisp special form (on the 3600 IF --> COND).
;;;
;;; - Is a common lisp special form (not likely)
;;; - Is not a common lisp special form (on the 3600 IF --> COND).
;;;
;;; by checking to see whether there is a template defined for
;;; something before we check to see whether we can macroexpand it.
;;;
;;; by checking to see whether there is a template defined for
;;; something before we check to see whether we can macroexpand it.
;;;
;; maintained as part of SBCL, so it should know
;; about all the special forms that SBCL knows
;; about.
;; maintained as part of SBCL, so it should know
;; about all the special forms that SBCL knows
;; about.
(t
;; Otherwise, walk the form as if it's just a
;; standard function call using a template for
(t
;; Otherwise, walk the form as if it's just a
;; standard function call using a template for
-(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))))
-