- (multiple-value-bind (ctypes count) (no-fun-values-types ctype)
- (multiple-value-bind (atypes acount) (no-fun-values-types atype)
- (multiple-value-bind (vtypes vcount) (values-types vtype)
- (declare (ignore vtypes))
- (aver (eq count acount))
- (cond ((not (eq count :unknown))
- (if (or (exit-p dest)
- (and (return-p dest)
- (multiple-value-bind (ignore count)
- (values-types (return-result-type dest))
- (declare (ignore ignore))
- (eq count :unknown))))
- (maybe-negate-check value ctypes atypes t)
- (maybe-negate-check value ctypes atypes force-hairy)))
- ((and (lvar-single-value-p lvar)
- (or (not (args-type-rest ctype))
- (eq (args-type-rest ctype) *universal-type*)))
- (principal-lvar-single-valuify lvar)
- (let ((creq (car (args-type-required ctype))))
- (multiple-value-setq (ctype atype)
- (if creq
- (values creq (car (args-type-required atype)))
- (values (car (args-type-optional ctype))
- (car (args-type-optional atype)))))
- (maybe-negate-check value
- (list ctype) (list atype)
- force-hairy)))
- ((and (mv-combination-p dest)
- (eq (mv-combination-kind dest) :local))
- (let* ((fun-ref (lvar-use (mv-combination-fun dest)))
- (length (length (lambda-vars (ref-leaf fun-ref)))))
- (maybe-negate-check value
- ;; FIXME
- (adjust-list (values-type-types ctype)
- length
- *universal-type*)
- (adjust-list (values-type-types atype)
- length
- *universal-type*)
- force-hairy)))
- ((not (eq vcount :unknown))
- (maybe-negate-check value
- (values-type-out ctype vcount)
- (values-type-out atype vcount)
- t))
- (t
- (values :too-hairy nil))))))))
+ (cond ((and (null (values-type-optional dtype))
+ (not (values-type-rest dtype)))
+ ;; we [almost] know how many values are produced
+ (maybe-negate-check value
+ (values-type-out ctype n-required)
+ (values-type-out atype n-required)
+ ;; backend checks only consumed values
+ (not (eql n-required n-consumed))
+ n-required))
+ ((lvar-single-value-p lvar)
+ ;; exactly one value is consumed
+ (principal-lvar-single-valuify lvar)
+ (let ((creq (car (args-type-required ctype))))
+ (multiple-value-setq (ctype atype)
+ (if creq
+ (values creq (car (args-type-required atype)))
+ (values (car (args-type-optional ctype))
+ (car (args-type-optional atype)))))
+ (maybe-negate-check value
+ (list ctype) (list atype)
+ force-hairy
+ n-required)))
+ ((and (mv-combination-p dest)
+ (eq (mv-combination-kind dest) :local))
+ ;; we know the number of consumed values
+ (maybe-negate-check value
+ (adjust-list (values-type-types ctype)
+ n-consumed
+ *universal-type*)
+ (adjust-list (values-type-types atype)
+ n-consumed
+ *universal-type*)
+ force-hairy
+ n-required))
+ (t
+ (values :too-hairy nil)))))