Make called-interactively-p work for edebug or advised code.
* lisp/subr.el (called-interactively-p-functions): New var. (internal--called-interactively-p--get-frame): New macro. (called-interactively-p, interactive-p): Rewrite in Lisp. * lisp/emacs-lisp/nadvice.el (advice--called-interactively-skip): New fun. (called-interactively-p-functions): Use it. * lisp/emacs-lisp/edebug.el (edebug--called-interactively-skip): New fun. (called-interactively-p-functions): Use it. * lisp/allout.el (allout-called-interactively-p): Don't assume called-interactively-p is a subr. * src/eval.c (Finteractive_p, Fcalled_interactively_p, interactive_p): Remove. (syms_of_eval): Remove corresponding defsubr. * src/bytecode.c (exec_byte_code): `interactive-p' is now a Lisp function. * test/automated/advice-tests.el (advice-tests--data): Remove. (advice-tests): Move the tests directly here instead. Add called-interactively-p tests.
This commit is contained in:
parent
b0636be7f9
commit
23ba2705e2
10 changed files with 336 additions and 186 deletions
|
@ -4268,6 +4268,21 @@ With prefix argument, make it a temporary breakpoint."
|
|||
|
||||
;;; Finalize Loading
|
||||
|
||||
;; When edebugging a function, some of the sub-expressions are
|
||||
;; wrapped in (edebug-enter (lambda () ..)), so we need to teach
|
||||
;; called-interactively-p that calls within the inner lambda should refer to
|
||||
;; the outside function.
|
||||
(add-hook 'called-interactively-p-functions
|
||||
#'edebug--called-interactively-skip)
|
||||
(defun edebug--called-interactively-skip (i frame1 frame2)
|
||||
(when (and (eq (car-safe (nth 1 frame1)) 'lambda)
|
||||
(eq (nth 1 (nth 1 frame1)) '())
|
||||
(eq (nth 1 frame2) 'edebug-enter))
|
||||
;; `edebug-enter' calls itself on its first invocation.
|
||||
(if (eq (nth 1 (internal--called-interactively-p--get-frame i))
|
||||
'edebug-enter)
|
||||
2 1)))
|
||||
|
||||
;; Finally, hook edebug into the rest of Emacs.
|
||||
;; There are probably some other things that could go here.
|
||||
|
||||
|
|
|
@ -402,6 +402,56 @@ of the piece of advice."
|
|||
(if (fboundp function-name)
|
||||
(symbol-function function-name))))))
|
||||
|
||||
;; When code is advised, called-interactively-p needs to be taught to skip
|
||||
;; the advising frames.
|
||||
;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p
|
||||
;; done from the advised function if the deepest advice is an around advice!
|
||||
;; In other cases (calls from an advice or calls from the advised function when
|
||||
;; the deepest advice is not an around advice), it should hopefully get
|
||||
;; it right.
|
||||
(add-hook 'called-interactively-p-functions
|
||||
#'advice--called-interactively-skip)
|
||||
(defun advice--called-interactively-skip (origi frame1 frame2)
|
||||
(let* ((i origi)
|
||||
(get-next-frame
|
||||
(lambda ()
|
||||
(setq frame1 frame2)
|
||||
(setq frame2 (internal--called-interactively-p--get-frame i))
|
||||
;; (message "Advice Frame %d = %S" i frame2)
|
||||
(setq i (1+ i)))))
|
||||
(when (and (eq (nth 1 frame2) 'apply)
|
||||
(progn
|
||||
(funcall get-next-frame)
|
||||
(advice--p (indirect-function (nth 1 frame2)))))
|
||||
(funcall get-next-frame)
|
||||
;; If we now have the symbol, this was the head advice and
|
||||
;; we're done.
|
||||
(while (advice--p (nth 1 frame1))
|
||||
;; This was an inner advice called from some earlier advice.
|
||||
;; The stack frames look different depending on the particular
|
||||
;; kind of the earlier advice.
|
||||
(let ((inneradvice (nth 1 frame1)))
|
||||
(if (and (eq (nth 1 frame2) 'apply)
|
||||
(progn
|
||||
(funcall get-next-frame)
|
||||
(advice--p (indirect-function
|
||||
(nth 1 frame2)))))
|
||||
;; The earlier advice was something like a before/after
|
||||
;; advice where the "next" code is called directly by the
|
||||
;; advice--p object.
|
||||
(funcall get-next-frame)
|
||||
;; It's apparently an around advice, where the "next" is
|
||||
;; called by the body of the advice in any way it sees fit,
|
||||
;; so we need to skip the frames of that body.
|
||||
(while
|
||||
(progn
|
||||
(funcall get-next-frame)
|
||||
(not (and (eq (nth 1 frame2) 'apply)
|
||||
(eq (nth 3 frame2) inneradvice)))))
|
||||
(funcall get-next-frame)
|
||||
(funcall get-next-frame))))
|
||||
(- i origi 1))))
|
||||
|
||||
|
||||
(provide 'nadvice)
|
||||
;;; nadvice.el ends here
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue