unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#28803: [PATCH] Fixed compiler warnings for advised functions.
@ 2017-10-12 23:02 John Williams
  2017-10-14  5:51 ` Noam Postavsky
  0 siblings, 1 reply; 10+ messages in thread
From: John Williams @ 2017-10-12 23:02 UTC (permalink / raw)
  To: 28803

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



[-- Attachment #2: 0001-Fixed-compiler-warnings-for-advised-functions.patch --]
[-- Type: text/x-patch, Size: 11385 bytes --]

From 3589eea932f5dec0125a3dcd16061385c0f30a5e Mon Sep 17 00:00:00 2001
From: John Williams <jrw@pobox.com>
Date: Thu, 12 Oct 2017 15:57:37 -0700
Subject: [PATCH] Fixed compiler warnings for advised functions.

Added the function `get-advertised-calling-convention', which is
mostly copied from `help-function-arglist'.  Changed
`help-function-arglist' to use `get-advertised-calling-convention'.
Changed nadvice.el to use `get-advertised-calling-convention' instead
of directly querying `advertised-signature-table'.  Added a unit test
to show that previously-advised functions now compile without
warnings.
---
 lisp/emacs-lisp/byte-run.el      | 76 ++++++++++++++++++++++++++++++++++++++--
 lisp/emacs-lisp/nadvice.el       |  7 ++--
 lisp/help.el                     | 52 +++------------------------
 test/automated/bytecomp-tests.el | 11 +++++-
 test/automated/cl-lib-tests.el   |  4 +--
 5 files changed, 94 insertions(+), 56 deletions(-)
 mode change 100644 => 100755 lisp/emacs-lisp/byte-run.el
 mode change 100644 => 100755 lisp/emacs-lisp/nadvice.el
 mode change 100644 => 100755 lisp/help.el
 mode change 100644 => 100755 test/automated/bytecomp-tests.el
 mode change 100644 => 100755 test/automated/cl-lib-tests.el

diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
old mode 100644
new mode 100755
index de6755a41c7..972a069084f
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -325,13 +325,83 @@ defsubst
 
 (defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key))
 
+(defun get-advertised-calling-convention (function &optional preserve-names)
+  "Return a formal argument list for the function FUNCTION.
+If PRESERVE-NAMES is non-nil, return a formal arglist that uses
+the same names as used in the original source code, when possible.
+
+If the function definition is an autoload, return 'autoload.
+Otherwise, if the argument list is unavailable, return t."
+
+  (let* ((def
+          ;; Handle symbols aliased to other symbols.
+          (indirect-function function))
+         (sig (gethash def advertised-signature-table t)))
+    (if (listp sig)
+        sig
+      ;; Advice wrappers have "catch all" args, so fetch the actual underlying
+      ;; function to find the real arguments.
+      (while (advice--p def) (setq def (advice--cdr def)))
+      ;; If definition is a macro, find the function inside it.
+      (if (eq (car-safe def) 'macro) (setq def (cdr def)))
+      (cond
+       ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0))
+       ((eq (car-safe def) 'lambda) (nth 1 def))
+       ((eq (car-safe def) 'closure) (nth 2 def))
+       ((or (and (byte-code-function-p def) (integerp (aref def 0)))
+            (subrp def))
+        (or (when preserve-names
+              (let* ((doc (condition-case nil (documentation def) (error nil)))
+                     (docargs (if doc (car (help-split-fundoc doc nil))))
+                     (arglist (if docargs
+                                  (cdar (read-from-string (downcase docargs)))))
+                     (valid t))
+                ;; Check validity.
+                (dolist (arg arglist)
+                  (unless (and (symbolp arg)
+                               (let ((name (symbol-name arg)))
+                                 (if (eq (aref name 0) ?&)
+                                     (memq arg '(&rest &optional))
+                                   (not (string-match "\\." name)))))
+                    (setq valid nil)))
+                (when valid arglist)))
+            (let* ((args-desc (if (not (subrp def))
+                                  (aref def 0)
+                                (let ((a (subr-arity def)))
+                                  (logior (car a)
+                                          (if (numberp (cdr a))
+                                              (lsh (cdr a) 8)
+                                            (lsh 1 7))))))
+                   (max (lsh args-desc -8))
+                   (min (logand args-desc 127))
+                   (rest (logand args-desc 128))
+                   (arglist ()))
+              (dotimes (i min)
+                (push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
+              (when (> max min)
+                (push '&optional arglist)
+                (dotimes (i (- max min))
+                  (push (intern (concat "arg" (number-to-string (+ 1 i min))))
+                        arglist)))
+              (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
+              (nreverse arglist))))
+       ((and (autoloadp def) (not (eq (nth 4 def) 'keymap)))
+        'autoload)
+       (t t)))))
+
 (defun set-advertised-calling-convention (function signature _when)
   "Set the advertised SIGNATURE of FUNCTION.
 This will allow the byte-compiler to warn the programmer when she uses
 an obsolete calling convention.  WHEN specifies since when the calling
-convention was modified."
-  (puthash (indirect-function function) signature
-           advertised-signature-table))
+convention was modified.
+
+For symmetry with with `get-advertised-calling-convention', if
+SIGNATURE is not a list, the advertised signature for FUNCTION is
+removed."
+  (if (listp signature)
+      (puthash (indirect-function function) signature
+               advertised-signature-table)
+    (remhash (indirect-function function) advertised-signature-table)))
 
 (defun make-obsolete (obsolete-name current-name &optional when)
   "Make the byte-compiler warn that function OBSOLETE-NAME is obsolete.
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
old mode 100644
new mode 100755
index 5a100b790f1..3e5c83af902
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -157,14 +157,17 @@ advice--make-interactive-form
 
 (defun advice--make-1 (byte-code stack-depth function main props)
   "Build a function value that adds FUNCTION to MAIN."
-  (let ((adv-sig (gethash main advertised-signature-table))
+  (let ((adv-sig (get-advertised-calling-convention main))
         (advice
          (apply #'make-byte-code 128 byte-code
                 (vector #'apply function main props) stack-depth nil
                 (and (or (commandp function) (commandp main))
                      (list (advice--make-interactive-form
                             function main))))))
-    (when adv-sig (puthash advice adv-sig advertised-signature-table))
+    (when (listp adv-sig)
+      ;; Don’t use set-advertised-calling-convention here; it causes
+      ;; strange problems.
+      (puthash advice adv-sig advertised-signature-table))
     advice))
 
 (defun advice--make (where function main props)
diff --git a/lisp/help.el b/lisp/help.el
old mode 100644
new mode 100755
index 68e8890ee1b..31ac4494183
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1404,54 +1404,10 @@ help-function-arglist
   "Return a formal argument list for the function DEF.
 IF PRESERVE-NAMES is non-nil, return a formal arglist that uses
 the same names as used in the original source code, when possible."
-  ;; Handle symbols aliased to other symbols.
-  (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def)))
-  ;; If definition is a macro, find the function inside it.
-  (if (eq (car-safe def) 'macro) (setq def (cdr def)))
-  (cond
-   ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0))
-   ((eq (car-safe def) 'lambda) (nth 1 def))
-   ((eq (car-safe def) 'closure) (nth 2 def))
-   ((or (and (byte-code-function-p def) (integerp (aref def 0)))
-        (subrp def))
-    (or (when preserve-names
-          (let* ((doc (condition-case nil (documentation def) (error nil)))
-                 (docargs (if doc (car (help-split-fundoc doc nil))))
-                 (arglist (if docargs
-                              (cdar (read-from-string (downcase docargs)))))
-                 (valid t))
-            ;; Check validity.
-            (dolist (arg arglist)
-              (unless (and (symbolp arg)
-                           (let ((name (symbol-name arg)))
-                             (if (eq (aref name 0) ?&)
-                                 (memq arg '(&rest &optional))
-                               (not (string-match "\\." name)))))
-                (setq valid nil)))
-            (when valid arglist)))
-        (let* ((args-desc (if (not (subrp def))
-                              (aref def 0)
-                            (let ((a (subr-arity def)))
-                              (logior (car a)
-                                      (if (numberp (cdr a))
-                                          (lsh (cdr a) 8)
-                                        (lsh 1 7))))))
-               (max (lsh args-desc -8))
-               (min (logand args-desc 127))
-               (rest (logand args-desc 128))
-               (arglist ()))
-          (dotimes (i min)
-            (push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
-          (when (> max min)
-            (push '&optional arglist)
-            (dotimes (i (- max min))
-              (push (intern (concat "arg" (number-to-string (+ 1 i min))))
-                    arglist)))
-          (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
-          (nreverse arglist))))
-   ((and (autoloadp def) (not (eq (nth 4 def) 'keymap)))
-    "[Arg list not available until function definition is loaded.]")
-   (t t)))
+  (let ((sig (get-advertised-calling-convention def preserve-names)))
+    (if (eq sig 'autoload)
+        "[Arg list not available until function definition is loaded.]"
+      sig)))
 
 (defun help--make-usage (function arglist)
   (cons (if (symbolp function) function 'anonymous)
diff --git a/test/automated/bytecomp-tests.el b/test/automated/bytecomp-tests.el
old mode 100644
new mode 100755
index f07138d3c55..ce1306abe60
--- a/test/automated/bytecomp-tests.el
+++ b/test/automated/bytecomp-tests.el
@@ -420,10 +420,19 @@ test-byte-comp-compile-and-load
       (defun def () (m))))
   (should (equal (funcall 'def) 4)))
 
+(ert-deftest bytecomp-tests--test-no-warnings-with-advice ()
+  (defun f ())
+  (define-advice f (:around (oldfun &rest args) test)
+    (apply oldfun args))
+  (with-current-buffer (get-buffer-create "*Compile-Log*")
+    (let ((inhibit-read-only t)) (erase-buffer)))
+  (test-byte-comp-compile-and-load t '(defun f ()))
+  (with-current-buffer (get-buffer-create "*Compile-Log*")
+    (goto-char (point-min))
+    (should-not (search-forward "Warning" nil t))))
 
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End:
 
 (provide 'byte-opt-testsuite)
-
diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el
old mode 100644
new mode 100755
index 5edc3e72bf2..d4e787e56a6
--- a/test/automated/cl-lib-tests.el
+++ b/test/automated/cl-lib-tests.el
@@ -230,8 +230,8 @@
 (ert-deftest cl-lib-arglist-performance ()
   ;; An `&aux' should not cause lambda's arglist to be turned into an &rest
   ;; that's parsed by hand.
-  (should (equal () (help-function-arglist 'cl-lib--con-1)))
-  (should (pcase (help-function-arglist 'cl-lib--con-2)
+  (should (equal () (get-advertised-calling-convention 'cl-lib--con-1)))
+  (should (pcase (get-advertised-calling-convention 'cl-lib--con-2)
             (`(&optional ,_) t))))
 
 (ert-deftest cl-the ()
-- 
2.15.0.rc0.271.g36b669edcc-goog


^ permalink raw reply related	[flat|nested] 10+ messages in thread
end of thread, other threads:[~2017-10-22 14:04 UTC | newest]

Thread overview: 10+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2017-10-12 23:02 bug#28803: [PATCH] Fixed compiler warnings for advised functions John Williams
2017-10-14  5:51 ` Noam Postavsky
     [not found]   ` <CAEdRJLCj0xMqWx5DNXALJQrJw7Z-nUYzXgHeB3Jh3zQd0zPB+A@mail.gmail.com>
     [not found]     ` <CAEdRJLCYmqcBajzDo-zHwuTg-mN=8APiZ6REYgYV5TAAu_E02A@mail.gmail.com>
2017-10-14 22:55       ` John Williams
2017-10-14 23:47         ` Noam Postavsky
2017-10-15  0:30           ` John Williams
2017-10-15  1:00             ` Noam Postavsky
2017-10-21 23:33           ` Noam Postavsky
2017-10-22  2:23             ` John Williams
2017-10-22 13:04               ` Noam Postavsky
2017-10-22 14:04               ` Eli Zaretskii

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).