;;; matches the specified result.
;;;
;;; Unlike the argument test, the result test may be called on values
-;;; or function types. If STRICT-RESULT is true and SAFETY is
-;;; non-zero, then the NODE-DERIVED-TYPE is always used. Otherwise, if
-;;; CONT's TYPE-CHECK is true, then the NODE-DERIVED-TYPE is
-;;; intersected with the CONT's ASSERTED-TYPE.
+;;; or function types. NODE-DERIVED-TYPE is intersected with the
+;;; trusted asserted type.
;;;
;;; The error and warning functions are functions that are called to
;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
(result-test #'values-subtypep)
((:lossage-fun *lossage-fun*))
((:unwinnage-fun *unwinnage-fun*)))
- (declare (type function result-test) (type combination call)
+ (declare (type (or function null) result-test) (type combination call)
;; FIXME: Could TYPE here actually be something like
;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
;; horrible... -- CSR, 2003-05-03
(when keyp
(check-key-args args max-args type))))
- (let* ((dtype (node-derived-type call))
- (return-type (fun-type-returns type))
- (out-type dtype))
- (multiple-value-bind (int win) (funcall result-test out-type return-type)
- (cond ((not win)
- (note-unwinnage "can't tell whether the result is a ~S"
- (type-specifier return-type)))
- ((not int)
- (note-lossage "The result is a ~S, not a ~S."
- (type-specifier out-type)
- (type-specifier return-type)))))))
+ (when result-test
+ (let* ((dtype (node-derived-type call))
+ (out-type (or
+ (binding* ((lvar (node-lvar call) :exit-if-null)
+ (dest (lvar-dest lvar)))
+ (when (and (cast-p dest)
+ (eq (cast-type-to-check dest) *wild-type*)
+ (immediately-used-p lvar call))
+ (values-type-intersection
+ dtype (cast-asserted-type dest))))
+ dtype))
+ (return-type (fun-type-returns type)))
+ (multiple-value-bind (int win) (funcall result-test out-type return-type)
+ (cond ((not win)
+ (note-unwinnage "can't tell whether the result is a ~S"
+ (type-specifier return-type)))
+ ((not int)
+ (note-lossage "The result is a ~S, not a ~S."
+ (type-specifier out-type)
+ (type-specifier return-type))))))))
(loop for arg in args
and i from 1
do (check-arg-type arg *wild-type* i)))
(multiple-value-bind (res win) (ctypep val type)
(cond ((not win)
(note-unwinnage "can't tell whether the ~:R argument is a ~
- constant ~S:~% ~S"
+ constant ~S:~% ~S"
n (type-specifier type) val)
nil)
((not res)
((not (check-arg-type k (specifier-type 'symbol) n)))
((not (constant-lvar-p k))
(note-unwinnage "The ~:R argument (in keyword position) is not a ~
- constant."
+ constant."
n))
(t
(let* ((name (lvar-value k))
((eq int *empty-type*)
(note-lossage
"Definition's declared type for variable ~A:~% ~S~@
- conflicts with this type from ~A:~% ~S"
+ conflicts with this type from ~A:~% ~S"
(leaf-debug-name var) (type-specifier vtype)
where (type-specifier type))
(return-from try-type-intersections (values nil nil)))
(unless (eq x y)
(note-lossage
"The definition ~:[doesn't have~;has~] ~A, but ~
- ~A ~:[doesn't~;does~]."
+ ~A ~:[doesn't~;does~]."
x what where y))))
(frob (optional-dispatch-keyp od) (fun-type-keyp type)
"&KEY arguments")
type-returns)))
(note-lossage
"The result type from ~A:~% ~S~@
- conflicts with the definition's result type:~% ~S"
+ conflicts with the definition's result type:~% ~S"
where (type-specifier type-returns) (type-specifier dtype))
nil)
(*lossage-detected* nil)
(not (csubtypep (leaf-type var) type)))
(funcall unwinnage-fun
"Assignment to argument: ~S~% ~
- prevents use of assertion from function ~
- type ~A:~% ~S~%"
+ prevents use of assertion from function ~
+ type ~A:~% ~S~%"
(leaf-debug-name var)
where
(type-specifier type))))
(let ((atype (lvar-value atype))
(dtype (lvar-value dtype)))
(unless (eq atype nil)
- (compiler-warn
- "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
- atype dtype))))
+ (warn 'type-warning
+ :format-control
+ "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
+ :format-arguments (list atype dtype)))))
(ir2-convert-full-call node block)))