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 (defun parse-macro (name lambda-list body &optional env)
  56   (declare (ignore env))
  57   (with-unique-names (whole environment)
  58     (multiple-value-bind (body decls)
  59         (parse-defmacro lambda-list whole body name
  60                         'parse-macro
  61                         :environment environment)
  62       `(lambda (,whole ,environment)
  63          ,@decls
  64          ,body))))
  65
  66 (defun enclose (lambda-expression &optional env)
  67   (let ((env (if env
  68                  (sb-c::make-restricted-lexenv env)
  69                  (make-null-lexenv))))
  70     (compile-in-lexenv nil lambda-expression env)))