0.8.10.29:

[sbcl.git] / contrib / sb-cltl2 / env.lisp

diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp
index 379de12..896d8f3 100644 (file)
--- a/contrib/sb-cltl2/env.lisp
+++ b/contrib/sb-cltl2/env.lisp
@@ -52,6 +52,24 @@ alist of declarations that apply to the apparent binding of VAR."
                       (type . ,(type-specifier ; XXX local type
                                 (info :variable :type var)))))))))
 
+(declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
+                declaration-information))
+(defun declaration-information (declaration-name &optional env)
+  (let ((env (or env (make-null-lexenv))))
+    (case declaration-name
+      (optimize
+       (let ((policy (sb-c::lexenv-policy env)))
+        (collect ((res))
+          (dolist (name sb-c::*policy-qualities*)
+            (res (list name (cdr (assoc name policy)))))
+          (loop for (name . nil) in sb-c::*policy-dependent-qualities*
+                do (res (list name (sb-c::policy-quality policy name))))
+          (res))))
+      (sb-ext:muffle-conditions
+       (car (rassoc 'muffle-warning
+                   (sb-c::lexenv-handled-conditions env))))
+      (t (error "Unsupported declaration ~S." declaration-name)))))
+
 (defun parse-macro (name lambda-list body &optional env)
   (declare (ignore env))
   (with-unique-names (whole environment)