Add the new macro with-suppressed-warnings

* lisp/emacs-lisp/byte-run.el (with-suppressed-warnings): New macro.

* doc/lispref/compile.texi (Compiler Errors): Document
with-suppressed-warnings and deemphasise with-no-warnings
slightly.

* lisp/emacs-lisp/bytecomp.el (byte-compile--suppressed-warnings):
New internal variable.
(byte-compile-warning-enabled-p): Heed
byte-compile--suppressed-warnings, bound via with-suppressed-warnings.
(byte-compile-initial-macro-environment): Provide a macro
expansion of with-suppressed-warnings.
(byte-compile-file-form-with-suppressed-warnings): New byte hunk
handler for the suppressed symbol machinery.
(byte-compile-suppressed-warnings): Ditto for the byteop.
(byte-compile-file-form-defmumble): Ditto.
(byte-compile-form, byte-compile-normal-call)
(byte-compile-normal-call, byte-compile-variable-ref)
(byte-compile-set-default, byte-compile-variable-set)
(byte-compile-function-form, byte-compile-set-default)
(byte-compile-warn-obsolete, byte-compile--declare-var): Pass the
symbol being warned in to byte-compile-warning-enabled-p.

* test/lisp/emacs-lisp/bytecomp-tests.el (test-suppression): New
function.
(bytecomp-test--with-suppressed-warnings): Tests.

5 files changed, 203 insertions, 27 deletions

diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi
index d9db55e22cd..4ff0e1c91e4 100644
--- a/doc/lispref/compile.texi
+++ b/doc/lispref/compile.texi
@@ -505,8 +505,25 @@ current lexical scope, or file if at top-level.)  @xref{Defining
 Variables}.
 @end itemize
 
-  You can also suppress any and all compiler warnings within a certain
-expression using the construct @code{with-no-warnings}:
+  You can also suppress compiler warnings within a certain expression
+using the @code{with-suppressed-warnings} macro:
+
+@defspec with-suppressed-warnings warnings body@dots{}
+In execution, this is equivalent to @code{(progn @var{body}...)}, but
+the compiler does not issue warnings for the specified conditions in
+@var{body}.  @var{warnings} is an associative list of warning symbols
+and function/variable symbols they apply to.  For instance, if you
+wish to call an obsolete function called @code{foo}, but want to
+suppress the compilation warning, say:
+
+@lisp
+(with-suppressed-warnings ((obsolete foo))
+  (foo ...))
+@end lisp
+@end defspec
+
+For more coarse-grained suppression of compiler warnings, you can use
+the @code{with-no-warnings} construct:
 
 @c This is implemented with a defun, but conceptually it is
 @c a special form.
@@ -516,8 +533,9 @@ In execution, this is equivalent to @code{(progn @var{body}...)},
 but the compiler does not issue warnings for anything that occurs
 inside @var{body}.
 
-We recommend that you use this construct around the smallest
-possible piece of code, to avoid missing possible warnings other than
+We recommend that you use @code{with-suppressed-warnings} instead, but
+if you do use this construct, that you use it around the smallest
+possible piece of code to avoid missing possible warnings other than
 one you intend to suppress.
 @end defspec
 
diff --git a/etc/NEWS b/etc/NEWS
index 6efa7642f85..5632ccc6d75 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1693,6 +1693,10 @@ valid event type.
 * Lisp Changes in Emacs 27.1
 
 +++
+** The new macro `with-suppressed-warnings' can be used to suppress
+specific byte-compile warnings.
+
++++
 ** The 'append' arg of 'add-hook' is generalized to a finer notion of 'depth'
 This makes it possible to control the ordering of functions more precisely,
 as was already possible in 'add-function' and `advice-add`.
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 842d1d48b45..6a21a0c909d 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -494,6 +494,34 @@ is enabled."
   ;; The implementation for the interpreter is basically trivial.
   (car (last body)))
 
+(defmacro with-suppressed-warnings (_warnings &rest body)
+  "Like `progn', but prevents compiler WARNINGS in BODY.
+
+WARNINGS is an associative list where the first element of each
+item is a warning type, and the rest of the elements in each item
+are symbols they apply to.  For instance, if you want to suppress
+byte compilation warnings about the two obsolete functions `foo'
+and `bar', as well as the function `zot' being called with the
+wrong number of parameters, say
+
+\(with-suppressed-warnings ((obsolete foo bar)
+                           (callargs zot))
+  (foo (bar))
+  (zot 1 2))
+
+The warnings that can be suppressed are a subset of the warnings
+in `byte-compile-warning-types'; see this variable for a fuller
+explanation of the warning types.  The types that can be
+suppressed with this macro are `free-vars', `callargs',
+`redefine', `obsolete', `interactive-only', `lexical', `mapcar',
+`constants' and `suspicious'.
+
+For the `mapcar' case, only the `mapcar' function can be used in
+the symbol list.  For `suspicious', only `set-buffer' can be used."
+  (declare (debug (sexp &optional body)) (indent 1))
+  ;; The implementation for the interpreter is basically trivial.
+  `(progn ,@body))
+
 
 (defun byte-run--unescaped-character-literals-warning ()
   "Return a warning about unescaped character literals.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index f2a38a9c6c3..13d563bde91 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -331,18 +331,27 @@ suppress.  For example, (not mapcar) will suppress warnings about mapcar."
                       ,@(mapcar (lambda (x) `(const ,x))
                                 byte-compile-warning-types))))
 
+(defvar byte-compile--suppressed-warnings nil
+  "Dynamically bound by `with-suppressed-warnings' to suppress warnings.")
+
 ;;;###autoload
 (put 'byte-compile-warnings 'safe-local-variable
      (lambda (v)
        (or (symbolp v)
            (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v))))))
 
-(defun byte-compile-warning-enabled-p (warning)
+(defun byte-compile-warning-enabled-p (warning &optional symbol)
   "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'."
-  (or (eq byte-compile-warnings t)
-      (if (eq (car byte-compile-warnings) 'not)
-          (not (memq warning byte-compile-warnings))
-        (memq warning byte-compile-warnings))))
+  (let ((suppress nil))
+    (dolist (elem byte-compile--suppressed-warnings)
+      (when (and (eq (car elem) warning)
+                 (memq symbol (cdr elem)))
+        (setq suppress t)))
+    (and (not suppress)
+         (or (eq byte-compile-warnings t)
+             (if (eq (car byte-compile-warnings) 'not)
+                 (not (memq warning byte-compile-warnings))
+               (memq warning byte-compile-warnings))))))
 
 ;;;###autoload
 (defun byte-compile-disable-warning (warning)
@@ -502,7 +511,16 @@ Return the compile-time value of FORM."
                                       form
                                       macroexpand-all-environment)))
                                 (eval expanded lexical-binding)
-                                expanded))))))
+                                expanded)))))
+    (with-suppressed-warnings
+        . ,(lambda (warnings &rest body)
+             ;; This function doesn't exist, but is just a placeholder
+             ;; symbol to hook up with the
+             ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery.
+             `(internal--with-suppressed-warnings
+               ',warnings
+               ,(macroexpand-all `(progn ,@body)
+                                 macroexpand-all-environment)))))
   "The default macro-environment passed to macroexpand by the compiler.
 Placing a macro here will cause a macro to have different semantics when
 expanded by the compiler as when expanded by the interpreter.")
@@ -1268,7 +1286,7 @@ function directly; use `byte-compile-warn' or
 
 (defun byte-compile-warn-obsolete (symbol)
   "Warn that SYMBOL (a variable or function) is obsolete."
-  (when (byte-compile-warning-enabled-p 'obsolete)
+  (when (byte-compile-warning-enabled-p 'obsolete symbol)
     (let* ((funcp (get symbol 'byte-obsolete-info))
            (msg (macroexp--obsolete-warning
                  symbol
@@ -2423,7 +2441,7 @@ list that represents a doc string reference.
 (defun byte-compile--declare-var (sym)
   (when (and (symbolp sym)
              (not (string-match "[-*/:$]" (symbol-name sym)))
-             (byte-compile-warning-enabled-p 'lexical))
+             (byte-compile-warning-enabled-p 'lexical sym))
     (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
                        sym))
   (when (memq sym byte-compile-lexical-variables)
@@ -2521,6 +2539,15 @@ list that represents a doc string reference.
     (mapc 'byte-compile-file-form (cdr form))
     nil))
 
+(put 'internal--with-suppressed-warnings 'byte-hunk-handler
+     'byte-compile-file-form-with-suppressed-warnings)
+(defun byte-compile-file-form-with-suppressed-warnings (form)
+  ;; cf byte-compile-file-form-progn.
+  (let ((byte-compile--suppressed-warnings
+         (append (cadadr form) byte-compile--suppressed-warnings)))
+    (mapc 'byte-compile-file-form (cddr form))
+    nil))
+
 ;; Automatically evaluate define-obsolete-function-alias etc at top-level.
 (put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete)
 (defun byte-compile-file-form-make-obsolete (form)
@@ -2559,7 +2586,7 @@ not to take responsibility for the actual compilation of the code."
             (setq byte-compile-call-tree
                   (cons (list name nil nil) byte-compile-call-tree))))
 
-    (if (byte-compile-warning-enabled-p 'redefine)
+    (if (byte-compile-warning-enabled-p 'redefine name)
         (byte-compile-arglist-warn name arglist macro))
 
     (if byte-compile-verbose
@@ -2571,7 +2598,7 @@ not to take responsibility for the actual compilation of the code."
            ;; This also silences "multiple definition" warnings for defmethods.
            nil)
           (that-one
-           (if (and (byte-compile-warning-enabled-p 'redefine)
+           (if (and (byte-compile-warning-enabled-p 'redefine name)
                     ;; Don't warn when compiling the stubs in byte-run...
                     (not (assq name byte-compile-initial-macro-environment)))
                (byte-compile-warn
@@ -2579,7 +2606,7 @@ not to take responsibility for the actual compilation of the code."
                 name))
            (setcdr that-one nil))
           (this-one
-           (when (and (byte-compile-warning-enabled-p 'redefine)
+           (when (and (byte-compile-warning-enabled-p 'redefine name)
                       ;; Hack: Don't warn when compiling the magic internal
                       ;; byte-compiler macros in byte-run.el...
                       (not (assq name byte-compile-initial-macro-environment)))
@@ -2588,7 +2615,7 @@ not to take responsibility for the actual compilation of the code."
                                 name)))
           ((eq (car-safe (symbol-function name))
                (if macro 'lambda 'macro))
-           (when (byte-compile-warning-enabled-p 'redefine)
+           (when (byte-compile-warning-enabled-p 'redefine name)
              (byte-compile-warn "%s `%s' being redefined as a %s"
                                 (if macro "function" "macro")
                                 name
@@ -3153,7 +3180,7 @@ for symbols generated by the byte compiler itself."
         (when (and (byte-compile-warning-enabled-p 'suspicious)
                    (macroexp--const-symbol-p fn))
           (byte-compile-warn "`%s' called as a function" fn))
-        (when (and (byte-compile-warning-enabled-p 'interactive-only)
+        (when (and (byte-compile-warning-enabled-p 'interactive-only fn)
                    interactive-only)
           (byte-compile-warn "`%s' is for interactive use only%s"
                              fn
@@ -3194,8 +3221,8 @@ for symbols generated by the byte compiler itself."
         (byte-compile-discard))))
 
 (defun byte-compile-normal-call (form)
-  (when (and (byte-compile-warning-enabled-p 'callargs)
-             (symbolp (car form)))
+  (when (and (symbolp (car form))
+             (byte-compile-warning-enabled-p 'callargs (car form)))
     (if (memq (car form)
               '(custom-declare-group custom-declare-variable
                                      custom-declare-face))
@@ -3204,7 +3231,7 @@ for symbols generated by the byte compiler itself."
   (if byte-compile-generate-call-tree
       (byte-compile-annotate-call-tree form))
   (when (and byte-compile--for-effect (eq (car form) 'mapcar)
-             (byte-compile-warning-enabled-p 'mapcar))
+             (byte-compile-warning-enabled-p 'mapcar 'mapcar))
     (byte-compile-set-symbol-position 'mapcar)
     (byte-compile-warn
      "`mapcar' called for effect; use `mapc' or `dolist' instead"))
@@ -3340,7 +3367,8 @@ for symbols generated by the byte compiler itself."
   (when (symbolp var)
     (byte-compile-set-symbol-position var))
   (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))
-         (when (byte-compile-warning-enabled-p 'constants)
+         (when (byte-compile-warning-enabled-p 'constants
+                                               (and (symbolp var) var))
            (byte-compile-warn (if (eq access-type 'let-bind)
                                   "attempt to let-bind %s `%s'"
                                 "variable reference to %s `%s'")
@@ -3377,7 +3405,7 @@ for symbols generated by the byte compiler itself."
         ;; VAR is lexically bound
         (byte-compile-stack-ref (cdr lex-binding))
       ;; VAR is dynamically bound
-      (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
+      (unless (or (not (byte-compile-warning-enabled-p 'free-vars var))
                   (boundp var)
                   (memq var byte-compile-bound-variables)
                   (memq var byte-compile-free-references))
@@ -3393,7 +3421,7 @@ for symbols generated by the byte compiler itself."
         ;; VAR is lexically bound.
         (byte-compile-stack-set (cdr lex-binding))
       ;; VAR is dynamically bound.
-      (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
+      (unless (or (not (byte-compile-warning-enabled-p 'free-vars var))
                   (boundp var)
                   (memq var byte-compile-bound-variables)
                   (memq var byte-compile-free-assignments))
@@ -3878,7 +3906,7 @@ discarding."
 (defun byte-compile-function-form (form)
   (let ((f (nth 1 form)))
     (when (and (symbolp f)
-               (byte-compile-warning-enabled-p 'callargs))
+               (byte-compile-warning-enabled-p 'callargs f))
       (byte-compile-function-warn f t (byte-compile-fdefinition f nil)))
 
     (byte-compile-constant (if (eq 'lambda (car-safe f))
@@ -3948,7 +3976,8 @@ discarding."
         (let ((var (car-safe (cdr varexp))))
           (and (or (not (symbolp var))
                    (macroexp--const-symbol-p var t))
-               (byte-compile-warning-enabled-p 'constants)
+               (byte-compile-warning-enabled-p 'constants
+                                               (and (symbolp var) var))
                (byte-compile-warn
                 "variable assignment to %s `%s'"
                 (if (symbolp var) "constant" "nonvariable")
@@ -4609,7 +4638,7 @@ binding slots have been popped."
 
 (defun byte-compile-save-excursion (form)
   (if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
-           (byte-compile-warning-enabled-p 'suspicious))
+           (byte-compile-warning-enabled-p 'suspicious 'set-buffer))
       (byte-compile-warn
        "Use `with-current-buffer' rather than save-excursion+set-buffer"))
   (byte-compile-out 'byte-save-excursion 0)
@@ -4650,7 +4679,7 @@ binding slots have been popped."
   ;; This is not used for file-level defvar/consts.
   (when (and (symbolp (nth 1 form))
              (not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
-             (byte-compile-warning-enabled-p 'lexical))
+             (byte-compile-warning-enabled-p 'lexical (nth 1 form)))
     (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
                        (nth 1 form)))
   (let ((fun (nth 0 form))
@@ -4767,6 +4796,13 @@ binding slots have been popped."
   (let (byte-compile-warnings)
     (byte-compile-form (cons 'progn (cdr form)))))
 
+(byte-defop-compiler-1 internal--with-suppressed-warnings
+                       byte-compile-suppressed-warnings)
+(defun byte-compile-suppressed-warnings (form)
+  (let ((byte-compile--suppressed-warnings
+         (append (cadadr form) byte-compile--suppressed-warnings)))
+    (byte-compile-form (macroexp-progn (cddr form)))))
+
 ;; Warn about misuses of make-variable-buffer-local.
 (byte-defop-compiler-1 make-variable-buffer-local
                        byte-compile-make-variable-buffer-local)
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 83162d250fc..6fe7f5b571d 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -686,6 +686,96 @@ literals (Bug#20852)."
       (should-not (member '(byte-constant 333) lap))
       (should (member '(byte-constant 444) lap)))))
 
+(defun test-suppression (form suppress match)
+  (let ((lexical-binding t)
+        (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*")))
+    ;; Check that we get a warning without suppression.
+    (with-current-buffer byte-compile-log-buffer
+      (let ((inhibit-read-only t))
+        (erase-buffer)))
+    (test-byte-comp-compile-and-load t form)
+    (with-current-buffer byte-compile-log-buffer
+      (unless match
+        (error "%s" (buffer-string)))
+      (goto-char (point-min))
+      (should (re-search-forward match nil t)))
+    ;; And that it's gone now.
+    (with-current-buffer byte-compile-log-buffer
+      (let ((inhibit-read-only t))
+        (erase-buffer)))
+    (test-byte-comp-compile-and-load t
+     `(with-suppressed-warnings ,suppress
+        ,form))
+    (with-current-buffer byte-compile-log-buffer
+      (goto-char (point-min))
+      (should-not (re-search-forward match nil t)))
+    ;; Also check that byte compiled forms are identical.
+    (should (equal (byte-compile form)
+                   (byte-compile
+                    `(with-suppressed-warnings ,suppress ,form))))))
+
+(ert-deftest bytecomp-test--with-suppressed-warnings ()
+  (test-suppression
+   '(defvar prefixless)
+   '((lexical prefixless))
+   "global/dynamic var .prefixless. lacks")
+
+  (test-suppression
+   '(defun foo()
+      (let ((nil t))
+        (message-mail)))
+   '((constants nil))
+   "Warning: attempt to let-bind constant .nil.")
+
+  (test-suppression
+   '(progn
+      (defun obsolete ()
+        (declare (obsolete foo "22.1")))
+      (defun zot ()
+        (obsolete)))
+   '((obsolete obsolete))
+   "Warning: .obsolete. is an obsolete function")
+
+  (test-suppression
+   '(progn
+      (defun wrong-params (foo &optional unused)
+        (ignore unused)
+        foo)
+      (defun zot ()
+        (wrong-params 1 2 3)))
+   '((callargs wrong-params))
+   "Warning: wrong-params called with")
+
+  (test-byte-comp-compile-and-load nil
+    (defvar obsolete-variable nil)
+    (make-obsolete-variable 'obsolete-variable nil "24.1"))
+  (test-suppression
+   '(defun zot ()
+      obsolete-variable)
+   '((obsolete obsolete-variable))
+   "obsolete")
+
+  (test-suppression
+   '(defun zot ()
+      (mapcar #'list '(1 2 3))
+      nil)
+   '((mapcar mapcar))
+   "Warning: .mapcar. called for effect")
+
+  (test-suppression
+   '(defun zot ()
+      free-variable)
+   '((free-vars free-variable))
+   "Warning: reference to free variable")
+
+  (test-suppression
+   '(defun zot ()
+      (save-excursion
+        (set-buffer (get-buffer-create "foo"))
+        nil))
+   '((suspicious set-buffer))
+   "Warning: Use .with-current-buffer. rather than"))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: