123 |
;; so if we know there's one value only: |
;; so if we know there's one value only: |
124 |
(c1expr (car args))) |
(c1expr (car args))) |
125 |
(t (setq args (c1args args info)) |
(t (setq args (c1args args info)) |
126 |
(list 'values info args)))) |
(setf (info-type info) (cons 'values (mapcar (lambda (x) (info-type (cadr x))) args))) |
127 |
|
(list 'values info args)))) |
128 |
|
|
129 |
(defun c2values (forms &aux (base *vs*) (*vs* *vs*)) |
(defun c2values (forms &aux (base *vs*) (*vs* *vs*)) |
130 |
(cond ((and (eq *value-to-go* 'return-object) |
(cond ((and (eq *value-to-go* 'return-object) |
206 |
(t (unless (eq *exit* 'return) (wt-nl) (reset-top)) |
(t (unless (eq *exit* 'return) (wt-nl) (reset-top)) |
207 |
(unwind-exit (cons 'var (car vrefs)))))) |
(unwind-exit (cons 'var (car vrefs)))))) |
208 |
|
|
209 |
(defun form-to-values-type (form) |
;(defun form-to-values-type (form) |
210 |
(if (and (consp form) (eq (car form) 'values)) form |
; (if (and (consp form) (eq (car form) 'values)) form |
211 |
(let ((frt (info-type (cadr (c1symbol-fun (car form) (cdr form)))))) |
; (let ((frt (info-type (cadr (c1symbol-fun (car form) (cdr form)))))) |
212 |
(if (and (consp frt) (eq (car frt) 'values)) frt |
; (if (and (consp frt) (eq (car frt) 'values)) frt |
213 |
(list 'values frt))))) |
; (list 'values frt))))) |
|
|
|
|
(defun multiple-binding-decls (vars mv-form body &optional expn vls) |
|
|
(cond ((and (not expn) (not vls) (not (eq (car mv-form) 'values)) (symbolp (car mv-form))) |
|
|
(let ((mv-form (form-to-values-type mv-form))) |
|
|
(multiple-binding-decls vars mv-form body t vls))) |
|
|
((eq (car mv-form) 'values) |
|
|
(multiple-binding-decls vars (cdr mv-form) body expn t)) |
|
|
((or (null vars) (null mv-form)) nil) |
|
|
(t |
|
|
(let ((var (car vars))) |
|
|
(let ((outer (and (not expn) (symbolp (car mv-form)) (cdr (assoc (car mv-form) *decls*)))) |
|
|
(inf (t-to-nil (var-is-inferred var body))) |
|
|
(exp (and (not expn) (consp (car mv-form)) (eq (caar mv-form) 'the) (cadar mv-form))) |
|
|
(typ (and expn (t-to-nil (car mv-form)))) |
|
|
(frt (and (not expn) (consp (car mv-form)) |
|
|
(symbolp (caar mv-form)) |
|
|
(t-to-nil |
|
|
(coerce-to-one-value |
|
|
(info-type |
|
|
(cadr |
|
|
(c1symbol-fun (caar mv-form) (cdar mv-form)))))))) |
|
|
(dec (var-is-declared var body)) |
|
|
(chb (var-is-changed var body))) |
|
|
(let ((type (or exp typ frt inf outer)) |
|
|
(ublk (not (or chb)))) |
|
|
(if type |
|
|
(progn |
|
|
(cmpnote "var ~S is type ~S from ~a, ~a~%" |
|
|
var type (cond (exp "explicit declaration") |
|
|
(typ "deduced multiple-value function return type") |
|
|
(frt "deduced function return type") |
|
|
(inf "argument inference") |
|
|
(outer "outer scope")) |
|
|
(cond (dec "is already declared, but amending declaration") |
|
|
(chb "but is changed in body") |
|
|
(t "declaring"))) |
|
|
(if ublk |
|
|
(cons (list type var) |
|
|
(multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)) |
|
|
(multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))) |
|
|
(multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)))))))) |
|
|
|
|
|
|
|
214 |
|
|
215 |
|
|
216 |
|
;;FIXME -- this still uses pass1, while let for performance reasons uses custom change-detection code. |
217 |
(defun declare-multiple-value-bindings (args) |
(defun declare-multiple-value-bindings (args) |
218 |
(let ((decls (multiple-binding-decls |
(let ((info (make-info)) |
219 |
(car args) |
(newvars *vars*)) |
220 |
(recursively-cmp-macroexpand (cadr args)) |
(dolist (var (car args)) |
221 |
(recursively-cmp-macroexpand (cddr args))))) |
(push (c1make-var var nil nil nil) newvars)) |
222 |
(if decls |
(let ((*vars* newvars)) |
223 |
(progn (cmpnote "multiple-value bindings ~S ~S declared ~S~%" (car args) (cadr args) decls) |
(c1args (c1body (cddr args) nil) info)) |
224 |
(cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args))))) |
(let ((expt (info-type (cadr (c1expr (cadr args)))))) |
225 |
args))) |
(let ((decls (remove-if-not #'t-to-nil |
226 |
|
(if (and (consp expt) (eq (car expt) 'values)) |
227 |
|
(mapcar #'list (cdr expt) (car args)) |
228 |
|
(list (list expt (caar args)))) :key #'car))) |
229 |
|
(let ((decls (remove-if |
230 |
|
(lambda (x) |
231 |
|
(let ((nv (car (member x newvars :key #'var-name :test #'eq)))) |
232 |
|
(when (is-changed nv info) |
233 |
|
(cmpnote "Multiple-value-binding ~S is changed and cannot be declared~%" x) |
234 |
|
t))) decls :key #'cadr))) |
235 |
|
(if decls |
236 |
|
(progn (cmpnote "Multiple-value bindings ~S of type ~S~%" (car args) decls ) |
237 |
|
(cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args))))) |
238 |
|
args)))))) |
239 |
|
|
240 |
|
;(defun multiple-binding-decls (vars mv-form body &optional expn vls) |
241 |
|
; (cond ((and (not expn) (not vls) (not (eq (car mv-form) 'values)) (symbolp (car mv-form))) |
242 |
|
; (let ((mv-form (form-to-values-type mv-form))) |
243 |
|
; (multiple-binding-decls vars mv-form body t vls))) |
244 |
|
; ((eq (car mv-form) 'values) |
245 |
|
; (multiple-binding-decls vars (cdr mv-form) body expn t)) |
246 |
|
; ((or (null vars) (null mv-form)) nil) |
247 |
|
; (t |
248 |
|
; (let ((var (car vars))) |
249 |
|
; (let ((outer (var-type-from-symbol-name (car mv-form))) |
250 |
|
; (inf (t-to-nil (var-is-inferred var body))) |
251 |
|
; (exp (and (not expn) (consp (car mv-form)) (eq (caar mv-form) 'the) (cadar mv-form))) |
252 |
|
; (typ (and expn (t-to-nil (car mv-form)))) |
253 |
|
; (frt (and (not expn) (consp (car mv-form)) |
254 |
|
; (symbolp (caar mv-form)) |
255 |
|
; (t-to-nil |
256 |
|
; (coerce-to-one-value |
257 |
|
; (info-type |
258 |
|
; (cadr |
259 |
|
; (c1symbol-fun (caar mv-form) (cdar mv-form)))))))) |
260 |
|
; (dec (var-is-declared var body)) |
261 |
|
; (chb (var-is-changed var body))) |
262 |
|
; (let ((type (or exp typ frt inf outer)) |
263 |
|
; (ublk (not (or chb)))) |
264 |
|
; (if type |
265 |
|
; (progn |
266 |
|
; (cmpnote "var ~S is type ~S from ~a, ~a~%" |
267 |
|
; var type (cond (exp "explicit declaration") |
268 |
|
; (typ "deduced multiple-value function return type") |
269 |
|
; (frt "deduced function return type") |
270 |
|
; (inf "argument inference") |
271 |
|
; (outer "outer scope")) |
272 |
|
; (cond (dec "is already declared, but amending declaration") |
273 |
|
; (chb "but is changed in body") |
274 |
|
; (t "declaring"))) |
275 |
|
; (if ublk |
276 |
|
; (cons (list type var) |
277 |
|
; (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)) |
278 |
|
; (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))) |
279 |
|
; (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)))))))) |
280 |
|
|
281 |
|
|
282 |
|
;(defun declare-multiple-value-bindings (args) |
283 |
|
; (let ((decls (multiple-binding-decls |
284 |
|
; (car args) |
285 |
|
; (recursively-cmp-macroexpand (cadr args)) |
286 |
|
; (recursively-cmp-macroexpand (cddr args))))) |
287 |
|
; (if decls |
288 |
|
; (progn (cmpnote "multiple-value bindings ~S ~S declared ~S~%" (car args) (cadr args) decls) |
289 |
|
; (cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args))))) |
290 |
|
; args))) |
291 |
|
|
292 |
|
|
293 |
(defun c1multiple-value-bind (args &aux (info (make-info)) |
(defun c1multiple-value-bind (args &aux (info (make-info)) |
294 |
(vars nil) (vnames nil) init-form |
(vars nil) (vnames nil) init-form |
295 |
ss is ts body other-decls |
ss is ts body other-decls |
296 |
(*vars* *vars*) (*decls* *decls*)) |
(*vars* *vars*)) |
297 |
(when (or (endp args) (endp (cdr args))) |
(when (or (endp args) (endp (cdr args))) |
298 |
(too-few-args 'multiple-value-bind 2 (length args))) |
(too-few-args 'multiple-value-bind 2 (length args))) |
299 |
|
|