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 (symbol &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)
 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 The second value is true if NAME is bound locally. This is currently
 288 always NIL for special variables, although arguably it should be T
 289 when there is a lexically apparent binding for the special variable.
 290
 291 The third value is an alist describind the declarations that apply to
 292 the function NAME. Standard declaration specifiers that may appear in
 293 CARS of the alist include:
 294
 295   DYNAMIC-EXTENT
 296     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
 297     is NIL, the alist element may be omitted.
 298
 299   IGNORE
 300     If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
 301     the alist element may be omitted.
 302
 303   TYPE
 304     The CDR is the type specifier associated with NAME, or the symbol
 305     T if there is explicit type declaration or proclamation associated
 306     with NAME. The type specifier may be equivalent to or a supertype
 307     of the original declaration. If the CDR is T the alist element may
 308     be omitted.
 309
 310   SB-EXT:ALWAYS-BOUND
 311     If CDR is T, NAME has been declared as SB-EXT:ALWAYS-BOUND \(SBCL
 312     specific.)
 313
 314 In addition to these declarations defined using DEFINE-DECLARATION may
 315 appear."
 316   (let* ((*lexenv* (or env (make-null-lexenv)))
 317          (kind (info :variable :kind name))
 318          (var (lexenv-find name vars))
 319          binding localp dx ignorep type)
 320     (etypecase var
 321       (sb-c::leaf
 322        (let ((env-type (or (lexenv-find var type-restrictions)
 323                            *universal-type*)))
 324          (setf type (type-intersection (sb-c::leaf-type var) env-type)
 325                dx (sb-c::leaf-dynamic-extent var)))
 326        (etypecase var
 327          (sb-c::lambda-var
 328           (setf binding :lexical
 329                 localp t
 330                 ignorep (sb-c::lambda-var-ignorep var)))
 331          ;; FIXME: IGNORE doesn't make sense for specials or constants
 332          ;; -- though it is _possible_ to declare them ignored, but
 333          ;; we don't keep the information around.
 334          (sb-c::global-var
 335           (setf binding (if (eq :global kind)
 336                             :global
 337                             :special)
 338                 ;; FIXME: Lexically apparent binding or not for specials?
 339                 localp nil))
 340          (sb-c::constant
 341           (setf binding :constant
 342                 localp nil))))
 343       (cons
 344        (setf binding :symbol-macro
 345              localp t))
 346        (null
 347         (let ((global-type (info :variable :type name)))
 348           (setf binding (case kind
 349                           (:macro :symbol-macro)
 350                           (:unknown nil)
 351                           (t kind))
 352                 type (if (eq *universal-type* global-type)
 353                          nil
 354                          global-type)
 355                 localp nil))))
 356     (values binding
 357             localp
 358             (let (alist)
 359               (when ignorep (push (cons 'ignore t) alist))
 360               (when (and type (neq *universal-type* type))
 361                 (push (cons 'type (type-specifier type)) alist))
 362               (when dx (push (cons 'dynamic-extent t) alist))
 363               (when (info :variable :always-bound name)
 364                 (push (cons 'sb-ext:always-bound t) alist))
 365               (append alist (extra-pairs :variable name var *lexenv*))))))
 366
 367 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
 368                 declaration-information))
 369 (defun declaration-information (declaration-name &optional env)
 370   "Return information about declarations named by DECLARATION-NAME.
 371
 372 If DECLARATION-NAME is OPTIMIZE return a list who's entries are of the
 373 form \(QUALITY VALUE).
 374
 375 If DECLARATION-NAME is DECLARATION return a list of declaration names that
 376 have been proclaimed as valid.
 377
 378 If DECLARATION-NAME is a name that has defined via DEFINE-DECLARATION return a
 379 user defined value.
 380
 381 If DECLARATION-NAME is SB-EXT:MUFFLE-CONDITIONS return a type specifier for
 382 the condition types that have been muffled."
 383   (let ((env (or env (make-null-lexenv))))
 384     (case declaration-name
 385       (optimize
 386        (let ((policy (sb-c::lexenv-policy env)))
 387          (collect ((res))
 388            (dolist (name sb-c::*policy-qualities*)
 389              (res (list name (cdr (assoc name policy)))))
 390            (loop for (name . nil) in sb-c::*policy-dependent-qualities*
 391                  do (res (list name (sb-c::policy-quality policy name))))
 392            (res))))
 393       (sb-ext:muffle-conditions
 394        (car (rassoc 'muffle-warning
 395                     (sb-c::lexenv-handled-conditions env))))
 396       (declaration
 397        ;; FIXME: This is a bit too deep in the guts of INFO for comfort...
 398        (let ((type (sb-c::type-info-number
 399                     (sb-c::type-info-or-lose :declaration :recognized)))
 400              (ret nil))
 401          (dolist (env *info-environment*)
 402            (do-info (env :name name :type-number num :value value)
 403              (when (and (= num type) value)
 404                (push name ret))))
 405          ret))
 406       (t (if (info :declaration :handler declaration-name)
 407              (extra-decl-info declaration-name env)
 408              (error "Unsupported declaration ~S." declaration-name))))))
 409
 410
 411 (defun parse-macro (name lambda-list body &optional env)
 412   "Process a macro definition of the kind that might appear in a DEFMACRO form
 413 into a lambda expression of two variables: a form and an environment. The
 414 lambda edxpression will parse its form argument, binding the variables in
 415 LAMBDA-LIST appropriately, and then excute BODY with those bindings in
 416 effect."
 417   (declare (ignore env))
 418   (with-unique-names (whole environment)
 419     (multiple-value-bind (body decls)
 420         (parse-defmacro lambda-list whole body name
 421                         'parse-macro
 422                         :environment environment)
 423       `(lambda (,whole ,environment)
 424          ,@decls
 425          ,body))))
 426
 427 (defun enclose (lambda-expression &optional environment)
 428   "Return a function consistent with LAMBDA-EXPRESSION in ENVIRONMENT: the
 429 lambda expression is allowed to reference the declarations and macro
 430 definitions in ENVIRONMENT, but consequences are undefined if lexical
 431 variables, functions, tags or any other run-time entity defined in ENVIRONMENT
 432 is referred to by the expression."
 433   (let ((env (if environment
 434                  (sb-c::make-restricted-lexenv environment)
 435                  (make-null-lexenv))))
 436     (compile-in-lexenv nil lambda-expression env)))
 437
 438 ;;; Add a bit of user-data to a lexenv.
 439 ;;;
 440 ;;; If KIND is :declare then DATA should be of the form
 441 ;;;    (declaration-name . value)
 442 ;;; If KIND is :variable then DATA should be of the form
 443 ;;;     (variable-name key value)
 444 ;;; If KIND is :function then DATA should be of the form
 445 ;;;     (function-name key value)
 446 ;;;
 447 ;;; PD-VARS and PD-FVARS are are the vars and fvars arguments
 448 ;;; of the process-decls call that called this function.
 449 (defun update-lexenv-user-data (env kind data pd-vars pd-fvars)
 450   (let ((user-data (sb-c::lexenv-user-data env)))
 451     ;; user-data looks like this:
 452     ;; ((:declare d . value)
 453     ;;  (:variable var binding key . value)
 454     ;;  (:function var binding key . value))
 455     (let ((*lexenv* env))
 456       (ecase kind
 457         (:variable
 458          (loop
 459             for (name key value) in data
 460             for binding1 = (sb-c::find-in-bindings pd-vars name)
 461             for binding  =  (if binding1 binding1 (lexenv-find name vars))
 462             do (push (list* :variable name binding key value) user-data)))
 463         (:function
 464          (loop
 465             for (name key value) in data
 466             for binding1 = (find name pd-fvars :key #'sb-c::leaf-source-name :test #'equal)
 467             for binding = (if binding1 binding1 (lexenv-find name funs))
 468             do (push (list* :function name binding key value) user-data)))
 469         (:declare
 470          (destructuring-bind (decl-name . value) data
 471            (push (list* :declare decl-name value) user-data)))))
 472     (sb-c::make-lexenv :default env :user-data user-data)))
 473
 474 (defmacro define-declaration (decl-name lambda-list &body body)
 475   "Define a handler for declaration specifiers starting with DECL-NAME.
 476
 477 The function defined by this macro is called with two arguments: a declaration
 478 specifier and a environment. It must return two values. The first value must
 479 be :VARIABLE, :FUNCTION, or :DECLARE.
 480
 481 If the first value is :VARIABLE or :FUNCTION then the second value should be a
 482 list of elements of the form (BINDING-NAME KEY VALUE). conses (KEY . VALUE)
 483 will be added to the alist returned by:
 484
 485    (function-information binding-name env)
 486
 487  or
 488
 489    (variable-information binding-name env)
 490
 491 If the first value is :DECLARE then the second value should be a
 492 cons (DECL-NAME . VALUE). VALUE will be returned by:
 493
 494    (declaration-information decl-name env)
 495 "
 496   `(eval-when (:compile-toplevel :load-toplevel :execute)
 497      (proclaim '(declaration ,decl-name))
 498      (flet ((func ,lambda-list
 499               ,@body))
 500        (setf
 501         (info :declaration :handler ',decl-name)
 502         (lambda (lexenv spec pd-vars pd-fvars)
 503           (multiple-value-bind (kind data) (func spec lexenv)
 504             (update-lexenv-user-data lexenv kind data pd-vars pd-fvars)))))))