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

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

Add tree-front-end

File size: 5.5 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(provide "TENV")
156
157
Note: See TracBrowser for help on using the repository browser.