[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] /srv/bzr/emacs/trunk r110964: * lisp/emacs-lisp/trace.el:
From: |
Stefan Monnier |
Subject: |
[Emacs-diffs] /srv/bzr/emacs/trunk r110964: * lisp/emacs-lisp/trace.el: Rewrite, use nadvice and lexical-binding. |
Date: |
Tue, 20 Nov 2012 14:30:37 -0500 |
User-agent: |
Bazaar (2.5.0) |
------------------------------------------------------------
revno: 110964
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Tue 2012-11-20 14:30:37 -0500
message:
* lisp/emacs-lisp/trace.el: Rewrite, use nadvice and lexical-binding.
(trace-buffer): Don't purecopy.
(trace-entry-message, trace-exit-message): Add `context' arg.
(trace--timer): New var.
(trace-make-advice): Adjust for use in nadvice.
Add `context' argument. Delay `display-buffer' via a timer.
(trace-function-internal): Use advice-add.
(trace--read-args): New function.
(trace-function-foreground, trace-function-background): Use it.
(trace-function): Rename to trace-function-foreground and redefine as
an alias to that new name.
(untrace-function, untrace-all): Adjust to the use of nadvice.
modified:
etc/NEWS
lisp/ChangeLog
lisp/emacs-lisp/trace.el
=== modified file 'etc/NEWS'
--- a/etc/NEWS 2012-11-19 16:17:49 +0000
+++ b/etc/NEWS 2012-11-20 19:30:37 +0000
@@ -32,6 +32,15 @@
+++
** New function `ses-rename-cell' to give SES cells arbitrary names.
+** trace-function was largely rewritten.
+New features include:
+- no prompting for the destination buffer, unless a prefix-arg was used.
+- additionally to prompting for a destination buffer, when a prefix-arg is
+ used, the user can enter a "context", i.e. Lisp expression whose value at the
+ time the function is entered/exited will be printed along with the function
+ name and arguments. Useful to trace the value of (current-buffer) or
+ (point) when the function is invoked.
+
* New Modes and Packages in Emacs 24.4
** New nadvice.el package offering lighter-weight advice facilities.
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2012-11-20 19:05:20 +0000
+++ b/lisp/ChangeLog 2012-11-20 19:30:37 +0000
@@ -1,5 +1,18 @@
2012-11-20 Stefan Monnier <address@hidden>
+ * emacs-lisp/trace.el: Rewrite, use nadvice and lexical-binding.
+ (trace-buffer): Don't purecopy.
+ (trace-entry-message, trace-exit-message): Add `context' arg.
+ (trace--timer): New var.
+ (trace-make-advice): Adjust for use in nadvice.
+ Add `context' argument. Delay `display-buffer' via a timer.
+ (trace-function-internal): Use advice-add.
+ (trace--read-args): New function.
+ (trace-function-foreground, trace-function-background): Use it.
+ (trace-function): Rename to trace-function-foreground and redefine as
+ an alias to that new name.
+ (untrace-function, untrace-all): Adjust to the use of nadvice.
+
* emacs-lisp/bytecomp.el (byte-compile): Fix handling of closures.
* emacs-lisp/byte-run.el (defun-declarations-alist): Fix last change.
=== modified file 'lisp/emacs-lisp/trace.el'
--- a/lisp/emacs-lisp/trace.el 2012-07-17 08:38:12 +0000
+++ b/lisp/emacs-lisp/trace.el 2012-11-20 19:30:37 +0000
@@ -1,4 +1,4 @@
-;;; trace.el --- tracing facility for Emacs Lisp functions
+;;; trace.el --- tracing facility for Emacs Lisp functions -*-
lexical-binding: t -*-
;; Copyright (C) 1993, 1998, 2000-2012 Free Software Foundation, Inc.
@@ -151,18 +151,15 @@
;;; Code:
-(require 'advice)
-
(defgroup trace nil
"Tracing facility for Emacs Lisp functions."
:prefix "trace-"
:group 'lisp)
;;;###autoload
-(defcustom trace-buffer (purecopy "*trace-output*")
+(defcustom trace-buffer "*trace-output*"
"Trace output will by default go to that buffer."
- :type 'string
- :group 'trace)
+ :type 'string)
;; Current level of traced function invocation:
(defvar trace-level 0)
@@ -176,78 +173,109 @@
(defvar inhibit-trace nil
"If non-nil, all tracing is temporarily inhibited.")
-(defun trace-entry-message (function level argument-bindings)
- ;; Generates a string that describes that FUNCTION has been entered at
- ;; trace LEVEL with ARGUMENT-BINDINGS.
- (format "%s%s%d -> %s: %s\n"
- (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
- (if (> level 1) " " "")
- level
- function
- (let ((print-circle t))
- (mapconcat (lambda (binding)
- (concat
- (symbol-name (ad-arg-binding-field binding 'name))
- "="
- ;; do this so we'll see strings:
- (prin1-to-string
- (ad-arg-binding-field binding 'value))))
- argument-bindings
- " "))))
-
-(defun trace-exit-message (function level value)
- ;; Generates a string that describes that FUNCTION has been exited at
- ;; trace LEVEL and that it returned VALUE.
- (format "%s%s%d <- %s: %s\n"
- (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
- (if (> level 1) " " "")
- level
- function
- ;; do this so we'll see strings:
- (let ((print-circle t)) (prin1-to-string value))))
-
-(defun trace-make-advice (function buffer background)
- ;; Builds the piece of advice to be added to FUNCTION's advice info
- ;; so that it will generate the proper trace output in BUFFER
- ;; (quietly if BACKGROUND is t).
- (ad-make-advice
- trace-advice-name nil t
- `(advice
- lambda ()
- (let ((trace-level (1+ trace-level))
- (trace-buffer (get-buffer-create ,buffer)))
- (unless inhibit-trace
- (with-current-buffer trace-buffer
- (set (make-local-variable 'window-point-insertion-type) t)
- ,(unless background '(display-buffer trace-buffer))
- (goto-char (point-max))
- ;; Insert a separator from previous trace output:
- (if (= trace-level 1) (insert trace-separator))
- (insert
- (trace-entry-message
- ',function trace-level ad-arg-bindings))))
- ad-do-it
- (unless inhibit-trace
- (with-current-buffer trace-buffer
- ,(unless background '(display-buffer trace-buffer))
- (goto-char (point-max))
- (insert
- (trace-exit-message
- ',function trace-level ad-return-value))))))))
-
-(defun trace-function-internal (function buffer background)
- ;; Adds trace advice for FUNCTION and activates it.
- (ad-add-advice
- function
- (trace-make-advice function (or buffer trace-buffer) background)
- 'around 'last)
- (ad-activate function nil))
+(defun trace-entry-message (function level args context)
+ "Generate a string that describes that FUNCTION has been entered.
+LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION,
+and CONTEXT is a string describing the dynamic context (e.g. values of
+some global variables)."
+ (let ((print-circle t))
+ (format "%s%s%d -> %S%s\n"
+ (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
+ (if (> level 1) " " "")
+ level
+ (cons function args)
+ context)))
+
+(defun trace-exit-message (function level value context)
+ "Generate a string that describes that FUNCTION has exited.
+LEVEL is the trace level, VALUE value returned by FUNCTION,
+and CONTEXT is a string describing the dynamic context (e.g. values of
+some global variables)."
+ (let ((print-circle t))
+ (format "%s%s%d <- %s: %S%s\n"
+ (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
+ (if (> level 1) " " "")
+ level
+ function
+ ;; Do this so we'll see strings:
+ value
+ context)))
+
+(defvar trace--timer nil)
+
+(defun trace-make-advice (function buffer background context)
+ "Build the piece of advice to be added to trace FUNCTION.
+FUNCTION is the name of the traced function.
+BUFFER is the buffer where the trace should be printed.
+BACKGROUND if nil means to display BUFFER.
+CONTEXT if non-nil should be a function that returns extra info that should
+be printed along with the arguments in the trace."
+ (lambda (body &rest args)
+ (let ((trace-level (1+ trace-level))
+ (trace-buffer (get-buffer-create buffer))
+ (ctx (funcall context)))
+ (unless inhibit-trace
+ (with-current-buffer trace-buffer
+ (set (make-local-variable 'window-point-insertion-type) t)
+ (unless (or background trace--timer
+ (get-buffer-window trace-buffer 'visible))
+ (setq trace--timer
+ ;; Postpone the display to some later time, in case we
+ ;; can't actually do it now.
+ (run-with-timer 0 nil
+ (lambda ()
+ (setq trace--timer nil)
+ (display-buffer trace-buffer)))))
+ (goto-char (point-max))
+ ;; Insert a separator from previous trace output:
+ (if (= trace-level 1) (insert trace-separator))
+ (insert
+ (trace-entry-message
+ function trace-level args ctx))))
+ (let ((result))
+ (unwind-protect
+ (setq result (list (apply body args)))
+ (unless inhibit-trace
+ (let ((ctx (funcall context)))
+ (with-current-buffer trace-buffer
+ (unless background (display-buffer trace-buffer))
+ (goto-char (point-max))
+ (insert
+ (trace-exit-message
+ function
+ trace-level
+ (if result (car result) '\!non-local\ exit\!)
+ ctx))))))
+ (car result)))))
+
+(defun trace-function-internal (function buffer background context)
+ "Add trace advice for FUNCTION."
+ (advice-add
+ function :around
+ (trace-make-advice function (or buffer trace-buffer) background
+ (or context (lambda () "")))
+ `((name . ,trace-advice-name))))
(defun trace-is-traced (function)
- (ad-find-advice function 'around trace-advice-name))
+ (advice-member-p trace-advice-name function))
+
+(defun trace--read-args (prompt)
+ (cons
+ (intern (completing-read prompt obarray 'fboundp t))
+ (when current-prefix-arg
+ (list
+ (read-buffer "Output to buffer: " trace-buffer)
+ (let ((exp
+ (let ((minibuffer-completing-symbol t))
+ (read-from-minibuffer "Context expression: "
+ nil read-expression-map t
+ 'read-expression-history))))
+ `(lambda ()
+ (let ((print-circle t))
+ (concat " [" (prin1-to-string ,exp) "]"))))))))
;;;###autoload
-(defun trace-function (function &optional buffer)
+(defun trace-function-foreground (function &optional buffer context)
"Traces FUNCTION with trace output going to BUFFER.
For every call of FUNCTION Lisp-style trace messages that display argument
and return values will be inserted into BUFFER. This function generates the
@@ -255,14 +283,11 @@
there might be!! The trace BUFFER will popup whenever FUNCTION is called.
Do not use this to trace functions that switch buffers or do any other
display oriented stuff, use `trace-function-background' instead."
- (interactive
- (list
- (intern (completing-read "Trace function: " obarray 'fboundp t))
- (read-buffer "Output to buffer: " trace-buffer)))
- (trace-function-internal function buffer nil))
+ (interactive (trace--read-args "Trace function: "))
+ (trace-function-internal function buffer nil context))
;;;###autoload
-(defun trace-function-background (function &optional buffer)
+(defun trace-function-background (function &optional buffer context)
"Traces FUNCTION with trace output going quietly to BUFFER.
When this tracing is enabled, every call to FUNCTION writes
a Lisp-style trace message (showing the arguments and return value)
@@ -272,12 +297,11 @@
the window or buffer configuration.
BUFFER defaults to `trace-buffer'."
- (interactive
- (list
- (intern
- (completing-read "Trace function in background: " obarray 'fboundp t))
- (read-buffer "Output to buffer: " trace-buffer)))
- (trace-function-internal function buffer t))
+ (interactive (trace--read-args "Trace function in background: "))
+ (trace-function-internal function buffer t context))
+
+;;;###autoload
+(defalias 'trace-function 'trace-function-foreground)
(defun untrace-function (function)
"Untraces FUNCTION and possibly activates all remaining advice.
@@ -285,16 +309,14 @@
activated only if the advice of FUNCTION is currently active. If FUNCTION
was not traced this is a noop."
(interactive
- (list (ad-read-advised-function "Untrace function" 'trace-is-traced)))
- (when (trace-is-traced function)
- (ad-remove-advice function 'around trace-advice-name)
- (ad-update function)))
+ (list (intern (completing-read "Untrace function: "
+ obarray #'trace-is-traced t))))
+ (advice-remove function trace-advice-name))
(defun untrace-all ()
"Untraces all currently traced functions."
(interactive)
- (ad-do-advised-functions (function)
- (untrace-function function)))
+ (mapatoms #'untrace-function))
(provide 'trace)
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] /srv/bzr/emacs/trunk r110964: * lisp/emacs-lisp/trace.el: Rewrite, use nadvice and lexical-binding.,
Stefan Monnier <=