((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)))
+ (flet ((get-type (type)
+ (acond ((args-type-required type)
+ (car it))
+ ((args-type-optional type)
+ (car it))
+ (t (bug "type ~S is too hairy" type)))))
+ (multiple-value-bind (ctype atype)
+ (values (get-type ctype) (get-type 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
nil)
((basic-combination-p dest)
(let ((kind (basic-combination-kind dest)))
- (cond ((eq cont (basic-combination-fun dest)) t)
- ((eq kind :local) t)
- ((eq kind :full)
- (and (combination-p dest)
- (not (values-subtypep ; explicit THE
- (continuation-externally-checkable-type cont)
- (continuation-type-to-check cont)))))
-
- ((eq kind :error) nil)
- ;; :ERROR means that we have an invalid syntax of
- ;; the call and the callee will detect it before
- ;; thinking about types.
-
- ((fun-info-ir2-convert kind) t)
- (t
- (dolist (template (fun-info-templates kind) nil)
- (when (eq (template-ltn-policy template) :fast-safe)
- (multiple-value-bind (val win)
- (valid-fun-use dest (template-type template))
- (when (or val (not win)) (return t)))))))))
+ (cond
+ ((eq cont (basic-combination-fun dest)) t)
+ (t
+ (ecase kind
+ (:local t)
+ (:full
+ (and (combination-p dest)
+ (not (values-subtypep ; explicit THE
+ (continuation-externally-checkable-type cont)
+ (continuation-type-to-check cont)))))
+ ;; :ERROR means that we have an invalid syntax of
+ ;; the call and the callee will detect it before
+ ;; thinking about types.
+ (:error nil)
+ (:known
+ (let ((info (basic-combination-fun-info dest)))
+ (if (fun-info-ir2-convert info)
+ t
+ (dolist (template (fun-info-templates info) nil)
+ (when (eq (template-ltn-policy template)
+ :fast-safe)
+ (multiple-value-bind (val win)
+ (valid-fun-use dest (template-type template))
+ (when (or val (not win)) (return t)))))))))))))
(t t))))
;;; Return a lambda form that we can convert to do a hairy type check
(leaf-source-name (elt (lambda-vars lambda)
pos)))))))
(cond ((and (ref-p use) (constant-p (ref-leaf use)))
- (compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
- what atype-spec (constant-value (ref-leaf use))))
+ (warn 'type-warning
+ :format-control
+ "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
+ :format-arguments
+ (list what atype-spec
+ (constant-value (ref-leaf use)))))
(t
- (compiler-warn
- "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
- what (type-specifier dtype) atype-spec))))))))
+ (warn 'type-warning
+ :format-control
+ "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
+ :format-arguments
+ (list what (type-specifier dtype) atype-spec)))))))))
(values))
;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,