Skip to content

Commit

Permalink
1.0.28.38: undefined warning and compilation unit summary tweaking
Browse files Browse the repository at this point in the history 
 * 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.
  • Loading branch information
@nikodemus
nikodemus committed May 11, 2009
1 parent 9ee246f commit 9837343
Show file tree
Hide file tree
Showing 5 changed files with 193 additions and 143 deletions.
2 changes: 1 addition & 1 deletion make-target-2-load.lisp
View file
Expand Up @@ -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")
Expand Down
106 changes: 60 additions & 46 deletions src/compiler/ir1report.lisp
View file
Expand Up @@ -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

Expand Down Expand Up @@ -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))
207 changes: 112 additions & 95 deletions src/compiler/main.lisp
View file
Expand Up @@ -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)

Expand Down Expand Up @@ -188,103 +188,121 @@
(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
;;; error counts. ABORT-P should be true when the compilation unit was
;;; 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
"~@<There is no function named ~S. References to ~S in ~
some contexts (like starts of blocks) have special ~
meaning, but here it would have to be a function, ~
and that shouldn't be right.~:@>"
name name))
(t
(compiler-warn
"~@<The ~(~A~) ~S is undefined, and its name is ~
reserved by ANSI CL so that even if it were ~
defined later, the code doing so would not be ~
portable.~:@>"
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
"~@<There is no function named ~S. References to ~S ~
in some contexts (like starts of blocks) have ~
special meaning, but here it would have to be a ~
function, and that shouldn't be right.~:@>" name
name))
(t
(compiler-warn
"~@<The function ~S is undefined, and its name is ~
reserved by ANSI CL so that even if it were ~
defined later, the code doing so would not be ~
portable.~:@>" name))))
(:type
(if (and (consp name) (eq 'quote (car name)))
(compiler-warn
"~@<Undefined type ~S. The name starts with ~S: ~
probably use of a quoted type name in a context ~
where the name is not evaluated.~:@>"
name 'quote)
(compiler-warn
"~@<Undefined type ~S. Note that name ~S is ~
reserved by ANSI CL, so code defining a type with ~
that name would not be portable.~:@>" 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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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*))
Expand Down
19 changes: 19 additions & 0 deletions tests/compiler.pure.lisp
View file
Expand Up @@ -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)))))

0 comments on commit 9837343

Please sign in to comment.