From 9837343101c3da7b3a8f94609ec116ec5025436a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 11 May 2009 15:44:11 +0000 Subject: [PATCH] 1.0.28.38: undefined warning and compilation unit summary tweaking * Signal a full warning for undefined types when the name is in the COMMON-LISP package. * Explain probable source of error when the name of an undefined type is a quoted object. * When same original source form is responsible for multiple undefined warnings, only signal the first: otherwise we may signal a boatload of identical warnings for a single source form just because the compiler tries so very hard to make sense of it. * Don't summarize the names of undefined things by signalling new warnings for them, instead include the names in the compilation unit summary. --- make-target-2-load.lisp | 2 +- src/compiler/ir1report.lisp | 106 ++++++++++++---------- src/compiler/main.lisp | 207 +++++++++++++++++++++++-------------------- tests/compiler.pure.lisp | 19 ++++ version.lisp-expr | 2 +- 5 files changed, 193 insertions(+), 143 deletions(-) diff --git a/make-target-2-load.lisp b/make-target-2-load.lisp index 9d7dff6..b0983cf 100644 --- a/make-target-2-load.lisp +++ b/make-target-2-load.lisp @@ -53,7 +53,7 @@ ;;; The system is complete now, all standard functions are ;;; defined. (sb-kernel::ctype-of-cache-clear) -(setq sb-c::*flame-on-necessarily-undefined-function* t) +(setq sb-c::*flame-on-necessarily-undefined-thing* t) ;;; Clean up stray symbols from the CL-USER package. (do-symbols (symbol "CL-USER") diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index e2ec713..72f0fa2 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -174,49 +174,61 @@ ;;; list of things that are going to be printed out in the error ;;; message, and can thus be blown off when they appear in the source ;;; context. -(defun find-error-context (args) +;;; +;;; If OLD-CONTEXTS is passed in, and includes a context with the +;;; same original source path as the new context would have, the old +;;; context is reused instead, and a secondary value of T is returned. +(defun find-error-context (args &optional old-contexts) (let ((context *compiler-error-context*)) (if (compiler-error-context-p context) - context - (let ((path (or (and (boundp '*current-path*) *current-path*) - (if context - (node-source-path context) - nil)))) - (when (and *source-info* path) - (multiple-value-bind (form src-context) (find-original-source path) - (collect ((full nil cons) - (short nil cons)) - (let ((forms (source-path-forms path)) - (n 0)) - (dolist (src (if (member (first forms) args) - (rest forms) - forms)) - (if (>= n *enclosing-source-cutoff*) - (short (stringify-form (if (consp src) - (car src) - src) - nil)) - (full (stringify-form src))) - (incf n))) - - (let* ((tlf (source-path-tlf-number path)) - (file-info (source-info-file-info *source-info*))) - (make-compiler-error-context - :enclosing-source (short) - :source (full) - :original-source (stringify-form form) - :context src-context - :file-name (file-info-name file-info) - :file-position - (multiple-value-bind (ignore pos) - (find-source-root tlf *source-info*) - (declare (ignore ignore)) - pos) - :original-source-path - (source-path-original-source path) - :lexenv (if context - (node-lexenv context) - (if (boundp '*lexenv*) *lexenv* nil))))))))))) + (values context t) + (let* ((path (or (and (boundp '*current-path*) *current-path*) + (if context + (node-source-path context) + nil))) + (old + (find (when path (source-path-original-source path)) + (remove-if #'null old-contexts) + :test #'equal + :key #'compiler-error-context-original-source-path))) + (if old + (values old t) + (when (and *source-info* path) + (multiple-value-bind (form src-context) (find-original-source path) + (collect ((full nil cons) + (short nil cons)) + (let ((forms (source-path-forms path)) + (n 0)) + (dolist (src (if (member (first forms) args) + (rest forms) + forms)) + (if (>= n *enclosing-source-cutoff*) + (short (stringify-form (if (consp src) + (car src) + src) + nil)) + (full (stringify-form src))) + (incf n))) + + (let* ((tlf (source-path-tlf-number path)) + (file-info (source-info-file-info *source-info*))) + (values + (make-compiler-error-context + :enclosing-source (short) + :source (full) + :original-source (stringify-form form) + :context src-context + :file-name (file-info-name file-info) + :file-position + (multiple-value-bind (ignore pos) + (find-source-root tlf *source-info*) + (declare (ignore ignore)) + pos) + :original-source-path (source-path-original-source path) + :lexenv (if context + (node-lexenv context) + (if (boundp '*lexenv*) *lexenv* nil))) + nil)))))))))) ;;;; printing error messages @@ -527,9 +539,11 @@ has written, having proved that it is unreachable.")) (res (or found (make-undefined-warning :name name :kind kind)))) (unless found (push res *undefined-warnings*)) - (when (or (not *undefined-warning-limit*) - (< (undefined-warning-count res) *undefined-warning-limit*)) - (push (find-error-context (list name)) - (undefined-warning-warnings res))) - (incf (undefined-warning-count res)))) + (multiple-value-bind (context old) + (find-error-context (list name) (undefined-warning-warnings res)) + (unless old + (when (or (not *undefined-warning-limit*) + (< (undefined-warning-count res) *undefined-warning-limit*)) + (push context (undefined-warning-warnings res))) + (incf (undefined-warning-count res)))))) (values)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 8608b82..b188592 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -32,9 +32,9 @@ *lexenv* *fun-names-in-this-file* *allow-instrumenting*)) -;;; Whether call of a function which cannot be defined causes a full +;;; Whether reference to a thing which cannot be defined causes a full ;;; warning. -(defvar *flame-on-necessarily-undefined-function* nil) +(defvar *flame-on-necessarily-undefined-thing* nil) (defvar *check-consistency* nil) @@ -188,11 +188,19 @@ (incf *aborted-compilation-unit-count*)) (summarize-compilation-unit (not succeeded-p))))))))) -;;; Is FUN-NAME something that no conforming program can rely on -;;; defining as a function? -(defun fun-name-reserved-by-ansi-p (fun-name) - (eq (symbol-package (fun-name-block-name fun-name)) - *cl-package*)) +;;; Is NAME something that no conforming program can rely on +;;; defining? +(defun name-reserved-by-ansi-p (name kind) + (ecase kind + (:function + (eq (symbol-package (fun-name-block-name name)) + *cl-package*)) + (:type + (let ((symbol (typecase name + (symbol name) + ((cons symbol) (car name)) + (t (return-from name-reserved-by-ansi-p nil))))) + (eq (symbol-package symbol) *cl-package*))))) ;;; This is to be called at the end of a compilation unit. It signals ;;; any residual warnings about unknown stuff, then prints the total @@ -200,91 +208,101 @@ ;;; aborted by throwing out. ABORT-COUNT is the number of dynamically ;;; enclosed nested compilation units that were aborted. (defun summarize-compilation-unit (abort-p) - (unless abort-p - (handler-bind ((style-warning #'compiler-style-warning-handler) - (warning #'compiler-warning-handler)) - - (let ((undefs (sort *undefined-warnings* #'string< - :key (lambda (x) - (let ((x (undefined-warning-name x))) - (if (symbolp x) - (symbol-name x) - (prin1-to-string x))))))) - (dolist (undef undefs) - (let ((name (undefined-warning-name undef)) - (kind (undefined-warning-kind undef)) - (warnings (undefined-warning-warnings undef)) - (undefined-warning-count (undefined-warning-count undef))) - (dolist (*compiler-error-context* warnings) - (if #-sb-xc-host (and (eq kind :function) - (fun-name-reserved-by-ansi-p name) - *flame-on-necessarily-undefined-function*) - #+sb-xc-host nil - (case name - ((declare) - (compiler-warn - "~@" - name name)) - (t - (compiler-warn - "~@" - kind name))) - (if (eq kind :variable) - (compiler-warn "undefined ~(~A~): ~S" kind name) - (compiler-style-warn "undefined ~(~A~): ~S" kind name)))) - (let ((warn-count (length warnings))) - (when (and warnings (> undefined-warning-count warn-count)) - (let ((more (- undefined-warning-count warn-count))) - (if (eq kind :variable) - (compiler-warn - "~W more use~:P of undefined ~(~A~) ~S" - more kind name) - (compiler-style-warn - "~W more use~:P of undefined ~(~A~) ~S" - more kind name))))))) - - (dolist (kind '(:variable :function :type)) - (let ((summary (mapcar #'undefined-warning-name - (remove kind undefs :test #'neq - :key #'undefined-warning-kind)))) - (when summary - (if (eq kind :variable) - (compiler-warn - "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ - ~% ~{~<~% ~1:;~S~>~^ ~}" - (cdr summary) kind summary) - (compiler-style-warn - "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ - ~% ~{~<~% ~1:;~S~>~^ ~}" - (cdr summary) kind summary)))))))) - - (unless (and (not abort-p) - (zerop *aborted-compilation-unit-count*) - (zerop *compiler-error-count*) - (zerop *compiler-warning-count*) - (zerop *compiler-style-warning-count*) - (zerop *compiler-note-count*)) - (pprint-logical-block (*error-output* nil :per-line-prefix "; ") - (format *error-output* "~&compilation unit ~:[finished~;aborted~]~ - ~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~ - ~[~:;~:*~& caught ~W ERROR condition~:P~]~ - ~[~:;~:*~& caught ~W WARNING condition~:P~]~ - ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~ - ~[~:;~:*~& printed ~W note~:P~]" - abort-p - *aborted-compilation-unit-count* - *compiler-error-count* - *compiler-warning-count* - *compiler-style-warning-count* - *compiler-note-count*)) - (terpri *error-output*) - (force-output *error-output*))) + (let (summary) + (unless abort-p + (handler-bind ((style-warning #'compiler-style-warning-handler) + (warning #'compiler-warning-handler)) + + (let ((undefs (sort *undefined-warnings* #'string< + :key (lambda (x) + (let ((x (undefined-warning-name x))) + (if (symbolp x) + (symbol-name x) + (prin1-to-string x))))))) + (dolist (kind '(:variable :function :type)) + (let ((names (mapcar #'undefined-warning-name + (remove kind undefs :test #'neq + :key #'undefined-warning-kind)))) + (when names (push (cons kind names) summary)))) + (dolist (undef undefs) + (let ((name (undefined-warning-name undef)) + (kind (undefined-warning-kind undef)) + (warnings (undefined-warning-warnings undef)) + (undefined-warning-count (undefined-warning-count undef))) + (dolist (*compiler-error-context* warnings) + (if #-sb-xc-host (and (member kind '(:function :type)) + (name-reserved-by-ansi-p name kind) + *flame-on-necessarily-undefined-thing*) + #+sb-xc-host nil + (ecase kind + (:function + (case name + ((declare) + (compiler-warn + "~@" name + name)) + (t + (compiler-warn + "~@" name)))) + (:type + (if (and (consp name) (eq 'quote (car name))) + (compiler-warn + "~@" + name 'quote) + (compiler-warn + "~@" name + name)))) + (if (eq kind :variable) + (compiler-warn "undefined ~(~A~): ~S" kind name) + (compiler-style-warn "undefined ~(~A~): ~S" kind name)))) + (let ((warn-count (length warnings))) + (when (and warnings (> undefined-warning-count warn-count)) + (let ((more (- undefined-warning-count warn-count))) + (if (eq kind :variable) + (compiler-warn + "~W more use~:P of undefined ~(~A~) ~S" + more kind name) + (compiler-style-warn + "~W more use~:P of undefined ~(~A~) ~S" + more kind name)))))))))) + + (unless (and (not abort-p) + (zerop *aborted-compilation-unit-count*) + (zerop *compiler-error-count*) + (zerop *compiler-warning-count*) + (zerop *compiler-style-warning-count*) + (zerop *compiler-note-count*)) + (pprint-logical-block (*error-output* nil :per-line-prefix "; ") + (format *error-output* "~&compilation unit ~:[finished~;aborted~]" + abort-p) + (dolist (cell summary) + (destructuring-bind (kind &rest names) cell + (format *error-output* + "~& Undefined ~(~A~)~p:~ + ~% ~{~<~% ~1:;~S~>~^ ~}" + kind (length names) names))) + (format *error-output* "~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~ + ~[~:;~:*~& caught ~W ERROR condition~:P~]~ + ~[~:;~:*~& caught ~W WARNING condition~:P~]~ + ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~ + ~[~:;~:*~& printed ~W note~:P~]" + *aborted-compilation-unit-count* + *compiler-error-count* + *compiler-warning-count* + *compiler-style-warning-count* + *compiler-note-count*)) + (terpri *error-output*) + (force-output *error-output*)))) ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and @@ -1185,6 +1203,7 @@ (catch 'process-toplevel-form-error-abort (let* ((path (or (get-source-path form) (cons form path))) + (*current-path* path) (*compiler-error-bailout* (lambda (&optional condition) (convert-and-maybe-compile @@ -1248,9 +1267,7 @@ ;; sequence of steps in ANSI's "3.2.3.1 Processing of ;; Top Level Forms". #-sb-xc-host - (let ((expanded - (let ((*current-path* path)) - (preprocessor-macroexpand-1 form)))) + (let ((expanded (preprocessor-macroexpand-1 form))) (cond ((eq expanded form) (when compile-time-too (eval-in-lexenv form *lexenv*)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 14603df..08fbf6a 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2877,3 +2877,22 @@ (compile nil `(lambda () (sb-ext:with-timeout 0 (sleep 1)))))) + +(with-test (:name :full-warning-for-undefined-type-in-cl) + (assert (eq :full + (handler-case + (compile nil `(lambda (x) (the replace x))) + (style-warning () + :style) + (warning () + :full))))) + +(with-test (:name :single-warning-for-single-undefined-type) + (let ((n 0)) + (handler-bind ((warning (lambda (c) + (declare (ignore c)) + (incf n)))) + (compile nil `(lambda (x) (the #:no-type x))) + (assert (= 1 n)) + (compile nil `(lambda (x) (the 'fixnum x))) + (assert (= 2 n))))) diff --git a/version.lisp-expr b/version.lisp-expr index 94219e9..6241eb7 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.28.37" +"1.0.28.38" -- 1.7.10.4