/[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.3 by camm, Sat Mar 20 17:42:13 2004 UTC revision 1.4 by camm, Sat Dec 11 00:34:35 2004 UTC
# Line 28  Line 28 
28  (si:putprop 'let* 'c1let* 'c1special)  (si:putprop 'let* 'c1let* 'c1special)
29  (si:putprop 'let* 'c2let* 'c2)  (si:putprop 'let* 'c2let* 'c2)
30    
31    (defvar *decls* nil)
32    
33    ;;FIXME centralize this
34    (defun push-macrolets (form)
35      (dolist** (def form)
36                (push (list (car def)
37                            (caddr (si:defmacro* (car def) (cadr def) (cddr def))))
38                      *funs*)))
39    
40    (defun recursively-cmp-macroexpand (form &optional bf &aux (*funs* *funs*))
41      (if (atom form)
42          form
43        (let ((cf (car form)))
44          (let ((new-cdr-bf (or (and (consp bf) (if (atom (car bf)) bf
45                                                  (and (member (caar bf) '(flet labels macrolet) :test #'eq) 'lambda)))
46                                (car (member cf '(let let* lambda flet labels macrolet quote)))))
47                (new-car-bf (and (consp cf) bf (list bf)))
48                (new-cf (if (or bf (atom cf) (eq (car cf) 'lambda))
49                            cf (cmp-macroexpand cf))))
50            (cons (recursively-cmp-macroexpand new-cf new-car-bf)
51                  (progn
52                    (when (eq bf 'macrolet)
53                      (push-macrolets cf))
54                    (recursively-cmp-macroexpand (cdr form) new-cdr-bf)))))))
55    
56    (defun var-is-changed (var form)
57      (cond ((atom form) nil)
58            ((and (eq (car form) 'setq)
59                  (let ((tmp (member var (cdr form) :test #'eq))) (and tmp (evenp (length tmp)))))
60             t)
61            (t (or (if (atom (car form)) nil (var-is-changed var (car form)))
62                   (var-is-changed var (cdr form))))))
63    
64    (defun var-type-position (var form procl)
65      (let ((pos (and (consp form) (position var form))))
66        (if (not pos) t
67          (type-and (or (nth pos procl) t)
68                    (let ((pos (1+ pos)))
69                      (var-type-position var (nthcdr pos form) (nthcdr pos procl)))))))
70    
71    (defun var-is-inferred (var form)
72      (if (atom form) t
73        (let ((procl (and (consp (car form)) (symbolp (caar form)) (get (caar form) 'compiler::proclaimed-arg-types))))
74          (type-and (if procl (var-type-position var (cdar form) procl) t)
75                    (type-and (var-is-inferred var (car form)) (var-is-inferred var (cdr form)))))))
76    
77    (defun var-in-decl (var form)
78      (and form (or (member var (cdar form) :test #'eq) (var-in-decl var (cdr form)))))
79    
80    (defun var-is-declared (var form)
81      (cond ((atom form) nil)
82            ((stringp (car form)) (var-is-declared var (cdr form)))
83            ((and (consp (car form)) (eq 'declare (caar form)))
84             (or (var-in-decl var (cdar form))
85                 (var-is-declared var (cdr form))))
86            (t nil)))
87    
88    (defun t-to-nil (x)
89      (if (eq x t) nil x))
90    
91    (defun binding-decls (bindings body star)
92      (cond ((atom bindings) nil)
93            ((atom (car bindings)) (binding-decls (cdr bindings) body star))
94            (t
95             (let* ((bf (car bindings))
96                    (var (car bf)))
97               (let ((outer (and (symbolp (cadr bf)) (cdr (assoc (cadr bf) *decls*))))
98                     (inf (t-to-nil (var-is-inferred var body)))
99                     (exp (and (consp (cadr bf)) (eq (caadr bf) 'the) (cadadr bf)))
100                     (proc (and (consp (cadr bf))
101                                (symbolp (caadr bf))
102                                (t-to-nil (get (caadr bf) 'compiler::proclaimed-return-type))))
103                     (dec (var-is-declared var body))
104                     (chb (var-is-changed var body))
105                     (chc (and star (var-is-changed var (cdr bindings)))))
106                 (let ((type (or exp (and (symbolp proc) proc) inf outer))
107                       (ublk (not (or dec chb chc))))
108                   (if type
109                       (progn
110                         (cmpnote "var ~S is type ~S from ~a, ~a~%"
111                                  var type (cond (exp "explicit declaration")
112                                                 ((and (symbolp proc) proc) "proclamation")
113                                                 (inf "argument inference")
114                                                 (outer "outer scope"))
115                                  (cond (dec "but is already declared")
116                                        (chb "but is changed in body")
117                                        (chc "but is changed in other bindings")
118                                        (t "declaring")))
119                         (if ublk
120                             (cons (list type var) (binding-decls (cdr bindings) body star))
121                           (binding-decls (cdr bindings) body star)))
122                     (binding-decls (cdr bindings) body star))))))))
123    
124    ;(type (or (and (symbolp (cadr bf)) (cdr (assoc (cadr bf) *decls*)))
125    ;                         (t-to-nil (var-is-inferred var body))
126    ;                         (and (consp (cadr bf))
127    ;                              (if (eq (caadr bf) 'the) (cadadr bf)
128    ;                                (and (symbolp (caadr bf))
129    ;                                     (t-to-nil (get (caadr bf) 'compiler::proclaimed-return-type))))))))
130    ;          (if (and type
131    ;                   (symbolp type)
132    ;                   (not (var-is-declared var body))
133    ;                   (not (var-is-changed var body))
134    ;                   (or (not star) (not (var-is-changed var (cdr bindings)))))
135    ;              (cons (list type var) (binding-decls (cdr bindings) body star))
136    ;            (binding-decls (cdr bindings) body star))))))
137      
138    (defun declare-let-bindings (args)
139      (let ((decls (binding-decls (car args) (recursively-cmp-macroexpand (cdr args)) nil)))
140        (if decls
141            (progn (cmpnote "Let bindings ~S declared ~S~%" (car args) decls)
142                   (cons (car args) (cons (cons 'declare decls) (cdr args))))
143          args)))
144    
145    (defun declare-let*-bindings (args)
146      (let ((decls (binding-decls
147                    (recursively-cmp-macroexpand (car args) (list 'let*))
148                    (recursively-cmp-macroexpand (cdr args))
149                    t)))
150        (if decls
151            (progn (cmpnote "Let* bindings ~S declared ~S~%" (car args) decls)
152                   (cons (car args) (cons (cons 'declare decls) (cdr args))))
153          args)))
154    
155  (defun c1let (args &aux (info (make-info))(setjmps *setjmps*)  (defun c1let (args &aux (info (make-info))(setjmps *setjmps*)
156                          (forms nil) (vars nil) (vnames nil)                          (forms nil) (vars nil) (vnames nil)
157                          ss is ts body other-decls                          ss is ts body other-decls
158                          (*vars* *vars*))                          (*vars* *vars*) (*decls* *decls*))
159    (when (endp args) (too-few-args 'let 1 0))    (when (endp args) (too-few-args 'let 1 0))
160    
161      (setq args (declare-let-bindings args))
162    
163    (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))
164    
165    (c1add-globals ss)    (c1add-globals ss)
# Line 160  Line 286 
286  (defun c1let* (args &aux (forms nil) (vars nil) (vnames nil)  (defun c1let* (args &aux (forms nil) (vars nil) (vnames nil)
287                  (setjmps *setjmps*)                  (setjmps *setjmps*)
288                      ss is ts body other-decls                      ss is ts body other-decls
289                      (info (make-info)) (*vars* *vars*))                      (info (make-info)) (*vars* *vars*) (*decls* *decls*))
290    (when (endp args) (too-few-args 'let* 1 0))    (when (endp args) (too-few-args 'let* 1 0))
291    
292      (setq args (declare-let*-bindings args))
293    
294    (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))
295    (c1add-globals ss)    (c1add-globals ss)
296    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

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