;;; advice.el --- an overloading mechanism for Emacs Lisp functions
-;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1993,1994,2000,01,2004 Free Software Foundation, Inc.
;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
;; Maintainer: FSF
;; generates an advised definition of the `documentation' function, and
;; it will enable automatic advice activation when functions get defined.
;; All of this can be undone at any time with `M-x ad-stop-advice'.
-;;
+;;
;; If you experience any strange behavior/errors etc. that you attribute to
;; Advice or to some ill-advised function do one of the following:
;; If this is a problem one can always specify an interactive form in a
;; before/around/after advice to gain control over argument values that
;; were supplied interactively.
-;;
+;;
;; Then the body forms of the various advices in the various classes of advice
;; are assembled in order. The forms of around advice L are normally part of
;; one of the forms of around advice L-1. An around advice can specify where
;; whose form depends on the type of the original function. The variable
;; `ad-return-value' will be set to its result. This variable is visible to
;; all pieces of advice which can access and modify it before it gets returned.
-;;
+;;
;; The semantic structure of advised functions that contain protected pieces
;; of advice is the same. The only difference is that `unwind-protect' forms
;; make sure that the protected advice gets executed even if some previous
;;
;; We start by defining an innocent looking function `foo' that simply
;; adds 1 to its argument X:
-;;
+;;
;; (defun foo (x)
;; "Add 1 to X."
;; (1+ x))
be returned at the end of the iteration, nil otherwise. The iteration can be
exited prematurely with `(ad-do-return [VALUE])'."
(let ((expansion
- (` (let ((ad-dO-vAr (, (car (cdr varform))))
- (, (car varform)))
- (while ad-dO-vAr
- (setq (, (car varform)) (car ad-dO-vAr))
- (,@ body)
- ;;work around a backquote bug:
- ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong
- ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar)))
- (, '(setq ad-dO-vAr (cdr ad-dO-vAr))))
- (, (car (cdr (cdr varform))))))))
+ `(let ((ad-dO-vAr ,(car (cdr varform)))
+ ,(car varform))
+ (while ad-dO-vAr
+ (setq ,(car varform) (car ad-dO-vAr))
+ ,@body
+ ;;work around a backquote bug:
+ ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong
+ ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar)))
+ ,'(setq ad-dO-vAr (cdr ad-dO-vAr)))
+ ,(car (cdr (cdr varform))))))
;;ok, this wastes some cons cells but only during compilation:
(if (catch 'contains-return
(ad-substitute-tree
(function (lambda (subtree)
- (cond ((eq (car-safe subtree) 'ad-dolist))
- ((eq (car-safe subtree) 'ad-do-return)
- (throw 'contains-return t)))))
+ (cond ((eq (car-safe subtree) 'ad-dolist))
+ ((eq (car-safe subtree) 'ad-do-return)
+ (throw 'contains-return t)))))
'identity body)
nil)
- (` (catch 'ad-dO-eXiT (, expansion)))
- expansion)))
+ `(catch 'ad-dO-eXiT ,expansion)
+ expansion)))
(defmacro ad-do-return (value)
- (` (throw 'ad-dO-eXiT (, value))))
+ `(throw 'ad-dO-eXiT ,value))
(if (not (get 'ad-dolist 'lisp-indent-hook))
(put 'ad-dolist 'lisp-indent-hook 1))
(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))))))))))))
+ `(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))))))))
(defun ad-save-real-definitions ()
;; Macro expansion will hardcode the values of the various byte-compiler
(defmacro ad-pushnew-advised-function (function)
"Add FUNCTION to `ad-advised-functions' unless its already there."
- (` (if (not (assoc (symbol-name (, function)) ad-advised-functions))
- (setq ad-advised-functions
- (cons (list (symbol-name (, function)))
- ad-advised-functions)))))
+ `(if (not (assoc (symbol-name ,function) ad-advised-functions))
+ (setq ad-advised-functions
+ (cons (list (symbol-name ,function))
+ ad-advised-functions))))
(defmacro ad-pop-advised-function (function)
"Remove FUNCTION from `ad-advised-functions'."
- (` (setq ad-advised-functions
- (delq (assoc (symbol-name (, function)) ad-advised-functions)
- ad-advised-functions))))
+ `(setq ad-advised-functions
+ (delq (assoc (symbol-name ,function) ad-advised-functions)
+ ad-advised-functions)))
(defmacro ad-do-advised-functions (varform &rest body)
"`ad-dolist'-style iterator that maps over `ad-advised-functions'.
BODY-FORM...)
On each iteration VAR will be bound to the name of an advised function
\(a symbol)."
- (` (ad-dolist ((, (car varform))
- ad-advised-functions
- (, (car (cdr varform))))
- (setq (, (car varform)) (intern (car (, (car varform)))))
- (,@ body))))
+ `(ad-dolist (,(car varform)
+ ad-advised-functions
+ ,(car (cdr varform)))
+ (setq ,(car varform) (intern (car ,(car varform))))
+ ,@body))
(if (not (get 'ad-do-advised-functions 'lisp-indent-hook))
(put 'ad-do-advised-functions 'lisp-indent-hook 1))
(defmacro ad-get-advice-info (function)
- (` (get (, function) 'ad-advice-info)))
+ `(get ,function 'ad-advice-info))
(defmacro ad-set-advice-info (function advice-info)
- (` (put (, function) 'ad-advice-info (, advice-info))))
+ `(put ,function 'ad-advice-info ,advice-info))
(defmacro ad-copy-advice-info (function)
- (` (ad-copy-tree (get (, function) 'ad-advice-info))))
+ `(ad-copy-tree (get ,function 'ad-advice-info)))
(defmacro ad-is-advised (function)
"Return non-nil if FUNCTION has any advice info associated with it.
(defmacro ad-get-advice-info-field (function field)
"Retrieve the value of the advice info FIELD of FUNCTION."
- (` (cdr (assq (, field) (ad-get-advice-info (, function))))))
+ `(cdr (assq ,field (ad-get-advice-info ,function))))
(defun ad-set-advice-info-field (function field value)
"Destructively modify VALUE of the advice info FIELD of FUNCTION."
(let (enabled-advices)
(ad-dolist (advice (ad-get-advice-info-field function class))
(if (ad-advice-enabled advice)
- (setq enabled-advices (cons advice enabled-advices))))
+ (push advice enabled-advices)))
(reverse enabled-advices)))
(defvar ad-activate-on-top-level t)
(defmacro ad-with-auto-activation-disabled (&rest body)
- (` (let ((ad-activate-on-top-level nil))
- (,@ body))))
+ `(let ((ad-activate-on-top-level nil))
+ ,@body))
(defun ad-safe-fset (symbol definition)
"A safe `fset' which will never call `ad-activate-internal' recursively."
(intern (format "ad-Orig-%s" function)))
(defmacro ad-get-orig-definition (function)
- (` (let ((origname (ad-get-advice-info-field (, function) 'origname)))
- (if (fboundp origname)
- (symbol-function origname)))))
+ `(let ((origname (ad-get-advice-info-field ,function 'origname)))
+ (if (fboundp origname)
+ (symbol-function origname))))
(defmacro ad-set-orig-definition (function definition)
- (` (ad-safe-fset
- (ad-get-advice-info-field function 'origname) (, definition))))
+ `(ad-safe-fset
+ (ad-get-advice-info-field function 'origname) ,definition))
(defmacro ad-clear-orig-definition (function)
- (` (fmakunbound (ad-get-advice-info-field (, function) 'origname))))
+ `(fmakunbound (ad-get-advice-info-field ,function 'origname)))
;; @@ Interactive input functions:
(intern function))))
(defvar ad-advice-class-completion-table
- (mapcar '(lambda (class) (list (symbol-name class)))
+ (mapcar (lambda (class) (list (symbol-name class)))
ad-advice-classes))
(defun ad-read-advice-class (function &optional prompt default)
(defmacro ad-find-advice (function class name)
"Find the first advice of FUNCTION in CLASS with NAME."
- (` (assq (, name) (ad-get-advice-info-field (, function) (, class)))))
+ `(assq ,name (ad-get-advice-info-field ,function ,class)))
(defun ad-advice-position (function class name)
"Return position of first advice of FUNCTION in CLASS with NAME."
(defmacro ad-macrofy (definition)
"Take a lambda function DEFINITION and make a macro out of it."
- (` (cons 'macro (, definition))))
+ `(cons 'macro ,definition))
(defmacro ad-lambdafy (definition)
"Take a macro function DEFINITION and make a lambda out of it."
- (` (cdr (, definition))))
+ `(cdr ,definition))
;; There is no way to determine whether some subr is a special form or not,
;; hence we need this list (which is probably out of date):
defun defvar function if interactive let let*
or prog1 prog2 progn quote save-current-buffer
save-excursion save-restriction save-window-excursion
- setq setq-default track-mouse unwind-protect while
+ setq setq-default unwind-protect while
with-output-to-temp-buffer)))
;; track-mouse could be void in some configurations.
(if (fboundp 'track-mouse)
- (setq tem (cons 'track-mouse tem)))
+ (push 'track-mouse tem))
(mapcar 'symbol-function tem)))
(defmacro ad-special-form-p (definition)
(defmacro ad-macro-p (definition)
;;"non-nil if DEFINITION is a macro."
- (` (eq (car-safe (, definition)) 'macro)))
+ `(eq (car-safe ,definition) 'macro))
(defmacro ad-lambda-p (definition)
;;"non-nil if DEFINITION is a lambda expression."
- (` (eq (car-safe (, definition)) 'lambda)))
+ `(eq (car-safe ,definition) 'lambda))
;; see ad-make-advice for the format of advice definitions:
(defmacro ad-advice-p (definition)
;;"non-nil if DEFINITION is a piece of advice."
- (` (eq (car-safe (, definition)) 'advice)))
+ `(eq (car-safe ,definition) 'advice))
;; Emacs/Lemacs cross-compatibility
;; (compiled-function-p is an obsolete function in Emacs):
(defmacro ad-compiled-p (definition)
"Return non-nil if DEFINITION is a compiled byte-code object."
- (` (or (byte-code-function-p (, definition))
- (and (ad-macro-p (, definition))
- (byte-code-function-p (ad-lambdafy (, definition)))))))
+ `(or (byte-code-function-p ,definition)
+ (and (ad-macro-p ,definition)
+ (byte-code-function-p (ad-lambdafy ,definition)))))
(defmacro ad-compiled-code (compiled-definition)
"Return the byte-code object of a COMPILED-DEFINITION."
- (` (if (ad-macro-p (, compiled-definition))
- (ad-lambdafy (, compiled-definition))
- (, compiled-definition))))
+ `(if (ad-macro-p ,compiled-definition)
+ (ad-lambdafy ,compiled-definition)
+ ,compiled-definition))
(defun ad-lambda-expression (definition)
"Return the lambda expression of a function/macro/advice DEFINITION."
;; otherwise get it from its printed representation:
(setq name (format "%s" definition))
(string-match "^#<subr \\([^>]+\\)>$" name)
- (ad-subr-arglist
- (intern (substring name (match-beginning 1) (match-end 1))))))))
+ (ad-subr-arglist (intern (match-string 1 name)))))))
;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish
;; a defined empty arglist `(nil)' from an undefined arglist:
(defmacro ad-define-subr-args (subr arglist)
- (` (put (, subr) 'ad-subr-arglist (list (, arglist)))))
+ `(put ,subr 'ad-subr-arglist (list ,arglist)))
(defmacro ad-undefine-subr-args (subr)
- (` (put (, subr) 'ad-subr-arglist nil)))
+ `(put ,subr 'ad-subr-arglist nil))
(defmacro ad-subr-args-defined-p (subr)
- (` (get (, subr) 'ad-subr-arglist)))
+ `(get ,subr 'ad-subr-arglist))
(defmacro ad-get-subr-args (subr)
- (` (car (get (, subr) 'ad-subr-arglist))))
+ `(car (get ,subr 'ad-subr-arglist)))
(defun ad-subr-arglist (subr-name)
"Retrieve arglist of the subr with SUBR-NAME.
Either use the one stored under the `ad-subr-arglist' property,
or try to retrieve it from the docstring and cache it under
that property, or otherwise use `(&rest ad-subr-args)'."
- (cond ((ad-subr-args-defined-p subr-name)
- (ad-get-subr-args subr-name))
- ;; says jwz: Should use this for Lemacs 19.8 and above:
- ;;((fboundp 'subr-min-args)
- ;; ...)
- ;; says hans: I guess what Jamie means is that I should use the values
- ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist
- ;; without having to look it up via parsing the docstring, e.g.,
- ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an
- ;; argument list. However, that won't work because there is no
- ;; way to distinguish a subr with args `(a &optional b &rest c)' from
- ;; one with args `(a &rest c)' using that mechanism. Also, the argument
- ;; names from the docstring are more meaningful. Hence, I'll stick with
- ;; the old way of doing things.
- (t (let ((doc (or (ad-real-documentation subr-name t) "")))
- (cond ((string-match "^\\(([^\)]+)\\)\n?\\'" doc)
- (ad-define-subr-args
- subr-name
- (cdr (car (read-from-string
- (downcase
- (substring doc
- (match-beginning 1)
- (match-end 1)))))))
- (ad-get-subr-args subr-name))
- ;; this is the old format used before Emacs 19.24:
- ((string-match
- "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'" doc)
- (ad-define-subr-args
- subr-name
- (car (read-from-string
- doc (match-beginning 1) (match-end 1))))
- (ad-get-subr-args subr-name))
- (t '(&rest ad-subr-args)))))))
+ (if (ad-subr-args-defined-p subr-name)
+ (ad-get-subr-args subr-name)
+ ;; says jwz: Should use this for Lemacs 19.8 and above:
+ ;;((fboundp 'subr-min-args)
+ ;; ...)
+ ;; says hans: I guess what Jamie means is that I should use the values
+ ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist
+ ;; without having to look it up via parsing the docstring, e.g.,
+ ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an
+ ;; argument list. However, that won't work because there is no
+ ;; way to distinguish a subr with args `(a &optional b &rest c)' from
+ ;; one with args `(a &rest c)' using that mechanism. Also, the argument
+ ;; names from the docstring are more meaningful. Hence, I'll stick with
+ ;; the old way of doing things.
+ (let ((doc (or (ad-real-documentation subr-name t) "")))
+ (if (not (string-match "\n\n\\((.+)\\)\\'" doc))
+ ;; Signalling an error leads to bugs during bootstrapping because
+ ;; the DOC file is not yet built (which is an error, BTW).
+ ;; (error "The usage info is missing from the subr %s" subr-name)
+ '(&rest ad-subr-args)
+ (ad-define-subr-args
+ subr-name
+ (cdr (car (read-from-string
+ (downcase (match-string 1 doc))))))
+ (ad-get-subr-args subr-name)))))
(defun ad-docstring (definition)
"Return the unexpanded docstring of DEFINITION."
;; Need to turn off auto-activation
;; because `byte-compile' uses `fset':
(ad-with-auto-activation-disabled
- (byte-compile function))))
+ (require 'bytecomp)
+ (let ((symbol (make-symbol "advice-compilation"))
+ (byte-compile-warnings
+ (if (listp byte-compile-warnings) byte-compile-warnings
+ byte-compile-warning-types)))
+ (if (featurep 'cl)
+ (setq byte-compile-warnings
+ (remq 'cl-functions byte-compile-warnings)))
+ (fset symbol (symbol-function function))
+ (byte-compile symbol)
+ (fset function (symbol-function symbol))))))
;; @@ Constructing advised definitions:
`required', `optional' or `rest' depending on the type of the argument."
(let* ((parsed-arglist (ad-parse-arglist arglist))
(rest (nth 2 parsed-arglist)))
- (` (list
- (,@ (mapcar (function
- (lambda (req)
- (` (list '(, req) (, req) 'required))))
- (nth 0 parsed-arglist)))
- (,@ (mapcar (function
- (lambda (opt)
- (` (list '(, opt) (, opt) 'optional))))
- (nth 1 parsed-arglist)))
- (,@ (if rest (list (` (list '(, rest) (, rest) 'rest)))))
- ))))
+ `(list
+ ,@(mapcar (function
+ (lambda (req)
+ `(list ',req ,req 'required)))
+ (nth 0 parsed-arglist))
+ ,@(mapcar (function
+ (lambda (opt)
+ `(list ',opt ,opt 'optional)))
+ (nth 1 parsed-arglist))
+ ,@(if rest (list `(list ',rest ,rest 'rest))))))
(defun ad-arg-binding-field (binding field)
(cond ((eq field 'name) (car binding))
(defun ad-element-access (position list)
(cond ((= position 0) (list 'car list))
- ((= position 1) (` (car (cdr (, list)))))
+ ((= position 1) `(car (cdr ,list)))
(t (list 'nth position list))))
(defun ad-access-argument (arglist index)
(let ((argument-access (ad-access-argument arglist index)))
(cond ((consp argument-access)
;; should this check whether there actually is something to set?
- (` (setcar (, (ad-list-access
- (car argument-access) (car (cdr argument-access))))
- (, value-form))))
+ `(setcar ,(ad-list-access
+ (car argument-access) (car (cdr argument-access)))
+ ,value-form))
(argument-access
- (` (setq (, argument-access) (, value-form))))
+ `(setq ,argument-access ,value-form))
(t (error "ad-set-argument: No argument at position %d of `%s'"
index arglist)))))
(rest-arg (nth 2 parsed-arglist))
args-form)
(if (< index (length reqopt-args))
- (setq args-form (` (list (,@ (nthcdr index reqopt-args))))))
+ (setq args-form `(list ,@(nthcdr index reqopt-args))))
(if rest-arg
(if args-form
- (setq args-form (` (nconc (, args-form) (, rest-arg))))
- (setq args-form (ad-list-access (- index (length reqopt-args))
- rest-arg))))
+ (setq args-form `(nconc ,args-form ,rest-arg))
+ (setq args-form (ad-list-access (- index (length reqopt-args))
+ rest-arg))))
args-form))
(defun ad-set-arguments (arglist index values-form)
arglist index
(ad-element-access values-index 'ad-vAlUeS))
set-forms))
- (setq set-forms
- (cons (if (= (car argument-access) 0)
- (list 'setq
- (car (cdr argument-access))
- (ad-list-access values-index 'ad-vAlUeS))
- (list 'setcdr
- (ad-list-access (1- (car argument-access))
- (car (cdr argument-access)))
- (ad-list-access values-index 'ad-vAlUeS)))
- set-forms))
- ;; terminate loop
- (setq arglist nil))
+ (setq set-forms
+ (cons (if (= (car argument-access) 0)
+ (list 'setq
+ (car (cdr argument-access))
+ (ad-list-access values-index 'ad-vAlUeS))
+ (list 'setcdr
+ (ad-list-access (1- (car argument-access))
+ (car (cdr argument-access)))
+ (ad-list-access values-index 'ad-vAlUeS)))
+ set-forms))
+ ;; terminate loop
+ (setq arglist nil))
(setq index (1+ index))
(setq values-index (1+ values-index)))
(if (null set-forms)
(error "ad-set-arguments: No argument at position %d of `%s'"
index arglist)
- (if (= (length set-forms) 1)
- ;; For exactly one set-form we can use values-form directly,...
- (ad-substitute-tree
- (function (lambda (form) (eq form 'ad-vAlUeS)))
- (function (lambda (form) values-form))
- (car set-forms))
- ;; ...if we have more we have to bind it to a variable:
- (` (let ((ad-vAlUeS (, values-form)))
- (,@ (reverse set-forms))
- ;; work around the old backquote bug:
- (, 'ad-vAlUeS)))))))
+ (if (= (length set-forms) 1)
+ ;; For exactly one set-form we can use values-form directly,...
+ (ad-substitute-tree
+ (function (lambda (form) (eq form 'ad-vAlUeS)))
+ (function (lambda (form) values-form))
+ (car set-forms))
+ ;; ...if we have more we have to bind it to a variable:
+ `(let ((ad-vAlUeS ,values-form))
+ ,@(reverse set-forms)
+ ;; work around the old backquote bug:
+ ,'ad-vAlUeS)))))
(defun ad-insert-argument-access-forms (definition arglist)
"Expands arg-access text macros in DEFINITION according to ARGLIST."
(capitalize (symbol-name class))
(ad-advice-name advice)))))))
+(require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage.
+
(defun ad-make-advised-docstring (function &optional style)
- ;;"Constructs a documentation string for the advised FUNCTION.
- ;;It concatenates the original documentation with the documentation
- ;;strings of the individual pieces of advice which will be formatted
- ;;according to STYLE. STYLE can be `plain' or `freeze', everything else
- ;;will be interpreted as `default'. The order of the advice documentation
- ;;strings corresponds to before/around/after and the individual ordering
- ;;in any of these classes."
+ "Construct a documentation string for the advised FUNCTION.
+It concatenates the original documentation with the documentation
+strings of the individual pieces of advice which will be formatted
+according to STYLE. STYLE can be `plain' or `freeze', everything else
+will be interpreted as `default'. The order of the advice documentation
+strings corresponds to before/around/after and the individual ordering
+in any of these classes."
(let* ((origdef (ad-real-orig-definition function))
(origtype (symbol-name (ad-definition-type origdef)))
(origdoc
;; Retrieve raw doc, key substitution will be taken care of later:
(ad-real-documentation origdef t))
- paragraphs advice-docstring)
+ (usage (help-split-fundoc origdoc function))
+ paragraphs advice-docstring ad-usage)
+ (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage)))
(if origdoc (setq paragraphs (list origdoc)))
- (if (not (eq style 'plain))
- (setq paragraphs (cons (concat "This " origtype " is advised.")
- paragraphs)))
+ (unless (eq style 'plain)
+ (push (concat "This " origtype " is advised.") paragraphs))
(ad-dolist (class ad-advice-classes)
(ad-dolist (advice (ad-get-enabled-advices function class))
(setq advice-docstring
(ad-make-single-advice-docstring advice class style))
(if advice-docstring
- (setq paragraphs (cons advice-docstring paragraphs)))))
- (if paragraphs
- ;; separate paragraphs with blank lines:
- (mapconcat 'identity (nreverse paragraphs) "\n\n"))))
+ (push advice-docstring paragraphs))))
+ (setq origdoc (if paragraphs
+ ;; separate paragraphs with blank lines:
+ (mapconcat 'identity (nreverse paragraphs) "\n\n")))
+ (help-add-fundoc-usage origdoc usage)))
(defun ad-make-plain-docstring (function)
(ad-make-advised-docstring function 'plain))
(interactive-form
(cond (orig-macro-p nil)
(advised-interactive-form)
- ((ad-interactive-form origdef))
+ ((ad-interactive-form origdef)
+ (if (and (symbolp function) (get function 'elp-info))
+ (interactive-form (aref (get function 'elp-info) 2))
+ (ad-interactive-form origdef)))
;; Otherwise we must have a subr: make it interactive if
;; we have to and initialize required arguments in case
;; it is called interactively:
(orig-interactive-p
- (let ((reqargs (car (ad-parse-arglist advised-arglist))))
- (if reqargs
- (` (interactive
- '(, (make-list (length reqargs) nil))))
- '(interactive))))))
+ (interactive-form origdef))))
(orig-form
(cond ((or orig-special-form-p orig-macro-p)
;; Special forms and macros will be advised into macros.
;; expansion time and return the result. The moral of that
;; is that one should always deactivate advised special
;; forms before one byte-compiles a file.
- (` ((, (if orig-macro-p
- 'macroexpand
- 'eval))
- (cons '(, origname)
- (, (ad-get-arguments advised-arglist 0))))))
+ `(,(if orig-macro-p 'macroexpand 'eval)
+ (cons ',origname
+ ,(ad-get-arguments advised-arglist 0))))
((and orig-subr-p
orig-interactive-p
+ (not interactive-form)
(not advised-interactive-form))
;; Check whether we were called interactively
;; in order to do proper prompting:
- (` (if (interactive-p)
- (call-interactively '(, origname))
- (, (ad-make-mapped-call
- orig-arglist advised-arglist origname)))))
+ `(if (interactive-p)
+ (call-interactively ',origname)
+ ,(ad-make-mapped-call orig-arglist
+ advised-arglist
+ origname)))
;; And now for normal functions and non-interactive subrs
;; (or subrs whose interactive behavior was advised):
(t (ad-make-mapped-call
(ad-get-enabled-advices function 'after)))))
(defun ad-assemble-advised-definition
- (type args docstring interactive orig &optional befores arounds afters)
+ (type args docstring interactive orig &optional befores arounds afters)
"Assembles an original and its advices into an advised function.
It constructs a function or macro definition according to TYPE which has to
(let (before-forms around-form around-form-protected after-forms definition)
(ad-dolist (advice befores)
- (cond ((and (ad-advice-protected advice)
- before-forms)
- (setq before-forms
- (` ((unwind-protect
- (, (ad-prognify before-forms))
- (,@ (ad-body-forms
- (ad-advice-definition advice))))))))
- (t (setq before-forms
- (append before-forms
- (ad-body-forms (ad-advice-definition advice)))))))
-
- (setq around-form (` (setq ad-return-value (, orig))))
+ (cond ((and (ad-advice-protected advice)
+ before-forms)
+ (setq before-forms
+ `((unwind-protect
+ ,(ad-prognify before-forms)
+ ,@(ad-body-forms
+ (ad-advice-definition advice))))))
+ (t (setq before-forms
+ (append before-forms
+ (ad-body-forms (ad-advice-definition advice)))))))
+
+ (setq around-form `(setq ad-return-value ,orig))
(ad-dolist (advice (reverse arounds))
- ;; If any of the around advices is protected then we
- ;; protect the complete around advice onion:
- (if (ad-advice-protected advice)
- (setq around-form-protected t))
- (setq around-form
- (ad-substitute-tree
- (function (lambda (form) (eq form 'ad-do-it)))
- (function (lambda (form) around-form))
- (ad-prognify (ad-body-forms (ad-advice-definition advice))))))
+ ;; If any of the around advices is protected then we
+ ;; protect the complete around advice onion:
+ (if (ad-advice-protected advice)
+ (setq around-form-protected t))
+ (setq around-form
+ (ad-substitute-tree
+ (function (lambda (form) (eq form 'ad-do-it)))
+ (function (lambda (form) around-form))
+ (ad-prognify (ad-body-forms (ad-advice-definition advice))))))
(setq after-forms
(if (and around-form-protected before-forms)
- (` ((unwind-protect
- (, (ad-prognify before-forms))
- (, around-form))))
- (append before-forms (list around-form))))
+ `((unwind-protect
+ ,(ad-prognify before-forms)
+ ,around-form))
+ (append before-forms (list around-form))))
(ad-dolist (advice afters)
- (cond ((and (ad-advice-protected advice)
- after-forms)
- (setq after-forms
- (` ((unwind-protect
- (, (ad-prognify after-forms))
- (,@ (ad-body-forms
- (ad-advice-definition advice))))))))
- (t (setq after-forms
- (append after-forms
- (ad-body-forms (ad-advice-definition advice)))))))
+ (cond ((and (ad-advice-protected advice)
+ after-forms)
+ (setq after-forms
+ `((unwind-protect
+ ,(ad-prognify after-forms)
+ ,@(ad-body-forms
+ (ad-advice-definition advice))))))
+ (t (setq after-forms
+ (append after-forms
+ (ad-body-forms (ad-advice-definition advice)))))))
(setq definition
- (` ((,@ (if (memq type '(macro special-form)) '(macro)))
- lambda
- (, args)
- (,@ (if docstring (list docstring)))
- (,@ (if interactive (list interactive)))
- (let (ad-return-value)
- (,@ after-forms)
- (, (if (eq type 'special-form)
- '(list 'quote ad-return-value)
- 'ad-return-value))))))
+ `(,@(if (memq type '(macro special-form)) '(macro))
+ lambda
+ ,args
+ ,@(if docstring (list docstring))
+ ,@(if interactive (list interactive))
+ (let (ad-return-value)
+ ,@after-forms
+ ,(if (eq type 'special-form)
+ '(list 'quote ad-return-value)
+ 'ad-return-value))))
(ad-insert-argument-access-forms definition args)))
;; a lot cheaper than reconstructing an advised definition.
(defmacro ad-get-cache-definition (function)
- (` (car (ad-get-advice-info-field (, function) 'cache))))
+ `(car (ad-get-advice-info-field ,function 'cache)))
(defmacro ad-get-cache-id (function)
- (` (cdr (ad-get-advice-info-field (, function) 'cache))))
+ `(cdr (ad-get-advice-info-field ,function 'cache)))
(defmacro ad-set-cache (function definition id)
- (` (ad-set-advice-info-field
- (, function) 'cache (cons (, definition) (, id)))))
+ `(ad-set-advice-info-field
+ ,function 'cache (cons ,definition ,id)))
(defun ad-clear-cache (function)
"Clears a previously cached advised definition of FUNCTION.
(symbol-function 'ad-make-origname))
(frozen-definition
(unwind-protect
- (progn
- ;; Make sure we construct a proper docstring:
- (ad-safe-fset 'ad-make-advised-definition-docstring
- 'ad-make-freeze-docstring)
- ;; Make sure `unique-origname' is used as the origname:
- (ad-safe-fset 'ad-make-origname '(lambda (x) unique-origname))
- ;; No we reset all current advice information to nil and
- ;; generate an advised definition that's solely determined
- ;; by ADVICE and the current origdef of FUNCTION:
- (ad-set-advice-info function nil)
- (ad-add-advice function advice class position)
- ;; The following will provide proper real docstrings as
- ;; well as a definition that will make the compiler happy:
- (ad-set-orig-definition function orig-definition)
- (ad-make-advised-definition function))
+ (progn
+ ;; Make sure we construct a proper docstring:
+ (ad-safe-fset 'ad-make-advised-definition-docstring
+ 'ad-make-freeze-docstring)
+ ;; Make sure `unique-origname' is used as the origname:
+ (ad-safe-fset 'ad-make-origname (lambda (x) unique-origname))
+ ;; No we reset all current advice information to nil and
+ ;; generate an advised definition that's solely determined
+ ;; by ADVICE and the current origdef of FUNCTION:
+ (ad-set-advice-info function nil)
+ (ad-add-advice function advice class position)
+ ;; The following will provide proper real docstrings as
+ ;; well as a definition that will make the compiler happy:
+ (ad-set-orig-definition function orig-definition)
+ (ad-make-advised-definition function))
;; Restore the old advice state:
(ad-set-advice-info function old-advice-info)
;; Restore functions:
(let* ((macro-p (ad-macro-p frozen-definition))
(body (cdr (if macro-p
(ad-lambdafy frozen-definition)
- frozen-definition))))
- (` (progn
- (if (not (fboundp '(, unique-origname)))
- (fset '(, unique-origname)
- ;; avoid infinite recursion in case the function
- ;; we want to freeze is already advised:
- (or (ad-get-orig-definition '(, function))
- (symbol-function '(, function)))))
- ((, (if macro-p 'defmacro 'defun))
- (, function)
- (,@ body))))))))
+ frozen-definition))))
+ `(progn
+ (if (not (fboundp ',unique-origname))
+ (fset ',unique-origname
+ ;; avoid infinite recursion in case the function
+ ;; we want to freeze is already advised:
+ (or (ad-get-orig-definition ',function)
+ (symbol-function ',function))))
+ (,(if macro-p 'defmacro 'defun)
+ ,function
+ ,@body))))))
;; @@ Activation and definition handling:
(defun ad-recover (function)
"Try to recover FUNCTION's original definition, and unadvise it.
This is more low-level than `ad-unadvise' in that it does not do
-deactivation, which might run hooks and get into other trouble."
+deactivation, which might run hooks and get into other trouble.
Use in emergencies."
;; Use more primitive interactive behavior here: Accept any symbol that's
;; currently defined in obarray, not necessarily with a function definition:
(let* ((class (car args))
(name (if (not (ad-class-p class))
(error "defadvice: Invalid advice class: %s" class)
- (nth 1 args)))
+ (nth 1 args)))
(position (if (not (ad-name-p name))
(error "defadvice: Invalid advice name: %s" name)
- (setq args (nthcdr 2 args))
- (if (ad-position-p (car args))
- (prog1 (car args)
- (setq args (cdr args))))))
+ (setq args (nthcdr 2 args))
+ (if (ad-position-p (car args))
+ (prog1 (car args)
+ (setq args (cdr args))))))
(arglist (if (listp (car args))
(prog1 (car args)
(setq args (cdr args)))))
(mapcar
(function
(lambda (flag)
- (let ((completion
- (try-completion (symbol-name flag) ad-defadvice-flags)))
- (cond ((eq completion t) flag)
- ((assoc completion ad-defadvice-flags)
- (intern completion))
- (t (error "defadvice: Invalid or ambiguous flag: %s"
- flag))))))
+ (let ((completion
+ (try-completion (symbol-name flag) ad-defadvice-flags)))
+ (cond ((eq completion t) flag)
+ ((assoc completion ad-defadvice-flags)
+ (intern completion))
+ (t (error "defadvice: Invalid or ambiguous flag: %s"
+ flag))))))
args))
(advice (ad-make-advice
name (memq 'protect flags)
(not (memq 'disable flags))
- (` (advice lambda (, arglist) (,@ body)))))
+ `(advice lambda ,arglist ,@body)))
(preactivation (if (memq 'preactivate flags)
(ad-preactivate-advice
function advice class position))))
;; jwz's idea: Freeze the advised definition into a dumpable
;; defun/defmacro whose docs can be written to the DOC file:
(ad-make-freeze-definition function advice class position)
- ;; the normal case:
- (` (progn
- (ad-add-advice '(, function) '(, advice) '(, class) '(, position))
- (,@ (if preactivation
- (` ((ad-set-cache
- '(, function)
- ;; the function will get compiled:
- (, (cond ((ad-macro-p (car preactivation))
- (` (ad-macrofy
- (function
- (, (ad-lambdafy
- (car preactivation)))))))
- (t (` (function
- (, (car preactivation)))))))
- '(, (car (cdr preactivation))))))))
- (,@ (if (memq 'activate flags)
- (` ((ad-activate '(, function)
- (, (if (memq 'compile flags) t)))))))
- '(, function))))))
+ ;; the normal case:
+ `(progn
+ (ad-add-advice ',function ',advice ',class ',position)
+ ,@(if preactivation
+ `((ad-set-cache
+ ',function
+ ;; the function will get compiled:
+ ,(cond ((ad-macro-p (car preactivation))
+ `(ad-macrofy
+ (function
+ ,(ad-lambdafy
+ (car preactivation)))))
+ (t `(function
+ ,(car preactivation))))
+ ',(car (cdr preactivation)))))
+ ,@(if (memq 'activate flags)
+ `((ad-activate ',function
+ ,(if (memq 'compile flags) t))))
+ ',function))))
;; @@ Tools:
(current-bindings
(mapcar (function
(lambda (function)
- (setq index (1+ index))
- (list (intern (format "ad-oRiGdEf-%d" index))
- (` (symbol-function '(, function))))))
+ (setq index (1+ index))
+ (list (intern (format "ad-oRiGdEf-%d" index))
+ `(symbol-function ',function))))
functions)))
- (` (let (, current-bindings)
- (unwind-protect
- (progn
- (,@ (progn
- ;; Make forms to redefine functions to their
- ;; original definitions if they are advised:
- (setq index -1)
- (mapcar
- (function
- (lambda (function)
- (setq index (1+ index))
- (` (ad-safe-fset
- '(, function)
- (or (ad-get-orig-definition '(, function))
- (, (car (nth index current-bindings))))))))
- functions)))
- (,@ body))
- (,@ (progn
- ;; Make forms to back-define functions to the definitions
- ;; they had outside this macro call:
- (setq index -1)
- (mapcar
- (function
- (lambda (function)
- (setq index (1+ index))
- (` (ad-safe-fset
- '(, function)
- (, (car (nth index current-bindings)))))))
- functions))))))))
+ `(let ,current-bindings
+ (unwind-protect
+ (progn
+ ,@(progn
+ ;; Make forms to redefine functions to their
+ ;; original definitions if they are advised:
+ (setq index -1)
+ (mapcar
+ (function
+ (lambda (function)
+ (setq index (1+ index))
+ `(ad-safe-fset
+ ',function
+ (or (ad-get-orig-definition ',function)
+ ,(car (nth index current-bindings))))))
+ functions))
+ ,@body)
+ ,@(progn
+ ;; Make forms to back-define functions to the definitions
+ ;; they had outside this macro call:
+ (setq index -1)
+ (mapcar
+ (function
+ (lambda (function)
+ (setq index (1+ index))
+ `(ad-safe-fset
+ ',function
+ ,(car (nth index current-bindings)))))
+ functions))))))
(if (not (get 'ad-with-originals 'lisp-indent-hook))
(put 'ad-with-originals 'lisp-indent-hook 1))
;; Use the advice mechanism to advise `documentation' to make it
;; generate proper documentation strings for advised definitions:
+;; This makes sure we get the right arglist for `documentation'
+;; during bootstrapping.
+(ad-define-subr-args 'documentation '(function &optional raw))
+
(defadvice documentation (after ad-advised-docstring first disable preact)
"Builds an advised docstring if FUNCTION is advised."
;; Because we get the function name from the advised docstring
(provide 'advice)
+;;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0
;;; advice.el ends here