emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

scratch/fcr 5837f75: nadvice.el: Restore interactive-form handling


From: Stefan Monnier
Subject: scratch/fcr 5837f75: nadvice.el: Restore interactive-form handling
Date: Sat, 18 Dec 2021 17:25:59 -0500 (EST)

branch: scratch/fcr
commit 5837f75e0f1fb58df9d7f97f79ec1de9db2fc78c
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    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/fcr.el (fcr-lambda): Fix thinko.
    
    * lisp/emacs-lisp/cl-generic.el: Prefill with an FCR dispatcher.
---
 lisp/emacs-lisp/cl-generic.el         |  2 ++
 lisp/emacs-lisp/fcr.el                | 17 +++++-----
 lisp/emacs-lisp/nadvice.el            | 10 +++++-
 lisp/simple.el                        | 62 +++++++++++++++++++----------------
 test/lisp/emacs-lisp/nadvice-tests.el |  8 ++---
 5 files changed, 57 insertions(+), 42 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 7a2a397..0dad76a 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--fcr-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/fcr.el b/lisp/emacs-lisp/fcr.el
index 83b6281..8f01d56 100644
--- a/lisp/emacs-lisp/fcr.el
+++ b/lisp/emacs-lisp/fcr.el
@@ -214,23 +214,22 @@
     ;; a docstring slot to FCRs.
     (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).
-         (fcr--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).
+       (fcr--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 fcr--fix-type (fcr)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 8dc9aa5..f75f527 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -65,7 +65,7 @@
     (:before-while ,(fcr-lambda advice ((where :before-while)) (&rest args)
                      (and (apply car args) (apply cdr args))))
     (:filter-args ,(fcr-lambda advice ((where :filter-args)) (&rest args)
-                     (apply cdr (funcall cdr args))))
+                     (apply cdr (funcall car args))))
     (:filter-return ,(fcr-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/simple.el b/lisp/simple.el
index ffb1331..bd1f4ba 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 ee33bb0..22125e6 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)))))
 



reply via email to

[Prev in Thread] Current Thread [Next in Thread]