157 |
(push var vrefs) |
(push var vrefs) |
158 |
(push-changed (car var) info) |
(push-changed (car var) info) |
159 |
) |
) |
160 |
|
(setf (info-type info) (type-and (info-type (cadar (c1args (car args) info))) |
161 |
|
(info-type (cadar (c1args (cdr args) info))))) |
162 |
(list 'multiple-value-setq info (reverse vrefs) (c1expr* (cadr args) info)) |
(list 'multiple-value-setq info (reverse vrefs) (c1expr* (cadr args) info)) |
163 |
) |
) |
164 |
|
|
205 |
(t (unless (eq *exit* 'return) (wt-nl) (reset-top)) |
(t (unless (eq *exit* 'return) (wt-nl) (reset-top)) |
206 |
(unwind-exit (cons 'var (car vrefs)))))) |
(unwind-exit (cons 'var (car vrefs)))))) |
207 |
|
|
208 |
|
(defun form-to-values-type (form) |
209 |
|
(if (and (consp form) (eq (car form) 'values)) form |
210 |
|
(let ((frt (fun-ret-type form))) |
211 |
|
(if (and (consp frt) (eq (car frt) 'values)) frt |
212 |
|
(list 'values frt))))) |
213 |
|
|
214 |
|
(defun multiple-binding-decls (vars mv-form body &optional expn vls) |
215 |
|
(cond ((and (not expn) (not vls) (not (eq (car mv-form) 'values)) (symbolp (car mv-form))) |
216 |
|
(let ((mv-form (form-to-values-type mv-form))) |
217 |
|
(multiple-binding-decls vars mv-form body t vls))) |
218 |
|
((eq (car mv-form) 'values) |
219 |
|
(multiple-binding-decls vars (cdr mv-form) body expn t)) |
220 |
|
((or (null vars) (null mv-form)) nil) |
221 |
|
(t |
222 |
|
(let ((var (car vars))) |
223 |
|
(let ((outer (and (symbolp (car mv-form)) (cdr (assoc (car mv-form) *decls*)))) |
224 |
|
(inf (t-to-nil (var-is-inferred var body))) |
225 |
|
(exp (and (consp (car mv-form)) (eq (caar mv-form) 'the) (cadar mv-form))) |
226 |
|
(typ (and expn (t-to-nil (car mv-form)))) |
227 |
|
(frt (and (consp (car mv-form)) |
228 |
|
(symbolp (caar mv-form)) |
229 |
|
(t-to-nil (coerce-to-one-value (fun-ret-type (car mv-form)))))) |
230 |
|
(dec (var-is-declared var body)) |
231 |
|
(chb (var-is-changed var body))) |
232 |
|
(let ((type (or exp typ frt inf outer)) |
233 |
|
(ublk (not (or dec chb)))) |
234 |
|
(if type |
235 |
|
(progn |
236 |
|
(cmpnote "var ~S is type ~S from ~a, ~a~%" |
237 |
|
var type (cond (exp "explicit declaration") |
238 |
|
(typ "deduced multiple-value function return type") |
239 |
|
(frt "deduced function return type") |
240 |
|
(inf "argument inference") |
241 |
|
(outer "outer scope")) |
242 |
|
(cond (dec "but is already declared") |
243 |
|
(chb "but is changed in body") |
244 |
|
(t "declaring"))) |
245 |
|
(if ublk |
246 |
|
(cons (list type var) |
247 |
|
(multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)) |
248 |
|
(multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))) |
249 |
|
(multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)))))))) |
250 |
|
|
251 |
|
|
252 |
|
|
253 |
|
|
254 |
|
(defun declare-multiple-value-bindings (args) |
255 |
|
(let ((decls (multiple-binding-decls |
256 |
|
(car args) |
257 |
|
(recursively-cmp-macroexpand (cadr args)) |
258 |
|
(recursively-cmp-macroexpand (cddr args))))) |
259 |
|
(if decls |
260 |
|
(progn (cmpnote "multiple-value bindings ~S ~S declared ~S~%" (car args) (cadr args) decls) |
261 |
|
(cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args))))) |
262 |
|
args))) |
263 |
|
|
264 |
|
|
265 |
(defun c1multiple-value-bind (args &aux (info (make-info)) |
(defun c1multiple-value-bind (args &aux (info (make-info)) |
266 |
(vars nil) (vnames nil) init-form |
(vars nil) (vnames nil) init-form |
267 |
ss is ts body other-decls |
ss is ts body other-decls |
269 |
(when (or (endp args) (endp (cdr args))) |
(when (or (endp args) (endp (cdr args))) |
270 |
(too-few-args 'multiple-value-bind 2 (length args))) |
(too-few-args 'multiple-value-bind 2 (length args))) |
271 |
|
|
272 |
|
(setq args (declare-multiple-value-bindings args)) |
273 |
|
|
274 |
(multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil)) |
(multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil)) |
275 |
|
|
276 |
(c1add-globals ss) |
(c1add-globals ss) |