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) <advice>: 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 5e468cd02239c8e837e57d1a7270b6c256396e04..072902f6af056b34f7ba6c48ec73e5d691ac1b54 100644 (file)
--- 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 d86b71d48cce9249c3bf544599222af7d5d62cd2..ebedfa9c1226717b192c663054b1d079092e69ac 100644 (file)
--- 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 cfc2bed872934da7d0e3eb653e716e0aac54ae14..f8ed5bfa394102a7b99975717612c9a531df9ae5 100644 (file)
--- 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 ffb1331e6ac3f62131f4159c2256916d7a87f5a7..bd1f4ba9690ccf6bf8b6d705170f17d8a8790129 100644 (file)
--- 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 ee33bb0fa40bbb2e164d4fa0458d94957856514b..22125e6f9ffec156da5458891f6df5110d642d08 100644 (file)
--- 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)))))