(t
(values :too-hairy nil)))))
-;;; Do we want to do a type check?
+;;; Return T is the cast appears to be from the declaration of the callee,
+;;; and should be checked externally -- that is, by the callee and not the caller.
(defun cast-externally-checkable-p (cast)
(declare (type cast cast))
(let* ((lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar))))
(and (combination-p dest)
- ;; 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.)
- (or (immediately-used-p lvar cast)
- (binding* ((ctran (node-next cast) :exit-if-null)
- (next (ctran-next ctran)))
- (and (cast-p next)
- (eq (node-dest next) dest)
- (eq (cast-type-check next) :external))))
- (values-subtypep (lvar-externally-checkable-type lvar)
- (cast-type-to-check cast)))))
+ ;; The theory is that the type assertion is from a declaration 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.
+ ;;
+ ;; ALMOST-IMMEDIATELY-USED-P ensures that we don't delegate casts
+ ;; that occur before nodes that can cause observable side effects --
+ ;; most commonly other non-external casts: so the order in which
+ ;; possible type errors are signalled matches with the evaluation
+ ;; order.
+ ;;
+ ;; FIXME: We should let more cases be handled by the callee then we
+ ;; currently do, see: https://bugs.launchpad.net/sbcl/+bug/309104
+ ;; This is not fixable quite here, though, because flow-analysis has
+ ;; deleted the LVAR of the cast by the time we get here, so there is
+ ;; no destination. Perhaps we should mark cases inserted by
+ ;; ASSERT-CALL-TYPE explicitly, and delete those whose destination is
+ ;; deemed unreachable?
+ (almost-immediately-used-p lvar cast)
+ (values (values-subtypep (lvar-externally-checkable-type lvar)
+ (cast-type-to-check cast))))))
;;; Return true if CAST's value is an lvar whose type the back end is
;;; likely to be able to check (see GENERATE-TYPE-CHECKS). Since we
(let* ((lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar)))
(value (cast-value cast))
- (atype (cast-asserted-type cast)))
+ (atype (cast-asserted-type cast))
+ (condition 'type-warning)
+ (not-ok-uses '()))
(do-uses (use value)
(let ((dtype (node-derived-type use)))
- (unless (values-types-equal-or-intersect dtype atype)
- (let* ((*compiler-error-context* use)
- (atype-spec (type-specifier atype))
- (what (when (and (combination-p dest)
- (eq (combination-kind dest) :local))
- (let ((lambda (combination-lambda dest))
- (pos (position-or-lose
- lvar (combination-args dest))))
- (format nil "~:[A possible~;The~] binding of ~S"
- (and (lvar-has-single-use-p lvar)
- (eq (functional-kind lambda) :let))
- (leaf-source-name (elt (lambda-vars lambda)
- pos)))))))
- (cond ((and (ref-p use) (constant-p (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
- (warn 'type-warning
- :format-control
- "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
- :format-arguments
- (list what (type-specifier dtype) atype-spec)))))))))
+ (if (values-types-equal-or-intersect dtype atype)
+ (setf condition 'type-style-warning)
+ (push use not-ok-uses))))
+ (dolist (use (nreverse not-ok-uses))
+ (let* ((*compiler-error-context* use)
+ (dtype (node-derived-type use))
+ (atype-spec (type-specifier atype))
+ (what (when (and (combination-p dest)
+ (eq (combination-kind dest) :local))
+ (let ((lambda (combination-lambda dest))
+ (pos (position-or-lose
+ lvar (combination-args dest))))
+ (format nil "~:[A possible~;The~] binding of ~S"
+ (and (lvar-has-single-use-p lvar)
+ (eq (functional-kind lambda) :let))
+ (leaf-source-name (elt (lambda-vars lambda)
+ pos)))))))
+ (cond ((and (ref-p use) (constant-p (ref-leaf use)))
+ (warn condition
+ :format-control
+ "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
+ :format-arguments
+ (list what atype-spec
+ (constant-value (ref-leaf use)))))
+ (t
+ (warn condition
+ :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,
projects / sbcl.git / blobdiff