From c40c56eedec692acb930ec0e358a933ab33a3560 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Mon, 26 Apr 2010 21:47:39 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ package-data-list.lisp-expr | 3 ++- src/code/condition.lisp | 3 +++ src/code/cross-condition.lisp | 3 +++ src/compiler/checkgen.lisp | 60 ++++++++++++++++++++++------------------- version.lisp-expr | 2 +- 6 files changed, 44 insertions(+), 29 deletions(-) diff --git a/NEWS b/NEWS index 8cc7a71..46ab8eb 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4