From: John Williams <jrw@pobox.com>
To: 28803@debbugs.gnu.org
Subject: bug#28803: [PATCH] Fixed compiler warnings for advised functions.
Date: Thu, 12 Oct 2017 16:02:39 -0700 [thread overview]
Message-ID: <CAEdRJLBHCJkMRy2quaJN47+6MidAN7EPF3XP0rmTvEd8C-WGqg@mail.gmail.com> (raw)
[-- 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
next reply other threads:[~2017-10-12 23:02 UTC|newest]
Thread overview: 10+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-10-12 23:02 John Williams [this message]
2017-10-14 5:51 ` bug#28803: [PATCH] Fixed compiler warnings for advised functions 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
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=CAEdRJLBHCJkMRy2quaJN47+6MidAN7EPF3XP0rmTvEd8C-WGqg@mail.gmail.com \
--to=jrw@pobox.com \
--cc=28803@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.