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 declaration-information
  12 augment-environment
  13 define-declaration
  14 (map-environment)
  15 |#
  16
  17 (declaim (ftype (sfunction (symbol &optional (or null lexenv))
  18                            (values (member nil :function :macro :special-form)
  19                                    boolean
  20                                    list))
  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.
  25
  26 This function returns three values. The first indicates the type of
  27 function definition or binding:
  28
  29   NIL
  30     There is no apparent definition for NAME.
  31
  32   :FUNCTION
  33     NAME refers to a function.
  34
  35   :MACRO
  36     NAME refers to a macro.
  37
  38   :SPECIAL-FORM
  39     NAME refers to a special operator. If the name refers to both a
  40     macro and a special operator, the macro takes precedence.
  41
  42 The second value is true if NAME is bound locally.
  43
  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:
  47
  48   DYNAMIC-EXTENT
  49     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
  50     is NIL, the alist element may be omitted.
  51
  52   INLINE
  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.
  56
  57   FTYPE
  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
  61     be omitted."
  62   (let* ((*lexenv* (or env (make-null-lexenv)))
  63          (fun (lexenv-find name funs))
  64          binding localp ftype dx inlinep)
  65     (etypecase fun
  66       (sb-c::leaf
  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)
  72                                             env-type)
  73                          env-type)
  74                dx (sb-c::leaf-dynamic-extent fun))
  75          (etypecase fun
  76            (sb-c::functional
  77             (setf localp t
  78                   inlinep (sb-c::functional-inlinep fun)))
  79            (sb-c::defined-fun
  80             ;; Inlined known functions.
  81             (setf localp nil
  82                   inlinep (sb-c::defined-fun-inlinep fun))))))
  83       (cons
  84        (setf binding :macro
  85              localp t))
  86       (null
  87        (case (info :function :kind name)
  88          (:macro
  89           (setf binding :macro
  90                 localp nil))
  91          (:special-form
  92           (setf binding :special-form
  93                 localp nil))
  94          (:function
  95           (setf binding :function
  96                 localp nil
  97                 ftype (when (eq :declared (info :function :where-from name))
  98                         (info :function :type name))
  99                 inlinep (info :function :inlinep name))))))
 100     (values binding
 101             localp
 102             (let (alist)
 103               (when (and ftype (neq *universal-fun-type* ftype))
 104                 (push (cons 'ftype (type-specifier ftype)) alist))
 105               (ecase inlinep
 106                 ((:inline :maybe-inline) (push (cons 'inline 'inline) alist))
 107                 (:notinline (push (cons 'inline 'notinline) alist))
 108                 ((nil)))
 109               (when dx (push (cons 'dynamic-extent t) alist))
 110               alist))))
 111
 112 (declaim (ftype (sfunction
 113                  (symbol &optional (or null lexenv))
 114                  (values (member nil :special :lexical :symbol-macro :constant :global)
 115                          boolean
 116                          list))
 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.
 121
 122 This function returns three values. The first indicated the type of the variable
 123 binding:
 124
 125   NIL
 126     There is no apparent binding for NAME.
 127
 128   :SPECIAL
 129     NAME refers to a special variable.
 130
 131   :LEXICAL
 132     NAME refers to a lexical variable.
 133
 134   :SYMBOL-MACRO
 135     NAME refers to a symbol macro.
 136
 137   :CONSTANT
 138     NAME refers to a named constant defined using DEFCONSTANT, or NAME
 139     is a keyword.
 140
 141   :GLOBAL
 142     NAME refers to a global variable. (SBCL specific extension.)
 143
 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.
 147
 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:
 151
 152   DYNAMIC-EXTENT
 153     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
 154     is NIL, the alist element may be omitted.
 155
 156   IGNORE
 157     If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
 158     the alist element may be omitted.
 159
 160   TYPE
 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
 165     be omitted.
 166
 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)
 173     (etypecase var
 174       (sb-c::leaf
 175        (let ((env-type (or (lexenv-find var type-restrictions)
 176                            *universal-type*)))
 177          (setf type (if (eq :declared (sb-c::leaf-where-from var))
 178                         (type-intersection (sb-c::leaf-type var)
 179                                            env-type)
 180                         env-type)
 181                dx (sb-c::leaf-dynamic-extent var)))
 182        (etypecase var
 183          (sb-c::lambda-var
 184           (setf binding :lexical
 185                 localp t
 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.
 190          (sb-c::global-var
 191           (setf binding (if (eq :global kind)
 192                             :global
 193                             :special)
 194                 ;; FIXME: Lexically apparent binding or not for specials?
 195                 localp nil))
 196          (sb-c::constant
 197           (setf binding :constant
 198                 localp nil))))
 199       (cons
 200        (setf binding :symbol-macro
 201              localp t))
 202        (null
 203         (let ((global-type (info :variable :type name)))
 204           (setf binding (case kind
 205                           (:macro :symbol-macro)
 206                           (:unknown nil)
 207                           (t kind))
 208                 type (if (eq *universal-type* global-type)
 209                          nil
 210                          global-type)
 211                 localp nil))))
 212     (values binding
 213             localp
 214             (let (alist)
 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))
 221               alist))))
 222
 223 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
 224                 declaration-information))
 225 (defun declaration-information (declaration-name &optional env)
 226   "Return information about declarations named by DECLARATION-NAME.
 227
 228 If DECLARATION-NAME is optimize return a list who's entries are of the
 229 form (quality value).
 230
 231 If DECLARATION-NAME is SB-EXT:MUFFLE-CONDITIONS return a type specifier for
 232 the condition types that have been muffled."
 233   (let ((env (or env (make-null-lexenv))))
 234     (case declaration-name
 235       (optimize
 236        (let ((policy (sb-c::lexenv-policy env)))
 237          (collect ((res))
 238            (dolist (name sb-c::*policy-qualities*)
 239              (res (list name (cdr (assoc name policy)))))
 240            (loop for (name . nil) in sb-c::*policy-dependent-qualities*
 241                  do (res (list name (sb-c::policy-quality policy name))))
 242            (res))))
 243       (sb-ext:muffle-conditions
 244        (car (rassoc 'muffle-warning
 245                     (sb-c::lexenv-handled-conditions env))))
 246       (t (error "Unsupported declaration ~S." declaration-name)))))
 247
 248 (defun parse-macro (name lambda-list body &optional env)
 249   "Process a macro definition of the kind that might appear in a DEFMACRO form
 250 into a lambda expression of two variables: a form and an environment. The
 251 lambda edxpression will parse its form argument, binding the variables in
 252 LAMBDA-LIST appropriately, and then excute BODY with those bindings in
 253 effect."
 254   (declare (ignore env))
 255   (with-unique-names (whole environment)
 256     (multiple-value-bind (body decls)
 257         (parse-defmacro lambda-list whole body name
 258                         'parse-macro
 259                         :environment environment)
 260       `(lambda (,whole ,environment)
 261          ,@decls
 262          ,body))))
 263
 264 (defun enclose (lambda-expression &optional environment)
 265   "Return a function consistent with LAMBDA-EXPRESSION in ENVIRONMENT: the
 266 lambda expression is allowed to reference the declarations and macro
 267 definitions in ENVIRONMENT, but consequences are undefined if lexical
 268 variables, functions, tags or any other run-time entity defined in ENVIRONMENT
 269 is referred to by the expression."
 270   (let ((env (if environment
 271                  (sb-c::make-restricted-lexenv environment)
 272                  (make-null-lexenv))))
 273     (compile-in-lexenv nil lambda-expression env)))