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
15 (defvar *null-lexenv
* (make-null-lexenv))
17 (defun augment-environment
18 (env &key variable symbol-macro function macro declare
)
19 "Create a new lexical environment by augmenting ENV with new information.
22 is a list of symbols to introduce as new variable bindings.
25 is a list symbol macro bindings of the form (name definition).
28 is a list of macro definitions of the form (name definition), where
29 definition is a function of two arguments (a form and an environment).
32 is a list of symbols to introduce as new local function bindings.
35 is a list of declaration specifiers. Declaration specifiers attach to the
36 new variable or function bindings as if they appeared in let, let*, flet
37 or labels form. For example:
39 (augment-environment env :variable '(x) :declare '((special x)))
43 (let (x) (declare (special x)) ....)
47 (augment-environment (augment-environment env :variable '(x))
48 :declare '((special x)))
52 (let (x) (locally (declare (special x))) ...)
54 (setq env
(copy-structure (sb-c::coerce-to-lexenv env
)))
57 (unless (or variable symbol-macro function macro declare
)
58 (return-from augment-environment env
))
60 ;; a null policy is used to identify a null lexenv
61 (when (sb-c::null-lexenv-p env
)
62 (setf (sb-c::lexenv-%policy env
) sb-c
::*policy
*))
65 (setf (sb-c::lexenv-funs env
)
67 (loop for
(name def
) in macro
68 collect
(cons name
(cons 'sb-sys
::macro def
)))
69 (sb-c::lexenv-funs env
))))
72 (setf (sb-c::lexenv-vars env
)
74 (loop for
(name def
) in symbol-macro
75 collect
(cons name
(cons 'sb-sys
::macro def
)))
76 (sb-c::lexenv-vars env
))))
78 (dolist (name variable
)
79 (lvars (sb-c::make-lambda-var
:%source-name name
)))
81 (dolist (name function
)
86 :allow-instrumenting nil
)))
89 ;; process-decls looks in *lexenv* policy to decide what warnings to print
90 (let ((*lexenv
* *null-lexenv
*))
91 (setq env
(sb-c::process-decls
92 (list `(declare ,@declare
))
93 (lvars) (clambdas) :lexenv env
:context nil
))))
96 (setf (sb-c::lexenv-funs env
)
98 (loop for name in function for lambda in
(clambdas)
99 collect
(cons name lambda
))
100 (sb-c::lexenv-funs env
))))
103 (setf (sb-c::lexenv-vars env
)
105 (loop for name in variable for lvar in
(lvars)
108 ;; If one of the lvars is declared special then
109 ;; process-decls will set it's specvar.
110 (if (sb-c::lambda-var-specvar lvar
)
111 (sb-c::lambda-var-specvar lvar
)
113 (sb-c::lexenv-vars env
))))
117 ;;; Retrieve the user-supplied (from define-declaration) pairs for a
118 ;;; function or a variable from a lexical environment.
120 ;;; KEYWORD should be :function or :variable, VAR should be a
121 ;;; function or variable name, respectively.
122 (defun extra-pairs (keyword var binding env
)
125 (dolist (entry (sb-c::lexenv-user-data env
))
127 (entry-keyword entry-var entry-binding
&rest entry-cons
)
129 (when (and (eq keyword entry-keyword
)
132 (and (eq var entry-var
)
133 (typecase entry-binding
136 (sb-c::lambda-var-specvar entry-binding
))
140 (eq binding entry-binding
))))
141 (push entry-cons ret
))))
144 (defun maybe-deprecation-entry (info)
146 (with-accessors ((state sb-int
:deprecation-info-state
)
147 (software sb-int
:deprecation-info-software
)
148 (version sb-int
:deprecation-info-version
)
149 (replacements sb-int
:deprecation-info-replacements
))
151 (list (cons 'sb-ext
:deprecated
153 :since
(list software version
)
154 :replacements replacements
))))))
156 ;;; Retrieve the user-supplied (from define-declaration) value for
157 ;;; the declaration with the given NAME
158 (defun extra-decl-info (name env
)
160 (dolist (entry (sb-c::lexenv-user-data env
))
161 (when (and (eq :declare
(car entry
))
162 (eq name
(cadr entry
)))
163 (return-from extra-decl-info
(cddr entry
))))
167 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
168 (defmacro list-cons-when
(test car cdr
)
170 (list (cons ,car
,cdr
)))))
172 (declaim (ftype (sfunction ((or symbol cons
) &optional lexenv-designator
)
173 (values (member nil
:function
:macro
:special-form
)
176 function-information
))
177 (defun function-information (name &optional env
)
178 "Return information about the function NAME in the lexical environment ENV.
179 Note that the global function binding may differ from the local one.
181 This function returns three values. The first indicates the type of
182 function definition or binding:
185 There is no apparent definition for NAME.
188 NAME refers to a function.
191 NAME refers to a macro.
194 NAME refers to a special operator. If the name refers to both a
195 macro and a special operator, the macro takes precedence.
197 The second value is true if NAME is bound locally.
199 The third value is an alist describing the declarations that apply to
200 the function NAME. Standard declaration specifiers that may appear in
201 CARS of the alist include:
204 If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
205 is NIL, the alist element may be omitted.
208 The CDR is one of the symbols INLINE, NOTINLINE, or NIL, to
209 indicate if the function has been declared INLINE or NOTINLINE. If
210 the CDR is NIL the alist element may be omitted.
213 The CDR is the type specifier associated with NAME, or the symbol
214 FUNCTION if there is functional type declaration or proclamation
215 associated with NAME. If the CDR is FUNCTION the alist element may
220 The CDR is a plist containing the following properties
222 :STATE ( :EARLY | :LATE | :FINAL )
223 Use of :EARLY deprecated functions signals a STYLE-WARNING at
226 Use of :LATE deprecated functions signals a full WARNING at
229 Use of :FINAL deprecated functions signals a full WARNING at
230 compile-time and an error at runtime.
232 :SINCE (SOFTWARE VERSION)
233 VERSION is a string designating the version since which the
234 function has been deprecated. SOFTWARE is NIL or the name of
235 the software to which VERSION refers, e.g. \"SBCL\" for
236 deprecated functions in SBCL.
238 :REPLACEMENTS REPLACEMENTS
239 When this property is present, REPLACEMENTS is a list of
240 symbols naming functions that should be used instead of the
243 In addition to these declarations defined using DEFINE-DECLARATION may
248 (sb-interpreter:basic-env
(sb-interpreter::lexenv-from-env env
))
249 (null (make-null-lexenv))
251 (fun (lexenv-find name funs
))
252 binding localp ftype dx inlinep
)
255 (let ((env-type (or (lexenv-find fun type-restrictions
)
256 *universal-fun-type
*)))
257 (setf binding
:function
258 ftype
(type-intersection (sb-c::leaf-type fun
) env-type
)
259 dx
(sb-c::leaf-dynamic-extent fun
))
263 inlinep
(sb-c::functional-inlinep fun
)))
265 ;; Inlined known functions.
267 inlinep
(sb-c::defined-fun-inlinep fun
))))))
272 ;; FIXME: we document above that :MACRO trumps :SPECIAL-FORM
273 ;; but that is clearly untrue.
274 (case (info :function
:kind name
)
279 (setf binding
:special-form
282 (setf binding
:function
284 ftype
(when (eq :declared
(info :function
:where-from name
))
285 (proclaimed-ftype name
))
286 inlinep
(info :function
:inlinep name
))))))
289 (nconc (ecase inlinep
290 ((:inline
:maybe-inline
)
291 (list '(inline . inline
)))
293 (list '(inline . notinline
)))
295 (list-cons-when (and ftype
(neq *universal-fun-type
* ftype
))
296 'ftype
(type-specifier ftype
))
297 (list-cons-when dx
'dynamic-extent t
)
299 (maybe-deprecation-entry
300 (info :function
:deprecated name
)))
301 (extra-pairs :function name fun
*lexenv
*)))))
303 (declaim (ftype (sfunction
304 (symbol &optional lexenv-designator
)
305 (values (member nil
:special
:lexical
:symbol-macro
:constant
:global
:alien
)
308 variable-information
))
309 (defun variable-information (name &optional env
)
310 "Return information about the variable name VAR in the lexical environment ENV.
311 Note that the global binding may differ from the local one.
313 This function returns three values. The first indicated the type of the variable
317 There is no apparent binding for NAME.
320 NAME refers to a special variable.
323 NAME refers to a lexical variable.
326 NAME refers to a symbol macro.
329 NAME refers to a named constant defined using DEFCONSTANT, or NAME
333 NAME refers to a global variable. (SBCL specific extension.)
336 NAME refers to an alien variable. (SBCL specific extension.)
338 The second value is true if NAME is bound locally. This is currently
339 always NIL for special variables, although arguably it should be T
340 when there is a lexically apparent binding for the special variable.
342 The third value is an alist describing the declarations that apply to
343 the function NAME. Standard declaration specifiers that may appear in
344 CARS of the alist include:
347 If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
348 is NIL, the alist element may be omitted.
351 If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
352 the alist element may be omitted.
355 The CDR is the type specifier associated with NAME, or the symbol
356 T if there is explicit type declaration or proclamation associated
357 with NAME. The type specifier may be equivalent to or a supertype
358 of the original declaration. If the CDR is T the alist element may
363 If CDR is T, NAME has been declared as SB-EXT:ALWAYS-BOUND
367 The CDR is a plist containing the following properties
369 :STATE ( :EARLY | :LATE | :FINAL )
370 Use of :EARLY deprecated variables signals a STYLE-WARNING at
373 Use of :LATE deprecated variables signals a full WARNING at
376 Use of :FINAL deprecated variables signals a full WARNING at
377 compile-time and an error at runtime.
379 :SINCE (SOFTWARE VERSION)
380 VERSION is a string designating the version since which the
381 variable has been deprecated. SOFTWARE is NIL or the name of
382 the software to which VERSION refers, e.g. \"SBCL\" for
383 deprecated variables in SBCL.
385 :REPLACEMENTS REPLACEMENTS
386 When this property is present, REPLACEMENTS is a list of
387 symbols naming variables that should be used instead of the
390 In addition to these declarations defined using DEFINE-DECLARATION may
392 (let* ((*lexenv
* (sb-c::coerce-to-lexenv env
))
393 (kind (info :variable
:kind name
))
394 (var (lexenv-find name vars
))
395 binding localp dx ignorep type
)
398 (let ((env-type (or (lexenv-find var type-restrictions
)
400 (setf type
(type-intersection (sb-c::leaf-type var
) env-type
)
401 dx
(sb-c::leaf-dynamic-extent var
)))
404 (setf binding
:lexical
406 ignorep
(sb-c::lambda-var-ignorep var
)))
407 ;; FIXME: IGNORE doesn't make sense for specials or constants
408 ;; -- though it is _possible_ to declare them ignored, but
409 ;; we don't keep the information around.
411 (setf binding
(if (eq :global kind
)
414 ;; FIXME: Lexically apparent binding or not for specials?
417 (setf binding
:constant
420 (setf binding
:symbol-macro
423 (let ((global-type (info :variable
:type name
)))
424 (setf binding
(case kind
425 (:macro
:symbol-macro
)
428 type
(if (eq *universal-type
* global-type
)
434 (nconc (list-cons-when ignorep
'ignore t
)
435 (list-cons-when (and type
(neq *universal-type
* type
))
436 'type
(type-specifier type
))
437 (list-cons-when dx
'dynamic-extent t
)
438 (list-cons-when (info :variable
:always-bound name
)
439 'sb-ext
:always-bound t
)
440 (maybe-deprecation-entry
441 (info :variable
:deprecated name
))
442 (extra-pairs :variable name var
*lexenv
*)))))
444 ;;; Unlike policy-related declarations which the interpeter itself needs
445 ;;; for correct operation of some macros, muffled conditions are irrelevant,
446 ;;; since warnings are not signaled much, if at all.
447 ;;; This is even more useless than env-package-locks.
448 ;;; It's only for SB-CLTL2, and not tested in the least.
450 (defun compute-handled-conditions (env)
451 (named-let recurse
((env env
))
452 (let ((result (acond ((sb-interpreter::env-parent env
)
453 (compute-handled-conditions it
))
454 (t sb-c
::*handled-conditions
*))))
455 (sb-interpreter::do-decl-spec
456 (declaration (sb-interpreter::env-declarations env
) result
)
457 (let ((f (case (car declaration
)
458 (sb-ext:muffle-conditions
459 #'sb-c
::process-muffle-conditions-decl
)
460 (sb-ext:unmuffle-conditions
461 #'sb-c
::process-unmuffle-conditions-decl
))))
463 (setq result
(funcall f declaration result
))))))))
465 (declaim (ftype (sfunction (symbol &optional lexenv-designator
) t
)
466 declaration-information
))
467 (defun declaration-information (declaration-name &optional env
)
468 "Return information about declarations named by DECLARATION-NAME.
470 If DECLARATION-NAME is OPTIMIZE return a list who's entries are of the
471 form \(QUALITY VALUE).
473 If DECLARATION-NAME is DECLARATION return a list of declaration names that
474 have been proclaimed as valid.
476 If DECLARATION-NAME is a name that has defined via DEFINE-DECLARATION return a
479 If DECLARATION-NAME is SB-EXT:MUFFLE-CONDITIONS return a type specifier for
480 the condition types that have been muffled."
481 (let ((env (or env
(make-null-lexenv))))
482 (case declaration-name
484 ;; CLtL2-mandated behavior:
485 ;; "The returned list always contains an entry for each of the standard
486 ;; qualities and for each of the implementation-specific qualities"
487 (sb-c::policy-to-decl-spec
490 (sb-interpreter:basic-env
(sb-interpreter:env-policy env
))
491 (t (sb-c::lexenv-policy env
)))
493 (sb-ext:muffle-conditions
494 (let ((handled-conditions
497 (sb-interpreter:basic-env
(compute-handled-conditions env
))
498 (t (sb-c::lexenv-handled-conditions env
)))))
499 (sb-int:awhen
(car (rassoc 'muffle-warning handled-conditions
))
500 (sb-kernel:type-specifier it
))))
502 (copy-list sb-c
::*recognized-declarations
*))
503 (t (if (info :declaration
:handler declaration-name
)
508 (sb-interpreter:basic-env
(sb-interpreter::lexenv-from-env env
))
510 (error "Unsupported declaration ~S." declaration-name
))))))
513 (defun parse-macro (name lambda-list body
&optional env
)
514 "Process a macro definition of the kind that might appear in a DEFMACRO form
515 into a lambda expression of two variables: a form and an environment. The
516 lambda expression will parse its form argument, binding the variables in
517 LAMBDA-LIST appropriately, and then execute BODY with those bindings in
519 (declare (ignore env
))
521 ;; lp#1545148 says that some people don't like NAMED-LAMBDA,
522 ;; so pass NIL instead of a name.
523 (make-macro-lambda nil
; (if (and name (symbolp name)) (string name) "PARSE-MACRO")
524 lambda-list body
'parse-macro name
)))
526 (defun enclose (lambda-expression &optional environment
)
527 "Return a function consistent with LAMBDA-EXPRESSION in ENVIRONMENT: the
528 lambda expression is allowed to reference the declarations and macro
529 definitions in ENVIRONMENT, but consequences are undefined if lexical
530 variables, functions, tags or any other run-time entity defined in ENVIRONMENT
531 is referred to by the expression."
532 (let ((env (if environment
533 (sb-c::make-restricted-lexenv environment
)
534 (make-null-lexenv))))
535 (compile-in-lexenv nil lambda-expression env
)))
537 ;;; Add a bit of user-data to a lexenv.
539 ;;; If KIND is :declare then DATA should be of the form
540 ;;; (declaration-name . value)
541 ;;; If KIND is :variable then DATA should be of the form
542 ;;; (variable-name key value)
543 ;;; If KIND is :function then DATA should be of the form
544 ;;; (function-name key value)
546 ;;; PD-VARS and PD-FVARS are are the vars and fvars arguments
547 ;;; of the process-decls call that called this function.
548 (defun update-lexenv-user-data (env kind data pd-vars pd-fvars
)
549 (let ((user-data (sb-c::lexenv-user-data env
)))
550 ;; user-data looks like this:
551 ;; ((:declare d . value)
552 ;; (:variable var binding key . value)
553 ;; (:function var binding key . value))
554 (let ((*lexenv
* env
))
558 for
(name key value
) in data
559 for binding1
= (sb-c::find-in-bindings pd-vars name
)
560 for binding
= (if binding1 binding1
(lexenv-find name vars
))
561 do
(push (list* :variable name binding key value
) user-data
)))
564 for
(name key value
) in data
565 for binding1
= (find name pd-fvars
:key
#'sb-c
::leaf-source-name
:test
#'equal
)
566 for binding
= (if binding1 binding1
(lexenv-find name funs
))
567 do
(push (list* :function name binding key value
) user-data
)))
569 (destructuring-bind (decl-name . value
) data
570 (push (list* :declare decl-name value
) user-data
)))))
571 (sb-c::make-lexenv
:default env
:user-data user-data
)))
573 (defmacro define-declaration
(decl-name lambda-list
&body body
)
574 "Define a handler for declaration specifiers starting with DECL-NAME.
576 The function defined by this macro is called with two arguments: a declaration
577 specifier and a environment. It must return two values. The first value must
578 be :VARIABLE, :FUNCTION, or :DECLARE.
580 If the first value is :VARIABLE or :FUNCTION then the second value should be a
581 list of elements of the form (BINDING-NAME KEY VALUE). conses (KEY . VALUE)
582 will be added to the alist returned by:
584 (function-information binding-name env)
588 (variable-information binding-name env)
590 If the first value is :DECLARE then the second value should be a
591 cons (DECL-NAME . VALUE). VALUE will be returned by:
593 (declaration-information decl-name env)
595 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
596 (proclaim '(declaration ,decl-name
))
597 (flet ((func ,lambda-list
600 (info :declaration
:handler
',decl-name
)
601 (lambda (lexenv spec pd-vars pd-fvars
)
602 (multiple-value-bind (kind data
) (func spec lexenv
)
603 (update-lexenv-user-data lexenv kind data pd-vars pd-fvars
)))))))