-(defun continuation-check-types (cont)
- (declare (type continuation cont))
- (let ((type (continuation-asserted-type cont))
- (dest (continuation-dest cont)))
- (assert (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))
- (assert (values-type-p type))
- (maybe-negate-check cont (args-type-optional type) nil))
- (t
- (values :too-hairy nil))))))
+(defun cast-check-types (cast force-hairy)
+ (declare (type cast cast))
+ (let* ((cont (node-cont cast))
+ (ctype (coerce-to-values (cast-type-to-check cast)))
+ (atype (coerce-to-values (cast-asserted-type cast)))
+ (value (cast-value cast))
+ (vtype (continuation-derived-type value))
+ (dest (continuation-dest cont)))
+ (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 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 (continuation-single-value-p cont)
+ (or (not (args-type-rest ctype))
+ (eq (args-type-rest ctype) *universal-type*)))
+ (principal-continuation-single-valuify cont)
+ (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 (continuation-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-start ctype vcount)
+ (values-type-start atype vcount)
+ t))
+ (t
+ (values :too-hairy nil))))))))
+
+;;; Do we want to do a type check?
+(defun worth-type-check-p (cast)
+ (declare (type cast cast))
+ (let* ((cont (node-cont cast))
+ (dest (continuation-dest cont)))
+ (not (or (not (cast-type-check cast))
+ (and (combination-p dest)
+ (let ((kind (combination-kind dest)))
+ (or (eq kind :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.)
+ (and (fun-info-p kind)
+ (null (fun-info-templates kind))
+ (not (fun-info-ir2-convert kind)))))
+ (and
+ (immediately-used-p cont cast)
+ (values-subtypep (continuation-externally-checkable-type cont)
+ (cast-type-to-check cast))))))))