X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/adf2fc4a01efe77d73cd52bc9173914ed56ff531..55f2168dd4ecd0ff197d5b3d5162cd276a47202d:/lisp/emacs-lisp/nadvice.el diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 576e72088e..02535ea627 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -1,6 +1,6 @@ ;;; 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 ;; Keywords: extensions, lisp, tools @@ -38,45 +38,67 @@ ;;;; 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\"\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!\"\207" 5) - (:filter-return "\301\300\302\"!\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 @@ -96,8 +118,9 @@ Each element has the form (WHERE BYTECODE STACK) where: "\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))) @@ -105,13 +128,6 @@ Each element has the form (WHERE BYTECODE STACK) where: (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 @@ -125,48 +141,74 @@ Each element has the form (WHERE BYTECODE STACK) where: ;; ((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)) @@ -190,8 +232,8 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (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 "keeps an example of the special \"run the default value\" functions. @@ -200,7 +242,7 @@ 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))) @@ -213,11 +255,16 @@ different, but `function-equal' will hopefully ignore those differences.") ;; 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 @@ -245,9 +292,14 @@ 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. +- `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: @@ -257,20 +309,18 @@ 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)))) @@ -281,11 +331,7 @@ 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)) - (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))))) @@ -301,7 +347,7 @@ properties alist that was specified when it was added." "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 advice function-def)) + (advice--member-p advice :use-both function-def)) ;;;; Specific application of add-function to `symbol-function' for advice. @@ -360,7 +406,6 @@ of the piece of advice." (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) @@ -379,15 +424,15 @@ is defined as a macro, alias, command, ..." ;; 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) @@ -407,7 +452,6 @@ of the piece of advice." (t (symbol-function symbol))) function) (unless (advice--p (advice--symbol-function symbol)) - ;; Not advised any more. (remove-function (get symbol 'defalias-fset-function) #'advice--defalias-fset) (let ((asr (get symbol 'advice--saved-rewrite)))