134 |
(if (and type (not ch)) (cons (list type var) out) out) specials))))))) |
(if (and type (not ch)) (cons (list type var) out) out) specials))))))) |
135 |
|
|
136 |
|
|
137 |
|
|
138 |
|
(defun binding-decls-new1 (star out specials body-info nvars ninfos) |
139 |
|
(cond ((atom nvars) (nreverse out)) |
140 |
|
((let* ((var (car nvars)) |
141 |
|
(type (t-to-nil (coerce-to-one-value (info-type (car ninfos))))) |
142 |
|
(n (var-name var)) |
143 |
|
(ch (or (si::specialp n) (member n specials) |
144 |
|
(is-changed var body-info) |
145 |
|
(member-if (lambda (x) (is-changed var x)) (cdr ninfos))))) |
146 |
|
(when type |
147 |
|
(cmpnote "var ~S is type ~S from type propagation, ~a~%" n type |
148 |
|
(if ch "but is changed" "declaring"))) |
149 |
|
(binding-decls-new1 star |
150 |
|
(if (and type (not ch)) (cons (list type n) out) out) |
151 |
|
specials |
152 |
|
body-info (cdr nvars) (cdr ninfos)))))) |
153 |
|
|
154 |
|
|
155 |
;;FIXME -- We can eliminate the extra recursively-cmp-macroexpand |
;;FIXME -- We can eliminate the extra recursively-cmp-macroexpand |
156 |
;;code, the logic of which as already provided in a somewhat differing |
;;code, the logic of which as already provided in a somewhat differing |
157 |
;;form by pass1, and extract the changed variable information from the |
;;form by pass1, and extract the changed variable information from the |
180 |
args)))) |
args)))) |
181 |
|
|
182 |
|
|
183 |
|
(defun make-bindings-var-info (bindings star vars infos) |
184 |
|
(cond ((atom bindings) (list (nreverse vars) (nreverse infos))) |
185 |
|
((let* ((cb (consp (car bindings))) |
186 |
|
(n (if cb (caar bindings) (car bindings))) |
187 |
|
(info (if cb (cadr (c1expr (cadar bindings))) (make-info))) |
188 |
|
(var (c1make-var n nil nil (list (cons n (info-type info)))))) |
189 |
|
(let ((*vars* (if star (cons var *vars*) *vars*))) |
190 |
|
(make-bindings-var-info (cdr bindings) star (cons var vars) (cons info infos))))))) |
191 |
|
|
192 |
|
|
193 |
|
(defvar *dlbs* 0) |
194 |
|
(defvar *dlbsrl* 2) |
195 |
|
|
196 |
|
(defun declare-let-bindings-new1 (args star specials) |
197 |
|
(if (>= *dlbs* *dlbsrl*) args |
198 |
|
(let ((*dlbs* (1+ *dlbs*))) |
199 |
|
(let ((res |
200 |
|
(let ((*suppress-compiler-warnings* t) |
201 |
|
(*suppress-compiler-notes* t)) |
202 |
|
(let* ((body-info (make-info)) |
203 |
|
(bvi (make-bindings-var-info (car args) star nil nil)) |
204 |
|
(nv (car bvi)) |
205 |
|
(ni (cadr bvi))) |
206 |
|
(let ((*vars* *vars*)) |
207 |
|
(dolist (v nv) (push v *vars*)) |
208 |
|
(c1args (c1body (cdr args) nil) body-info) |
209 |
|
(list body-info nv ni)))))) |
210 |
|
(let ((decls (binding-decls-new1 star nil specials (car res) (cadr res)(caddr res)))) |
211 |
|
(if decls |
212 |
|
(progn (cmpnote "Let bindings ~S declared ~S~%" (car args) decls) |
213 |
|
(cons (car args) (cons (cons 'declare decls) (cdr args)))) |
214 |
|
args)))))) |
215 |
|
|
216 |
|
|
217 |
(defun c1let (args &aux (info (make-info))(setjmps *setjmps*) |
(defun c1let (args &aux (info (make-info))(setjmps *setjmps*) |
218 |
(forms nil) (vars nil) (vnames nil) |
(forms nil) (vars nil) (vnames nil) |
219 |
ss is ts body other-decls |
ss is ts body other-decls |
220 |
(*vars* *vars*)) |
(*vars* *vars*)) |
221 |
(when (endp args) (too-few-args 'let 1 0)) |
(when (endp args) (too-few-args 'let 1 0)) |
222 |
|
|
223 |
(setq args (declare-let-bindings-new args nil ss)) |
; (setq args (declare-let-bindings-new args nil ss)) |
224 |
|
(setq args (declare-let-bindings-new1 args nil ss)) |
225 |
|
|
226 |
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
227 |
|
|
352 |
(info (make-info)) (*vars* *vars*)) |
(info (make-info)) (*vars* *vars*)) |
353 |
(when (endp args) (too-few-args 'let* 1 0)) |
(when (endp args) (too-few-args 'let* 1 0)) |
354 |
|
|
355 |
(setq args (declare-let-bindings-new args t ss)) |
(setq args (declare-let-bindings-new1 args t ss)) |
356 |
|
|
357 |
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
358 |
(c1add-globals ss) |
(c1add-globals ss) |