diff options
Diffstat (limited to 'lisp/emacs-lisp/nadvice.el')
| -rw-r--r-- | lisp/emacs-lisp/nadvice.el | 76 |
1 files changed, 38 insertions, 38 deletions
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 85934d9ed0a..9f2b42f5765 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -165,6 +165,8 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (buffer-string)) usage)))) +;; FIXME: How about renaming this to just `eval-interactive-spec'? +;; It's not specific to the advice system. (defun advice-eval-interactive-spec (spec) "Evaluate the interactive spec SPEC." (cond @@ -174,24 +176,44 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") ;; FIXME: Despite appearances, this is not faithful: SPEC and ;; (advice-eval-interactive-spec SPEC) will behave subtly differently w.r.t ;; command-history (and maybe a few other details). - (call-interactively `(lambda (&rest args) (interactive ,spec) args))) + (call-interactively + ;; Sadly (lambda (&rest args) (interactive spec) args) doesn't work :-( + (cconv--interactive-helper (lambda (&rest args) args) spec))) ;; ((functionp spec) (funcall spec)) (t (eval spec)))) +(defun advice--interactive-form-1 (function) + "Like `interactive-form' but preserves the static context if needed." + (let ((if (interactive-form function))) + (if (or (null if) (not (eq 'closure (car-safe function)))) + if + (cl-assert (eq 'interactive (car if))) + (let ((form (cadr if))) + (if (macroexp-const-p form) + if + ;; The interactive is expected to be run in the static context + ;; that the function captured. + (let ((ctx (nth 1 function))) + `(interactive + ,(let* ((f (if (eq 'function (car-safe form)) (cadr form) form))) + ;; If the form jut returns a function, preserve the fact that + ;; it just returns a function, which is an info we use in + ;; `advice--make-interactive-form'. + (if (eq 'lambda (car-safe f)) + `',(eval form ctx) + `(eval ',form ',ctx)))))))))) + (defun advice--interactive-form (function) "Like `interactive-form' but tries to avoid autoloading functions." (if (not (and (symbolp function) (autoloadp (indirect-function function)))) - (interactive-form function) + (advice--interactive-form-1 function) (when (commandp function) `(interactive (advice-eval-interactive-spec - (cadr (interactive-form ',function))))))) + (cadr (advice--interactive-form-1 ',function))))))) (defun advice--make-interactive-form (iff ifm) - ;; TODO: make it so that interactive spec can be a constant which - ;; dynamically checks the advice--car/cdr to do its job. - ;; For that, advice-eval-interactive-spec needs to be more faithful. (let* ((fspec (cadr iff))) - (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? + (when (memq (car-safe fspec) '(function quote)) ;; Macroexpanded lambda? (setq fspec (eval fspec t))) (if (functionp fspec) `(funcall ',fspec ',(cadr ifm)) @@ -270,14 +292,13 @@ HOW is a symbol to select an entry in `advice--how-alist'." (equal function (cdr (assq 'name props)))) (list (advice--remove-function rest function))))))) -(defvar advice--buffer-local-function-sample nil - "Keeps an example of the special \"run the default value\" functions. -These functions play the same role as t in buffer-local hooks, and to recognize -them, we keep a sample here against which to compare. Each instance is -different, but `function-equal' will hopefully ignore those differences.") +(oclosure-define (advice--forward + (:predicate advice--forward-p)) + "Redirect to the global value of a var. +These functions act like the t special value in buffer-local hooks.") (defun advice--set-buffer-local (var val) - (if (function-equal val advice--buffer-local-function-sample) + (if (advice--forward-p val) (kill-local-variable var) (set (make-local-variable var) val))) @@ -286,11 +307,10 @@ different, but `function-equal' will hopefully ignore those differences.") "Buffer-local value of VAR, presumed to contain a function." (declare (gv-setter advice--set-buffer-local)) (if (local-variable-p var) (symbol-value var) - (setq advice--buffer-local-function-sample - ;; This function acts like the t special value in buffer-local hooks. - ;; FIXME: Provide an `advice-bottom' function that's like - ;; `advice-cd*r' but also follows through this proxy. - (lambda (&rest args) (apply (default-value var) args))))) + ;; FIXME: Provide an `advice-bottom' function that's like + ;; `advice--cd*r' but also follows through this proxy. + (oclosure-lambda (advice--forward) (&rest args) + (apply (default-value var) args)))) (eval-and-compile (defun advice--normalize-place (place) @@ -369,26 +389,8 @@ is also interactive. There are 3 cases: `(advice--add-function ,how (gv-ref ,(advice--normalize-place place)) ,function ,props)) -(declare-function comp-subr-trampoline-install "comp") - ;;;###autoload (defun advice--add-function (how ref function props) - (when (and (featurep 'native-compile) - (subr-primitive-p (gv-deref ref))) - (let ((subr-name (intern (subr-name (gv-deref ref))))) - ;; Requiring the native compiler to advice `macroexpand' cause a - ;; circular dependency in eager macro expansion. uniquify is - ;; advising `rename-buffer' while being loaded in loadup.el. - ;; This would require the whole native compiler machinery but we - ;; don't want to include it in the dump. Because these two - ;; functions are already handled in - ;; `native-comp-never-optimize-functions' we hack the problem - ;; this way for now :/ - (unless (memq subr-name '(macroexpand rename-buffer)) - ;; Must require explicitly as during bootstrap we have no - ;; autoloads. - (require 'comp) - (comp-subr-trampoline-install subr-name)))) (let* ((name (cdr (assq 'name props))) (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (when a @@ -507,8 +509,6 @@ HOW can be one of: <<>>" ;; TODO: ;; - record the advice location, to display in describe-function. - ;; - change all defadvice in lisp/**/*.el. - ;; - obsolete advice.el. (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) (unless (eq f nf) (fset symbol nf)) |