[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] /srv/bzr/emacs/trunk r110874: * lisp/emacs-lisp/nadvice.el
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] /srv/bzr/emacs/trunk r110874: * lisp/emacs-lisp/nadvice.el: New package. |
|
Date: |
Mon, 12 Nov 2012 15:43:43 -0500 |
|
User-agent: |
Bazaar (2.5.0) |
------------------------------------------------------------
revno: 110874
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Mon 2012-11-12 15:43:43 -0500
message:
* 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.
added:
lisp/emacs-lisp/nadvice.el
test/automated/advice-tests.el
modified:
etc/NEWS
lisp/ChangeLog
lisp/emacs-lisp/advice.el
lisp/emacs-lisp/debug.el
lisp/emacs-lisp/elp.el
lisp/subr.el
test/ChangeLog
=== modified file 'etc/NEWS'
--- a/etc/NEWS 2012-11-10 23:13:33 +0000
+++ b/etc/NEWS 2012-11-12 20:43:43 +0000
@@ -27,6 +27,13 @@
* 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 @@
* 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.
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2012-11-10 23:19:43 +0000
+++ b/lisp/ChangeLog 2012-11-12 20:43:43 +0000
@@ -1,3 +1,40 @@
+2012-11-12 Stefan Monnier <address@hidden>
+
+ * 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 <address@hidden>
* mail/emacsbug.el (report-emacs-bug-tracker-url)
=== modified file 'lisp/emacs-lisp/advice.el'
--- a/lisp/emacs-lisp/advice.el 2012-11-10 23:13:33 +0000
+++ b/lisp/emacs-lisp/advice.el 2012-11-12 20:43:43 +0000
@@ -1776,27 +1776,6 @@
(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 @@
(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 @@
;; 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 @@
"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 @@
(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 @@
(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))
=== modified file 'lisp/emacs-lisp/debug.el'
--- a/lisp/emacs-lisp/debug.el 2012-10-19 09:28:50 +0000
+++ b/lisp/emacs-lisp/debug.el 2012-11-12 20:43:43 +0000
@@ -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 @@
: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 @@
;;;###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 @@
(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 @@
(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 @@
(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 @@
(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 @@
;; 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 @@
;; 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 @@
(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 @@
: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 @@
;; 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 @@
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 @@
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 @@
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 @@
(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 @@
(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)
=== modified file 'lisp/emacs-lisp/elp.el'
--- a/lisp/emacs-lisp/elp.el 2012-07-26 01:27:33 +0000
+++ b/lisp/emacs-lisp/elp.el 2012-11-12 20:43:43 +0000
@@ -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 @@
"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 @@
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 @@
(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 @@
(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 @@
(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 @@
;; 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))
-
- ;; 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)
-
- ;; 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)))))
+ (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))
+
+ ;; Zap the properties.
+ (put funsym elp-timer-info-property nil)
+
+ (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 @@
(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 @@
(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 @@
(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 @@
(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 @@
(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
=== added file 'lisp/emacs-lisp/nadvice.el'
--- a/lisp/emacs-lisp/nadvice.el 1970-01-01 00:00:00 +0000
+++ b/lisp/emacs-lisp/nadvice.el 2012-11-12 20:43:43 +0000
@@ -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 <address@hidden>
+;; 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
=== modified file 'lisp/subr.el'
--- a/lisp/subr.el 2012-11-09 20:45:10 +0000
+++ b/lisp/subr.el 2012-11-12 20:43:43 +0000
@@ -2809,6 +2809,12 @@
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)))
=== modified file 'test/ChangeLog'
--- a/test/ChangeLog 2012-10-14 07:40:05 +0000
+++ b/test/ChangeLog 2012-11-12 20:43:43 +0000
@@ -1,3 +1,7 @@
+2012-11-12 Stefan Monnier <address@hidden>
+
+ * automated/advice-tests.el: New tests.
+
2012-10-14 Eli Zaretskii <address@hidden>
* automated/compile-tests.el (compile-tests--test-regexps-data):
=== added file 'test/automated/advice-tests.el'
--- a/test/automated/advice-tests.el 1970-01-01 00:00:00 +0000
+++ b/test/automated/advice-tests.el 2012-11-12 20:43:43 +0000
@@ -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.
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] /srv/bzr/emacs/trunk r110874: * lisp/emacs-lisp/nadvice.el: New package.,
Stefan Monnier <=