bug#66326: 29.1.50; There should be a way to promote warnings to errors

[Spencer Baugh]

Patch implementing this:

>From 6fad83ea8729569c968ccdfc1ec2807387bc979e Mon Sep 17 00:00:00 2001
From: Spencer Baugh <sbaugh@janestreet.com>
Date: Tue, 3 Oct 2023 14:36:25 -0400
Subject: [PATCH] Support turning warnings into errors

Support turning warnings into errors in a user-configurable way.  This
is especially useful in combination with (setq debug-on-error t) to
drop to the debugger when a warning happens.

* lisp/emacs-lisp/warnings.el (warning-suppress-types): Improve
docstring.
(warning-to-error-types, warning-to-error): Add.
(display-warning): Check warning-to-error-types.
---
 lisp/emacs-lisp/warnings.el | 209 ++++++++++++++++++++----------------
 1 file changed, 114 insertions(+), 95 deletions(-)

diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
index 31b840d6c83..9e0a35b87bb 100644
--- a/lisp/emacs-lisp/warnings.el
+++ b/lisp/emacs-lisp/warnings.el
@@ -114,11 +114,20 @@ warning-suppress-types
 The element must match an initial segment of the list TYPE.
 Thus, (foo bar) as an element matches (foo bar)
 or (foo bar ANYTHING...) as TYPE.
+An empty list as an element matches any TYPE.
 If TYPE is a symbol FOO, that is equivalent to the list (FOO),
 so only the element (FOO) will match it.
 See also `warning-suppress-log-types'."
   :type '(repeat (repeat symbol))
   :version "22.1")
+
+(defcustom warning-to-error-types nil
+  "List of warning types to signal as an error instead.
+If any element of this list matches the TYPE argument to `display-warning',
+an error is signaled instead of logging a warning.
+See `warning-suppress-types' for the format of elements in this list."
+  :type '(repeat (repeat symbol))
+  :version "30.1")
 
 ;; The autoload cookie is so that programs can bind this variable
 ;; safely, testing the existing value, before they call one of the
@@ -230,6 +239,12 @@ warnings-suppress
                               (cons (list type) warning-suppress-types)))
     (_ (message "Exiting"))))
 
+(defun warning-to-error (type message level)
+  (let* ((typename (if (consp type) (car type) type))
+         (level-info (assq level warning-levels)))
+    (error (nth 1 level-info)
+           (format warning-type-format typename))))
+
 ;;;###autoload
 (defun display-warning (type message &optional level buffer-name)
   "Display a warning message, MESSAGE.
@@ -263,105 +278,109 @@ display-warning
 disable automatic display of the warning or disable the warning
 entirely by setting `warning-suppress-types' or
 `warning-suppress-log-types' on their behalf."
-  (if (not (or after-init-time noninteractive (daemonp)))
-      ;; Ensure warnings that happen early in the startup sequence
-      ;; are visible when startup completes (bug#20792).
-      (delay-warning type message level buffer-name)
-    (unless level
-      (setq level :warning))
-    (unless buffer-name
-      (setq buffer-name "*Warnings*"))
+  (unless level
+    (setq level :warning))
+  (unless buffer-name
+    (setq buffer-name "*Warnings*"))
+  (cond
+   ((< (warning-numeric-level level)
+       (warning-numeric-level warning-minimum-log-level)))
+   ((warning-suppress-p type warning-suppress-log-types))
+   ((warning-suppress-p type warning-to-error-types)
+    (warning-to-error type message level))
+   ((not (or after-init-time noninteractive (daemonp)))
+    ;; Ensure warnings that happen early in the startup sequence
+    ;; are visible when startup completes (bug#20792).
+    (delay-warning type message level buffer-name))
+   (t
     (with-suppressed-warnings ((obsolete warning-level-aliases))
       (when-let ((new (cdr (assq level warning-level-aliases))))
         (warn "Warning level `%s' is obsolete; use `%s' instead" level new)
         (setq level new)))
-    (or (< (warning-numeric-level level)
-          (warning-numeric-level warning-minimum-log-level))
-       (warning-suppress-p type warning-suppress-log-types)
-       (let* ((typename (if (consp type) (car type) type))
-              (old (get-buffer buffer-name))
-              (buffer (or old (get-buffer-create buffer-name)))
-              (level-info (assq level warning-levels))
-               ;; `newline' may be unbound during bootstrap.
-               (newline (if (fboundp 'newline) #'newline
-                          (lambda () (insert "\n"))))
-              start end)
-         (with-current-buffer buffer
-           ;; If we created the buffer, disable undo.
-           (unless old
-             (when (fboundp 'special-mode) ; Undefined during bootstrap.
-                (special-mode))
-             (setq buffer-read-only t)
-             (setq buffer-undo-list t))
-           (goto-char (point-max))
-           (when (and warning-series (symbolp warning-series))
-             (setq warning-series
-                   (prog1 (point-marker)
-                     (unless (eq warning-series t)
-                       (funcall warning-series)))))
-           (let ((inhibit-read-only t))
-             (unless (bolp)
-               (funcall newline))
-             (setq start (point))
-              ;; Don't output the button when doing batch compilation
-              ;; and similar.
-              (unless (or noninteractive (eq type 'bytecomp))
-                (insert (buttonize (icon-string 'warnings-suppress)
-                                   #'warnings-suppress type)
-                        " "))
-             (if warning-prefix-function
-                 (setq level-info (funcall warning-prefix-function
-                                           level level-info)))
-             (insert (format (nth 1 level-info)
-                             (format warning-type-format typename))
-                     message)
-              (funcall newline)
-             (when (and warning-fill-prefix
-                         (not (string-search "\n" message))
-                         (not noninteractive))
-               (let ((fill-prefix warning-fill-prefix)
-                     (fill-column warning-fill-column))
-                 (fill-region start (point))))
-             (setq end (point)))
-           (when (and (markerp warning-series)
-                      (eq (marker-buffer warning-series) buffer))
-             (goto-char warning-series)))
-         (if (nth 2 level-info)
-             (funcall (nth 2 level-info)))
-         (cond (noninteractive
-                ;; Noninteractively, take the text we inserted
-                ;; in the warnings buffer and print it.
-                ;; Do this unconditionally, since there is no way
-                ;; to view logged messages unless we output them.
-                (with-current-buffer buffer
-                  (save-excursion
-                    ;; Don't include the final newline in the arg
-                    ;; to `message', because it adds a newline.
-                    (goto-char end)
-                    (if (bolp)
-                        (forward-char -1))
-                    (message "%s" (buffer-substring start (point))))))
-               ((and (daemonp) (null after-init-time))
-                ;; Warnings assigned during daemon initialization go into
-                ;; the messages buffer.
-                (message "%s"
-                         (with-current-buffer buffer
-                           (save-excursion
-                             (goto-char end)
-                             (if (bolp)
-                                 (forward-char -1))
-                             (buffer-substring start (point))))))
-               (t
-                ;; Interactively, decide whether the warning merits
-                ;; immediate display.
-                (or (< (warning-numeric-level level)
-                       (warning-numeric-level warning-minimum-level))
-                    (warning-suppress-p type warning-suppress-types)
-                    (let ((window (display-buffer buffer)))
-                      (when (and (markerp warning-series)
-                                 (eq (marker-buffer warning-series) buffer))
-                        (set-window-start window warning-series))
-                      (sit-for 0)))))))))
+    (let* ((typename (if (consp type) (car type) type))
+          (old (get-buffer buffer-name))
+          (buffer (or old (get-buffer-create buffer-name)))
+          (level-info (assq level warning-levels))
+           ;; `newline' may be unbound during bootstrap.
+           (newline (if (fboundp 'newline) #'newline
+                      (lambda () (insert "\n"))))
+          start end)
+      (with-current-buffer buffer
+       ;; If we created the buffer, disable undo.
+       (unless old
+         (when (fboundp 'special-mode) ; Undefined during bootstrap.
+            (special-mode))
+         (setq buffer-read-only t)
+         (setq buffer-undo-list t))
+       (goto-char (point-max))
+       (when (and warning-series (symbolp warning-series))
+         (setq warning-series
+               (prog1 (point-marker)
+                 (unless (eq warning-series t)
+                   (funcall warning-series)))))
+       (let ((inhibit-read-only t))
+         (unless (bolp)
+           (funcall newline))
+         (setq start (point))
+          ;; Don't output the button when doing batch compilation
+          ;; and similar.
+          (unless (or noninteractive (eq type 'bytecomp))
+            (insert (buttonize (icon-string 'warnings-suppress)
+                               #'warnings-suppress type)
+                    " "))
+         (if warning-prefix-function
+             (setq level-info (funcall warning-prefix-function
+                                       level level-info)))
+         (insert (format (nth 1 level-info)
+                         (format warning-type-format typename))
+                 message)
+          (funcall newline)
+         (when (and warning-fill-prefix
+                     (not (string-search "\n" message))
+                     (not noninteractive))
+           (let ((fill-prefix warning-fill-prefix)
+                 (fill-column warning-fill-column))
+             (fill-region start (point))))
+         (setq end (point)))
+       (when (and (markerp warning-series)
+                  (eq (marker-buffer warning-series) buffer))
+         (goto-char warning-series)))
+      (if (nth 2 level-info)
+         (funcall (nth 2 level-info)))
+      (cond (noninteractive
+            ;; Noninteractively, take the text we inserted
+            ;; in the warnings buffer and print it.
+            ;; Do this unconditionally, since there is no way
+            ;; to view logged messages unless we output them.
+            (with-current-buffer buffer
+              (save-excursion
+                ;; Don't include the final newline in the arg
+                ;; to `message', because it adds a newline.
+                (goto-char end)
+                (if (bolp)
+                    (forward-char -1))
+                (message "%s" (buffer-substring start (point))))))
+           ((and (daemonp) (null after-init-time))
+            ;; Warnings assigned during daemon initialization go into
+            ;; the messages buffer.
+            (message "%s"
+                     (with-current-buffer buffer
+                       (save-excursion
+                         (goto-char end)
+                         (if (bolp)
+                             (forward-char -1))
+                         (buffer-substring start (point))))))
+           (t
+            ;; Interactively, decide whether the warning merits
+            ;; immediate display.
+            (or (< (warning-numeric-level level)
+                   (warning-numeric-level warning-minimum-level))
+                (warning-suppress-p type warning-suppress-types)
+                (let ((window (display-buffer buffer)))
+                  (when (and (markerp warning-series)
+                             (eq (marker-buffer warning-series) buffer))
+                    (set-window-start window warning-series))
+                  (sit-for 0)))))))))
 
 ;; Use \\<special-mode-map> so that help-enable-autoload can do its thing.
 ;; Any keymap that is defined will do.
-- 
2.39.3