149 |
;; generates an advised definition of the `documentation' function, and |
;; generates an advised definition of the `documentation' function, and |
150 |
;; it will enable automatic advice activation when functions get defined. |
;; it will enable automatic advice activation when functions get defined. |
151 |
;; All of this can be undone at any time with `M-x ad-stop-advice'. |
;; All of this can be undone at any time with `M-x ad-stop-advice'. |
152 |
;; |
;; |
153 |
;; If you experience any strange behavior/errors etc. that you attribute to |
;; If you experience any strange behavior/errors etc. that you attribute to |
154 |
;; Advice or to some ill-advised function do one of the following: |
;; Advice or to some ill-advised function do one of the following: |
155 |
|
|
368 |
;; If this is a problem one can always specify an interactive form in a |
;; If this is a problem one can always specify an interactive form in a |
369 |
;; before/around/after advice to gain control over argument values that |
;; before/around/after advice to gain control over argument values that |
370 |
;; were supplied interactively. |
;; were supplied interactively. |
371 |
;; |
;; |
372 |
;; Then the body forms of the various advices in the various classes of advice |
;; Then the body forms of the various advices in the various classes of advice |
373 |
;; are assembled in order. The forms of around advice L are normally part of |
;; are assembled in order. The forms of around advice L are normally part of |
374 |
;; one of the forms of around advice L-1. An around advice can specify where |
;; one of the forms of around advice L-1. An around advice can specify where |
381 |
;; whose form depends on the type of the original function. The variable |
;; whose form depends on the type of the original function. The variable |
382 |
;; `ad-return-value' will be set to its result. This variable is visible to |
;; `ad-return-value' will be set to its result. This variable is visible to |
383 |
;; all pieces of advice which can access and modify it before it gets returned. |
;; all pieces of advice which can access and modify it before it gets returned. |
384 |
;; |
;; |
385 |
;; The semantic structure of advised functions that contain protected pieces |
;; The semantic structure of advised functions that contain protected pieces |
386 |
;; of advice is the same. The only difference is that `unwind-protect' forms |
;; of advice is the same. The only difference is that `unwind-protect' forms |
387 |
;; make sure that the protected advice gets executed even if some previous |
;; make sure that the protected advice gets executed even if some previous |
943 |
;; |
;; |
944 |
;; We start by defining an innocent looking function `foo' that simply |
;; We start by defining an innocent looking function `foo' that simply |
945 |
;; adds 1 to its argument X: |
;; adds 1 to its argument X: |
946 |
;; |
;; |
947 |
;; (defun foo (x) |
;; (defun foo (x) |
948 |
;; "Add 1 to X." |
;; "Add 1 to X." |
949 |
;; (1+ x)) |
;; (1+ x)) |
1905 |
be returned at the end of the iteration, nil otherwise. The iteration can be |
be returned at the end of the iteration, nil otherwise. The iteration can be |
1906 |
exited prematurely with `(ad-do-return [VALUE])'." |
exited prematurely with `(ad-do-return [VALUE])'." |
1907 |
(let ((expansion |
(let ((expansion |
1908 |
(` (let ((ad-dO-vAr (, (car (cdr varform)))) |
`(let ((ad-dO-vAr ,(car (cdr varform))) |
1909 |
(, (car varform))) |
,(car varform)) |
1910 |
(while ad-dO-vAr |
(while ad-dO-vAr |
1911 |
(setq (, (car varform)) (car ad-dO-vAr)) |
(setq ,(car varform) (car ad-dO-vAr)) |
1912 |
(,@ body) |
,@body |
1913 |
;;work around a backquote bug: |
;;work around a backquote bug: |
1914 |
;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong |
;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong |
1915 |
;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar))) |
;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar))) |
1916 |
(, '(setq ad-dO-vAr (cdr ad-dO-vAr)))) |
,'(setq ad-dO-vAr (cdr ad-dO-vAr))) |
1917 |
(, (car (cdr (cdr varform)))))))) |
,(car (cdr (cdr varform)))))) |
1918 |
;;ok, this wastes some cons cells but only during compilation: |
;;ok, this wastes some cons cells but only during compilation: |
1919 |
(if (catch 'contains-return |
(if (catch 'contains-return |
1920 |
(ad-substitute-tree |
(ad-substitute-tree |
1921 |
(function (lambda (subtree) |
(function (lambda (subtree) |
1922 |
(cond ((eq (car-safe subtree) 'ad-dolist)) |
(cond ((eq (car-safe subtree) 'ad-dolist)) |
1923 |
((eq (car-safe subtree) 'ad-do-return) |
((eq (car-safe subtree) 'ad-do-return) |
1924 |
(throw 'contains-return t))))) |
(throw 'contains-return t))))) |
1925 |
'identity body) |
'identity body) |
1926 |
nil) |
nil) |
1927 |
(` (catch 'ad-dO-eXiT (, expansion))) |
`(catch 'ad-dO-eXiT ,expansion) |
1928 |
expansion))) |
expansion))) |
1929 |
|
|
1930 |
(defmacro ad-do-return (value) |
(defmacro ad-do-return (value) |
1931 |
(` (throw 'ad-dO-eXiT (, value)))) |
`(throw 'ad-dO-eXiT ,value)) |
1932 |
|
|
1933 |
(if (not (get 'ad-dolist 'lisp-indent-hook)) |
(if (not (get 'ad-dolist 'lisp-indent-hook)) |
1934 |
(put 'ad-dolist 'lisp-indent-hook 1)) |
(put 'ad-dolist 'lisp-indent-hook 1)) |
1944 |
(let ((saved-function (intern (format "ad-real-%s" function)))) |
(let ((saved-function (intern (format "ad-real-%s" function)))) |
1945 |
;; Make sure the compiler is loaded during macro expansion: |
;; Make sure the compiler is loaded during macro expansion: |
1946 |
(require 'byte-compile "bytecomp") |
(require 'byte-compile "bytecomp") |
1947 |
(` (if (not (fboundp '(, saved-function))) |
`(if (not (fboundp ',saved-function)) |
1948 |
(progn (fset '(, saved-function) (symbol-function '(, function))) |
(progn (fset ',saved-function (symbol-function ',function)) |
1949 |
;; Copy byte-compiler properties: |
;; Copy byte-compiler properties: |
1950 |
(,@ (if (get function 'byte-compile) |
,@(if (get function 'byte-compile) |
1951 |
(` ((put '(, saved-function) 'byte-compile |
`((put ',saved-function 'byte-compile |
1952 |
'(, (get function 'byte-compile))))))) |
',(get function 'byte-compile)))) |
1953 |
(,@ (if (get function 'byte-opcode) |
,@(if (get function 'byte-opcode) |
1954 |
(` ((put '(, saved-function) 'byte-opcode |
`((put ',saved-function 'byte-opcode |
1955 |
'(, (get function 'byte-opcode)))))))))))) |
',(get function 'byte-opcode)))))))) |
1956 |
|
|
1957 |
(defun ad-save-real-definitions () |
(defun ad-save-real-definitions () |
1958 |
;; Macro expansion will hardcode the values of the various byte-compiler |
;; Macro expansion will hardcode the values of the various byte-compiler |
1986 |
|
|
1987 |
(defmacro ad-pushnew-advised-function (function) |
(defmacro ad-pushnew-advised-function (function) |
1988 |
"Add FUNCTION to `ad-advised-functions' unless its already there." |
"Add FUNCTION to `ad-advised-functions' unless its already there." |
1989 |
(` (if (not (assoc (symbol-name (, function)) ad-advised-functions)) |
`(if (not (assoc (symbol-name ,function) ad-advised-functions)) |
1990 |
(setq ad-advised-functions |
(setq ad-advised-functions |
1991 |
(cons (list (symbol-name (, function))) |
(cons (list (symbol-name ,function)) |
1992 |
ad-advised-functions))))) |
ad-advised-functions)))) |
1993 |
|
|
1994 |
(defmacro ad-pop-advised-function (function) |
(defmacro ad-pop-advised-function (function) |
1995 |
"Remove FUNCTION from `ad-advised-functions'." |
"Remove FUNCTION from `ad-advised-functions'." |
1996 |
(` (setq ad-advised-functions |
`(setq ad-advised-functions |
1997 |
(delq (assoc (symbol-name (, function)) ad-advised-functions) |
(delq (assoc (symbol-name ,function) ad-advised-functions) |
1998 |
ad-advised-functions)))) |
ad-advised-functions))) |
1999 |
|
|
2000 |
(defmacro ad-do-advised-functions (varform &rest body) |
(defmacro ad-do-advised-functions (varform &rest body) |
2001 |
"`ad-dolist'-style iterator that maps over `ad-advised-functions'. |
"`ad-dolist'-style iterator that maps over `ad-advised-functions'. |
2003 |
BODY-FORM...) |
BODY-FORM...) |
2004 |
On each iteration VAR will be bound to the name of an advised function |
On each iteration VAR will be bound to the name of an advised function |
2005 |
\(a symbol)." |
\(a symbol)." |
2006 |
(` (ad-dolist ((, (car varform)) |
`(ad-dolist (,(car varform) |
2007 |
ad-advised-functions |
ad-advised-functions |
2008 |
(, (car (cdr varform)))) |
,(car (cdr varform))) |
2009 |
(setq (, (car varform)) (intern (car (, (car varform))))) |
(setq ,(car varform) (intern (car ,(car varform)))) |
2010 |
(,@ body)))) |
,@body)) |
2011 |
|
|
2012 |
(if (not (get 'ad-do-advised-functions 'lisp-indent-hook)) |
(if (not (get 'ad-do-advised-functions 'lisp-indent-hook)) |
2013 |
(put 'ad-do-advised-functions 'lisp-indent-hook 1)) |
(put 'ad-do-advised-functions 'lisp-indent-hook 1)) |
2014 |
|
|
2015 |
(defmacro ad-get-advice-info (function) |
(defmacro ad-get-advice-info (function) |
2016 |
(` (get (, function) 'ad-advice-info))) |
`(get ,function 'ad-advice-info)) |
2017 |
|
|
2018 |
(defmacro ad-set-advice-info (function advice-info) |
(defmacro ad-set-advice-info (function advice-info) |
2019 |
(` (put (, function) 'ad-advice-info (, advice-info)))) |
`(put ,function 'ad-advice-info ,advice-info)) |
2020 |
|
|
2021 |
(defmacro ad-copy-advice-info (function) |
(defmacro ad-copy-advice-info (function) |
2022 |
(` (ad-copy-tree (get (, function) 'ad-advice-info)))) |
`(ad-copy-tree (get ,function 'ad-advice-info))) |
2023 |
|
|
2024 |
(defmacro ad-is-advised (function) |
(defmacro ad-is-advised (function) |
2025 |
"Return non-nil if FUNCTION has any advice info associated with it. |
"Return non-nil if FUNCTION has any advice info associated with it. |
2034 |
|
|
2035 |
(defmacro ad-get-advice-info-field (function field) |
(defmacro ad-get-advice-info-field (function field) |
2036 |
"Retrieve the value of the advice info FIELD of FUNCTION." |
"Retrieve the value of the advice info FIELD of FUNCTION." |
2037 |
(` (cdr (assq (, field) (ad-get-advice-info (, function)))))) |
`(cdr (assq ,field (ad-get-advice-info ,function)))) |
2038 |
|
|
2039 |
(defun ad-set-advice-info-field (function field value) |
(defun ad-set-advice-info-field (function field value) |
2040 |
"Destructively modify VALUE of the advice info FIELD of FUNCTION." |
"Destructively modify VALUE of the advice info FIELD of FUNCTION." |
2160 |
(defvar ad-activate-on-top-level t) |
(defvar ad-activate-on-top-level t) |
2161 |
|
|
2162 |
(defmacro ad-with-auto-activation-disabled (&rest body) |
(defmacro ad-with-auto-activation-disabled (&rest body) |
2163 |
(` (let ((ad-activate-on-top-level nil)) |
`(let ((ad-activate-on-top-level nil)) |
2164 |
(,@ body)))) |
,@body)) |
2165 |
|
|
2166 |
(defun ad-safe-fset (symbol definition) |
(defun ad-safe-fset (symbol definition) |
2167 |
"A safe `fset' which will never call `ad-activate-internal' recursively." |
"A safe `fset' which will never call `ad-activate-internal' recursively." |
2183 |
(intern (format "ad-Orig-%s" function))) |
(intern (format "ad-Orig-%s" function))) |
2184 |
|
|
2185 |
(defmacro ad-get-orig-definition (function) |
(defmacro ad-get-orig-definition (function) |
2186 |
(` (let ((origname (ad-get-advice-info-field (, function) 'origname))) |
`(let ((origname (ad-get-advice-info-field ,function 'origname))) |
2187 |
(if (fboundp origname) |
(if (fboundp origname) |
2188 |
(symbol-function origname))))) |
(symbol-function origname)))) |
2189 |
|
|
2190 |
(defmacro ad-set-orig-definition (function definition) |
(defmacro ad-set-orig-definition (function definition) |
2191 |
(` (ad-safe-fset |
`(ad-safe-fset |
2192 |
(ad-get-advice-info-field function 'origname) (, definition)))) |
(ad-get-advice-info-field function 'origname) ,definition)) |
2193 |
|
|
2194 |
(defmacro ad-clear-orig-definition (function) |
(defmacro ad-clear-orig-definition (function) |
2195 |
(` (fmakunbound (ad-get-advice-info-field (, function) 'origname)))) |
`(fmakunbound (ad-get-advice-info-field ,function 'origname))) |
2196 |
|
|
2197 |
|
|
2198 |
;; @@ Interactive input functions: |
;; @@ Interactive input functions: |
2300 |
|
|
2301 |
(defmacro ad-find-advice (function class name) |
(defmacro ad-find-advice (function class name) |
2302 |
"Find the first advice of FUNCTION in CLASS with NAME." |
"Find the first advice of FUNCTION in CLASS with NAME." |
2303 |
(` (assq (, name) (ad-get-advice-info-field (, function) (, class))))) |
`(assq ,name (ad-get-advice-info-field ,function ,class))) |
2304 |
|
|
2305 |
(defun ad-advice-position (function class name) |
(defun ad-advice-position (function class name) |
2306 |
"Return position of first advice of FUNCTION in CLASS with NAME." |
"Return position of first advice of FUNCTION in CLASS with NAME." |
2458 |
|
|
2459 |
(defmacro ad-macrofy (definition) |
(defmacro ad-macrofy (definition) |
2460 |
"Take a lambda function DEFINITION and make a macro out of it." |
"Take a lambda function DEFINITION and make a macro out of it." |
2461 |
(` (cons 'macro (, definition)))) |
`(cons 'macro ,definition)) |
2462 |
|
|
2463 |
(defmacro ad-lambdafy (definition) |
(defmacro ad-lambdafy (definition) |
2464 |
"Take a macro function DEFINITION and make a lambda out of it." |
"Take a macro function DEFINITION and make a lambda out of it." |
2465 |
(` (cdr (, definition)))) |
`(cdr ,definition)) |
2466 |
|
|
2467 |
;; There is no way to determine whether some subr is a special form or not, |
;; There is no way to determine whether some subr is a special form or not, |
2468 |
;; hence we need this list (which is probably out of date): |
;; hence we need this list (which is probably out of date): |
2492 |
|
|
2493 |
(defmacro ad-macro-p (definition) |
(defmacro ad-macro-p (definition) |
2494 |
;;"non-nil if DEFINITION is a macro." |
;;"non-nil if DEFINITION is a macro." |
2495 |
(` (eq (car-safe (, definition)) 'macro))) |
`(eq (car-safe ,definition) 'macro)) |
2496 |
|
|
2497 |
(defmacro ad-lambda-p (definition) |
(defmacro ad-lambda-p (definition) |
2498 |
;;"non-nil if DEFINITION is a lambda expression." |
;;"non-nil if DEFINITION is a lambda expression." |
2499 |
(` (eq (car-safe (, definition)) 'lambda))) |
`(eq (car-safe ,definition) 'lambda)) |
2500 |
|
|
2501 |
;; see ad-make-advice for the format of advice definitions: |
;; see ad-make-advice for the format of advice definitions: |
2502 |
(defmacro ad-advice-p (definition) |
(defmacro ad-advice-p (definition) |
2503 |
;;"non-nil if DEFINITION is a piece of advice." |
;;"non-nil if DEFINITION is a piece of advice." |
2504 |
(` (eq (car-safe (, definition)) 'advice))) |
`(eq (car-safe ,definition) 'advice)) |
2505 |
|
|
2506 |
;; Emacs/Lemacs cross-compatibility |
;; Emacs/Lemacs cross-compatibility |
2507 |
;; (compiled-function-p is an obsolete function in Emacs): |
;; (compiled-function-p is an obsolete function in Emacs): |
2511 |
|
|
2512 |
(defmacro ad-compiled-p (definition) |
(defmacro ad-compiled-p (definition) |
2513 |
"Return non-nil if DEFINITION is a compiled byte-code object." |
"Return non-nil if DEFINITION is a compiled byte-code object." |
2514 |
(` (or (byte-code-function-p (, definition)) |
`(or (byte-code-function-p ,definition) |
2515 |
(and (ad-macro-p (, definition)) |
(and (ad-macro-p ,definition) |
2516 |
(byte-code-function-p (ad-lambdafy (, definition))))))) |
(byte-code-function-p (ad-lambdafy ,definition))))) |
2517 |
|
|
2518 |
(defmacro ad-compiled-code (compiled-definition) |
(defmacro ad-compiled-code (compiled-definition) |
2519 |
"Return the byte-code object of a COMPILED-DEFINITION." |
"Return the byte-code object of a COMPILED-DEFINITION." |
2520 |
(` (if (ad-macro-p (, compiled-definition)) |
`(if (ad-macro-p ,compiled-definition) |
2521 |
(ad-lambdafy (, compiled-definition)) |
(ad-lambdafy ,compiled-definition) |
2522 |
(, compiled-definition)))) |
,compiled-definition)) |
2523 |
|
|
2524 |
(defun ad-lambda-expression (definition) |
(defun ad-lambda-expression (definition) |
2525 |
"Return the lambda expression of a function/macro/advice DEFINITION." |
"Return the lambda expression of a function/macro/advice DEFINITION." |
2551 |
;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish |
;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish |
2552 |
;; a defined empty arglist `(nil)' from an undefined arglist: |
;; a defined empty arglist `(nil)' from an undefined arglist: |
2553 |
(defmacro ad-define-subr-args (subr arglist) |
(defmacro ad-define-subr-args (subr arglist) |
2554 |
(` (put (, subr) 'ad-subr-arglist (list (, arglist))))) |
`(put ,subr 'ad-subr-arglist (list ,arglist))) |
2555 |
(defmacro ad-undefine-subr-args (subr) |
(defmacro ad-undefine-subr-args (subr) |
2556 |
(` (put (, subr) 'ad-subr-arglist nil))) |
`(put ,subr 'ad-subr-arglist nil)) |
2557 |
(defmacro ad-subr-args-defined-p (subr) |
(defmacro ad-subr-args-defined-p (subr) |
2558 |
(` (get (, subr) 'ad-subr-arglist))) |
`(get ,subr 'ad-subr-arglist)) |
2559 |
(defmacro ad-get-subr-args (subr) |
(defmacro ad-get-subr-args (subr) |
2560 |
(` (car (get (, subr) 'ad-subr-arglist)))) |
`(car (get ,subr 'ad-subr-arglist))) |
2561 |
|
|
2562 |
(defun ad-subr-arglist (subr-name) |
(defun ad-subr-arglist (subr-name) |
2563 |
"Retrieve arglist of the subr with SUBR-NAME. |
"Retrieve arglist of the subr with SUBR-NAME. |
2761 |
`required', `optional' or `rest' depending on the type of the argument." |
`required', `optional' or `rest' depending on the type of the argument." |
2762 |
(let* ((parsed-arglist (ad-parse-arglist arglist)) |
(let* ((parsed-arglist (ad-parse-arglist arglist)) |
2763 |
(rest (nth 2 parsed-arglist))) |
(rest (nth 2 parsed-arglist))) |
2764 |
(` (list |
`(list |
2765 |
(,@ (mapcar (function |
,@(mapcar (function |
2766 |
(lambda (req) |
(lambda (req) |
2767 |
(` (list '(, req) (, req) 'required)))) |
`(list ',req ,req 'required))) |
2768 |
(nth 0 parsed-arglist))) |
(nth 0 parsed-arglist)) |
2769 |
(,@ (mapcar (function |
,@(mapcar (function |
2770 |
(lambda (opt) |
(lambda (opt) |
2771 |
(` (list '(, opt) (, opt) 'optional)))) |
`(list ',opt ,opt 'optional))) |
2772 |
(nth 1 parsed-arglist))) |
(nth 1 parsed-arglist)) |
2773 |
(,@ (if rest (list (` (list '(, rest) (, rest) 'rest))))) |
,@(if rest (list `(list ',rest ,rest 'rest)))))) |
|
)))) |
|
2774 |
|
|
2775 |
(defun ad-arg-binding-field (binding field) |
(defun ad-arg-binding-field (binding field) |
2776 |
(cond ((eq field 'name) (car binding)) |
(cond ((eq field 'name) (car binding)) |
2784 |
|
|
2785 |
(defun ad-element-access (position list) |
(defun ad-element-access (position list) |
2786 |
(cond ((= position 0) (list 'car list)) |
(cond ((= position 0) (list 'car list)) |
2787 |
((= position 1) (` (car (cdr (, list))))) |
((= position 1) `(car (cdr ,list))) |
2788 |
(t (list 'nth position list)))) |
(t (list 'nth position list)))) |
2789 |
|
|
2790 |
(defun ad-access-argument (arglist index) |
(defun ad-access-argument (arglist index) |
2813 |
(let ((argument-access (ad-access-argument arglist index))) |
(let ((argument-access (ad-access-argument arglist index))) |
2814 |
(cond ((consp argument-access) |
(cond ((consp argument-access) |
2815 |
;; should this check whether there actually is something to set? |
;; should this check whether there actually is something to set? |
2816 |
(` (setcar (, (ad-list-access |
`(setcar ,(ad-list-access |
2817 |
(car argument-access) (car (cdr argument-access)))) |
(car argument-access) (car (cdr argument-access))) |
2818 |
(, value-form)))) |
,value-form)) |
2819 |
(argument-access |
(argument-access |
2820 |
(` (setq (, argument-access) (, value-form)))) |
`(setq ,argument-access ,value-form)) |
2821 |
(t (error "ad-set-argument: No argument at position %d of `%s'" |
(t (error "ad-set-argument: No argument at position %d of `%s'" |
2822 |
index arglist))))) |
index arglist))))) |
2823 |
|
|
2829 |
(rest-arg (nth 2 parsed-arglist)) |
(rest-arg (nth 2 parsed-arglist)) |
2830 |
args-form) |
args-form) |
2831 |
(if (< index (length reqopt-args)) |
(if (< index (length reqopt-args)) |
2832 |
(setq args-form (` (list (,@ (nthcdr index reqopt-args)))))) |
(setq args-form `(list ,@(nthcdr index reqopt-args)))) |
2833 |
(if rest-arg |
(if rest-arg |
2834 |
(if args-form |
(if args-form |
2835 |
(setq args-form (` (nconc (, args-form) (, rest-arg)))) |
(setq args-form `(nconc ,args-form ,rest-arg)) |
2836 |
(setq args-form (ad-list-access (- index (length reqopt-args)) |
(setq args-form (ad-list-access (- index (length reqopt-args)) |
2837 |
rest-arg)))) |
rest-arg)))) |
2838 |
args-form)) |
args-form)) |
2839 |
|
|
2840 |
(defun ad-set-arguments (arglist index values-form) |
(defun ad-set-arguments (arglist index values-form) |
2849 |
arglist index |
arglist index |
2850 |
(ad-element-access values-index 'ad-vAlUeS)) |
(ad-element-access values-index 'ad-vAlUeS)) |
2851 |
set-forms)) |
set-forms)) |
2852 |
(setq set-forms |
(setq set-forms |
2853 |
(cons (if (= (car argument-access) 0) |
(cons (if (= (car argument-access) 0) |
2854 |
(list 'setq |
(list 'setq |
2855 |
(car (cdr argument-access)) |
(car (cdr argument-access)) |
2856 |
(ad-list-access values-index 'ad-vAlUeS)) |
(ad-list-access values-index 'ad-vAlUeS)) |
2857 |
(list 'setcdr |
(list 'setcdr |
2858 |
(ad-list-access (1- (car argument-access)) |
(ad-list-access (1- (car argument-access)) |
2859 |
(car (cdr argument-access))) |
(car (cdr argument-access))) |
2860 |
(ad-list-access values-index 'ad-vAlUeS))) |
(ad-list-access values-index 'ad-vAlUeS))) |
2861 |
set-forms)) |
set-forms)) |
2862 |
;; terminate loop |
;; terminate loop |
2863 |
(setq arglist nil)) |
(setq arglist nil)) |
2864 |
(setq index (1+ index)) |
(setq index (1+ index)) |
2865 |
(setq values-index (1+ values-index))) |
(setq values-index (1+ values-index))) |
2866 |
(if (null set-forms) |
(if (null set-forms) |
2867 |
(error "ad-set-arguments: No argument at position %d of `%s'" |
(error "ad-set-arguments: No argument at position %d of `%s'" |
2868 |
index arglist) |
index arglist) |
2869 |
(if (= (length set-forms) 1) |
(if (= (length set-forms) 1) |
2870 |
;; For exactly one set-form we can use values-form directly,... |
;; For exactly one set-form we can use values-form directly,... |
2871 |
(ad-substitute-tree |
(ad-substitute-tree |
2872 |
(function (lambda (form) (eq form 'ad-vAlUeS))) |
(function (lambda (form) (eq form 'ad-vAlUeS))) |
2873 |
(function (lambda (form) values-form)) |
(function (lambda (form) values-form)) |
2874 |
(car set-forms)) |
(car set-forms)) |
2875 |
;; ...if we have more we have to bind it to a variable: |
;; ...if we have more we have to bind it to a variable: |
2876 |
(` (let ((ad-vAlUeS (, values-form))) |
`(let ((ad-vAlUeS ,values-form)) |
2877 |
(,@ (reverse set-forms)) |
,@(reverse set-forms) |
2878 |
;; work around the old backquote bug: |
;; work around the old backquote bug: |
2879 |
(, 'ad-vAlUeS))))))) |
,'ad-vAlUeS))))) |
2880 |
|
|
2881 |
(defun ad-insert-argument-access-forms (definition arglist) |
(defun ad-insert-argument-access-forms (definition arglist) |
2882 |
"Expands arg-access text macros in DEFINITION according to ARGLIST." |
"Expands arg-access text macros in DEFINITION according to ARGLIST." |
3070 |
((ad-interactive-form origdef) |
((ad-interactive-form origdef) |
3071 |
(if (and (symbolp function) (get function 'elp-info)) |
(if (and (symbolp function) (get function 'elp-info)) |
3072 |
(interactive-form (aref (get function 'elp-info) 2)) |
(interactive-form (aref (get function 'elp-info) 2)) |
3073 |
(ad-interactive-form origdef))) |
(ad-interactive-form origdef))) |
3074 |
;; Otherwise we must have a subr: make it interactive if |
;; Otherwise we must have a subr: make it interactive if |
3075 |
;; we have to and initialize required arguments in case |
;; we have to and initialize required arguments in case |
3076 |
;; it is called interactively: |
;; it is called interactively: |
3077 |
(orig-interactive-p |
(orig-interactive-p |
3078 |
(interactive-form origdef)))) |
(interactive-form origdef)))) |
3079 |
(orig-form |
(orig-form |
3080 |
(cond ((or orig-special-form-p orig-macro-p) |
(cond ((or orig-special-form-p orig-macro-p) |
3103 |
;; in order to do proper prompting: |
;; in order to do proper prompting: |
3104 |
`(if (interactive-p) |
`(if (interactive-p) |
3105 |
(call-interactively ',origname) |
(call-interactively ',origname) |
3106 |
,(ad-make-mapped-call orig-arglist |
,(ad-make-mapped-call orig-arglist |
3107 |
advised-arglist |
advised-arglist |
3108 |
origname))) |
origname))) |
3109 |
;; And now for normal functions and non-interactive subrs |
;; And now for normal functions and non-interactive subrs |
3125 |
(ad-get-enabled-advices function 'after))))) |
(ad-get-enabled-advices function 'after))))) |
3126 |
|
|
3127 |
(defun ad-assemble-advised-definition |
(defun ad-assemble-advised-definition |
3128 |
(type args docstring interactive orig &optional befores arounds afters) |
(type args docstring interactive orig &optional befores arounds afters) |
3129 |
|
|
3130 |
"Assembles an original and its advices into an advised function. |
"Assembles an original and its advices into an advised function. |
3131 |
It constructs a function or macro definition according to TYPE which has to |
It constructs a function or macro definition according to TYPE which has to |
3138 |
|
|
3139 |
(let (before-forms around-form around-form-protected after-forms definition) |
(let (before-forms around-form around-form-protected after-forms definition) |
3140 |
(ad-dolist (advice befores) |
(ad-dolist (advice befores) |
3141 |
(cond ((and (ad-advice-protected advice) |
(cond ((and (ad-advice-protected advice) |
3142 |
before-forms) |
before-forms) |
3143 |
(setq before-forms |
(setq before-forms |
3144 |
(` ((unwind-protect |
`((unwind-protect |
3145 |
(, (ad-prognify before-forms)) |
,(ad-prognify before-forms) |
3146 |
(,@ (ad-body-forms |
,@(ad-body-forms |
3147 |
(ad-advice-definition advice)))))))) |
(ad-advice-definition advice)))))) |
3148 |
(t (setq before-forms |
(t (setq before-forms |
3149 |
(append before-forms |
(append before-forms |
3150 |
(ad-body-forms (ad-advice-definition advice))))))) |
(ad-body-forms (ad-advice-definition advice))))))) |
3151 |
|
|
3152 |
(setq around-form (` (setq ad-return-value (, orig)))) |
(setq around-form `(setq ad-return-value ,orig)) |
3153 |
(ad-dolist (advice (reverse arounds)) |
(ad-dolist (advice (reverse arounds)) |
3154 |
;; If any of the around advices is protected then we |
;; If any of the around advices is protected then we |
3155 |
;; protect the complete around advice onion: |
;; protect the complete around advice onion: |
3156 |
(if (ad-advice-protected advice) |
(if (ad-advice-protected advice) |
3157 |
(setq around-form-protected t)) |
(setq around-form-protected t)) |
3158 |
(setq around-form |
(setq around-form |
3159 |
(ad-substitute-tree |
(ad-substitute-tree |
3160 |
(function (lambda (form) (eq form 'ad-do-it))) |
(function (lambda (form) (eq form 'ad-do-it))) |
3161 |
(function (lambda (form) around-form)) |
(function (lambda (form) around-form)) |
3162 |
(ad-prognify (ad-body-forms (ad-advice-definition advice)))))) |
(ad-prognify (ad-body-forms (ad-advice-definition advice)))))) |
3163 |
|
|
3164 |
(setq after-forms |
(setq after-forms |
3165 |
(if (and around-form-protected before-forms) |
(if (and around-form-protected before-forms) |
3166 |
(` ((unwind-protect |
`((unwind-protect |
3167 |
(, (ad-prognify before-forms)) |
,(ad-prognify before-forms) |
3168 |
(, around-form)))) |
,around-form)) |
3169 |
(append before-forms (list around-form)))) |
(append before-forms (list around-form)))) |
3170 |
(ad-dolist (advice afters) |
(ad-dolist (advice afters) |
3171 |
(cond ((and (ad-advice-protected advice) |
(cond ((and (ad-advice-protected advice) |
3172 |
after-forms) |
after-forms) |
3173 |
(setq after-forms |
(setq after-forms |
3174 |
(` ((unwind-protect |
`((unwind-protect |
3175 |
(, (ad-prognify after-forms)) |
,(ad-prognify after-forms) |
3176 |
(,@ (ad-body-forms |
,@(ad-body-forms |
3177 |
(ad-advice-definition advice)))))))) |
(ad-advice-definition advice)))))) |
3178 |
(t (setq after-forms |
(t (setq after-forms |
3179 |
(append after-forms |
(append after-forms |
3180 |
(ad-body-forms (ad-advice-definition advice))))))) |
(ad-body-forms (ad-advice-definition advice))))))) |
3181 |
|
|
3182 |
(setq definition |
(setq definition |
3183 |
(` ((,@ (if (memq type '(macro special-form)) '(macro))) |
`(,@(if (memq type '(macro special-form)) '(macro)) |
3184 |
lambda |
lambda |
3185 |
(, args) |
,args |
3186 |
(,@ (if docstring (list docstring))) |
,@(if docstring (list docstring)) |
3187 |
(,@ (if interactive (list interactive))) |
,@(if interactive (list interactive)) |
3188 |
(let (ad-return-value) |
(let (ad-return-value) |
3189 |
(,@ after-forms) |
,@after-forms |
3190 |
(, (if (eq type 'special-form) |
,(if (eq type 'special-form) |
3191 |
'(list 'quote ad-return-value) |
'(list 'quote ad-return-value) |
3192 |
'ad-return-value)))))) |
'ad-return-value)))) |
3193 |
|
|
3194 |
(ad-insert-argument-access-forms definition args))) |
(ad-insert-argument-access-forms definition args))) |
3195 |
|
|
3265 |
;; a lot cheaper than reconstructing an advised definition. |
;; a lot cheaper than reconstructing an advised definition. |
3266 |
|
|
3267 |
(defmacro ad-get-cache-definition (function) |
(defmacro ad-get-cache-definition (function) |
3268 |
(` (car (ad-get-advice-info-field (, function) 'cache)))) |
`(car (ad-get-advice-info-field ,function 'cache))) |
3269 |
|
|
3270 |
(defmacro ad-get-cache-id (function) |
(defmacro ad-get-cache-id (function) |
3271 |
(` (cdr (ad-get-advice-info-field (, function) 'cache)))) |
`(cdr (ad-get-advice-info-field ,function 'cache))) |
3272 |
|
|
3273 |
(defmacro ad-set-cache (function definition id) |
(defmacro ad-set-cache (function definition id) |
3274 |
(` (ad-set-advice-info-field |
`(ad-set-advice-info-field |
3275 |
(, function) 'cache (cons (, definition) (, id))))) |
,function 'cache (cons ,definition ,id))) |
3276 |
|
|
3277 |
(defun ad-clear-cache (function) |
(defun ad-clear-cache (function) |
3278 |
"Clears a previously cached advised definition of FUNCTION. |
"Clears a previously cached advised definition of FUNCTION. |
3450 |
(symbol-function 'ad-make-origname)) |
(symbol-function 'ad-make-origname)) |
3451 |
(frozen-definition |
(frozen-definition |
3452 |
(unwind-protect |
(unwind-protect |
3453 |
(progn |
(progn |
3454 |
;; Make sure we construct a proper docstring: |
;; Make sure we construct a proper docstring: |
3455 |
(ad-safe-fset 'ad-make-advised-definition-docstring |
(ad-safe-fset 'ad-make-advised-definition-docstring |
3456 |
'ad-make-freeze-docstring) |
'ad-make-freeze-docstring) |
3457 |
;; Make sure `unique-origname' is used as the origname: |
;; Make sure `unique-origname' is used as the origname: |
3458 |
(ad-safe-fset 'ad-make-origname (lambda (x) unique-origname)) |
(ad-safe-fset 'ad-make-origname (lambda (x) unique-origname)) |
3459 |
;; No we reset all current advice information to nil and |
;; No we reset all current advice information to nil and |
3460 |
;; generate an advised definition that's solely determined |
;; generate an advised definition that's solely determined |
3461 |
;; by ADVICE and the current origdef of FUNCTION: |
;; by ADVICE and the current origdef of FUNCTION: |
3462 |
(ad-set-advice-info function nil) |
(ad-set-advice-info function nil) |
3463 |
(ad-add-advice function advice class position) |
(ad-add-advice function advice class position) |
3464 |
;; The following will provide proper real docstrings as |
;; The following will provide proper real docstrings as |
3465 |
;; well as a definition that will make the compiler happy: |
;; well as a definition that will make the compiler happy: |
3466 |
(ad-set-orig-definition function orig-definition) |
(ad-set-orig-definition function orig-definition) |
3467 |
(ad-make-advised-definition function)) |
(ad-make-advised-definition function)) |
3468 |
;; Restore the old advice state: |
;; Restore the old advice state: |
3469 |
(ad-set-advice-info function old-advice-info) |
(ad-set-advice-info function old-advice-info) |
3470 |
;; Restore functions: |
;; Restore functions: |
3475 |
(let* ((macro-p (ad-macro-p frozen-definition)) |
(let* ((macro-p (ad-macro-p frozen-definition)) |
3476 |
(body (cdr (if macro-p |
(body (cdr (if macro-p |
3477 |
(ad-lambdafy frozen-definition) |
(ad-lambdafy frozen-definition) |
3478 |
frozen-definition)))) |
frozen-definition)))) |
3479 |
(` (progn |
`(progn |
3480 |
(if (not (fboundp '(, unique-origname))) |
(if (not (fboundp ',unique-origname)) |
3481 |
(fset '(, unique-origname) |
(fset ',unique-origname |
3482 |
;; avoid infinite recursion in case the function |
;; avoid infinite recursion in case the function |
3483 |
;; we want to freeze is already advised: |
;; we want to freeze is already advised: |
3484 |
(or (ad-get-orig-definition '(, function)) |
(or (ad-get-orig-definition ',function) |
3485 |
(symbol-function '(, function))))) |
(symbol-function ',function)))) |
3486 |
((, (if macro-p 'defmacro 'defun)) |
(,(if macro-p 'defmacro 'defun) |
3487 |
(, function) |
,function |
3488 |
(,@ body)))))))) |
,@body)))))) |
3489 |
|
|
3490 |
|
|
3491 |
;; @@ Activation and definition handling: |
;; @@ Activation and definition handling: |
3811 |
(let* ((class (car args)) |
(let* ((class (car args)) |
3812 |
(name (if (not (ad-class-p class)) |
(name (if (not (ad-class-p class)) |
3813 |
(error "defadvice: Invalid advice class: %s" class) |
(error "defadvice: Invalid advice class: %s" class) |
3814 |
(nth 1 args))) |
(nth 1 args))) |
3815 |
(position (if (not (ad-name-p name)) |
(position (if (not (ad-name-p name)) |
3816 |
(error "defadvice: Invalid advice name: %s" name) |
(error "defadvice: Invalid advice name: %s" name) |
3817 |
(setq args (nthcdr 2 args)) |
(setq args (nthcdr 2 args)) |
3818 |
(if (ad-position-p (car args)) |
(if (ad-position-p (car args)) |
3819 |
(prog1 (car args) |
(prog1 (car args) |
3820 |
(setq args (cdr args)))))) |
(setq args (cdr args)))))) |
3821 |
(arglist (if (listp (car args)) |
(arglist (if (listp (car args)) |
3822 |
(prog1 (car args) |
(prog1 (car args) |
3823 |
(setq args (cdr args))))) |
(setq args (cdr args))))) |
3825 |
(mapcar |
(mapcar |
3826 |
(function |
(function |
3827 |
(lambda (flag) |
(lambda (flag) |
3828 |
(let ((completion |
(let ((completion |
3829 |
(try-completion (symbol-name flag) ad-defadvice-flags))) |
(try-completion (symbol-name flag) ad-defadvice-flags))) |
3830 |
(cond ((eq completion t) flag) |
(cond ((eq completion t) flag) |
3831 |
((assoc completion ad-defadvice-flags) |
((assoc completion ad-defadvice-flags) |
3832 |
(intern completion)) |
(intern completion)) |
3833 |
(t (error "defadvice: Invalid or ambiguous flag: %s" |
(t (error "defadvice: Invalid or ambiguous flag: %s" |
3834 |
flag)))))) |
flag)))))) |
3835 |
args)) |
args)) |
3836 |
(advice (ad-make-advice |
(advice (ad-make-advice |
3837 |
name (memq 'protect flags) |
name (memq 'protect flags) |
3838 |
(not (memq 'disable flags)) |
(not (memq 'disable flags)) |
3839 |
(` (advice lambda (, arglist) (,@ body))))) |
`(advice lambda ,arglist ,@body))) |
3840 |
(preactivation (if (memq 'preactivate flags) |
(preactivation (if (memq 'preactivate flags) |
3841 |
(ad-preactivate-advice |
(ad-preactivate-advice |
3842 |
function advice class position)))) |
function advice class position)))) |
3845 |
;; jwz's idea: Freeze the advised definition into a dumpable |
;; jwz's idea: Freeze the advised definition into a dumpable |
3846 |
;; defun/defmacro whose docs can be written to the DOC file: |
;; defun/defmacro whose docs can be written to the DOC file: |
3847 |
(ad-make-freeze-definition function advice class position) |
(ad-make-freeze-definition function advice class position) |
3848 |
;; the normal case: |
;; the normal case: |
3849 |
(` (progn |
`(progn |
3850 |
(ad-add-advice '(, function) '(, advice) '(, class) '(, position)) |
(ad-add-advice ',function ',advice ',class ',position) |
3851 |
(,@ (if preactivation |
,@(if preactivation |
3852 |
(` ((ad-set-cache |
`((ad-set-cache |
3853 |
'(, function) |
',function |
3854 |
;; the function will get compiled: |
;; the function will get compiled: |
3855 |
(, (cond ((ad-macro-p (car preactivation)) |
,(cond ((ad-macro-p (car preactivation)) |
3856 |
(` (ad-macrofy |
`(ad-macrofy |
3857 |
(function |
(function |
3858 |
(, (ad-lambdafy |
,(ad-lambdafy |
3859 |
(car preactivation))))))) |
(car preactivation))))) |
3860 |
(t (` (function |
(t `(function |
3861 |
(, (car preactivation))))))) |
,(car preactivation)))) |
3862 |
'(, (car (cdr preactivation)))))))) |
',(car (cdr preactivation))))) |
3863 |
(,@ (if (memq 'activate flags) |
,@(if (memq 'activate flags) |
3864 |
(` ((ad-activate '(, function) |
`((ad-activate ',function |
3865 |
(, (if (memq 'compile flags) t))))))) |
,(if (memq 'compile flags) t)))) |
3866 |
'(, function)))))) |
',function)))) |
3867 |
|
|
3868 |
|
|
3869 |
;; @@ Tools: |
;; @@ Tools: |
3879 |
(current-bindings |
(current-bindings |
3880 |
(mapcar (function |
(mapcar (function |
3881 |
(lambda (function) |
(lambda (function) |
3882 |
(setq index (1+ index)) |
(setq index (1+ index)) |
3883 |
(list (intern (format "ad-oRiGdEf-%d" index)) |
(list (intern (format "ad-oRiGdEf-%d" index)) |
3884 |
(` (symbol-function '(, function)))))) |
`(symbol-function ',function)))) |
3885 |
functions))) |
functions))) |
3886 |
(` (let (, current-bindings) |
`(let ,current-bindings |
3887 |
(unwind-protect |
(unwind-protect |
3888 |
(progn |
(progn |
3889 |
(,@ (progn |
,@(progn |
3890 |
;; Make forms to redefine functions to their |
;; Make forms to redefine functions to their |
3891 |
;; original definitions if they are advised: |
;; original definitions if they are advised: |
3892 |
(setq index -1) |
(setq index -1) |
3893 |
(mapcar |
(mapcar |
3894 |
(function |
(function |
3895 |
(lambda (function) |
(lambda (function) |
3896 |
(setq index (1+ index)) |
(setq index (1+ index)) |
3897 |
(` (ad-safe-fset |
`(ad-safe-fset |
3898 |
'(, function) |
',function |
3899 |
(or (ad-get-orig-definition '(, function)) |
(or (ad-get-orig-definition ',function) |
3900 |
(, (car (nth index current-bindings)))))))) |
,(car (nth index current-bindings)))))) |
3901 |
functions))) |
functions)) |
3902 |
(,@ body)) |
,@body) |
3903 |
(,@ (progn |
,@(progn |
3904 |
;; Make forms to back-define functions to the definitions |
;; Make forms to back-define functions to the definitions |
3905 |
;; they had outside this macro call: |
;; they had outside this macro call: |
3906 |
(setq index -1) |
(setq index -1) |
3907 |
(mapcar |
(mapcar |
3908 |
(function |
(function |
3909 |
(lambda (function) |
(lambda (function) |
3910 |
(setq index (1+ index)) |
(setq index (1+ index)) |
3911 |
(` (ad-safe-fset |
`(ad-safe-fset |
3912 |
'(, function) |
',function |
3913 |
(, (car (nth index current-bindings))))))) |
,(car (nth index current-bindings))))) |
3914 |
functions)))))))) |
functions)))))) |
3915 |
|
|
3916 |
(if (not (get 'ad-with-originals 'lisp-indent-hook)) |
(if (not (get 'ad-with-originals 'lisp-indent-hook)) |
3917 |
(put 'ad-with-originals 'lisp-indent-hook 1)) |
(put 'ad-with-originals 'lisp-indent-hook 1)) |