[prev in list] [next in list] [prev in thread] [next in thread] 

List:       sbcl-commits
Subject:    [Sbcl-commits] CVS: sbcl/src/compiler checkgen.lisp,1.50,1.51
From:       "Paul Khuong" <pkhuong () users ! sourceforge ! net>
Date:       2010-04-26 21:47:41
Message-ID: E1O6W9V-000887-GB () sfp-cvsdas-3 ! v30 ! ch3 ! sourceforge ! com
[Download RAW message or body]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv31220/src/compiler

Modified Files:
	checkgen.lisp 
Log Message:
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.


Index: checkgen.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- checkgen.lisp	17 Jun 2009 20:03:36 -0000	1.50
+++ checkgen.lisp	26 Apr 2010 21:47:39 -0000	1.51
@@ -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,


------------------------------------------------------------------------------
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]