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
16 (defvar *null-lexenv* (make-null-lexenv))
18 (defun augment-environment
19 (env &key variable symbol-macro function macro declare)
20 "Create a new lexical environment by augmenting ENV with new information.
23 is a list of symbols to introduce as new variable bindings.
26 is a list symbol macro bindings of the form (name definition).
29 is a list of macro definitions of the form (name definition), where
30 definition is a function of two arguments (a form and an environment).
33 is a list of symbols to introduce as new local function bindings.
36 is a list of declaration specifiers. Declaration specifiers attach to the
37 new variable or function bindings as if they appeared in let, let*, flet
38 or labels form. For example:
40 (augment-environment env :variable '(x) :declare '((special x)))
44 (let (x) (declare (special x)) ....)
48 (augment-environment (augment-environment env :variable '(x))
49 :declare '((special x)))
53 (let (x) (locally (declare (special x))) ...)
57 (unless (or variable symbol-macro function macro declare)
58 (return-from augment-environment env))
61 (setq env (make-null-lexenv))
62 (setq env (copy-structure env)))
64 ;; a null policy is used to identify a null lexenv
65 (when (sb-c::null-lexenv-p env)
66 (setf (sb-c::lexenv-%policy env) sb-c::*policy*))
69 (setf (sb-c::lexenv-funs env)
71 (loop for (name def) in macro
72 collect (cons name (cons 'sb-sys::macro def)))
73 (sb-c::lexenv-funs env))))
76 (setf (sb-c::lexenv-vars env)
78 (loop for (name def) in symbol-macro
79 collect (cons name (cons 'sb-sys::macro def)))
80 (sb-c::lexenv-vars env))))
82 (dolist (name variable)
83 (lvars (sb-c::make-lambda-var :%source-name name)))
85 (dolist (name function)
90 :allow-instrumenting nil)))
93 ;; process-decls looks in *lexenv* policy to decide what warnings to print
94 (let ((*lexenv* *null-lexenv*))
95 (setq env (sb-c::process-decls
96 (list `(declare ,@declare))
97 (lvars) (clambdas) :lexenv env :context nil))))
100 (setf (sb-c::lexenv-funs env)
102 (loop for name in function for lambda in (clambdas)
103 collect (cons name lambda))
104 (sb-c::lexenv-funs env))))
107 (setf (sb-c::lexenv-vars env)
109 (loop for name in variable for lvar in (lvars)
112 ;; if one of the lvars is declared special then process-decls
113 ;; will set it's specvar.
114 (if (sb-c::lambda-var-specvar lvar)
115 (sb-c::lambda-var-specvar lvar)
117 (sb-c::lexenv-vars env))))
121 (declaim (ftype (sfunction (symbol &optional (or null lexenv))
122 (values (member nil :function :macro :special-form)
125 function-information))
126 (defun function-information (name &optional env)
127 "Return information about the function NAME in the lexical environment ENV.
128 Note that the global function binding may differ from the local one.
130 This function returns three values. The first indicates the type of
131 function definition or binding:
134 There is no apparent definition for NAME.
137 NAME refers to a function.
140 NAME refers to a macro.
143 NAME refers to a special operator. If the name refers to both a
144 macro and a special operator, the macro takes precedence.
146 The second value is true if NAME is bound locally.
148 The third value is an alist describing 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 The CDR is one of the symbols INLINE, NOTINLINE, or NIL, to
158 indicate if the function has been declared INLINE or NOTINLINE. If
159 the CDR is NIL the alist element may be omitted.
162 The CDR is the type specifier associated with NAME, or the symbol
163 FUNCTION if there is functional type declaration or proclamation
164 associated with NAME. If the CDR is FUNCTION the alist element may
166 (let* ((*lexenv* (or env (make-null-lexenv)))
167 (fun (lexenv-find name funs))
168 binding localp ftype dx inlinep)
171 (let ((env-type (or (lexenv-find fun type-restrictions)
172 *universal-fun-type*)))
173 (setf binding :function
174 ftype (type-intersection (sb-c::leaf-type fun) env-type)
175 dx (sb-c::leaf-dynamic-extent fun))
179 inlinep (sb-c::functional-inlinep fun)))
181 ;; Inlined known functions.
183 inlinep (sb-c::defined-fun-inlinep fun))))))
188 (case (info :function :kind name)
193 (setf binding :special-form
196 (setf binding :function
198 ftype (when (eq :declared (info :function :where-from name))
199 (info :function :type name))
200 inlinep (info :function :inlinep name))))))
204 (when (and ftype (neq *universal-fun-type* ftype))
205 (push (cons 'ftype (type-specifier ftype)) alist))
207 ((:inline :maybe-inline) (push (cons 'inline 'inline) alist))
208 (:notinline (push (cons 'inline 'notinline) alist))
210 (when dx (push (cons 'dynamic-extent t) alist))
213 (declaim (ftype (sfunction
214 (symbol &optional (or null lexenv))
215 (values (member nil :special :lexical :symbol-macro :constant :global)
218 variable-information))
219 (defun variable-information (name &optional env)
220 "Return information about the variable name VAR in the lexical environment ENV.
221 Note that the global binding may differ from the local one.
223 This function returns three values. The first indicated the type of the variable
227 There is no apparent binding for NAME.
230 NAME refers to a special variable.
233 NAME refers to a lexical variable.
236 NAME refers to a symbol macro.
239 NAME refers to a named constant defined using DEFCONSTANT, or NAME
243 NAME refers to a global variable. (SBCL specific extension.)
245 The second value is true if NAME is bound locally. This is currently
246 always NIL for special variables, although arguably it should be T
247 when there is a lexically apparent binding for the special variable.
249 The third value is an alist describind the declarations that apply to
250 the function NAME. Standard declaration specifiers that may appear in
251 CARS of the alist include:
254 If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
255 is NIL, the alist element may be omitted.
258 If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
259 the alist element may be omitted.
262 The CDR is the type specifier associated with NAME, or the symbol
263 T if there is explicit type declaration or proclamation associated
264 with NAME. The type specifier may be equivalent to or a supertype
265 of the original declaration. If the CDR is T the alist element may
268 Additionally, the SBCL specific SB-EXT:ALWAYS-BOUND declaration will
269 appear with CDR as T if the variable has been declared always bound."
270 (let* ((*lexenv* (or env (make-null-lexenv)))
271 (kind (info :variable :kind name))
272 (var (lexenv-find name vars))
273 binding localp dx ignorep type)
276 (let ((env-type (or (lexenv-find var type-restrictions)
278 (setf type (type-intersection (sb-c::leaf-type var) env-type)
279 dx (sb-c::leaf-dynamic-extent var)))
282 (setf binding :lexical
284 ignorep (sb-c::lambda-var-ignorep var)))
285 ;; FIXME: IGNORE doesn't make sense for specials or constants
286 ;; -- though it is _possible_ to declare them ignored, but
287 ;; we don't keep the information around.
289 (setf binding (if (eq :global kind)
292 ;; FIXME: Lexically apparent binding or not for specials?
295 (setf binding :constant
298 (setf binding :symbol-macro
301 (let ((global-type (info :variable :type name)))
302 (setf binding (case kind
303 (:macro :symbol-macro)
306 type (if (eq *universal-type* global-type)
313 (when ignorep (push (cons 'ignore t) alist))
314 (when (and type (neq *universal-type* type))
315 (push (cons 'type (type-specifier type)) alist))
316 (when dx (push (cons 'dynamic-extent t) alist))
317 (when (info :variable :always-bound name)
318 (push (cons 'sb-ext:always-bound t) alist))
321 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
322 declaration-information))
323 (defun declaration-information (declaration-name &optional env)
324 "Return information about declarations named by DECLARATION-NAME.
326 If DECLARATION-NAME is OPTIMIZE return a list who's entries are of the
327 form \(QUALITY VALUE).
329 If DECLARATION-NAME is DECLARATION return a list of declaration names that
330 have been proclaimed as valid.
332 If DECLARATION-NAME is SB-EXT:MUFFLE-CONDITIONS return a type specifier for
333 the condition types that have been muffled."
334 (let ((env (or env (make-null-lexenv))))
335 (case declaration-name
337 (let ((policy (sb-c::lexenv-policy env)))
339 (dolist (name sb-c::*policy-qualities*)
340 (res (list name (cdr (assoc name policy)))))
341 (loop for (name . nil) in sb-c::*policy-dependent-qualities*
342 do (res (list name (sb-c::policy-quality policy name))))
344 (sb-ext:muffle-conditions
345 (car (rassoc 'muffle-warning
346 (sb-c::lexenv-handled-conditions env))))
348 ;; FIXME: This is a bit too deep in the guts of INFO for comfort...
349 (let ((type (sb-c::type-info-number
350 (sb-c::type-info-or-lose :declaration :recognized)))
352 (dolist (env *info-environment*)
353 (do-info (env :name name :type-number num :value value)
354 (when (and (= num type) value)
357 (t (error "Unsupported declaration ~S." declaration-name)))))
359 (defun parse-macro (name lambda-list body &optional env)
360 "Process a macro definition of the kind that might appear in a DEFMACRO form
361 into a lambda expression of two variables: a form and an environment. The
362 lambda edxpression will parse its form argument, binding the variables in
363 LAMBDA-LIST appropriately, and then excute BODY with those bindings in
365 (declare (ignore env))
366 (with-unique-names (whole environment)
367 (multiple-value-bind (body decls)
368 (parse-defmacro lambda-list whole body name
370 :environment environment)
371 `(lambda (,whole ,environment)
375 (defun enclose (lambda-expression &optional environment)
376 "Return a function consistent with LAMBDA-EXPRESSION in ENVIRONMENT: the
377 lambda expression is allowed to reference the declarations and macro
378 definitions in ENVIRONMENT, but consequences are undefined if lexical
379 variables, functions, tags or any other run-time entity defined in ENVIRONMENT
380 is referred to by the expression."
381 (let ((env (if environment
382 (sb-c::make-restricted-lexenv environment)
383 (make-null-lexenv))))
384 (compile-in-lexenv nil lambda-expression env)))