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

[Spencer Baugh <sbaugh@janestreet.com>]

[-- Attachment #1: Type: text/plain, Size: 27 bytes --]


Patch implementing this:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Support-turning-warnings-into-errors.patch --]
[-- Type: text/x-patch, Size: 10631 bytes --]

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")
 \f
 ;; 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)))))))))
 \f
 ;; Use \\<special-mode-map> so that help-enable-autoload can do its thing.
 ;; Any keymap that is defined will do.
-- 
2.39.3