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 augment-environment
  12 define-declaration
  13 (map-environment)
  14 |#
  15
  16 (declaim (ftype (sfunction (symbol &optional (or null lexenv))
  17                            (values (member nil :function :macro :special-form)
  18                                    boolean
  19                                    list))
  20                 function-information))
  21 (defun function-information (name &optional env)
  22   "Return information about the function NAME in the lexical environment ENV.
  23 Note that the global function binding may differ from the local one.
  24
  25 This function returns three values. The first indicates the type of
  26 function definition or binding:
  27
  28   NIL
  29     There is no apparent definition for NAME.
  30
  31   :FUNCTION
  32     NAME refers to a function.
  33
  34   :MACRO
  35     NAME refers to a macro.
  36
  37   :SPECIAL-FORM
  38     NAME refers to a special operator. If the name refers to both a
  39     macro and a special operator, the macro takes precedence.
  40
  41 The second value is true if NAME is bound locally.
  42
  43 The third value is an alist describing the declarations that apply to
  44 the function NAME. Standard declaration specifiers that may appear in
  45 CARS of the alist include:
  46
  47   DYNAMIC-EXTENT
  48     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
  49     is NIL, the alist element may be omitted.
  50
  51   INLINE
  52     The CDR is one of the symbols INLINE, NOTINLINE, or NIL, to
  53     indicate if the function has been declared INLINE or NOTINLINE. If
  54     the CDR is NIL the alist element may be omitted.
  55
  56   FTYPE
  57     The CDR is the type specifier associated with NAME, or the symbol
  58     FUNCTION if there is functional type declaration or proclamation
  59     associated with NAME. If the CDR is FUNCTION the alist element may
  60     be omitted."
  61   (let* ((*lexenv* (or env (make-null-lexenv)))
  62          (fun (lexenv-find name funs))
  63          binding localp ftype dx inlinep)
  64     (etypecase fun
  65       (sb-c::leaf
  66        (let ((env-type (or (lexenv-find fun type-restrictions)
  67                            *universal-fun-type*)))
  68          (setf binding :function
  69                ftype (if (eq :declared (sb-c::leaf-where-from fun))
  70                          (type-intersection (sb-c::leaf-type fun)
  71                                             env-type)
  72                          env-type)
  73                dx (sb-c::leaf-dynamic-extent fun))
  74          (etypecase fun
  75            (sb-c::functional
  76             (setf localp t
  77                   inlinep (sb-c::functional-inlinep fun)))
  78            (sb-c::defined-fun
  79             ;; Inlined known functions.
  80             (setf localp nil
  81                   inlinep (sb-c::defined-fun-inlinep fun))))))
  82       (cons
  83        (setf binding :macro
  84              localp t))
  85       (null
  86        (case (info :function :kind name)
  87          (:macro
  88           (setf binding :macro
  89                 localp nil))
  90          (:special-form
  91           (setf binding :special-form
  92                 localp nil))
  93          (:function
  94           (setf binding :function
  95                 localp nil
  96                 ftype (when (eq :declared (info :function :where-from name))
  97                         (info :function :type name))
  98                 inlinep (info :function :inlinep name))))))
  99     (values binding
 100             localp
 101             (let (alist)
 102               (when (and ftype (neq *universal-fun-type* ftype))
 103                 (push (cons 'ftype (type-specifier ftype)) alist))
 104               (ecase inlinep
 105                 ((:inline :maybe-inline) (push (cons 'inline 'inline) alist))
 106                 (:notinline (push (cons 'inline 'notinline) alist))
 107                 ((nil)))
 108               (when dx (push (cons 'dynamic-extent t) alist))
 109               alist))))
 110
 111 (declaim (ftype (sfunction
 112                  (symbol &optional (or null lexenv))
 113                  (values (member nil :special :lexical :symbol-macro :constant :global)
 114                          boolean
 115                          list))
 116                 variable-information))
 117 (defun variable-information (name &optional env)
 118   "Return information about the variable name VAR in the lexical environment ENV.
 119 Note that the global binding may differ from the local one.
 120
 121 This function returns three values. The first indicated the type of the variable
 122 binding:
 123
 124   NIL
 125     There is no apparent binding for NAME.
 126
 127   :SPECIAL
 128     NAME refers to a special variable.
 129
 130   :LEXICAL
 131     NAME refers to a lexical variable.
 132
 133   :SYMBOL-MACRO
 134     NAME refers to a symbol macro.
 135
 136   :CONSTANT
 137     NAME refers to a named constant defined using DEFCONSTANT, or NAME
 138     is a keyword.
 139
 140   :GLOBAL
 141     NAME refers to a global variable. (SBCL specific extension.)
 142
 143 The second value is true if NAME is bound locally. This is currently
 144 always NIL for special variables, although arguably it should be T
 145 when there is a lexically apparent binding for the special variable.
 146
 147 The third value is an alist describind the declarations that apply to
 148 the function NAME. Standard declaration specifiers that may appear in
 149 CARS of the alist include:
 150
 151   DYNAMIC-EXTENT
 152     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
 153     is NIL, the alist element may be omitted.
 154
 155   IGNORE
 156     If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
 157     the alist element may be omitted.
 158
 159   TYPE
 160     The CDR is the type specifier associated with NAME, or the symbol
 161     T if there is explicit type declaration or proclamation associated
 162     with NAME. The type specifier may be equivalent to or a supertype
 163     of the original declaration. If the CDR is T the alist element may
 164     be omitted.
 165
 166 Additionally, the SBCL specific SB-EXT:ALWAYS-BOUND declaration will
 167 appear with CDR as T if the variable has been declared always bound."
 168   (let* ((*lexenv* (or env (make-null-lexenv)))
 169          (kind (info :variable :kind name))
 170          (var (lexenv-find name vars))
 171          binding localp dx ignorep type)
 172     (etypecase var
 173       (sb-c::leaf
 174        (let ((env-type (or (lexenv-find var type-restrictions)
 175                            *universal-type*)))
 176          (setf type (if (eq :declared (sb-c::leaf-where-from var))
 177                         (type-intersection (sb-c::leaf-type var)
 178                                            env-type)
 179                         env-type)
 180                dx (sb-c::leaf-dynamic-extent var)))
 181        (etypecase var
 182          (sb-c::lambda-var
 183           (setf binding :lexical
 184                 localp t
 185                 ignorep (sb-c::lambda-var-ignorep var)))
 186          ;; FIXME: IGNORE doesn't make sense for specials or constants
 187          ;; -- though it is _possible_ to declare them ignored, but
 188          ;; we don't keep the information around.
 189          (sb-c::global-var
 190           (setf binding (if (eq :global kind)
 191                             :global
 192                             :special)
 193                 ;; FIXME: Lexically apparent binding or not for specials?
 194                 localp nil))
 195          (sb-c::constant
 196           (setf binding :constant
 197                 localp nil))))
 198       (cons
 199        (setf binding :symbol-macro
 200              localp t))
 201        (null
 202         (let ((global-type (info :variable :type name)))
 203           (setf binding (case kind
 204                           (:macro :symbol-macro)
 205                           (:unknown nil)
 206                           (t kind))
 207                 type (if (eq *universal-type* global-type)
 208                          nil
 209                          global-type)
 210                 localp nil))))
 211     (values binding
 212             localp
 213             (let (alist)
 214               (when ignorep (push (cons 'ignore t) alist))
 215               (when (and type (neq *universal-type* type))
 216                 (push (cons 'type (type-specifier type)) alist))
 217               (when dx (push (cons 'dynamic-extent t) alist))
 218               (when (info :variable :always-bound name)
 219                 (push (cons 'sb-ext:always-bound t) alist))
 220               alist))))
 221
 222 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
 223                 declaration-information))
 224 (defun declaration-information (declaration-name &optional env)
 225   "Return information about declarations named by DECLARATION-NAME.
 226
 227 If DECLARATION-NAME is OPTIMIZE return a list who's entries are of the
 228 form \(QUALITY VALUE).
 229
 230 If DECLARATION-NAME is DECLARATION return a list of declaration names that
 231 have been proclaimed as valid.
 232
 233 If DECLARATION-NAME is SB-EXT:MUFFLE-CONDITIONS return a type specifier for
 234 the condition types that have been muffled."
 235   (let ((env (or env (make-null-lexenv))))
 236     (case declaration-name
 237       (optimize
 238        (let ((policy (sb-c::lexenv-policy env)))
 239          (collect ((res))
 240            (dolist (name sb-c::*policy-qualities*)
 241              (res (list name (cdr (assoc name policy)))))
 242            (loop for (name . nil) in sb-c::*policy-dependent-qualities*
 243                  do (res (list name (sb-c::policy-quality policy name))))
 244            (res))))
 245       (sb-ext:muffle-conditions
 246        (car (rassoc 'muffle-warning
 247                     (sb-c::lexenv-handled-conditions env))))
 248       (declaration
 249        ;; FIXME: This is a bit too deep in the guts of INFO for comfort...
 250        (let ((type (sb-c::type-info-number
 251                     (sb-c::type-info-or-lose :declaration :recognized)))
 252              (ret nil))
 253          (dolist (env *info-environment*)
 254            (do-info (env :name name :type-number num :value value)
 255              (when (and (= num type) value)
 256                (push name ret))))
 257          ret))
 258       (t (error "Unsupported declaration ~S." declaration-name)))))
 259
 260 (defun parse-macro (name lambda-list body &optional env)
 261   "Process a macro definition of the kind that might appear in a DEFMACRO form
 262 into a lambda expression of two variables: a form and an environment. The
 263 lambda edxpression will parse its form argument, binding the variables in
 264 LAMBDA-LIST appropriately, and then excute BODY with those bindings in
 265 effect."
 266   (declare (ignore env))
 267   (with-unique-names (whole environment)
 268     (multiple-value-bind (body decls)
 269         (parse-defmacro lambda-list whole body name
 270                         'parse-macro
 271                         :environment environment)
 272       `(lambda (,whole ,environment)
 273          ,@decls
 274          ,body))))
 275
 276 (defun enclose (lambda-expression &optional environment)
 277   "Return a function consistent with LAMBDA-EXPRESSION in ENVIRONMENT: the
 278 lambda expression is allowed to reference the declarations and macro
 279 definitions in ENVIRONMENT, but consequences are undefined if lexical
 280 variables, functions, tags or any other run-time entity defined in ENVIRONMENT
 281 is referred to by the expression."
 282   (let ((env (if environment
 283                  (sb-c::make-restricted-lexenv environment)
 284                  (make-null-lexenv))))
 285     (compile-in-lexenv nil lambda-expression env)))