Tighter floating-point type constraints in some cases
[sbcl.git] / contrib / sb-cltl2 / env.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; The software is in the public domain and is provided with
5 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
6 ;;;; more information.
7
8 (in-package :sb-cltl2)
9
10 #| TODO:
11 (map-environment)
12 |#
13
14
15 (defvar *null-lexenv* (make-null-lexenv))
16
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.
20
21    VARIABLE
22      is a list of symbols to introduce as new variable bindings.
23
24    SYMBOL-MACRO
25      is a list symbol macro bindings of the form (name definition).
26
27    MACRO
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).
30
31    FUNCTION
32      is a list of symbols to introduce as new local function bindings.
33
34    DECLARE
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:
38
39       (augment-environment env :variable '(x) :declare '((special x)))
40
41      is like
42
43       (let (x) (declare (special x)) ....)
44
45      but
46
47       (augment-environment (augment-environment env :variable '(x))
48                            :declare '((special x)))
49
50      is like
51
52        (let (x) (locally (declare (special x))) ...)
53 "
54   (collect ((lvars)
55             (clambdas))
56     (unless (or variable symbol-macro function macro declare)
57       (return-from augment-environment env))
58
59     (if (null env)
60         (setq env (make-null-lexenv))
61         (setq env (copy-structure env)))
62
63     ;; a null policy is used to identify a null lexenv
64     (when (sb-c::null-lexenv-p env)
65       (setf (sb-c::lexenv-%policy env) sb-c::*policy*))
66
67     (when macro
68       (setf (sb-c::lexenv-funs env)
69             (nconc
70              (loop for (name def) in macro
71                 collect (cons name (cons 'sb-sys::macro def)))
72              (sb-c::lexenv-funs env))))
73
74     (when symbol-macro
75       (setf (sb-c::lexenv-vars env)
76             (nconc
77              (loop for (name def) in symbol-macro
78                 collect (cons name (cons 'sb-sys::macro def)))
79              (sb-c::lexenv-vars env))))
80
81     (dolist (name variable)
82       (lvars (sb-c::make-lambda-var :%source-name name)))
83
84     (dolist (name function)
85       (clambdas
86        (sb-c::make-lambda
87         :lexenv *null-lexenv*
88         :%source-name name
89         :allow-instrumenting nil)))
90
91     (when declare
92       ;; process-decls looks in *lexenv* policy to decide what warnings to print
93       (let ((*lexenv* *null-lexenv*))
94         (setq env (sb-c::process-decls
95                    (list `(declare ,@declare))
96                    (lvars) (clambdas) :lexenv env :context nil))))
97
98     (when function
99       (setf (sb-c::lexenv-funs env)
100             (nconc
101              (loop for name in function for lambda in (clambdas)
102                   collect (cons name lambda))
103              (sb-c::lexenv-funs env))))
104
105     (when variable
106       (setf (sb-c::lexenv-vars env)
107             (nconc
108              (loop for name in variable for lvar in (lvars)
109                 collect
110                 (cons name
111                       ;; If one of the lvars is declared special then
112                       ;; process-decls will set it's specvar.
113                       (if (sb-c::lambda-var-specvar lvar)
114                           (sb-c::lambda-var-specvar lvar)
115                           lvar)))
116              (sb-c::lexenv-vars env))))
117
118     env))
119
120 ;;; Retrieve the user-supplied (from define-declaration) pairs for a
121 ;;; function or a variable from a lexical environment.
122 ;;;
123 ;;; KEYWORD should be :function or :variable, VAR should be a
124 ;;; function or variable name, respectively.
125 (defun extra-pairs (keyword var binding env)
126   (when env
127     (let ((ret nil))
128       (dolist (entry (sb-c::lexenv-user-data env))
129         (destructuring-bind
130               (entry-keyword entry-var entry-binding &rest entry-cons)
131             entry
132           (when (and (eq keyword entry-keyword)
133                      (typecase binding
134                        (sb-c::global-var
135                         (and (eq var entry-var)
136                              (typecase entry-binding
137                                (sb-c::global-var t)
138                                (sb-c::lambda-var
139                                 (sb-c::lambda-var-specvar entry-binding))
140                                (null t)
141                                (t nil))))
142                        (t
143                         (eq binding entry-binding))))
144             (push entry-cons ret))))
145       (nreverse ret))))
146
147 ;;; Retrieve the user-supplied (from define-declaration) value for
148 ;;; the declaration with the given NAME
149 (defun extra-decl-info (name env)
150   (when env
151     (dolist (entry (sb-c::lexenv-user-data env))
152       (when (and (eq :declare (car entry))
153                  (eq name (cadr entry)))
154         (return-from extra-decl-info (cddr entry))))
155     nil))
156
157
158 (declaim (ftype (sfunction ((or symbol cons) &optional (or null lexenv))
159                            (values (member nil :function :macro :special-form)
160                                    boolean
161                                    list))
162                 function-information))
163 (defun function-information (name &optional env)
164   "Return information about the function NAME in the lexical environment ENV.
165 Note that the global function binding may differ from the local one.
166
167 This function returns three values. The first indicates the type of
168 function definition or binding:
169
170   NIL
171     There is no apparent definition for NAME.
172
173   :FUNCTION
174     NAME refers to a function.
175
176   :MACRO
177     NAME refers to a macro.
178
179   :SPECIAL-FORM
180     NAME refers to a special operator. If the name refers to both a
181     macro and a special operator, the macro takes precedence.
182
183 The second value is true if NAME is bound locally.
184
185 The third value is an alist describing the declarations that apply to
186 the function NAME. Standard declaration specifiers that may appear in
187 CARS of the alist include:
188
189   DYNAMIC-EXTENT
190     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
191     is NIL, the alist element may be omitted.
192
193   INLINE
194     The CDR is one of the symbols INLINE, NOTINLINE, or NIL, to
195     indicate if the function has been declared INLINE or NOTINLINE. If
196     the CDR is NIL the alist element may be omitted.
197
198   FTYPE
199     The CDR is the type specifier associated with NAME, or the symbol
200     FUNCTION if there is functional type declaration or proclamation
201     associated with NAME. If the CDR is FUNCTION the alist element may
202     be omitted.
203
204 In addition to these declarations defined using DEFINE-DECLARATION may
205 appear."
206   (let* ((*lexenv* (or env (make-null-lexenv)))
207          (fun (lexenv-find name funs))
208          binding localp ftype dx inlinep)
209     (etypecase fun
210       (sb-c::leaf
211        (let ((env-type (or (lexenv-find fun type-restrictions)
212                            *universal-fun-type*)))
213          (setf binding :function
214                ftype (type-intersection (sb-c::leaf-type fun) env-type)
215                dx (sb-c::leaf-dynamic-extent fun))
216          (etypecase fun
217            (sb-c::functional
218             (setf localp t
219                   inlinep (sb-c::functional-inlinep fun)))
220            (sb-c::defined-fun
221             ;; Inlined known functions.
222             (setf localp nil
223                   inlinep (sb-c::defined-fun-inlinep fun))))))
224       (cons
225        (setf binding :macro
226              localp t))
227       (null
228        (case (info :function :kind name)
229          (:macro
230           (setf binding :macro
231                 localp nil))
232          (:special-form
233           (setf binding :special-form
234                 localp nil))
235          (:function
236           (setf binding :function
237                 localp nil
238                 ftype (when (eq :declared (info :function :where-from name))
239                         (info :function :type name))
240                 inlinep (info :function :inlinep name))))))
241     (values binding
242             localp
243             (let (alist)
244               (when (and ftype (neq *universal-fun-type* ftype))
245                 (push (cons 'ftype (type-specifier ftype)) alist))
246               (ecase inlinep
247                 ((:inline :maybe-inline) (push (cons 'inline 'inline) alist))
248                 (:notinline (push (cons 'inline 'notinline) alist))
249                 ((nil)))
250               (when dx (push (cons 'dynamic-extent t) alist))
251               (append alist (extra-pairs :function name fun *lexenv*))))))
252
253
254
255 (declaim (ftype (sfunction
256                  (symbol &optional (or null lexenv))
257                  (values (member nil :special :lexical :symbol-macro :constant :global :alien)
258                          boolean
259                          list))
260                 variable-information))
261 (defun variable-information (name &optional env)
262   "Return information about the variable name VAR in the lexical environment ENV.
263 Note that the global binding may differ from the local one.
264
265 This function returns three values. The first indicated the type of the variable
266 binding:
267
268   NIL
269     There is no apparent binding for NAME.
270
271   :SPECIAL
272     NAME refers to a special variable.
273
274   :LEXICAL
275     NAME refers to a lexical variable.
276
277   :SYMBOL-MACRO
278     NAME refers to a symbol macro.
279
280   :CONSTANT
281     NAME refers to a named constant defined using DEFCONSTANT, or NAME
282     is a keyword.
283
284   :GLOBAL
285     NAME refers to a global variable. (SBCL specific extension.)
286
287   :ALIEN
288     NAME refers to an alien variable. (SBCL specific extension.)
289
290 The second value is true if NAME is bound locally. This is currently
291 always NIL for special variables, although arguably it should be T
292 when there is a lexically apparent binding for the special variable.
293
294 The third value is an alist describind the declarations that apply to
295 the function NAME. Standard declaration specifiers that may appear in
296 CARS of the alist include:
297
298   DYNAMIC-EXTENT
299     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
300     is NIL, the alist element may be omitted.
301
302   IGNORE
303     If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
304     the alist element may be omitted.
305
306   TYPE
307     The CDR is the type specifier associated with NAME, or the symbol
308     T if there is explicit type declaration or proclamation associated
309     with NAME. The type specifier may be equivalent to or a supertype
310     of the original declaration. If the CDR is T the alist element may
311     be omitted.
312
313   SB-EXT:ALWAYS-BOUND
314     If CDR is T, NAME has been declared as SB-EXT:ALWAYS-BOUND \(SBCL
315     specific.)
316
317 In addition to these declarations defined using DEFINE-DECLARATION may
318 appear."
319   (let* ((*lexenv* (or env (make-null-lexenv)))
320          (kind (info :variable :kind name))
321          (var (lexenv-find name vars))
322          binding localp dx ignorep type)
323     (etypecase var
324       (sb-c::leaf
325        (let ((env-type (or (lexenv-find var type-restrictions)
326                            *universal-type*)))
327          (setf type (type-intersection (sb-c::leaf-type var) env-type)
328                dx (sb-c::leaf-dynamic-extent var)))
329        (etypecase var
330          (sb-c::lambda-var
331           (setf binding :lexical
332                 localp t
333                 ignorep (sb-c::lambda-var-ignorep var)))
334          ;; FIXME: IGNORE doesn't make sense for specials or constants
335          ;; -- though it is _possible_ to declare them ignored, but
336          ;; we don't keep the information around.
337          (sb-c::global-var
338           (setf binding (if (eq :global kind)
339                             :global
340                             :special)
341                 ;; FIXME: Lexically apparent binding or not for specials?
342                 localp nil))
343          (sb-c::constant
344           (setf binding :constant
345                 localp nil))))
346       (cons
347        (setf binding :symbol-macro
348              localp t))
349        (null
350         (let ((global-type (info :variable :type name)))
351           (setf binding (case kind
352                           (:macro :symbol-macro)
353                           (:unknown nil)
354                           (t kind))
355                 type (if (eq *universal-type* global-type)
356                          nil
357                          global-type)
358                 localp nil))))
359     (values binding
360             localp
361             (let (alist)
362               (when ignorep (push (cons 'ignore t) alist))
363               (when (and type (neq *universal-type* type))
364                 (push (cons 'type (type-specifier type)) alist))
365               (when dx (push (cons 'dynamic-extent t) alist))
366               (when (info :variable :always-bound name)
367                 (push (cons 'sb-ext:always-bound t) alist))
368               (append alist (extra-pairs :variable name var *lexenv*))))))
369
370 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
371                 declaration-information))
372 (defun declaration-information (declaration-name &optional env)
373   "Return information about declarations named by DECLARATION-NAME.
374
375 If DECLARATION-NAME is OPTIMIZE return a list who's entries are of the
376 form \(QUALITY VALUE).
377
378 If DECLARATION-NAME is DECLARATION return a list of declaration names that
379 have been proclaimed as valid.
380
381 If DECLARATION-NAME is a name that has defined via DEFINE-DECLARATION return a
382 user defined value.
383
384 If DECLARATION-NAME is SB-EXT:MUFFLE-CONDITIONS return a type specifier for
385 the condition types that have been muffled."
386   (let ((env (or env (make-null-lexenv))))
387     (case declaration-name
388       (optimize
389        (let ((policy (sb-c::lexenv-policy env)))
390          (collect ((res))
391            (dolist (name sb-c::*policy-qualities*)
392              (res (list name (sb-c::policy-quality policy name))))
393            (loop for (name . nil) in sb-c::*policy-dependent-qualities*
394                  do (res (list name (sb-c::policy-quality policy name))))
395            (res))))
396       (sb-ext:muffle-conditions
397        (car (rassoc 'muffle-warning
398                     (sb-c::lexenv-handled-conditions env))))
399       (declaration
400        ;; FIXME: This is a bit too deep in the guts of INFO for comfort...
401        (let ((type (sb-c::type-info-number
402                     (sb-c::type-info-or-lose :declaration :recognized)))
403              (ret nil))
404          (dolist (env *info-environment*)
405            (do-info (env :name name :type-number num :value value)
406              (when (and (= num type) value)
407                (push name ret))))
408          ret))
409       (t (if (info :declaration :handler declaration-name)
410              (extra-decl-info declaration-name env)
411              (error "Unsupported declaration ~S." declaration-name))))))
412
413
414 (defun parse-macro (name lambda-list body &optional env)
415   "Process a macro definition of the kind that might appear in a DEFMACRO form
416 into a lambda expression of two variables: a form and an environment. The
417 lambda edxpression will parse its form argument, binding the variables in
418 LAMBDA-LIST appropriately, and then excute BODY with those bindings in
419 effect."
420   (declare (ignore env))
421   (with-unique-names (whole environment)
422     (multiple-value-bind (body decls)
423         (parse-defmacro lambda-list whole body name
424                         'parse-macro
425                         :environment environment)
426       `(lambda (,whole ,environment)
427          ,@decls
428          ,body))))
429
430 (defun enclose (lambda-expression &optional environment)
431   "Return a function consistent with LAMBDA-EXPRESSION in ENVIRONMENT: the
432 lambda expression is allowed to reference the declarations and macro
433 definitions in ENVIRONMENT, but consequences are undefined if lexical
434 variables, functions, tags or any other run-time entity defined in ENVIRONMENT
435 is referred to by the expression."
436   (let ((env (if environment
437                  (sb-c::make-restricted-lexenv environment)
438                  (make-null-lexenv))))
439     (compile-in-lexenv nil lambda-expression env)))
440
441 ;;; Add a bit of user-data to a lexenv.
442 ;;;
443 ;;; If KIND is :declare then DATA should be of the form
444 ;;;    (declaration-name . value)
445 ;;; If KIND is :variable then DATA should be of the form
446 ;;;     (variable-name key value)
447 ;;; If KIND is :function then DATA should be of the form
448 ;;;     (function-name key value)
449 ;;;
450 ;;; PD-VARS and PD-FVARS are are the vars and fvars arguments
451 ;;; of the process-decls call that called this function.
452 (defun update-lexenv-user-data (env kind data pd-vars pd-fvars)
453   (let ((user-data (sb-c::lexenv-user-data env)))
454     ;; user-data looks like this:
455     ;; ((:declare d . value)
456     ;;  (:variable var binding key . value)
457     ;;  (:function var binding key . value))
458     (let ((*lexenv* env))
459       (ecase kind
460         (:variable
461          (loop
462             for (name key value) in data
463             for binding1 = (sb-c::find-in-bindings pd-vars name)
464             for binding  =  (if binding1 binding1 (lexenv-find name vars))
465             do (push (list* :variable name binding key value) user-data)))
466         (:function
467          (loop
468             for (name key value) in data
469             for binding1 = (find name pd-fvars :key #'sb-c::leaf-source-name :test #'equal)
470             for binding = (if binding1 binding1 (lexenv-find name funs))
471             do (push (list* :function name binding key value) user-data)))
472         (:declare
473          (destructuring-bind (decl-name . value) data
474            (push (list* :declare decl-name value) user-data)))))
475     (sb-c::make-lexenv :default env :user-data user-data)))
476
477 (defmacro define-declaration (decl-name lambda-list &body body)
478   "Define a handler for declaration specifiers starting with DECL-NAME.
479
480 The function defined by this macro is called with two arguments: a declaration
481 specifier and a environment. It must return two values. The first value must
482 be :VARIABLE, :FUNCTION, or :DECLARE.
483
484 If the first value is :VARIABLE or :FUNCTION then the second value should be a
485 list of elements of the form (BINDING-NAME KEY VALUE). conses (KEY . VALUE)
486 will be added to the alist returned by:
487
488    (function-information binding-name env)
489
490  or
491
492    (variable-information binding-name env)
493
494 If the first value is :DECLARE then the second value should be a
495 cons (DECL-NAME . VALUE). VALUE will be returned by:
496
497    (declaration-information decl-name env)
498 "
499   `(eval-when (:compile-toplevel :load-toplevel :execute)
500      (proclaim '(declaration ,decl-name))
501      (flet ((func ,lambda-list
502               ,@body))
503        (setf
504         (info :declaration :handler ',decl-name)
505         (lambda (lexenv spec pd-vars pd-fvars)
506           (multiple-value-bind (kind data) (func spec lexenv)
507             (update-lexenv-user-data lexenv kind data pd-vars pd-fvars)))))))