2 new commits in xemacs-base:
https://bitbucket.org/xemacs/xemacs-base/changeset/51d722692ee0/
changeset: 51d722692ee0
user: kehoea
date: 2012-05-11 18:41:54
summary: Uncomment docstrings, advice.el.
2012-05-11 Aidan Kehoe <kehoea(a)parhasard.net>
* advice.el (ad-pushnew-advised-function):
* advice.el (ad-pop-advised-function):
* advice.el (ad-do-advised-functions):
* advice.el (ad-is-advised):
* advice.el (ad-initialize-advice-info):
* advice.el (ad-get-advice-info-field):
* advice.el (ad-set-advice-info-field):
* advice.el (ad-is-active):
* advice.el (ad-has-enabled-advice):
* advice.el (ad-has-redefining-advice):
* advice.el (ad-has-any-advice):
* advice.el (ad-get-enabled-advices):
* advice.el (ad-safe-fset):
* advice.el (ad-make-origname):
* advice.el (ad-read-advised-function):
* advice.el (ad-read-advice-class):
* advice.el (ad-read-advice-name):
* advice.el (ad-read-advice-specification):
* advice.el (ad-read-regexp):
* advice.el (ad-find-advice):
* advice.el (ad-advice-position):
* advice.el (ad-compiled-p):
* advice.el (ad-compiled-code):
* advice.el (ad-lambda-expression):
* advice.el (ad-arglist):
* advice.el (ad-subr-arglist):
* advice.el (ad-docstring):
* advice.el (ad-interactive-form):
* advice.el (ad-body-forms):
* advice.el (ad-make-advised-definition-docstring):
* advice.el (ad-advised-definition-p):
* advice.el (ad-definition-type):
* advice.el (ad-has-proper-definition):
* advice.el (ad-real-definition):
* advice.el (ad-real-orig-definition):
* advice.el (ad-is-compilable):
* advice.el (ad-compile-function):
* advice.el (ad-parse-arglist):
* advice.el (ad-retrieve-args-form):
* advice.el (ad-access-argument):
* advice.el (ad-get-argument):
* advice.el (ad-set-argument):
* advice.el (ad-get-arguments):
* advice.el (ad-set-arguments):
* advice.el (ad-insert-argument-access-forms):
* advice.el (ad-make-mapped-call):
* advice.el (ad-make-advised-docstring):
* advice.el (ad-advised-arglist):
* advice.el (ad-advised-interactive-form):
* advice.el (ad-make-advised-definition):
* advice.el (ad-make-hook-form):
* advice.el (ad-make-cache-id):
* advice.el (ad-get-cache-class-id):
* advice.el (ad-verify-cache-id):
* advice.el (ad-preactivate-advice):
* advice.el (ad-should-compile):
* advice.el (ad-activate-advised-definition):
Uncomment the docstrings for these functions, they take up negligible
space these days.
affected #: 2 files
diff -r d56f8e5d14021584dbef7f97c5985c36f19980cf -r
51d722692ee03cc29c3a708e66e4b46dc164a117 ChangeLog
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,65 @@
+2012-05-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * advice.el (ad-pushnew-advised-function):
+ * advice.el (ad-pop-advised-function):
+ * advice.el (ad-do-advised-functions):
+ * advice.el (ad-is-advised):
+ * advice.el (ad-initialize-advice-info):
+ * advice.el (ad-get-advice-info-field):
+ * advice.el (ad-set-advice-info-field):
+ * advice.el (ad-is-active):
+ * advice.el (ad-has-enabled-advice):
+ * advice.el (ad-has-redefining-advice):
+ * advice.el (ad-has-any-advice):
+ * advice.el (ad-get-enabled-advices):
+ * advice.el (ad-safe-fset):
+ * advice.el (ad-make-origname):
+ * advice.el (ad-read-advised-function):
+ * advice.el (ad-read-advice-class):
+ * advice.el (ad-read-advice-name):
+ * advice.el (ad-read-advice-specification):
+ * advice.el (ad-read-regexp):
+ * advice.el (ad-find-advice):
+ * advice.el (ad-advice-position):
+ * advice.el (ad-compiled-p):
+ * advice.el (ad-compiled-code):
+ * advice.el (ad-lambda-expression):
+ * advice.el (ad-arglist):
+ * advice.el (ad-subr-arglist):
+ * advice.el (ad-docstring):
+ * advice.el (ad-interactive-form):
+ * advice.el (ad-body-forms):
+ * advice.el (ad-make-advised-definition-docstring):
+ * advice.el (ad-advised-definition-p):
+ * advice.el (ad-definition-type):
+ * advice.el (ad-has-proper-definition):
+ * advice.el (ad-real-definition):
+ * advice.el (ad-real-orig-definition):
+ * advice.el (ad-is-compilable):
+ * advice.el (ad-compile-function):
+ * advice.el (ad-parse-arglist):
+ * advice.el (ad-retrieve-args-form):
+ * advice.el (ad-access-argument):
+ * advice.el (ad-get-argument):
+ * advice.el (ad-set-argument):
+ * advice.el (ad-get-arguments):
+ * advice.el (ad-set-arguments):
+ * advice.el (ad-insert-argument-access-forms):
+ * advice.el (ad-make-mapped-call):
+ * advice.el (ad-make-advised-docstring):
+ * advice.el (ad-advised-arglist):
+ * advice.el (ad-advised-interactive-form):
+ * advice.el (ad-make-advised-definition):
+ * advice.el (ad-make-hook-form):
+ * advice.el (ad-make-cache-id):
+ * advice.el (ad-get-cache-class-id):
+ * advice.el (ad-verify-cache-id):
+ * advice.el (ad-preactivate-advice):
+ * advice.el (ad-should-compile):
+ * advice.el (ad-activate-advised-definition):
+ Uncomment the docstrings for these functions, they take up negligible
+ space these days.
+
2012-01-10 Norbert Koch <viteno(a)xemacs.org>
* Makefile (VERSION): XEmacs package 2.31 released.
diff -r d56f8e5d14021584dbef7f97c5985c36f19980cf -r
51d722692ee03cc29c3a708e66e4b46dc164a117 advice.el
--- a/advice.el
+++ b/advice.el
@@ -1922,24 +1922,24 @@
(defvar ad-advised-functions nil)
(defmacro ad-pushnew-advised-function (function)
- ;;"Add FUNCTION to `ad-advised-functions' unless its already there."
+ "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)))))
(defmacro ad-pop-advised-function (function)
- ;;"Remove FUNCTION from `ad-advised-functions'."
+ "Remove FUNCTION from `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)
- ;;"`dolist'-style iterator that maps over `ad-advised-functions'.
- ;; (ad-do-advised-functions (VAR [RESULT-FORM])
- ;; BODY-FORM...)
- ;;Also see `dolist'. On each iteration VAR will be bound to the
- ;;name of an advised function (a symbol)."
+ "`dolist'-style iterator that maps over `ad-advised-functions'.
+ (ad-do-advised-functions (VAR [RESULT-FORM])
+ BODY-FORM...)
+Also see `dolist'. On each iteration VAR will be bound to the
+name of an advised function (a symbol)."
(` (dolist ((, (car varform))
ad-advised-functions
(, (car (cdr varform))))
@@ -1959,22 +1959,22 @@
(` (copy-tree (get (, function) 'ad-advice-info))))
(defmacro ad-is-advised (function)
- ;;"Returns non-nil if FUNCTION has any advice info associated with it.
- ;;This does not mean that the advice is also active."
+ "Return non-nil if FUNCTION has any advice info associated with it.
+This does not mean that the advice is also active."
(list 'ad-get-advice-info function))
(defun ad-initialize-advice-info (function)
- ;;"Initializes the advice info for FUNCTION.
- ;;Assumes that FUNCTION has not yet been advised."
+ "Initializes the advice info for FUNCTION.
+Assumes that FUNCTION has not yet been advised."
(ad-pushnew-advised-function function)
(ad-set-advice-info function (list (cons 'active nil))))
(defmacro ad-get-advice-info-field (function field)
- ;;"Retrieves the value of the advice info FIELD of FUNCTION."
+ "Retrieves the value of the advice info FIELD of FUNCTION."
(` (cdr (assq (, field) (ad-get-advice-info (, function))))))
(defun ad-set-advice-info-field (function field value)
- ;;"Destructively modifies VALUE of the advice info FIELD of FUNCTION."
+ "Destructively modifies VALUE of the advice info FIELD of FUNCTION."
(and (ad-is-advised function)
(cond ((assq field (ad-get-advice-info function))
;; A field with that name is already present:
@@ -1985,7 +1985,7 @@
;; Don't make this a macro so we can use it as a predicate:
(defun ad-is-active (function)
- ;;"non-nil if FUNCTION is advised and activated."
+ "Return non-nil if FUNCTION is advised and activated."
(ad-get-advice-info-field function 'active))
@@ -2029,27 +2029,27 @@
(defvar ad-advice-classes '(before around after activation deactivation))
(defun ad-has-enabled-advice (function class)
- ;;"True if at least one of FUNCTION's advices in CLASS is enabled."
+ "True if at least one of FUNCTION's advices in CLASS is enabled."
(dolist (advice (ad-get-advice-info-field function class))
(if (ad-advice-enabled advice) (return t))))
(defun ad-has-redefining-advice (function)
- ;;"True if FUNCTION's advice info defines at least 1 redefining advice.
- ;;Redefining advices affect the construction of an advised definition."
+ "True if FUNCTION's advice info defines at least 1 redefining advice.
+Redefining advices affect the construction of an advised definition."
(and (ad-is-advised function)
(or (ad-has-enabled-advice function 'before)
(ad-has-enabled-advice function 'around)
(ad-has-enabled-advice function 'after))))
(defun ad-has-any-advice (function)
- ;;"True if the advice info of FUNCTION defines at least one advice."
+ "True if the advice info of FUNCTION defines at least one advice."
(and (ad-is-advised function)
(dolist (class ad-advice-classes nil)
(if (ad-get-advice-info-field function class)
(return t)))))
(defun ad-get-enabled-advices (function class)
- ;;"Returns the list of enabled advices of FUNCTION in CLASS."
+ "Returns the list of enabled advices of FUNCTION in CLASS."
(let (enabled-advices)
(dolist (advice (ad-get-advice-info-field function class))
(if (ad-advice-enabled advice)
@@ -2101,7 +2101,7 @@
(,@ body))))
(defun ad-safe-fset (symbol definition)
- ;; A safe `fset' which will never call `ad-activate' recursively.
+ "A safe `fset' which will never call `ad-activate' recursively."
(ad-with-auto-activation-disabled
(ad-real-fset symbol definition)))
@@ -2116,7 +2116,7 @@
;; we need to use `ad-real-orig-definition'.
(defun ad-make-origname (function)
- ;;"Makes name to be used to call the original FUNCTION."
+ "Make name to be used to call the original FUNCTION."
(intern (format "ad-Orig-%s" function)))
(defmacro ad-get-orig-definition (function)
@@ -2136,11 +2136,11 @@
;; ===============================
(defun ad-read-advised-function (&optional prompt predicate default)
- ;;"Reads name of advised function with completion from the minibuffer.
- ;;An optional PROMPT will be used to prompt for the function. PREDICATE
- ;;plays the same role as for `try-completion' (which see). DEFAULT will
- ;;be returned on empty input (defaults to the first advised function for
- ;;which PREDICATE returns non-nil)."
+ "Read name of advised function with completion from the minibuffer.
+An optional PROMPT will be used to prompt for the function. PREDICATE
+plays the same role as for `try-completion' (which see). DEFAULT will
+be returned on empty input (defaults to the first advised function for
+which PREDICATE returns non-nil)."
(if (null ad-advised-functions)
(error "ad-read-advised-function: There are no advised functions"))
(setq default
@@ -2175,10 +2175,10 @@
ad-advice-classes))
(defun ad-read-advice-class (function &optional prompt default)
- ;;"Reads a legal advice class with completion from the minibuffer.
- ;;An optional PROMPT will be used to prompt for the class. DEFAULT will
- ;;be returned on empty input (defaults to the first non-empty advice
- ;;class of FUNCTION)."
+ "Read a legal advice class with completion from the minibuffer.
+An optional PROMPT will be used to prompt for the class. DEFAULT will
+be returned on empty input (defaults to the first non-empty advice
+class of FUNCTION)."
(setq default
(or default
(dolist (class ad-advice-classes)
@@ -2193,8 +2193,8 @@
(intern class))))
(defun ad-read-advice-name (function class &optional prompt)
- ;;"Reads name of existing advice of CLASS for FUNCTION with completion.
- ;;An optional PROMPT is used to prompt for the name."
+ "Reads name of existing advice of CLASS for FUNCTION with completion.
+An optional PROMPT is used to prompt for the name."
(let* ((name-completion-table
(mapcar (function (lambda (advice)
(list (symbol-name (ad-advice-name advice)))))
@@ -2211,9 +2211,9 @@
(intern name))))
(defun ad-read-advice-specification (&optional prompt)
- ;;"Reads a complete function/class/name specification from minibuffer.
- ;;The list of read symbols will be returned. The optional PROMPT will
- ;;be used to prompt for the function."
+ "Reads a complete function/class/name specification from minibuffer.
+The list of read symbols will be returned. The optional PROMPT will
+be used to prompt for the function."
(let* ((function (ad-read-advised-function prompt))
(class (ad-read-advice-class function))
(name (ad-read-advice-name function class)))
@@ -2223,7 +2223,7 @@
(defvar ad-last-regexp "")
(defun ad-read-regexp (&optional prompt)
- ;;"Reads a regular expression from the minibuffer."
+ "Read a regular expression from the minibuffer."
(let ((regexp (read-from-minibuffer
(concat (or prompt "Regular expression: ")
(if (equal ad-last-regexp "") ""
@@ -2236,11 +2236,11 @@
;; ===========================================================
(defmacro ad-find-advice (function class name)
- ;;"Finds the first advice of FUNCTION in CLASS with NAME."
+ "Find the first advice of FUNCTION in CLASS with NAME."
(` (assq (, name) (ad-get-advice-info-field (, function) (, class)))))
(defun ad-advice-position (function class name)
- ;;"Returns position of first advice of FUNCTION in CLASS with NAME."
+ "Return position of first advice of FUNCTION in CLASS with NAME."
(let* ((found-advice (ad-find-advice function class name))
(advices (ad-get-advice-info-field function class)))
(if found-advice
@@ -2429,19 +2429,19 @@
(ad-safe-fset 'byte-code-function-p 'compiled-function-p))
(defmacro ad-compiled-p (definition)
- ;;"non-nil if DEFINITION is a compiled byte-code object."
+ "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)))))))
(defmacro ad-compiled-code (compiled-definition)
- ;;"Returns the byte-code object of a COMPILED-DEFINITION."
+ "Return the byte-code object of a COMPILED-DEFINITION."
(` (if (ad-macro-p (, compiled-definition))
(ad-lambdafy (, compiled-definition))
(, compiled-definition))))
(defun ad-lambda-expression (definition)
- ;;"Returns the lambda expression of a function/macro/advice DEFINITION."
+ "Return the lambda expression of a function/macro/advice DEFINITION."
(cond ((ad-lambda-p definition)
definition)
((ad-macro-p definition)
@@ -2451,9 +2451,9 @@
(t nil)))
(defun ad-arglist (definition &optional name)
- ;;"Returns the argument list of DEFINITION.
- ;;If DEFINITION could be from a subr then its NAME should be
- ;;supplied to make subr arglist lookup more efficient."
+ "Return the argument list of DEFINITION.
+If DEFINITION could be from a subr then its NAME should be
+supplied to make subr arglist lookup more efficient."
(cond ((ad-compiled-p definition)
;; XEmacs fix:
(if (featurep 'xemacs)
@@ -2482,10 +2482,10 @@
(` (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)'."
+ "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:
@@ -2524,7 +2524,7 @@
(t '(&rest ad-subr-args)))))))
(defun ad-docstring (definition)
- ;;"Returns the unexpanded docstring of DEFINITION."
+ "Return the unexpanded docstring of DEFINITION."
(let ((docstring
(if (ad-compiled-p definition)
(ad-real-documentation definition t)
@@ -2534,7 +2534,7 @@
docstring)))
(defun ad-interactive-form (definition)
- ;;"Returns the interactive form of DEFINITION."
+ "Return the interactive form of DEFINITION."
(cond ((ad-compiled-p definition)
(and (commandp definition)
;; XEmacs: we have an accessor function so don't use aref.
@@ -2546,7 +2546,7 @@
(commandp (ad-lambda-expression definition)))))
(defun ad-body-forms (definition)
- ;;"Returns the list of body forms of DEFINITION."
+ "Return the list of body forms of DEFINITION."
(cond ((ad-compiled-p definition)
nil)
((consp definition)
@@ -2559,15 +2559,15 @@
(defvar ad-advised-definition-docstring-regexp "^\\$ad-doc: \\(.+\\)\\$$")
(defun ad-make-advised-definition-docstring (function)
- ;; Makes an identifying docstring for the advised definition of FUNCTION.
- ;; Put function name into the documentation string so we can infer
- ;; the name of the advised function from the docstring. This is needed
- ;; to generate a proper advised docstring even if we are just given a
- ;; definition (also see the defadvice for `documentation'):
+ "Make an identifying docstring for the advised definition of FUNCTION.
+Put function name into the documentation string so we can infer
+the name of the advised function from the docstring. This is needed
+to generate a proper advised docstring even if we are just given a
+definition (also see the defadvice for `documentation')."
(format "$ad-doc: %s$" (prin1-to-string function)))
(defun ad-advised-definition-p (definition)
- ;;"non-nil if DEFINITION was generated from advice information."
+ "Return non-nil if DEFINITION was generated from advice information."
(if (or (ad-lambda-p definition)
(ad-macro-p definition)
(ad-compiled-p definition))
@@ -2577,7 +2577,7 @@
ad-advised-definition-docstring-regexp docstring)))))
(defun ad-definition-type (definition)
- ;;"Returns symbol that describes the type of DEFINITION."
+ "Return symbol that describes the type of DEFINITION."
(if (ad-macro-p definition)
'macro
(if (ad-subr-p definition)
@@ -2591,8 +2591,8 @@
'advice)))))
(defun ad-has-proper-definition (function)
- ;;"True if FUNCTION is a symbol with a proper definition.
- ;;For that it has to be fbound with a non-autoload definition."
+ "True if FUNCTION is a symbol with a proper definition.
+For that it has to be fbound with a non-autoload definition."
(and (symbolp function)
(fboundp function)
(not (eq (car-safe (symbol-function function)) 'autoload))))
@@ -2600,7 +2600,7 @@
;; The following two are necessary for the sake of packages such as
;; ange-ftp which redefine functions via fcell indirection:
(defun ad-real-definition (function)
- ;;"Finds FUNCTION's definition at the end of function cell indirection."
+ "Find FUNCTION's definition at the end of function cell indirection."
(if (ad-has-proper-definition function)
(let ((definition (symbol-function function)))
(if (symbolp definition)
@@ -2608,19 +2608,19 @@
definition))))
(defun ad-real-orig-definition (function)
- ;;"Finds FUNCTION's real original definition starting from its
`origname'."
+ "Find FUNCTION's real original definition starting from its
`origname'."
(if (ad-is-advised function)
(ad-real-definition (ad-get-advice-info-field function 'origname))))
(defun ad-is-compilable (function)
- ;;"True if FUNCTION has an interpreted definition that can be compiled."
+ "True if FUNCTION has an interpreted definition that can be compiled."
(and (ad-has-proper-definition function)
(or (ad-lambda-p (symbol-function function))
(ad-macro-p (symbol-function function)))
(not (ad-compiled-p (symbol-function function)))))
(defun ad-compile-function (function)
- "Byte-compiles FUNCTION (or macro) if it is not yet compiled."
+ "Byte-compile FUNCTION (or macro) if it is not yet compiled."
(interactive "aByte-compile function: ")
(if (ad-is-compilable function)
;; Need to turn off auto-activation
@@ -2667,10 +2667,10 @@
;; =============================
(defun ad-parse-arglist (arglist)
- ;;"Parses ARGLIST into its required, optional and rest parameters.
- ;;A three-element list is returned, where the 1st element is the list of
- ;;required arguments, the 2nd is the list of optional arguments, and the 3rd
- ;;is the name of an optional rest parameter (or nil)."
+ "Parse ARGLIST into its required, optional and rest parameters.
+A three-element list is returned, where the 1st element is the list of
+required arguments, the 2nd is the list of optional arguments, and the 3rd
+is the name of an optional rest parameter (or nil)."
(let* (required optional rest)
(setq rest (car (cdr (memq '&rest arglist))))
(if rest (setq arglist (reverse (cdr (memq '&rest (reverse arglist))))))
@@ -2681,12 +2681,12 @@
(list required optional rest)))
(defun ad-retrieve-args-form (arglist)
- ;;"Generates a form which evaluates into names/values/types of ARGLIST.
- ;;When the form gets evaluated within a function with that argument list
- ;;it will result in a list with one entry for each argument, where the
- ;;first element of each entry is the name of the argument, the second
- ;;element is its actual current value, and the third element is either
- ;;`required', `optional' or `rest' depending on the type of the
argument."
+ "Generate a form which evaluates into names/values/types of ARGLIST.
+When the form gets evaluated within a function with that argument list
+it will result in a list with one entry for each argument, where the
+first element of each entry is the name of the argument, the second
+element is its actual current value, and the third element is either
+`required', `optional' or `rest' depending on the type of the
argument."
(let* ((parsed-arglist (ad-parse-arglist arglist))
(rest (nth 2 parsed-arglist)))
(` (list
@@ -2717,9 +2717,9 @@
(t (list 'nth position list))))
(defun ad-access-argument (arglist index)
- ;;"Tells how to access ARGLIST's actual argument at position INDEX.
- ;;For a required/optional arg it simply returns it, if a rest argument has
- ;;to be accessed, it returns a list with the index and name."
+ "Tells how to access ARGLIST's actual argument at position INDEX.
+For a required/optional arg it simply returns it, if a rest argument has
+to be accessed, it returns a list with the index and name."
(let* ((parsed-arglist (ad-parse-arglist arglist))
(reqopt-args (append (nth 0 parsed-arglist)
(nth 1 parsed-arglist)))
@@ -2730,7 +2730,7 @@
(list (- index (length reqopt-args)) rest-arg)))))
(defun ad-get-argument (arglist index)
- ;;"Returns form to access ARGLIST's actual argument at position INDEX."
+ "Returns form to access ARGLIST's actual argument at position INDEX."
(let ((argument-access (ad-access-argument arglist index)))
(cond ((consp argument-access)
(ad-element-access
@@ -2738,7 +2738,7 @@
(argument-access))))
(defun ad-set-argument (arglist index value-form)
- ;;"Returns form to set ARGLIST's actual arg at INDEX to VALUE-FORM."
+ "Returns form to set ARGLIST's actual arg at INDEX to VALUE-FORM."
(let ((argument-access (ad-access-argument arglist index)))
(cond ((consp argument-access)
;; should this check whether there actually is something to set?
@@ -2751,7 +2751,7 @@
index arglist)))))
(defun ad-get-arguments (arglist index)
- ;;"Returns form to access all actual arguments starting at position INDEX."
+ "Returns form to access all actual arguments starting at position INDEX."
(let* ((parsed-arglist (ad-parse-arglist arglist))
(reqopt-args (append (nth 0 parsed-arglist)
(nth 1 parsed-arglist)))
@@ -2767,8 +2767,8 @@
args-form))
(defun ad-set-arguments (arglist index values-form)
- ;;"Makes form to assign elements of VALUES-FORM as actual ARGLIST args.
- ;;The assignment starts at position INDEX."
+ "Makes form to assign elements of VALUES-FORM as actual ARGLIST args.
+The assignment starts at position INDEX."
(let ((values-index 0)
argument-access set-forms)
(while (setq argument-access (ad-access-argument arglist index))
@@ -2805,7 +2805,7 @@
(, 'ad-vAlUeS)))))))
(defun ad-insert-argument-access-forms (definition arglist)
- ;;"Expands arg-access text macros in DEFINITION according to ARGLIST."
+ "Expand arg-access text macros in DEFINITION according to ARGLIST."
(macrolet
((subtree-test (form)
`(funcall #'(lambda (form)
@@ -2892,7 +2892,7 @@
source-reqopt-args)))))))))
(defun ad-make-mapped-call (source-arglist target-arglist target-function)
- ;;"Makes form to call TARGET-FUNCTION with args from SOURCE-ARGLIST."
+ "Make form to call TARGET-FUNCTION with args from SOURCE-ARGLIST."
(let* ((mapped-form (ad-map-arglists source-arglist target-arglist)))
(if (eq (car mapped-form) 'funcall)
(cons target-function (cdr (cdr mapped-form)))
@@ -2925,13 +2925,13 @@
(or advice-docstring ""))))))
(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
@@ -2961,7 +2961,7 @@
;; ========================================================
(defun ad-advised-arglist (function)
- ;;"Finds first defined arglist in FUNCTION's redefining advices."
+ "Find first defined arglist in FUNCTION's redefining advices."
(dolist (advice (append (ad-get-enabled-advices function 'before)
(ad-get-enabled-advices function 'around)
(ad-get-enabled-advices function 'after)))
@@ -2971,7 +2971,7 @@
(return arglist)))))
(defun ad-advised-interactive-form (function)
- ;;"Finds first interactive form in FUNCTION's redefining advices."
+ "Find first interactive form in FUNCTION's redefining advices."
(dolist (advice (append (ad-get-enabled-advices function 'before)
(ad-get-enabled-advices function 'around)
(ad-get-enabled-advices function 'after)))
@@ -2985,7 +2985,7 @@
;; ============================
(defun ad-make-advised-definition (function)
- ;;"Generates an advised definition of FUNCTION from its advice info."
+ "Generate an advised definition of FUNCTION from its advice info."
(if (and (ad-is-advised function)
(ad-has-redefining-advice function))
(let* ((origdef (ad-real-orig-definition function))
@@ -3129,7 +3129,7 @@
;; This is needed for activation/deactivation hooks:
(defun ad-make-hook-form (function hook-name)
- ;;"Makes hook-form from FUNCTION's advice bodies in class HOOK-NAME."
+ "Make hook-form from FUNCTION's advice bodies in class HOOK-NAME."
(let ((hook-forms
(mapcar (function (lambda (advice)
(ad-body-forms (ad-advice-definition advice))))
@@ -3217,7 +3217,7 @@
(ad-set-advice-info-field function 'cache nil))
(defun ad-make-cache-id (function)
- ;;"Generates an identifying image of the current advices of FUNCTION."
+ "Generate an identifying image of the current advices of FUNCTION."
(let ((original-definition (ad-real-orig-definition function))
(cached-definition (ad-get-cache-definition function)))
(list (mapcar (function (lambda (advice) (ad-advice-name advice)))
@@ -3236,7 +3236,7 @@
(ad-interactive-form cached-definition))))))
(defun ad-get-cache-class-id (function class)
- ;;"Returns the part of FUNCTION's cache id that identifies CLASS."
+ "Return the part of FUNCTION's cache id that identifies CLASS."
(let ((cache-id (ad-get-cache-id function)))
(if (eq class 'before)
(car cache-id)
@@ -3286,7 +3286,7 @@
code))
(defun ad-verify-cache-id (function)
- ;;"True if FUNCTION's cache-id is compatible with its current advices."
+ "True if FUNCTION's cache-id is compatible with its current advices."
(eq (ad-cache-id-verification-code function) 'verified))
@@ -3314,7 +3314,7 @@
;; advised definition will be generated.
(defun ad-preactivate-advice (function advice class position)
- ;;"Preactivates FUNCTION and returns the constructed cache."
+ "Preactivate FUNCTION and returns the constructed cache."
(let* ((function-defined-p (fboundp function))
(old-definition
(if function-defined-p
@@ -3426,11 +3426,11 @@
;; ======================================
(defun ad-should-compile (function compile)
- ;;"Returns non-nil if the advised FUNCTION should be compiled.
- ;;If COMPILE is non-nil and not a negative number then it returns t.
- ;;If COMPILE is a negative number then it returns nil.
- ;;If COMPILE is nil then the result depends on the value of
- ;;`ad-default-compilation-action' (which see)."
+ "Return non-nil if the advised FUNCTION should be compiled.
+If COMPILE is non-nil and not a negative number then it returns t.
+If COMPILE is a negative number then it returns nil.
+If COMPILE is nil then the result depends on the value of
+`ad-default-compilation-action' (which see)."
(if (integerp compile)
(>= compile 0)
(if compile
@@ -3446,9 +3446,9 @@
(t (featurep 'byte-compile))))))
(defun ad-activate-advised-definition (function compile)
- ;;"Redefines FUNCTION with its advised definition from cache or scratch.
- ;;The resulting FUNCTION will be compiled if `ad-should-compile' returns t.
- ;;The current definition and its cache-id will be put into the cache."
+ "Redefine FUNCTION with its advised definition from cache or scratch.
+The resulting FUNCTION will be compiled if `ad-should-compile' returns t.
+The current definition and its cache-id will be put into the cache."
(let ((verified-cached-definition
(if (ad-verify-cache-id function)
(ad-get-cache-definition function))))
https://bitbucket.org/xemacs/xemacs-base/changeset/080d3b71a1cc/
changeset: 080d3b71a1cc
user: kehoea
date: 2012-05-11 20:21:55
summary: Use standard backquotes, advice.el, old Emacs Lisp backquotes are long
obsolete.
affected #: 2 files
diff -r 51d722692ee03cc29c3a708e66e4b46dc164a117 -r
080d3b71a1cc2953be541e3c57c4a9506ab05f63 ChangeLog
--- a/ChangeLog
+++ b/ChangeLog
@@ -60,6 +60,8 @@
Uncomment the docstrings for these functions, they take up negligible
space these days.
+ Use standard backquotes, old Emacs Lisp backquotes are long obsolete.
+
2012-01-10 Norbert Koch <viteno(a)xemacs.org>
* Makefile (VERSION): XEmacs package 2.31 released.
diff -r 51d722692ee03cc29c3a708e66e4b46dc164a117 -r
080d3b71a1cc2953be541e3c57c4a9506ab05f63 advice.el
--- a/advice.el
+++ b/advice.el
@@ -1731,7 +1731,7 @@
;; `ad-return-value' in a piece of after advice. For example:
;;
;; (defmacro foom (x)
-;; (` (list (, x))))
+;; `(list ,x))
;; foom
;;
;; (foom '(a))
@@ -1763,9 +1763,7 @@
;;
;; (defadvice foom (after fg-print-x act)
;; "Print the value of X."
-;; (setq ad-return-value
-;; (` (progn (print (, x))
-;; (, ad-return-value)))))
+;; (setq ad-return-value `(progn (print ,x) ,ad-return-value)))
;; foom
;;
;; (macroexpand '(foom '(a)))
@@ -1879,15 +1877,15 @@
(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
@@ -1923,16 +1921,15 @@
(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)
"`dolist'-style iterator that maps over `ad-advised-functions'.
@@ -1940,23 +1937,21 @@
BODY-FORM...)
Also see `dolist'. On each iteration VAR will be bound to the
name of an advised function (a symbol)."
- (` (dolist ((, (car varform))
- ad-advised-functions
- (, (car (cdr varform))))
- (setq (, (car varform)) (intern (car (, (car varform)))))
- (,@ body))))
+ `(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)
- (` (copy-tree (get (, function) 'ad-advice-info))))
+ `(copy-tree (get ,function 'ad-advice-info)))
(defmacro ad-is-advised (function)
"Return non-nil if FUNCTION has any advice info associated with it.
@@ -1971,7 +1966,7 @@
(defmacro ad-get-advice-info-field (function field)
"Retrieves 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 modifies VALUE of the advice info FIELD of FUNCTION."
@@ -2097,8 +2092,8 @@
(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' recursively."
@@ -2120,17 +2115,14 @@
(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:
;; ===============================
@@ -2237,7 +2229,7 @@
(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."
@@ -2266,12 +2258,12 @@
(if found-advice (return found-advice))))))
(defun ad-enable-advice-internal (function class name flag)
- ;;"Sets enable FLAG of FUNCTION's advices in CLASS matching NAME.
- ;;If NAME is a string rather than a symbol then it's interpreted as a regular
- ;;expression and all advices whose name contain a match for it will be
- ;;affected. If CLASS is `any' advices in all legal advice classes will be
- ;;considered. The number of changed advices will be returned (or nil if
- ;;FUNCTION was not advised)."
+ "Set enable FLAG of FUNCTION's advices in CLASS matching NAME.
+If NAME is a string rather than a symbol then it's interpreted as a regular
+expression and all advices whose name contain a match for it will be
+affected. If CLASS is `any' advices in all legal advice classes will be
+considered. The number of changed advices will be returned (or nil if
+FUNCTION was not advised)."
(if (ad-is-advised function)
(let ((matched-advices 0))
(dolist (advice-class ad-advice-classes)
@@ -2394,33 +2386,33 @@
;; ===================================================
(defmacro ad-macrofy (definition)
- ;;"Takes a lambda function DEFINITION and makes a macro out of it."
- (` (cons 'macro (, definition))))
+ "Take a lambda function DEFINITION and make a macro out of it."
+ `(cons 'macro ,definition))
(defmacro ad-lambdafy (definition)
- ;;"Takes a macro function DEFINITION and makes a lambda out of it."
- (` (cdr (, definition))))
+ "Take a macro function DEFINITION and make a lambda out of it."
+ `(cdr ,definition))
(defmacro ad-interactive-p (definition)
- ;;"non-nil if DEFINITION can be called interactively."
+ "Non-nil if DEFINITION can be called interactively."
(list 'commandp definition))
(defmacro ad-subr-p (definition)
- ;;"non-nil if DEFINITION is a subr."
+ "Non-nil if DEFINITION is a subr."
(list 'subrp definition))
(defmacro ad-macro-p (definition)
- ;;"non-nil if DEFINITION is a macro."
- (` (eq (car-safe (, definition)) 'macro)))
+ "Non-nil if DEFINITION is a macro."
+ `(eq (car-safe ,definition) 'macro))
(defmacro ad-lambda-p (definition)
- ;;"non-nil if DEFINITION is a lambda expression."
- (` (eq (car-safe (, definition)) 'lambda)))
+ "Non-nil if DEFINITION is a lambda expression."
+ `(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)))
+ "Non-nil if DEFINITION is a piece of advice."
+ `(eq (car-safe ,definition) 'advice))
;; Emacs/XEmacs cross-compatibility
;; (compiled-function-p is an obsolete function in Emacs):
@@ -2430,15 +2422,15 @@
(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."
@@ -2473,13 +2465,13 @@
;; 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.
@@ -2688,18 +2680,12 @@
element is its actual current value, and the third element is either
`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)))))
- ))))
+ (rest (nth 2 parsed-arglist)))
+ `(list ,@(mapcar #'(lambda (req) `(list ',req ,req 'required))
+ (nth 0 parsed-arglist))
+ ,@(mapcar #'(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))
@@ -2713,7 +2699,7 @@
(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)
@@ -2742,13 +2728,15 @@
(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))))
- (argument-access
- (` (setq (, argument-access) (, value-form))))
- (t (error "ad-set-argument: No argument at position %d of `%s'"
- index arglist)))))
+ `(setcar ,(ad-list-access (car argument-access)
+ (car (cdr argument-access)))
+ ,value-form))
+ (argument-access `(setq ,argument-access ,value-form))
+ (t
+ (error
+ "ad-set-argument: No argument at position %d of `%s'"
+ index
+ arglist)))))
(defun ad-get-arguments (arglist index)
"Returns form to access all actual arguments starting at position INDEX."
@@ -2758,12 +2746,13 @@
(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))))
+ (if args-form
+ (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)
@@ -2799,10 +2788,10 @@
;; For exactly one set-form we can use values-form directly,...
(subst values-form 'ad-vAlUeS (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)))))))
+ `(let ((ad-vAlUeS ,values-form))
+ ,@(reverse set-forms)
+ ;; work around the old backquote bug:
+ ,'ad-vAlUeS)))))
(defun ad-insert-argument-access-forms (definition arglist)
"Expand arg-access text macros in DEFINITION according to ARGLIST."
@@ -3007,11 +2996,11 @@
;; 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))))))
+ (let ((reqargs
+ (car (ad-parse-arglist advised-arglist))))
+ (if reqargs
+ `(interactive ',(make-list (length reqargs) nil))
+ '(interactive))))))
(orig-form
(cond ((or orig-special-form-p orig-macro-p)
;; Special forms and macros will be advised into macros.
@@ -3028,20 +3017,18 @@
;; 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))))))
- ((and orig-subr-p
- orig-interactive-p
- (not advised-interactive-form))
+ `(,(if orig-macro-p 'macroexpand 'eval)
+ (cons ',origname
+ ,(ad-get-arguments advised-arglist 0))))
+ ((and orig-subr-p
+ orig-interactive-p
+ (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
@@ -3074,18 +3061,16 @@
(let (before-forms around-form around-form-protected after-forms definition)
(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))
(dolist (advice (reverse arounds))
;; If any of the around advices is protected then we
;; protect the complete around advice onion:
@@ -3096,35 +3081,27 @@
(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))))
+ (if (and around-form-protected before-forms)
+ `((unwind-protect ,(ad-prognify before-forms) ,around-form))
+ (append before-forms (list around-form))))
(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)))
;; This is needed for activation/deactivation hooks:
@@ -3199,14 +3176,13 @@
;; 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.
@@ -3407,20 +3383,17 @@
(ad-safe-fset 'ad-make-origname real-origname-fn))))
(if frozen-definition
(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))))))))
-
+ (body (cdr (if macro-p
+ (ad-lambdafy frozen-definition)
+ frozen-definition))))
+ `(progn
+ (if (not (fboundp ',unique-origname))
+ ;; avoid infinite recursion in case the function
+ ;; we want to freeze is already advised:
+ (fset ',unique-origname
+ (or (ad-get-orig-definition ',function)
+ (symbol-function ',function))))
+ (,(if macro-p 'defmacro 'defun) ,function ,@body))))))
;; @@ Activation and definition handling:
;; ======================================
@@ -3552,7 +3525,7 @@
(t (ad-deactivate function)))))))))
(defun ad-deactivate (function)
- "Deactivates the advice of an actively advised FUNCTION.
+ "Deactivate the advice of an actively advised FUNCTION.
If FUNCTION has a proper original definition, then the current
definition of FUNCTION will be replaced with it. All the advice
information will still be available so it can be activated again with
@@ -3755,10 +3728,9 @@
(t (error "defadvice: Illegal or ambiguous flag: %s"
flag))))))
args))
- (advice (ad-make-advice
- name (memq 'protect flags)
- (not (memq 'disable flags))
- (` (advice lambda (, arglist) (,@ body)))))
+ (advice (ad-make-advice name (memq 'protect flags)
+ (not (memq 'disable flags))
+ `(advice lambda ,arglist ,@body)))
(preactivation (if (memq 'preactivate flags)
(ad-preactivate-advice
function advice class position))))
@@ -3766,27 +3738,21 @@
(if (memq 'freeze flags)
;; 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-on '(, function)
- (, (if (memq 'compile flags) t)))))))
- '(, function))))))
-
+ (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
+ ,(cond ((ad-macro-p (car preactivation))
+ `(ad-macrofy
+ #',(ad-lambdafy (car preactivation))))
+ (t `#',(car preactivation)))
+ ',(car (cdr preactivation)))))
+ ,@(if (memq 'activate flags)
+ `((ad-activate-on ',function
+ ,(if (memq 'compile flags) t))))
+ ',function))))
;; @@ Tools:
;; =========
@@ -3801,39 +3767,35 @@
(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
+ `(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))))))))
+ (setq index -1)
+ (mapcar
+ #'(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
+ #'(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))
Repository URL:
https://bitbucket.org/xemacs/xemacs-base/
--
This is a commit notification from
bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches