[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp d07d7ab 1/2: Add `advice-flet' macro
From: |
Andrea Corallo |
Subject: |
feature/native-comp d07d7ab 1/2: Add `advice-flet' macro |
Date: |
Fri, 2 Oct 2020 15:22:09 -0400 (EDT) |
branch: feature/native-comp
commit d07d7ab1a0e321ced62ebe5dd9db27eb7e93430e
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Add `advice-flet' macro
The testsuite does large use of primitive redefinition, to avoid that
we define `advice-flet' to use instead as an easy `cl-letf'
replacement.
* lisp/emacs-lisp/nadvice.el (advice-flet): New macro.
---
lisp/emacs-lisp/nadvice.el | 26 ++++++++++++++++++++++++++
1 file changed, 26 insertions(+)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 5b3aa70..21da038 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -356,6 +356,32 @@ of the piece of advice."
(macroexp-let2 nil new `(advice--remove-function ,getter ,function)
`(unless (eq ,new ,getter) ,(funcall setter new)))))
+;;;###autoload
+(defmacro advice-flet (bindings &rest body)
+ ;; FIXME add doc.
+ (declare (indent 1))
+ (let ((let-binds ())
+ (ad-add ())
+ (ad-del ()))
+ (dolist (bind bindings)
+ (let* ((fun-name (car bind))
+ (fun (cadr bind))
+ (tmp-sym (gensym (symbol-name fun-name))))
+ (push `(,tmp-sym ,fun) let-binds)
+ (push `(advice-add #',fun-name
+ ,(if (= (length bind) 3)
+ (nth 2 bind)
+ :override)
+ ,tmp-sym)
+ ad-add)
+ (push `(advice-remove #',fun-name ,tmp-sym) ad-del)))
+ `(let ,(reverse let-binds)
+ (unwind-protect
+ (progn
+ ,@(reverse ad-add)
+ ,@body)
+ ,@(reverse ad-del)))))
+
(defun advice-function-mapc (f function-def)
"Apply F to every advice function in FUNCTION-DEF.
F is called with two arguments: the function that was added, and the