From 231d8498eb1a10fadf7a4cd860cc934e05516433 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 12 Nov 2012 15:43:43 -0500 Subject: [PATCH] * 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. --- etc/NEWS | 8 + lisp/ChangeLog | 37 ++++ lisp/emacs-lisp/advice.el | 42 +--- lisp/emacs-lisp/debug.el | 181 +++++------------ lisp/emacs-lisp/elp.el | 332 ++++++++++++------------------- lisp/emacs-lisp/nadvice.el | 348 +++++++++++++++++++++++++++++++++ lisp/subr.el | 6 + test/ChangeLog | 4 + test/automated/advice-tests.el | 66 +++++++ 9 files changed, 657 insertions(+), 367 deletions(-) create mode 100644 lisp/emacs-lisp/nadvice.el create mode 100644 test/automated/advice-tests.el diff --git a/etc/NEWS b/etc/NEWS index 6e0609b94d..a78980bedc 100644 --- a/etc/NEWS +++ b/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 `-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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c5c4369ef1..f53b58b012 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,40 @@ +2012-11-12 Stefan Monnier + + * 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 * mail/emacsbug.el (report-emacs-bug-tracker-url) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 8239522c0f..16c12aad29 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -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)) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index c04e68c0cf..3d4f41be8e 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -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-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) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index b94817cdb0..067b45f5cd 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -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))) - - ;; add this function to the instrumentation list - (unless (memq funsym elp-all-instrumented-list) - (push funsym elp-all-instrumented-list)))) + ;; ELP wrapper. + (advice-add funsym :around (elp--make-wrapper funsym) + `((name . ,elp--advice-name))))) + +(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 @@ 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 diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el new file mode 100644 index 0000000000..020a2f89bd --- /dev/null +++ b/lisp/emacs-lisp/nadvice.el @@ -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 +;; 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 . + +;;; 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 diff --git a/lisp/subr.el b/lisp/subr.el index 0ba932a3ef..ebfcfbc093 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -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))) diff --git a/test/ChangeLog b/test/ChangeLog index 72b44747ba..4a9d215aa2 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2012-11-12 Stefan Monnier + + * automated/advice-tests.el: New tests. + 2012-10-14 Eli Zaretskii * automated/compile-tests.el (compile-tests--test-regexps-data): diff --git a/test/automated/advice-tests.el b/test/automated/advice-tests.el new file mode 100644 index 0000000000..cac10e9602 --- /dev/null +++ b/test/automated/advice-tests.el @@ -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 . + +;;; 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. -- 2.20.1