From: Stefan Monnier Date: Sat, 18 Dec 2021 22:25:50 +0000 (-0500) Subject: nadvice.el: Restore interactive-form handling X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9465a7e59e7cc0140762c4c6fd9e83cfc7dd27a6;p=emacs.git nadvice.el: Restore interactive-form handling * test/lisp/emacs-lisp/nadvice-tests.el (advice-test-call-interactively): Prefer a locally scoped function. * lisp/simple.el (interactive-form): Don't skip the method dispatch when recursing. (interactive-form) : New method. * lisp/emacs-lisp/nadvice.el (advice--where-alist): Fix typo. (advice--get-interactive-form): New function. * lisp/emacs-lisp/oclosure.el (oclosure-lambda): Fix thinko. * lisp/emacs-lisp/cl-generic.el: Prefill with an OClosure dispatcher. --- diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5e468cd0223..072902f6af0 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1304,6 +1304,8 @@ Used internally for the (major-mode MODE) context specializers." (list cl-generic--oclosure-generalizer)))) (cl-call-next-method))) +(cl--generic-prefill-dispatchers 0 advice) + ;;; Support for unloading. (cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index d86b71d48cc..ebedfa9c122 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -65,7 +65,7 @@ (:before-while ,(oclosure-lambda advice ((where :before-while)) (&rest args) (and (apply car args) (apply cdr args)))) (:filter-args ,(oclosure-lambda advice ((where :filter-args)) (&rest args) - (apply cdr (funcall cdr args)))) + (apply cdr (funcall car args)))) (:filter-return ,(oclosure-lambda advice ((where :filter-return)) (&rest args) (funcall car (apply cdr args))))) "List of descriptions of how to add a function. @@ -176,6 +176,14 @@ function of type `advice'.") `(funcall ',fspec ',(cadr ifm)) (cadr (or iff ifm))))) + +;; This is the `advice' method of `interactive-form'. +(defun advice--get-interactive-form (ad) + (let ((car (advice--car ad)) + (cdr (advice--cdr ad))) + (when (or (commandp car) (commandp cdr)) + `(interactive ,(advice--make-interactive-form car cdr))))) + (defun advice--make (where function main props) "Build a function value that adds FUNCTION to MAIN at WHERE. WHERE is a symbol to select an entry in `advice--where-alist'." diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index cfc2bed8729..f8ed5bfa394 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -214,23 +214,22 @@ ;; a docstring slot to OClosures. (while (memq (car-safe (car-safe body)) '(interactive declare)) (push (pop body) prebody)) - ;; FIXME: Optimize temps away when they're provided in the right order! + ;; FIXME: Optimize temps away when they're provided in the right order? ;; FIXME: Slots not specified in `fields' tend to emit "Variable FOO left ;; uninitialized"! `(let ,tempbinds - (let ,slotbinds - ;; FIXME: Prevent store-conversion for fields vars! - ;; FIXME: Set the object's *type*! - ;; FIXME: Make sure the slotbinds whose value is duplicable aren't - ;; just value/variable-propagated by the optimizer (tho I think our - ;; optimizer is too naive to be a problem currently). - (oclosure--fix-type + ;; FIXME: Prevent store-conversion for fields vars! + ;; FIXME: Make sure the slotbinds whose value is duplicable aren't + ;; just value/variable-propagated by the optimizer (tho I think our + ;; optimizer is too naive to be a problem currently). + (oclosure--fix-type + (let ,slotbinds (lambda ,args (:documentation ',type) ,@prebody ;; Add dummy code which accesses the field's vars to make sure ;; they're captured in the closure. - (if t nil ,@(mapcar #'car fields)) + (if t nil ,@(mapcar #'car slotbinds)) ,@body)))))) (defun oclosure--fix-type (oclosure) diff --git a/lisp/simple.el b/lisp/simple.el index ffb1331e6ac..bd1f4ba9690 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2345,36 +2345,42 @@ FUNCTION is expected to be a function value rather than, say, a mere symbol." doc))) (_ (signal 'invalid-function (list function))))) -(cl-defgeneric interactive-form (cmd) +(cl-defgeneric interactive-form (cmd &optional original-name) "Return the interactive form of CMD or nil if none. If CMD is not a command, the return value is nil. -Value, if non-nil, is a list (interactive SPEC)." - (let ((fun (indirect-function cmd))) ;Check cycles. - (when fun - (named-let loop ((fun cmd)) - (pcase fun - ((pred symbolp) - (or (get fun 'interactive-form) - (loop (symbol-function fun)))) - ((pred byte-code-function-p) - (when (> (length fun) 5) - (let ((form (aref fun 5))) - (if (vectorp form) - ;; The vector form is the new form, where the first - ;; element is the interactive spec, and the second is the - ;; command modes. - (list 'interactive (aref form 0)) - (list 'interactive form))))) - ((pred autoloadp) - (interactive-form (autoload-do-load fun cmd))) - ((or `(lambda ,_args . ,body) - `(closure ,_env ,_args . ,body)) - (let ((spec (assq 'interactive body))) - (if (cddr spec) - ;; Drop the "applicable modes" info. - (list 'interactive (cadr spec)) - spec))) - (_ (internal--interactive-form fun))))))) +Value, if non-nil, is a list (interactive SPEC). +ORIGINAL-NAME is used internally only." + (pcase cmd + ((pred symbolp) + (let ((fun (indirect-function cmd))) ;Check cycles. + (when fun + (or (get cmd 'interactive-form) + (interactive-form (symbol-function cmd) (or original-name cmd)))))) + ((pred byte-code-function-p) + (when (> (length cmd) 5) + (let ((form (aref cmd 5))) + (if (vectorp form) + ;; The vector form is the new form, where the first + ;; element is the interactive spec, and the second is the + ;; command modes. + (list 'interactive (aref form 0)) + (list 'interactive form))))) + ((pred autoloadp) + (interactive-form (autoload-do-load cmd original-name))) + ((or `(lambda ,_args . ,body) + `(closure ,_env ,_args . ,body)) + (let ((spec (assq 'interactive body))) + (if (cddr spec) + ;; Drop the "applicable modes" info. + (list 'interactive (cadr spec)) + spec))) + (_ (internal--interactive-form cmd)))) + +(cl-defmethod interactive-form ((function advice) &optional _) + ;; This should ideally be in `nadvice.el' but `nadvice.el' is loaded before + ;; `cl-generic.el' so it can't use `cl-defmethod'. + ;; FIXME: η-reduce! + (advice--get-interactive-form function)) (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index ee33bb0fa40..22125e6f9ff 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -153,13 +153,13 @@ function being an around advice." (ert-deftest advice-test-call-interactively () "Check interaction between advice on call-interactively and called-interactively-p." - (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p))) - (let ((old (symbol-function 'call-interactively))) + (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) + (old (symbol-function 'call-interactively))) (unwind-protect (progn (advice-add 'call-interactively :before #'ignore) - (should (equal (sm-test7.4) '(1 . nil))) - (should (equal (call-interactively 'sm-test7.4) '(1 . t)))) + (should (equal (funcall sm-test7.4) '(1 . nil))) + (should (equal (call-interactively sm-test7.4) '(1 . t)))) (advice-remove 'call-interactively #'ignore) (should (eq (symbol-function 'call-interactively) old)))))