contrib/sb-cltl2/env.lisp

   1 (in-package :sb-cltl2)
   2
   3 #| TODO:
   4 function-information
   5 declaration-information
   6 augment-environment
   7 define-declaration
   8 (map-environment)
   9 |#
  10
  11 (declaim (ftype (sfunction
  12                  (symbol &optional (or null lexenv))
  13                  (values (member nil :special :lexical :symbol-macro :constant)
  14                          boolean
  15                          list))
  16                 variable-information))
  17 (defun variable-information (var &optional env)
  18   "Return three values. The first indicates a binding kind of VAR; the
  19 second is True if there is a local binding of VAR; the third is an
  20 alist of declarations that apply to the apparent binding of VAR."
  21   (let* ((*lexenv* (or env (make-null-lexenv)))
  22          (info (lexenv-find var vars)))
  23     (etypecase info
  24       (sb-c::leaf (let ((type (type-specifier
  25                                (type-intersection
  26                                 (sb-c::leaf-type info)
  27                                 (or (lexenv-find info type-restrictions)
  28                                     *universal-type*)))))
  29                     (etypecase info
  30                       (sb-c::lambda-var
  31                        (values :lexical t
  32                                `((ignore . ,(sb-c::lambda-var-ignorep info))
  33                                  (type . ,type))))
  34                       (sb-c::global-var
  35                        (values :special t
  36                                `((type . ,type)) ; XXX ignore
  37                                ))
  38                       (sb-c::constant
  39                        (values :constant nil
  40                                `((type . ,type)) ; XXX ignore
  41                                )))))
  42       (cons (values :symbol-macro t
  43                     nil                 ; FIXME: also in the compiler
  44                     ))
  45       (null (values (ecase (info :variable :kind var)
  46                       (:special :special)
  47                       (:constant :constant)
  48                       (:macro :symbol-macro)
  49                       (:global nil))
  50                     nil
  51                     `(                  ; XXX ignore
  52                       (type . ,(type-specifier ; XXX local type
  53                                 (info :variable :type var)))))))))
  54
  55 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
  56                 declaration-information))
  57 (defun declaration-information (declaration-name &optional env)
  58   (let ((env (or env (make-null-lexenv))))
  59     (case declaration-name
  60       (optimize
  61        (let ((policy (sb-c::lexenv-policy env)))
  62          (collect ((res))
  63            (dolist (name sb-c::*policy-qualities*)
  64              (res (list name (cdr (assoc name policy)))))
  65            (loop for (name . nil) in sb-c::*policy-dependent-qualities*
  66                  do (res (list name (sb-c::policy-quality policy name))))
  67            (res))))
  68       (sb-ext:muffle-conditions
  69        (car (rassoc 'muffle-warning
  70                     (sb-c::lexenv-handled-conditions env))))
  71       (t (error "Unsupported declaration ~S." declaration-name)))))
  72
  73 (defun parse-macro (name lambda-list body &optional env)
  74   (declare (ignore env))
  75   (with-unique-names (whole environment)
  76     (multiple-value-bind (body decls)
  77         (parse-defmacro lambda-list whole body name
  78                         'parse-macro
  79                         :environment environment)
  80       `(lambda (,whole ,environment)
  81          ,@decls
  82          ,body))))
  83
  84 (defun enclose (lambda-expression &optional env)
  85   (let ((env (if env
  86                  (sb-c::make-restricted-lexenv env)
  87                  (make-null-lexenv))))
  88     (compile-in-lexenv nil lambda-expression env)))