[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)))))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- scratch/fcr 5837f75: nadvice.el: Restore interactive-form handling,
Stefan Monnier <=