mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-27 19:31:38 +00:00
* lisp/emacs-lisp/nadvice.el: New package.
* lisp/subr.el (special-form-p): New function. * lisp/emacs-lisp/elp.el: Use lexical-binding and advice-add. (elp-all-instrumented-list): Remove var. (elp-not-profilable): Remove elp-wrapper. (elp-profilable-p): Use autoloadp and special-form-p. (elp--advice-name): New const. (elp-instrument-function): Use advice-add. (elp--instrumented-p): New predicate. (elp-restore-function): Use advice-remove. (elp-restore-all, elp-reset-all): Use mapatoms. (elp-set-master): Use elp--instrumented-p. (elp--make-wrapper): Rename from elp-wrapper, return a function suitable for advice-add. Use cl-inf. (elp-results): Use mapatoms+elp--instrumented-p. * lisp/emacs-lisp/debug.el: Use lexical-binding and advice-add. (debug-function-list): Remove var. (debug): Rename arg, and then let-bind it explicitly inside. (debugger-setup-buffer): Rename arg. (debugger-setup-buffer): Adjust counts to new debug-on-entry setup. (debugger-frame-number): Adjust to new debug-on-entry setup. (debug--implement-debug-on-entry): Rename from implement-debug-on-entry, add argument. (debugger-special-form-p): Remove, use special-form-p instead. (debug-on-entry): Use advice-add. (debug--function-list): New function. (cancel-debug-on-entry): Use it, along with advice-remove. (debug-arglist, debug-convert-byte-code, debug-on-entry-1): Remove. (debugger-list-functions): Use debug--function-list instead of debug-function-list. * lisp/emacs-lisp/advice.el (ad-save-real-definition): Remove, unused. (ad-special-form-p): Remove, use special-form-p instead. (ad-set-advice-info): Use add-function and remove-function. (ad--defalias-fset): Adjust accordingly. * test/automated/advice-tests.el: New tests.
This commit is contained in:
Stefan Monnier
parent
be49ba7461
commit
231d8498eb
8
etc/NEWS
8
etc/NEWS
@ -27,6 +27,13 @@ so we will look at it and add it to the manual.
|
||||
* Editing Changes in Emacs 24.4
|
||||
* Changes in Specialized Modes and Packages in Emacs 24.4
|
||||
* New Modes and Packages in Emacs 24.4
|
||||
** New nadvice.el package offering lighter-weight advice facilities.
|
||||
It is layered as:
|
||||
- add-function/remove-function which can be used to add/remove code on any
|
||||
function-carrying place, such as process-filters or `<foo>-function' hooks.
|
||||
- advice-add/advice-remove to add/remove a piece of advice on a named function,
|
||||
much like `defadvice' does.
|
||||
|
||||
* Incompatible Lisp Changes in Emacs 24.4
|
||||
|
||||
** `dolist' in lexical-binding mode does not bind VAR in RESULT any more.
|
||||
@ -35,6 +42,7 @@ spurious warnings about an unused var.
|
||||
|
||||
* Lisp changes in Emacs 24.4
|
||||
|
||||
** New function special-form-p.
|
||||
** Docstrings can be made dynamic by adding a `dynamic-docstring-function'
|
||||
text-property on the first char.
|
||||
|
||||
|
||||
@ -1,3 +1,40 @@
|
||||
2012-11-12 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/nadvice.el: New package.
|
||||
* subr.el (special-form-p): New function.
|
||||
* emacs-lisp/elp.el: Use lexical-binding and advice-add.
|
||||
(elp-all-instrumented-list): Remove var.
|
||||
(elp-not-profilable): Remove elp-wrapper.
|
||||
(elp-profilable-p): Use autoloadp and special-form-p.
|
||||
(elp--advice-name): New const.
|
||||
(elp-instrument-function): Use advice-add.
|
||||
(elp--instrumented-p): New predicate.
|
||||
(elp-restore-function): Use advice-remove.
|
||||
(elp-restore-all, elp-reset-all): Use mapatoms.
|
||||
(elp-set-master): Use elp--instrumented-p.
|
||||
(elp--make-wrapper): Rename from elp-wrapper, return a function
|
||||
suitable for advice-add. Use cl-inf.
|
||||
(elp-results): Use mapatoms+elp--instrumented-p.
|
||||
* emacs-lisp/debug.el: Use lexical-binding and advice-add.
|
||||
(debug-function-list): Remove var.
|
||||
(debug): Rename arg, and then let-bind it explicitly inside.
|
||||
(debugger-setup-buffer): Rename arg.
|
||||
(debugger-setup-buffer): Adjust counts to new debug-on-entry setup.
|
||||
(debugger-frame-number): Adjust to new debug-on-entry setup.
|
||||
(debug--implement-debug-on-entry): Rename from
|
||||
implement-debug-on-entry, add argument.
|
||||
(debugger-special-form-p): Remove, use special-form-p instead.
|
||||
(debug-on-entry): Use advice-add.
|
||||
(debug--function-list): New function.
|
||||
(cancel-debug-on-entry): Use it, along with advice-remove.
|
||||
(debug-arglist, debug-convert-byte-code, debug-on-entry-1): Remove.
|
||||
(debugger-list-functions): Use debug--function-list instead of
|
||||
debug-function-list.
|
||||
* emacs-lisp/advice.el (ad-save-real-definition): Remove, unused.
|
||||
(ad-special-form-p): Remove, use special-form-p instead.
|
||||
(ad-set-advice-info): Use add-function and remove-function.
|
||||
(ad--defalias-fset): Adjust accordingly.
|
||||
|
||||
2012-11-10 Glenn Morris <rgm@gnu.org>
|
||||
|
||||
* mail/emacsbug.el (report-emacs-bug-tracker-url)
|
||||
|
||||
@ -1776,27 +1776,6 @@ generates a copy of TREE."
|
||||
(funcall fUnCtIoN tReE))
|
||||
(t tReE)))
|
||||
|
||||
;; @@ Save real definitions of subrs used by Advice:
|
||||
;; =================================================
|
||||
;; Advice depends on the real, unmodified functionality of various subrs,
|
||||
;; we save them here so advised versions will not interfere (eventually,
|
||||
;; we will save all subrs used in code generated by Advice):
|
||||
|
||||
(defmacro ad-save-real-definition (function)
|
||||
(let ((saved-function (intern (format "ad-real-%s" function))))
|
||||
;; Make sure the compiler is loaded during macro expansion:
|
||||
(require 'byte-compile "bytecomp")
|
||||
`(if (not (fboundp ',saved-function))
|
||||
(progn (fset ',saved-function (symbol-function ',function))
|
||||
;; Copy byte-compiler properties:
|
||||
,@(if (get function 'byte-compile)
|
||||
`((put ',saved-function 'byte-compile
|
||||
',(get function 'byte-compile))))
|
||||
,@(if (get function 'byte-opcode)
|
||||
`((put ',saved-function 'byte-opcode
|
||||
',(get function 'byte-opcode))))))))
|
||||
|
||||
|
||||
;; @@ Advice info access fns:
|
||||
;; ==========================
|
||||
|
||||
@ -1849,9 +1828,12 @@ On each iteration VAR will be bound to the name of an advised function
|
||||
|
||||
(defsubst ad-set-advice-info (function advice-info)
|
||||
(cond
|
||||
(advice-info (put function 'defalias-fset-function #'ad--defalias-fset))
|
||||
(advice-info
|
||||
(add-function :around (get function 'defalias-fset-function)
|
||||
#'ad--defalias-fset))
|
||||
((get function 'defalias-fset-function)
|
||||
(put function 'defalias-fset-function nil)))
|
||||
(remove-function (get function 'defalias-fset-function)
|
||||
#'ad--defalias-fset)))
|
||||
(put function 'ad-advice-info advice-info))
|
||||
|
||||
(defmacro ad-copy-advice-info (function)
|
||||
@ -1974,8 +1956,8 @@ Redefining advices affect the construction of an advised definition."
|
||||
;; to `ad-activate' by using `ad-with-auto-activation-disabled' where
|
||||
;; appropriate, especially in a safe version of `fset'.
|
||||
|
||||
(defun ad--defalias-fset (function definition)
|
||||
(fset function definition)
|
||||
(defun ad--defalias-fset (fsetfun function definition)
|
||||
(funcall (or fsetfun #'fset) function definition)
|
||||
(ad-activate-internal function nil))
|
||||
|
||||
;; For now define `ad-activate-internal' to the dummy definition:
|
||||
@ -2310,12 +2292,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
|
||||
"Take a macro function DEFINITION and make a lambda out of it."
|
||||
`(cdr ,definition))
|
||||
|
||||
(defun ad-special-form-p (definition)
|
||||
"Non-nil if and only if DEFINITION is a special form."
|
||||
(if (and (symbolp definition) (fboundp definition))
|
||||
(setq definition (indirect-function definition)))
|
||||
(and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled)))
|
||||
|
||||
(defmacro ad-subr-p (definition)
|
||||
;;"non-nil if DEFINITION is a subr."
|
||||
(list 'subrp definition))
|
||||
@ -2415,7 +2391,7 @@ definition (see the code for `documentation')."
|
||||
(cond
|
||||
((ad-macro-p definition) 'macro)
|
||||
((ad-subr-p definition)
|
||||
(if (ad-special-form-p definition)
|
||||
(if (special-form-p definition)
|
||||
'special-form
|
||||
'subr))
|
||||
((or (ad-lambda-p definition)
|
||||
@ -2804,7 +2780,7 @@ in any of these classes."
|
||||
(origname (ad-get-advice-info-field function 'origname))
|
||||
(orig-interactive-p (commandp origdef))
|
||||
(orig-subr-p (ad-subr-p origdef))
|
||||
(orig-special-form-p (ad-special-form-p origdef))
|
||||
(orig-special-form-p (special-form-p origdef))
|
||||
(orig-macro-p (ad-macro-p origdef))
|
||||
;; Construct the individual pieces that we need for assembly:
|
||||
(orig-arglist (ad-arglist origdef))
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
;;; debug.el --- debuggers and related commands for Emacs
|
||||
;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 1985-1986, 1994, 2001-2012 Free Software Foundation, Inc.
|
||||
|
||||
@ -81,9 +81,6 @@ The value used here is passed to `quit-restore-window'."
|
||||
:group 'debugger
|
||||
:version "24.2")
|
||||
|
||||
(defvar debug-function-list nil
|
||||
"List of functions currently set for debug on entry.")
|
||||
|
||||
(defvar debugger-step-after-exit nil
|
||||
"Non-nil means \"single-step\" after the debugger exits.")
|
||||
|
||||
@ -146,7 +143,7 @@ where CAUSE can be:
|
||||
;;;###autoload
|
||||
(setq debugger 'debug)
|
||||
;;;###autoload
|
||||
(defun debug (&rest debugger-args)
|
||||
(defun debug (&rest args)
|
||||
"Enter debugger. \\<debugger-mode-map>`\\[debugger-continue]' returns from the debugger.
|
||||
Arguments are mainly for use when this is called from the internals
|
||||
of the evaluator.
|
||||
@ -165,6 +162,7 @@ first will be printed into the backtrace buffer."
|
||||
(if (get-buffer "*Backtrace*")
|
||||
(with-current-buffer (get-buffer "*Backtrace*")
|
||||
(list major-mode (buffer-string)))))
|
||||
(debugger-args args)
|
||||
(debugger-buffer (get-buffer-create "*Backtrace*"))
|
||||
(debugger-old-buffer (current-buffer))
|
||||
(debugger-window nil)
|
||||
@ -219,7 +217,7 @@ first will be printed into the backtrace buffer."
|
||||
(save-excursion
|
||||
(when (eq (car debugger-args) 'debug)
|
||||
;; Skip the frames for backtrace-debug, byte-code,
|
||||
;; and implement-debug-on-entry.
|
||||
;; debug--implement-debug-on-entry and the advice's `apply'.
|
||||
(backtrace-debug 4 t)
|
||||
;; Place an extra debug-on-exit for macro's.
|
||||
(when (eq 'lambda (car-safe (cadr (backtrace-frame 4))))
|
||||
@ -318,7 +316,7 @@ first will be printed into the backtrace buffer."
|
||||
(setq debug-on-next-call debugger-step-after-exit)
|
||||
debugger-value)))
|
||||
|
||||
(defun debugger-setup-buffer (debugger-args)
|
||||
(defun debugger-setup-buffer (args)
|
||||
"Initialize the `*Backtrace*' buffer for entry to the debugger.
|
||||
That buffer should be current already."
|
||||
(setq buffer-read-only nil)
|
||||
@ -334,20 +332,22 @@ That buffer should be current already."
|
||||
(delete-region (point)
|
||||
(progn
|
||||
(search-forward "\n debug(")
|
||||
(forward-line (if (eq (car debugger-args) 'debug)
|
||||
2 ; Remove implement-debug-on-entry frame.
|
||||
(forward-line (if (eq (car args) 'debug)
|
||||
;; Remove debug--implement-debug-on-entry
|
||||
;; and the advice's `apply' frame.
|
||||
3
|
||||
1))
|
||||
(point)))
|
||||
(insert "Debugger entered")
|
||||
;; lambda is for debug-on-call when a function call is next.
|
||||
;; debug is for debug-on-entry function called.
|
||||
(pcase (car debugger-args)
|
||||
(pcase (car args)
|
||||
((or `lambda `debug)
|
||||
(insert "--entering a function:\n"))
|
||||
;; Exiting a function.
|
||||
(`exit
|
||||
(insert "--returning value: ")
|
||||
(setq debugger-value (nth 1 debugger-args))
|
||||
(setq debugger-value (nth 1 args))
|
||||
(prin1 debugger-value (current-buffer))
|
||||
(insert ?\n)
|
||||
(delete-char 1)
|
||||
@ -356,7 +356,7 @@ That buffer should be current already."
|
||||
;; Debugger entered for an error.
|
||||
(`error
|
||||
(insert "--Lisp error: ")
|
||||
(prin1 (nth 1 debugger-args) (current-buffer))
|
||||
(prin1 (nth 1 args) (current-buffer))
|
||||
(insert ?\n))
|
||||
;; debug-on-call, when the next thing is an eval.
|
||||
(`t
|
||||
@ -364,8 +364,8 @@ That buffer should be current already."
|
||||
;; User calls debug directly.
|
||||
(_
|
||||
(insert ": ")
|
||||
(prin1 (if (eq (car debugger-args) 'nil)
|
||||
(cdr debugger-args) debugger-args)
|
||||
(prin1 (if (eq (car args) 'nil)
|
||||
(cdr args) args)
|
||||
(current-buffer))
|
||||
(insert ?\n)))
|
||||
;; After any frame that uses eval-buffer,
|
||||
@ -525,9 +525,10 @@ removes itself from that hook."
|
||||
(count 0))
|
||||
(while (not (eq (cadr (backtrace-frame count)) 'debug))
|
||||
(setq count (1+ count)))
|
||||
;; Skip implement-debug-on-entry frame.
|
||||
(when (eq 'implement-debug-on-entry (cadr (backtrace-frame (1+ count))))
|
||||
(setq count (1+ count)))
|
||||
;; Skip debug--implement-debug-on-entry frame.
|
||||
(when (eq 'debug--implement-debug-on-entry
|
||||
(cadr (backtrace-frame (1+ count))))
|
||||
(setq count (+ 2 count)))
|
||||
(goto-char (point-min))
|
||||
(when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):")
|
||||
(goto-char (match-end 0))
|
||||
@ -694,10 +695,10 @@ Applies to the frame whose line point is on in the backtrace."
|
||||
:help "Continue to exit from this frame, with all debug-on-entry suspended"))
|
||||
(define-key menu-map [deb-cont]
|
||||
'(menu-item "Continue" debugger-continue
|
||||
:help "Continue, evaluating this expression without stopping"))
|
||||
:help "Continue, evaluating this expression without stopping"))
|
||||
(define-key menu-map [deb-step]
|
||||
'(menu-item "Step through" debugger-step-through
|
||||
:help "Proceed, stepping through subexpressions of this expression"))
|
||||
:help "Proceed, stepping through subexpressions of this expression"))
|
||||
map))
|
||||
|
||||
(put 'debugger-mode 'mode-class 'special)
|
||||
@ -777,7 +778,7 @@ For the cross-reference format, see `help-make-xrefs'."
|
||||
|
||||
;; When you change this, you may also need to change the number of
|
||||
;; frames that the debugger skips.
|
||||
(defun implement-debug-on-entry ()
|
||||
(defun debug--implement-debug-on-entry (&rest _ignore)
|
||||
"Conditionally call the debugger.
|
||||
A call to this function is inserted by `debug-on-entry' to cause
|
||||
functions to break on entry."
|
||||
@ -785,12 +786,6 @@ functions to break on entry."
|
||||
nil
|
||||
(funcall debugger 'debug)))
|
||||
|
||||
(defun debugger-special-form-p (symbol)
|
||||
"Return whether SYMBOL is a special form."
|
||||
(and (fboundp symbol)
|
||||
(subrp (symbol-function symbol))
|
||||
(eq (cdr (subr-arity (symbol-function symbol))) 'unevalled)))
|
||||
|
||||
;;;###autoload
|
||||
(defun debug-on-entry (function)
|
||||
"Request FUNCTION to invoke debugger each time it is called.
|
||||
@ -808,7 +803,7 @@ Use \\[cancel-debug-on-entry] to cancel the effect of this command.
|
||||
Redefining FUNCTION also cancels it."
|
||||
(interactive
|
||||
(let ((fn (function-called-at-point)) val)
|
||||
(when (debugger-special-form-p fn)
|
||||
(when (special-form-p fn)
|
||||
(setq fn nil))
|
||||
(setq val (completing-read
|
||||
(if fn
|
||||
@ -817,36 +812,21 @@ Redefining FUNCTION also cancels it."
|
||||
obarray
|
||||
#'(lambda (symbol)
|
||||
(and (fboundp symbol)
|
||||
(not (debugger-special-form-p symbol))))
|
||||
(not (special-form-p symbol))))
|
||||
t nil nil (symbol-name fn)))
|
||||
(list (if (equal val "") fn (intern val)))))
|
||||
;; FIXME: Use advice.el.
|
||||
(when (debugger-special-form-p function)
|
||||
(error "Function %s is a special form" function))
|
||||
(if (or (symbolp (symbol-function function))
|
||||
(subrp (symbol-function function)))
|
||||
;; The function is built-in or aliased to another function.
|
||||
;; Create a wrapper in which we can add the debug call.
|
||||
(fset function `(lambda (&rest debug-on-entry-args)
|
||||
,(interactive-form (symbol-function function))
|
||||
(apply ',(symbol-function function)
|
||||
debug-on-entry-args)))
|
||||
(when (autoloadp (symbol-function function))
|
||||
;; The function is autoloaded. Load its real definition.
|
||||
(autoload-do-load (symbol-function function) function))
|
||||
(when (or (not (consp (symbol-function function)))
|
||||
(and (eq (car (symbol-function function)) 'macro)
|
||||
(not (consp (cdr (symbol-function function))))))
|
||||
;; The function is byte-compiled. Create a wrapper in which
|
||||
;; we can add the debug call.
|
||||
(debug-convert-byte-code function)))
|
||||
(unless (consp (symbol-function function))
|
||||
(error "Definition of %s is not a list" function))
|
||||
(fset function (debug-on-entry-1 function t))
|
||||
(unless (memq function debug-function-list)
|
||||
(push function debug-function-list))
|
||||
(advice-add function :before #'debug--implement-debug-on-entry)
|
||||
function)
|
||||
|
||||
(defun debug--function-list ()
|
||||
"List of functions currently set for debug on entry."
|
||||
(let ((funs '()))
|
||||
(mapatoms
|
||||
(lambda (s)
|
||||
(when (advice-member-p #'debug--implement-debug-on-entry s)
|
||||
(push s funs))))
|
||||
funs))
|
||||
|
||||
;;;###autoload
|
||||
(defun cancel-debug-on-entry (&optional function)
|
||||
"Undo effect of \\[debug-on-entry] on FUNCTION.
|
||||
@ -857,80 +837,16 @@ To specify a nil argument interactively, exit with an empty minibuffer."
|
||||
(list (let ((name
|
||||
(completing-read
|
||||
"Cancel debug on entry to function (default all functions): "
|
||||
(mapcar 'symbol-name debug-function-list) nil t)))
|
||||
(mapcar #'symbol-name (debug--function-list)) nil t)))
|
||||
(when name
|
||||
(unless (string= name "")
|
||||
(intern name))))))
|
||||
(if (and function
|
||||
(not (string= function ""))) ; Pre 22.1 compatibility test.
|
||||
(if function
|
||||
(progn
|
||||
(let ((defn (debug-on-entry-1 function nil)))
|
||||
(condition-case nil
|
||||
(when (and (equal (nth 1 defn) '(&rest debug-on-entry-args))
|
||||
(eq (car (nth 3 defn)) 'apply))
|
||||
;; `defn' is a wrapper introduced in debug-on-entry.
|
||||
;; Get rid of it since we don't need it any more.
|
||||
(setq defn (nth 1 (nth 1 (nth 3 defn)))))
|
||||
(error nil))
|
||||
(fset function defn))
|
||||
(setq debug-function-list (delq function debug-function-list))
|
||||
(advice-remove function #'debug--implement-debug-on-entry)
|
||||
function)
|
||||
(message "Cancelling debug-on-entry for all functions")
|
||||
(mapcar 'cancel-debug-on-entry debug-function-list)))
|
||||
|
||||
(defun debug-arglist (definition)
|
||||
;; FIXME: copied from ad-arglist.
|
||||
"Return the argument list of DEFINITION."
|
||||
(require 'help-fns)
|
||||
(help-function-arglist definition 'preserve-names))
|
||||
|
||||
(defun debug-convert-byte-code (function)
|
||||
(let* ((defn (symbol-function function))
|
||||
(macro (eq (car-safe defn) 'macro)))
|
||||
(when macro (setq defn (cdr defn)))
|
||||
(when (byte-code-function-p defn)
|
||||
(let* ((args (debug-arglist defn))
|
||||
(body
|
||||
`((,(if (memq '&rest args) #'apply #'funcall)
|
||||
,defn
|
||||
,@(remq '&rest (remq '&optional args))))))
|
||||
(if (> (length defn) 5)
|
||||
;; The mere presence of field 5 is sufficient to make
|
||||
;; it interactive.
|
||||
(push `(interactive ,(aref defn 5)) body))
|
||||
(if (and (> (length defn) 4) (aref defn 4))
|
||||
;; Use `documentation' here, to get the actual string,
|
||||
;; in case the compiled function has a reference
|
||||
;; to the .elc file.
|
||||
(setq body (cons (documentation function) body)))
|
||||
(setq defn `(closure (t) ,args ,@body)))
|
||||
(when macro (setq defn (cons 'macro defn)))
|
||||
(fset function defn))))
|
||||
|
||||
(defun debug-on-entry-1 (function flag)
|
||||
(let* ((defn (symbol-function function))
|
||||
(tail defn))
|
||||
(when (eq (car-safe tail) 'macro)
|
||||
(setq tail (cdr tail)))
|
||||
(if (not (memq (car-safe tail) '(closure lambda)))
|
||||
;; Only signal an error when we try to set debug-on-entry.
|
||||
;; When we try to clear debug-on-entry, we are now done.
|
||||
(when flag
|
||||
(error "%s is not a user-defined Lisp function" function))
|
||||
(if (eq (car tail) 'closure) (setq tail (cdr tail)))
|
||||
(setq tail (cdr tail))
|
||||
;; Skip the docstring.
|
||||
(when (and (stringp (cadr tail)) (cddr tail))
|
||||
(setq tail (cdr tail)))
|
||||
;; Skip the interactive form.
|
||||
(when (eq 'interactive (car-safe (cadr tail)))
|
||||
(setq tail (cdr tail)))
|
||||
(unless (eq flag (equal (cadr tail) '(implement-debug-on-entry)))
|
||||
;; Add/remove debug statement as needed.
|
||||
(setcdr tail (if flag
|
||||
(cons '(implement-debug-on-entry) (cdr tail))
|
||||
(cddr tail)))))
|
||||
defn))
|
||||
(mapcar #'cancel-debug-on-entry (debug--function-list))))
|
||||
|
||||
(defun debugger-list-functions ()
|
||||
"Display a list of all the functions now set to debug on entry."
|
||||
@ -940,17 +856,18 @@ To specify a nil argument interactively, exit with an empty minibuffer."
|
||||
(called-interactively-p 'interactive))
|
||||
(with-output-to-temp-buffer (help-buffer)
|
||||
(with-current-buffer standard-output
|
||||
(if (null debug-function-list)
|
||||
(princ "No debug-on-entry functions now\n")
|
||||
(princ "Functions set to debug on entry:\n\n")
|
||||
(dolist (fun debug-function-list)
|
||||
(make-text-button (point) (progn (prin1 fun) (point))
|
||||
'type 'help-function
|
||||
'help-args (list fun))
|
||||
(terpri))
|
||||
(terpri)
|
||||
(princ "Note: if you have redefined a function, then it may no longer\n")
|
||||
(princ "be set to debug on entry, even if it is in the list.")))))
|
||||
(let ((funs (debug--function-list)))
|
||||
(if (null funs)
|
||||
(princ "No debug-on-entry functions now\n")
|
||||
(princ "Functions set to debug on entry:\n\n")
|
||||
(dolist (fun funs)
|
||||
(make-text-button (point) (progn (prin1 fun) (point))
|
||||
'type 'help-function
|
||||
'help-args (list fun))
|
||||
(terpri))
|
||||
(terpri)
|
||||
(princ "Note: if you have redefined a function, then it may no longer\n")
|
||||
(princ "be set to debug on entry, even if it is in the list."))))))
|
||||
|
||||
(provide 'debug)
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
;;; elp.el --- Emacs Lisp Profiler
|
||||
;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 1994-1995, 1997-1998, 2001-2012
|
||||
;; Free Software Foundation, Inc.
|
||||
@ -124,6 +124,7 @@
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
;; start of user configuration variables
|
||||
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
|
||||
@ -148,9 +149,9 @@ Results are displayed with the `elp-results' command."
|
||||
"Non-nil specifies ELP results sorting function.
|
||||
These functions are currently available:
|
||||
|
||||
elp-sort-by-call-count -- sort by the highest call count
|
||||
elp-sort-by-total-time -- sort by the highest total time
|
||||
elp-sort-by-average-time -- sort by the highest average times
|
||||
`elp-sort-by-call-count' -- sort by the highest call count
|
||||
`elp-sort-by-total-time' -- sort by the highest total time
|
||||
`elp-sort-by-average-time' -- sort by the highest average times
|
||||
|
||||
You can write your own sort function. It should adhere to the
|
||||
interface specified by the PREDICATE argument for `sort'.
|
||||
@ -167,7 +168,7 @@ If a number, no function that has been called fewer than that number
|
||||
of times will be displayed in the output buffer. If nil, all
|
||||
functions will be displayed."
|
||||
:type '(choice integer
|
||||
(const :tag "Show All" nil))
|
||||
(const :tag "Show All" nil))
|
||||
:group 'elp)
|
||||
|
||||
(defcustom elp-use-standard-output nil
|
||||
@ -193,9 +194,6 @@ In other words, a new unique buffer is create every time you run
|
||||
(defconst elp-timer-info-property 'elp-info
|
||||
"ELP information property name.")
|
||||
|
||||
(defvar elp-all-instrumented-list nil
|
||||
"List of all functions currently being instrumented.")
|
||||
|
||||
(defvar elp-record-p t
|
||||
"Controls whether functions should record times or not.
|
||||
This variable is set by the master function.")
|
||||
@ -205,7 +203,7 @@ This variable is set by the master function.")
|
||||
|
||||
(defvar elp-not-profilable
|
||||
;; First, the functions used inside each instrumented function:
|
||||
'(elp-wrapper called-interactively-p
|
||||
'(called-interactively-p
|
||||
;; Then the functions used by the above functions. I used
|
||||
;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x))
|
||||
;; (aref (symbol-function 'elp-wrapper) 2)))
|
||||
@ -223,60 +221,21 @@ them would thus lead to infinite recursion.")
|
||||
(fboundp fun)
|
||||
(not (or (memq fun elp-not-profilable)
|
||||
(keymapp fun)
|
||||
(memq (car-safe (symbol-function fun)) '(autoload macro))
|
||||
(condition-case nil
|
||||
(when (subrp (indirect-function fun))
|
||||
(eq 'unevalled
|
||||
(cdr (subr-arity (indirect-function fun)))))
|
||||
(error nil))))))
|
||||
(autoloadp (symbol-function fun)) ;FIXME: Why not just load it?
|
||||
(special-form-p fun)))))
|
||||
|
||||
(defconst elp--advice-name 'ELP-instrumentation\ )
|
||||
|
||||
;;;###autoload
|
||||
(defun elp-instrument-function (funsym)
|
||||
"Instrument FUNSYM for profiling.
|
||||
FUNSYM must be a symbol of a defined function."
|
||||
(interactive "aFunction to instrument: ")
|
||||
;; restore the function. this is necessary to avoid infinite
|
||||
;; recursion of already instrumented functions (i.e. elp-wrapper
|
||||
;; calling elp-wrapper ad infinitum). it is better to simply
|
||||
;; restore the function than to throw an error. this will work
|
||||
;; properly in the face of eval-defun because if the function was
|
||||
;; redefined, only the timer info will be nil'd out since
|
||||
;; elp-restore-function is smart enough not to trash the new
|
||||
;; definition.
|
||||
(elp-restore-function funsym)
|
||||
(let* ((funguts (symbol-function funsym))
|
||||
(infovec (vector 0 0 funguts))
|
||||
(newguts '(lambda (&rest args))))
|
||||
;; we cannot profile macros
|
||||
(and (eq (car-safe funguts) 'macro)
|
||||
(error "ELP cannot profile macro: %s" funsym))
|
||||
;; TBD: at some point it might be better to load the autoloaded
|
||||
;; function instead of throwing an error. if we do this, then we
|
||||
;; probably want elp-instrument-package to be updated with the
|
||||
;; newly loaded list of functions. i'm not sure it's smart to do
|
||||
;; the autoload here, since that could have side effects, and
|
||||
;; elp-instrument-function is similar (in my mind) to defun-ish
|
||||
;; type functionality (i.e. it shouldn't execute the function).
|
||||
(and (autoloadp funguts)
|
||||
(error "ELP cannot profile autoloaded function: %s" funsym))
|
||||
(let* ((infovec (vector 0 0)))
|
||||
;; We cannot profile functions used internally during profiling.
|
||||
(unless (elp-profilable-p funsym)
|
||||
(error "ELP cannot profile the function: %s" funsym))
|
||||
;; put rest of newguts together
|
||||
(if (commandp funsym)
|
||||
(setq newguts (append newguts '((interactive)))))
|
||||
(setq newguts (append newguts `((elp-wrapper
|
||||
(quote ,funsym)
|
||||
,(when (commandp funsym)
|
||||
'(called-interactively-p 'any))
|
||||
args))))
|
||||
;; to record profiling times, we set the symbol's function
|
||||
;; definition so that it runs the elp-wrapper function with the
|
||||
;; function symbol as an argument. We place the old function
|
||||
;; definition on the info vector.
|
||||
;;
|
||||
;; The info vector data structure is a 3 element vector. The 0th
|
||||
;; The info vector data structure is a 2 element vector. The 0th
|
||||
;; element is the call-count, i.e. the total number of times this
|
||||
;; function has been entered. This value is bumped up on entry to
|
||||
;; the function so that non-local exists are still recorded. TBD:
|
||||
@ -285,72 +244,45 @@ FUNSYM must be a symbol of a defined function."
|
||||
;; The 1st element is the total amount of time in seconds that has
|
||||
;; been spent inside this function. This number is added to on
|
||||
;; function exit.
|
||||
;;
|
||||
;; The 2nd element is the old function definition list. This gets
|
||||
;; funcall'd in between start/end time retrievals. I believe that
|
||||
;; this lets us profile even byte-compiled functions.
|
||||
|
||||
;; put the info vector on the property list
|
||||
;; Put the info vector on the property list.
|
||||
(put funsym elp-timer-info-property infovec)
|
||||
|
||||
;; Set the symbol's new profiling function definition to run
|
||||
;; elp-wrapper.
|
||||
(let ((advice-info (get funsym 'ad-advice-info)))
|
||||
(if advice-info
|
||||
(progn
|
||||
;; If function is advised, don't let Advice change
|
||||
;; its definition from under us during the `fset'.
|
||||
(put funsym 'ad-advice-info nil)
|
||||
(fset funsym newguts)
|
||||
(put funsym 'ad-advice-info advice-info))
|
||||
(fset funsym newguts)))
|
||||
;; ELP wrapper.
|
||||
(advice-add funsym :around (elp--make-wrapper funsym)
|
||||
`((name . ,elp--advice-name)))))
|
||||
|
||||
;; add this function to the instrumentation list
|
||||
(unless (memq funsym elp-all-instrumented-list)
|
||||
(push funsym elp-all-instrumented-list))))
|
||||
(defun elp--instrumented-p (sym)
|
||||
(advice-member-p elp--advice-name sym))
|
||||
|
||||
(defun elp-restore-function (funsym)
|
||||
"Restore an instrumented function to its original definition.
|
||||
Argument FUNSYM is the symbol of a defined function."
|
||||
(interactive "aFunction to restore: ")
|
||||
(let ((info (get funsym elp-timer-info-property)))
|
||||
;; delete the function from the all instrumented list
|
||||
(setq elp-all-instrumented-list
|
||||
(delq funsym elp-all-instrumented-list))
|
||||
(interactive
|
||||
(list
|
||||
(intern
|
||||
(completing-read "Function to restore: " obarray
|
||||
#'elp--instrumented-p t))))
|
||||
;; If the function was the master, reset the master.
|
||||
(if (eq funsym elp-master)
|
||||
(setq elp-master nil
|
||||
elp-record-p t))
|
||||
|
||||
;; if the function was the master, reset the master
|
||||
(if (eq funsym elp-master)
|
||||
(setq elp-master nil
|
||||
elp-record-p t))
|
||||
;; Zap the properties.
|
||||
(put funsym elp-timer-info-property nil)
|
||||
|
||||
;; zap the properties
|
||||
(put funsym elp-timer-info-property nil)
|
||||
|
||||
;; restore the original function definition, but if the function
|
||||
;; wasn't instrumented do nothing. we do this after the above
|
||||
;; because its possible the function got un-instrumented due to
|
||||
;; circumstances beyond our control. Also, check to make sure
|
||||
;; that the current function symbol points to elp-wrapper. If
|
||||
;; not, then the user probably did an eval-defun, or loaded a
|
||||
;; byte-compiled version, while the function was instrumented and
|
||||
;; we don't want to destroy the new definition. can it ever be
|
||||
;; the case that a lisp function can be compiled instrumented?
|
||||
(and info
|
||||
(functionp funsym)
|
||||
(not (byte-code-function-p (symbol-function funsym)))
|
||||
(assq 'elp-wrapper (symbol-function funsym))
|
||||
(fset funsym (aref info 2)))))
|
||||
(advice-remove funsym elp--advice-name))
|
||||
|
||||
;;;###autoload
|
||||
(defun elp-instrument-list (&optional list)
|
||||
"Instrument, for profiling, all functions in `elp-function-list'.
|
||||
Use optional LIST if provided instead.
|
||||
If called interactively, read LIST using the minibuffer."
|
||||
(interactive "PList of functions to instrument: ")
|
||||
(interactive "PList of functions to instrument: ") ;FIXME: Doesn't work?!
|
||||
(unless (listp list)
|
||||
(signal 'wrong-type-argument (list 'listp list)))
|
||||
(let ((list (or list elp-function-list)))
|
||||
(mapcar 'elp-instrument-function list)))
|
||||
(mapcar #'elp-instrument-function (or list elp-function-list)))
|
||||
|
||||
;;;###autoload
|
||||
(defun elp-instrument-package (prefix)
|
||||
@ -371,15 +303,13 @@ For example, to instrument all ELP functions, do the following:
|
||||
(defun elp-restore-list (&optional list)
|
||||
"Restore the original definitions for all functions in `elp-function-list'.
|
||||
Use optional LIST if provided instead."
|
||||
(interactive "PList of functions to restore: ")
|
||||
(let ((list (or list elp-function-list)))
|
||||
(mapcar 'elp-restore-function list)))
|
||||
(interactive "PList of functions to restore: ") ;FIXME: Doesn't work!?
|
||||
(mapcar #'elp-restore-function (or list elp-function-list)))
|
||||
|
||||
(defun elp-restore-all ()
|
||||
"Restore the original definitions of all functions being profiled."
|
||||
(interactive)
|
||||
(elp-restore-list elp-all-instrumented-list))
|
||||
|
||||
(mapatoms #'elp-restore-function))
|
||||
|
||||
(defun elp-reset-function (funsym)
|
||||
"Reset the profiling information for FUNSYM."
|
||||
@ -395,30 +325,36 @@ Use optional LIST if provided instead."
|
||||
(defun elp-reset-list (&optional list)
|
||||
"Reset the profiling information for all functions in `elp-function-list'.
|
||||
Use optional LIST if provided instead."
|
||||
(interactive "PList of functions to reset: ")
|
||||
(interactive "PList of functions to reset: ") ;FIXME: Doesn't work!?
|
||||
(let ((list (or list elp-function-list)))
|
||||
(mapcar 'elp-reset-function list)))
|
||||
|
||||
(defun elp-reset-all ()
|
||||
"Reset the profiling information for all functions being profiled."
|
||||
(interactive)
|
||||
(elp-reset-list elp-all-instrumented-list))
|
||||
(mapatoms (lambda (sym)
|
||||
(if (get sym elp-timer-info-property)
|
||||
(elp-reset-function sym)))))
|
||||
|
||||
(defun elp-set-master (funsym)
|
||||
"Set the master function for profiling."
|
||||
(interactive "aMaster function: ")
|
||||
;; when there's a master function, recording is turned off by
|
||||
;; default
|
||||
(interactive
|
||||
(list
|
||||
(intern
|
||||
(completing-read "Master function: " obarray
|
||||
#'elp--instrumented-p
|
||||
t nil nil (if elp-master (symbol-name elp-master))))))
|
||||
;; When there's a master function, recording is turned off by default.
|
||||
(setq elp-master funsym
|
||||
elp-record-p nil)
|
||||
;; make sure master function is instrumented
|
||||
(or (memq funsym elp-all-instrumented-list)
|
||||
;; Make sure master function is instrumented.
|
||||
(or (elp--instrumented-p funsym)
|
||||
(elp-instrument-function funsym)))
|
||||
|
||||
(defun elp-unset-master ()
|
||||
"Unset the master function."
|
||||
(interactive)
|
||||
;; when there's no master function, recording is turned on by default.
|
||||
;; When there's no master function, recording is turned on by default.
|
||||
(setq elp-master nil
|
||||
elp-record-p t))
|
||||
|
||||
@ -426,49 +362,40 @@ Use optional LIST if provided instead."
|
||||
(defsubst elp-elapsed-time (start end)
|
||||
(float-time (time-subtract end start)))
|
||||
|
||||
(defun elp-wrapper (funsym interactive-p args)
|
||||
"This function has been instrumented for profiling by the ELP.
|
||||
(defun elp--make-wrapper (funsym)
|
||||
"Make the piece of advice that instruments FUNSYM."
|
||||
(lambda (func &rest args)
|
||||
"This function has been instrumented for profiling by the ELP.
|
||||
ELP is the Emacs Lisp Profiler. To restore the function to its
|
||||
original definition, use \\[elp-restore-function] or \\[elp-restore-all]."
|
||||
;; turn on recording if this is the master function
|
||||
(if (and elp-master
|
||||
(eq funsym elp-master))
|
||||
(setq elp-record-p t))
|
||||
;; get info vector and original function symbol
|
||||
(let* ((info (get funsym elp-timer-info-property))
|
||||
(func (aref info 2))
|
||||
result)
|
||||
(or func
|
||||
(error "%s is not instrumented for profiling" funsym))
|
||||
(if (not elp-record-p)
|
||||
;; when not recording, just call the original function symbol
|
||||
;; and return the results.
|
||||
(setq result
|
||||
(if interactive-p
|
||||
(call-interactively func)
|
||||
(apply func args)))
|
||||
;; we are recording times
|
||||
(let (enter-time exit-time)
|
||||
;; increment the call-counter
|
||||
(aset info 0 (1+ (aref info 0)))
|
||||
;; now call the old symbol function, checking to see if it
|
||||
;; should be called interactively. make sure we return the
|
||||
;; correct value
|
||||
(if interactive-p
|
||||
(setq enter-time (current-time)
|
||||
result (call-interactively func)
|
||||
exit-time (current-time))
|
||||
;; turn on recording if this is the master function
|
||||
(if (and elp-master
|
||||
(eq funsym elp-master))
|
||||
(setq elp-record-p t))
|
||||
;; get info vector and original function symbol
|
||||
(let* ((info (get funsym elp-timer-info-property))
|
||||
result)
|
||||
(or func
|
||||
(error "%s is not instrumented for profiling" funsym))
|
||||
(if (not elp-record-p)
|
||||
;; when not recording, just call the original function symbol
|
||||
;; and return the results.
|
||||
(setq result (apply func args))
|
||||
;; we are recording times
|
||||
(let (enter-time exit-time)
|
||||
;; increment the call-counter
|
||||
(cl-incf (aref info 0))
|
||||
(setq enter-time (current-time)
|
||||
result (apply func args)
|
||||
exit-time (current-time)))
|
||||
;; calculate total time in function
|
||||
(aset info 1 (+ (aref info 1) (elp-elapsed-time enter-time exit-time)))
|
||||
))
|
||||
;; turn off recording if this is the master function
|
||||
(if (and elp-master
|
||||
(eq funsym elp-master))
|
||||
(setq elp-record-p nil))
|
||||
result))
|
||||
exit-time (current-time))
|
||||
;; calculate total time in function
|
||||
(cl-incf (aref info 1) (elp-elapsed-time enter-time exit-time))
|
||||
))
|
||||
;; turn off recording if this is the master function
|
||||
(if (and elp-master
|
||||
(eq funsym elp-master))
|
||||
(setq elp-record-p nil))
|
||||
result)))
|
||||
|
||||
|
||||
;; shut the byte-compiler up
|
||||
@ -582,57 +509,58 @@ displayed."
|
||||
(elp-et-len (length et-header))
|
||||
(at-header "Average Time")
|
||||
(elp-at-len (length at-header))
|
||||
(resvec
|
||||
(mapcar
|
||||
(function
|
||||
(lambda (funsym)
|
||||
(let* ((info (get funsym elp-timer-info-property))
|
||||
(symname (format "%s" funsym))
|
||||
(cc (aref info 0))
|
||||
(tt (aref info 1)))
|
||||
(if (not info)
|
||||
(insert "No profiling information found for: "
|
||||
symname)
|
||||
(setq longest (max longest (length symname)))
|
||||
(vector cc tt (if (zerop cc)
|
||||
0.0 ;avoid arithmetic div-by-zero errors
|
||||
(/ (float tt) (float cc)))
|
||||
symname)))))
|
||||
elp-all-instrumented-list))
|
||||
(resvec '())
|
||||
) ; end let*
|
||||
(mapatoms
|
||||
(lambda (funsym)
|
||||
(when (elp--instrumented-p funsym)
|
||||
(let* ((info (get funsym elp-timer-info-property))
|
||||
(symname (format "%s" funsym))
|
||||
(cc (aref info 0))
|
||||
(tt (aref info 1)))
|
||||
(if (not info)
|
||||
(insert "No profiling information found for: "
|
||||
symname)
|
||||
(setq longest (max longest (length symname)))
|
||||
(push
|
||||
(vector cc tt (if (zerop cc)
|
||||
0.0 ;avoid arithmetic div-by-zero errors
|
||||
(/ (float tt) (float cc)))
|
||||
symname)
|
||||
resvec))))))
|
||||
;; If printing to stdout, insert the header so it will print.
|
||||
;; Otherwise use header-line-format.
|
||||
(setq elp-field-len (max titlelen longest))
|
||||
(if (or elp-use-standard-output noninteractive)
|
||||
(progn
|
||||
(insert title)
|
||||
(if (> longest titlelen)
|
||||
(progn
|
||||
(insert-char 32 (- longest titlelen))))
|
||||
(insert " " cc-header " " et-header " " at-header "\n")
|
||||
(insert-char ?= elp-field-len)
|
||||
(insert " ")
|
||||
(insert-char ?= elp-cc-len)
|
||||
(insert " ")
|
||||
(insert-char ?= elp-et-len)
|
||||
(insert " ")
|
||||
(insert-char ?= elp-at-len)
|
||||
(insert "\n"))
|
||||
(let ((column 0))
|
||||
(setq header-line-format
|
||||
(mapconcat
|
||||
(lambda (title)
|
||||
(prog1
|
||||
(concat
|
||||
(propertize " "
|
||||
'display (list 'space :align-to column)
|
||||
'face 'fixed-pitch)
|
||||
title)
|
||||
(setq column (+ column 2
|
||||
(if (= column 0)
|
||||
elp-field-len
|
||||
(length title))))))
|
||||
(list title cc-header et-header at-header) ""))))
|
||||
(progn
|
||||
(insert title)
|
||||
(if (> longest titlelen)
|
||||
(progn
|
||||
(insert-char 32 (- longest titlelen))))
|
||||
(insert " " cc-header " " et-header " " at-header "\n")
|
||||
(insert-char ?= elp-field-len)
|
||||
(insert " ")
|
||||
(insert-char ?= elp-cc-len)
|
||||
(insert " ")
|
||||
(insert-char ?= elp-et-len)
|
||||
(insert " ")
|
||||
(insert-char ?= elp-at-len)
|
||||
(insert "\n"))
|
||||
(let ((column 0))
|
||||
(setq header-line-format
|
||||
(mapconcat
|
||||
(lambda (title)
|
||||
(prog1
|
||||
(concat
|
||||
(propertize " "
|
||||
'display (list 'space :align-to column)
|
||||
'face 'fixed-pitch)
|
||||
title)
|
||||
(setq column (+ column 2
|
||||
(if (= column 0)
|
||||
elp-field-len
|
||||
(length title))))))
|
||||
(list title cc-header et-header at-header) ""))))
|
||||
;; if sorting is enabled, then sort the results list. in either
|
||||
;; case, call elp-output-result to output the result in the
|
||||
;; buffer
|
||||
@ -644,7 +572,7 @@ displayed."
|
||||
(pop-to-buffer resultsbuf)
|
||||
;; copy results to standard-output?
|
||||
(if (or elp-use-standard-output noninteractive)
|
||||
(princ (buffer-substring (point-min) (point-max)))
|
||||
(princ (buffer-substring (point-min) (point-max)))
|
||||
(goto-char (point-min)))
|
||||
;; reset profiling info if desired
|
||||
(and elp-reset-after-results
|
||||
|
||||
348
lisp/emacs-lisp/nadvice.el
Normal file
348
lisp/emacs-lisp/nadvice.el
Normal file
@ -0,0 +1,348 @@
|
||||
;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
;; Keywords: extensions, lisp, tools
|
||||
;; Package: emacs
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This package lets you add behavior (which we call "piece of advice") to
|
||||
;; existing functions, like the old `advice.el' package, but with much fewer
|
||||
;; bells ans whistles. It comes in 2 parts:
|
||||
;;
|
||||
;; - The first part lets you add/remove functions, similarly to
|
||||
;; add/remove-hook, from any "place" (i.e. as accepted by `setf') that
|
||||
;; holds a function.
|
||||
;; This part provides mainly 2 macros: `add-function' and `remove-function'.
|
||||
;;
|
||||
;; - The second part provides `add-advice' and `remove-advice' which are
|
||||
;; refined version of the previous macros specially tailored for the case
|
||||
;; where the place that we want to modify is a `symbol-function'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;;; Lightweight advice/hook
|
||||
(defvar advice--where-alist
|
||||
'((:around "\300\301\302\003#\207" 5)
|
||||
(:before "\300\301\002\"\210\300\302\002\"\207" 4)
|
||||
(:after "\300\302\002\"\300\301\003\"\210\207" 5)
|
||||
(:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4)
|
||||
(:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4)
|
||||
(:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4)
|
||||
(:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4))
|
||||
"List of descriptions of how to add a function.
|
||||
Each element has the form (WHERE BYTECODE STACK) where:
|
||||
WHERE is a keyword indicating where the function is added.
|
||||
BYTECODE is the corresponding byte-code that will be used.
|
||||
STACK is the amount of stack space needed by the byte-code.")
|
||||
|
||||
(defvar advice--bytecodes (mapcar #'cadr advice--where-alist))
|
||||
|
||||
(defun advice--p (object)
|
||||
(and (byte-code-function-p object)
|
||||
(eq 128 (aref object 0))
|
||||
(memq (length object) '(5 6))
|
||||
(memq (aref object 1) advice--bytecodes)
|
||||
(eq #'apply (aref (aref object 2) 0))))
|
||||
|
||||
(defsubst advice--car (f) (aref (aref f 2) 1))
|
||||
(defsubst advice--cdr (f) (aref (aref f 2) 2))
|
||||
(defsubst advice--props (f) (aref (aref f 2) 3))
|
||||
|
||||
(defun advice--make-docstring (_string function)
|
||||
"Build the raw doc-string of SYMBOL, presumably advised."
|
||||
(let ((flist (indirect-function function))
|
||||
(docstring nil))
|
||||
(if (eq 'macro (car-safe flist)) (setq flist (cdr flist)))
|
||||
(while (advice--p flist)
|
||||
(let ((bytecode (aref flist 1))
|
||||
(where nil))
|
||||
(dolist (elem advice--where-alist)
|
||||
(if (eq bytecode (cadr elem)) (setq where (car elem))))
|
||||
(setq docstring
|
||||
(concat
|
||||
docstring
|
||||
(propertize (format "%s advice: " where)
|
||||
'face 'warning)
|
||||
(let ((fun (advice--car flist)))
|
||||
(if (symbolp fun) (format "`%S'" fun)
|
||||
(let* ((name (cdr (assq 'name (advice--props flist))))
|
||||
(doc (documentation fun t))
|
||||
(usage (help-split-fundoc doc function)))
|
||||
(if usage (setq doc (cdr usage)))
|
||||
(if name
|
||||
(if doc
|
||||
(format "%s\n%s" name doc)
|
||||
(format "%s" name))
|
||||
(or doc "No documentation")))))
|
||||
"\n")))
|
||||
(setq flist (advice--cdr flist)))
|
||||
(if docstring (setq docstring (concat docstring "\n")))
|
||||
(let* ((origdoc (unless (eq function flist) ;Avoid inf-loops.
|
||||
(documentation flist t)))
|
||||
(usage (help-split-fundoc origdoc function)))
|
||||
(setq usage (if (null usage)
|
||||
(let ((arglist (help-function-arglist flist)))
|
||||
(format "%S" (help-make-usage function arglist)))
|
||||
(setq origdoc (cdr usage)) (car usage)))
|
||||
(help-add-fundoc-usage (concat docstring origdoc) usage))))
|
||||
|
||||
(defvar advice--docstring
|
||||
;; Can't eval-when-compile nor use defconst because it then gets pure-copied,
|
||||
;; which drops the text-properties.
|
||||
;;(eval-when-compile
|
||||
(propertize "Advised function"
|
||||
'dynamic-docstring-function #'advice--make-docstring)) ;; )
|
||||
|
||||
(defun advice--make-interactive-form (function main)
|
||||
;; TODO: Make it possible to do around-like advising on the
|
||||
;; interactive forms (bug#12844).
|
||||
;; TODO: make it so that interactive spec can be a constant which
|
||||
;; dynamically checks the advice--car/cdr to do its job.
|
||||
;; TODO: Implement interactive-read-args:
|
||||
;;(when (or (commandp function) (commandp main))
|
||||
;; `(interactive-read-args
|
||||
;; (cadr (or (interactive-form function) (interactive-form main)))))
|
||||
;; FIXME: This loads autoloaded functions too eagerly.
|
||||
(cadr (or (interactive-form function)
|
||||
(interactive-form main))))
|
||||
|
||||
(defsubst advice--make-1 (byte-code stack-depth function main props)
|
||||
"Build a function value that adds FUNCTION to MAIN."
|
||||
(let ((adv-sig (gethash main advertised-signature-table))
|
||||
(advice
|
||||
(apply #'make-byte-code 128 byte-code
|
||||
(vector #'apply function main props) stack-depth
|
||||
advice--docstring
|
||||
(when (or (commandp function) (commandp main))
|
||||
(list (advice--make-interactive-form
|
||||
function main))))))
|
||||
(when adv-sig (puthash advice adv-sig advertised-signature-table))
|
||||
advice))
|
||||
|
||||
(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'."
|
||||
(let ((desc (assq where advice--where-alist)))
|
||||
(unless desc (error "Unknown add-function location `%S'" where))
|
||||
(advice--make-1 (nth 1 desc) (nth 2 desc)
|
||||
function main props)))
|
||||
|
||||
(defun advice--member-p (function definition)
|
||||
(let ((found nil))
|
||||
(while (and (not found) (advice--p definition))
|
||||
(if (or (equal function (advice--car definition))
|
||||
(equal function (cdr (assq 'name (advice--props definition)))))
|
||||
(setq found t)
|
||||
(setq definition (advice--cdr definition))))
|
||||
found))
|
||||
|
||||
;;;###autoload
|
||||
(defun advice--remove-function (flist function)
|
||||
(if (not (advice--p flist))
|
||||
flist
|
||||
(let ((first (advice--car flist))
|
||||
(props (advice--props flist)))
|
||||
(if (or (equal function first)
|
||||
(equal function (cdr (assq 'name props))))
|
||||
(advice--cdr flist)
|
||||
(let* ((rest (advice--cdr flist))
|
||||
(nrest (advice--remove-function rest function)))
|
||||
(if (eq rest nrest) flist
|
||||
(advice--make-1 (aref flist 1) (aref flist 3)
|
||||
first nrest props)))))))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro add-function (where place function &optional props)
|
||||
;; TODO:
|
||||
;; - provide something like `around' for interactive forms.
|
||||
;; - provide some kind of buffer-local functionality at least when `place'
|
||||
;; is a variable.
|
||||
;; - obsolete with-wrapper-hook (mostly requires buffer-local support).
|
||||
;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP
|
||||
;; and tracing want to stay first.
|
||||
;; - maybe also let `where' specify some kind of predicate and use it
|
||||
;; to implement things like mode-local or eieio-defmethod.
|
||||
;; :before is like a normal add-hook on a normal hook.
|
||||
;; :before-while is like add-hook on run-hook-with-args-until-failure.
|
||||
;; :before-until is like add-hook on run-hook-with-args-until-success.
|
||||
;; Same with :after-* but for (add-hook ... 'append).
|
||||
"Add a piece of advice on the function stored at PLACE.
|
||||
FUNCTION describes the code to add. WHERE describes where to add it.
|
||||
WHERE can be explained by showing the resulting new function, as the
|
||||
result of combining FUNCTION and the previous value of PLACE, which we
|
||||
call OLDFUN here:
|
||||
`:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r))
|
||||
`:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r)))
|
||||
`:around' (lambda (&rest r) (apply FUNCTION OLDFUN r))
|
||||
`:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r)))
|
||||
`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r)))
|
||||
`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r)))
|
||||
`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r)))
|
||||
If FUNCTION was already added, do nothing.
|
||||
PROPS is an alist of additional properties, among which the following have
|
||||
a special meaning:
|
||||
- `name': a string or symbol. It can be used to refer to this piece of advice."
|
||||
(declare (debug t)) ;;(indent 2)
|
||||
`(advice--add-function ,where (gv-ref ,place) ,function ,props))
|
||||
|
||||
;;;###autoload
|
||||
(defun advice--add-function (where ref function props)
|
||||
(unless (advice--member-p function (gv-deref ref))
|
||||
(setf (gv-deref ref)
|
||||
(advice--make where function (gv-deref ref) props))))
|
||||
|
||||
(defmacro remove-function (place function)
|
||||
"Remove the FUNCTION piece of advice from PLACE.
|
||||
If FUNCTION was not added to PLACE, do nothing.
|
||||
Instead of FUNCTION being the actual function, it can also be the `name'
|
||||
of the piece of advice."
|
||||
(declare (debug t))
|
||||
(gv-letplace (getter setter) place
|
||||
(macroexp-let2 nil new `(advice--remove-function ,getter ,function)
|
||||
`(unless (eq ,new ,getter) ,(funcall setter new)))))
|
||||
|
||||
;;;; Specific application of add-function to `symbol-function' for advice.
|
||||
|
||||
(defun advice--subst-main (old new)
|
||||
(if (not (advice--p old))
|
||||
new
|
||||
(let* ((first (advice--car old))
|
||||
(rest (advice--cdr old))
|
||||
(props (advice--props old))
|
||||
(nrest (advice--subst-main rest new)))
|
||||
(if (equal rest nrest) old
|
||||
(advice--make-1 (aref old 1) (aref old 3)
|
||||
first nrest props)))))
|
||||
|
||||
(defun advice--defalias-fset (fsetfun symbol newdef)
|
||||
(let* ((olddef (if (fboundp symbol) (symbol-function symbol)))
|
||||
(oldadv
|
||||
(cond
|
||||
((null (get symbol 'advice--pending))
|
||||
(or olddef
|
||||
(progn
|
||||
(message "Delayed advice activation failed for %s: no data"
|
||||
symbol)
|
||||
nil)))
|
||||
((or (not olddef) (autoloadp olddef))
|
||||
(prog1 (get symbol 'advice--pending)
|
||||
(put symbol 'advice--pending nil)))
|
||||
(t (message "Dropping left-over advice--pending for %s" symbol)
|
||||
(put symbol 'advice--pending nil)
|
||||
olddef))))
|
||||
(funcall (or fsetfun #'fset) symbol (advice--subst-main oldadv newdef))))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defun advice-add (symbol where function &optional props)
|
||||
"Like `add-function' but for the function named SYMBOL.
|
||||
Contrary to `add-function', this will properly handle the cases where SYMBOL
|
||||
is defined as a macro, alias, command, ..."
|
||||
;; TODO:
|
||||
;; - record the advice location, to display in describe-function.
|
||||
;; - change all defadvice in lisp/**/*.el.
|
||||
;; - rewrite advice.el on top of this.
|
||||
;; - obsolete advice.el.
|
||||
;; To make advice.el and nadvice.el interoperate properly I see 2 different
|
||||
;; ways:
|
||||
;; - keep them separate: complete the defalias-fset-function setter with
|
||||
;; a matching accessor which both nadvice.el and advice.el will have to use
|
||||
;; in place of symbol-function. This can probably be made to work, but
|
||||
;; they have to agree on a "protocol".
|
||||
;; - layer advice.el on top of nadvice.el. I prefer this approach. the
|
||||
;; simplest way is to make advice.el build one ad-Advice-foo function for
|
||||
;; each advised function which is advice-added/removed whenever ad-activate
|
||||
;; ad-deactivate is called.
|
||||
(let ((f (and (fboundp symbol) (symbol-function symbol))))
|
||||
(cond
|
||||
((special-form-p f)
|
||||
;; Not worth the trouble trying to handle this, I think.
|
||||
(error "add-advice failure: %S is a special form" symbol))
|
||||
((and (symbolp f)
|
||||
(eq 'macro (car-safe (ignore-errors (indirect-function f)))))
|
||||
(let ((newval (cons 'macro (cdr (indirect-function f)))))
|
||||
(put symbol 'advice--saved-rewrite (cons f newval))
|
||||
(fset symbol newval)))
|
||||
;; `f' might be a pure (hence read-only) cons!
|
||||
((and (eq 'macro (car-safe f)) (not (ignore-errors (setcdr f (cdr f)) t)))
|
||||
(fset symbol (cons 'macro (cdr f))))
|
||||
))
|
||||
(let ((f (and (fboundp symbol) (symbol-function symbol))))
|
||||
(add-function where (cond
|
||||
((eq (car-safe f) 'macro) (cdr f))
|
||||
;; If the function is not yet defined, we can't yet
|
||||
;; install the advice.
|
||||
;; FIXME: If it's an autoloaded command, we also
|
||||
;; have a problem because we need to load the
|
||||
;; command to build the interactive-form.
|
||||
((or (not f) (and (autoloadp f))) ;; (commandp f)
|
||||
(get symbol 'advice--pending))
|
||||
(t (symbol-function symbol)))
|
||||
function props)
|
||||
(add-function :around (get symbol 'defalias-fset-function)
|
||||
#'advice--defalias-fset))
|
||||
nil)
|
||||
|
||||
;;;###autoload
|
||||
(defun advice-remove (symbol function)
|
||||
"Like `remove-function' but for the function named SYMBOL.
|
||||
Contrary to `remove-function', this will work also when SYMBOL is a macro
|
||||
and it will not signal an error if SYMBOL is not `fboundp'.
|
||||
Instead of the actual function to remove, FUNCTION can also be the `name'
|
||||
of the piece of advice."
|
||||
(when (fboundp symbol)
|
||||
(let ((f (symbol-function symbol)))
|
||||
;; Can't use the `if' place here, because the body is too large,
|
||||
;; resulting in use of code that only works with lexical-scoping.
|
||||
(remove-function (if (eq (car-safe f) 'macro)
|
||||
(cdr f)
|
||||
(symbol-function symbol))
|
||||
function)
|
||||
(unless (advice--p
|
||||
(if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol)))
|
||||
;; Not adviced any more.
|
||||
(remove-function (get symbol 'defalias-fset-function)
|
||||
#'advice--defalias-fset)
|
||||
(if (eq (symbol-function symbol)
|
||||
(cdr (get symbol 'advice--saved-rewrite)))
|
||||
(fset symbol (car (get symbol 'advice--saved-rewrite))))))
|
||||
nil))
|
||||
|
||||
;; (defun advice-mapc (fun symbol)
|
||||
;; "Apply FUN to every function added as advice to SYMBOL.
|
||||
;; FUN is called with a two arguments: the function that was added, and the
|
||||
;; properties alist that was specified when it was added."
|
||||
;; (let ((def (or (get symbol 'advice--pending)
|
||||
;; (if (fboundp symbol) (symbol-function symbol)))))
|
||||
;; (while (advice--p def)
|
||||
;; (funcall fun (advice--car def) (advice--props def))
|
||||
;; (setq def (advice--cdr def)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun advice-member-p (function symbol)
|
||||
"Return non-nil if advice FUNCTION has been added to function SYMBOL.
|
||||
Instead of FUNCTION being the actual function, it can also be the `name'
|
||||
of the piece of advice."
|
||||
(advice--member-p function
|
||||
(or (get symbol 'advice--pending)
|
||||
(if (fboundp symbol) (symbol-function symbol)))))
|
||||
|
||||
|
||||
(provide 'nadvice)
|
||||
;;; nadvice.el ends here
|
||||
@ -2809,6 +2809,12 @@ Otherwise, return nil."
|
||||
Otherwise, return nil."
|
||||
(and (memq object '(nil t)) t))
|
||||
|
||||
(defun special-form-p (object)
|
||||
"Non-nil if and only if OBJECT is a special form."
|
||||
(if (and (symbolp object) (fboundp object))
|
||||
(setq object (indirect-function object)))
|
||||
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
|
||||
|
||||
(defun field-at-pos (pos)
|
||||
"Return the field at position POS, taking stickiness etc into account."
|
||||
(let ((raw-field (get-char-property (field-beginning pos) 'field)))
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
2012-11-12 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/advice-tests.el: New tests.
|
||||
|
||||
2012-10-14 Eli Zaretskii <eliz@gnu.org>
|
||||
|
||||
* automated/compile-tests.el (compile-tests--test-regexps-data):
|
||||
|
||||
66
test/automated/advice-tests.el
Normal file
66
test/automated/advice-tests.el
Normal file
@ -0,0 +1,66 @@
|
||||
;;; advice-tests.el --- Test suite for the new advice thingy.
|
||||
|
||||
;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar advice-tests--data
|
||||
'(((defun sm-test1 (x) (+ x 4))
|
||||
(sm-test1 6) 10)
|
||||
((advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
|
||||
(sm-test1 6) 50)
|
||||
((defun sm-test1 (x) (+ x 14))
|
||||
(sm-test1 6) 100)
|
||||
((null (get 'sm-test1 'defalias-fset-function)) nil)
|
||||
((advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
|
||||
(sm-test1 6) 20)
|
||||
((null (get 'sm-test1 'defalias-fset-function)) t)
|
||||
|
||||
((defun sm-test2 (x) (+ x 4))
|
||||
(sm-test2 6) 10)
|
||||
((defadvice sm-test2 (around sm-test activate)
|
||||
ad-do-it (setq ad-return-value (* ad-return-value 5)))
|
||||
(sm-test2 6) 50)
|
||||
((ad-deactivate 'sm-test2)
|
||||
(sm-test2 6) 10)
|
||||
((ad-activate 'sm-test2)
|
||||
(sm-test2 6) 50)
|
||||
((defun sm-test2 (x) (+ x 14))
|
||||
(sm-test2 6) 100)
|
||||
((null (get 'sm-test2 'defalias-fset-function)) nil)
|
||||
((ad-remove-advice 'sm-test2 'around 'sm-test)
|
||||
(sm-test2 6) 100)
|
||||
((ad-activate 'sm-test2)
|
||||
(sm-test2 6) 20)
|
||||
((null (get 'sm-test2 'defalias-fset-function)) t)
|
||||
))
|
||||
|
||||
(ert-deftest advice-tests ()
|
||||
"Test advice code."
|
||||
(with-temp-buffer
|
||||
(dolist (test advice-tests--data)
|
||||
(let ((res (eval `(progn ,@(butlast test)))))
|
||||
(should (equal (car (last test)) res))))))
|
||||
|
||||
;; Local Variables:
|
||||
;; no-byte-compile: t
|
||||
;; End:
|
||||
|
||||
;;; advice-tests.el ends here.
|
||||
Loading…
Reference in New Issue
Block a user