+
+;;; Add a bit of user-data to a lexenv.
+;;;
+;;; If KIND is :declare then DATA should be of the form
+;;; (declaration-name . value)
+;;; If KIND is :variable then DATA should be of the form
+;;; (variable-name key value)
+;;; If KIND is :function then DATA should be of the form
+;;; (function-name key value)
+;;;
+;;; PD-VARS and PD-FVARS are are the vars and fvars arguments
+;;; of the process-decls call that called this function.
+(defun update-lexenv-user-data (env kind data pd-vars pd-fvars)
+ (let ((user-data (sb-c::lexenv-user-data env)))
+ ;; user-data looks like this:
+ ;; ((:declare d . value)
+ ;; (:variable var binding key . value)
+ ;; (:function var binding key . value))
+ (let ((*lexenv* env))
+ (ecase kind
+ (:variable
+ (loop
+ for (name key value) in data
+ for binding1 = (sb-c::find-in-bindings pd-vars name)
+ for binding = (if binding1 binding1 (lexenv-find name vars))
+ do (push (list* :variable name binding key value) user-data)))
+ (:function
+ (loop
+ for (name key value) in data
+ for binding1 = (find name pd-fvars :key #'sb-c::leaf-source-name :test #'equal)
+ for binding = (if binding1 binding1 (lexenv-find name funs))
+ do (push (list* :function name binding key value) user-data)))
+ (:declare
+ (destructuring-bind (decl-name . value) data
+ (push (list* :declare decl-name value) user-data)))))
+ (sb-c::make-lexenv :default env :user-data user-data)))
+
+(defmacro define-declaration (decl-name lambda-list &body body)
+ "Define a handler for declaration specifiers starting with DECL-NAME.
+
+The function defined by this macro is called with two arguments: a declaration
+specifier and a environment. It must return two values. The first value must
+be :VARIABLE, :FUNCTION, or :DECLARE.
+
+If the first value is :VARIABLE or :FUNCTION then the second value should be a
+list of elements of the form (BINDING-NAME KEY VALUE). conses (KEY . VALUE)
+will be added to the alist returned by:
+
+ (function-information binding-name env)
+
+ or
+
+ (variable-information binding-name env)
+
+If the first value is :DECLARE then the second value should be a
+cons (DECL-NAME . VALUE). VALUE will be returned by:
+
+ (declaration-information decl-name env)
+"
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (proclaim '(declaration ,decl-name))
+ (flet ((func ,lambda-list
+ ,@body))
+ (setf
+ (info :declaration :handler ',decl-name)
+ (lambda (lexenv spec pd-vars pd-fvars)
+ (multiple-value-bind (kind data) (func spec lexenv)
+ (update-lexenv-user-data lexenv kind data pd-vars pd-fvars)))))))