From 3589eea932f5dec0125a3dcd16061385c0f30a5e Mon Sep 17 00:00:00 2001 From: John Williams 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