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)
 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 The second value is true if NAME is bound locally. This is currently
 142 always NIL for special variables, although arguably it should be T
 143 when there is a lexically apparent binding for the special variable.
 144
 145 The third value is an alist describind the declarations that apply to
 146 the function NAME. Standard declaration specifiers that may appear in
 147 CARS of the alist include:
 148
 149   DYNAMIC-EXTENT
 150     If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
 151     is NIL, the alist element may be omitted.
 152
 153   IGNORE
 154     If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
 155     the alist element may be omitted.
 156
 157   TYPE
 158     The CDR is the type specifier associated with NAME, or the symbol
 159     T if there is explicit type declaration or proclamation associated
 160     with NAME. The type specifier may be equivalent to or a supertype
 161     of the original declaration. If the CDR is T the alist element may
 162     be omitted."
 163   (let* ((*lexenv* (or env (make-null-lexenv)))
 164          (var (lexenv-find name vars))
 165          binding localp dx ignorep type)
 166     (etypecase var
 167       (sb-c::leaf
 168        (let ((env-type (or (lexenv-find var type-restrictions)
 169                            *universal-type*)))
 170          (setf type (if (eq :declared (sb-c::leaf-where-from var))
 171                         (type-intersection (sb-c::leaf-type var)
 172                                            env-type)
 173                         env-type)
 174                dx (sb-c::leaf-dynamic-extent var)))
 175        (etypecase var
 176          (sb-c::lambda-var
 177           (setf binding :lexical
 178                 localp t
 179                 ignorep (sb-c::lambda-var-ignorep var)))
 180          ;; FIXME: IGNORE doesn't make sense for specials or constants
 181          ;; -- though it is _possible_ to declare them ignored, but
 182          ;; we don't keep the information around.
 183          (sb-c::global-var
 184           (setf binding :special
 185                 ;; FIXME: Lexically apparent binding or not?
 186                 localp nil))
 187          (sb-c::constant
 188           (setf binding :constant
 189                 localp nil))))
 190       (cons
 191        (setf binding :symbol-macro
 192              localp t))
 193        (null
 194         (let ((global-type (info :variable :type name))
 195               (kind (info :variable :kind name)))
 196           (setf binding (case kind
 197                           (:macro :symbol-macro)
 198                           (:global nil)
 199                           (t kind))
 200                 type (if (eq *universal-type* global-type)
 201                          nil
 202                          global-type)
 203                 localp nil))))
 204     (values binding
 205             localp
 206             (let (alist)
 207               (when ignorep (push (cons 'ignore t) alist))
 208               (when (and type (neq *universal-type* type))
 209                 (push (cons 'type (type-specifier type)) alist))
 210               (when dx (push (cons 'dynamic-extent t) alist))
 211               alist))))
 212
 213 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
 214                 declaration-information))
 215 (defun declaration-information (declaration-name &optional env)
 216   (let ((env (or env (make-null-lexenv))))
 217     (case declaration-name
 218       (optimize
 219        (let ((policy (sb-c::lexenv-policy env)))
 220          (collect ((res))
 221            (dolist (name sb-c::*policy-qualities*)
 222              (res (list name (cdr (assoc name policy)))))
 223            (loop for (name . nil) in sb-c::*policy-dependent-qualities*
 224                  do (res (list name (sb-c::policy-quality policy name))))
 225            (res))))
 226       (sb-ext:muffle-conditions
 227        (car (rassoc 'muffle-warning
 228                     (sb-c::lexenv-handled-conditions env))))
 229       (t (error "Unsupported declaration ~S." declaration-name)))))
 230
 231 (defun parse-macro (name lambda-list body &optional env)
 232   (declare (ignore env))
 233   (with-unique-names (whole environment)
 234     (multiple-value-bind (body decls)
 235         (parse-defmacro lambda-list whole body name
 236                         'parse-macro
 237                         :environment environment)
 238       `(lambda (,whole ,environment)
 239          ,@decls
 240          ,body))))
 241
 242 (defun enclose (lambda-expression &optional env)
 243   (let ((env (if env
 244                  (sb-c::make-restricted-lexenv env)
 245                  (make-null-lexenv))))
 246     (compile-in-lexenv nil lambda-expression env)))