- (aver (not (eq type *wild-type*)))
- (multiple-value-bind (types count) (no-function-values-types type)
- (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 cont types t)
- (maybe-negate-check cont types nil)))
- ((and (mv-combination-p dest)
- (eq (basic-combination-kind dest) :local))
- (aver (values-type-p type))
- (maybe-negate-check cont (args-type-optional type) nil))
- (t
- (values :too-hairy nil))))))
+ (aver (not (eq ctype *wild-type*)))
+ (multiple-value-bind (ctypes count) (no-fun-values-types ctype)
+ (multiple-value-bind (atypes acount) (no-fun-values-types ctype)
+ (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 cont ctypes atypes t)
+ (maybe-negate-check cont ctypes atypes force-hairy)))
+ ((and (mv-combination-p dest)
+ (eq (basic-combination-kind dest) :local))
+ (aver (values-type-p ctype))
+ (maybe-negate-check cont
+ (args-type-optional ctype)
+ (args-type-optional atype)
+ force-hairy))
+ (t
+ (values :too-hairy nil)))))))
+
+;;; Do we want to do a type check?
+(defun worth-type-check-p (cont)
+ (let ((dest (continuation-dest cont)))
+ (not (or (values-subtypep (continuation-proven-type cont)
+ (continuation-type-to-check cont))
+ (and (combination-p dest)
+ (eq (combination-kind dest) :full)
+ ;; The theory is that the type assertion is from a
+ ;; declaration in (or on) the callee, so the callee
+ ;; should be able to do the check. We want to let
+ ;; the callee do the check, because it is possible
+ ;; that by the time of call that declaration will be
+ ;; changed and we do not want to make people
+ ;; recompile all calls to a function when they were
+ ;; originally compiled with a bad declaration. (See
+ ;; also bug 35.)
+ (values-subtypep (continuation-externally-checkable-type cont)
+ (continuation-type-to-check cont)))
+ (and (mv-combination-p dest) ; bug 220
+ (eq (mv-combination-kind dest) :full))))))