1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; The software is in the public domain and is provided with
5 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
11 declaration-information
17 (declaim (ftype (sfunction (symbol &optional (or null lexenv))
18 (values (member nil :function :macro :special-form)
21 function-information))
22 (defun function-information (name &optional env)
23 "Return information about the function NAME in the lexical environment ENV.
24 Note that the global function binding may differ from the local one.
26 This function returns three values. The first indicates the type of
27 function definition or binding:
30 There is no apparent definition for NAME.
33 NAME refers to a function.
36 NAME refers to a macro.
39 NAME refers to a special operator. If the name refers to both a
40 macro and a special operator, the macro takes precedence.
42 The second value is true if NAME is bound locally.
44 The third value is an alist describing the declarations that apply to
45 the function NAME. Standard declaration specifiers that may appear in
46 CARS of the alist include:
49 If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
50 is NIL, the alist element may be omitted.
53 The CDR is one of the symbols INLINE, NOTINLINE, or NIL, to
54 indicate if the function has been declared INLINE or NOTINLINE. If
55 the CDR is NIL the alist element may be omitted.
58 The CDR is the type specifier associated with NAME, or the symbol
59 FUNCTION if there is functional type declaration or proclamation
60 associated with NAME. If the CDR is FUNCTION the alist element may
62 (let* ((*lexenv* (or env (make-null-lexenv)))
63 (fun (lexenv-find name funs))
64 binding localp ftype dx inlinep)
67 (let ((env-type (or (lexenv-find fun type-restrictions)
68 *universal-fun-type*)))
69 (setf binding :function
70 ftype (if (eq :declared (sb-c::leaf-where-from fun))
71 (type-intersection (sb-c::leaf-type fun)
74 dx (sb-c::leaf-dynamic-extent fun))
78 inlinep (sb-c::functional-inlinep fun)))
80 ;; Inlined known functions.
82 inlinep (sb-c::defined-fun-inlinep fun))))))
87 (case (info :function :kind name)
92 (setf binding :special-form
95 (setf binding :function
97 ftype (when (eq :declared (info :function :where-from name))
98 (info :function :type name))
99 inlinep (info :function :inlinep name))))))
103 (when (and ftype (neq *universal-fun-type* ftype))
104 (push (cons 'ftype (type-specifier ftype)) alist))
106 ((:inline :maybe-inline) (push (cons 'inline 'inline) alist))
107 (:notinline (push (cons 'inline 'notinline) alist))
109 (when dx (push (cons 'dynamic-extent t) alist))
112 (declaim (ftype (sfunction
113 (symbol &optional (or null lexenv))
114 (values (member nil :special :lexical :symbol-macro :constant :global)
117 variable-information))
118 (defun variable-information (name &optional env)
119 "Return information about the variable name VAR in the lexical environment ENV.
120 Note that the global binding may differ from the local one.
122 This function returns three values. The first indicated the type of the variable
126 There is no apparent binding for NAME.
129 NAME refers to a special variable.
132 NAME refers to a lexical variable.
135 NAME refers to a symbol macro.
138 NAME refers to a named constant defined using DEFCONSTANT, or NAME
142 NAME refers to a global variable. (SBCL specific extension.)
144 The second value is true if NAME is bound locally. This is currently
145 always NIL for special variables, although arguably it should be T
146 when there is a lexically apparent binding for the special variable.
148 The third value is an alist describind the declarations that apply to
149 the function NAME. Standard declaration specifiers that may appear in
150 CARS of the alist include:
153 If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
154 is NIL, the alist element may be omitted.
157 If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
158 the alist element may be omitted.
161 The CDR is the type specifier associated with NAME, or the symbol
162 T if there is explicit type declaration or proclamation associated
163 with NAME. The type specifier may be equivalent to or a supertype
164 of the original declaration. If the CDR is T the alist element may
167 Additionally, the SBCL specific SB-EXT:ALWAYS-BOUND declaration will
168 appear with CDR as T if the variable has been declared always bound."
169 (let* ((*lexenv* (or env (make-null-lexenv)))
170 (kind (info :variable :kind name))
171 (var (lexenv-find name vars))
172 binding localp dx ignorep type)
175 (let ((env-type (or (lexenv-find var type-restrictions)
177 (setf type (if (eq :declared (sb-c::leaf-where-from var))
178 (type-intersection (sb-c::leaf-type var)
181 dx (sb-c::leaf-dynamic-extent var)))
184 (setf binding :lexical
186 ignorep (sb-c::lambda-var-ignorep var)))
187 ;; FIXME: IGNORE doesn't make sense for specials or constants
188 ;; -- though it is _possible_ to declare them ignored, but
189 ;; we don't keep the information around.
191 (setf binding (if (eq :global kind)
194 ;; FIXME: Lexically apparent binding or not for specials?
197 (setf binding :constant
200 (setf binding :symbol-macro
203 (let ((global-type (info :variable :type name)))
204 (setf binding (case kind
205 (:macro :symbol-macro)
208 type (if (eq *universal-type* global-type)
215 (when ignorep (push (cons 'ignore t) alist))
216 (when (and type (neq *universal-type* type))
217 (push (cons 'type (type-specifier type)) alist))
218 (when dx (push (cons 'dynamic-extent t) alist))
219 (when (info :variable :always-bound name)
220 (push (cons 'sb-ext:always-bound t) alist))
223 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
224 declaration-information))
225 (defun declaration-information (declaration-name &optional env)
226 (let ((env (or env (make-null-lexenv))))
227 (case declaration-name
229 (let ((policy (sb-c::lexenv-policy env)))
231 (dolist (name sb-c::*policy-qualities*)
232 (res (list name (cdr (assoc name policy)))))
233 (loop for (name . nil) in sb-c::*policy-dependent-qualities*
234 do (res (list name (sb-c::policy-quality policy name))))
236 (sb-ext:muffle-conditions
237 (car (rassoc 'muffle-warning
238 (sb-c::lexenv-handled-conditions env))))
239 (t (error "Unsupported declaration ~S." declaration-name)))))
241 (defun parse-macro (name lambda-list body &optional env)
242 (declare (ignore env))
243 (with-unique-names (whole environment)
244 (multiple-value-bind (body decls)
245 (parse-defmacro lambda-list whole body name
247 :environment environment)
248 `(lambda (,whole ,environment)
252 (defun enclose (lambda-expression &optional env)
254 (sb-c::make-restricted-lexenv env)
255 (make-null-lexenv))))
256 (compile-in-lexenv nil lambda-expression env)))