/[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 - (hide annotations)
Tue Apr 20 17:57:44 2010 UTC (4 years 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 rtoy 1.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 rtoy 1.8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/env-access.lisp,v 1.8 2010/04/20 17:57:44 rtoy Rel $")
10 rtoy 1.1
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 rtoy 1.6 (intl:textdomain "cmucl")
21    
22 rtoy 1.1 (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 rtoy 1.7 "Returns information about the symbol VAR in the lexical environment ENV.
32 rtoy 1.5 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 rtoy 1.1 (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 rtoy 1.7 "Returns information about declarations named by the symbol DECLARATION-NAME.
80 rtoy 1.5 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 rtoy 1.2 (let ((lexenv (or env (make-null-environment))))
90 rtoy 1.1 (case declaration-name
91     (optimize
92 rtoy 1.2 (let ((cookie (lexenv-cookie lexenv)))
93 rtoy 1.1 (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 cshapiro 1.4 (list 'inhibit-warnings (cookie-brevity cookie)))
99 rtoy 1.1 ))
100     (ext:optimize-interface
101 rtoy 1.2 (let ((cookie (lexenv-interface-cookie lexenv)))
102 rtoy 1.1 (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 cshapiro 1.4 (list 'inhibit-warnings (cookie-brevity cookie)))))
108 rtoy 1.2 (declaration
109     (cond (env
110     ;; What are we supposed to do if an environment is
111     ;; given?
112     nil)
113     (t
114 rtoy 1.3 (let ((decls (list 'special 'ftype 'function
115     'inline 'notinline 'maybe-inline
116     'ignore 'ignorable 'optimize 'optimize-interface
117     'type
118     'values)))
119 rtoy 1.2 ;; 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 rtoy 1.3 decls))))
126 rtoy 1.8 (t (error (intl:gettext "Unsupported declaration ~S.") declaration-name)))))
127 rtoy 1.1
128     (defun parse-macro (name lambda-list body &optional env)
129 rtoy 1.7 "Process a macro in the same way that DEFMACRO or MACROLET would.
130 rtoy 1.5 Three values are returned:
131     1) A lambda-expression that accepts two arguments
132     2) A form
133     3) An environment"
134 rtoy 1.1 (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 rtoy 1.7 "Returns information about the function name FUNCTION in the lexical environment ENV.
147 rtoy 1.5 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 rtoy 1.1 (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 rtoy 1.3 (defmacro env (&environment env)
219     `(quote ,env))
220    
221 rtoy 1.1 (defun augment-environment (env &key variable symbol-macro function macro declare)
222 rtoy 1.7 "Return a new environment containing information in ENV that is augmented
223 rtoy 1.5 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 rtoy 1.1 (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 rtoy 1.3 (eval:internal-eval
252 rtoy 1.1 `(flet ,(loop for fn in function collect `(,fn ()))
253     (let ,variable
254     (declare ,@declare)
255     (env)))
256 rtoy 1.3 t
257 rtoy 1.1 env))))

  ViewVC Help
Powered by ViewVC 1.1.5