/[gcl]/gcl/cmpnew/gcl_cmplet.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmplet.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.17 by pfdietz, Sat Aug 27 00:11:17 2005 UTC revision 1.18 by camm, Sun Sep 18 01:53:38 2005 UTC
# Line 134  Line 134 
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
# Line 162  Line 180 
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    
# Line 299  Line 352 
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)

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26