+
+(defvar *null-lexenv* (make-null-lexenv))
+
+(defun augment-environment
+ (env &key variable symbol-macro function macro declare)
+ "Create a new lexical environment by augmenting ENV with new information.
+
+ VARIABLE
+ is a list of symbols to introduce as new variable bindings.
+
+ SYMBOL-MACRO
+ is a list symbol macro bindings of the form (name definition).
+
+ MACRO
+ is a list of macro definitions of the form (name definition), where
+ definition is a function of two arguments (a form and an environment).
+
+ FUNCTION
+ is a list of symbols to introduce as new local function bindings.
+
+ DECLARE
+ is a list of declaration specifiers. Declaration specifiers attach to the
+ new variable or function bindings as if they appeared in let, let*, flet
+ or labels form. For example:
+
+ (augment-environment env :variable '(x) :declare '((special x)))
+
+ is like
+
+ (let (x) (declare (special x)) ....)
+
+ but
+
+ (augment-environment (augment-environment env :variable '(x))
+ :declare '((special x)))
+
+ is like
+
+ (let (x) (locally (declare (special x))) ...)
+"
+ (collect ((lvars)
+ (clambdas))
+ (unless (or variable symbol-macro function macro declare)
+ (return-from augment-environment env))
+
+ (if (null env)
+ (setq env (make-null-lexenv))
+ (setq env (copy-structure env)))
+
+ ;; a null policy is used to identify a null lexenv
+ (when (sb-c::null-lexenv-p env)
+ (setf (sb-c::lexenv-%policy env) sb-c::*policy*))
+
+ (when macro
+ (setf (sb-c::lexenv-funs env)
+ (nconc
+ (loop for (name def) in macro
+ collect (cons name (cons 'sb-sys::macro def)))
+ (sb-c::lexenv-funs env))))
+
+ (when symbol-macro
+ (setf (sb-c::lexenv-vars env)
+ (nconc
+ (loop for (name def) in symbol-macro
+ collect (cons name (cons 'sb-sys::macro def)))
+ (sb-c::lexenv-vars env))))
+
+ (dolist (name variable)
+ (lvars (sb-c::make-lambda-var :%source-name name)))
+
+ (dolist (name function)
+ (clambdas
+ (sb-c::make-lambda
+ :lexenv *null-lexenv*
+ :%source-name name
+ :allow-instrumenting nil)))
+
+ (when declare
+ ;; process-decls looks in *lexenv* policy to decide what warnings to print
+ (let ((*lexenv* *null-lexenv*))
+ (setq env (sb-c::process-decls
+ (list `(declare ,@declare))
+ (lvars) (clambdas) :lexenv env :context nil))))
+
+ (when function
+ (setf (sb-c::lexenv-funs env)
+ (nconc
+ (loop for name in function for lambda in (clambdas)
+ collect (cons name lambda))
+ (sb-c::lexenv-funs env))))
+
+ (when variable
+ (setf (sb-c::lexenv-vars env)
+ (nconc
+ (loop for name in variable for lvar in (lvars)
+ collect
+ (cons name
+ ;; If one of the lvars is declared special then
+ ;; process-decls will set it's specvar.
+ (if (sb-c::lambda-var-specvar lvar)
+ (sb-c::lambda-var-specvar lvar)
+ lvar)))
+ (sb-c::lexenv-vars env))))
+
+ env))
+
+;;; Retrieve the user-supplied (from define-declaration) pairs for a
+;;; function or a variable from a lexical environment.
+;;;
+;;; KEYWORD should be :function or :variable, VAR should be a
+;;; function or variable name, respectively.
+(defun extra-pairs (keyword var binding env)
+ (when env
+ (let ((ret nil))
+ (dolist (entry (sb-c::lexenv-user-data env))
+ (destructuring-bind
+ (entry-keyword entry-var entry-binding &rest entry-cons)
+ entry
+ (when (and (eq keyword entry-keyword)
+ (typecase binding
+ (sb-c::global-var
+ (and (eq var entry-var)
+ (typecase entry-binding
+ (sb-c::global-var t)
+ (sb-c::lambda-var
+ (sb-c::lambda-var-specvar entry-binding))
+ (null t)
+ (t nil))))
+ (t
+ (eq binding entry-binding))))
+ (push entry-cons ret))))
+ (nreverse ret))))
+
+;;; Retrieve the user-supplied (from define-declaration) value for
+;;; the declaration with the given NAME
+(defun extra-decl-info (name env)
+ (when env
+ (dolist (entry (sb-c::lexenv-user-data env))
+ (when (and (eq :declare (car entry))
+ (eq name (cadr entry)))
+ (return-from extra-decl-info (cddr entry))))
+ nil))
+
+
+(declaim (ftype (sfunction ((or symbol cons) &optional (or null lexenv))