-(defun variable-information (var &optional env)
- (let* ((*lexenv* (or env (sb-kernel: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-type info)
- (or (lexenv-find info type-restrictions)
- sb-kernel:*universal-type*)))))
- (etypecase info
- (sb-c::lambda-var
- (values :lexical t
- `((ignore . ,(sb-c::lambda-var-ignorep info))
- (type . ,type))))
- (sb-c::global-var
- (values :special t
- `((type . ,type)) ; XXX ignore
- ))
- (sb-c::constant
- (values :constant nil
- `((type . ,type)) ; XXX ignore
- )))))
- (cons (values :symbol-macro t
- nil ; FIXME: also in the compiler
- ))
- (null (values (ecase (info :variable :kind var)
- (:special :special)
- (:constant :constant)
- (:macro :symbol-macro)
- (:global nil))
- nil
- `( ; XXX ignore
- (type . ,(sb-kernel:type-specifier ; XXX local type
- (info :variable :type var)))))))))
-
-(defun parse-macro (name lambda-list body
- &optional env)
+(defun variable-information (name &optional env)
+ "Return information about the variable name VAR in the lexical environment ENV.
+Note that the global binding may differ from the local one.
+
+This function returns three values. The first indicated the type of the variable
+binding:
+
+ NIL
+ There is no apparent binding for NAME.
+
+ :SPECIAL
+ NAME refers to a special variable.
+
+ :LEXICAL
+ NAME refers to a lexical variable.
+
+ :SYMBOL-MACRO
+ NAME refers to a symbol macro.
+
+ :CONSTANT
+ NAME refers to a named constant defined using DEFCONSTANT, or NAME
+ is a keyword.
+
+ :GLOBAL
+ NAME refers to a global variable. (SBCL specific extension.)
+
+The second value is true if NAME is bound locally. This is currently
+always NIL for special variables, although arguably it should be T
+when there is a lexically apparent binding for the special variable.
+
+The third value is an alist describind the declarations that apply to
+the function NAME. Standard declaration specifiers that may appear in
+CARS of the alist include:
+
+ DYNAMIC-EXTENT
+ If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
+ is NIL, the alist element may be omitted.
+
+ IGNORE
+ If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
+ the alist element may be omitted.
+
+ TYPE
+ The CDR is the type specifier associated with NAME, or the symbol
+ T if there is explicit type declaration or proclamation associated
+ with NAME. The type specifier may be equivalent to or a supertype
+ of the original declaration. If the CDR is T the alist element may
+ be omitted.
+
+Additionally, the SBCL specific SB-EXT:ALWAYS-BOUND declaration will
+appear with CDR as T if the variable has been declared always bound."
+ (let* ((*lexenv* (or env (make-null-lexenv)))
+ (kind (info :variable :kind name))
+ (var (lexenv-find name vars))
+ binding localp dx ignorep type)
+ (etypecase var
+ (sb-c::leaf
+ (let ((env-type (or (lexenv-find var type-restrictions)
+ *universal-type*)))
+ (setf type (if (eq :declared (sb-c::leaf-where-from var))
+ (type-intersection (sb-c::leaf-type var)
+ env-type)
+ env-type)
+ dx (sb-c::leaf-dynamic-extent var)))
+ (etypecase var
+ (sb-c::lambda-var
+ (setf binding :lexical
+ localp t
+ ignorep (sb-c::lambda-var-ignorep var)))
+ ;; FIXME: IGNORE doesn't make sense for specials or constants
+ ;; -- though it is _possible_ to declare them ignored, but
+ ;; we don't keep the information around.
+ (sb-c::global-var
+ (setf binding (if (eq :global kind)
+ :global
+ :special)
+ ;; FIXME: Lexically apparent binding or not for specials?
+ localp nil))
+ (sb-c::constant
+ (setf binding :constant
+ localp nil))))
+ (cons
+ (setf binding :symbol-macro
+ localp t))
+ (null
+ (let ((global-type (info :variable :type name)))
+ (setf binding (case kind
+ (:macro :symbol-macro)
+ (:unknown nil)
+ (t kind))
+ type (if (eq *universal-type* global-type)
+ nil
+ global-type)
+ localp nil))))
+ (values binding
+ localp
+ (let (alist)
+ (when ignorep (push (cons 'ignore t) alist))
+ (when (and type (neq *universal-type* type))
+ (push (cons 'type (type-specifier type)) alist))
+ (when dx (push (cons 'dynamic-extent t) alist))
+ (when (info :variable :always-bound name)
+ (push (cons 'sb-ext:always-bound t) alist))
+ alist))))
+
+(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)