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