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 0abdf8c..896d8f3 100644 (file)
--- a/contrib/sb-cltl2/env.lisp
+++ b/contrib/sb-cltl2/env.lisp
@@ -9,20 +9,23 @@ define-declaration
 |#
 
 (declaim (ftype (sfunction
-                 (symbol &optional (or null sb-kernel:lexenv))
+                 (symbol &optional (or null lexenv))
                  (values (member nil :special :lexical :symbol-macro :constant)
                          boolean
                          list))
                 variable-information))
 (defun variable-information (var &optional env)
-  (let* ((*lexenv* (or env (sb-kernel:make-null-lexenv)))
+  "Return three values. The first indicates a binding kind of VAR; the
+second is True if there is a local binding of VAR; the third is an
+alist of declarations that apply to the apparent binding of VAR."
+  (let* ((*lexenv* (or env (make-null-lexenv)))
          (info (lexenv-find var vars)))
     (etypecase info
-      (sb-c::leaf (let ((type (sb-kernel:type-specifier
-                               (sb-kernel:type-intersection
+      (sb-c::leaf (let ((type (type-specifier
+                               (type-intersection
                                 (sb-c::leaf-type info)
                                 (or (lexenv-find info type-restrictions)
-                                    sb-kernel:*universal-type*)))))
+                                    *universal-type*)))))
                     (etypecase info
                       (sb-c::lambda-var
                        (values :lexical t
@@ -46,24 +49,40 @@ define-declaration
                       (:global nil))
                     nil
                     `(                  ; XXX ignore
-                      (type . ,(sb-kernel:type-specifier ; XXX local type
+                      (type . ,(type-specifier ; XXX local type
                                 (info :variable :type var)))))))))
 
-(defun parse-macro (name lambda-list body
-                    &optional env)
+(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)
     (multiple-value-bind (body decls)
-        (sb-kernel:parse-defmacro lambda-list whole body name
-                                  'parse-macro
-                                  :environment environment)
+        (parse-defmacro lambda-list whole body name
+                        'parse-macro
+                        :environment environment)
       `(lambda (,whole ,environment)
          ,@decls
          ,body))))
 
-(defun enclose (lambda-expression
-                &optional env)
+(defun enclose (lambda-expression &optional env)
   (let ((env (if env
                  (sb-c::make-restricted-lexenv env)
-                 (sb-kernel:make-null-lexenv))))
+                 (make-null-lexenv))))
     (compile-in-lexenv nil lambda-expression env)))