+\f
+;;; A knob for muffling warnings, mostly for use while loading files.
+(defvar *muffled-warnings* 'uninteresting-redefinition
+ "A type that ought to specify a subtype of WARNING. Whenever a
+warning is signaled, if the warning if of this type and is not
+handled by any other handler, it will be muffled.")
+\f
+;;; Various STYLE-WARNING signaled in the system.
+;; For the moment, we're only getting into the details for function
+;; redefinitions, but other redefinitions could be done later
+;; (e.g. methods).
+(define-condition redefinition-warning (style-warning)
+ ((name
+ :initarg :name
+ :reader redefinition-warning-name)
+ (new-location
+ :initarg :new-location
+ :reader redefinition-warning-new-location)))
+
+(define-condition function-redefinition-warning (redefinition-warning)
+ ((new-function
+ :initarg :new-function
+ :reader function-redefinition-warning-new-function)))
+
+(define-condition redefinition-with-defun (function-redefinition-warning)
+ ()
+ (:report (lambda (warning stream)
+ (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~
+ in DEFUN"
+ (redefinition-warning-name warning)))))
+
+(define-condition redefinition-with-defmacro (function-redefinition-warning)
+ ()
+ (:report (lambda (warning stream)
+ (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~
+ in DEFMACRO"
+ (redefinition-warning-name warning)))))
+
+(define-condition redefinition-with-defgeneric (redefinition-warning)
+ ()
+ (:report (lambda (warning stream)
+ (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~
+ in DEFGENERIC"
+ (redefinition-warning-name warning)))))
+
+(define-condition redefinition-with-defmethod (redefinition-warning)
+ ((qualifiers :initarg :qualifiers
+ :reader redefinition-with-defmethod-qualifiers)
+ (specializers :initarg :specializers
+ :reader redefinition-with-defmethod-specializers)
+ (new-location :initarg :new-location
+ :reader redefinition-with-defmethod-new-location)
+ (old-method :initarg :old-method
+ :reader redefinition-with-defmethod-old-method))
+ (:report (lambda (warning stream)
+ (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD"
+ (redefinition-warning-name warning)
+ (redefinition-with-defmethod-qualifiers warning)
+ (redefinition-with-defmethod-specializers warning)))))
+
+;;;; Deciding which redefinitions are "interesting".
+
+(defun function-file-namestring (function)
+ #!+sb-eval
+ (when (typep function 'sb!eval:interpreted-function)
+ (return-from function-file-namestring
+ (sb!c:definition-source-location-namestring
+ (sb!eval:interpreted-function-source-location function))))
+ (let* ((fun (sb!kernel:%fun-fun function))
+ (code (sb!kernel:fun-code-header fun))
+ (debug-info (sb!kernel:%code-debug-info code))
+ (debug-source (when debug-info
+ (sb!c::debug-info-source debug-info)))
+ (namestring (when debug-source
+ (sb!c::debug-source-namestring debug-source))))
+ namestring))
+
+(defun interesting-function-redefinition-warning-p (warning old)
+ (let ((new (function-redefinition-warning-new-function warning))
+ (source-location (redefinition-warning-new-location warning)))
+ (or
+ ;; Compiled->Interpreted is interesting.
+ (and (typep old 'compiled-function)
+ (typep new '(not compiled-function)))
+ ;; FIN->Regular is interesting.
+ (and (typep old 'funcallable-instance)
+ (typep new '(not funcallable-instance)))
+ ;; Different file or unknown location is interesting.
+ (let* ((old-namestring (function-file-namestring old))
+ (new-namestring
+ (or (function-file-namestring new)
+ (when source-location
+ (sb!c::definition-source-location-namestring source-location)))))
+ (and (or (not old-namestring)
+ (not new-namestring)
+ (not (string= old-namestring new-namestring))))))))
+
+(defun uninteresting-ordinary-function-redefinition-p (warning)
+ (and
+ ;; There's garbage in various places when the first DEFUN runs in
+ ;; cold-init.
+ sb!kernel::*cold-init-complete-p*
+ (typep warning 'redefinition-with-defun)
+ ;; Shared logic.
+ (let ((name (redefinition-warning-name warning)))
+ (not (interesting-function-redefinition-warning-p
+ warning (or (fdefinition name) (macro-function name)))))))
+
+(defun uninteresting-macro-redefinition-p (warning)
+ (and
+ (typep warning 'redefinition-with-defmacro)
+ ;; Shared logic.
+ (let ((name (redefinition-warning-name warning)))
+ (not (interesting-function-redefinition-warning-p
+ warning (or (macro-function name) (fdefinition name)))))))
+
+(defun uninteresting-generic-function-redefinition-p (warning)
+ (and
+ (typep warning 'redefinition-with-defgeneric)
+ ;; Can't use the shared logic above, since GF's don't get a "new"
+ ;; definition -- rather the FIN-FUNCTION is set.
+ (let* ((name (redefinition-warning-name warning))
+ (old (fdefinition name))
+ (old-location (when (typep old 'generic-function)
+ (sb!pcl::definition-source old)))
+ (old-namestring (when old-location
+ (sb!c:definition-source-location-namestring old-location)))
+ (new-location (redefinition-warning-new-location warning))
+ (new-namestring (when new-location
+ (sb!c:definition-source-location-namestring new-location))))
+ (and old-namestring
+ new-namestring
+ (string= old-namestring new-namestring)))))
+
+(defun uninteresting-method-redefinition-p (warning)
+ (and
+ (typep warning 'redefinition-with-defmethod)
+ ;; Can't use the shared logic above, since GF's don't get a "new"
+ ;; definition -- rather the FIN-FUNCTION is set.
+ (let* ((old-method (redefinition-with-defmethod-old-method warning))
+ (old-location (sb!pcl::definition-source old-method))
+ (old-namestring (when old-location
+ (sb!c:definition-source-location-namestring old-location)))
+ (new-location (redefinition-warning-new-location warning))
+ (new-namestring (when new-location
+ (sb!c:definition-source-location-namestring new-location))))
+ (and new-namestring
+ old-namestring
+ (string= new-namestring old-namestring)))))
+
+(deftype uninteresting-redefinition ()
+ '(or (satisfies uninteresting-ordinary-function-redefinition-p)
+ (satisfies uninteresting-macro-redefinition-p)
+ (satisfies uninteresting-generic-function-redefinition-p)
+ (satisfies uninteresting-method-redefinition-p)))
+
+(define-condition redefinition-with-deftransform (redefinition-warning)
+ ((transform :initarg :transform
+ :reader redefinition-with-deftransform-transform))
+ (:report (lambda (warning stream)
+ (format stream "Overwriting ~S"
+ (redefinition-with-deftransform-transform warning)))))
+\f
+;;; Various other STYLE-WARNINGS
+(define-condition dubious-asterisks-around-variable-name
+ (style-warning simple-condition)
+ ()
+ (:report (lambda (warning stream)
+ (format stream "~@?, even though the name follows~@
+the usual naming convention (names like *FOO*) for special variables"
+ (simple-condition-format-control warning)
+ (simple-condition-format-arguments warning)))))
+
+(define-condition asterisks-around-lexical-variable-name
+ (dubious-asterisks-around-variable-name)
+ ())