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 define-declaration
  12 (map-environment)
  13 |#
  14
  15
  16 (defvar *null-lexenv* (make-null-lexenv))
  17
  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.
  21
  22    VARIABLE
  23      is a list of symbols to introduce as new variable bindings.
  24
  25    SYMBOL-MACRO
  26      is a list symbol macro bindings of the form (name definition).
  27
  28    MACRO
  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).
  31
  32    FUNCTION
  33      is a list of symbols to introduce as new local function bindings.
  34
  35    DECLARE
  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:
  39
  40       (augment-environment env :variable '(x) :declare '((special x)))
  41
  42      is like
  43
  44       (let (x) (declare (special x)) ....)
  45
  46      but
  47
  48       (augment-environment (augment-environment env :variable '(x))
  49                            :declare '((special x)))
  50
  51      is like
  52
  53        (let (x) (locally (declare (special x))) ...)
  54 "
  55   (collect ((lvars)
  56             (clambdas))
  57     (unless (or variable symbol-macro function macro declare)
  58       (return-from augment-environment env))
  59
  60     (if (null env)
  61         (setq env (make-null-lexenv))
  62         (setq env (copy-structure env)))
  63
  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*))
  67
  68     (when macro
  69       (setf (sb-c::lexenv-funs env)
  70             (nconc
  71              (loop for (name def) in macro
  72                 collect (cons name (cons 'sb-sys::macro def)))
  73              (sb-c::lexenv-funs env))))
  74
  75     (when symbol-macro
  76       (setf (sb-c::lexenv-vars env)
  77             (nconc
  78              (loop for (name def) in symbol-macro
  79                 collect (cons name (cons 'sb-sys::macro def)))
  80              (sb-c::lexenv-vars env))))
  81
  82     (dolist (name variable)
  83       (lvars (sb-c::make-lambda-var :%source-name name)))
  84
  85     (dolist (name function)
  86       (clambdas
  87        (sb-c::make-lambda
  88         :lexenv *null-lexenv*
  89         :%source-name name
  90         :allow-instrumenting nil)))
  91
  92     (when declare
  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))))
  98
  99     (when function
 100       (setf (sb-c::lexenv-funs env)
 101             (nconc
 102              (loop for name in function for lambda in (clambdas)
 103                   collect (cons name lambda))
 104              (sb-c::lexenv-funs env))))
 105
 106     (when variable
 107       (setf (sb-c::lexenv-vars env)
 108             (nconc
 109              (loop for name in variable for lvar in (lvars)
 110                 collect
 111                 (cons name
 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)
 116                           lvar)))
 117              (sb-c::lexenv-vars env))))
 118
 119     env))
 120
 121 (declaim (ftype (sfunction (symbol &optional (or null lexenv))
 122                            (values (member nil :function :macro :special-form)
 123                                    boolean
 124                                    list))
 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.
 129
 130 This function returns three values. The first indicates the type of
 131 function definition or binding:
 132
 133   NIL
 134     There is no apparent definition for NAME.
 135
 136   :FUNCTION
 137     NAME refers to a function.
 138
 139   :MACRO
 140     NAME refers to a macro.
 141
 142   :SPECIAL-FORM
 143     NAME refers to a special operator. If the name refers to both a
 144     macro and a special operator, the macro takes precedence.
 145
 146 The second value is true if NAME is bound locally.
 147
 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:
 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   INLINE
 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.
 160
 161   FTYPE
 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
 165     be omitted."
 166   (let* ((*lexenv* (or env (make-null-lexenv)))
 167          (fun (lexenv-find name funs))
 168          binding localp ftype dx inlinep)
 169     (etypecase fun
 170       (sb-c::leaf
 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))
 176          (etypecase fun
 177            (sb-c::functional
 178             (setf localp t
 179                   inlinep (sb-c::functional-inlinep fun)))
 180            (sb-c::defined-fun
 181             ;; Inlined known functions.
 182             (setf localp nil
 183                   inlinep (sb-c::defined-fun-inlinep fun))))))
 184       (cons
 185        (setf binding :macro
 186              localp t))
 187       (null
 188        (case (info :function :kind name)
 189          (:macro
 190           (setf binding :macro
 191                 localp nil))
 192          (:special-form
 193           (setf binding :special-form
 194                 localp nil))
 195          (:function
 196           (setf binding :function
 197                 localp nil
 198                 ftype (when (eq :declared (info :function :where-from name))
 199                         (info :function :type name))
 200                 inlinep (info :function :inlinep name))))))
 201     (values binding
 202             localp
 203             (let (alist)
 204               (when (and ftype (neq *universal-fun-type* ftype))
 205                 (push (cons 'ftype (type-specifier ftype)) alist))
 206               (ecase inlinep
 207                 ((:inline :maybe-inline) (push (cons 'inline 'inline) alist))
 208                 (:notinline (push (cons 'inline 'notinline) alist))
 209                 ((nil)))
 210               (when dx (push (cons 'dynamic-extent t) alist))
 211               alist))))
 212
 213 (declaim (ftype (sfunction
 214                  (symbol &optional (or null lexenv))
 215                  (values (member nil :special :lexical :symbol-macro :constant :global)
 216                          boolean
 217                          list))
 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.
 222
 223 This function returns three values. The first indicated the type of the variable
 224 binding:
 225
 226   NIL
 227     There is no apparent binding for NAME.
 228
 229   :SPECIAL
 230     NAME refers to a special variable.
 231
 232   :LEXICAL
 233     NAME refers to a lexical variable.
 234
 235   :SYMBOL-MACRO
 236     NAME refers to a symbol macro.
 237
 238   :CONSTANT
 239     NAME refers to a named constant defined using DEFCONSTANT, or NAME
 240     is a keyword.
 241
 242   :GLOBAL
 243     NAME refers to a global variable. (SBCL specific extension.)
 244
 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.
 248
 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:
 252
 253   DYNAMIC-EXTENT
 254     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
 255     is NIL, the alist element may be omitted.
 256
 257   IGNORE
 258     If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
 259     the alist element may be omitted.
 260
 261   TYPE
 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
 266     be omitted.
 267
 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)
 274     (etypecase var
 275       (sb-c::leaf
 276        (let ((env-type (or (lexenv-find var type-restrictions)
 277                            *universal-type*)))
 278          (setf type (type-intersection (sb-c::leaf-type var) env-type)
 279                dx (sb-c::leaf-dynamic-extent var)))
 280        (etypecase var
 281          (sb-c::lambda-var
 282           (setf binding :lexical
 283                 localp t
 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.
 288          (sb-c::global-var
 289           (setf binding (if (eq :global kind)
 290                             :global
 291                             :special)
 292                 ;; FIXME: Lexically apparent binding or not for specials?
 293                 localp nil))
 294          (sb-c::constant
 295           (setf binding :constant
 296                 localp nil))))
 297       (cons
 298        (setf binding :symbol-macro
 299              localp t))
 300        (null
 301         (let ((global-type (info :variable :type name)))
 302           (setf binding (case kind
 303                           (:macro :symbol-macro)
 304                           (:unknown nil)
 305                           (t kind))
 306                 type (if (eq *universal-type* global-type)
 307                          nil
 308                          global-type)
 309                 localp nil))))
 310     (values binding
 311             localp
 312             (let (alist)
 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))
 319               alist))))
 320
 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.
 325
 326 If DECLARATION-NAME is OPTIMIZE return a list who's entries are of the
 327 form \(QUALITY VALUE).
 328
 329 If DECLARATION-NAME is DECLARATION return a list of declaration names that
 330 have been proclaimed as valid.
 331
 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
 336       (optimize
 337        (let ((policy (sb-c::lexenv-policy env)))
 338          (collect ((res))
 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))))
 343            (res))))
 344       (sb-ext:muffle-conditions
 345        (car (rassoc 'muffle-warning
 346                     (sb-c::lexenv-handled-conditions env))))
 347       (declaration
 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)))
 351              (ret nil))
 352          (dolist (env *info-environment*)
 353            (do-info (env :name name :type-number num :value value)
 354              (when (and (= num type) value)
 355                (push name ret))))
 356          ret))
 357       (t (error "Unsupported declaration ~S." declaration-name)))))
 358
 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
 364 effect."
 365   (declare (ignore env))
 366   (with-unique-names (whole environment)
 367     (multiple-value-bind (body decls)
 368         (parse-defmacro lambda-list whole body name
 369                         'parse-macro
 370                         :environment environment)
 371       `(lambda (,whole ,environment)
 372          ,@decls
 373          ,body))))
 374
 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)))