;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*-
-;; Copyright (C) 2012-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2012-2014 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions, lisp, tools
;;;; 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)
- (:override "\300\301\ 2\"\207" 4)
- (: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)
- (:filter-args "\300\302\301\ 3!\"\207" 5)
- (:filter-return "\301\300\302\ 3\"!\207" 5))
- "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))
+ '((:around . (apply function main args))
+ (:before . (progn
+ (apply function args)
+ (apply main args)))
+ (:after . (prog1 (apply main args)
+ (apply function args)))
+ (:override . (apply function args))
+ (:after-until . (or (apply main args) (apply function args)))
+ (:after-while . (and (apply main args) (apply function args)))
+ (:before-until . (or (apply function args) (apply main args)))
+ (:before-while . (and (apply function args) (apply main args)))
+ (:filter-args . (apply main (apply function args)))
+ (:filter-return . (funcall function (apply main args))))
+ "List of descriptions of how to add a function.")
+
+(setq advice--where-alist
+ (mapcar #'(lambda (tem)
+ (cons (car tem)
+ (eval `(lambda (function main)
+ (lambda (&rest args)
+ ,(cdr tem))))))
+ 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))
+ (when (funcall (@ (guile) procedure?) object)
+ (funcall (@ (guile) procedure-property) object 'advice)))
+
+(defun advice--car (f)
+ (when (funcall (@ (guile) procedure?) f)
+ (funcall (@ (guile) procedure-property) f 'advice-car)))
+
+(defun advice--cdr (f)
+ (when (funcall (@ (guile) procedure?) f)
+ (funcall (@ (guile) procedure-property) f 'advice-cdr)))
+
+(defun advice--props (f)
+ (when (funcall (@ (guile) procedure?) f)
+ (funcall (@ (guile) procedure-property) f 'advice-props)))
+
+(defun advice--cd*r (f)
+ (while (advice--p f)
+ (setq f (advice--cdr f)))
+ f)
+
+(defun advice--make-docstring (function)
+ "Build the raw docstring for FUNCTION, presumably advised."
+ (let* ((flist (indirect-function function))
+ (docfun nil)
+ (docstring nil))
(if (eq 'macro (car-safe flist)) (setq flist (cdr flist)))
(while (advice--p flist)
(let ((bytecode (aref flist 1))
+ (doc (aref flist 4))
(where nil))
+ ;; Hack attack! For advices installed before calling
+ ;; Snarf-documentation, the integer offset into the DOC file will not
+ ;; be installed in the "core unadvised function" but in the advice
+ ;; object instead! So here we try to undo the damage.
+ (if (integerp doc) (setq docfun flist))
(dolist (elem advice--where-alist)
- (if (eq bytecode (cadr elem)) (setq where (car elem))))
+ (if (eq bytecode (cdr elem)) (setq where (car elem))))
(setq docstring
(concat
docstring
"\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)))
+ (unless docfun (setq docfun flist))
+ (let* ((origdoc (unless (eq function docfun) ;Avoid inf-loops.
+ (documentation docfun t)))
(usage (help-split-fundoc origdoc function)))
(setq usage (if (null usage)
(let ((arglist (help-function-arglist flist)))
(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-eval-interactive-spec (spec)
"Evaluate the interactive spec SPEC."
(cond
;; ((functionp spec) (funcall spec))
(t (eval spec))))
+(defun advice--interactive-form (function)
+ ;; Like `interactive-form' but tries to avoid autoloading functions.
+ (when (commandp function)
+ (if (not (and (symbolp function) (autoloadp (indirect-function function))))
+ (interactive-form function)
+ `(interactive (advice-eval-interactive-spec
+ (cadr (interactive-form ',function)))))))
+
(defun advice--make-interactive-form (function main)
;; TODO: make it so that interactive spec can be a constant which
;; dynamically checks the advice--car/cdr to do its job.
;; For that, advice-eval-interactive-spec needs to be more faithful.
- ;; FIXME: The calls to interactive-form below load autoloaded functions
- ;; too eagerly.
- (let ((fspec (cadr (interactive-form function))))
+ (let* ((iff (advice--interactive-form function))
+ (ifm (advice--interactive-form main))
+ (fspec (cadr iff)))
(when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda?
(setq fspec (nth 1 fspec)))
(if (functionp fspec)
- `(funcall ',fspec
- ',(cadr (interactive-form main)))
- (cadr (or (interactive-form function)
- (interactive-form main))))))
+ `(funcall ',fspec ',(cadr ifm))
+ (cadr (or iff ifm)))))
-(defsubst advice--make-1 (byte-code stack-depth function main props)
+(defun advice--make-1 (type make-wrapper 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))))))
+ (funcall make-wrapper function main)))
+ (funcall (@ (guile) set-procedure-property!)
+ advice 'advice-type type)
+ (funcall (@ (guile) set-procedure-property!)
+ advice 'advice-car function)
+ (funcall (@ (guile) set-procedure-property!)
+ advice 'advice-cdr main)
+ (funcall (@ (guile) set-procedure-property!)
+ advice 'advice-props props)
+ (when (or (commandp function) (commandp main))
+ (funcall (@ (guile) set-procedure-property!)
+ advice
+ 'interactive-form
+ (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 name definition)
+ (let ((fd (or (cdr (assq 'depth props)) 0))
+ (md (if (advice--p main)
+ (or (cdr (assq 'depth (advice--props main))) 0))))
+ (if (and md (> fd md))
+ ;; `function' should go deeper.
+ (let ((rest (advice--make where function (advice--cdr main) props)))
+ (advice--make-1 (aref main 1) (aref main 3)
+ (advice--car main) rest (advice--props main)))
+ (let ((desc (assq where advice--where-alist)))
+ (unless desc (error "Unknown add-function location `%S'" where))
+ (advice--make-1 (car desc) (cdr desc)
+ function main props)))))
+
+(defun advice--member-p (function use-name definition)
(let ((found nil))
(while (and (not found) (advice--p definition))
- (if (or (equal function (advice--car definition))
- (when name
- (equal name (cdr (assq 'name (advice--props definition))))))
+ (if (if (eq use-name :use-both)
+ (or (equal function
+ (cdr (assq 'name (advice--props definition))))
+ (equal function (advice--car definition)))
+ (equal function (if use-name
+ (cdr (assq 'name (advice--props definition)))
+ (advice--car definition))))
(setq found definition)
(setq definition (advice--cdr definition))))
found))
(lambda (first rest props)
(cond ((not first) rest)
((or (equal function first)
- (equal function (cdr (assq 'name props))))
- (list rest))))))
+ (equal function (cdr (assq 'name props))))
+ (list (advice--remove-function rest function)))))))
-(defvar advice--buffer-local-function-sample nil)
+(defvar advice--buffer-local-function-sample nil
+ "keeps an example of the special \"run the default value\" functions.
+These functions play the same role as t in buffer-local hooks, and to recognize
+them, we keep a sample here against which to compare. Each instance is
+different, but `function-equal' will hopefully ignore those differences.")
(defun advice--set-buffer-local (var val)
- (if (function-equal val advice--buffer-local-function-sample)
+ (if (equal val advice--buffer-local-function-sample)
(kill-local-variable var)
(set (make-local-variable var) val)))
(declare (gv-setter advice--set-buffer-local))
(if (local-variable-p var) (symbol-value var)
(setq advice--buffer-local-function-sample
+ ;; This function acts like the t special value in buffer-local hooks.
(lambda (&rest args) (apply (default-value var) args)))))
+(eval-and-compile
+ (defun advice--normalize-place (place)
+ (cond ((eq 'local (car-safe place)) `(advice--buffer-local ,@(cdr place)))
+ ((eq 'var (car-safe place)) (nth 1 place))
+ ((symbolp place) `(default-value ',place))
+ (t place))))
+
;;;###autoload
(defmacro add-function (where place function &optional props)
;; TODO:
- ;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP
- ;; and tracing want to stay first.
;; - maybe let `where' specify some kind of predicate and use it
;; to implement things like mode-local or eieio-defmethod.
;; Of course, that only makes sense if the predicates of all advices can
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.
+- `depth': a number indicating a preference w.r.t ordering.
+ The default depth is 0. By convention, a depth of 100 means that
+ the advice should be innermost (i.e. at the end of the list),
+ whereas a depth of -100 means that the advice should be outermost.
-If PLACE is a simple variable, only its global value will be affected.
-Use (local 'VAR) if you want to apply FUNCTION to VAR buffer-locally.
+If PLACE is a symbol, its `default-value' will be affected.
+Use (local 'SYMBOL) if you want to apply FUNCTION to SYMBOL buffer-locally.
+Use (var VAR) if you want to apply FUNCTION to the (lexical) VAR.
If one of FUNCTION or OLDFUN is interactive, then the resulting function
is also interactive. There are 3 cases:
`advice-eval-interactive-spec') and return the list of arguments to use.
- Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN."
(declare (debug t)) ;;(indent 2)
- (cond ((eq 'local (car-safe place))
- (setq place `(advice--buffer-local ,@(cdr place))))
- ((symbolp place)
- (setq place `(default-value ',place))))
- `(advice--add-function ,where (gv-ref ,place) ,function ,props))
+ `(advice--add-function ,where (gv-ref ,(advice--normalize-place place))
+ ,function ,props))
;;;###autoload
(defun advice--add-function (where ref function props)
- (let ((a (advice--member-p function (cdr (assq 'name props))
- (gv-deref ref))))
+ (let* ((name (cdr (assq 'name props)))
+ (a (advice--member-p (or name function) (if name t) (gv-deref ref))))
(when a
;; The advice is already present. Remove the old one, first.
(setf (gv-deref ref)
- (advice--remove-function (gv-deref ref) (advice--car a))))
+ (advice--remove-function (gv-deref ref)
+ (or name (advice--car a)))))
(setf (gv-deref ref)
(advice--make where function (gv-deref ref) props))))
Instead of FUNCTION being the actual function, it can also be the `name'
of the piece of advice."
(declare (debug t))
- (cond ((eq 'local (car-safe place))
- (setq place `(advice--buffer-local ,@(cdr place))))
- ((symbolp place)
- (error "Use (default-value '%S) or (local '%S)" place place)))
- (gv-letplace (getter setter) place
+ (gv-letplace (getter setter) (advice--normalize-place place)
(macroexp-let2 nil new `(advice--remove-function ,getter ,function)
`(unless (eq ,new ,getter) ,(funcall setter new)))))
+(defun advice-function-mapc (f function-def)
+ "Apply F to every advice function in FUNCTION-DEF.
+F is called with two arguments: the function that was added, and the
+properties alist that was specified when it was added."
+ (while (advice--p function-def)
+ (funcall f (advice--car function-def) (advice--props function-def))
+ (setq function-def (advice--cdr function-def))))
+
+(defun advice-function-member-p (advice function-def)
+ "Return non-nil if ADVICE is already in FUNCTION-DEF.
+Instead of ADVICE being the actual function, it can also be the `name'
+of the piece of advice."
+ (advice--member-p advice :use-both function-def))
+
;;;; Specific application of add-function to `symbol-function' for advice.
(defun advice--subst-main (old new)
(cond
((special-form-p def)
;; Not worth the trouble trying to handle this, I think.
- (error "advice-add failure: %S is a special form" symbol))
- ((and (symbolp def)
- (eq 'macro (car-safe (ignore-errors (indirect-function def)))))
- (let ((newval (cons 'macro (cdr (indirect-function def)))))
- (put symbol 'advice--saved-rewrite (cons def newval))
+ (error "Advice impossible: %S is a special form" symbol))
+ ((and (symbolp def) (macrop def))
+ (let ((newval `(macro . ,(lambda (&rest r) (macroexpand `(,def . ,r))))))
+ (put symbol 'advice--saved-rewrite (cons def (cdr newval)))
newval))
;; `f' might be a pure (hence read-only) cons!
((and (eq 'macro (car-safe def))
(defsubst advice--strip-macro (x)
(if (eq 'macro (car-safe x)) (cdr x) x))
+(defun advice--symbol-function (symbol)
+ ;; The value conceptually stored in `symbol-function' is split into two
+ ;; parts:
+ ;; - the normal function definition.
+ ;; - the list of advice applied to it.
+ ;; `advice--symbol-function' is intended to return the second part (i.e. the
+ ;; list of advice, which includes a hole at the end which typically holds the
+ ;; first part, but this function doesn't care much which value is found
+ ;; there).
+ ;; In the "normal" state both parts are combined into a single value stored
+ ;; in the "function slot" of the symbol. But the way they are combined is
+ ;; different depending on whether the definition is a function or a macro.
+ ;; Also if the function definition is nil (i.e. unbound) or is an autoload,
+ ;; the second part is stashed away temporarily in the `advice--pending'
+ ;; symbol property.
+ (or (get symbol 'advice--pending)
+ (advice--strip-macro (symbol-function symbol))))
+
(defun advice--defalias-fset (fsetfun symbol newdef)
+ (unless fsetfun (setq fsetfun #'fset))
(when (get symbol 'advice--saved-rewrite)
(put symbol 'advice--saved-rewrite nil))
(setq newdef (advice--normalize symbol newdef))
- (let* ((olddef (advice--strip-macro
- (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))))
- (let* ((snewdef (advice--strip-macro newdef))
- (snewadv (advice--subst-main oldadv snewdef)))
- (funcall (or fsetfun #'fset) symbol
- (if (eq snewdef newdef) snewadv (cons 'macro snewadv))))))
-
+ (let ((oldadv (advice--symbol-function symbol)))
+ (if (and newdef (not (autoloadp newdef)))
+ (let* ((snewdef (advice--strip-macro newdef))
+ (snewadv (advice--subst-main oldadv snewdef)))
+ (put symbol 'advice--pending nil)
+ (funcall fsetfun symbol
+ (if (eq snewdef newdef) snewadv (cons 'macro snewadv))))
+ (unless (eq oldadv (get symbol 'advice--pending))
+ (put symbol 'advice--pending (advice--subst-main oldadv nil)))
+ (funcall fsetfun symbol newdef))))
;;;###autoload
(defun advice-add (symbol where function &optional props)
;; 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.
- (let* ((f (and (fboundp symbol) (symbol-function symbol)))
+ (let* ((f (symbol-function symbol))
(nf (advice--normalize symbol f)))
- (unless (eq f nf) ;; Most importantly, if nf == nil!
- (fset symbol nf))
+ (unless (eq f nf) (fset symbol nf))
(add-function where (cond
((eq (car-safe nf) 'macro) (cdr nf))
;; Reasons to delay installation of the advice:
;; - If the function is not yet defined, installing
;; the advice would affect `fboundp'ness.
- ;; - If it's an autoloaded command,
- ;; advice--make-interactive-form would end up
- ;; loading the command eagerly.
+ ;; - the symbol-function slot of an autoloaded
+ ;; function is not itself a function value.
;; - `autoload' does nothing if the function is
;; not an autoload or undefined.
((or (not nf) (autoloadp nf))
(get symbol 'advice--pending))
(t (symbol-function symbol)))
function props)
+ (put symbol 'function-documentation `(advice--make-docstring ',symbol))
(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'.
+Contrary to `remove-function', this also works when SYMBOL is a macro
+or an autoload and it preserves `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 advised 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)))))
+ (let ((f (symbol-function symbol)))
+ (remove-function (cond ;This is `advice--symbol-function' but as a "place".
+ ((get symbol 'advice--pending)
+ (get symbol 'advice--pending))
+ ((eq (car-safe f) 'macro) (cdr f))
+ (t (symbol-function symbol)))
+ function)
+ (unless (advice--p (advice--symbol-function symbol))
+ (remove-function (get symbol 'defalias-fset-function)
+ #'advice--defalias-fset)
+ (let ((asr (get symbol 'advice--saved-rewrite)))
+ (and asr (eq (cdr-safe (symbol-function symbol))
+ (cdr asr))
+ (fset symbol (car (get symbol 'advice--saved-rewrite)))))))
+ nil)
+
+(defun advice-mapc (fun symbol)
+ "Apply FUN to every advice function in SYMBOL.
+FUN is called with a two arguments: the function that was added, and the
+properties alist that was specified when it was added."
+ (advice-function-mapc fun (advice--symbol-function symbol)))
;;;###autoload
-(defun advice-member-p (advice function-name)
- "Return non-nil if ADVICE has been added to FUNCTION-NAME.
+(defun advice-member-p (advice symbol)
+ "Return non-nil if ADVICE has been added to SYMBOL.
Instead of ADVICE being the actual function, it can also be the `name'
of the piece of advice."
- (advice--member-p advice advice
- (or (get function-name 'advice--pending)
- (advice--strip-macro
- (if (fboundp function-name)
- (symbol-function function-name))))))
+ (advice-function-member-p advice (advice--symbol-function symbol)))
;; When code is advised, called-interactively-p needs to be taught to skip
;; the advising frames.
(get-next-frame
(lambda ()
(setq frame1 frame2)
- (setq frame2 (internal--called-interactively-p--get-frame i))
+ (setq frame2 (backtrace-frame i #'called-interactively-p))
;; (message "Advice Frame %d = %S" i frame2)
(setq i (1+ i)))))
(when (and (eq (nth 1 frame2) 'apply)
HCoop / bpt / emacs.git / blobdiff