(declare (type lvar tag))
(let ((ctype (lvar-type tag)))
(when (csubtypep ctype (specifier-type '(or number character)))
- (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
- tends to be unportable because THROW and CATCH ~
- use EQ comparison)~@:>"
- (lvar-source tag)
- (type-specifier (lvar-type tag))))))
+ (let ((sources (lvar-all-sources tag)))
+ (if (singleton-p sources)
+ (compiler-style-warn
+ "~@<using ~S of type ~S as a catch tag (which ~
+ tends to be unportable because THROW and CATCH ~
+ use EQ comparison)~@:>"
+ (first sources)
+ (type-specifier (lvar-type tag)))
+ (compiler-style-warn
+ "~@<using ~{~S~^~#[~; or ~:;, ~]~} in ~S of type ~S ~
+ as a catch tag (which tends to be unportable ~
+ because THROW and CATCH use EQ comparison)~@:>"
+ (rest sources) (first sources)
+ (type-specifier (lvar-type tag))))))))
(defun %compile-time-type-error (values atype dtype context)
(declare (ignore dtype))
(destructuring-bind (form . detail) context
(if (and (consp atype) (eq (car atype) 'values))
- (error 'simple-type-error
- :datum (car values)
- :expected-type atype
- :format-control
- "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in ~2I~_~S ~I~_is ~
+ (if (singleton-p detail)
+ (error 'simple-type-error
+ :datum (car values)
+ :expected-type atype
+ :format-control
+ "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in ~2I~_~S ~I~_is ~
not of type ~2I~_~S.~:>"
- :format-arguments (list values
- detail form
- atype))
- (error 'simple-type-error
- :datum (car values)
- :expected-type atype
- :format-control "~@<Value of ~S in ~2I~_~S ~I~_is ~2I~_~S, ~
+ :format-arguments (list values
+ (first detail) form
+ atype))
+ (error 'simple-type-error
+ :datum (car values)
+ :expected-type atype
+ :format-control
+ "~@<Value set ~2I~_[~{~S~^ ~}] ~
+ ~I~_from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
+ ~I~_of ~2I~_~S ~I~_in ~2I~_~S ~I~_is not of type ~2I~_~S.~:>"
+ :format-arguments (list values
+ (rest detail) (first detail)
+ form
+ atype)))
+ (if (singleton-p detail)
+ (error 'simple-type-error
+ :datum (car values)
+ :expected-type atype
+ :format-control "~@<Value of ~S in ~2I~_~S ~I~_is ~2I~_~S, ~
~I~_not a ~2I~_~S.~:@>"
- :format-arguments (list detail form
- (car values)
- atype)))))
+ :format-arguments (list (car detail) form
+ (car values)
+ atype))
+ (error 'simple-type-error
+ :datum (car values)
+ :expected-type atype
+ :format-control "~@<Value from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
+ ~I~_of ~2I~_~S ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~
+ ~I~_not a ~2I~_~S.~:@>"
+ :format-arguments (list (rest detail) (first detail) form
+ (car values)
+ atype))))))
(defoptimizer (%compile-time-type-error ir2-convert)
((objects atype dtype context) node block)
(dtype (lvar-value dtype))
(detail (cdr (lvar-value context))))
(unless (eq atype nil)
- (if (constantp detail)
+ (if (singleton-p detail)
+ (let ((detail (first detail)))
+ (if (constantp detail)
+ (warn 'type-warning
+ :format-control
+ "~@<Constant ~2I~_~S ~Iconflicts with its ~
+ asserted type ~2I~_~S.~@:>"
+ :format-arguments (list (eval detail) atype))
+ (warn 'type-warning
+ :format-control
+ "~@<Derived type of ~S is ~2I~_~S, ~
+ ~I~_conflicting with ~
+ its asserted type ~2I~_~S.~@:>"
+ :format-arguments (list detail dtype atype))))
(warn 'type-warning
- :format-control
- "~@<Constant ~2I~_~S ~Iconflicts with its asserted type ~
- ~2I~_~S.~@:>"
- :format-arguments (list (eval detail) atype))
- (warn 'type-warning
- :format-control
- "~@<Derived type of ~S is ~2I~_~S, ~I~_conflicting with ~
- its asserted type ~2I~_~S.~@:>"
- :format-arguments (list detail dtype atype))))))
+ :format-control
+ "~@<Derived type of ~2I~_~{~S~^~#[~; and ~:;, ~]~} ~
+ ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~I~_conflicting with ~
+ their asserted type ~2I~_~S.~@:>"
+ :format-arguments (list (rest detail) (first detail) dtype atype))))))
(ir2-convert-full-call node block)))
(values nil nil)
(values (node-source-form use) t))))
+(defun common-suffix (x y)
+ (let ((mismatch (mismatch x y :from-end t)))
+ (if mismatch
+ (subseq x mismatch)
+ x)))
+
+;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
+;;; singleton. Otherwise, return a list of the lowest common
+;;; ancestor source form of all the uses (if it can be found),
+;;; followed by all the uses' source forms.
+(defun lvar-all-sources (lvar)
+ (let ((use (lvar-uses lvar)))
+ (if (listp use)
+ (let ((forms '())
+ (path (node-source-path (first use))))
+ (dolist (use use (cons (if (find 'original-source-start path)
+ (find-original-source path)
+ "a hairy form")
+ forms))
+ (pushnew (node-source-form use) forms)
+ (setf path (common-suffix path
+ (node-source-path use)))))
+ (list (node-source-form use)))))
+
;;; Return the unique node, delivering a value to LVAR.
#!-sb-fluid (declaim (inline lvar-use))
(defun lvar-use (lvar)
(optimize speed))
(logtest x 2048))))
'(function ((unsigned-byte 10)) (values null &optional)))))
+
+;; type mismatches on LVARs with multiple potential sources used to
+;; be reported as mismatches with the value NIL. Make sure we get
+;; a warning, but that it doesn't complain about a constant NIL ...
+;; of type FIXNUM.
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL cast))
+ (block nil
+ (handler-bind ((sb-int:type-warning
+ (lambda (c)
+ (assert
+ (not (search "Constant "
+ (simple-condition-format-control
+ c))))
+ (return))))
+ (compile nil `(lambda (x y z)
+ (declare (type fixnum y z))
+ (aref (if x y z) 0))))
+ (error "Where's my warning?")))
+
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
+ (block nil
+ (handler-bind ((style-warning
+ (lambda (c)
+ (assert
+ (not (position
+ nil
+ (simple-condition-format-arguments c))))
+ (return))))
+ (compile nil `(lambda (x y z f)
+ (declare (type fixnum y z))
+ (catch (if x y z) (funcall f)))))
+ (error "Where's my style-warning?")))
projects / sbcl.git / commitdiff