1.0.37.68: Downgrade WARNING to STYLE-WARNING for *possible* type errors

 * Detect some cases that might not lead to type errors, and signal
   a STYLE-WARNING instead of a WARNING then.

diff --git a/NEWS b/NEWS
index 8cc7a71..46ab8eb 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -43,6 +43,8 @@ changes relative to sbcl-1.0.37:
   * enhancement: improved DEFMETHOD pretty-printing.
   * enhancement: perform range reduction when arguments are too large for
     x87's transcendentals (instead of returning 0). (lp#327192)
+  * enhancement: eliminate some spurious TYPE-WARNINGs. Should help with
+    some of CL-PPCRE's macros. (lp#570079)
   * bug fix: correct restart text for the continuable error in MAKE-PACKAGE.
   * bug fix: a rare case of startup-time page table corruption.
   * bug fix: a semaphore with multiple waiters and some of them unwinding due

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 9ce98a5..6cfd99f 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1006,7 +1006,8 @@ possibly temporariliy, because it might be used internally."
 
                "DUPLICATE-DEFINITION" "DUPLICATE-DEFINITION-NAME"
                "PACKAGE-AT-VARIANCE" "ARRAY-INITIAL-ELEMENT-MISMATCH"
-               "TYPE-WARNING" "LOCAL-ARGUMENT-MISMATCH"
+               "TYPE-WARNING" "TYPE-STYLE-WARNING"
+               "LOCAL-ARGUMENT-MISMATCH"
                "FORMAT-ARGS-MISMATCH" "FORMAT-TOO-FEW-ARGS-WARNING"
                "FORMAT-TOO-MANY-ARGS-WARNING" "EXTENSION-FAILURE"
                "STRUCTURE-INITARG-NOT-KEYWORD" "CONSTANT-MODIFIED"

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 21dacb2..ee00b04 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -946,6 +946,9 @@
 (define-condition type-warning (reference-condition simple-warning)
   ()
   (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
+(define-condition type-style-warning (reference-condition simple-style-warning)
+  ()
+  (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
 
 (define-condition local-argument-mismatch (reference-condition simple-warning)
   ()

diff --git a/src/code/cross-condition.lisp b/src/code/cross-condition.lisp
index cd8580c..c487980 100644 (file)
--- a/src/code/cross-condition.lisp
+++ b/src/code/cross-condition.lisp
@@ -39,6 +39,9 @@
 (define-condition type-warning (reference-condition simple-warning)
   ()
   (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
+(define-condition type-style-warning (reference-condition simple-style-warning)
+  ()
+  (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))
 
 (define-condition bug (simple-error)
   ()

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index 46b32e1..b461851 100644 (file)
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -449,35 +449,41 @@
   (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,

diff --git a/version.lisp-expr b/version.lisp-expr
index 9d21537..dbb4b45 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.37.67"
+"1.0.37.68"