/[emacs]/emacs/lisp/emacs-lisp/advice.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/advice.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.29 by gerd, Mon Jul 9 13:06:11 2001 UTC revision 1.30 by sds, Tue Nov 27 15:52:52 2001 UTC
# Line 149  Line 149 
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    
# Line 368  Line 368 
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
# Line 381  Line 381 
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
# Line 943  Line 943 
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))
# Line 1905  current head at every iteration.  If RES Line 1905  current head at every iteration.  If RES
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))
# Line 1944  exited prematurely with `(ad-do-return [ Line 1944  exited prematurely with `(ad-do-return [
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
# Line 1986  exited prematurely with `(ad-do-return [ Line 1986  exited prematurely with `(ad-do-return [
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'.
# Line 2003  exited prematurely with `(ad-do-return [ Line 2003  exited prematurely with `(ad-do-return [
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.
# Line 2034  Assumes that FUNCTION has not yet been a Line 2034  Assumes that FUNCTION has not yet been a
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."
# Line 2160  Redefining advices affect the constructi Line 2160  Redefining advices affect the constructi
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."
# Line 2183  Redefining advices affect the constructi Line 2183  Redefining advices affect the constructi
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:
# Line 2300  be used to prompt for the function." Line 2300  be used to prompt for the function."
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."
# Line 2458  will clear the cache." Line 2458  will clear the cache."
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):
# Line 2492  will clear the cache." Line 2492  will clear the cache."
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):
# Line 2511  will clear the cache." Line 2511  will clear the cache."
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."
# Line 2551  supplied to make subr arglist lookup mor Line 2551  supplied to make subr arglist lookup mor
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.
# Line 2761  element is its actual current value, and Line 2761  element is its actual current value, and
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))
# Line 2785  element is its actual current value, and Line 2784  element is its actual current value, and
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)
# Line 2814  to be accessed, it returns a list with t Line 2813  to be accessed, it returns a list with t
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    
# Line 2830  to be accessed, it returns a list with t Line 2829  to be accessed, it returns a list with t
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)
# Line 2850  The assignment starts at position INDEX. Line 2849  The assignment starts at position INDEX.
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."
# Line 3071  Example: `(ad-map-arglists '(a &rest arg Line 3070  Example: `(ad-map-arglists '(a &rest arg
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)
# Line 3104  Example: `(ad-map-arglists '(a &rest arg Line 3103  Example: `(ad-map-arglists '(a &rest arg
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
# Line 3126  Example: `(ad-map-arglists '(a &rest arg Line 3125  Example: `(ad-map-arglists '(a &rest arg
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
# Line 3139  should be modified.  The assembled funct Line 3138  should be modified.  The assembled funct
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    
# Line 3266  should be modified.  The assembled funct Line 3265  should be modified.  The assembled funct
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.
# Line 3451  advised definition from scratch." Line 3450  advised definition from scratch."
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:
# Line 3476  advised definition from scratch." Line 3475  advised definition from scratch."
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:
# Line 3812  See Info node `(elisp)Advising Functions Line 3811  See Info node `(elisp)Advising Functions
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)))))
# Line 3826  See Info node `(elisp)Advising Functions Line 3825  See Info node `(elisp)Advising Functions
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))))
# Line 3846  See Info node `(elisp)Advising Functions Line 3845  See Info node `(elisp)Advising Functions
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:
# Line 3880  undone on exit of this macro." Line 3879  undone on exit of this macro."
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))

Legend:
Removed from v.1.29  
changed lines
  Added in v.1.30

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26