[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/oclosure 9465a7e59e 10/25: nadvice.el: Restore interactive-form
From: |
Stefan Monnier |
Subject: |
scratch/oclosure 9465a7e59e 10/25: nadvice.el: Restore interactive-form handling |
Date: |
Fri, 31 Dec 2021 15:40:57 -0500 (EST) |
branch: scratch/oclosure
commit 9465a7e59e7cc0140762c4c6fd9e83cfc7dd27a6
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/oclosure.el (oclosure-lambda): Fix thinko.
* lisp/emacs-lisp/cl-generic.el: Prefill with an OClosure dispatcher.
---
lisp/emacs-lisp/cl-generic.el | 2 ++
lisp/emacs-lisp/nadvice.el | 10 +++++-
lisp/emacs-lisp/oclosure.el | 17 +++++-----
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 5e468cd022..072902f6af 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 d86b71d48c..ebedfa9c12 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 cfc2bed872..f8ed5bfa39 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 ffb1331e6a..bd1f4ba969 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 ee33bb0fa4..22125e6f9f 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)))))
- scratch/oclosure ae0bfc4f75 05/25: * lisp/loadup.el (oclosure): Load before `nadvice`, (continued)
- scratch/oclosure ae0bfc4f75 05/25: * lisp/loadup.el (oclosure): Load before `nadvice`, Stefan Monnier, 2021/12/31
- scratch/oclosure afa68def26 11/25: cl-print.el: Dispatch on `advice` type, Stefan Monnier, 2021/12/31
- scratch/oclosure fe5457ff75 19/25: oclosure.el (oclosure-lambda): Change calling convention, Stefan Monnier, 2021/12/31
- scratch/oclosure d93b0ad4d4 06/25: (interactive-form, function-docstring): New generic functions, Stefan Monnier, 2021/12/31
- scratch/oclosure a444d85977 08/25: Fix bootstrap problems and various misc issues found along the way, Stefan Monnier, 2021/12/31
- scratch/oclosure f44ee8cd53 17/25: oclosure.el (accessor): New type, Stefan Monnier, 2021/12/31
- scratch/oclosure 55a8e92413 20/25: oclosure.el: Add support for mutable slots, Stefan Monnier, 2021/12/31
- scratch/oclosure bc1d94a0d8 21/25: * lisp/emacs-lisp/oclosure.el (Commentary:): Add a few notes, Stefan Monnier, 2021/12/31
- scratch/oclosure 263172dbfb 02/25: lisp/emacs-lisp/oclosure.el: Make it available to cl-generic, Stefan Monnier, 2021/12/31
- scratch/oclosure 3119e59252 07/25: lisp/emacs-lisp/oclosure.el: Rename `oclosure-make` to `oclosure-lambda`, Stefan Monnier, 2021/12/31
- scratch/oclosure 9465a7e59e 10/25: nadvice.el: Restore interactive-form handling,
Stefan Monnier <=
- scratch/oclosure 3c9d64b602 14/25: cl-macs.el (cl--transform-lambda): Fix last change, Stefan Monnier, 2021/12/31
- scratch/oclosure 01002ebba0 18/25: oclosure.el (oclosure-define): Use `oclosure--copy` to define accessors, Stefan Monnier, 2021/12/31
- scratch/oclosure 20e5cd82ae 13/25: Fix bug#28557, Stefan Monnier, 2021/12/31
- scratch/oclosure 44dbab47f7 23/25: * lisp/emacs-lisp/oclosure.el: Remove obsolete comment, Stefan Monnier, 2021/12/31
- scratch/oclosure 1ace4acd54 22/25: Replace uniquify.el's advice with direct calls, Stefan Monnier, 2021/12/31
- scratch/oclosure 3aa60102b9 24/25: kmacro.el: Unify the lambda and the list representations, Stefan Monnier, 2021/12/31
- scratch/oclosure e9cfab679d 15/25: lisp/emacs-lisp/cl-macs.el: Align with `master`, Stefan Monnier, 2021/12/31
- scratch/oclosure e65e2bd0aa 12/25: * lisp/emacs-lisp/cl-generic.el (cl-generic--oclosure-generalizer): Fix precedence, Stefan Monnier, 2021/12/31
- scratch/oclosure de320e2003 25/25: Arrange to load `nadvice` later in `loadup.el`, Stefan Monnier, 2021/12/31