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)))))))