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 sb-kernel: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   (let* ((*lexenv* (or env (sb-kernel:make-null-lexenv)))
  19          (info (lexenv-find var vars)))
  20     (etypecase info
  21       (sb-c::leaf (let ((type (sb-kernel:type-specifier
  22                                (sb-kernel:type-intersection
  23                                 (sb-c::leaf-type info)
  24                                 (or (lexenv-find info type-restrictions)
  25                                     sb-kernel:*universal-type*)))))
  26                     (etypecase info
  27                       (sb-c::lambda-var
  28                        (values :lexical t
  29                                `((ignore . ,(sb-c::lambda-var-ignorep info))
  30                                  (type . ,type))))
  31                       (sb-c::global-var
  32                        (values :special t
  33                                `((type . ,type)) ; XXX ignore
  34                                ))
  35                       (sb-c::constant
  36                        (values :constant nil
  37                                `((type . ,type)) ; XXX ignore
  38                                )))))
  39       (cons (values :symbol-macro t
  40                     nil                 ; FIXME: also in the compiler
  41                     ))
  42       (null (values (ecase (info :variable :kind var)
  43                       (:special :special)
  44                       (:constant :constant)
  45                       (:macro :symbol-macro)
  46                       (:global nil))
  47                     nil
  48                     `(                  ; XXX ignore
  49                       (type . ,(sb-kernel:type-specifier ; XXX local type
  50                                 (info :variable :type var)))))))))
  51
  52 (defun parse-macro (name lambda-list body
  53                     &optional env)
  54   (declare (ignore env))
  55   (with-unique-names (whole environment)
  56     (multiple-value-bind (body decls)
  57         (sb-kernel:parse-defmacro lambda-list whole body name
  58                                   'parse-macro
  59                                   :environment environment)
  60       `(lambda (,whole ,environment)
  61          ,@decls
  62          ,body))))
  63
  64 (defun enclose (lambda-expression
  65                 &optional env)
  66   (let ((env (if env
  67                  (sb-c::make-restricted-lexenv env)
  68                  (sb-kernel:make-null-lexenv))))
  69     (compile-in-lexenv nil lambda-expression env)))