/[cmucl]/src/code/env-access.lisp
ViewVC logotype

Contents of /src/code/env-access.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Apr 20 17:57:44 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.7: +2 -2 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Mode: Lisp; Package: C; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7
8 (ext:file-comment
9 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/env-access.lisp,v 1.8 2010/04/20 17:57:44 rtoy Rel $")
10
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; The environment access functions specified in Common Lisp the
15 ;;; Language, 2nd edition.
16 ;;;
17
18 (in-package "EXT")
19
20 (intl:textdomain "cmucl")
21
22 (export '(variable-information
23 function-information
24 declaration-information
25 parse-macro))
26
27
28 (in-package "C")
29
30 (defun variable-information (var &optional env)
31 "Returns information about the symbol VAR in the lexical environment ENV.
32 Three values are returned:
33 1) Type or binding of VAR.
34 NIL No definition or binding
35 :special VAR is special
36 :lexical VAR is lexical
37 :symbol-macro VAR refers to a SYMBOL-MACROLET binding
38 :constant VAR refers to a named constant or VAR is a keyword
39 2) non-NIL if there is a local binding
40 3) An a-list containing information about any declarations that apply."
41 (let* ((*lexical-environment* (or env (make-null-environment)))
42 (info (lexenv-find var variables)))
43 (etypecase info
44 (leaf
45 (let ((type (type-specifier
46 (type-intersection
47 (leaf-type info)
48 (or (lexenv-find info type-restrictions)
49 *universal-type*)))))
50 (etypecase info
51 (lambda-var
52 (values :lexical t
53 `((ignore . ,(lambda-var-ignorep info))
54 (type . ,type)
55 (dynamic-extent . ,(lambda-var-dynamic-extent info)))))
56 (global-var
57 (values :special t
58 `((type . ,type))
59 ))
60 (constant
61 (values :constant nil
62 `((type . ,type))
63 )))))
64 (cons
65 (values :symbol-macro t
66 nil))
67 (null
68 (values (ecase (info variable kind var)
69 (:special :special)
70 (:constant :constant)
71 (:macro :symbol-macro)
72 (:global nil))
73 nil
74 `(
75 (type . ,(type-specifier
76 (info variable type var)))))))))
77
78 (defun declaration-information (declaration-name &optional env)
79 "Returns information about declarations named by the symbol DECLARATION-NAME.
80 Supported DECLARATION-NAMES are
81 1) OPTIMIZE
82 A list whose entries are of the form (QUALITY VALUE) is returned,
83 where QUALITY and VALUE are standard optimization qualities and
84 values.
85 2) EXT:OPTIMIZE-INTERFACE
86 Like OPTIMIZE, but for the EXT:OPTIMIZE-INTERFACE declaration.
87 3) DECLARATION.
88 A list of the declaration names the have been proclaimed as valid."
89 (let ((lexenv (or env (make-null-environment))))
90 (case declaration-name
91 (optimize
92 (let ((cookie (lexenv-cookie lexenv)))
93 (list (list 'speed (cookie-speed cookie))
94 (list 'safety (cookie-safety cookie))
95 (list 'compilation-speed (cookie-cspeed cookie))
96 (list 'space (cookie-space cookie))
97 (list 'debug (cookie-debug cookie))
98 (list 'inhibit-warnings (cookie-brevity cookie)))
99 ))
100 (ext:optimize-interface
101 (let ((cookie (lexenv-interface-cookie lexenv)))
102 (list (list 'speed (cookie-speed cookie))
103 (list 'safety (cookie-safety cookie))
104 (list 'compilation-speed (cookie-cspeed cookie))
105 (list 'space (cookie-space cookie))
106 (list 'debug (cookie-debug cookie))
107 (list 'inhibit-warnings (cookie-brevity cookie)))))
108 (declaration
109 (cond (env
110 ;; What are we supposed to do if an environment is
111 ;; given?
112 nil)
113 (t
114 (let ((decls (list 'special 'ftype 'function
115 'inline 'notinline 'maybe-inline
116 'ignore 'ignorable 'optimize 'optimize-interface
117 'type
118 'values)))
119 ;; Do we want to run over the entire list of
120 ;; environments in *info-environment*?
121 (dolist (env ext::*info-environment*)
122 (do-info (env :name name :class class :type type :value value)
123 (when (equal class "DECLARATION")
124 (push name decls))))
125 decls))))
126 (t (error (intl:gettext "Unsupported declaration ~S.") declaration-name)))))
127
128 (defun parse-macro (name lambda-list body &optional env)
129 "Process a macro in the same way that DEFMACRO or MACROLET would.
130 Three values are returned:
131 1) A lambda-expression that accepts two arguments
132 2) A form
133 3) An environment"
134 (declare (ignore env))
135 (let ((whole (gensym "WHOLE-"))
136 (environment (gensym "ENVIRONMENT-")))
137 (multiple-value-bind (body decls)
138 (lisp::parse-defmacro lambda-list whole body name
139 'parse-macro
140 :environment environment)
141 `(lambda (,whole ,environment)
142 ,@decls
143 ,body))))
144
145 (defun function-information (function &optional env)
146 "Returns information about the function name FUNCTION in the lexical environment ENV.
147 Three values are returned:
148 1) Type of definition or binding:
149 NIL No apparent definition
150 :function FUNCTION refers to a function
151 :macro FUNCTION refers to a macro
152 :special-form FUNCTION is a special form
153 2) non-NIL if definition is local
154 3) An a-list containing information about the declarations that apply."
155 (flet ((inlinealist (i)
156 (ecase i
157 (:inline
158 (list '(inline . inline)))
159 (:notinline
160 (list '(inline . notinline)))
161 (:maybe-inline
162 (list '(inline . maybe-inline)))
163 ((nil)
164 nil))))
165 (let* ((*lexical-environment* (or env (make-null-environment)))
166 (info (lexenv-find-function function)))
167 (etypecase info
168 (clambda
169 (let ((type (type-specifier
170 (type-intersection
171 (leaf-type info)
172 (or (lexenv-find info type-restrictions)
173 *universal-type*)))))
174 (values :function
175 t
176 (nconc (if (functional-dynamic-extent info)
177 (list '(dynamic-extent . t)))
178 (inlinealist (functional-inlinep info))
179 (if (not (eq type 'function))
180 (list `(ftype . ,type)))))))
181 (cons
182 (values :macro t nil))
183 (null
184 (multiple-value-bind (kind kindp)
185 (info function kind function)
186 (cond (kindp
187 (ecase kind
188 (:macro
189 (values :macro nil nil))
190 (:special-form
191 (values :special-form nil nil))
192 (:function
193 (values
194 :function
195 nil
196 (nconc (list `(ftype . ,(type-specifier (info function type function))))
197 (inlinealist (info function inlinep function)))))))
198 (t
199 (if (eq kind :function)
200 (values
201 :function
202 nil
203 (nconc (list `(ftype . ,(type-specifier (info function type function))))
204 (inlinealist (info function inlinep function))))
205 (values nil nil nil))))))
206 (defined-function
207 (let ((type (type-specifier
208 (type-intersection
209 (defined-function-type info)
210 (or (lexenv-find info type-restrictions)
211 *universal-type*)))))
212 (values :function
213 nil
214 (nconc (if (not (eq type 'function))
215 (list `(ftype . ,type)))
216 (inlinealist (defined-function-inlinep info ))))))))))
217
218 (defmacro env (&environment env)
219 `(quote ,env))
220
221 (defun augment-environment (env &key variable symbol-macro function macro declare)
222 "Return a new environment containing information in ENV that is augmented
223 by the specified parameters:
224 :VARIABLE a list of symbols visible as bound variables in the new
225 environemnt
226 :SYMBOL-MACRO a list of symbol macro definitions
227 :FUNCTION a list of function names that will be visible as local
228 functions
229 :MACRO a list of local macro definitions
230 :DECLARE a list of declaration specifiers"
231 (when (or macro symbol-macro)
232 (setq env (copy-structure env)))
233 (when macro
234 (setf (lexenv-functions env)
235 (nconc
236 (loop for (name def) in macro
237 collect (cons name (cons 'sys::macro def)))
238 (lexenv-functions env))))
239 (when symbol-macro
240 (setf (lexenv-variables env)
241 (nconc
242 (loop for (name def) in symbol-macro
243 collect (cons name (cons 'sys::macro def)))
244 (lexenv-variables env))))
245 (if (not (or variable function declare))
246 env
247 (handler-bind (((or style-warning)
248 #'(lambda (c)
249 (declare (ignore c))
250 (invoke-restart 'muffle-warning))))
251 (eval:internal-eval
252 `(flet ,(loop for fn in function collect `(,fn ()))
253 (let ,variable
254 (declare ,@declare)
255 (env)))
256 t
257 env))))

  ViewVC Help
Powered by ViewVC 1.1.5