source: branches/tfe/ccl/compiler/tfe/tenv.lisp @ 6563

Last change on this file since 6563 was 6563, checked in by gb, 13 years ago

Some more env-processing stuff, just copied from nx.

File size: 8.9 KB
Line 
1
2
3(in-package "CCL")
4
5;;; This should return a VAR (local to/inherited by the current
6;;; lambda definition), an indication of whether that VAR was inherited
7;;; (true) or local (false), and an indication of whether a CATCH
8;;; was established between the variable's binding and this reference.
9(defun tenv-find-lexical-variable (name env)
10  (do* ((e env (lexenv.parent-env e)))
11       ((or (null e) (eq (%svref e 0) 'definition-environment))
12        (error "Bug: lexical variable ~s not found" name))
13    (let* ((vars (lexenv.variables e)))
14      (unless (atom vars)
15        (dolist (v vars)
16          (when (eq (var-name v) name)
17            (return-from tenv-find-lexical-variable v)))))))
18
19(defun tenv-note-lexref (ref var)
20  (let* ((bind-node (var-refs var)))
21    (when bind-node
22      (let* ((last (tbind-refs bind-node)))
23        (setf (tlexref-next ref) last
24              (tbind-refs bind-node) ref)))))
25
26(defun tenv-note-setq (set var)
27  (let* ((bind-node (var-refs var)))
28    (when bind-node
29      (let* ((last (tbind-sets bind-node)))
30        (setf (tsetq-lexical-next set) last
31              (tbind-sets bind-node) set)))))
32
33(defun tenv-effect-vdecls (pending sym env)
34  (let ((vdecls (lexenv.vdecls env))
35        (own nil))
36    (dolist (decl (pending-declarations-vdecls pending) (setf (lexenv.vdecls env) vdecls))
37      (when (eq (car decl) sym) 
38        (push decl vdecls)
39        (push (cdr decl) own)))
40    own))
41
42(defun tenv-need-sym (sym)
43  (if (typep sym 'symbol)
44    sym
45    (error "~S is not a symbol" sym)))
46
47(defun tenv-need-var (sym env)
48  (let* ((sym (tenv-need-sym sym)))
49    (if (constantp sym env)
50      (error "Can't bind or assign to constant ~s." sym)
51      sym)))
52 
53;;; Returns the new variable.
54(defun tenv-init-var (pending var env)
55  (let* ((sym (var-name var))
56         (bits (%i+ (if (nx-proclaimed-special-p sym)
57                      (if (nx-proclaimed-parameter-p sym)
58                        (%ilogior (ash -1 $vbitspecial) (%ilsl $vbitparameter 1))
59                        (ash -1 $vbitspecial))
60                      0)
61                    (if (proclaimed-ignore-p sym) (%ilsl $vbitignore 1) 0))))
62    (push var (lexenv.variables env))
63    (dolist (decl (tenv-effect-vdecls pending sym env))
64      (case (car decl)
65        (special (setq bits (%ilogior bits (ash -1 $vbitspecial) (%ilsl $vbitparameter 1))))
66        (ignore (setq bits (%ilogior bits (%ilsl $vbitignore 1))))
67        (ignore-if-unused (setq bits (%ilogior bits (%ilsl $vbitignoreunused 1))))
68        (dynamic-extent (setq bits (%ilogior bits (%ilsl $vbitdynamicextent 1))))))
69    (setf (var-bits var) bits)
70    var))
71
72(defun tenv-new-var (pending sym env)
73  (tenv-init-var pending (cons-var (tenv-need-var sym env) 0) env))
74
75(defun tenv-new-temp-var (env)
76  (push (cons-var (gensym) 0) (lexenv.variables env)))
77
78
79
80;;; Try to add declarations that aren't already in effect to the
81;;; (innermost contour of) the environment; declarations that
82;;; apply to bindings might already have been added to any contour
83;;; between inner-env (inclusive) and outer-env (exclusive).
84;;; Maintaining separate contours for each binding lets us
85;;; capture the bindings/declarations in effect for each initform,
86;;; but makes stuff like this complicated.
87;;; Type declarations that aren't associated with a (current)
88;;; binding might refine an already-extant declaration, so
89;;; it's necesary to do a type intersection
90(defun tenv-effect-other-decls (pending inner-env outer-env)
91  (flet ((vdecl-exists (v)
92           (do* ((e inner-env (lexenv.parent-env e)))
93                ((eq e outer-env))
94             (if (member v (lexenv.vdecls e))
95               (return t))))
96         (fdecl-exists (f)
97           (do* ((e inner-env (lexenv.parent-env e)))
98                ((eq e outer-env))
99             (if (member f (lexenv.fdecls e))
100               (return t)))))
101    (dolist (f (pending-declarations-fdecls pending))
102      (unless (fdecl-exists f)
103        (push f (lexenv.fdecls inner-env))))
104    (dolist (m (pending-declarations-mdecls pending))
105      (push m (lexenv.mdecls inner-env)))
106    (dolist (v (pending-declarations-vdecls pending))
107      (unless (vdecl-exists v)
108        (when (eq (cadr v) 'type)
109          (let* ((sym (car v))
110                 (other-decls
111                  (nth-value 2 (variable-information sym inner-env)))
112                 (otype (dolist (o other-decls)
113                          (when (eq (cadr o) 'type)
114                            (return o)))))
115            (when otype
116              (multiple-value-bind (intersection sure)
117                  (type-intersection (specifier-type (cddr otype))
118                                     (specifier-type (cddr v)))
119                (when sure
120                  (if (eq intersection *empty-type*)
121                    (warn "Conflicting type declarations for ~s" sym)
122                    (rplacd (cdr v) (type-specifier intersection))))))))
123        (push v (lexenv.vdecls inner-env))))))
124
125;;; The "bits" field of a VAR may point back to the "parent" (the var
126;;; in some ancestor function that the current function (and all intervening
127;;; functions) "inherits".
128(defun tenv-var-bits (var)
129  (do* ((var var bits)
130        (bits (var-bits var) (var-bits var)))
131       ((fixnump bits) bits)))
132
133(defun tenv-check-var-usage (var)
134  (let* ((bits (tenv-var-bits var)))
135    (declare (fixnum bits))
136    (unless (or (logbitp $vbitspecial bits)
137                (logbitp $vbitignorable bits))
138      (let* ((bind (var-refs var)))
139        (when bind                      ; shouldn't this always exist ?
140          (let* ((refs (tbind-refs bind))
141                 (sets (tbind-sets bind)))
142            (if (logbitp $vbitignore bits)
143              (if (or refs sets)
144                (warn "Variable ~s not ignored" (var-name var)))
145              (unless refs
146                (warn "Unused lexical variable ~s" (var-name var))))))))))
147
148(defun tenv-check-env-var-usage (inner-env outer-env)
149  (do* ((env inner-env (lexenv.parent-env env)))
150       ((eq env outer-env))
151    (let* ((vars (lexenv.variables env)))
152      (unless (atom vars)
153        (dolist (v vars) (tenv-check-var-usage v))))))
154
155;;; Pending declarations
156(defstruct tenv-pending-declarations
157  vdecls
158  fdecls
159  mdecls)
160
161(defvar *tenv-standard-declaration-handlers* ())
162
163(defun tenv-bad-decls (decl)
164  (tgen-warn "Invalid declaration: ~s" decl))
165
166(defmacro deftenvdecl (sym lambda-list &body forms)
167  (multiple-value-bind (body decls) (parse-body forms nil t)
168    `(setf (getf *tenv-standard-declaration-handlers* ',sym )
169           (function (lambda ,lambda-list
170                       ,@decls
171                       ,@body)))))
172
173(deftenvdecl special (pending decl env)
174  (declare (ignore env))
175  (dolist (s (%cdr decl))
176    (if (symbolp s) 
177      (tenv-new-vdecl pending s 'special)
178      (tenv-bad-decls decl))))
179
180(deftenvdecl dynamic-extent (pending decl env)
181  (declare (ignore env))
182  (dolist (s (%cdr decl))
183    (if (symbolp s) 
184      (tenv-new-vdecl pending s 'dynamic-extent t)
185      (if (and (consp s)
186               (eq (%car s) 'function)
187               (consp (%cdr s))
188               (valid-function-name-p (cadr s))
189               (setq s (validate-function-name (cadr s))))
190        (tenv-new-fdecl pending s 'dynamic-extent t)
191        (tenv-bad-decls decl)))))
192
193(deftenvdecl ignorable (pending decl env)
194  (declare (ignore env))
195  (dolist (s (%cdr decl))
196    (if (symbolp s) 
197      (tenv-new-vdecl pending s 'ignore-if-unused t)
198      (if (and (consp s)
199               (eq (%car s) 'function)
200               (consp (%cdr s))
201               (valid-function-name-p (cadr s))
202               (setq s (validate-function-name (cadr s))))
203        (tenv-new-fdecl pending s 'ignore-if-unused t)
204        (tenv-bad-decls decl)))))
205
206(deftenvdecl ftype (pending decl env)
207  (declare (ignore env))
208  (destructuring-bind (type &rest fnames) (%cdr decl)
209    (dolist (s fnames)
210      (tenv-new-fdecl pending s 'ftype type))))
211
212(deftenvdecl settable (pending decl env)
213  (tenv-settable-decls pending decl env t))
214
215(deftenvdecl unsettable (pending decl env)
216  (tenv-settable-decls pending decl env nil))
217
218(defun tenv-settable-decls (pending decl env val)
219  (declare (ignore env))
220  (dolist (s (%cdr decl))
221    (if (symbolp s)
222      (tenv-new-vdecl pending s 'settable val)
223      (tenv-bad-decls decl))))
224
225(deftenvdecl type (pending decl env)
226  (declare (ignore env))
227  (let* ((spec (%cdr decl))
228         (type (car spec))
229         (ctype (specifier-type type)))
230    (unless (typep ctype 'unknown-ctype)
231      (dolist (sym (cdr spec))
232        (if (symbolp sym)
233          (tenv-new-vdecl pending sym 'type (type-specifier ctype))
234          (tenv-bad-decls decl))))))
235
236(defun tenv-inline-decl (pending decl val &aux valid-name)
237  (dolist (s (%cdr decl))
238    (multiple-value-setq (valid-name s) (valid-function-name-p s))
239    (if valid-name
240      (progn
241        (if (tenv-self-call-p s nil t)
242          (setq *tenv-inlined-self* val))
243        (tenv-new-fdecl pending s 'inline (if val 'inline 'notinline)))
244      (tenv-bad-decls decl))))
245
246(deftenvdecl inline (pending decl env)
247  (declare (ignore env))
248  (tenv-inline-decl pending decl t))
249
250(deftenvdecl notinline (pending decl env)
251  (declare (ignore env))
252  (tenv-inline-decl pending decl nil))
253
254
255(defun tenv-new-vdecl (pending name class &optional info)
256  (push (cons name (cons class info)) (tenv-pending-declarations-vdecls pending)))
257
258(defun tenv-new-fdecl (pending name class &optional info)
259  (push (cons name (cons class info)) (tenv-pending-declarations-fdecls pending)))
260
261(defun tenv-new-mdecl (pending name class &optional info)
262  (push (cons name (cons class info)) (tenv-pending-declarations-mdecls pending)))
263
264
265
266(provide "TENV")
267
268
Note: See TracBrowser for help on using the repository browser.