From f6c6e09c7f16b7adbe2e5d1214a27902937f419e Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Sun, 4 Nov 2012 07:22:06 -0500 Subject: Auto-commit of loaddefs files. --- lisp/emacs-lisp/cl-loaddefs.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 5ad6e37a5a1..a2e394e3f4e 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -265,7 +265,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value. ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp ;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) -;;;;;; "cl-macs" "cl-macs.el" "366e9efa4e3e7a81b2253e503611b23a") +;;;;;; "cl-macs" "cl-macs.el" "57cf89149db1e8ea6bc1582713980cf8") ;;; Generated autoloads from cl-macs.el (autoload 'cl--compiler-macro-list* "cl-macs" "\ @@ -473,9 +473,9 @@ from OBARRAY. (put 'cl-do-symbols 'lisp-indent-function '1) (autoload 'cl-do-all-symbols "cl-macs" "\ +Like `cl-do-symbols', but use the default obarray. - -\(fn SPEC &rest BODY)" nil t) +\(fn (VAR [RESULT]) BODY...)" nil t) (put 'cl-do-all-symbols 'lisp-indent-function '1) -- cgit v1.2.3 From 5593ed900d0d420f4ee3dd7af3f56b118308a3c0 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Mon, 5 Nov 2012 00:29:12 -0800 Subject: Misc small cl doc fixes * emacs-lisp/cl-extra.el (cl-maplist, cl-mapcan): Doc fix. * emacs-lisp/cl-extra.el (cl-prettyexpand): * emacs-lisp/cl-lib.el (cl-proclaim, cl-declaim): * emacs-lisp/cl-macs.el (cl-destructuring-bind, cl-locally) (cl-the, cl-compiler-macroexpand): Add basic doc strings. --- lisp/ChangeLog | 9 +++++++++ lisp/emacs-lisp/cl-extra.el | 7 +++++-- lisp/emacs-lisp/cl-lib.el | 7 ++++++- lisp/emacs-lisp/cl-macs.el | 7 +++++++ 4 files changed, 27 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 5be111818dd..95c407fcdb7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2012-11-05 Glenn Morris + + * emacs-lisp/cl-extra.el (cl-prettyexpand): + * emacs-lisp/cl-lib.el (cl-proclaim, cl-declaim): + * emacs-lisp/cl-macs.el (cl-destructuring-bind, cl-locally) + (cl-the, cl-compiler-macroexpand): Add basic doc strings. + + * emacs-lisp/cl-extra.el (cl-maplist, cl-mapcan): Doc fix. + 2012-11-03 Glenn Morris * emacs-lisp/cl-macs.el (cl-parse-loop-clause): diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index c72e3342648..8f801b39d3d 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -131,7 +131,7 @@ TYPE is the sequence type to return. ;;;###autoload (defun cl-maplist (cl-func cl-list &rest cl-rest) "Map FUNCTION to each sublist of LIST or LISTs. -Like `mapcar', except applies to lists and their cdr's rather than to +Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \n(fn FUNCTION LIST...)" (if cl-rest @@ -170,7 +170,7 @@ the elements themselves. ;;;###autoload (defun cl-mapcan (cl-func cl-seq &rest cl-rest) - "Like `mapcar', but nconc's together the values returned by the function. + "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))) @@ -675,6 +675,9 @@ PROPLIST is a list of the sort returned by `symbol-plist'. ;;;###autoload (defun cl-prettyexpand (form &optional full) + "Expand macros in FORM and insert the pretty-printed result. +Optional argument FULL non-nil means to expand all macros, +including `cl-block' and `cl-eval-when'." (message "Expanding...") (let ((cl--compiling-file full) (byte-compile-macro-environment nil)) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 122402797e1..e9b30a8f62d 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -251,12 +251,17 @@ one value. (defvar cl-proclaims-deferred nil) (defun cl-proclaim (spec) + "Record a global declaration specified by SPEC." (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) (push spec cl-proclaims-deferred)) nil) (defmacro cl-declaim (&rest specs) - (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x)))) + "Like `cl-proclaim', but takes any number of unevaluated, unquoted arguments. +Puts `(cl-eval-when (compile load eval) ...)' around the declarations +so that they are registered at compile-time as well as run-time." + (let ((body (mapcar (function (lambda (x) + (list 'cl-proclaim (list 'quote x)))) specs))) (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 8d240774edb..b28f8f7f9e9 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -554,6 +554,7 @@ its argument list allows full Common Lisp conventions." ;;;###autoload (defmacro cl-destructuring-bind (args expr &rest body) + "Bind the variables in ARGS to the result of EXPR and execute BODY." (declare (indent 2) (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil) @@ -1886,10 +1887,12 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). ;;;###autoload (defmacro cl-locally (&rest body) + "Equivalent to `progn'." (declare (debug t)) (cons 'progn body)) ;;;###autoload (defmacro cl-the (_type form) + "At present this ignores _TYPE and is simply equivalent to FORM." (declare (indent 1) (debug (cl-type-spec form))) form) @@ -2537,6 +2540,10 @@ and then returning foo." ;;;###autoload (defun cl-compiler-macroexpand (form) + "Like `macroexpand', but for compiler macros. +Expands FORM repeatedly until no further expansion is possible. +Returns FORM unchanged if it has no compiler macro, or if it has a +macro that returns its `&whole' argument." (while (let ((func (car-safe form)) (handler nil)) (while (and (symbolp func) -- cgit v1.2.3 From 7e92a493969e1cb5887f87508d7c020bb11693b6 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Mon, 5 Nov 2012 07:20:41 -0500 Subject: Auto-commit of loaddefs files. --- lisp/emacs-lisp/cl-loaddefs.el | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index a2e394e3f4e..e18c32da996 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -11,7 +11,7 @@ ;;;;;; cl--map-overlays cl--map-intervals cl--map-keymap-recursively ;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan ;;;;;; cl-mapl cl-mapc cl-maplist cl-map cl--mapcar-many cl-equalp -;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "7d7f65d8a05e954a919fe2555b68fb05") +;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "b7d4e24fe58609eaf4fb319c81eb829e") ;;; Generated autoloads from cl-extra.el (autoload 'cl-coerce "cl-extra" "\ @@ -41,7 +41,7 @@ TYPE is the sequence type to return. (autoload 'cl-maplist "cl-extra" "\ Map FUNCTION to each sublist of LIST or LISTs. -Like `mapcar', except applies to lists and their cdr's rather than to +Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \(fn FUNCTION LIST...)" nil nil) @@ -57,7 +57,7 @@ Like `cl-maplist', but does not accumulate values returned by the function. \(fn FUNCTION LIST...)" nil nil) (autoload 'cl-mapcan "cl-extra" "\ -Like `mapcar', but nconc's together the values returned by the function. +Like `cl-mapcar', but nconc's together the values returned by the function. \(fn FUNCTION SEQUENCE...)" nil nil) @@ -248,7 +248,9 @@ Remove from SYMBOL's plist the property PROPNAME and its value. \(fn SYMBOL PROPNAME)" nil nil) (autoload 'cl-prettyexpand "cl-extra" "\ - +Expand macros in FORM and insert the pretty-printed result. +Optional argument FULL non-nil means to expand all macros, +including `cl-block' and `cl-eval-when'. \(fn FORM &optional FULL)" nil nil) @@ -265,7 +267,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value. ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp ;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) -;;;;;; "cl-macs" "cl-macs.el" "57cf89149db1e8ea6bc1582713980cf8") +;;;;;; "cl-macs" "cl-macs.el" "a7228877484d2b39e1c2bee40b011734") ;;; Generated autoloads from cl-macs.el (autoload 'cl--compiler-macro-list* "cl-macs" "\ @@ -320,7 +322,7 @@ its argument list allows full Common Lisp conventions. \(fn FUNC)" nil t) (autoload 'cl-destructuring-bind "cl-macs" "\ - +Bind the variables in ARGS to the result of EXPR and execute BODY. \(fn ARGS EXPR &rest BODY)" nil t) @@ -564,12 +566,12 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (put 'cl-multiple-value-setq 'lisp-indent-function '1) (autoload 'cl-locally "cl-macs" "\ - +Equivalent to `progn'. \(fn &rest BODY)" nil t) (autoload 'cl-the "cl-macs" "\ - +At present this ignores _TYPE and is simply equivalent to FORM. \(fn TYPE FORM)" nil t) @@ -721,7 +723,10 @@ and then returning foo. \(fn FUNC ARGS &rest BODY)" nil t) (autoload 'cl-compiler-macroexpand "cl-macs" "\ - +Like `macroexpand', but for compiler macros. +Expands FORM repeatedly until no further expansion is possible. +Returns FORM unchanged if it has no compiler macro, or if it has a +macro that returns its `&whole' argument. \(fn FORM)" nil nil) -- cgit v1.2.3 From 6b3770fb9dd180abbda32383eba5e961e76d7504 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Mon, 5 Nov 2012 20:36:44 -0500 Subject: * lisp/emacs-lisp/gv.el (gv-define-setter): Fix doc typo. --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/gv.el | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 95c407fcdb7..9295f72a336 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2012-11-06 Glenn Morris + + * emacs-lisp/gv.el (gv-define-setter): Fix doc typo. + 2012-11-05 Glenn Morris * emacs-lisp/cl-extra.el (cl-prettyexpand): diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index d6c91539a90..3dd021f9e74 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -194,7 +194,7 @@ well for simple place forms. Assignments of VAL to (NAME ARGS...) are expanded by binding the argument forms (VAL ARGS...) according to ARGLIST, then executing BODY, which must return a Lisp form that does the assignment. -The first arg in ARLIST (the one that receives VAL) receives an expression +The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) `(aset ,a ,i ,v))" -- cgit v1.2.3 From d57c286eea2c3bc69e8aeac6c4a1458625032a73 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 6 Nov 2012 22:14:27 -0500 Subject: * lisp/emacs-lisp/cl.el (defsetf): Pass the third arg to gv-define-simple-setter. Fixes: debbugs:12812 --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/cl.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e89af026c66..b88baaa2f0a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-11-07 Stefan Monnier + + * emacs-lisp/cl.el (defsetf): Pass the third arg to + gv-define-simple-setter (bug#12812). + 2012-11-06 Stefan Monnier * woman.el (woman-decode-region): Disable adaptive-fill when rendering diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index d3ef83961e2..52567f34278 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -597,7 +597,7 @@ Example: (cl-function (lambda (,@(car args) ,@arg1) ,@(cdr args))) do args))) - `(gv-define-simple-setter ,name ,arg1))) + `(gv-define-simple-setter ,name ,arg1 ,(car args)))) ;; FIXME: CL used to provide a setf method for `apply', but I haven't been able ;; to find a case where it worked. The code below tries to handle it as well. -- cgit v1.2.3 From b715ed4447b025d713fc68a7af3728c2d463974b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 6 Nov 2012 22:39:33 -0500 Subject: * lisp/emacs-lisp/gv.el (gv-define-simple-setter): Don't evaluate `val' twice when `fix-return' is set. Fixes: debbugs:12813 --- lisp/ChangeLog | 3 +++ lisp/emacs-lisp/gv.el | 6 ++++-- 2 files changed, 7 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b88baaa2f0a..187ff2d7e1d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,8 @@ 2012-11-07 Stefan Monnier + * emacs-lisp/gv.el (gv-define-simple-setter): Don't evaluate `val' + twice when `fix-return' is set (bug#12813). + * emacs-lisp/cl.el (defsetf): Pass the third arg to gv-define-simple-setter (bug#12812). diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 3dd021f9e74..a0c412a9504 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -213,9 +213,11 @@ If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and instead the assignment is turned into (prog1 VAL (SETTER ARGS... VAL)) so as to preserve the semantics of `setf'." (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) - (let ((set-call `(cons ',setter (append args (list val))))) `(gv-define-setter ,name (val &rest args) - ,(if fix-return `(list 'prog1 val ,set-call) set-call)))) + ,(if fix-return + `(macroexp-let2 nil v val + (cons ',setter (append args (list v)))) + `(cons ',setter (append args (list val)))))) ;;; Typical operations on generalized variables. -- cgit v1.2.3 From 2ee1d59f5bea4a206595d621dcb63477461b7155 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Tue, 6 Nov 2012 20:37:07 -0800 Subject: Small doc updates for generalized variables * lisp/emacs-lisp/gv.el (gv-letplace): Fix doc typo. (gv-define-simple-setter): Update doc of `fix-return'. * doc/lispref/variables.texi (Adding Generalized Variables): Update description of FIX-RETURN expansion. * doc/misc/cl.texi (Obsolete Setf Customization): Revert defsetf example to the more correct let rather than prog1. --- doc/lispref/ChangeLog | 5 +++++ doc/lispref/variables.texi | 9 +++++++-- doc/misc/ChangeLog | 5 +++++ doc/misc/cl.texi | 10 +++++----- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/gv.el | 8 ++++++-- 6 files changed, 33 insertions(+), 9 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index c588e81dd1f..6e7a0b7a648 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,8 @@ +2012-11-07 Glenn Morris + + * variables.texi (Adding Generalized Variables): + Update description of FIX-RETURN expansion. + 2012-11-06 Glenn Morris * variables.texi (Setting Generalized Variables): diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index a7134af20bd..fb98b3cd035 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -2089,8 +2089,13 @@ no problem with, e.g., @code{car} and @code{setcar}, because @code{setcar} returns the value that it set. If your @var{setter} function does not return @var{value}, use a non-@code{nil} value for the @var{fix-return} argument of @code{gv-define-simple-setter}. This -wraps the @code{setf} expansion in @code{(prog1 @var{value} @dots{})} -so that it returns the correct result. +expands into something equivalent to +@example +(let ((temp @var{value})) + (@var{setter} @var{args}@dots{} temp) + temp) +@end example +so ensuring that it returns the correct result. @end defmac diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog index bd815e3df9f..49f86ef093b 100644 --- a/doc/misc/ChangeLog +++ b/doc/misc/ChangeLog @@ -1,3 +1,8 @@ +2012-11-07 Glenn Morris + + * cl.texi (Obsolete Setf Customization): + Revert defsetf example to the more correct let rather than prog1. + 2012-11-06 Glenn Morris * cl.texi (Overview): Mention EIEIO here, as well as the appendix. diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index a5a696b6b16..e39186c1222 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -4950,9 +4950,8 @@ is completely irregular. @end defmac @defmac defsetf access-fn update-fn -This is the simpler of two @code{defsetf} forms, and is entirely -obsolete, being replaced by @code{gv-define-simple-setter} in Emacs -24.3. +This is the simpler of two @code{defsetf} forms, and is +replaced by @code{gv-define-simple-setter} in Emacs 24.3. @xref{Adding Generalized Variables,,,elisp,GNU Emacs Lisp Reference Manual}. Where @var{access-fn} is the name of a function that accesses a place, @@ -4983,8 +4982,9 @@ not suitable, so that the above @code{setf} should be expanded to something more like @example -(prog1 @var{value} - (@var{update-fn} @var{arg1} @var{arg2} @var{arg3} @var{value})) +(let ((temp @var{value})) + (@var{update-fn} @var{arg1} @var{arg2} @var{arg3} temp) + temp) @end example Some examples are: diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 187ff2d7e1d..cfd79fc57ef 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-11-07 Glenn Morris + + * emacs-lisp/gv.el (gv-letplace): Fix doc typo. + (gv-define-simple-setter): Update doc of `fix-return'. + 2012-11-07 Stefan Monnier * emacs-lisp/gv.el (gv-define-simple-setter): Don't evaluate `val' diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index a0c412a9504..145c48c670e 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -111,7 +111,7 @@ DO must return an Elisp expression." GETTER will be bound to a copyable expression that returns the value of PLACE. SETTER will be bound to a function that takes an expression V and returns -and new expression that sets PLACE to V. +a new expression that sets PLACE to V. BODY should return some Elisp expression E manipulating PLACE via GETTER and SETTER. The returned value will then be an Elisp expression that first evaluates @@ -209,8 +209,12 @@ to be pure and copyable. Example use: This macro is an easy-to-use substitute for `gv-define-expander' that works well for simple place forms. Assignments of VAL to (NAME ARGS...) are turned into calls of the form (SETTER ARGS... VAL). + If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and -instead the assignment is turned into (prog1 VAL (SETTER ARGS... VAL)) +instead the assignment is turned into something equivalent to + \(let ((temp VAL)) + (SETTER ARGS... temp) + temp) so as to preserve the semantics of `setf'." (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) `(gv-define-setter ,name (val &rest args) -- cgit v1.2.3 From 031b2ea7f5cefc53885d469c3c37ef68103d49aa Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Wed, 7 Nov 2012 00:56:16 -0800 Subject: More cl-lib and gv doc updates * lisp/emacs-lisp/cl.el (define-setf-expander, defsetf) (define-modify-macro): Doc fixes. * doc/misc/cl.texi (Obsolete Setf Customization): Give defsetf gv.el replacements. * etc/NEWS: Related edit. --- doc/misc/ChangeLog | 2 +- doc/misc/cl.texi | 29 ++++++++++++++++++---------- etc/NEWS | 4 ++-- lisp/ChangeLog | 3 +++ lisp/emacs-lisp/cl.el | 52 ++++++++++++++++++++++++++++++++------------------- 5 files changed, 58 insertions(+), 32 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog index 93a2971f8c6..6951f2df79d 100644 --- a/doc/misc/ChangeLog +++ b/doc/misc/ChangeLog @@ -2,7 +2,7 @@ * cl.texi (Obsolete Setf Customization): Revert defsetf example to the more correct let rather than prog1. - Give define-modify-macro gv.el replacement. + Give define-modify-macro and defsetf gv.el replacements. 2012-11-06 Glenn Morris diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 21750b79c93..d3c9ad6aedf 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -5019,14 +5019,16 @@ These translate directly to @code{gv-define-simple-setter}: @end defmac @defmac defsetf access-fn arglist (store-var) forms@dots{} -This is the second, more complex, form of @code{defsetf}. It is -rather like @code{defmacro} except for the additional @var{store-var} -argument. The @var{forms} should return a Lisp form that stores -the value of @var{store-var} into the generalized variable formed -by a call to @var{access-fn} with arguments described by @var{arglist}. -The @var{forms} may begin with a string which documents the @code{setf} -method (analogous to the doc string that appears at the front of a -function). +This is the second, more complex, form of @code{defsetf}. +It can be replaced by @code{gv-define-setter}. + +This form of @code{defsetf} is rather like @code{defmacro} except for +the additional @var{store-var} argument. The @var{forms} should +return a Lisp form that stores the value of @var{store-var} into the +generalized variable formed by a call to @var{access-fn} with +arguments described by @var{arglist}. The @var{forms} may begin with +a string which documents the @code{setf} method (analogous to the doc +string that appears at the front of a function). For example, the simple form of @code{defsetf} is shorthand for @@ -5041,11 +5043,18 @@ macros like @code{cl-incf} that invoke this setf-method will insert temporary variables as needed to make sure the apparent order of evaluation is preserved. -Another example drawn from the standard package: +Another standard example: @example (defsetf nth (n x) (store) - (list 'setcar (list 'nthcdr n x) store)) + `(setcar (nthcdr ,n ,x) ,store)) +@end example + +You could write this using @code{gv-define-setter} as: + +@example +(gv-define-setter nth (store n x) + `(setcar (nthcdr ,n ,x) ,store)) @end example @end defmac diff --git a/etc/NEWS b/etc/NEWS index 33ec17c1960..76126cf6dda 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -339,8 +339,8 @@ rather than making them unbound. *** The following methods of extending `setf' are obsolete (use features from gv.el instead): `define-modify-macro' (use `gv-letplace') -`defsetf' (use `gv-define-simple-setter', or FIXME) -`define-setf-expander' (use FIXME) +`defsetf' (use `gv-define-simple-setter' or `gv-define-setter') +`define-setf-expander' (use `gv-define-setter' or `gv-define-expander') ** Compilation mode +++ diff --git a/lisp/ChangeLog b/lisp/ChangeLog index cfd79fc57ef..ff9684ad175 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,8 @@ 2012-11-07 Glenn Morris + * emacs-lisp/cl.el (define-setf-expander, defsetf) + (define-modify-macro): Doc fixes. + * emacs-lisp/gv.el (gv-letplace): Fix doc typo. (gv-define-simple-setter): Update doc of `fix-return'. diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 52567f34278..016967bc713 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -547,13 +547,15 @@ deprecated usage of `symbol-function' in place forms)." ; bug#12760 (defmacro define-setf-expander (name arglist &rest body) "Define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). -The argument forms ARGS are bound according to ARGLIST, as if NAME were -going to be expanded as a macro, then the BODY forms are executed and must -return a list of five elements: a temporary-variables list, a value-forms -list, a store-variables list (of length one), a store-form, and an access- -form. See `gv-define-expander', `gv-define-setter', and `gv-define-expander' -for a better and simpler ways to define setf-methods." +This method shows how to handle `setf's to places of the form +\(NAME ARGS...). The argument forms ARGS are bound according to +ARGLIST, as if NAME were going to be expanded as a macro, then +the BODY forms are executed and must return a list of five elements: +a temporary-variables list, a value-forms list, a store-variables list +\(of length one), a store-form, and an access- form. + +See `gv-define-expander', and `gv-define-setter' for better and +simpler ways to define setf-methods." (declare (debug (&define name cl-lambda-list cl-declarations-or-string def-body))) `(progn @@ -566,23 +568,31 @@ for a better and simpler ways to define setf-methods." (defmacro defsetf (name arg1 &rest args) "Define a `setf' method. -This macro is an easy-to-use substitute for `define-setf-expander' that works -well for simple place forms. In the simple `defsetf' form, `setf's of -the form (setf (NAME ARGS...) VAL) are transformed to function or macro -calls of the form (FUNC ARGS... VAL). Example: +This macro is an easy-to-use substitute for `define-setf-expander' +that works well for simple place forms. + +In the simple `defsetf' form, `setf's of the form (setf (NAME +ARGS...) VAL) are transformed to function or macro calls of the +form (FUNC ARGS... VAL). For example: (defsetf aref aset) +You can replace this form with `gv-define-simple-setter'. + Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). -Here, the above `setf' call is expanded by binding the argument forms ARGS -according to ARGLIST, binding the value form VAL to STORE, then executing -BODY, which must return a Lisp form that does the necessary `setf' operation. -Actually, ARGLIST and STORE may be bound to temporary variables which are -introduced automatically to preserve proper execution order of the arguments. -Example: + +Here, the above `setf' call is expanded by binding the argument +forms ARGS according to ARGLIST, binding the value form VAL to +STORE, then executing BODY, which must return a Lisp form that +does the necessary `setf' operation. Actually, ARGLIST and STORE +may be bound to temporary variables which are introduced +automatically to preserve proper execution order of the arguments. +For example: (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) +You can replace this form with `gv-define-setter'. + \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" (declare (debug (&define name @@ -639,8 +649,12 @@ Example: (defmacro define-modify-macro (name arglist func &optional doc) "Define a `setf'-like modify macro. -If NAME is called, it combines its PLACE argument with the other arguments -from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" +If NAME is called, it combines its PLACE argument with the other +arguments from ARGLIST using FUNC. For example: + + (define-modify-macro incf (&optional (n 1)) +) + +You can replace this macro with `gv-letplace'." (declare (debug (&define name cl-lambda-list ;; should exclude &key symbolp &optional stringp))) -- cgit v1.2.3 From 41626722272734aa3a7e4fdfafd3b085133db665 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 7 Nov 2012 20:24:14 -0500 Subject: * lisp/emacs-lisp/gv.el (gv-define-simple-setter): Fix last change. Fixes: debbugs:12812 --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/gv.el | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 98e47dd83d9..6a574f4b26d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-11-08 Stefan Monnier + + * emacs-lisp/gv.el (gv-define-simple-setter): Fix last change + (bug#12812). + 2012-11-07 Chong Yidong * minibuf-eldef.el (minibuffer-eldef-shorten-default): Convert to diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 145c48c670e..38bb6319a03 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -220,7 +220,8 @@ so as to preserve the semantics of `setf'." `(gv-define-setter ,name (val &rest args) ,(if fix-return `(macroexp-let2 nil v val - (cons ',setter (append args (list v)))) + (cons ',setter (append args (list v))) + v) `(cons ',setter (append args (list val)))))) ;;; Typical operations on generalized variables. -- cgit v1.2.3 From d14bb752ea51331ce2fb459c6ffacd8b11f80bb0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 8 Nov 2012 08:34:06 -0500 Subject: * lisp/emacs-lisp/gv.el (gv-ref, gv-deref): New function and macro. --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/gv.el | 18 ++++++++++++++++++ 2 files changed, 22 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7c51b139ec3..e0ff05aa7dc 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2012-11-08 Stefan Monnier + + * emacs-lisp/gv.el (gv-ref, gv-deref): New function and macro. + 2012-11-07 Michael Albinus * notifications.el (notifications-get-server-information-method): diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index d6c91539a90..34e29ba1cbd 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -433,6 +433,24 @@ The return value is the last VAL in the list. `(logior (logand ,v ,mask) (logand ,getter (lognot ,mask)))))))))) +;;; References + +;;;###autoload +(defmacro gv-ref (place) + "Return a reference to PLACE. +This is like the `&' operator of the C language." + (gv-letplace (getter setter) place + `(cons (lambda () ,getter) + (lambda (gv--val) ,(funcall setter 'gv--val))))) + +;;;###autoload +(defsubst gv-deref (ref) + "Dereference REF, returning the referenced value. +This is like the `*' operator of the C language. +REF must have been previously obtained with `gv-ref'." + (declare (gv-setter (lambda (v) `(funcall (cdr ,ref) ,v)))) + (funcall (car ref))) + ;;; Vaguely related definitions that should be moved elsewhere. ;; (defun alist-get (key alist) -- cgit v1.2.3 From 784c1a7b3aae2f43894ba711ae6dd77aa8bb96c7 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 8 Nov 2012 09:21:21 -0500 Subject: * lisp/emacs-lisp/gv.el (gv-ref, gv-deref): New function and macro. --- lisp/ChangeLog | 6 ++++++ lisp/emacs-lisp/gv.el | 1 - 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e0ff05aa7dc..e44f1a7cdff 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,11 @@ 2012-11-08 Stefan Monnier + * emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): + Byte-compile *before* eval in eval-and-compile. + (byte-compile-log-warning): Remove redundant inhibit-read-only. + (byte-compile-file-form-autoload): Don't hide actual definition. + (byte-compile-maybe-guarded): Accept `functionp' as well. + * emacs-lisp/gv.el (gv-ref, gv-deref): New function and macro. 2012-11-07 Michael Albinus diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 34e29ba1cbd..72c2ec60734 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -443,7 +443,6 @@ This is like the `&' operator of the C language." `(cons (lambda () ,getter) (lambda (gv--val) ,(funcall setter 'gv--val))))) -;;;###autoload (defsubst gv-deref (ref) "Dereference REF, returning the referenced value. This is like the `*' operator of the C language. -- cgit v1.2.3 From 32170f7ff2f85378cbafd68ea562fc0da7909941 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 8 Nov 2012 09:36:47 -0500 Subject: * lisp/emacs-lisp/advice.el: Require `cl-lib' at run-time to fix miscompilation of trace.el. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/advice.el | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b141afe67e6..b17f3d9a59e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-11-08 Stefan Monnier + + * emacs-lisp/advice.el: Require `cl-lib' at run-time to fix + miscompilation of trace.el. + 2012-11-08 Glenn Morris * vc/diff-mode.el (diff-remove-trailing-whitespace): Doc fix. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index bd85238e23e..e358c756712 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1709,7 +1709,8 @@ ;; During a normal load this is a noop: (require 'advice-preload "advice.el") (require 'macroexp) -(eval-when-compile (require 'cl-lib)) +;; At run-time also, since ad-do-advised-functions returns code that uses it. +(require 'cl-lib) ;; @@ Variable definitions: ;; ======================== -- cgit v1.2.3 From a9a5c7f69099233a10d54b1c0e2792fdd88454b9 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 8 Nov 2012 09:54:03 -0500 Subject: * lisp/emacs-lisp/gv.el (gv-deref): Move setter declaration, to fix bootstrap. --- lisp/emacs-lisp/gv.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 72c2ec60734..456bace5b1b 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -447,8 +447,11 @@ This is like the `&' operator of the C language." "Dereference REF, returning the referenced value. This is like the `*' operator of the C language. REF must have been previously obtained with `gv-ref'." - (declare (gv-setter (lambda (v) `(funcall (cdr ,ref) ,v)))) (funcall (car ref))) +;; Don't use `declare' because it seems to introduce circularity problems: +;; Warning: Eager macro-expansion skipped due to cycle: +;; … => (load "gv.el") => (macroexpand-all (defsubst gv-deref …)) => (macroexpand (defun …)) => (load "gv.el") +(gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v)) ;;; Vaguely related definitions that should be moved elsewhere. -- cgit v1.2.3 From e703069f9c23dd94b65e1d81ce57758c7f905bb2 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 8 Nov 2012 09:58:15 -0500 Subject: * lisp/emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): Byte-compile *before* eval in eval-and-compile. (byte-compile-log-warning): Remove redundant inhibit-read-only. (byte-compile-file-form-autoload): Don't hide actual definition. (byte-compile-maybe-guarded): Accept `functionp' as well. --- lisp/emacs-lisp/bytecomp.el | 39 +++++++++++++++++++++++++++------------ 1 file changed, 27 insertions(+), 12 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e776df4ef37..9baa95dffaa 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -419,8 +419,8 @@ This list lives partly on the stack.") (defconst byte-compile-initial-macro-environment '( -;; (byte-compiler-options . (lambda (&rest forms) -;; (apply 'byte-compiler-options-handler forms))) + ;; (byte-compiler-options . (lambda (&rest forms) + ;; (apply 'byte-compiler-options-handler forms))) (declare-function . byte-compile-macroexpand-declare-function) (eval-when-compile . (lambda (&rest body) (list @@ -429,8 +429,19 @@ This list lives partly on the stack.") (byte-compile-top-level (byte-compile-preprocess (cons 'progn body))))))) (eval-and-compile . (lambda (&rest body) - (byte-compile-eval-before-compile (cons 'progn body)) - (cons 'progn body)))) + ;; Byte compile before running it. Do it piece by + ;; piece, in case further expressions need earlier + ;; ones to be evaluated already, as is the case in + ;; eieio.el. + `(progn + ,@(mapcar (lambda (exp) + (let ((cexp + (byte-compile-top-level + (byte-compile-preprocess + exp)))) + (eval cexp) + cexp)) + body))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -731,9 +742,11 @@ otherwise pop it") ;; Also, this lets us notice references to free variables. (defmacro byte-compile-push-bytecodes (&rest args) - "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. -ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. -BYTES and PC are updated after evaluating all the arguments." + "Push bytes onto BVAR, and increment CVAR by the number of bytes pushed. +BVAR and CVAR are variables which are updated after evaluating +all the arguments. + +\(fn BYTE1 BYTE2 ... BYTEn BVAR CVAR)" (let ((byte-exprs (butlast args 2)) (bytes-var (car (last args 2))) (pc-var (car (last args)))) @@ -1097,8 +1110,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defun byte-compile-log-warning (string &optional fill level) (let ((warning-prefix-function 'byte-compile-warning-prefix) (warning-type-format "") - (warning-fill-prefix (if fill " ")) - (inhibit-read-only t)) + (warning-fill-prefix (if fill " "))) (display-warning 'bytecomp string level byte-compile-log-buffer))) (defun byte-compile-warn (format &rest args) @@ -2189,7 +2201,10 @@ list that represents a doc string reference. (when (and (consp (nth 1 form)) (eq (car (nth 1 form)) 'quote) (consp (cdr (nth 1 form))) - (symbolp (nth 1 (nth 1 form)))) + (symbolp (nth 1 (nth 1 form))) + ;; Don't add it if it's already defined. Otherwise, it might + ;; hide the actual definition. + (not (fboundp (nth 1 (nth 1 form))))) (push (cons (nth 1 (nth 1 form)) (cons 'autoload (cdr (cdr form)))) byte-compile-function-environment) @@ -3689,10 +3704,10 @@ If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs), that suppresses all warnings during execution of BODY." (declare (indent 1) (debug t)) `(let* ((fbound-list (byte-compile-find-bound-condition - ,condition (list 'fboundp) + ,condition '(fboundp functionp) byte-compile-unresolved-functions)) (bound-list (byte-compile-find-bound-condition - ,condition (list 'boundp 'default-boundp))) + ,condition '(boundp default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables (append bound-list byte-compile-bound-variables))) -- cgit v1.2.3 From 57618ecf3358e49ab3c380330e82ca8d2078cc63 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 8 Nov 2012 23:10:16 -0500 Subject: New property dynamic-docstring-function for docstrings. * src/doc.c (Fdocumentation): Handle new property dynamic-docstring-function to replace the old ad-advice-info. * lisp/emacs-lisp/advice.el: Use new dynamic docstrings. (ad-make-advised-definition-docstring, ad-advised-definition-p): Use dynamic-docstring-function instead of ad-advice-info. (ad--make-advised-docstring): New function extracted from ad-make-advised-docstring. (ad-make-advised-docstring): Use it. * lisp/progmodes/sql.el (sql--make-help-docstring): New function, extracted from sql-help. (sql-help): Use it with dynamic-docstring-function. --- etc/NEWS | 4 ++++ lisp/ChangeLog | 10 ++++++++++ lisp/emacs-lisp/advice.el | 22 +++++++++++++++------- lisp/progmodes/sql.el | 47 +++++++++++++++++++++-------------------------- src/ChangeLog | 5 +++++ src/doc.c | 35 ++++++++++++++++------------------- 6 files changed, 71 insertions(+), 52 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 2b56ea9f540..bb8bcd6cb56 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -29,6 +29,10 @@ so we will look at it and add it to the manual. * New Modes and Packages in Emacs 24.4 * Incompatible Lisp Changes in Emacs 24.4 * Lisp changes in Emacs 24.4 + +** Docstrings can be made dynamic by adding a `dynamic-docstring-function' +text-property on the first char. + * Changes in Emacs 24.4 on non-free operating systems diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b54a3e281af..f0af63ac094 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,15 @@ 2012-11-09 Stefan Monnier + * emacs-lisp/advice.el: Use new dynamic docstrings. + (ad-make-advised-definition-docstring, ad-advised-definition-p): + Use dynamic-docstring-function instead of ad-advice-info. + (ad--make-advised-docstring): New function extracted from + ad-make-advised-docstring. + (ad-make-advised-docstring): Use it. + * progmodes/sql.el (sql--make-help-docstring): New function, extracted + from sql-help. + (sql-help): Use it with dynamic-docstring-function. + * env.el (env--substitute-vars-regexp): Don't use rx (for bootstrap). 2012-11-08 Stefan Monnier diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index bd85238e23e..33805836db2 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2414,13 +2414,15 @@ Like `interactive-form', but also works on pieces of advice." (if (ad-interactive-form definition) 1 0)) (cdr (cdr (ad-lambda-expression definition))))))) -(defun ad-make-advised-definition-docstring (function) +(defun ad-make-advised-definition-docstring (_function) "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 (see the code for `documentation')." - (propertize "Advice doc string" 'ad-advice-info function)) + (eval-when-compile + (propertize "Advice doc string" 'dynamic-docstring-function + #'ad--make-advised-docstring))) (defun ad-advised-definition-p (definition) "Return non-nil if DEFINITION was generated from advice information." @@ -2429,7 +2431,7 @@ definition (see the code for `documentation')." (ad-compiled-p definition)) (let ((docstring (ad-docstring definition))) (and (stringp docstring) - (get-text-property 0 'ad-advice-info docstring))))) + (get-text-property 0 'dynamic-docstring-function docstring))))) (defun ad-definition-type (definition) "Return symbol that describes the type of DEFINITION." @@ -2752,6 +2754,13 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage. (defun ad-make-advised-docstring (function &optional style) + (let* ((origdef (ad-real-orig-definition function)) + (origdoc + ;; Retrieve raw doc, key substitution will be taken care of later: + (ad-real-documentation origdef t))) + (ad--make-advised-docstring origdoc function style))) + +(defun ad--make-advised-docstring (origdoc function &optional style) "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 @@ -2761,9 +2770,6 @@ strings corresponds to before/around/after and the individual ordering in any of these classes." (let* ((origdef (ad-real-orig-definition function)) (origtype (symbol-name (ad-definition-type origdef))) - (origdoc - ;; Retrieve raw doc, key substitution will be taken care of later: - (ad-real-documentation origdef t)) (usage (help-split-fundoc origdoc function)) paragraphs advice-docstring ad-usage) (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) @@ -2780,7 +2786,9 @@ in any of these classes." (propertize ;; separate paragraphs with blank lines: (mapconcat 'identity (nreverse paragraphs) "\n\n") - 'ad-advice-info function))) + ;; FIXME: what is this for? + 'dynamic-docstring-function + #'ad--make-advised-docstring))) (help-add-fundoc-usage origdoc usage))) (defun ad-make-plain-docstring (function) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 3d5abc4df62..64b87d9e436 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -2802,8 +2802,12 @@ each line with INDENT." doc)) ;;;###autoload -(defun sql-help () - "Show short help for the SQL modes. +(eval + ;; FIXME: This dynamic-docstring-function trick doesn't work for byte-compiled + ;; functions, because of the lazy-loading of docstrings, which strips away + ;; text properties. + '(defun sql-help () + #("Show short help for the SQL modes. Use an entry function to open an interactive SQL buffer. This buffer is usually named `*SQL*'. The name of the major mode is SQLi. @@ -2834,32 +2838,23 @@ anything. The name of the major mode is SQL. In this SQL buffer (SQL mode), you can send the region or the entire buffer to the interactive SQL buffer (SQLi mode). The results are appended to the SQLi buffer without disturbing your SQL buffer." + 0 1 (dynamic-docstring-function sql--make-help-docstring)) (interactive) + (describe-function 'sql-help))) - ;; Insert references to loaded products into the help buffer string - (let ((doc (documentation 'sql-help t)) - changedp) - (setq changedp nil) - - ;; Insert FREE software list - (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]FREE\\s-*\n" doc 0) - (setq doc (replace-match (sql-help-list-products (match-string 1 doc) t) - t t doc 0) - changedp t)) - - ;; Insert non-FREE software list - (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]NONFREE\\s-*\n" doc 0) - (setq doc (replace-match (sql-help-list-products (match-string 1 doc) nil) - t t doc 0) - changedp t)) - - ;; If we changed the help text, save the change so that the help - ;; sub-system will see it - (when changedp - (put 'sql-help 'function-documentation doc))) - - ;; Call help on this function - (describe-function 'sql-help)) +(defun sql--make-help-docstring (doc _fun) + "Insert references to loaded products into the help buffer string." + + ;; Insert FREE software list + (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]FREE\\s-*\n" doc 0) + (setq doc (replace-match (sql-help-list-products (match-string 1 doc) t) + t t doc 0))) + + ;; Insert non-FREE software list + (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]NONFREE\\s-*\n" doc 0) + (setq doc (replace-match (sql-help-list-products (match-string 1 doc) nil) + t t doc 0))) + doc) (defun sql-read-passwd (prompt &optional default) "Read a password using PROMPT. Optional DEFAULT is password to start with." diff --git a/src/ChangeLog b/src/ChangeLog index 42c63b21e95..9bd6ccec017 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2012-11-09 Stefan Monnier + + * doc.c (Fdocumentation): Handle new property + dynamic-docstring-function to replace the old ad-advice-info. + 2012-11-09 Paul Eggert * fns.c (Qeql, hashtest_eq): Now static. diff --git a/src/doc.c b/src/doc.c index 9ead1addfba..1d3d1e64442 100644 --- a/src/doc.c +++ b/src/doc.c @@ -21,7 +21,7 @@ along with GNU Emacs. If not, see . */ #include #include -#include /* Must be after sys/types.h for USG*/ +#include /* Must be after sys/types.h for USG. */ #include #include @@ -42,7 +42,7 @@ static ptrdiff_t get_doc_string_buffer_size; static unsigned char *read_bytecode_pointer; -/* readchar in lread.c calls back here to fetch the next byte. +/* `readchar' in lread.c calls back here to fetch the next byte. If UNREADFLAG is 1, we unread a byte. */ int @@ -338,15 +338,9 @@ string is passed through `substitute-command-keys'. */) doc = Qnil; - if (SYMBOLP (function)) - { - Lisp_Object tem = Fget (function, Qfunction_documentation); - if (!NILP (tem)) - return Fdocumentation_property (function, Qfunction_documentation, - raw); - } - fun = Findirect_function (function, Qnil); + if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) + fun = XCDR (fun); if (SUBRP (fun)) { if (XSUBR (fun)->doc == 0) @@ -400,8 +394,6 @@ string is passed through `substitute-command-keys'. */) else return Qnil; } - else if (EQ (funcar, Qmacro)) - return Fdocumentation (Fcdr (fun), raw); else goto oops; } @@ -411,16 +403,19 @@ string is passed through `substitute-command-keys'. */) xsignal1 (Qinvalid_function, fun); } - /* Check for an advised function. Its doc string - has an `ad-advice-info' text property. */ + /* Check for a dynamic docstring. These come with + a dynamic-docstring-function text property. */ if (STRINGP (doc)) { - Lisp_Object innerfunc; - innerfunc = Fget_text_property (make_number (0), - intern ("ad-advice-info"), + Lisp_Object func + = Fget_text_property (make_number (0), + intern ("dynamic-docstring-function"), doc); - if (! NILP (innerfunc)) - doc = call1 (intern ("ad-make-advised-docstring"), innerfunc); + if (!NILP (func)) + /* Pass both `doc' and `function' since `function' can be needed, and + finding `doc' can be annoying: calling `documentation' is not an + option because it would infloop. */ + doc = call2 (func, doc, function); } /* If DOC is 0, it's typically because of a dumped file missing @@ -528,6 +523,8 @@ store_function_docstring (Lisp_Object obj, ptrdiff_t offset) { tem = Fcdr (Fcdr (fun)); if (CONSP (tem) && INTEGERP (XCAR (tem))) + /* FIXME: This modifies typically pure hash-cons'd data, so its + correctness is quite delicate. */ XSETCAR (tem, make_number (offset)); } else if (EQ (tem, Qmacro)) -- cgit v1.2.3 From f5925cd9f5e525c1e023c163338ccbf6c19e9ef0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 9 Nov 2012 10:56:51 -0500 Subject: * lisp/emacs-lisp/bytecomp.el (byte-compile-out-toplevel): Don't turn (funcall '(lambda ..) ..) into ((lambda ..) ..). --- lisp/ChangeLog | 23 ++++++++++++++--------- lisp/emacs-lisp/bytecomp.el | 3 ++- 2 files changed, 16 insertions(+), 10 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d7cb2143d36..a7f6d1befb5 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,15 +1,20 @@ +2012-11-09 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-out-toplevel): Don't turn + (funcall '(lambda ..) ..) into ((lambda ..) ..). + 2012-11-09 Vincent Belaïche * ses.el: symbol to coordinate mapping is made by symbol property - `ses-cell'. This means that the same mapping is done for all SES - sheets. That is good enough for cells with standard A1 names, but - not for named cell. So a hash map is added for those - latter. - (defconst ses-localvars): added local variable ses--named-cell-hashmap + `ses-cell'. This means that the same mapping is done for all SES + sheets. That is good enough for cells with standard A1 names, but + not for named cell. So a hash map is added for the latter. + (defconst ses-localvars): Add local variable ses--named-cell-hashmap (ses-sym-rowcol): Use hashmap for named cell. (ses-is-cell-sym-p): New defun. (ses-decode-cell-symbol): New defun. - (ses-create-cell-variable): Add cell to hashmap when name is not A1-like. + (ses-create-cell-variable): Add cell to hashmap when name is not + A1-like. (ses-rename-cell): Check that cell new name is not already in spreadsheet with the use of ses-is-cell-sym-p (ses-rename-cell): Use hash map for named cells, but accept also @@ -120,8 +125,8 @@ 2012-11-05 Agustín Martín Domingo - * textmodes/ispell.el (ispell-program-name): Update - spellchecker parameters when customized. + * textmodes/ispell.el (ispell-program-name): + Update spellchecker parameters when customized. 2012-11-04 Glenn Morris @@ -515,7 +520,7 @@ 2012-10-19 Stefan Monnier * minibuffer.el (minibuffer-force-complete): Make the next completion use - the same completion-field (bug@12221). + the same completion-field (bug#12221). 2012-10-19 Martin Rudalics diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9baa95dffaa..a325e0f3e44 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2823,7 +2823,8 @@ for symbols generated by the byte compiler itself." (setq body (nreverse body)) (setq body (list (if (and (eq tmp 'funcall) - (eq (car-safe (car body)) 'quote)) + (eq (car-safe (car body)) 'quote) + (symbolp (nth 1 (car body)))) (cons (nth 1 (car body)) (cdr body)) (cons tmp body)))) (or (eq output-type 'file) -- cgit v1.2.3 From 6858633a9c9f7e764e017cc5cbf77516729d120b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 9 Nov 2012 15:41:03 -0500 Subject: * lisp/emacs-lisp/advice.el: Miscellaneous cleanup. Use lexical-binding. (fset, documentation): Don't save real def since we don't advise. (ad-do-advised-functions): Remove problematic `result-form'. (ad-safe-fset): `ad-real-fset' => `fset'. (ad-read-advised-function): Don't assume that ad-do-advised-functions uses CL's dolist internally. (ad-arglist): Remove unused arg `name'. (ad-docstring, ad-make-advised-docstring): `ad-real-documentation' => `documentation'. (warning-suppress-types): Declare. (ad-set-arguments): Simple CSE. (ad-recover-normality): Sanity check. --- lisp/ChangeLog | 13 ++++ lisp/emacs-lisp/advice.el | 157 ++++++++++++++++++++-------------------------- 2 files changed, 80 insertions(+), 90 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a7f6d1befb5..612cdc33d52 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,18 @@ 2012-11-09 Stefan Monnier + * emacs-lisp/advice.el: Miscellaneous cleanup. Use lexical-binding. + (fset, documentation): Don't save real def since we don't advise. + (ad-do-advised-functions): Remove problematic `result-form'. + (ad-safe-fset): `ad-real-fset' => `fset'. + (ad-read-advised-function): Don't assume that ad-do-advised-functions + uses CL's dolist internally. + (ad-arglist): Remove unused arg `name'. + (ad-docstring, ad-make-advised-docstring): + `ad-real-documentation' => `documentation'. + (warning-suppress-types): Declare. + (ad-set-arguments): Simple CSE. + (ad-recover-normality): Sanity check. + * emacs-lisp/bytecomp.el (byte-compile-out-toplevel): Don't turn (funcall '(lambda ..) ..) into ((lambda ..) ..). diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 33805836db2..92becb8bea9 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,4 +1,4 @@ -;;; advice.el --- An overloading mechanism for Emacs Lisp functions +;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*- ;; Copyright (C) 1993-1994, 2000-2012 Free Software Foundation, Inc. @@ -1795,15 +1795,6 @@ generates a copy of TREE." `((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 - ;; properties into the compiled version of this function such that the - ;; proper values will be available at runtime without loading the compiler: - (ad-save-real-definition fset) - (ad-save-real-definition documentation)) - -(ad-save-real-definitions) - ;; @@ Advice info access fns: ;; ========================== @@ -1839,15 +1830,13 @@ generates a copy of TREE." 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]) + "`dolist'-style iterator that maps over advised functions. +\(ad-do-advised-functions (VAR) BODY-FORM...) On each iteration VAR will be bound to the name of an advised function \(a symbol)." (declare (indent 1)) - `(cl-dolist (,(car varform) - ad-advised-functions - ,(car (cdr varform))) + `(cl-dolist (,(car varform) ad-advised-functions) (setq ,(car varform) (intern (car ,(car varform)))) ,@body)) @@ -1866,7 +1855,7 @@ On each iteration VAR will be bound to the name of an advised function (defmacro ad-is-advised (function) "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-macro function)) + `(ad-get-advice-info-macro ,function)) (defun ad-initialize-advice-info (function) "Initialize the advice info for FUNCTION. @@ -1949,7 +1938,7 @@ Redefining advices affect the construction of an advised definition." (defun ad-has-any-advice (function) "True if the advice info of FUNCTION defines at least one advice." (and (ad-is-advised function) - (cl-dolist (class ad-advice-classes nil) + (cl-dolist (class ad-advice-classes) (if (ad-get-advice-info-field function class) (cl-return t))))) @@ -1989,12 +1978,12 @@ Redefining advices affect the construction of an advised definition." ;; appropriate, especially in a safe version of `fset'. ;; For now define `ad-activate-internal' to the dummy definition: -(defun ad-activate-internal (function &optional compile) +(defun ad-activate-internal (_function &optional _compile) "Automatic advice activation is disabled. `ad-start-advice' enables it." nil) ;; This is just a copy of the above: -(defun ad-activate-internal-off (function &optional compile) +(defun ad-activate-internal-off (_function &optional _compile) "Automatic advice activation is disabled. `ad-start-advice' enables it." nil) @@ -2008,7 +1997,7 @@ Redefining advices affect the construction of an advised definition." (defun ad-safe-fset (symbol definition) "A safe `fset' which will never call `ad-activate-internal' recursively." (ad-with-auto-activation-disabled - (ad-real-fset symbol definition))) + (fset symbol definition))) ;; @@ Access functions for original definitions: @@ -2052,7 +2041,7 @@ function at point for which PREDICATE returns non-nil)." (error "ad-read-advised-function: There are no advised functions")) (setq default (or default - ;; Prefer func name at point, if it's in ad-advised-functions etc. + ;; Prefer func name at point, if it's an advised function etc. (let ((function (progn (require 'help) (function-called-at-point)))) @@ -2061,24 +2050,20 @@ function at point for which PREDICATE returns non-nil)." (or (null predicate) (funcall predicate function)) function)) - (ad-do-advised-functions (function) - (if (or (null predicate) - (funcall predicate function)) - (cl-return function))) + (cl-block nil + (ad-do-advised-functions (function) + (if (or (null predicate) + (funcall predicate function)) + (cl-return function)))) (error "ad-read-advised-function: %s" "There are no qualifying advised functions"))) - (let* ((ad-pReDiCaTe predicate) - (function + (let* ((function (completing-read (format "%s (default %s): " (or prompt "Function") default) ad-advised-functions (if predicate - (function - (lambda (function) - ;; Oops, no closures - the joys of dynamic scoping: - ;; `predicate' clashed with the `predicate' argument - ;; of `completing-read'..... - (funcall ad-pReDiCaTe (intern (car function)))))) + (lambda (function) + (funcall predicate (intern (car function))))) t))) (if (equal function "") (if (ad-is-advised default) @@ -2376,10 +2361,8 @@ See Info node `(elisp)Computed Advice' for detailed documentation." (cdr definition)) (t nil))) -(defun ad-arglist (definition &optional name) - "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." +(defun ad-arglist (definition) + "Return the argument list of DEFINITION." (require 'help-fns) (help-function-arglist (if (or (ad-macro-p definition) (ad-advice-p definition)) @@ -2391,7 +2374,7 @@ supplied to make subr arglist lookup more efficient." "Return the unexpanded docstring of DEFINITION." (let ((docstring (if (ad-compiled-p definition) - (ad-real-documentation definition t) + (documentation definition t) (car (cdr (cdr (ad-lambda-expression definition))))))) (if (or (stringp docstring) (natnump docstring)) @@ -2475,6 +2458,7 @@ For that it has to be fbound with a non-autoload definition." (ad-macro-p (symbol-function function))) (not (ad-compiled-p (symbol-function function))))) +(defvar warning-suppress-types) ;From warnings.el. (defun ad-compile-function (function) "Byte-compiles FUNCTION (or macro) if it is not yet compiled." (interactive "aByte-compile function: ") @@ -2605,24 +2589,20 @@ The assignment starts at position INDEX." (let ((values-index 0) argument-access set-forms) (while (setq argument-access (ad-access-argument arglist index)) - (if (symbolp argument-access) - (setq set-forms - (cons (ad-set-argument - arglist index - (ad-element-access values-index 'ad-vAlUeS)) - set-forms)) - (setq set-forms - (cons (if (= (car argument-access) 0) - (list 'setq - (car (cdr argument-access)) - (ad-list-access values-index 'ad-vAlUeS)) - (list 'setcdr - (ad-list-access (1- (car argument-access)) - (car (cdr argument-access))) - (ad-list-access values-index 'ad-vAlUeS))) - set-forms)) - ;; terminate loop - (setq arglist nil)) + (push (if (symbolp argument-access) + (ad-set-argument + arglist index + (ad-element-access values-index 'ad-vAlUeS)) + (setq arglist nil) ;; Terminate loop. + (if (= (car argument-access) 0) + `(setq + ,(car (cdr argument-access)) + ,(ad-list-access values-index 'ad-vAlUeS)) + `(setcdr + ,(ad-list-access (1- (car argument-access)) + (car (cdr argument-access))) + ,(ad-list-access values-index 'ad-vAlUeS)))) + set-forms) (setq index (1+ index)) (setq values-index (1+ values-index))) (if (null set-forms) @@ -2631,8 +2611,8 @@ The assignment starts at position INDEX." (if (= (length set-forms) 1) ;; For exactly one set-form we can use values-form directly,... (ad-substitute-tree - (function (lambda (form) (eq form 'ad-vAlUeS))) - (function (lambda (form) values-form)) + (lambda (form) (eq form 'ad-vAlUeS)) + (lambda (_form) values-form) (car set-forms)) ;; ...if we have more we have to bind it to a variable: `(let ((ad-vAlUeS ,values-form)) @@ -2702,11 +2682,10 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (cond (need-apply ;; `apply' can take care of that directly: (append source-reqopt-args (list source-rest-arg))) - (t (mapcar (function - (lambda (arg) - (setq target-arg-index (1+ target-arg-index)) - (ad-get-argument - source-arglist target-arg-index))) + (t (mapcar (lambda (_arg) + (setq target-arg-index (1+ target-arg-index)) + (ad-get-argument + source-arglist target-arg-index)) (append target-reqopt-args (and target-rest-arg ;; If we have a rest arg gobble up @@ -2757,7 +2736,7 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (let* ((origdef (ad-real-orig-definition function)) (origdoc ;; Retrieve raw doc, key substitution will be taken care of later: - (ad-real-documentation origdef t))) + (documentation origdef t))) (ad--make-advised-docstring origdoc function style))) (defun ad--make-advised-docstring (origdoc function &optional style) @@ -2771,7 +2750,7 @@ in any of these classes." (let* ((origdef (ad-real-orig-definition function)) (origtype (symbol-name (ad-definition-type origdef))) (usage (help-split-fundoc origdoc function)) - paragraphs advice-docstring ad-usage) + paragraphs advice-docstring) (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) (if origdoc (setq paragraphs (list origdoc))) (unless (eq style 'plain) @@ -2834,7 +2813,7 @@ in any of these classes." (orig-special-form-p (ad-special-form-p origdef)) (orig-macro-p (ad-macro-p origdef)) ;; Construct the individual pieces that we need for assembly: - (orig-arglist (ad-arglist origdef function)) + (orig-arglist (ad-arglist origdef)) (advised-arglist (or (ad-advised-arglist function) orig-arglist)) (advised-interactive-form (ad-advised-interactive-form function)) @@ -2929,8 +2908,8 @@ should be modified. The assembled function will be returned." (setq around-form-protected t)) (setq around-form (ad-substitute-tree - (function (lambda (form) (eq form 'ad-do-it))) - (function (lambda (form) around-form)) + (lambda (form) (eq form 'ad-do-it)) + (lambda (_form) around-form) (macroexp-progn (ad-body-forms (ad-advice-definition advice)))))) (setq after-forms @@ -3065,10 +3044,10 @@ advised definition from scratch." (mapcar (function (lambda (advice) (ad-advice-name advice))) (ad-get-enabled-advices function 'after)) (ad-definition-type original-definition) - (if (equal (ad-arglist original-definition function) + (if (equal (ad-arglist original-definition) (ad-arglist cached-definition)) t - (ad-arglist original-definition function)) + (ad-arglist original-definition)) (if (eq (ad-definition-type original-definition) 'function) (equal (interactive-form original-definition) (interactive-form cached-definition)))))) @@ -3113,7 +3092,7 @@ advised definition from scratch." (and (eq (nth 3 cache-id) (ad-definition-type original-definition)) (setq code 'arglist-mismatch) (equal (if (eq (nth 4 cache-id) t) - (ad-arglist original-definition function) + (ad-arglist original-definition) (nth 4 cache-id) ) (ad-arglist cached-definition)) (setq code 'interactive-form-mismatch) @@ -3227,7 +3206,7 @@ advised definition from scratch." (ad-safe-fset 'ad-make-advised-definition-docstring 'ad-make-freeze-docstring) ;; Make sure `unique-origname' is used as the origname: - (ad-safe-fset 'ad-make-origname (lambda (x) unique-origname)) + (ad-safe-fset 'ad-make-origname (lambda (_x) unique-origname)) ;; No we reset all current advice information to nil and ;; generate an advised definition that's solely determined ;; by ADVICE and the current origdef of FUNCTION: @@ -3677,28 +3656,24 @@ undone on exit of this macro." ;; 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)) + (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 - (function - (lambda (function) - (setq index (1+ index)) - `(ad-safe-fset - ',function - ,(car (nth index current-bindings))))) - functions)))))) + (mapcar (lambda (function) + (setq index (1+ index)) + `(ad-safe-fset + ',function + ,(car (nth index current-bindings)))) + functions)))))) ;; @@ Starting, stopping and recovering from the advice package magic: @@ -3727,7 +3702,9 @@ Use only in REAL emergencies." (ad-set-advice-info 'ad-activate-internal nil) (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off) (ad-recover-all) - (setq ad-advised-functions nil)) + (ad-do-advised-functions (function) + (message "Oops! Left over advised function %S" function) + (ad-pop-advised-function function))) (ad-start-advice) -- cgit v1.2.3 From 32e5c58ca969ec30d31520da52c9866cafa62927 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 9 Nov 2012 17:20:47 -0500 Subject: Provide new `defalias-fset-function' symbol property. * src/lisp.h (AUTOLOADP): New macro. * src/eval.c (Fautoload): Don't attach to loadhist, call Fdefalias instead. * src/data.c (Ffset): Remove special ad-advice-info handling. (Fdefalias): Handle autoload definitions and new Qdefalias_fset_function. (Fsubr_arity): CSE. (Finteractive_form): Simplify. (Fquo): Don't insist on having at least 2 arguments. (Qdefalias_fset_function): New var. * lisp/emacs-lisp/advice.el (ad-set-advice-info): Set defalias-fset-function. (ad--defalias-fset): New function. (ad-safe-fset): Remove. (ad-make-freeze-definition): Use cl-letf*. --- etc/NEWS | 3 + lisp/ChangeLog | 7 +++ lisp/emacs-lisp/advice.el | 150 +++++++++++++++++++++------------------------- src/ChangeLog | 13 +++- src/data.c | 71 +++++++++++----------- src/eval.c | 21 +++---- src/lisp.h | 2 + 7 files changed, 134 insertions(+), 133 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 177f91066ac..dd8ad72ba94 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -38,6 +38,9 @@ spurious warnings about an unused var. ** Docstrings can be made dynamic by adding a `dynamic-docstring-function' text-property on the first char. +** The `defalias-fset-function' property lets you catch calls to defalias +and redirect them to your own function instead of `fset'. + * Changes in Emacs 24.4 on non-free operating systems diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6f10e311eac..a07749e4f18 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2012-11-09 Stefan Monnier + + * emacs-lisp/advice.el (ad-set-advice-info): Set defalias-fset-function. + (ad--defalias-fset): New function. + (ad-safe-fset): Remove. + (ad-make-freeze-definition): Use cl-letf*. + 2012-11-09 Stefan Monnier * subr.el (dolist): Don't bind VAR in RESULT. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 92becb8bea9..42c25a4613d 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1846,8 +1846,12 @@ On each iteration VAR will be bound to the name of an advised function (defmacro ad-get-advice-info-macro (function) `(get ,function 'ad-advice-info)) -(defmacro ad-set-advice-info (function advice-info) - `(put ,function 'ad-advice-info ,advice-info)) +(defsubst ad-set-advice-info (function advice-info) + (cond + (advice-info (put function 'defalias-fset-function #'ad--defalias-fset)) + ((get function 'defalias-fset-function) + (put function 'defalias-fset-function nil))) + (put function 'ad-advice-info advice-info)) (defmacro ad-copy-advice-info (function) `(copy-tree (get ,function 'ad-advice-info))) @@ -1954,18 +1958,10 @@ Redefining advices affect the construction of an advised definition." ;; @@ Dealing with automatic advice activation via `fset/defalias': ;; ================================================================ -;; Since Emacs 19.26 the built-in versions of `fset' and `defalias' -;; take care of automatic advice activation, hence, we don't have to -;; hack it anymore by advising `fset/defun/defmacro/byte-code/etc'. +;; Automatic activation happens when a function gets defined via `defalias', +;; which calls the `defalias-fset-function' (which we set to +;; `ad--defalias-fset') instead of `fset', if non-nil. -;; The functionality of the new `fset' is as follows: -;; -;; fset(sym,newdef) -;; assign NEWDEF to SYM -;; if (get SYM 'ad-advice-info) -;; ad-activate-internal(SYM, nil) -;; return (symbol-function SYM) -;; ;; Whether advised definitions created by automatic activations will be ;; compiled depends on the value of `ad-default-compilation-action'. @@ -1977,6 +1973,10 @@ Redefining advices affect the construction of an advised definition." ;; to `ad-activate' by using `ad-with-auto-activation-disabled' where ;; appropriate, especially in a safe version of `fset'. +(defun ad--defalias-fset (function definition) + (fset function definition) + (ad-activate-internal function nil)) + ;; For now define `ad-activate-internal' to the dummy definition: (defun ad-activate-internal (_function &optional _compile) "Automatic advice activation is disabled. `ad-start-advice' enables it." @@ -1994,12 +1994,6 @@ Redefining advices affect the construction of an advised definition." `(let ((ad-activate-on-top-level nil)) ,@body)) -(defun ad-safe-fset (symbol definition) - "A safe `fset' which will never call `ad-activate-internal' recursively." - (ad-with-auto-activation-disabled - (fset symbol definition))) - - ;; @@ Access functions for original definitions: ;; ============================================ ;; The advice-info of an advised function contains its `origname' which is @@ -2019,8 +2013,7 @@ Redefining advices affect the construction of an advised definition." (symbol-function origname)))) (defmacro ad-set-orig-definition (function definition) - `(ad-safe-fset - (ad-get-advice-info-field ,function 'origname) ,definition)) + `(fset (ad-get-advice-info-field ,function 'origname) ,definition)) (defmacro ad-clear-orig-definition (function) `(fmakunbound (ad-get-advice-info-field ,function 'origname))) @@ -3151,7 +3144,7 @@ advised definition from scratch." (ad-set-advice-info function old-advice-info) ;; Don't `fset' function to nil if it was previously unbound: (if function-defined-p - (ad-safe-fset function old-definition) + (fset function old-definition) (fmakunbound function))))) @@ -3182,61 +3175,54 @@ advised definition from scratch." (error "ad-make-freeze-definition: `%s' is not yet defined" function)) - (let* ((name (ad-advice-name advice)) - ;; With a unique origname we can have multiple freeze advices - ;; for the same function, each overloading the previous one: - (unique-origname - (intern (format "%s-%s-%s" (ad-make-origname function) class name))) - (orig-definition - ;; If FUNCTION is already advised, we'll use its current origdef - ;; as the original definition of the frozen advice: - (or (ad-get-orig-definition function) - (symbol-function function))) - (old-advice-info - (if (ad-is-advised function) - (ad-copy-advice-info function))) - (real-docstring-fn - (symbol-function 'ad-make-advised-definition-docstring)) - (real-origname-fn - (symbol-function 'ad-make-origname)) - (frozen-definition - (unwind-protect - (progn - ;; Make sure we construct a proper docstring: - (ad-safe-fset 'ad-make-advised-definition-docstring - 'ad-make-freeze-docstring) - ;; Make sure `unique-origname' is used as the origname: - (ad-safe-fset 'ad-make-origname (lambda (_x) unique-origname)) - ;; No we reset all current advice information to nil and - ;; generate an advised definition that's solely determined - ;; by ADVICE and the current origdef of FUNCTION: - (ad-set-advice-info function nil) - (ad-add-advice function advice class position) - ;; The following will provide proper real docstrings as - ;; well as a definition that will make the compiler happy: - (ad-set-orig-definition function orig-definition) - (ad-make-advised-definition function)) - ;; Restore the old advice state: - (ad-set-advice-info function old-advice-info) - ;; Restore functions: - (ad-safe-fset - 'ad-make-advised-definition-docstring real-docstring-fn) - (ad-safe-fset 'ad-make-origname real-origname-fn)))) + (cl-letf* + ((name (ad-advice-name advice)) + ;; With a unique origname we can have multiple freeze advices + ;; for the same function, each overloading the previous one: + (unique-origname + (intern (format "%s-%s-%s" (ad-make-origname function) class name))) + (orig-definition + ;; If FUNCTION is already advised, we'll use its current origdef + ;; as the original definition of the frozen advice: + (or (ad-get-orig-definition function) + (symbol-function function))) + (old-advice-info + (if (ad-is-advised function) + (ad-copy-advice-info function))) + ;; Make sure we construct a proper docstring: + ((symbol-function 'ad-make-advised-definition-docstring) + #'ad-make-freeze-docstring) + ;; Make sure `unique-origname' is used as the origname: + ((symbol-function 'ad-make-origname) (lambda (_x) unique-origname)) + (frozen-definition + (unwind-protect + (progn + ;; No we reset all current advice information to nil and + ;; generate an advised definition that's solely determined + ;; by ADVICE and the current origdef of FUNCTION: + (ad-set-advice-info function nil) + (ad-add-advice function advice class position) + ;; The following will provide proper real docstrings as + ;; well as a definition that will make the compiler happy: + (ad-set-orig-definition function orig-definition) + (ad-make-advised-definition function)) + ;; Restore the old advice state: + (ad-set-advice-info function old-advice-info)))) (if frozen-definition (let* ((macro-p (ad-macro-p frozen-definition)) (body (cdr (if macro-p (ad-lambdafy frozen-definition) - 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)))))) + (if (not (fboundp ',unique-origname)) + (fset ',unique-origname + ;; avoid infinite recursion in case the function + ;; we want to freeze is already advised: + (or (ad-get-orig-definition ',function) + (symbol-function ',function)))) + (,(if macro-p 'defmacro 'defun) + ,function + ,@body)))))) ;; @@ Activation and definition handling: @@ -3269,7 +3255,7 @@ 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)))) - (ad-safe-fset function + (fset function (or verified-cached-definition (ad-make-advised-definition function))) (if (ad-should-compile function compile) @@ -3311,7 +3297,7 @@ the value of `ad-redefinition-action' and de/activate again." (error "ad-handle-definition (see its doc): `%s' %s" function "invalidly redefined") (if (eq ad-redefinition-action 'discard) - (ad-safe-fset function original-definition) + (fset function original-definition) (ad-set-orig-definition function current-definition) (if (eq ad-redefinition-action 'warn) (message "ad-handle-definition: `%s' got redefined" @@ -3386,7 +3372,7 @@ a call to `ad-activate'." (if (not (ad-get-orig-definition function)) (error "ad-deactivate: `%s' has no original definition" function) - (ad-safe-fset function (ad-get-orig-definition function)) + (fset function (ad-get-orig-definition function)) (ad-set-advice-info-field function 'active nil) (eval (ad-make-hook-form function 'deactivation)) function))))) @@ -3424,7 +3410,7 @@ Use in emergencies." (completing-read "Recover advised function: " obarray nil t)))) (cond ((ad-is-advised function) (cond ((ad-get-orig-definition function) - (ad-safe-fset function (ad-get-orig-definition function)) + (fset function (ad-get-orig-definition function)) (ad-clear-orig-definition function))) (ad-set-advice-info function nil) (ad-pop-advised-function function)))) @@ -3658,8 +3644,7 @@ undone on exit of this macro." (setq index -1) (mapcar (lambda (function) (setq index (1+ index)) - `(ad-safe-fset - ',function + `(fset ',function (or (ad-get-orig-definition ',function) ,(car (nth index current-bindings))))) functions)) @@ -3670,8 +3655,7 @@ undone on exit of this macro." (setq index -1) (mapcar (lambda (function) (setq index (1+ index)) - `(ad-safe-fset - ',function + `(fset ',function ,(car (nth index current-bindings)))) functions)))))) @@ -3684,7 +3668,7 @@ undone on exit of this macro." (interactive) ;; Advising `ad-activate-internal' means death!! (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate)) + (fset 'ad-activate-internal 'ad-activate)) (defun ad-stop-advice () "Stop the automatic advice handling magic. @@ -3692,7 +3676,7 @@ You should only need this in case of Advice-related emergencies." (interactive) ;; Advising `ad-activate-internal' means death!! (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off)) + (fset 'ad-activate-internal 'ad-activate-internal-off)) (defun ad-recover-normality () "Undo all advice related redefinitions and unadvises everything. @@ -3700,7 +3684,7 @@ Use only in REAL emergencies." (interactive) ;; Advising `ad-activate-internal' means death!! (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off) + (fset 'ad-activate-internal 'ad-activate-internal-off) (ad-recover-all) (ad-do-advised-functions (function) (message "Oops! Left over advised function %S" function) diff --git a/src/ChangeLog b/src/ChangeLog index 43d60936d70..da3e96bbcc3 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,14 @@ +2012-11-09 Stefan Monnier + + * lisp.h (AUTOLOADP): New macro. + * eval.c (Fautoload): Don't attach to loadhist, call Fdefalias instead. + * data.c (Ffset): Remove special ad-advice-info handling. + (Fdefalias): Handle autoload definitions and new Qdefalias_fset_function. + (Fsubr_arity): CSE. + (Finteractive_form): Simplify. + (Fquo): Don't insist on having at least 2 arguments. + (Qdefalias_fset_function): New var. + 2012-11-09 Jan Djärv * image.c (xpm_make_color_table_h): Change to hashtest_equal. @@ -26,7 +37,7 @@ 2012-11-09 Jan Djärv - * nsfont.m (ns_descriptor_to_entity): Qcondesed and Qexpanded has + * nsfont.m (ns_descriptor_to_entity): Qcondensed and Qexpanded has been removed, so remove them here also. 2012-11-09 Stefan Monnier diff --git a/src/data.c b/src/data.c index abcdd4dca0d..663e25e7063 100644 --- a/src/data.c +++ b/src/data.c @@ -80,7 +80,7 @@ static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; -Lisp_Object Qinteractive_form; +Lisp_Object Qinteractive_form, Qdefalias_fset_function; static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *); @@ -444,7 +444,7 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, } -/* Extract and set components of lists */ +/* Extract and set components of lists. */ DEFUN ("car", Fcar, Scar, 1, 1, 0, doc: /* Return the car of LIST. If arg is nil, return nil. @@ -608,27 +608,18 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, (register Lisp_Object symbol, Lisp_Object definition) { register Lisp_Object function; - CHECK_SYMBOL (symbol); - if (NILP (symbol) || EQ (symbol, Qt)) - xsignal1 (Qsetting_constant, symbol); function = XSYMBOL (symbol)->function; if (!NILP (Vautoload_queue) && !EQ (function, Qunbound)) Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue); - if (CONSP (function) && EQ (XCAR (function), Qautoload)) + if (AUTOLOADP (function)) Fput (symbol, Qautoload, XCDR (function)); set_symbol_function (symbol, definition); - /* Handle automatic advice activation. */ - if (CONSP (XSYMBOL (symbol)->plist) - && !NILP (Fget (symbol, Qad_advice_info))) - { - call2 (Qad_activate_internal, symbol, Qnil); - definition = XSYMBOL (symbol)->function; - } + return definition; } @@ -642,15 +633,32 @@ The return value is undefined. */) (register Lisp_Object symbol, Lisp_Object definition, Lisp_Object docstring) { CHECK_SYMBOL (symbol); - if (CONSP (XSYMBOL (symbol)->function) - && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload)) - LOADHIST_ATTACH (Fcons (Qt, symbol)); if (!NILP (Vpurify_flag) /* If `definition' is a keymap, immutable (and copying) is wrong. */ && !KEYMAPP (definition)) definition = Fpurecopy (definition); - definition = Ffset (symbol, definition); - LOADHIST_ATTACH (Fcons (Qdefun, symbol)); + + { + bool autoload = AUTOLOADP (definition); + if (NILP (Vpurify_flag) || !autoload) + { /* Only add autoload entries after dumping, because the ones before are + not useful and else we get loads of them from the loaddefs.el. */ + + if (AUTOLOADP (XSYMBOL (symbol)->function)) + /* Remember that the function was already an autoload. */ + LOADHIST_ATTACH (Fcons (Qt, symbol)); + LOADHIST_ATTACH (Fcons (autoload ? Qautoload : Qdefun, symbol)); + } + } + + { /* Handle automatic advice activation. */ + Lisp_Object hook = Fget (symbol, Qdefalias_fset_function); + if (!NILP (hook)) + call2 (hook, symbol, definition); + else + Ffset (symbol, definition); + } + if (!NILP (docstring)) Fput (symbol, Qfunction_documentation, docstring); /* We used to return `definition', but now that `defun' and `defmacro' expand @@ -680,12 +688,10 @@ function with `&rest' args, or `unevalled' for a special form. */) CHECK_SUBR (subr); minargs = XSUBR (subr)->min_args; maxargs = XSUBR (subr)->max_args; - if (maxargs == MANY) - return Fcons (make_number (minargs), Qmany); - else if (maxargs == UNEVALLED) - return Fcons (make_number (minargs), Qunevalled); - else - return Fcons (make_number (minargs), make_number (maxargs)); + return Fcons (make_number (minargs), + maxargs == MANY ? Qmany + : maxargs == UNEVALLED ? Qunevalled + : make_number (maxargs)); } DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0, @@ -711,7 +717,7 @@ Value, if non-nil, is a list \(interactive SPEC). */) return Qnil; /* Use an `interactive-form' property if present, analogous to the - function-documentation property. */ + function-documentation property. */ fun = cmd; while (SYMBOLP (fun)) { @@ -735,6 +741,8 @@ Value, if non-nil, is a list \(interactive SPEC). */) if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE) return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); } + else if (AUTOLOADP (fun)) + return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil)); else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); @@ -742,14 +750,6 @@ Value, if non-nil, is a list \(interactive SPEC). */) return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))); else if (EQ (funcar, Qlambda)) return Fassq (Qinteractive, Fcdr (XCDR (fun))); - else if (EQ (funcar, Qautoload)) - { - struct gcpro gcpro1; - GCPRO1 (cmd); - Fautoload_do_load (fun, cmd, Qnil); - UNGCPRO; - return Finteractive_form (cmd); - } } return Qnil; } @@ -2695,10 +2695,10 @@ usage: (* &rest NUMBERS-OR-MARKERS) */) return arith_driver (Amult, nargs, args); } -DEFUN ("/", Fquo, Squo, 2, MANY, 0, +DEFUN ("/", Fquo, Squo, 1, MANY, 0, doc: /* Return first argument divided by all the remaining arguments. The arguments must be numbers or markers. -usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */) +usage: (/ DIVIDEND &rest DIVISORS) */) (ptrdiff_t nargs, Lisp_Object *args) { ptrdiff_t argnum; @@ -3063,6 +3063,7 @@ syms_of_data (void) DEFSYM (Qfont_object, "font-object"); DEFSYM (Qinteractive_form, "interactive-form"); + DEFSYM (Qdefalias_fset_function, "defalias-fset-function"); defsubr (&Sindirect_variable); defsubr (&Sinteractive_form); diff --git a/src/eval.c b/src/eval.c index 975204da017..dcd48cb7250 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1876,26 +1876,19 @@ this does nothing and returns nil. */) CHECK_STRING (file); /* If function is defined and not as an autoload, don't override. */ - if ((CONSP (XSYMBOL (function)->function) - && EQ (XCAR (XSYMBOL (function)->function), Qautoload))) - /* Remember that the function was already an autoload. */ - LOADHIST_ATTACH (Fcons (Qt, function)); - else if (!EQ (XSYMBOL (function)->function, Qunbound)) + if (!EQ (XSYMBOL (function)->function, Qunbound) + && !AUTOLOADP (XSYMBOL (function)->function)) return Qnil; - if (NILP (Vpurify_flag)) - /* Only add entries after dumping, because the ones before are - not useful and else we get loads of them from the loaddefs.el. */ - LOADHIST_ATTACH (Fcons (Qautoload, function)); - else if (EQ (docstring, make_number (0))) + if (!NILP (Vpurify_flag) && EQ (docstring, make_number (0))) /* `read1' in lread.c has found the docstring starting with "\ and assumed the docstring will be provided by Snarf-documentation, so it passed us 0 instead. But that leads to accidental sharing in purecopy's hash-consing, so we use a (hopefully) unique integer instead. */ - docstring = make_number (XUNTAG (function, Lisp_Symbol)); - return Ffset (function, - Fpurecopy (list5 (Qautoload, file, docstring, - interactive, type))); + docstring = make_number (XHASH (function)); + return Fdefalias (function, + list5 (Qautoload, file, docstring, interactive, type), + Qnil); } Lisp_Object diff --git a/src/lisp.h b/src/lisp.h index e2c1cc0e169..72e38fa4653 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1694,6 +1694,8 @@ typedef struct { #define MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker) #define SAVE_VALUEP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value) +#define AUTOLOADP(x) (CONSP (x) && EQ (Qautoload, XCAR (x))) + #define INTFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Int) #define BOOLFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Bool) #define OBJFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Obj) -- cgit v1.2.3 From 68146aa5abeb41ea6f535e6d2cad6a5211ba49e0 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Sat, 10 Nov 2012 16:40:37 -0800 Subject: * lisp/emacs-lisp/debug.el (debugger-bury-or-kill): Fix :version. --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/debug.el | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 542c80abeec..88ecfddffb2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2012-11-11 Glenn Morris + + * emacs-lisp/debug.el (debugger-bury-or-kill): Fix :version. + 2012-11-10 Leo Liu * ido.el (ido-set-matches-1): Fix split-string args to avoid diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index c04e68c0cfa..1117d11e07e 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -79,7 +79,7 @@ The value used here is passed to `quit-restore-window'." (const :tag "Bury" bury) (const :tag "Kill" kill)) :group 'debugger - :version "24.2") + :version "24.3") (defvar debug-function-list nil "List of functions currently set for debug on entry.") -- cgit v1.2.3 From 57fc0fee5fd12dd5b43323d127fea62040c01c79 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Sat, 10 Nov 2012 17:16:25 -0800 Subject: Document debugger-bury-or-kill * doc/lispref/debugging.texi (Using Debugger): Mention debugger-bury-or-kill. * lisp/emacs-lisp/debug.el (debugger-bury-or-kill): Doc tweak. * etc/NEWS: Related edit. --- doc/lispref/ChangeLog | 1 + doc/lispref/debugging.texi | 9 +++++++-- etc/NEWS | 4 +++- lisp/ChangeLog | 2 ++ lisp/emacs-lisp/debug.el | 6 +++--- 5 files changed, 16 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 0016258bcb5..9d101722388 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,6 +1,7 @@ 2012-11-11 Glenn Morris * debugging.texi (Error Debugging): Mention debug-on-message. + (Using Debugger): Mention debugger-bury-or-kill. * control.texi (Signaling Errors): * debugging.texi (Error Debugging): diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index 9a43cfeac5d..11532b19781 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi @@ -322,6 +322,7 @@ is a message describing the reason that the debugger was invoked (such as the error message and associated data, if it was invoked due to an error). +@vindex debugger-bury-or-kill The backtrace buffer is read-only and uses a special major mode, Debugger mode, in which letters are defined as debugger commands. The usual Emacs editing commands are available; thus, you can switch windows @@ -330,8 +331,12 @@ switch buffers, visit files, or do any other sort of editing. However, the debugger is a recursive editing level (@pxref{Recursive Editing}) and it is wise to go back to the backtrace buffer and exit the debugger (with the @kbd{q} command) when you are finished with it. Exiting -the debugger gets out of the recursive edit and kills the backtrace -buffer. +the debugger gets out of the recursive edit and buries the backtrace +buffer. (You can customize what the @kbd{q} command does with the +backtrace buffer by setting the variable @code{debugger-bury-or-kill}. +For example, set it to @code{kill} if you prefer to kill the buffer +rather than bury it. Consult the variable's documentation for more +possibilities.) When the debugger has been entered, the @code{debug-on-error} variable is temporarily set according to diff --git a/etc/NEWS b/etc/NEWS index 42c639ef25b..26707315da6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -804,7 +804,9 @@ table, but with a different prefix. *** New error type and new function `user-error'. These do not trigger the debugger. -*** New option `debugger-bury-or-kill'. ++++ +*** New option `debugger-bury-or-kill', saying what to do with the +debugger buffer when exiting debug. +++ *** Set `debug-on-message' to enter the debugger when a certain diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0207a4f903f..d7f86f510c5 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2012-11-11 Glenn Morris + * emacs-lisp/debug.el (debugger-bury-or-kill): Doc tweak. + * help.el (temp-buffer-max-height): * window.el (fit-frame-to-buffer, fit-frame-to-buffer-bottom-margin): * emacs-lisp/debug.el (debugger-bury-or-kill): Fix :version. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 1117d11e07e..6be30fc9164 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -49,9 +49,9 @@ the middle is discarded, and just the beginning and end are displayed." :version "21.1") (defcustom debugger-bury-or-kill 'bury - "How to proceed with the debugger buffer when exiting `debug'. -The value used here affects the behavior of operations on any -window previously showing the debugger buffer. + "What to do with the debugger buffer when exiting `debug'. +The value affects the behavior of operations on any window +previously showing the debugger buffer. `nil' means that if its window is not deleted when exiting the debugger, invoking `switch-to-prev-buffer' will usually show -- cgit v1.2.3 From c02ed5ace85372fedd4836fe1a33fa22927e7065 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Sun, 11 Nov 2012 06:22:06 -0500 Subject: Auto-commit of loaddefs files. --- lisp/emacs-lisp/cl-loaddefs.el | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 551043caa5e..bf99af2f7e6 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -11,7 +11,7 @@ ;;;;;; cl--map-overlays cl--map-intervals cl--map-keymap-recursively ;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan ;;;;;; cl-mapl cl-mapc cl-maplist cl-map cl--mapcar-many cl-equalp -;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "0e9284b6492cc98eee7c85ae4e5322ee") +;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "8e9fee941c465ac0fee9b92a92d64154") ;;; Generated autoloads from cl-extra.el (autoload 'cl-coerce "cl-extra" "\ @@ -41,7 +41,7 @@ TYPE is the sequence type to return. (autoload 'cl-maplist "cl-extra" "\ Map FUNCTION to each sublist of LIST or LISTs. -Like `mapcar', except applies to lists and their cdr's rather than to +Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \(fn FUNCTION LIST...)" nil nil) @@ -57,7 +57,7 @@ Like `cl-maplist', but does not accumulate values returned by the function. \(fn FUNCTION LIST...)" nil nil) (autoload 'cl-mapcan "cl-extra" "\ -Like `mapcar', but nconc's together the values returned by the function. +Like `cl-mapcar', but nconc's together the values returned by the function. \(fn FUNCTION SEQUENCE...)" nil nil) @@ -248,7 +248,9 @@ Remove from SYMBOL's plist the property PROPNAME and its value. \(fn SYMBOL PROPNAME)" nil nil) (autoload 'cl-prettyexpand "cl-extra" "\ - +Expand macros in FORM and insert the pretty-printed result. +Optional argument FULL non-nil means to expand all macros, +including `cl-block' and `cl-eval-when'. \(fn FORM &optional FULL)" nil nil) @@ -265,7 +267,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value. ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp ;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) -;;;;;; "cl-macs" "cl-macs.el" "57cf89149db1e8ea6bc1582713980cf8") +;;;;;; "cl-macs" "cl-macs.el" "a7228877484d2b39e1c2bee40b011734") ;;; Generated autoloads from cl-macs.el (autoload 'cl--compiler-macro-list* "cl-macs" "\ @@ -320,7 +322,7 @@ its argument list allows full Common Lisp conventions. \(fn FUNC)" nil t) (autoload 'cl-destructuring-bind "cl-macs" "\ - +Bind the variables in ARGS to the result of EXPR and execute BODY. \(fn ARGS EXPR &rest BODY)" nil t) @@ -564,12 +566,12 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (put 'cl-multiple-value-setq 'lisp-indent-function '1) (autoload 'cl-locally "cl-macs" "\ - +Equivalent to `progn'. \(fn &rest BODY)" nil t) (autoload 'cl-the "cl-macs" "\ - +At present this ignores _TYPE and is simply equivalent to FORM. \(fn TYPE FORM)" nil t) @@ -721,7 +723,10 @@ and then returning foo. \(fn FUNC ARGS &rest BODY)" nil t) (autoload 'cl-compiler-macroexpand "cl-macs" "\ - +Like `macroexpand', but for compiler macros. +Expands FORM repeatedly until no further expansion is possible. +Returns FORM unchanged if it has no compiler macro, or if it has a +macro that returns its `&whole' argument. \(fn FORM)" nil nil) -- cgit v1.2.3 From 231d8498eb1a10fadf7a4cd860cc934e05516433 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 12 Nov 2012 15:43:43 -0500 Subject: * lisp/emacs-lisp/nadvice.el: New package. * lisp/subr.el (special-form-p): New function. * lisp/emacs-lisp/elp.el: Use lexical-binding and advice-add. (elp-all-instrumented-list): Remove var. (elp-not-profilable): Remove elp-wrapper. (elp-profilable-p): Use autoloadp and special-form-p. (elp--advice-name): New const. (elp-instrument-function): Use advice-add. (elp--instrumented-p): New predicate. (elp-restore-function): Use advice-remove. (elp-restore-all, elp-reset-all): Use mapatoms. (elp-set-master): Use elp--instrumented-p. (elp--make-wrapper): Rename from elp-wrapper, return a function suitable for advice-add. Use cl-inf. (elp-results): Use mapatoms+elp--instrumented-p. * lisp/emacs-lisp/debug.el: Use lexical-binding and advice-add. (debug-function-list): Remove var. (debug): Rename arg, and then let-bind it explicitly inside. (debugger-setup-buffer): Rename arg. (debugger-setup-buffer): Adjust counts to new debug-on-entry setup. (debugger-frame-number): Adjust to new debug-on-entry setup. (debug--implement-debug-on-entry): Rename from implement-debug-on-entry, add argument. (debugger-special-form-p): Remove, use special-form-p instead. (debug-on-entry): Use advice-add. (debug--function-list): New function. (cancel-debug-on-entry): Use it, along with advice-remove. (debug-arglist, debug-convert-byte-code, debug-on-entry-1): Remove. (debugger-list-functions): Use debug--function-list instead of debug-function-list. * lisp/emacs-lisp/advice.el (ad-save-real-definition): Remove, unused. (ad-special-form-p): Remove, use special-form-p instead. (ad-set-advice-info): Use add-function and remove-function. (ad--defalias-fset): Adjust accordingly. * test/automated/advice-tests.el: New tests. --- etc/NEWS | 8 + lisp/ChangeLog | 37 +++++ lisp/emacs-lisp/advice.el | 42 ++--- lisp/emacs-lisp/debug.el | 181 ++++++--------------- lisp/emacs-lisp/elp.el | 332 +++++++++++++++------------------------ lisp/emacs-lisp/nadvice.el | 348 +++++++++++++++++++++++++++++++++++++++++ lisp/subr.el | 6 + test/ChangeLog | 4 + test/automated/advice-tests.el | 66 ++++++++ 9 files changed, 657 insertions(+), 367 deletions(-) create mode 100644 lisp/emacs-lisp/nadvice.el create mode 100644 test/automated/advice-tests.el (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 6e0609b94d9..a78980bedcc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -27,6 +27,13 @@ so we will look at it and add it to the manual. * Editing Changes in Emacs 24.4 * Changes in Specialized Modes and Packages in Emacs 24.4 * New Modes and Packages in Emacs 24.4 +** New nadvice.el package offering lighter-weight advice facilities. +It is layered as: +- add-function/remove-function which can be used to add/remove code on any + function-carrying place, such as process-filters or `-function' hooks. +- advice-add/advice-remove to add/remove a piece of advice on a named function, + much like `defadvice' does. + * Incompatible Lisp Changes in Emacs 24.4 ** `dolist' in lexical-binding mode does not bind VAR in RESULT any more. @@ -35,6 +42,7 @@ spurious warnings about an unused var. * Lisp changes in Emacs 24.4 +** New function special-form-p. ** Docstrings can be made dynamic by adding a `dynamic-docstring-function' text-property on the first char. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c5c4369ef17..f53b58b0129 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,40 @@ +2012-11-12 Stefan Monnier + + * emacs-lisp/nadvice.el: New package. + * subr.el (special-form-p): New function. + * emacs-lisp/elp.el: Use lexical-binding and advice-add. + (elp-all-instrumented-list): Remove var. + (elp-not-profilable): Remove elp-wrapper. + (elp-profilable-p): Use autoloadp and special-form-p. + (elp--advice-name): New const. + (elp-instrument-function): Use advice-add. + (elp--instrumented-p): New predicate. + (elp-restore-function): Use advice-remove. + (elp-restore-all, elp-reset-all): Use mapatoms. + (elp-set-master): Use elp--instrumented-p. + (elp--make-wrapper): Rename from elp-wrapper, return a function + suitable for advice-add. Use cl-inf. + (elp-results): Use mapatoms+elp--instrumented-p. + * emacs-lisp/debug.el: Use lexical-binding and advice-add. + (debug-function-list): Remove var. + (debug): Rename arg, and then let-bind it explicitly inside. + (debugger-setup-buffer): Rename arg. + (debugger-setup-buffer): Adjust counts to new debug-on-entry setup. + (debugger-frame-number): Adjust to new debug-on-entry setup. + (debug--implement-debug-on-entry): Rename from + implement-debug-on-entry, add argument. + (debugger-special-form-p): Remove, use special-form-p instead. + (debug-on-entry): Use advice-add. + (debug--function-list): New function. + (cancel-debug-on-entry): Use it, along with advice-remove. + (debug-arglist, debug-convert-byte-code, debug-on-entry-1): Remove. + (debugger-list-functions): Use debug--function-list instead of + debug-function-list. + * emacs-lisp/advice.el (ad-save-real-definition): Remove, unused. + (ad-special-form-p): Remove, use special-form-p instead. + (ad-set-advice-info): Use add-function and remove-function. + (ad--defalias-fset): Adjust accordingly. + 2012-11-10 Glenn Morris * mail/emacsbug.el (report-emacs-bug-tracker-url) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 8239522c0f8..16c12aad29b 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1776,27 +1776,6 @@ generates a copy of TREE." (funcall fUnCtIoN tReE)) (t tReE))) -;; @@ Save real definitions of subrs used by Advice: -;; ================================================= -;; Advice depends on the real, unmodified functionality of various subrs, -;; we save them here so advised versions will not interfere (eventually, -;; we will save all subrs used in code generated by Advice): - -(defmacro ad-save-real-definition (function) - (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)))))))) - - ;; @@ Advice info access fns: ;; ========================== @@ -1849,9 +1828,12 @@ On each iteration VAR will be bound to the name of an advised function (defsubst ad-set-advice-info (function advice-info) (cond - (advice-info (put function 'defalias-fset-function #'ad--defalias-fset)) + (advice-info + (add-function :around (get function 'defalias-fset-function) + #'ad--defalias-fset)) ((get function 'defalias-fset-function) - (put function 'defalias-fset-function nil))) + (remove-function (get function 'defalias-fset-function) + #'ad--defalias-fset))) (put function 'ad-advice-info advice-info)) (defmacro ad-copy-advice-info (function) @@ -1974,8 +1956,8 @@ Redefining advices affect the construction of an advised definition." ;; to `ad-activate' by using `ad-with-auto-activation-disabled' where ;; appropriate, especially in a safe version of `fset'. -(defun ad--defalias-fset (function definition) - (fset function definition) +(defun ad--defalias-fset (fsetfun function definition) + (funcall (or fsetfun #'fset) function definition) (ad-activate-internal function nil)) ;; For now define `ad-activate-internal' to the dummy definition: @@ -2310,12 +2292,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Take a macro function DEFINITION and make a lambda out of it." `(cdr ,definition)) -(defun ad-special-form-p (definition) - "Non-nil if and only if DEFINITION is a special form." - (if (and (symbolp definition) (fboundp definition)) - (setq definition (indirect-function definition))) - (and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled))) - (defmacro ad-subr-p (definition) ;;"non-nil if DEFINITION is a subr." (list 'subrp definition)) @@ -2415,7 +2391,7 @@ definition (see the code for `documentation')." (cond ((ad-macro-p definition) 'macro) ((ad-subr-p definition) - (if (ad-special-form-p definition) + (if (special-form-p definition) 'special-form 'subr)) ((or (ad-lambda-p definition) @@ -2804,7 +2780,7 @@ in any of these classes." (origname (ad-get-advice-info-field function 'origname)) (orig-interactive-p (commandp origdef)) (orig-subr-p (ad-subr-p origdef)) - (orig-special-form-p (ad-special-form-p origdef)) + (orig-special-form-p (special-form-p origdef)) (orig-macro-p (ad-macro-p origdef)) ;; Construct the individual pieces that we need for assembly: (orig-arglist (ad-arglist origdef)) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index c04e68c0cfa..3d4f41be8ee 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,4 +1,4 @@ -;;; debug.el --- debuggers and related commands for Emacs +;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1985-1986, 1994, 2001-2012 Free Software Foundation, Inc. @@ -81,9 +81,6 @@ The value used here is passed to `quit-restore-window'." :group 'debugger :version "24.2") -(defvar debug-function-list nil - "List of functions currently set for debug on entry.") - (defvar debugger-step-after-exit nil "Non-nil means \"single-step\" after the debugger exits.") @@ -146,7 +143,7 @@ where CAUSE can be: ;;;###autoload (setq debugger 'debug) ;;;###autoload -(defun debug (&rest debugger-args) +(defun debug (&rest args) "Enter debugger. \\`\\[debugger-continue]' returns from the debugger. Arguments are mainly for use when this is called from the internals of the evaluator. @@ -165,6 +162,7 @@ first will be printed into the backtrace buffer." (if (get-buffer "*Backtrace*") (with-current-buffer (get-buffer "*Backtrace*") (list major-mode (buffer-string))))) + (debugger-args args) (debugger-buffer (get-buffer-create "*Backtrace*")) (debugger-old-buffer (current-buffer)) (debugger-window nil) @@ -219,7 +217,7 @@ first will be printed into the backtrace buffer." (save-excursion (when (eq (car debugger-args) 'debug) ;; Skip the frames for backtrace-debug, byte-code, - ;; and implement-debug-on-entry. + ;; debug--implement-debug-on-entry and the advice's `apply'. (backtrace-debug 4 t) ;; Place an extra debug-on-exit for macro's. (when (eq 'lambda (car-safe (cadr (backtrace-frame 4)))) @@ -318,7 +316,7 @@ first will be printed into the backtrace buffer." (setq debug-on-next-call debugger-step-after-exit) debugger-value))) -(defun debugger-setup-buffer (debugger-args) +(defun debugger-setup-buffer (args) "Initialize the `*Backtrace*' buffer for entry to the debugger. That buffer should be current already." (setq buffer-read-only nil) @@ -334,20 +332,22 @@ That buffer should be current already." (delete-region (point) (progn (search-forward "\n debug(") - (forward-line (if (eq (car debugger-args) 'debug) - 2 ; Remove implement-debug-on-entry frame. + (forward-line (if (eq (car args) 'debug) + ;; Remove debug--implement-debug-on-entry + ;; and the advice's `apply' frame. + 3 1)) (point))) (insert "Debugger entered") ;; lambda is for debug-on-call when a function call is next. ;; debug is for debug-on-entry function called. - (pcase (car debugger-args) + (pcase (car args) ((or `lambda `debug) (insert "--entering a function:\n")) ;; Exiting a function. (`exit (insert "--returning value: ") - (setq debugger-value (nth 1 debugger-args)) + (setq debugger-value (nth 1 args)) (prin1 debugger-value (current-buffer)) (insert ?\n) (delete-char 1) @@ -356,7 +356,7 @@ That buffer should be current already." ;; Debugger entered for an error. (`error (insert "--Lisp error: ") - (prin1 (nth 1 debugger-args) (current-buffer)) + (prin1 (nth 1 args) (current-buffer)) (insert ?\n)) ;; debug-on-call, when the next thing is an eval. (`t @@ -364,8 +364,8 @@ That buffer should be current already." ;; User calls debug directly. (_ (insert ": ") - (prin1 (if (eq (car debugger-args) 'nil) - (cdr debugger-args) debugger-args) + (prin1 (if (eq (car args) 'nil) + (cdr args) args) (current-buffer)) (insert ?\n))) ;; After any frame that uses eval-buffer, @@ -525,9 +525,10 @@ removes itself from that hook." (count 0)) (while (not (eq (cadr (backtrace-frame count)) 'debug)) (setq count (1+ count))) - ;; Skip implement-debug-on-entry frame. - (when (eq 'implement-debug-on-entry (cadr (backtrace-frame (1+ count)))) - (setq count (1+ count))) + ;; Skip debug--implement-debug-on-entry frame. + (when (eq 'debug--implement-debug-on-entry + (cadr (backtrace-frame (1+ count)))) + (setq count (+ 2 count))) (goto-char (point-min)) (when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):") (goto-char (match-end 0)) @@ -694,10 +695,10 @@ Applies to the frame whose line point is on in the backtrace." :help "Continue to exit from this frame, with all debug-on-entry suspended")) (define-key menu-map [deb-cont] '(menu-item "Continue" debugger-continue - :help "Continue, evaluating this expression without stopping")) + :help "Continue, evaluating this expression without stopping")) (define-key menu-map [deb-step] '(menu-item "Step through" debugger-step-through - :help "Proceed, stepping through subexpressions of this expression")) + :help "Proceed, stepping through subexpressions of this expression")) map)) (put 'debugger-mode 'mode-class 'special) @@ -777,7 +778,7 @@ For the cross-reference format, see `help-make-xrefs'." ;; When you change this, you may also need to change the number of ;; frames that the debugger skips. -(defun implement-debug-on-entry () +(defun debug--implement-debug-on-entry (&rest _ignore) "Conditionally call the debugger. A call to this function is inserted by `debug-on-entry' to cause functions to break on entry." @@ -785,12 +786,6 @@ functions to break on entry." nil (funcall debugger 'debug))) -(defun debugger-special-form-p (symbol) - "Return whether SYMBOL is a special form." - (and (fboundp symbol) - (subrp (symbol-function symbol)) - (eq (cdr (subr-arity (symbol-function symbol))) 'unevalled))) - ;;;###autoload (defun debug-on-entry (function) "Request FUNCTION to invoke debugger each time it is called. @@ -808,7 +803,7 @@ Use \\[cancel-debug-on-entry] to cancel the effect of this command. Redefining FUNCTION also cancels it." (interactive (let ((fn (function-called-at-point)) val) - (when (debugger-special-form-p fn) + (when (special-form-p fn) (setq fn nil)) (setq val (completing-read (if fn @@ -817,36 +812,21 @@ Redefining FUNCTION also cancels it." obarray #'(lambda (symbol) (and (fboundp symbol) - (not (debugger-special-form-p symbol)))) + (not (special-form-p symbol)))) t nil nil (symbol-name fn))) (list (if (equal val "") fn (intern val))))) - ;; FIXME: Use advice.el. - (when (debugger-special-form-p function) - (error "Function %s is a special form" function)) - (if (or (symbolp (symbol-function function)) - (subrp (symbol-function function))) - ;; The function is built-in or aliased to another function. - ;; Create a wrapper in which we can add the debug call. - (fset function `(lambda (&rest debug-on-entry-args) - ,(interactive-form (symbol-function function)) - (apply ',(symbol-function function) - debug-on-entry-args))) - (when (autoloadp (symbol-function function)) - ;; The function is autoloaded. Load its real definition. - (autoload-do-load (symbol-function function) function)) - (when (or (not (consp (symbol-function function))) - (and (eq (car (symbol-function function)) 'macro) - (not (consp (cdr (symbol-function function)))))) - ;; The function is byte-compiled. Create a wrapper in which - ;; we can add the debug call. - (debug-convert-byte-code function))) - (unless (consp (symbol-function function)) - (error "Definition of %s is not a list" function)) - (fset function (debug-on-entry-1 function t)) - (unless (memq function debug-function-list) - (push function debug-function-list)) + (advice-add function :before #'debug--implement-debug-on-entry) function) +(defun debug--function-list () + "List of functions currently set for debug on entry." + (let ((funs '())) + (mapatoms + (lambda (s) + (when (advice-member-p #'debug--implement-debug-on-entry s) + (push s funs)))) + funs)) + ;;;###autoload (defun cancel-debug-on-entry (&optional function) "Undo effect of \\[debug-on-entry] on FUNCTION. @@ -857,80 +837,16 @@ To specify a nil argument interactively, exit with an empty minibuffer." (list (let ((name (completing-read "Cancel debug on entry to function (default all functions): " - (mapcar 'symbol-name debug-function-list) nil t))) + (mapcar #'symbol-name (debug--function-list)) nil t))) (when name (unless (string= name "") (intern name)))))) - (if (and function - (not (string= function ""))) ; Pre 22.1 compatibility test. + (if function (progn - (let ((defn (debug-on-entry-1 function nil))) - (condition-case nil - (when (and (equal (nth 1 defn) '(&rest debug-on-entry-args)) - (eq (car (nth 3 defn)) 'apply)) - ;; `defn' is a wrapper introduced in debug-on-entry. - ;; Get rid of it since we don't need it any more. - (setq defn (nth 1 (nth 1 (nth 3 defn))))) - (error nil)) - (fset function defn)) - (setq debug-function-list (delq function debug-function-list)) + (advice-remove function #'debug--implement-debug-on-entry) function) (message "Cancelling debug-on-entry for all functions") - (mapcar 'cancel-debug-on-entry debug-function-list))) - -(defun debug-arglist (definition) - ;; FIXME: copied from ad-arglist. - "Return the argument list of DEFINITION." - (require 'help-fns) - (help-function-arglist definition 'preserve-names)) - -(defun debug-convert-byte-code (function) - (let* ((defn (symbol-function function)) - (macro (eq (car-safe defn) 'macro))) - (when macro (setq defn (cdr defn))) - (when (byte-code-function-p defn) - (let* ((args (debug-arglist defn)) - (body - `((,(if (memq '&rest args) #'apply #'funcall) - ,defn - ,@(remq '&rest (remq '&optional args)))))) - (if (> (length defn) 5) - ;; The mere presence of field 5 is sufficient to make - ;; it interactive. - (push `(interactive ,(aref defn 5)) body)) - (if (and (> (length defn) 4) (aref defn 4)) - ;; Use `documentation' here, to get the actual string, - ;; in case the compiled function has a reference - ;; to the .elc file. - (setq body (cons (documentation function) body))) - (setq defn `(closure (t) ,args ,@body))) - (when macro (setq defn (cons 'macro defn))) - (fset function defn)))) - -(defun debug-on-entry-1 (function flag) - (let* ((defn (symbol-function function)) - (tail defn)) - (when (eq (car-safe tail) 'macro) - (setq tail (cdr tail))) - (if (not (memq (car-safe tail) '(closure lambda))) - ;; Only signal an error when we try to set debug-on-entry. - ;; When we try to clear debug-on-entry, we are now done. - (when flag - (error "%s is not a user-defined Lisp function" function)) - (if (eq (car tail) 'closure) (setq tail (cdr tail))) - (setq tail (cdr tail)) - ;; Skip the docstring. - (when (and (stringp (cadr tail)) (cddr tail)) - (setq tail (cdr tail))) - ;; Skip the interactive form. - (when (eq 'interactive (car-safe (cadr tail))) - (setq tail (cdr tail))) - (unless (eq flag (equal (cadr tail) '(implement-debug-on-entry))) - ;; Add/remove debug statement as needed. - (setcdr tail (if flag - (cons '(implement-debug-on-entry) (cdr tail)) - (cddr tail))))) - defn)) + (mapcar #'cancel-debug-on-entry (debug--function-list)))) (defun debugger-list-functions () "Display a list of all the functions now set to debug on entry." @@ -940,17 +856,18 @@ To specify a nil argument interactively, exit with an empty minibuffer." (called-interactively-p 'interactive)) (with-output-to-temp-buffer (help-buffer) (with-current-buffer standard-output - (if (null debug-function-list) - (princ "No debug-on-entry functions now\n") - (princ "Functions set to debug on entry:\n\n") - (dolist (fun debug-function-list) - (make-text-button (point) (progn (prin1 fun) (point)) - 'type 'help-function - 'help-args (list fun)) - (terpri)) - (terpri) - (princ "Note: if you have redefined a function, then it may no longer\n") - (princ "be set to debug on entry, even if it is in the list."))))) + (let ((funs (debug--function-list))) + (if (null funs) + (princ "No debug-on-entry functions now\n") + (princ "Functions set to debug on entry:\n\n") + (dolist (fun funs) + (make-text-button (point) (progn (prin1 fun) (point)) + 'type 'help-function + 'help-args (list fun)) + (terpri)) + (terpri) + (princ "Note: if you have redefined a function, then it may no longer\n") + (princ "be set to debug on entry, even if it is in the list.")))))) (provide 'debug) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index b94817cdb02..067b45f5cd8 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -1,4 +1,4 @@ -;;; elp.el --- Emacs Lisp Profiler +;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*- ;; Copyright (C) 1994-1995, 1997-1998, 2001-2012 ;; Free Software Foundation, Inc. @@ -124,6 +124,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) ;; start of user configuration variables ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv @@ -148,9 +149,9 @@ Results are displayed with the `elp-results' command." "Non-nil specifies ELP results sorting function. These functions are currently available: - elp-sort-by-call-count -- sort by the highest call count - elp-sort-by-total-time -- sort by the highest total time - elp-sort-by-average-time -- sort by the highest average times + `elp-sort-by-call-count' -- sort by the highest call count + `elp-sort-by-total-time' -- sort by the highest total time + `elp-sort-by-average-time' -- sort by the highest average times You can write your own sort function. It should adhere to the interface specified by the PREDICATE argument for `sort'. @@ -167,7 +168,7 @@ If a number, no function that has been called fewer than that number of times will be displayed in the output buffer. If nil, all functions will be displayed." :type '(choice integer - (const :tag "Show All" nil)) + (const :tag "Show All" nil)) :group 'elp) (defcustom elp-use-standard-output nil @@ -193,9 +194,6 @@ In other words, a new unique buffer is create every time you run (defconst elp-timer-info-property 'elp-info "ELP information property name.") -(defvar elp-all-instrumented-list nil - "List of all functions currently being instrumented.") - (defvar elp-record-p t "Controls whether functions should record times or not. This variable is set by the master function.") @@ -205,7 +203,7 @@ This variable is set by the master function.") (defvar elp-not-profilable ;; First, the functions used inside each instrumented function: - '(elp-wrapper called-interactively-p + '(called-interactively-p ;; Then the functions used by the above functions. I used ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x)) ;; (aref (symbol-function 'elp-wrapper) 2))) @@ -223,60 +221,21 @@ them would thus lead to infinite recursion.") (fboundp fun) (not (or (memq fun elp-not-profilable) (keymapp fun) - (memq (car-safe (symbol-function fun)) '(autoload macro)) - (condition-case nil - (when (subrp (indirect-function fun)) - (eq 'unevalled - (cdr (subr-arity (indirect-function fun))))) - (error nil)))))) + (autoloadp (symbol-function fun)) ;FIXME: Why not just load it? + (special-form-p fun))))) +(defconst elp--advice-name 'ELP-instrumentation\ ) ;;;###autoload (defun elp-instrument-function (funsym) "Instrument FUNSYM for profiling. FUNSYM must be a symbol of a defined function." (interactive "aFunction to instrument: ") - ;; restore the function. this is necessary to avoid infinite - ;; recursion of already instrumented functions (i.e. elp-wrapper - ;; calling elp-wrapper ad infinitum). it is better to simply - ;; restore the function than to throw an error. this will work - ;; properly in the face of eval-defun because if the function was - ;; redefined, only the timer info will be nil'd out since - ;; elp-restore-function is smart enough not to trash the new - ;; definition. - (elp-restore-function funsym) - (let* ((funguts (symbol-function funsym)) - (infovec (vector 0 0 funguts)) - (newguts '(lambda (&rest args)))) - ;; we cannot profile macros - (and (eq (car-safe funguts) 'macro) - (error "ELP cannot profile macro: %s" funsym)) - ;; TBD: at some point it might be better to load the autoloaded - ;; function instead of throwing an error. if we do this, then we - ;; probably want elp-instrument-package to be updated with the - ;; newly loaded list of functions. i'm not sure it's smart to do - ;; the autoload here, since that could have side effects, and - ;; elp-instrument-function is similar (in my mind) to defun-ish - ;; type functionality (i.e. it shouldn't execute the function). - (and (autoloadp funguts) - (error "ELP cannot profile autoloaded function: %s" funsym)) + (let* ((infovec (vector 0 0))) ;; We cannot profile functions used internally during profiling. (unless (elp-profilable-p funsym) (error "ELP cannot profile the function: %s" funsym)) - ;; put rest of newguts together - (if (commandp funsym) - (setq newguts (append newguts '((interactive))))) - (setq newguts (append newguts `((elp-wrapper - (quote ,funsym) - ,(when (commandp funsym) - '(called-interactively-p 'any)) - args)))) - ;; to record profiling times, we set the symbol's function - ;; definition so that it runs the elp-wrapper function with the - ;; function symbol as an argument. We place the old function - ;; definition on the info vector. - ;; - ;; The info vector data structure is a 3 element vector. The 0th + ;; The info vector data structure is a 2 element vector. The 0th ;; element is the call-count, i.e. the total number of times this ;; function has been entered. This value is bumped up on entry to ;; the function so that non-local exists are still recorded. TBD: @@ -285,72 +244,45 @@ FUNSYM must be a symbol of a defined function." ;; The 1st element is the total amount of time in seconds that has ;; been spent inside this function. This number is added to on ;; function exit. - ;; - ;; The 2nd element is the old function definition list. This gets - ;; funcall'd in between start/end time retrievals. I believe that - ;; this lets us profile even byte-compiled functions. - ;; put the info vector on the property list + ;; Put the info vector on the property list. (put funsym elp-timer-info-property infovec) ;; Set the symbol's new profiling function definition to run - ;; elp-wrapper. - (let ((advice-info (get funsym 'ad-advice-info))) - (if advice-info - (progn - ;; If function is advised, don't let Advice change - ;; its definition from under us during the `fset'. - (put funsym 'ad-advice-info nil) - (fset funsym newguts) - (put funsym 'ad-advice-info advice-info)) - (fset funsym newguts))) - - ;; add this function to the instrumentation list - (unless (memq funsym elp-all-instrumented-list) - (push funsym elp-all-instrumented-list)))) + ;; ELP wrapper. + (advice-add funsym :around (elp--make-wrapper funsym) + `((name . ,elp--advice-name))))) + +(defun elp--instrumented-p (sym) + (advice-member-p elp--advice-name sym)) (defun elp-restore-function (funsym) "Restore an instrumented function to its original definition. Argument FUNSYM is the symbol of a defined function." - (interactive "aFunction to restore: ") - (let ((info (get funsym elp-timer-info-property))) - ;; delete the function from the all instrumented list - (setq elp-all-instrumented-list - (delq funsym elp-all-instrumented-list)) - - ;; if the function was the master, reset the master - (if (eq funsym elp-master) - (setq elp-master nil - elp-record-p t)) - - ;; zap the properties - (put funsym elp-timer-info-property nil) - - ;; restore the original function definition, but if the function - ;; wasn't instrumented do nothing. we do this after the above - ;; because its possible the function got un-instrumented due to - ;; circumstances beyond our control. Also, check to make sure - ;; that the current function symbol points to elp-wrapper. If - ;; not, then the user probably did an eval-defun, or loaded a - ;; byte-compiled version, while the function was instrumented and - ;; we don't want to destroy the new definition. can it ever be - ;; the case that a lisp function can be compiled instrumented? - (and info - (functionp funsym) - (not (byte-code-function-p (symbol-function funsym))) - (assq 'elp-wrapper (symbol-function funsym)) - (fset funsym (aref info 2))))) + (interactive + (list + (intern + (completing-read "Function to restore: " obarray + #'elp--instrumented-p t)))) + ;; If the function was the master, reset the master. + (if (eq funsym elp-master) + (setq elp-master nil + elp-record-p t)) + + ;; Zap the properties. + (put funsym elp-timer-info-property nil) + + (advice-remove funsym elp--advice-name)) ;;;###autoload (defun elp-instrument-list (&optional list) "Instrument, for profiling, all functions in `elp-function-list'. Use optional LIST if provided instead. If called interactively, read LIST using the minibuffer." - (interactive "PList of functions to instrument: ") + (interactive "PList of functions to instrument: ") ;FIXME: Doesn't work?! (unless (listp list) (signal 'wrong-type-argument (list 'listp list))) - (let ((list (or list elp-function-list))) - (mapcar 'elp-instrument-function list))) + (mapcar #'elp-instrument-function (or list elp-function-list))) ;;;###autoload (defun elp-instrument-package (prefix) @@ -371,15 +303,13 @@ For example, to instrument all ELP functions, do the following: (defun elp-restore-list (&optional list) "Restore the original definitions for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to restore: ") - (let ((list (or list elp-function-list))) - (mapcar 'elp-restore-function list))) + (interactive "PList of functions to restore: ") ;FIXME: Doesn't work!? + (mapcar #'elp-restore-function (or list elp-function-list))) (defun elp-restore-all () "Restore the original definitions of all functions being profiled." (interactive) - (elp-restore-list elp-all-instrumented-list)) - + (mapatoms #'elp-restore-function)) (defun elp-reset-function (funsym) "Reset the profiling information for FUNSYM." @@ -395,30 +325,36 @@ Use optional LIST if provided instead." (defun elp-reset-list (&optional list) "Reset the profiling information for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to reset: ") + (interactive "PList of functions to reset: ") ;FIXME: Doesn't work!? (let ((list (or list elp-function-list))) (mapcar 'elp-reset-function list))) (defun elp-reset-all () "Reset the profiling information for all functions being profiled." (interactive) - (elp-reset-list elp-all-instrumented-list)) + (mapatoms (lambda (sym) + (if (get sym elp-timer-info-property) + (elp-reset-function sym))))) (defun elp-set-master (funsym) "Set the master function for profiling." - (interactive "aMaster function: ") - ;; when there's a master function, recording is turned off by - ;; default + (interactive + (list + (intern + (completing-read "Master function: " obarray + #'elp--instrumented-p + t nil nil (if elp-master (symbol-name elp-master)))))) + ;; When there's a master function, recording is turned off by default. (setq elp-master funsym elp-record-p nil) - ;; make sure master function is instrumented - (or (memq funsym elp-all-instrumented-list) + ;; Make sure master function is instrumented. + (or (elp--instrumented-p funsym) (elp-instrument-function funsym))) (defun elp-unset-master () "Unset the master function." (interactive) - ;; when there's no master function, recording is turned on by default. + ;; When there's no master function, recording is turned on by default. (setq elp-master nil elp-record-p t)) @@ -426,49 +362,40 @@ Use optional LIST if provided instead." (defsubst elp-elapsed-time (start end) (float-time (time-subtract end start))) -(defun elp-wrapper (funsym interactive-p args) - "This function has been instrumented for profiling by the ELP. +(defun elp--make-wrapper (funsym) + "Make the piece of advice that instruments FUNSYM." + (lambda (func &rest args) + "This function has been instrumented for profiling by the ELP. ELP is the Emacs Lisp Profiler. To restore the function to its original definition, use \\[elp-restore-function] or \\[elp-restore-all]." - ;; turn on recording if this is the master function - (if (and elp-master - (eq funsym elp-master)) - (setq elp-record-p t)) - ;; get info vector and original function symbol - (let* ((info (get funsym elp-timer-info-property)) - (func (aref info 2)) - result) - (or func - (error "%s is not instrumented for profiling" funsym)) - (if (not elp-record-p) - ;; when not recording, just call the original function symbol - ;; and return the results. - (setq result - (if interactive-p - (call-interactively func) - (apply func args))) - ;; we are recording times - (let (enter-time exit-time) - ;; increment the call-counter - (aset info 0 (1+ (aref info 0))) - ;; now call the old symbol function, checking to see if it - ;; should be called interactively. make sure we return the - ;; correct value - (if interactive-p - (setq enter-time (current-time) - result (call-interactively func) - exit-time (current-time)) + ;; turn on recording if this is the master function + (if (and elp-master + (eq funsym elp-master)) + (setq elp-record-p t)) + ;; get info vector and original function symbol + (let* ((info (get funsym elp-timer-info-property)) + result) + (or func + (error "%s is not instrumented for profiling" funsym)) + (if (not elp-record-p) + ;; when not recording, just call the original function symbol + ;; and return the results. + (setq result (apply func args)) + ;; we are recording times + (let (enter-time exit-time) + ;; increment the call-counter + (cl-incf (aref info 0)) (setq enter-time (current-time) result (apply func args) - exit-time (current-time))) - ;; calculate total time in function - (aset info 1 (+ (aref info 1) (elp-elapsed-time enter-time exit-time))) - )) - ;; turn off recording if this is the master function - (if (and elp-master - (eq funsym elp-master)) - (setq elp-record-p nil)) - result)) + exit-time (current-time)) + ;; calculate total time in function + (cl-incf (aref info 1) (elp-elapsed-time enter-time exit-time)) + )) + ;; turn off recording if this is the master function + (if (and elp-master + (eq funsym elp-master)) + (setq elp-record-p nil)) + result))) ;; shut the byte-compiler up @@ -582,57 +509,58 @@ displayed." (elp-et-len (length et-header)) (at-header "Average Time") (elp-at-len (length at-header)) - (resvec - (mapcar - (function - (lambda (funsym) - (let* ((info (get funsym elp-timer-info-property)) - (symname (format "%s" funsym)) - (cc (aref info 0)) - (tt (aref info 1))) - (if (not info) - (insert "No profiling information found for: " - symname) - (setq longest (max longest (length symname))) - (vector cc tt (if (zerop cc) - 0.0 ;avoid arithmetic div-by-zero errors - (/ (float tt) (float cc))) - symname))))) - elp-all-instrumented-list)) + (resvec '()) ) ; end let* + (mapatoms + (lambda (funsym) + (when (elp--instrumented-p funsym) + (let* ((info (get funsym elp-timer-info-property)) + (symname (format "%s" funsym)) + (cc (aref info 0)) + (tt (aref info 1))) + (if (not info) + (insert "No profiling information found for: " + symname) + (setq longest (max longest (length symname))) + (push + (vector cc tt (if (zerop cc) + 0.0 ;avoid arithmetic div-by-zero errors + (/ (float tt) (float cc))) + symname) + resvec)))))) ;; If printing to stdout, insert the header so it will print. ;; Otherwise use header-line-format. (setq elp-field-len (max titlelen longest)) (if (or elp-use-standard-output noninteractive) - (progn - (insert title) - (if (> longest titlelen) - (progn - (insert-char 32 (- longest titlelen)))) - (insert " " cc-header " " et-header " " at-header "\n") - (insert-char ?= elp-field-len) - (insert " ") - (insert-char ?= elp-cc-len) - (insert " ") - (insert-char ?= elp-et-len) - (insert " ") - (insert-char ?= elp-at-len) - (insert "\n")) - (let ((column 0)) - (setq header-line-format - (mapconcat - (lambda (title) - (prog1 - (concat - (propertize " " - 'display (list 'space :align-to column) - 'face 'fixed-pitch) - title) - (setq column (+ column 2 - (if (= column 0) - elp-field-len - (length title)))))) - (list title cc-header et-header at-header) "")))) + (progn + (insert title) + (if (> longest titlelen) + (progn + (insert-char 32 (- longest titlelen)))) + (insert " " cc-header " " et-header " " at-header "\n") + (insert-char ?= elp-field-len) + (insert " ") + (insert-char ?= elp-cc-len) + (insert " ") + (insert-char ?= elp-et-len) + (insert " ") + (insert-char ?= elp-at-len) + (insert "\n")) + (let ((column 0)) + (setq header-line-format + (mapconcat + (lambda (title) + (prog1 + (concat + (propertize " " + 'display (list 'space :align-to column) + 'face 'fixed-pitch) + title) + (setq column (+ column 2 + (if (= column 0) + elp-field-len + (length title)))))) + (list title cc-header et-header at-header) "")))) ;; if sorting is enabled, then sort the results list. in either ;; case, call elp-output-result to output the result in the ;; buffer @@ -644,7 +572,7 @@ displayed." (pop-to-buffer resultsbuf) ;; copy results to standard-output? (if (or elp-use-standard-output noninteractive) - (princ (buffer-substring (point-min) (point-max))) + (princ (buffer-substring (point-min) (point-max))) (goto-char (point-min))) ;; reset profiling info if desired (and elp-reset-after-results diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el new file mode 100644 index 00000000000..020a2f89bdb --- /dev/null +++ b/lisp/emacs-lisp/nadvice.el @@ -0,0 +1,348 @@ +;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*- + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: extensions, lisp, tools +;; Package: emacs + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This package lets you add behavior (which we call "piece of advice") to +;; existing functions, like the old `advice.el' package, but with much fewer +;; bells ans whistles. It comes in 2 parts: +;; +;; - The first part lets you add/remove functions, similarly to +;; add/remove-hook, from any "place" (i.e. as accepted by `setf') that +;; holds a function. +;; This part provides mainly 2 macros: `add-function' and `remove-function'. +;; +;; - The second part provides `add-advice' and `remove-advice' which are +;; refined version of the previous macros specially tailored for the case +;; where the place that we want to modify is a `symbol-function'. + +;;; Code: + +;;;; Lightweight advice/hook +(defvar advice--where-alist + '((:around "\300\301\302\003#\207" 5) + (:before "\300\301\002\"\210\300\302\002\"\207" 4) + (:after "\300\302\002\"\300\301\003\"\210\207" 5) + (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) + (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) + (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) + (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)) + "List of descriptions of how to add a function. +Each element has the form (WHERE BYTECODE STACK) where: + WHERE is a keyword indicating where the function is added. + BYTECODE is the corresponding byte-code that will be used. + STACK is the amount of stack space needed by the byte-code.") + +(defvar advice--bytecodes (mapcar #'cadr advice--where-alist)) + +(defun advice--p (object) + (and (byte-code-function-p object) + (eq 128 (aref object 0)) + (memq (length object) '(5 6)) + (memq (aref object 1) advice--bytecodes) + (eq #'apply (aref (aref object 2) 0)))) + +(defsubst advice--car (f) (aref (aref f 2) 1)) +(defsubst advice--cdr (f) (aref (aref f 2) 2)) +(defsubst advice--props (f) (aref (aref f 2) 3)) + +(defun advice--make-docstring (_string function) + "Build the raw doc-string of SYMBOL, presumably advised." + (let ((flist (indirect-function function)) + (docstring nil)) + (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) + (while (advice--p flist) + (let ((bytecode (aref flist 1)) + (where nil)) + (dolist (elem advice--where-alist) + (if (eq bytecode (cadr elem)) (setq where (car elem)))) + (setq docstring + (concat + docstring + (propertize (format "%s advice: " where) + 'face 'warning) + (let ((fun (advice--car flist))) + (if (symbolp fun) (format "`%S'" fun) + (let* ((name (cdr (assq 'name (advice--props flist)))) + (doc (documentation fun t)) + (usage (help-split-fundoc doc function))) + (if usage (setq doc (cdr usage))) + (if name + (if doc + (format "%s\n%s" name doc) + (format "%s" name)) + (or doc "No documentation"))))) + "\n"))) + (setq flist (advice--cdr flist))) + (if docstring (setq docstring (concat docstring "\n"))) + (let* ((origdoc (unless (eq function flist) ;Avoid inf-loops. + (documentation flist t))) + (usage (help-split-fundoc origdoc function))) + (setq usage (if (null usage) + (let ((arglist (help-function-arglist flist))) + (format "%S" (help-make-usage function arglist))) + (setq origdoc (cdr usage)) (car usage))) + (help-add-fundoc-usage (concat docstring origdoc) usage)))) + +(defvar advice--docstring + ;; Can't eval-when-compile nor use defconst because it then gets pure-copied, + ;; which drops the text-properties. + ;;(eval-when-compile + (propertize "Advised function" + 'dynamic-docstring-function #'advice--make-docstring)) ;; ) + +(defun advice--make-interactive-form (function main) + ;; TODO: Make it possible to do around-like advising on the + ;; interactive forms (bug#12844). + ;; TODO: make it so that interactive spec can be a constant which + ;; dynamically checks the advice--car/cdr to do its job. + ;; TODO: Implement interactive-read-args: + ;;(when (or (commandp function) (commandp main)) + ;; `(interactive-read-args + ;; (cadr (or (interactive-form function) (interactive-form main))))) + ;; FIXME: This loads autoloaded functions too eagerly. + (cadr (or (interactive-form function) + (interactive-form main)))) + +(defsubst advice--make-1 (byte-code stack-depth function main props) + "Build a function value that adds FUNCTION to MAIN." + (let ((adv-sig (gethash main advertised-signature-table)) + (advice + (apply #'make-byte-code 128 byte-code + (vector #'apply function main props) stack-depth + advice--docstring + (when (or (commandp function) (commandp main)) + (list (advice--make-interactive-form + function main)))))) + (when adv-sig (puthash advice adv-sig advertised-signature-table)) + advice)) + +(defun advice--make (where function main props) + "Build a function value that adds FUNCTION to MAIN at WHERE. +WHERE is a symbol to select an entry in `advice--where-alist'." + (let ((desc (assq where advice--where-alist))) + (unless desc (error "Unknown add-function location `%S'" where)) + (advice--make-1 (nth 1 desc) (nth 2 desc) + function main props))) + +(defun advice--member-p (function definition) + (let ((found nil)) + (while (and (not found) (advice--p definition)) + (if (or (equal function (advice--car definition)) + (equal function (cdr (assq 'name (advice--props definition))))) + (setq found t) + (setq definition (advice--cdr definition)))) + found)) + +;;;###autoload +(defun advice--remove-function (flist function) + (if (not (advice--p flist)) + flist + (let ((first (advice--car flist)) + (props (advice--props flist))) + (if (or (equal function first) + (equal function (cdr (assq 'name props)))) + (advice--cdr flist) + (let* ((rest (advice--cdr flist)) + (nrest (advice--remove-function rest function))) + (if (eq rest nrest) flist + (advice--make-1 (aref flist 1) (aref flist 3) + first nrest props))))))) + +;;;###autoload +(defmacro add-function (where place function &optional props) + ;; TODO: + ;; - provide something like `around' for interactive forms. + ;; - provide some kind of buffer-local functionality at least when `place' + ;; is a variable. + ;; - obsolete with-wrapper-hook (mostly requires buffer-local support). + ;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP + ;; and tracing want to stay first. + ;; - maybe also let `where' specify some kind of predicate and use it + ;; to implement things like mode-local or eieio-defmethod. + ;; :before is like a normal add-hook on a normal hook. + ;; :before-while is like add-hook on run-hook-with-args-until-failure. + ;; :before-until is like add-hook on run-hook-with-args-until-success. + ;; Same with :after-* but for (add-hook ... 'append). + "Add a piece of advice on the function stored at PLACE. +FUNCTION describes the code to add. WHERE describes where to add it. +WHERE can be explained by showing the resulting new function, as the +result of combining FUNCTION and the previous value of PLACE, which we +call OLDFUN here: +`:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) +`:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) +`:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) +`:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) +`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) +`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) +`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) +If FUNCTION was already added, do nothing. +PROPS is an alist of additional properties, among which the following have +a special meaning: +- `name': a string or symbol. It can be used to refer to this piece of advice." + (declare (debug t)) ;;(indent 2) + `(advice--add-function ,where (gv-ref ,place) ,function ,props)) + +;;;###autoload +(defun advice--add-function (where ref function props) + (unless (advice--member-p function (gv-deref ref)) + (setf (gv-deref ref) + (advice--make where function (gv-deref ref) props)))) + +(defmacro remove-function (place function) + "Remove the FUNCTION piece of advice from PLACE. +If FUNCTION was not added to PLACE, do nothing. +Instead of FUNCTION being the actual function, it can also be the `name' +of the piece of advice." + (declare (debug t)) + (gv-letplace (getter setter) place + (macroexp-let2 nil new `(advice--remove-function ,getter ,function) + `(unless (eq ,new ,getter) ,(funcall setter new))))) + +;;;; Specific application of add-function to `symbol-function' for advice. + +(defun advice--subst-main (old new) + (if (not (advice--p old)) + new + (let* ((first (advice--car old)) + (rest (advice--cdr old)) + (props (advice--props old)) + (nrest (advice--subst-main rest new))) + (if (equal rest nrest) old + (advice--make-1 (aref old 1) (aref old 3) + first nrest props))))) + +(defun advice--defalias-fset (fsetfun symbol newdef) + (let* ((olddef (if (fboundp symbol) (symbol-function symbol))) + (oldadv + (cond + ((null (get symbol 'advice--pending)) + (or olddef + (progn + (message "Delayed advice activation failed for %s: no data" + symbol) + nil))) + ((or (not olddef) (autoloadp olddef)) + (prog1 (get symbol 'advice--pending) + (put symbol 'advice--pending nil))) + (t (message "Dropping left-over advice--pending for %s" symbol) + (put symbol 'advice--pending nil) + olddef)))) + (funcall (or fsetfun #'fset) symbol (advice--subst-main oldadv newdef)))) + + +;;;###autoload +(defun advice-add (symbol where function &optional props) + "Like `add-function' but for the function named SYMBOL. +Contrary to `add-function', this will properly handle the cases where SYMBOL +is defined as a macro, alias, command, ..." + ;; TODO: + ;; - record the advice location, to display in describe-function. + ;; - change all defadvice in lisp/**/*.el. + ;; - rewrite advice.el on top of this. + ;; - obsolete advice.el. + ;; To make advice.el and nadvice.el interoperate properly I see 2 different + ;; ways: + ;; - keep them separate: complete the defalias-fset-function setter with + ;; a matching accessor which both nadvice.el and advice.el will have to use + ;; in place of symbol-function. This can probably be made to work, but + ;; they have to agree on a "protocol". + ;; - layer advice.el on top of nadvice.el. I prefer this approach. the + ;; simplest way is to make advice.el build one ad-Advice-foo function for + ;; each advised function which is advice-added/removed whenever ad-activate + ;; ad-deactivate is called. + (let ((f (and (fboundp symbol) (symbol-function symbol)))) + (cond + ((special-form-p f) + ;; Not worth the trouble trying to handle this, I think. + (error "add-advice failure: %S is a special form" symbol)) + ((and (symbolp f) + (eq 'macro (car-safe (ignore-errors (indirect-function f))))) + (let ((newval (cons 'macro (cdr (indirect-function f))))) + (put symbol 'advice--saved-rewrite (cons f newval)) + (fset symbol newval))) + ;; `f' might be a pure (hence read-only) cons! + ((and (eq 'macro (car-safe f)) (not (ignore-errors (setcdr f (cdr f)) t))) + (fset symbol (cons 'macro (cdr f)))) + )) + (let ((f (and (fboundp symbol) (symbol-function symbol)))) + (add-function where (cond + ((eq (car-safe f) 'macro) (cdr f)) + ;; If the function is not yet defined, we can't yet + ;; install the advice. + ;; FIXME: If it's an autoloaded command, we also + ;; have a problem because we need to load the + ;; command to build the interactive-form. + ((or (not f) (and (autoloadp f))) ;; (commandp f) + (get symbol 'advice--pending)) + (t (symbol-function symbol))) + function props) + (add-function :around (get symbol 'defalias-fset-function) + #'advice--defalias-fset)) + nil) + +;;;###autoload +(defun advice-remove (symbol function) + "Like `remove-function' but for the function named SYMBOL. +Contrary to `remove-function', this will work also when SYMBOL is a macro +and it will not signal an error if SYMBOL is not `fboundp'. +Instead of the actual function to remove, FUNCTION can also be the `name' +of the piece of advice." + (when (fboundp symbol) + (let ((f (symbol-function symbol))) + ;; Can't use the `if' place here, because the body is too large, + ;; resulting in use of code that only works with lexical-scoping. + (remove-function (if (eq (car-safe f) 'macro) + (cdr f) + (symbol-function symbol)) + function) + (unless (advice--p + (if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol))) + ;; Not adviced any more. + (remove-function (get symbol 'defalias-fset-function) + #'advice--defalias-fset) + (if (eq (symbol-function symbol) + (cdr (get symbol 'advice--saved-rewrite))) + (fset symbol (car (get symbol 'advice--saved-rewrite)))))) + nil)) + +;; (defun advice-mapc (fun symbol) +;; "Apply FUN to every function added as advice to SYMBOL. +;; FUN is called with a two arguments: the function that was added, and the +;; properties alist that was specified when it was added." +;; (let ((def (or (get symbol 'advice--pending) +;; (if (fboundp symbol) (symbol-function symbol))))) +;; (while (advice--p def) +;; (funcall fun (advice--car def) (advice--props def)) +;; (setq def (advice--cdr def))))) + +;;;###autoload +(defun advice-member-p (function symbol) + "Return non-nil if advice FUNCTION has been added to function SYMBOL. +Instead of FUNCTION being the actual function, it can also be the `name' +of the piece of advice." + (advice--member-p function + (or (get symbol 'advice--pending) + (if (fboundp symbol) (symbol-function symbol))))) + + +(provide 'nadvice) +;;; nadvice.el ends here diff --git a/lisp/subr.el b/lisp/subr.el index 0ba932a3efe..ebfcfbc0930 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2809,6 +2809,12 @@ Otherwise, return nil." Otherwise, return nil." (and (memq object '(nil t)) t)) +(defun special-form-p (object) + "Non-nil if and only if OBJECT is a special form." + (if (and (symbolp object) (fboundp object)) + (setq object (indirect-function object))) + (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) + (defun field-at-pos (pos) "Return the field at position POS, taking stickiness etc into account." (let ((raw-field (get-char-property (field-beginning pos) 'field))) diff --git a/test/ChangeLog b/test/ChangeLog index 72b44747bac..4a9d215aa21 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2012-11-12 Stefan Monnier + + * automated/advice-tests.el: New tests. + 2012-10-14 Eli Zaretskii * automated/compile-tests.el (compile-tests--test-regexps-data): diff --git a/test/automated/advice-tests.el b/test/automated/advice-tests.el new file mode 100644 index 00000000000..cac10e9602f --- /dev/null +++ b/test/automated/advice-tests.el @@ -0,0 +1,66 @@ +;;; advice-tests.el --- Test suite for the new advice thingy. + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(defvar advice-tests--data + '(((defun sm-test1 (x) (+ x 4)) + (sm-test1 6) 10) + ((advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (sm-test1 6) 50) + ((defun sm-test1 (x) (+ x 14)) + (sm-test1 6) 100) + ((null (get 'sm-test1 'defalias-fset-function)) nil) + ((advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (sm-test1 6) 20) + ((null (get 'sm-test1 'defalias-fset-function)) t) + + ((defun sm-test2 (x) (+ x 4)) + (sm-test2 6) 10) + ((defadvice sm-test2 (around sm-test activate) + ad-do-it (setq ad-return-value (* ad-return-value 5))) + (sm-test2 6) 50) + ((ad-deactivate 'sm-test2) + (sm-test2 6) 10) + ((ad-activate 'sm-test2) + (sm-test2 6) 50) + ((defun sm-test2 (x) (+ x 14)) + (sm-test2 6) 100) + ((null (get 'sm-test2 'defalias-fset-function)) nil) + ((ad-remove-advice 'sm-test2 'around 'sm-test) + (sm-test2 6) 100) + ((ad-activate 'sm-test2) + (sm-test2 6) 20) + ((null (get 'sm-test2 'defalias-fset-function)) t) + )) + +(ert-deftest advice-tests () + "Test advice code." + (with-temp-buffer + (dolist (test advice-tests--data) + (let ((res (eval `(progn ,@(butlast test))))) + (should (equal (car (last test)) res)))))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; advice-tests.el ends here. -- cgit v1.2.3 From f8705f6e3102454bf1e3213956eb3ac8160ff047 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 12 Nov 2012 16:31:15 -0500 Subject: * lisp/emacs-lisp/gv.el (gv-define-simple-setter): One more fix. Fixes: debbugs:12871 --- lisp/ChangeLog | 8 ++++++-- lisp/emacs-lisp/gv.el | 5 +++-- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a927c010724..2ad7230e912 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2012-11-12 Stefan Monnier + + * emacs-lisp/gv.el (gv-define-simple-setter): One more fix (bug#12871). + 2012-11-12 Wolfgang Jenkner * ansi-color.el (ansi-color-apply-sequence): Implement SGR codes @@ -13,7 +17,7 @@ correctly. (python-nav-end-of-defun): Rename from python-end-of-defun-function. Ensure forward movement. - (python-info-current-defun): Reimplemented to work as intended + (python-info-current-defun): Reimplement to work as intended with new fixed python-nav-{end,beginning}-of-defun. Stop scanning parent defuns as soon as possible. @@ -62,7 +66,7 @@ 2012-11-09 Jan Djärv - * server.el (server-create-window-system-frame): Improved comment. + * server.el (server-create-window-system-frame): Improve comment. 2012-11-08 Jan Djärv diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 38bb6319a03..965fc1c3ef0 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -220,8 +220,9 @@ so as to preserve the semantics of `setf'." `(gv-define-setter ,name (val &rest args) ,(if fix-return `(macroexp-let2 nil v val - (cons ',setter (append args (list v))) - v) + `(progn + (,',setter ,@(append args (list v))) + ,v)) `(cons ',setter (append args (list val)))))) ;;; Typical operations on generalized variables. -- cgit v1.2.3 From 413d4689c0c3f616856615ac7b8bb047c5f2febd Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 12 Nov 2012 22:00:09 -0500 Subject: * lisp/emacs-lisp/cl.el (dolist, dotimes, declare): Use advice-add to override the default. * lisp/emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Rewrite without using cl--dotimes/dolist. * lisp/subr.el (dolist, dotimes, declare): Redefine them normally, even when `cl' is loaded. * lisp/emacs-lisp/nadvice.el (advice--normalize): New function, extracted from add-advice. (advice--strip-macro): New function. (advice--defalias-fset): Use them to handle macros. (advice-add): Use them. (advice-member-p): Correctly handle macros. --- lisp/ChangeLog | 16 ++++++++ lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/cl-macs.el | 12 +++--- lisp/emacs-lisp/cl.el | 20 +++++----- lisp/emacs-lisp/nadvice.el | 87 +++++++++++++++++++++++++----------------- lisp/subr.el | 6 --- test/automated/advice-tests.el | 7 ++++ 7 files changed, 91 insertions(+), 59 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6ab2880f09f..92f3343db64 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,19 @@ +2012-11-13 Stefan Monnier + + * emacs-lisp/cl.el (dolist, dotimes, declare): Use advice-add to + override the default. + * emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Rewrite without using + cl--dotimes/dolist. + * subr.el (dolist, dotimes, declare): Redefine them normally, even when + `cl' is loaded. + + * emacs-lisp/nadvice.el (advice--normalize): New function, extracted + from add-advice. + (advice--strip-macro): New function. + (advice--defalias-fset): Use them to handle macros. + (advice-add): Use them. + (advice-member-p): Correctly handle macros. + 2012-11-13 Stefan Monnier * emacs-lisp/gv.el (gv-define-simple-setter): One more fix (bug#12871). diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index bf99af2f7e6..eb58d17c02e 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -267,7 +267,7 @@ including `cl-block' and `cl-eval-when'. ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp ;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) -;;;;;; "cl-macs" "cl-macs.el" "a7228877484d2b39e1c2bee40b011734") +;;;;;; "cl-macs" "cl-macs.el" "c7ad09a74a1d2969406e7e2aaf3812fc") ;;; Generated autoloads from cl-macs.el (autoload 'cl--compiler-macro-list* "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b28f8f7f9e9..3c46c40242d 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1547,9 +1547,9 @@ An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" (declare (debug ((symbolp form &optional form) cl-declarations body)) (indent 1)) - `(cl-block nil - (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist) - ,spec ,@body))) + (let ((loop `(dolist ,spec ,@body))) + (if (advice-member-p #'cl--wrap-in-nil-block 'dolist) + loop `(cl-block nil ,loop)))) ;;;###autoload (defmacro cl-dotimes (spec &rest body) @@ -1560,9 +1560,9 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (debug cl-dolist) (indent 1)) - `(cl-block nil - (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes) - ,spec ,@body))) + (let ((loop `(dotimes ,spec ,@body))) + (if (advice-member-p #'cl--wrap-in-nil-block 'dotimes) + loop `(cl-block nil ,loop)))) ;;;###autoload (defmacro cl-do-symbols (spec &rest body) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 016967bc713..40d12358b17 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -107,14 +107,6 @@ )) (defvaralias var (intern (format "cl-%s" var)))) -;; Before overwriting subr.el's `dotimes' and `dolist', let's remember -;; them under a different name, so we can use them in our implementation -;; of `dotimes' and `dolist'. -(unless (fboundp 'cl--dotimes) - (defalias 'cl--dotimes (symbol-function 'dotimes) "The non-CL `dotimes'.")) -(unless (fboundp 'cl--dolist) - (defalias 'cl--dolist (symbol-function 'dolist) "The non-CL `dolist'.")) - (dolist (fun '( (get* . cl-get) (random* . cl-random) @@ -228,7 +220,6 @@ remf psetf (define-setf-method . define-setf-expander) - declare the locally multiple-value-setq @@ -239,8 +230,6 @@ psetq do-all-symbols do-symbols - dotimes - dolist do* do loop @@ -322,6 +311,15 @@ (intern (format "cl-%s" fun))))) (defalias fun new))) +(defun cl--wrap-in-nil-block (fun &rest args) + `(cl-block nil ,(apply fun args))) +(advice-add 'dolist :around #'cl--wrap-in-nil-block) +(advice-add 'dotimes :around #'cl--wrap-in-nil-block) + +(defun cl--pass-args-to-cl-declare (&rest specs) + (macroexpand `(cl-declare ,@specs))) +(advice-add 'declare :after #'cl--pass-args-to-cl-declare) + ;;; Features provided a bit differently in Elisp. ;; First, the old lexical-let is now better served by `lexical-binding', tho diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 020a2f89bdb..ca1ebf3cad2 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -230,23 +230,49 @@ of the piece of advice." (advice--make-1 (aref old 1) (aref old 3) first nrest props))))) +(defun advice--normalize (symbol def) + (cond + ((special-form-p def) + ;; Not worth the trouble trying to handle this, I think. + (error "add-advice failure: %S is a special form" symbol)) + ((and (symbolp def) + (eq 'macro (car-safe (ignore-errors (indirect-function def))))) + (let ((newval (cons 'macro (cdr (indirect-function def))))) + (put symbol 'advice--saved-rewrite (cons def newval)) + newval)) + ;; `f' might be a pure (hence read-only) cons! + ((and (eq 'macro (car-safe def)) + (not (ignore-errors (setcdr def (cdr def)) t))) + (cons 'macro (cdr def))) + (t def))) + +(defsubst advice--strip-macro (x) + (if (eq 'macro (car-safe x)) (cdr x) x)) + (defun advice--defalias-fset (fsetfun symbol newdef) - (let* ((olddef (if (fboundp symbol) (symbol-function symbol))) + (when (get symbol 'advice--saved-rewrite) + (put symbol 'advice--saved-rewrite nil)) + (setq newdef (advice--normalize symbol newdef)) + (let* ((olddef (advice--strip-macro + (if (fboundp symbol) (symbol-function symbol)))) (oldadv (cond - ((null (get symbol 'advice--pending)) - (or olddef - (progn - (message "Delayed advice activation failed for %s: no data" - symbol) - nil))) - ((or (not olddef) (autoloadp olddef)) - (prog1 (get symbol 'advice--pending) - (put symbol 'advice--pending nil))) + ((null (get symbol 'advice--pending)) + (or olddef + (progn + (message "Delayed advice activation failed for %s: no data" + symbol) + nil))) + ((or (not olddef) (autoloadp olddef)) + (prog1 (get symbol 'advice--pending) + (put symbol 'advice--pending nil))) (t (message "Dropping left-over advice--pending for %s" symbol) (put symbol 'advice--pending nil) olddef)))) - (funcall (or fsetfun #'fset) symbol (advice--subst-main oldadv newdef)))) + (let* ((snewdef (advice--strip-macro newdef)) + (snewadv (advice--subst-main oldadv snewdef))) + (funcall (or fsetfun #'fset) symbol + (if (eq snewdef newdef) snewadv (cons 'macro snewadv)))))) ;;;###autoload @@ -269,29 +295,18 @@ is defined as a macro, alias, command, ..." ;; simplest way is to make advice.el build one ad-Advice-foo function for ;; each advised function which is advice-added/removed whenever ad-activate ;; ad-deactivate is called. - (let ((f (and (fboundp symbol) (symbol-function symbol)))) - (cond - ((special-form-p f) - ;; Not worth the trouble trying to handle this, I think. - (error "add-advice failure: %S is a special form" symbol)) - ((and (symbolp f) - (eq 'macro (car-safe (ignore-errors (indirect-function f))))) - (let ((newval (cons 'macro (cdr (indirect-function f))))) - (put symbol 'advice--saved-rewrite (cons f newval)) - (fset symbol newval))) - ;; `f' might be a pure (hence read-only) cons! - ((and (eq 'macro (car-safe f)) (not (ignore-errors (setcdr f (cdr f)) t))) - (fset symbol (cons 'macro (cdr f)))) - )) - (let ((f (and (fboundp symbol) (symbol-function symbol)))) + (let* ((f (and (fboundp symbol) (symbol-function symbol))) + (nf (advice--normalize symbol f))) + (unless (eq f nf) ;; Most importantly, if nf == nil! + (fset symbol nf)) (add-function where (cond - ((eq (car-safe f) 'macro) (cdr f)) + ((eq (car-safe nf) 'macro) (cdr nf)) ;; If the function is not yet defined, we can't yet ;; install the advice. ;; FIXME: If it's an autoloaded command, we also ;; have a problem because we need to load the ;; command to build the interactive-form. - ((or (not f) (and (autoloadp f))) ;; (commandp f) + ((or (not nf) (and (autoloadp nf))) ;; (commandp nf) (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) @@ -316,7 +331,7 @@ of the piece of advice." function) (unless (advice--p (if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol))) - ;; Not adviced any more. + ;; Not advised any more. (remove-function (get symbol 'defalias-fset-function) #'advice--defalias-fset) (if (eq (symbol-function symbol) @@ -335,13 +350,15 @@ of the piece of advice." ;; (setq def (advice--cdr def))))) ;;;###autoload -(defun advice-member-p (function symbol) - "Return non-nil if advice FUNCTION has been added to function SYMBOL. -Instead of FUNCTION being the actual function, it can also be the `name' +(defun advice-member-p (advice function-name) + "Return non-nil if ADVICE has been added to FUNCTION-NAME. +Instead of ADVICE being the actual function, it can also be the `name' of the piece of advice." - (advice--member-p function - (or (get symbol 'advice--pending) - (if (fboundp symbol) (symbol-function symbol))))) + (advice--member-p advice + (or (get function-name 'advice--pending) + (advice--strip-macro + (if (fboundp function-name) + (symbol-function function-name)))))) (provide 'nadvice) diff --git a/lisp/subr.el b/lisp/subr.el index ebfcfbc0930..b0ac2dd2106 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -195,11 +195,6 @@ value of last one, or nil if there are none. (declare (indent 1) (debug t)) (cons 'if (cons cond (cons nil body)))) -(if (null (featurep 'cl)) - (progn - ;; If we reload subr.el after having loaded CL, be careful not to - ;; overwrite CL's extended definition of `dolist', `dotimes', `declare'. - (defmacro dolist (spec &rest body) "Loop over a list. Evaluate BODY with VAR bound to each car from LIST, in turn. @@ -279,7 +274,6 @@ The possible values of SPECS are specified by `defun-declarations-alist' and `macro-declarations-alist'." ;; FIXME: edebug spec should pay attention to defun-declarations-alist. nil) -)) (defmacro ignore-errors (&rest body) "Execute BODY; if an error occurs, return nil. diff --git a/test/automated/advice-tests.el b/test/automated/advice-tests.el index cac10e9602f..9f9719fdcfc 100644 --- a/test/automated/advice-tests.el +++ b/test/automated/advice-tests.el @@ -50,6 +50,13 @@ ((ad-activate 'sm-test2) (sm-test2 6) 20) ((null (get 'sm-test2 'defalias-fset-function)) t) + + ((advice-add 'sm-test3 :around + (lambda (f &rest args) `(toto ,(apply f args))) + '((name . wrap-with-toto))) + (defmacro sm-test3 (x) `(call-test3 ,x)) + (macroexpand '(sm-test3 56)) (toto (call-test3 56))) + )) (ert-deftest advice-tests () -- cgit v1.2.3 From 7db1bda8a4a757581f2b93a90657ae667d7e62fb Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 12 Nov 2012 23:05:35 -0500 Subject: * lisp/emacs-lisp/advice.el: Remove support for freezing. (ad-make-freeze-docstring, ad-make-freeze-definition): Remove functions. (ad-make-single-advice-docstring, ad-defadvice-flags, defadvice): Remove support for `freeze'. --- etc/NEWS | 2 + lisp/ChangeLog | 9 ++- lisp/emacs-lisp/advice.el | 138 +++++++--------------------------------------- 3 files changed, 30 insertions(+), 119 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index b6d90b7f8c1..fbe24c8345f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -43,6 +43,8 @@ It is layered as: * Incompatible Lisp Changes in Emacs 24.4 +** `defadvice' does not honor the `freeze' flag any more. + ** `dolist' in lexical-binding mode does not bind VAR in RESULT any more. VAR was bound to nil which was not tremendously useful and just lead to spurious warnings about an unused var. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d04c42da4f1..bab44db48a1 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,10 @@ 2012-11-13 Stefan Monnier + * emacs-lisp/advice.el: Remove support for freezing. + (ad-make-freeze-docstring, ad-make-freeze-definition): Remove functions. + (ad-make-single-advice-docstring, ad-defadvice-flags, defadvice): + Remove support for `freeze'. + * emacs-lisp/cl.el (dolist, dotimes, declare): Use advice-add to override the default. * emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Rewrite without using @@ -16,8 +21,8 @@ 2012-11-13 Dmitry Gutov - * progmodes/ruby-mode.el (ruby-font-lock-keywords): Never - font-lock the beginning of singleton class as heredoc. + * progmodes/ruby-mode.el (ruby-font-lock-keywords): + Never font-lock the beginning of singleton class as heredoc. 2012-11-13 Stefan Monnier diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 16c12aad29b..ecaf6861a6c 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2686,11 +2686,6 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (let ((advice-docstring (ad-docstring (ad-advice-definition advice)))) (cond ((eq style 'plain) advice-docstring) - ((eq style 'freeze) - (format "Permanent %s-advice `%s':%s%s" - class (ad-advice-name advice) - (if advice-docstring "\n" "") - (or advice-docstring ""))) (t (if advice-docstring (format "%s-advice `%s':\n%s" (capitalize (symbol-name class)) @@ -2713,7 +2708,7 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return "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 +according to STYLE. STYLE can be `plain', 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." @@ -2742,8 +2737,6 @@ in any of these classes." (defun ad-make-plain-docstring (function) (ad-make-advised-docstring function 'plain)) -(defun ad-make-freeze-docstring (function) - (ad-make-advised-docstring function 'freeze)) ;; @@@ Accessing overriding arglists and interactive forms: ;; ======================================================== @@ -3125,83 +3118,6 @@ advised definition from scratch." (fmakunbound function))))) -;; @@ Freezing: -;; ============ -;; Freezing transforms a `defadvice' into a redefining `defun/defmacro' -;; for the advised function without keeping any advice information. This -;; feature was jwz's idea: It generates a dumpable function definition -;; whose documentation can be written to the DOC file, and the generated -;; code does not need any Advice runtime support. Of course, frozen advices -;; cannot be undone. - -;; Freezing only considers the advice of the particular `defadvice', other -;; already existing advices for the same function will be ignored. To ensure -;; proper interaction when an already advised function gets redefined with -;; a frozen advice, frozen advices always use the actual original definition -;; of the function, i.e., they are always at the core of the onion. E.g., if -;; an already advised function gets redefined with a frozen advice and then -;; unadvised, the frozen advice remains as the new definition of the function. - -;; While multiple freeze advices for a single function or freeze-advising -;; of an already advised function are possible, they are better avoided, -;; because definition/compile/load ordering is relevant, and it becomes -;; incomprehensible pretty quickly. - -(defun ad-make-freeze-definition (function advice class position) - (if (not (ad-has-proper-definition function)) - (error - "ad-make-freeze-definition: `%s' is not yet defined" - function)) - (cl-letf* - ((name (ad-advice-name advice)) - ;; With a unique origname we can have multiple freeze advices - ;; for the same function, each overloading the previous one: - (unique-origname - (intern (format "%s-%s-%s" (ad-make-origname function) class name))) - (orig-definition - ;; If FUNCTION is already advised, we'll use its current origdef - ;; as the original definition of the frozen advice: - (or (ad-get-orig-definition function) - (symbol-function function))) - (old-advice-info - (if (ad-is-advised function) - (ad-copy-advice-info function))) - ;; Make sure we construct a proper docstring: - ((symbol-function 'ad-make-advised-definition-docstring) - #'ad-make-freeze-docstring) - ;; Make sure `unique-origname' is used as the origname: - ((symbol-function 'ad-make-origname) (lambda (_x) unique-origname)) - (frozen-definition - (unwind-protect - (progn - ;; No we reset all current advice information to nil and - ;; generate an advised definition that's solely determined - ;; by ADVICE and the current origdef of FUNCTION: - (ad-set-advice-info function nil) - (ad-add-advice function advice class position) - ;; The following will provide proper real docstrings as - ;; well as a definition that will make the compiler happy: - (ad-set-orig-definition function orig-definition) - (ad-make-advised-definition function)) - ;; Restore the old advice state: - (ad-set-advice-info function old-advice-info)))) - (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)))))) - - ;; @@ Activation and definition handling: ;; ====================================== @@ -3468,7 +3384,7 @@ deactivation, which might run hooks and get into other trouble." ;; Completion alist of valid `defadvice' flags (defvar ad-defadvice-flags '(("protect") ("disable") ("activate") - ("compile") ("preactivate") ("freeze"))) + ("compile") ("preactivate"))) ;;;###autoload (defmacro defadvice (function args &rest body) @@ -3487,7 +3403,7 @@ POSITION ::= `first' | `last' | NUMBER. Optional, defaults to `first', ARGLIST ::= An optional argument list to be used for the advised function instead of the argument list of the original. The first one found in before/around/after-advices will be used. -FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'|`freeze'. +FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'. All flags can be specified with unambiguous initial substrings. DOCSTRING ::= Optional documentation for this piece of advice. INTERACTIVE-FORM ::= Optional interactive form to be used for the advised @@ -3513,13 +3429,6 @@ time. This generates a compiled advised definition according to the current advice state that will be used during activation if appropriate. Only use this if the `defadvice' gets actually compiled. -`freeze': Expands the `defadvice' into a redefining `defun/defmacro' according -to this particular single advice. No other advice information will be saved. -Frozen advices cannot be undone, they behave like a hard redefinition of -the advised function. `freeze' implies `activate' and `preactivate'. The -documentation of the advised function can be dumped onto the `DOC' file -during preloading. - See Info node `(elisp)Advising Functions' for comprehensive documentation. usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) [DOCSTRING] [INTERACTIVE-FORM] @@ -3569,29 +3478,24 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) (ad-preactivate-advice function advice class position)))) ;; Now for the things to be done at evaluation time: - (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 ',function - ,(if (memq 'compile flags) t)))) - ',function)))) + `(progn + (ad-add-advice ',function ',advice ',class ',position) + ,@(if preactivation + `((ad-set-cache + ',function + ;; the function will get compiled: + ,(cond ((ad-macro-p (car preactivation)) + `(ad-macrofy + (function + ,(ad-lambdafy + (car preactivation))))) + (t `(function + ,(car preactivation)))) + ',(car (cdr preactivation))))) + ,@(if (memq 'activate flags) + `((ad-activate ',function + ,(if (memq 'compile flags) t)))) + ',function))) ;; @@ Tools: -- cgit v1.2.3