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 | |
---|