Update of /cvsroot/sbcl/sbcl/contrib/sb-cltl2
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv22026/contrib/sb-cltl2
Modified Files:
env.lisp tests.lisp
Log Message:
1.0.30.15: more complete SB-CLTL2:DECLARATION-INFORMATION
* (DECLARATION-INFORMATION 'DECLARATION) returns a list of
declaration names that have been proclaimed as valid.
Patch by Larry D'Anna.
Index: env.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-cltl2/env.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- env.lisp 29 Jul 2009 16:01:29 -0000 1.8
+++ env.lisp 29 Jul 2009 16:15:42 -0000 1.9
@@ -8,7 +8,6 @@
(in-package :sb-cltl2)
#| TODO:
-declaration-information
augment-environment
define-declaration
(map-environment)
@@ -225,8 +224,11 @@
(defun declaration-information (declaration-name &optional env)
"Return information about declarations named by DECLARATION-NAME.
-If DECLARATION-NAME is optimize return a list who's entries are of the
-form (quality value).
+If DECLARATION-NAME is OPTIMIZE return a list who's entries are of the
+form \(QUALITY VALUE).
+
+If DECLARATION-NAME is DECLARATION return a list of declaration names that
+have been proclaimed as valid.
If DECLARATION-NAME is SB-EXT:MUFFLE-CONDITIONS return a type specifier for
the condition types that have been muffled."
@@ -243,6 +245,16 @@
(sb-ext:muffle-conditions
(car (rassoc 'muffle-warning
(sb-c::lexenv-handled-conditions env))))
+ (declaration
+ ;; FIXME: This is a bit too deep in the guts of INFO for comfort...
+ (let ((type (sb-c::type-info-number
+ (sb-c::type-info-or-lose :declaration :recognized)))
+ (ret nil))
+ (dolist (env *info-environment*)
+ (do-info (env :name name :type-number num :value value)
+ (when (and (= num type) value)
+ (push name ret))))
+ ret))
(t (error "Unsupported declaration ~S." declaration-name)))))
(defun parse-macro (name lambda-list body &optional env)
Index: tests.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-cltl2/tests.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- tests.lisp 29 Jul 2009 16:01:29 -0000 1.9
+++ tests.lisp 29 Jul 2009 16:15:42 -0000 1.10
@@ -109,6 +109,13 @@
(subtypep '(and warning (not style-warning)) dinfo)))))))
t)
+
+(declaim (declaration fubar))
+
+(deftest declaration-information.declaration
+ (if (member 'fubar (declaration-information 'declaration)) 'yay)
+ yay)
+
;;;; VARIABLE-INFORMATION
(defvar *foo*)
|