1.0.0.15: build fix & cleanup
[sbcl.git] / 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)))