diff options
| author | Gemini Lasswell | 2018-06-19 07:27:41 -0700 |
|---|---|---|
| committer | Gemini Lasswell | 2018-08-03 08:53:02 -0700 |
| commit | e09120d68694272ea5efbe13b16936b4382389d8 (patch) | |
| tree | 99f072a54e22202ee74969370722564a519e27a7 | |
| parent | 8a7620955b4d859caecd9a5dc9f2a986baf994fd (diff) | |
| download | emacs-e09120d68694272ea5efbe13b16936b4382389d8.tar.gz emacs-e09120d68694272ea5efbe13b16936b4382389d8.zip | |
Add backtrace-mode and use it in the debugger, ERT and Edebug
* doc/lispref/debugging.texi (Using Debugger): Remove explanation of
backtrace buffer. Refer to new node.
(Backtraces): New node.
(Debugger Commands): Refer to new node. Remove 'v'.
* doc/lispref/edebug.texi (Edebug Misc): Refer to new node.
* doc/misc/ert.texi (Running Tests Interactively): Refer to new node.
* lisp/emacs-lisp-backtrace.el: New file.
* test/lisp/emacs-lisp/backtrace-tests.el: New file.
* lisp/emacs-lisp/debug.el: (debugger-buffer-state): New cl-defstruct.
(debugger--restore-buffer-state): New function.
(debug): Use a debugger-buffer-state object to save and restore buffer
state. Fix bug#15749 by leaving an unused buffer in debugger-mode,
empty, instead of in fundamental-mode, and then when reusing a buffer,
not calling debugger-mode if the buffer is already in debugger-mode.
(debugger-insert-backtrace): Remove.
(debugger-setup-buffer): Use backtrace-mode.
(debugger--insert-header): New function.
(debugger-continue, debugger-return-value): Change check for flags to
use backtrace-frames.
(debugger-frame-number): Determine backtrace frame number from
backtrace-frames.
(debugger--locals-visible-p, debugger--insert-locals)
(debugger--show-locals, debugger--hide-locals)
(debugger-toggle-locals): Remove.
(debugger-mode-map): Make a child of backtrace-mode-map. Move
navigation commands to backtrace-mode-map. Bind 'q' to debugger-quit
instead of top-level. Make Help Follow menu item call
backtrace-help-follow-symbol.
(debugger-mode): Derive from backtrace-mode.
(debug-help-follow): Remove. Move body of this function to
'backtrace-help-follow-symbol' in backtrace.el.
(debugger-quit): New function.
* lisp/emacs-lisp/edebug.el (edebug-unwrap-results): Remove warning
in docstring about circular results.
(edebug-unwrap): Use pcase.
(edebug-unwrap1): New function to unwrap circular objects.
(edebug-unwrap*): Use it.
(edebug--frame): New cl-defstruct.
(edebug-backtrace): Call the buffer *Edebug Backtrace* and use
backtrace-mode. Get the frames from edebug--backtrace-frames.
(edebug--backtrace-frames, edebug--unwrap-and-add-info)
(edebug--symbol-not-prefixed-p): New functions.
* lisp/emacs-lisp/lisp-mode.el
(lisp-el-font-lock-keywords-for-backtraces)
(lisp-el-font-lock-keywords-for-backtraces-1)
(lisp-el-font-lock-keywords-for-backtraces-2): New constants.
* lisp/emacs-lisp/ert.el (ert--print-backtrace): Remove.
(ert--run-test-debugger): Use backtrace-get-frames.
(ert-run-tests-batch): Use backtrace-to-string.
(ert-results-pop-to-backtrace-for-test-at-point): Use backtrace-mode.
(ert--insert-backtrace-header): New function.
* tests/lisp/emacs-lisp/ert-tests.el (ert-test--which-file):
Use backtrace-frame slot accessor.
| -rw-r--r-- | doc/lispref/debugging.texi | 93 | ||||
| -rw-r--r-- | doc/lispref/edebug.texi | 4 | ||||
| -rw-r--r-- | doc/misc/ert.texi | 8 | ||||
| -rw-r--r-- | etc/NEWS | 31 | ||||
| -rw-r--r-- | lisp/emacs-lisp/backtrace.el | 767 | ||||
| -rw-r--r-- | lisp/emacs-lisp/debug.el | 390 | ||||
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 178 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 42 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 10 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/backtrace-tests.el | 89 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/ert-tests.el | 2 |
11 files changed, 1262 insertions, 352 deletions
diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index 1b1f87465db..b5a73a255af 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi | |||
| @@ -81,7 +81,8 @@ debugger recursively. @xref{Recursive Editing}. | |||
| 81 | * Function Debugging:: Entering it when a certain function is called. | 81 | * Function Debugging:: Entering it when a certain function is called. |
| 82 | * Variable Debugging:: Entering it when a variable is modified. | 82 | * Variable Debugging:: Entering it when a variable is modified. |
| 83 | * Explicit Debug:: Entering it at a certain point in the program. | 83 | * Explicit Debug:: Entering it at a certain point in the program. |
| 84 | * Using Debugger:: What the debugger does; what you see while in it. | 84 | * Using Debugger:: What the debugger does. |
| 85 | * Backtraces:: What you see while in the debugger. | ||
| 85 | * Debugger Commands:: Commands used while in the debugger. | 86 | * Debugger Commands:: Commands used while in the debugger. |
| 86 | * Invoking the Debugger:: How to call the function @code{debug}. | 87 | * Invoking the Debugger:: How to call the function @code{debug}. |
| 87 | * Internals of Debugger:: Subroutines of the debugger, and global variables. | 88 | * Internals of Debugger:: Subroutines of the debugger, and global variables. |
| @@ -392,32 +393,79 @@ this is not what you want, you can either set | |||
| 392 | @code{eval-expression-debug-on-error} to @code{nil}, or set | 393 | @code{eval-expression-debug-on-error} to @code{nil}, or set |
| 393 | @code{debug-on-error} to @code{nil} in @code{debugger-mode-hook}. | 394 | @code{debug-on-error} to @code{nil} in @code{debugger-mode-hook}. |
| 394 | 395 | ||
| 396 | The debugger itself must be run byte-compiled, since it makes | ||
| 397 | assumptions about the state of the Lisp interpreter. These | ||
| 398 | assumptions are false if the debugger is running interpreted. | ||
| 399 | |||
| 400 | @node Backtraces | ||
| 401 | @subsection Backtraces | ||
| 402 | @cindex backtrace buffer | ||
| 403 | |||
| 404 | Debugger mode is derived from Backtrace mode, which is also used to | ||
| 405 | show backtraces by Edebug and ERT. (@pxref{Edebug} and @ref{Top,the | ||
| 406 | ERT manual,, ert, ERT: Emacs Lisp Regression Testing}) | ||
| 407 | |||
| 408 | @cindex stack frame | ||
| 409 | The backtrace buffer shows you the functions that are executing and | ||
| 410 | their argument values. When a backtrace buffer is created, it shows | ||
| 411 | each stack frame on one, possibly very long, line. (A stack frame is | ||
| 412 | the place where the Lisp interpreter records information about a | ||
| 413 | particular invocation of a function.) The most recently called | ||
| 414 | function will be at the top. | ||
| 415 | |||
| 395 | @cindex current stack frame | 416 | @cindex current stack frame |
| 396 | The backtrace buffer shows you the functions that are executing and | 417 | In a backtrace you can specify a stack frame by moving point to a line |
| 397 | their argument values. It also allows you to specify a stack frame by | 418 | describing that frame. The frame whose line point is on is considered |
| 398 | moving point to the line describing that frame. (A stack frame is the | 419 | the @dfn{current frame}. |
| 399 | place where the Lisp interpreter records information about a particular | 420 | |
| 400 | invocation of a function.) The frame whose line point is on is | 421 | If a function name is underlined, that means Emacs knows where its |
| 401 | considered the @dfn{current frame}. Some of the debugger commands | 422 | source code is located. You can click with the mouse on that name, or |
| 402 | operate on the current frame. If a line starts with a star, that means | 423 | move to it and type @key{RET}, to visit the source code. You can also |
| 403 | that exiting that frame will call the debugger again. This is useful | 424 | type @key{RET} while point is on any name of a function or variable |
| 404 | for examining the return value of a function. | 425 | which is not underlined, to see help information for that symbol in a |
| 405 | 426 | help buffer, if any exists. The @code{xref-find-definitions} command, | |
| 406 | If a function name is underlined, that means the debugger knows | 427 | bound to @key{M-.}, can also be used on any identifier in a backtrace |
| 407 | where its source code is located. You can click with the mouse on | 428 | (@pxref{Looking Up Identifiers,,,emacs,Emacs manual}). |
| 408 | that name, or move to it and type @key{RET}, to visit the source code. | 429 | |
| 430 | In backtraces, the tails of long lists and the ends of long strings, | ||
| 431 | vectors or structures, as well as objects which are deeply nested, | ||
| 432 | will be printed as underlined ``...''. You can click with the mouse | ||
| 433 | on a ``...'', or type @key{RET} while point is on it, to show the part | ||
| 434 | of the object that was hidden. To control how much abbreviation is | ||
| 435 | done, customize @code{backtrace-line-length}. | ||
| 436 | |||
| 437 | Here is a list of commands for navigating and viewing backtraces: | ||
| 409 | 438 | ||
| 410 | The debugger itself must be run byte-compiled, since it makes | 439 | @table @kbd |
| 411 | assumptions about how many stack frames are used for the debugger | 440 | @item v |
| 412 | itself. These assumptions are false if the debugger is running | 441 | Toggle the display of local variables of the current stack frame. |
| 413 | interpreted. | 442 | |
| 443 | @item p | ||
| 444 | Move to the beginning of the frame, or to the beginning | ||
| 445 | of the previous frame. | ||
| 446 | |||
| 447 | @item n | ||
| 448 | Move to the beginning of the next frame. | ||
| 449 | |||
| 450 | @item + | ||
| 451 | Add line breaks and indentation to the top-level Lisp form at point to | ||
| 452 | make it more readable. | ||
| 453 | |||
| 454 | @item = | ||
| 455 | Collapse the top-level Lisp form at point back to a single line. | ||
| 456 | |||
| 457 | @item # | ||
| 458 | Toggle @code{print-circle} for the frame at point. | ||
| 459 | |||
| 460 | @end table | ||
| 414 | 461 | ||
| 415 | @node Debugger Commands | 462 | @node Debugger Commands |
| 416 | @subsection Debugger Commands | 463 | @subsection Debugger Commands |
| 417 | @cindex debugger command list | 464 | @cindex debugger command list |
| 418 | 465 | ||
| 419 | The debugger buffer (in Debugger mode) provides special commands in | 466 | The debugger buffer (in Debugger mode) provides special commands in |
| 420 | addition to the usual Emacs commands. The most important use of | 467 | addition to the usual Emacs commands and to the Backtrace mode commands |
| 468 | described in the previous section. The most important use of | ||
| 421 | debugger commands is for stepping through code, so that you can see | 469 | debugger commands is for stepping through code, so that you can see |
| 422 | how control flows. The debugger can step through the control | 470 | how control flows. The debugger can step through the control |
| 423 | structures of an interpreted function, but cannot do so in a | 471 | structures of an interpreted function, but cannot do so in a |
| @@ -427,6 +475,11 @@ the same function. (To do this, visit the source for the function and | |||
| 427 | type @kbd{C-M-x} on its definition.) You cannot use the Lisp debugger | 475 | type @kbd{C-M-x} on its definition.) You cannot use the Lisp debugger |
| 428 | to step through a primitive function. | 476 | to step through a primitive function. |
| 429 | 477 | ||
| 478 | Some of the debugger commands operate on the current frame. If a | ||
| 479 | frame starts with a star, that means that exiting that frame will call the | ||
| 480 | debugger again. This is useful for examining the return value of a | ||
| 481 | function. | ||
| 482 | |||
| 430 | @c FIXME: Add @findex for the following commands? --xfq | 483 | @c FIXME: Add @findex for the following commands? --xfq |
| 431 | Here is a list of Debugger mode commands: | 484 | Here is a list of Debugger mode commands: |
| 432 | 485 | ||
| @@ -502,8 +555,6 @@ Display a list of functions that will invoke the debugger when called. | |||
| 502 | This is a list of functions that are set to break on entry by means of | 555 | This is a list of functions that are set to break on entry by means of |
| 503 | @code{debug-on-entry}. | 556 | @code{debug-on-entry}. |
| 504 | 557 | ||
| 505 | @item v | ||
| 506 | Toggle the display of local variables of the current stack frame. | ||
| 507 | @end table | 558 | @end table |
| 508 | 559 | ||
| 509 | @node Invoking the Debugger | 560 | @node Invoking the Debugger |
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index b9cc1d5afc2..0e0a2e8a643 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi | |||
| @@ -442,8 +442,8 @@ Redisplay the most recently known expression result in the echo area | |||
| 442 | Display a backtrace, excluding Edebug's own functions for clarity | 442 | Display a backtrace, excluding Edebug's own functions for clarity |
| 443 | (@code{edebug-backtrace}). | 443 | (@code{edebug-backtrace}). |
| 444 | 444 | ||
| 445 | You cannot use debugger commands in the backtrace buffer in Edebug as | 445 | @xref{Debugging,, Backtraces, elisp}, for the commands which work |
| 446 | you would in the standard debugger. | 446 | in a backtrace buffer. |
| 447 | 447 | ||
| 448 | The backtrace buffer is killed automatically when you continue | 448 | The backtrace buffer is killed automatically when you continue |
| 449 | execution. | 449 | execution. |
diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index 82e0e27ed1c..e2aeeb1353a 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi | |||
| @@ -273,9 +273,11 @@ moving point to it and typing @kbd{@key{RET}} jumps to its definition. | |||
| 273 | @cindex backtrace of a failed test | 273 | @cindex backtrace of a failed test |
| 274 | Pressing @kbd{r} re-runs the test near point on its own. Pressing | 274 | Pressing @kbd{r} re-runs the test near point on its own. Pressing |
| 275 | @kbd{d} re-runs it with the debugger enabled. @kbd{.} jumps to the | 275 | @kbd{d} re-runs it with the debugger enabled. @kbd{.} jumps to the |
| 276 | definition of the test near point (@kbd{@key{RET}} has the same effect if | 276 | definition of the test near point (@kbd{@key{RET}} has the same effect |
| 277 | point is on the name of the test). On a failed test, @kbd{b} shows | 277 | if point is on the name of the test). On a failed test, @kbd{b} shows |
| 278 | the backtrace of the failure. | 278 | the backtrace of the failure. @xref{Debugging,, Backtraces, elisp, |
| 279 | the Emacs Lisp Reference Manual}, for more information about | ||
| 280 | backtraces. | ||
| 279 | 281 | ||
| 280 | @kindex l@r{, in ert results buffer} | 282 | @kindex l@r{, in ert results buffer} |
| 281 | @kbd{l} shows the list of @code{should} forms executed in the test. | 283 | @kbd{l} shows the list of @code{should} forms executed in the test. |
| @@ -466,6 +466,14 @@ the shift key. | |||
| 466 | *** Isearch now remembers the regexp-based search mode for words/symbols | 466 | *** Isearch now remembers the regexp-based search mode for words/symbols |
| 467 | and case-sensitivity together with search strings in the search ring. | 467 | and case-sensitivity together with search strings in the search ring. |
| 468 | 468 | ||
| 469 | ** Debugger | ||
| 470 | |||
| 471 | +++ | ||
| 472 | *** The Lisp Debugger is now based on 'backtrace-mode'. | ||
| 473 | Backtrace mode adds fontification and commands for changing the | ||
| 474 | appearance of backtrace frames. See the node "Backtraces" in the Elisp | ||
| 475 | manual for documentation of the new mode and its commands. | ||
| 476 | |||
| 469 | ** Edebug | 477 | ** Edebug |
| 470 | 478 | ||
| 471 | +++ | 479 | +++ |
| @@ -475,14 +483,18 @@ using the new variables 'edebug-behavior-alist', | |||
| 475 | 'edebug-new-definition-function'. Edebug's behavior can be changed | 483 | 'edebug-new-definition-function'. Edebug's behavior can be changed |
| 476 | globally or for individual definitions. | 484 | globally or for individual definitions. |
| 477 | 485 | ||
| 486 | +++ | ||
| 487 | *** Edebug's backtrace buffer now uses 'backtrace-mode'. | ||
| 488 | Backtrace mode adds fontification, links and commands for changing the | ||
| 489 | appearance of backtrace frames. See the node "Backtraces" in the Elisp | ||
| 490 | manual for documentation of the new mode and its commands. | ||
| 491 | |||
| 478 | ** Enhanced xterm support | 492 | ** Enhanced xterm support |
| 479 | 493 | ||
| 480 | *** New variable 'xterm-set-window-title' controls whether Emacs sets | 494 | *** New variable 'xterm-set-window-title' controls whether Emacs sets |
| 481 | the XTerm window title. This feature is experimental and is disabled | 495 | the XTerm window title. This feature is experimental and is disabled |
| 482 | by default. | 496 | by default. |
| 483 | 497 | ||
| 484 | ** Gamegrid | ||
| 485 | |||
| 486 | ** grep | 498 | ** grep |
| 487 | 499 | ||
| 488 | +++ | 500 | +++ |
| @@ -499,6 +511,14 @@ The abbreviation can be disabled by the new option | |||
| 499 | *** New variable 'ert-quiet' allows to make ERT output in batch mode | 511 | *** New variable 'ert-quiet' allows to make ERT output in batch mode |
| 500 | less verbose by removing non-essential information. | 512 | less verbose by removing non-essential information. |
| 501 | 513 | ||
| 514 | +++ | ||
| 515 | *** ERT's backtrace buffer now uses 'backtrace-mode'. | ||
| 516 | Backtrace mode adds fontification and commands for changing the | ||
| 517 | appearance of backtrace frames. See the node "Backtraces" in the Elisp | ||
| 518 | manual for documentation of the new mode and its commands. | ||
| 519 | |||
| 520 | ** Gamegrid | ||
| 521 | |||
| 502 | --- | 522 | --- |
| 503 | *** Gamegrid now determines its default glyph size based on display | 523 | *** Gamegrid now determines its default glyph size based on display |
| 504 | dimensions, instead of always using 16 pixels. As a result, Tetris, | 524 | dimensions, instead of always using 16 pixels. As a result, Tetris, |
| @@ -669,6 +689,13 @@ transport strategies as well as a separate API to use them. A | |||
| 669 | transport implementation for process-based communication, such as is | 689 | transport implementation for process-based communication, such as is |
| 670 | used by the Language Server Protocol (LSP), is readily available. | 690 | used by the Language Server Protocol (LSP), is readily available. |
| 671 | 691 | ||
| 692 | +++ | ||
| 693 | ** Backtrace mode improves viewing of Elisp backtraces. | ||
| 694 | Backtrace mode adds pretty printing, fontification and ellipsis | ||
| 695 | expansion to backtrace buffers produced by the Lisp debugger, Edebug | ||
| 696 | and ERT. See the node "Backtraces" in the Elisp manual for | ||
| 697 | documentation of the new mode and its commands. | ||
| 698 | |||
| 672 | 699 | ||
| 673 | * Incompatible Lisp Changes in Emacs 27.1 | 700 | * Incompatible Lisp Changes in Emacs 27.1 |
| 674 | 701 | ||
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el new file mode 100644 index 00000000000..d16edb6a6cf --- /dev/null +++ b/lisp/emacs-lisp/backtrace.el | |||
| @@ -0,0 +1,767 @@ | |||
| 1 | ;;; backtrace.el --- generic major mode for Elisp backtraces -*- lexical-binding: t -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 2018 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Gemini Lasswell | ||
| 6 | ;; Keywords: lisp, tools, maint | ||
| 7 | ;; Version: 1.0 | ||
| 8 | |||
| 9 | ;; This file is part of GNU Emacs. | ||
| 10 | |||
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 12 | ;; it under the terms of the GNU General Public License as published by | ||
| 13 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 14 | ;; (at your option) any later version. | ||
| 15 | |||
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 19 | ;; GNU General Public License for more details. | ||
| 20 | |||
| 21 | ;; You should have received a copy of the GNU General Public License | ||
| 22 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
| 23 | |||
| 24 | ;;; Commentary: | ||
| 25 | |||
| 26 | ;; This file defines Backtrace mode, a generic major mode for displaying | ||
| 27 | ;; Elisp stack backtraces, which can be used as is or inherited from | ||
| 28 | ;; by another mode. | ||
| 29 | |||
| 30 | ;; For usage information, see the documentation of `backtrace-mode'. | ||
| 31 | |||
| 32 | ;;; Code: | ||
| 33 | |||
| 34 | (eval-when-compile (require 'cl-lib)) | ||
| 35 | (eval-when-compile (require 'pcase)) | ||
| 36 | (eval-when-compile (require 'subr-x)) ; if-let | ||
| 37 | (require 'help-mode) ; Define `help-function-def' button type. | ||
| 38 | (require 'lisp-mode) | ||
| 39 | |||
| 40 | ;;; Options | ||
| 41 | |||
| 42 | (defgroup backtrace nil | ||
| 43 | "Viewing of Elisp backtraces." | ||
| 44 | :group 'lisp) | ||
| 45 | |||
| 46 | (defcustom backtrace-fontify t | ||
| 47 | "If non-nil, fontify Backtrace buffers. | ||
| 48 | Set to nil to disable fontification, which may be necessary in | ||
| 49 | order to debug the code that does fontification." | ||
| 50 | :type 'boolean | ||
| 51 | :group 'backtrace | ||
| 52 | :version "27.1") | ||
| 53 | |||
| 54 | (defcustom backtrace-line-length 5000 | ||
| 55 | "Target length for lines in Backtrace buffers. | ||
| 56 | Backtrace mode will attempt to abbreviate printing of backtrace | ||
| 57 | frames to make them shorter than this, but success is not | ||
| 58 | guaranteed." | ||
| 59 | :type 'integer | ||
| 60 | :group 'backtrace | ||
| 61 | :version "27.1") | ||
| 62 | |||
| 63 | ;;; Backtrace frame data structure | ||
| 64 | |||
| 65 | (cl-defstruct | ||
| 66 | (backtrace-frame | ||
| 67 | (:constructor backtrace-make-frame)) | ||
| 68 | evald fun args flags locals pos) | ||
| 69 | |||
| 70 | (cl-defun backtrace-get-frames | ||
| 71 | (&optional base &key (constructor #'backtrace-make-frame)) | ||
| 72 | "Collect all frames of current backtrace into a list. | ||
| 73 | The list will contain objects made by CONSTRUCTOR, which | ||
| 74 | defaults to `backtrace-make-frame' and which, if provided, should | ||
| 75 | be the constructor of a structure which includes | ||
| 76 | `backtrace-frame'. If non-nil, BASE should be a function, and | ||
| 77 | frames before its nearest activation frame are discarded." | ||
| 78 | (let ((frames nil) | ||
| 79 | (eval-buffers eval-buffer-list)) | ||
| 80 | (mapbacktrace (lambda (evald fun args flags) | ||
| 81 | (push (funcall constructor | ||
| 82 | :evald evald :fun fun | ||
| 83 | :args args :flags flags) | ||
| 84 | frames)) | ||
| 85 | (or base 'backtrace-get-frames)) | ||
| 86 | (setq frames (nreverse frames)) | ||
| 87 | ;; Add local variables to each frame, and the buffer position | ||
| 88 | ;; to frames containing eval-buffer or eval-region. | ||
| 89 | (dotimes (idx (length frames)) | ||
| 90 | (let ((frame (nth idx frames))) | ||
| 91 | ;; `backtrace--locals' gives an error when idx is 0. But the | ||
| 92 | ;; locals for frame 0 are not needed, because when we get here | ||
| 93 | ;; from debug-on-entry, the locals aren't bound yet, and when | ||
| 94 | ;; coming from Edebug or ERT there is an Edebug or ERT | ||
| 95 | ;; function at frame 0. | ||
| 96 | (when (> idx 0) | ||
| 97 | (setf (backtrace-frame-locals frame) | ||
| 98 | (backtrace--locals idx (or base 'backtrace-get-frames)))) | ||
| 99 | (when (and eval-buffers (memq (backtrace-frame-fun frame) | ||
| 100 | '(eval-buffer eval-region))) | ||
| 101 | ;; This will get the wrong result if there are two nested | ||
| 102 | ;; eval-region calls for the same buffer. That's not a very | ||
| 103 | ;; useful case. | ||
| 104 | (with-current-buffer (pop eval-buffers) | ||
| 105 | (setf (backtrace-frame-pos frame) (point)))))) | ||
| 106 | frames)) | ||
| 107 | |||
| 108 | ;; Font Locking support | ||
| 109 | |||
| 110 | (defconst backtrace--font-lock-keywords | ||
| 111 | '((backtrace--match-ellipsis-in-string | ||
| 112 | (1 'button prepend))) | ||
| 113 | "Expressions to fontify in Backtrace mode. | ||
| 114 | Fontify these in addition to the expressions Emacs Lisp mode | ||
| 115 | fontifies.") | ||
| 116 | |||
| 117 | (defconst backtrace-font-lock-keywords | ||
| 118 | (append lisp-el-font-lock-keywords-for-backtraces | ||
| 119 | backtrace--font-lock-keywords) | ||
| 120 | "Default expressions to highlight in Backtrace mode.") | ||
| 121 | (defconst backtrace-font-lock-keywords-1 | ||
| 122 | (append lisp-el-font-lock-keywords-for-backtraces-1 | ||
| 123 | backtrace--font-lock-keywords) | ||
| 124 | "Subdued level highlighting for Backtrace mode.") | ||
| 125 | (defconst backtrace-font-lock-keywords-2 | ||
| 126 | (append lisp-el-font-lock-keywords-for-backtraces-2 | ||
| 127 | backtrace--font-lock-keywords) | ||
| 128 | "Gaudy level highlighting for Backtrace mode.") | ||
| 129 | |||
| 130 | (defun backtrace--match-ellipsis-in-string (bound) | ||
| 131 | ;; Fontify ellipses within strings as buttons. | ||
| 132 | (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t) | ||
| 133 | (and (get-text-property (- (point) 2) 'cl-print-ellipsis) | ||
| 134 | (get-text-property (- (point) 3) 'cl-print-ellipsis) | ||
| 135 | (get-text-property (- (point) 4) 'cl-print-ellipsis)))) | ||
| 136 | |||
| 137 | ;;; Xref support | ||
| 138 | |||
| 139 | (defun backtrace--xref-backend () 'elisp) | ||
| 140 | |||
| 141 | ;;; Backtrace mode variables | ||
| 142 | |||
| 143 | (defvar-local backtrace-frames nil | ||
| 144 | "Stack frames displayed in the current Backtrace buffer. | ||
| 145 | This should be a list of `backtrace-frame' objects.") | ||
| 146 | |||
| 147 | (defvar-local backtrace-view nil | ||
| 148 | "A plist describing how to render backtrace frames. | ||
| 149 | Possible entries are :show-flags, :do-xrefs and :print-circle.") | ||
| 150 | |||
| 151 | (defvar-local backtrace-insert-header-function nil | ||
| 152 | "Function for inserting a header for the current Backtrace buffer. | ||
| 153 | If nil, no header will be created. Note that Backtrace buffers | ||
| 154 | are fontified as in Emacs Lisp Mode, the header text included.") | ||
| 155 | |||
| 156 | (defvar backtrace-revert-hook nil | ||
| 157 | "Hook run before reverting a Backtrace buffer. | ||
| 158 | This is commonly used to recompute `backtrace-frames'.") | ||
| 159 | |||
| 160 | (defvar-local backtrace-print-function #'cl-prin1 | ||
| 161 | "Function used to print values in the current Backtrace buffer.") | ||
| 162 | |||
| 163 | (defvar backtrace-mode-map | ||
| 164 | (let ((map (copy-keymap special-mode-map))) | ||
| 165 | (set-keymap-parent map button-buffer-map) | ||
| 166 | (define-key map "n" 'backtrace-forward-frame) | ||
| 167 | (define-key map "p" 'backtrace-backward-frame) | ||
| 168 | (define-key map "v" 'backtrace-toggle-locals) | ||
| 169 | (define-key map "#" 'backtrace-toggle-print-circle) | ||
| 170 | (define-key map "\C-m" 'backtrace-help-follow-symbol) | ||
| 171 | (define-key map "+" 'backtrace-pretty-print) | ||
| 172 | (define-key map "=" 'backtrace-collapse) | ||
| 173 | (define-key map [follow-link] 'mouse-face) | ||
| 174 | (define-key map [mouse-2] 'mouse-select-window) | ||
| 175 | map) | ||
| 176 | "Local keymap for `backtrace-mode' buffers.") | ||
| 177 | |||
| 178 | ;;; Navigation and Text Properties | ||
| 179 | |||
| 180 | ;; This mode uses the following text properties: | ||
| 181 | ;; backtrace-index: The index into the buffer-local variable | ||
| 182 | ;; `backtrace-frames' for the frame at point, or nil if outside of a | ||
| 183 | ;; frame (in the buffer header). | ||
| 184 | ;; backtrace-view: A plist describing how the frame is printed. See | ||
| 185 | ;; the docstring for the buffer-local variable `backtrace-view. | ||
| 186 | ;; backtrace-section: The part of a frame which point is in. Either | ||
| 187 | ;; `func' or `locals'. At the moment just used to show and hide the | ||
| 188 | ;; local variables. Derived modes which do additional printing | ||
| 189 | ;; could define their own frame sections. | ||
| 190 | ;; backtrace-form: A value applied to each printed representation of a | ||
| 191 | ;; top-level s-expression, which needs to be different for sexps | ||
| 192 | ;; printed adjacent to each other, so the limits can be quickly | ||
| 193 | ;; found for pretty-printing. The value chosen is a list contining | ||
| 194 | ;; the values of print-level and print-length used to print the | ||
| 195 | ;; sexp, and those values are used when expanding ellipses. | ||
| 196 | |||
| 197 | (defsubst backtrace-get-index (&optional pos) | ||
| 198 | "Return the index of the backtrace frame at POS. | ||
| 199 | The value is an index into `backtrace-frames', or nil. | ||
| 200 | POS, if omitted or nil, defaults to point." | ||
| 201 | (get-text-property (or pos (point)) 'backtrace-index)) | ||
| 202 | |||
| 203 | (defsubst backtrace-get-section (&optional pos) | ||
| 204 | "Return the section of a backtrace frame at POS. | ||
| 205 | POS, if omitted or nil, defaults to point." | ||
| 206 | (get-text-property (or pos (point)) 'backtrace-section)) | ||
| 207 | |||
| 208 | (defsubst backtrace-get-view (&optional pos) | ||
| 209 | "Return the view plist of the backtrace frame at POS. | ||
| 210 | POS, if omitted or nil, defaults to point." | ||
| 211 | (get-text-property (or pos (point)) 'backtrace-view)) | ||
| 212 | |||
| 213 | (defsubst backtrace-get-form (&optional pos) | ||
| 214 | "Return the backtrace form data for the form printed at POS. | ||
| 215 | POS, if omitted or nil, defaults to point." | ||
| 216 | (get-text-property (or pos (point)) 'backtrace-form)) | ||
| 217 | |||
| 218 | (defun backtrace-get-frame-start (&optional pos) | ||
| 219 | "Return the beginning position of the frame at POS in the buffer. | ||
| 220 | POS, if omitted or nil, defaults to point." | ||
| 221 | (let ((posn (or pos (point)))) | ||
| 222 | (if (or (= (point-min) posn) | ||
| 223 | (not (eq (backtrace-get-index posn) | ||
| 224 | (backtrace-get-index (1- posn))))) | ||
| 225 | posn | ||
| 226 | (previous-single-property-change posn 'backtrace-index nil (point-min))))) | ||
| 227 | |||
| 228 | (defun backtrace-get-frame-end (&optional pos) | ||
| 229 | "Return the position of the end of the frame at POS in the buffer. | ||
| 230 | POS, if omitted or nil, defaults to point." | ||
| 231 | (next-single-property-change (or pos (point)) | ||
| 232 | 'backtrace-index nil (point-max))) | ||
| 233 | |||
| 234 | (defun backtrace-get-section-end (&optional pos) | ||
| 235 | "Return the position of the end of the frame section at POS. | ||
| 236 | POS, if omitted or nil, defaults to point." | ||
| 237 | (let* ((frame-end (backtrace-get-frame-end pos)) | ||
| 238 | (section-end (next-single-property-change | ||
| 239 | (or pos (point)) 'backtrace-section nil frame-end))) | ||
| 240 | (min frame-end section-end))) | ||
| 241 | |||
| 242 | (defun backtrace-forward-frame () | ||
| 243 | "Move forward to the beginning of the next frame." | ||
| 244 | (interactive) | ||
| 245 | (let ((max (backtrace-get-frame-end))) | ||
| 246 | (when (= max (point-max)) | ||
| 247 | (user-error "No next stack frame")) | ||
| 248 | (goto-char max))) | ||
| 249 | |||
| 250 | (defun backtrace-backward-frame () | ||
| 251 | "Move backward to the start of a stack frame." | ||
| 252 | (interactive) | ||
| 253 | (let ((current-index (backtrace-get-index)) | ||
| 254 | (min (backtrace-get-frame-start))) | ||
| 255 | (if (or (and (/= (point) (point-max)) (null current-index)) | ||
| 256 | (= min (point-min)) | ||
| 257 | (and (= min (point)) | ||
| 258 | (null (backtrace-get-index (1- min))))) | ||
| 259 | (user-error "No previous stack frame")) | ||
| 260 | (if (= min (point)) | ||
| 261 | (goto-char (backtrace-get-frame-start (1- min))) | ||
| 262 | (goto-char min)))) | ||
| 263 | |||
| 264 | ;; Other Backtrace mode commands | ||
| 265 | |||
| 266 | (defun backtrace-revert (&rest _ignored) | ||
| 267 | "The `revert-buffer-function' for `backtrace-mode'. | ||
| 268 | It runs `backtrace-revert-hook', then calls `backtrace-print'." | ||
| 269 | (interactive) | ||
| 270 | (unless (derived-mode-p 'backtrace-mode) | ||
| 271 | (error "The current buffer is not in Backtrace mode")) | ||
| 272 | (run-hooks 'backtrace-revert-hook) | ||
| 273 | (backtrace-print t)) | ||
| 274 | |||
| 275 | (defun backtrace-toggle-locals () | ||
| 276 | "Toggle the display of local variables for the backtrace frame at point. | ||
| 277 | TODO with argument, toggle all frames." | ||
| 278 | (interactive) | ||
| 279 | (let ((index (backtrace-get-index))) | ||
| 280 | (unless index | ||
| 281 | (user-error "Not in a stack frame")) | ||
| 282 | (let ((pos (point))) | ||
| 283 | (goto-char (backtrace-get-frame-start)) | ||
| 284 | (while (and (eq index (backtrace-get-index)) | ||
| 285 | (not (eq (backtrace-get-section) 'locals))) | ||
| 286 | (goto-char (next-single-property-change (point) 'backtrace-section))) | ||
| 287 | (let ((end (backtrace-get-section-end))) | ||
| 288 | (backtrace--set-locals-visible (point) end (invisible-p (point))) | ||
| 289 | |||
| 290 | (goto-char (if (invisible-p pos) end pos)))))) | ||
| 291 | |||
| 292 | (defun backtrace--set-locals-visible (beg end visible) | ||
| 293 | (backtrace--change-button-skip beg end (not visible)) | ||
| 294 | (if visible | ||
| 295 | (remove-overlays beg end 'invisible t) | ||
| 296 | (let ((o (make-overlay beg end))) | ||
| 297 | (overlay-put o 'invisible t) | ||
| 298 | (overlay-put o 'evaporate t)))) | ||
| 299 | |||
| 300 | (defun backtrace--change-button-skip (beg end value) | ||
| 301 | "Change the skip property on all buttons between BEG and END. | ||
| 302 | Set it to VALUE unless the button is a `backtrace-ellipsis' button." | ||
| 303 | (let ((inhibit-read-only t)) | ||
| 304 | (setq beg (next-button beg)) | ||
| 305 | (while (and beg (< beg end)) | ||
| 306 | (unless (eq (button-type beg) 'backtrace-ellipsis) | ||
| 307 | (button-put beg 'skip value)) | ||
| 308 | (setq beg (next-button beg))))) | ||
| 309 | |||
| 310 | (defun backtrace-toggle-print-circle () | ||
| 311 | "Toggle `print-circle' for the backtrace frame at point." | ||
| 312 | ;; TODO with argument, toggle the whole buffer. | ||
| 313 | (interactive) | ||
| 314 | (backtrace--toggle-feature :print-circle)) | ||
| 315 | |||
| 316 | (defun backtrace--toggle-feature (feature) | ||
| 317 | "Toggle FEATURE for the backtrace frame at point. | ||
| 318 | FEATURE should be one of the options in `backtrace-view'. | ||
| 319 | After toggling the feature, reprint the frame and position | ||
| 320 | point at the start of the section of the frame it was in | ||
| 321 | before." | ||
| 322 | ;; TODO preserve (in)visibility of locals | ||
| 323 | (let ((index (backtrace-get-index)) | ||
| 324 | (view (copy-sequence (backtrace-get-view)))) | ||
| 325 | (unless index | ||
| 326 | (user-error "Not in a stack frame")) | ||
| 327 | (setq view (plist-put view feature (not (plist-get view feature)))) | ||
| 328 | (let ((inhibit-read-only t) | ||
| 329 | (index (backtrace-get-index)) | ||
| 330 | (section (backtrace-get-section)) | ||
| 331 | (min (backtrace-get-frame-start)) | ||
| 332 | (max (backtrace-get-frame-end))) | ||
| 333 | (delete-region min max) | ||
| 334 | (goto-char min) | ||
| 335 | (backtrace-print-frame (nth index backtrace-frames) view) | ||
| 336 | (add-text-properties min (point) | ||
| 337 | `(backtrace-index ,index backtrace-view ,view)) | ||
| 338 | (goto-char min) | ||
| 339 | (when (not (eq section (backtrace-get-section))) | ||
| 340 | (if-let ((pos (text-property-any (backtrace-get-frame-start) | ||
| 341 | (backtrace-get-frame-end) | ||
| 342 | 'backtrace-section section))) | ||
| 343 | (goto-char pos)))))) | ||
| 344 | |||
| 345 | (defmacro backtrace--with-output-variables (view &rest body) | ||
| 346 | "Bind output variables according to VIEW and execute BODY." | ||
| 347 | (declare (indent 1)) | ||
| 348 | `(let ((print-escape-control-characters t) | ||
| 349 | (print-escape-newlines t) | ||
| 350 | (print-circle (plist-get ,view :print-circle)) | ||
| 351 | (standard-output (current-buffer))) | ||
| 352 | ,@body)) | ||
| 353 | |||
| 354 | (defun backtrace-expand-ellipsis (button) | ||
| 355 | "Expand display of the elided form at BUTTON." | ||
| 356 | ;; TODO a command to expand all ... in form at point | ||
| 357 | ;; with argument, don't bind print-level, length?? | ||
| 358 | ;; Enable undo so there's a way to go back? | ||
| 359 | (interactive) | ||
| 360 | (goto-char (button-start button)) | ||
| 361 | (unless (get-text-property (point) 'cl-print-ellipsis) | ||
| 362 | (if (and (> (point) (point-min)) | ||
| 363 | (get-text-property (1- (point)) 'cl-print-ellipsis)) | ||
| 364 | (backward-char) | ||
| 365 | (user-error "No ellipsis to expand here"))) | ||
| 366 | (let* ((end (next-single-property-change (point) 'cl-print-ellipsis)) | ||
| 367 | (begin (previous-single-property-change end 'cl-print-ellipsis)) | ||
| 368 | (value (get-text-property begin 'cl-print-ellipsis)) | ||
| 369 | (props (backtrace-get-text-properties begin)) | ||
| 370 | (tag (backtrace-get-form begin)) | ||
| 371 | (length (nth 0 tag)) ; TODO should this work with a target char count | ||
| 372 | (level (nth 1 tag)) ; like backtrace-print-to-string? | ||
| 373 | (inhibit-read-only t)) | ||
| 374 | (backtrace--with-output-variables (backtrace-get-view) | ||
| 375 | (let ((print-level level) | ||
| 376 | (print-length length)) | ||
| 377 | (delete-region begin end) | ||
| 378 | (cl-print-expand-ellipsis value (current-buffer)) | ||
| 379 | (setq end (point)) | ||
| 380 | (goto-char begin) | ||
| 381 | (while (< (point) end) | ||
| 382 | (let ((next (next-single-property-change (point) 'cl-print-ellipsis | ||
| 383 | nil end))) | ||
| 384 | (when (get-text-property (point) 'cl-print-ellipsis) | ||
| 385 | (make-text-button (point) next :type 'backtrace-ellipsis)) | ||
| 386 | (goto-char next))) | ||
| 387 | (goto-char begin) | ||
| 388 | (add-text-properties begin end props))))) | ||
| 389 | |||
| 390 | (defun backtrace-pretty-print () | ||
| 391 | "Pretty-print the top level s-expression at point." | ||
| 392 | (interactive) | ||
| 393 | (backtrace--reformat-sexp #'backtrace--pretty-print | ||
| 394 | "No form here to pretty-print")) | ||
| 395 | |||
| 396 | (defun backtrace--pretty-print () | ||
| 397 | "Pretty print the current buffer, then remove the trailing newline." | ||
| 398 | (set-syntax-table emacs-lisp-mode-syntax-table) | ||
| 399 | (pp-buffer) | ||
| 400 | (goto-char (1- (point-max))) | ||
| 401 | (delete-char 1)) | ||
| 402 | |||
| 403 | (defun backtrace-collapse () | ||
| 404 | "Collapse the top level s-expression at point onto one line." | ||
| 405 | (interactive) | ||
| 406 | (backtrace--reformat-sexp #'backtrace--collapse "No form here to collapse")) | ||
| 407 | |||
| 408 | (defun backtrace--collapse () | ||
| 409 | "Replace line breaks and following indentation with spaces. | ||
| 410 | Works on the current buffer." | ||
| 411 | (goto-char (point-min)) | ||
| 412 | (while (re-search-forward "\n[[:blank:]]*" nil t) | ||
| 413 | (replace-match " "))) | ||
| 414 | |||
| 415 | (defun backtrace--reformat-sexp (format-function error-message) | ||
| 416 | "Reformat the top level sexp at point. | ||
| 417 | Locate the top level sexp at or following point on the same line, | ||
| 418 | and reformat it with FORMAT-FUNCTION, preserving the location of | ||
| 419 | point within the sexp. If no sexp is found before the end of | ||
| 420 | the line or buffer, show ERROR-MESSAGE instead. | ||
| 421 | |||
| 422 | FORMAT-FUNCTION will be called without arguments, with the | ||
| 423 | current buffer set to a temporary buffer containing only the | ||
| 424 | content of the sexp." | ||
| 425 | (let* ((orig-pos (point)) | ||
| 426 | (pos (point)) | ||
| 427 | (tag (backtrace-get-form pos)) | ||
| 428 | (end (next-single-property-change pos 'backtrace-form)) | ||
| 429 | (begin (previous-single-property-change end 'backtrace-form | ||
| 430 | nil (point-min)))) | ||
| 431 | (unless tag | ||
| 432 | (when (or (= end (point-max)) (> end (point-at-eol))) | ||
| 433 | (user-error error-message)) | ||
| 434 | (goto-char end) | ||
| 435 | (setq pos end | ||
| 436 | end (next-single-property-change pos 'backtrace-form) | ||
| 437 | begin (previous-single-property-change end 'backtrace-form | ||
| 438 | nil (point-min)))) | ||
| 439 | (let* ((offset (when (>= orig-pos begin) (- orig-pos begin))) | ||
| 440 | (offset-marker (when offset (make-marker))) | ||
| 441 | (content (buffer-substring begin end)) | ||
| 442 | (props (backtrace-get-text-properties begin)) | ||
| 443 | (inhibit-read-only t)) | ||
| 444 | (delete-region begin end) | ||
| 445 | (insert (with-temp-buffer | ||
| 446 | (insert content) | ||
| 447 | (when offset | ||
| 448 | (set-marker-insertion-type offset-marker t) | ||
| 449 | (set-marker offset-marker (+ (point-min) offset))) | ||
| 450 | (funcall format-function) | ||
| 451 | (when offset | ||
| 452 | (setq offset (- (marker-position offset-marker) (point-min)))) | ||
| 453 | (buffer-string))) | ||
| 454 | (when offset | ||
| 455 | (set-marker offset-marker (+ begin offset))) | ||
| 456 | (save-excursion | ||
| 457 | (goto-char begin) | ||
| 458 | (indent-sexp)) | ||
| 459 | (add-text-properties begin (point) props) | ||
| 460 | (if offset | ||
| 461 | (goto-char (marker-position offset-marker)) | ||
| 462 | (goto-char orig-pos))))) | ||
| 463 | |||
| 464 | (defun backtrace-get-text-properties (pos) | ||
| 465 | "Return a plist of backtrace-mode's text properties at POS." | ||
| 466 | (apply #'append | ||
| 467 | (mapcar (lambda (prop) | ||
| 468 | (list prop (get-text-property pos prop))) | ||
| 469 | '(backtrace-section backtrace-index backtrace-view | ||
| 470 | backtrace-form)))) | ||
| 471 | |||
| 472 | (defun backtrace-help-follow-symbol (&optional pos) | ||
| 473 | "Follow cross-reference at POS, defaulting to point. | ||
| 474 | For the cross-reference format, see `help-make-xrefs'." | ||
| 475 | (interactive "d") | ||
| 476 | (unless pos | ||
| 477 | (setq pos (point))) | ||
| 478 | (unless (push-button pos) | ||
| 479 | ;; Check if the symbol under point is a function or variable. | ||
| 480 | (let ((sym | ||
| 481 | (intern | ||
| 482 | (save-excursion | ||
| 483 | (goto-char pos) (skip-syntax-backward "w_") | ||
| 484 | (buffer-substring (point) | ||
| 485 | (progn (skip-syntax-forward "w_") | ||
| 486 | (point))))))) | ||
| 487 | (when (or (boundp sym) (fboundp sym) (facep sym)) | ||
| 488 | (describe-symbol sym))))) | ||
| 489 | |||
| 490 | ;; Print backtrace frames | ||
| 491 | |||
| 492 | (defun backtrace-print (&optional remember-pos) | ||
| 493 | "Populate the current Backtrace mode buffer. | ||
| 494 | This erases the buffer and inserts printed representations of the | ||
| 495 | frames. Optional argument REMEMBER-POS, if non-nil, means to | ||
| 496 | move point to the entry with the same ID element as the current | ||
| 497 | line and recenter window line accordingly." | ||
| 498 | (let ((inhibit-read-only t) | ||
| 499 | entry-index saved-pt window-line) | ||
| 500 | (and remember-pos | ||
| 501 | (setq entry-index (backtrace-get-index)) | ||
| 502 | (when (eq (window-buffer) (current-buffer)) | ||
| 503 | (setq window-line | ||
| 504 | (count-screen-lines (window-start) (point))))) | ||
| 505 | (erase-buffer) | ||
| 506 | (when backtrace-insert-header-function | ||
| 507 | (funcall backtrace-insert-header-function)) | ||
| 508 | (dotimes (idx (length backtrace-frames)) | ||
| 509 | (let ((beg (point)) | ||
| 510 | (elt (nth idx backtrace-frames))) | ||
| 511 | (and entry-index | ||
| 512 | (equal entry-index idx) | ||
| 513 | (setq entry-index nil | ||
| 514 | saved-pt (point))) | ||
| 515 | (backtrace-print-frame elt backtrace-view) | ||
| 516 | (add-text-properties | ||
| 517 | beg (point) | ||
| 518 | `(backtrace-index ,idx backtrace-view ,backtrace-view)))) | ||
| 519 | (set-buffer-modified-p nil) | ||
| 520 | ;; If REMEMBER-POS was specified, move to the "old" location. | ||
| 521 | (if saved-pt | ||
| 522 | (progn (goto-char saved-pt) | ||
| 523 | (when window-line | ||
| 524 | (recenter window-line))) | ||
| 525 | (goto-char (point-min))))) | ||
| 526 | |||
| 527 | ;; Define button type used for ...'s. | ||
| 528 | ;; Set skip property so you don't have to TAB through 100 of them to | ||
| 529 | ;; get to the next function name. | ||
| 530 | (define-button-type 'backtrace-ellipsis | ||
| 531 | 'skip t 'action #'backtrace-expand-ellipsis | ||
| 532 | 'help-echo "mouse-2, RET: expand this ellipsis") | ||
| 533 | |||
| 534 | (defun backtrace-print-to-string (obj &optional limit) | ||
| 535 | "Return a printed representation of OBJ formatted for backtraces. | ||
| 536 | Attempt to get the length of the returned string under LIMIT | ||
| 537 | charcters with appropriate settings of `print-level' and | ||
| 538 | `print-length.' Attach the settings used with the text property | ||
| 539 | `backtrace-form'. LIMIT defaults to `backtrace-line-length'." | ||
| 540 | (backtrace--with-output-variables backtrace-view | ||
| 541 | (backtrace--print-to-string obj limit))) | ||
| 542 | |||
| 543 | (defun backtrace--print-to-string (sexp &optional limit) | ||
| 544 | ;; This is for use by callers who wrap the call with | ||
| 545 | ;; backtrace--with-output-variables. | ||
| 546 | (setq limit (or limit backtrace-line-length)) | ||
| 547 | (let* ((length 50) ; (/ backtrace-line-length 100) ?? | ||
| 548 | (level (truncate (log limit))) | ||
| 549 | (delta (truncate (/ length level)))) | ||
| 550 | (with-temp-buffer | ||
| 551 | (catch 'done | ||
| 552 | (while t | ||
| 553 | (erase-buffer) | ||
| 554 | (let ((standard-output (current-buffer)) | ||
| 555 | (print-length length) | ||
| 556 | (print-level level)) | ||
| 557 | (backtrace--print sexp)) | ||
| 558 | ;; Stop when either the level is too low or the sexp is | ||
| 559 | ;; successfully printed in the space allowed. | ||
| 560 | (when (or (< (- (point-max) (point-min)) limit) (= level 2)) | ||
| 561 | (throw 'done nil)) | ||
| 562 | (cl-decf level) | ||
| 563 | (cl-decf length delta))) | ||
| 564 | (put-text-property (point-min) (point) | ||
| 565 | 'backtrace-form (list length level)) | ||
| 566 | ;; Make buttons from all the "..."s. | ||
| 567 | ;; TODO should this be under control of :do-ellipses in the view | ||
| 568 | ;; plist? | ||
| 569 | (goto-char (point-min)) | ||
| 570 | (while (< (point) (point-max)) | ||
| 571 | (let ((end (next-single-property-change (point) 'cl-print-ellipsis | ||
| 572 | nil (point-max)))) | ||
| 573 | (when (get-text-property (point) 'cl-print-ellipsis) | ||
| 574 | (make-text-button (point) end :type 'backtrace-ellipsis)) | ||
| 575 | (goto-char end))) | ||
| 576 | (buffer-string)))) | ||
| 577 | |||
| 578 | (defun backtrace-print-frame (frame view) | ||
| 579 | "Insert a backtrace FRAME at point formatted according to VIEW. | ||
| 580 | Tag the sections of the frame with the `backtrace-section' text | ||
| 581 | property for use by navigation." | ||
| 582 | (backtrace--with-output-variables view | ||
| 583 | (backtrace--print-flags frame view) | ||
| 584 | (backtrace--print-func-and-args frame view) | ||
| 585 | (backtrace--print-locals frame view))) | ||
| 586 | |||
| 587 | (defun backtrace--print-flags (frame view) | ||
| 588 | "Print the flags of a backtrace FRAME if enabled in VIEW." | ||
| 589 | (let ((beg (point)) | ||
| 590 | (flag (plist-get (backtrace-frame-flags frame) :debug-on-exit))) | ||
| 591 | (insert (if (and (plist-get view :show-flags) flag) "* " " ")) | ||
| 592 | (put-text-property beg (point) 'backtrace-section 'func))) | ||
| 593 | |||
| 594 | (defun backtrace--print-func-and-args (frame view) | ||
| 595 | "Print the function, arguments and buffer position of a backtrace FRAME. | ||
| 596 | Format it according to VIEW." | ||
| 597 | (let* ((beg (point)) | ||
| 598 | (evald (backtrace-frame-evald frame)) | ||
| 599 | (fun (backtrace-frame-fun frame)) | ||
| 600 | (args (backtrace-frame-args frame)) | ||
| 601 | (fun-file (and (plist-get view :do-xrefs) (symbol-file fun 'defun))) | ||
| 602 | (fun-pt (point))) | ||
| 603 | (cond | ||
| 604 | ((and evald (not debugger-stack-frame-as-list)) | ||
| 605 | (if (atom fun) | ||
| 606 | (funcall backtrace-print-function fun) | ||
| 607 | (insert | ||
| 608 | (backtrace--print-to-string fun (when args (/ backtrace-line-length 2))))) | ||
| 609 | (if args | ||
| 610 | (insert (backtrace--print-to-string | ||
| 611 | args (max (truncate (/ backtrace-line-length 5)) | ||
| 612 | (- backtrace-line-length (- (point) beg))))) | ||
| 613 | ;; The backtrace-form property is so that | ||
| 614 | ;; backtrace-pretty-print will find it. | ||
| 615 | ;; backtrace-pretty-print doesn't do anything useful with it, | ||
| 616 | ;; just being consistent. | ||
| 617 | (let ((start (point))) | ||
| 618 | (insert "()") | ||
| 619 | (put-text-property start (point) 'backtrace-form t)))) | ||
| 620 | (t | ||
| 621 | (let ((fun-and-args (cons fun args))) | ||
| 622 | (insert (backtrace--print-to-string fun-and-args))) | ||
| 623 | (cl-incf fun-pt))) | ||
| 624 | (when fun-file | ||
| 625 | (make-text-button fun-pt (+ fun-pt (length (symbol-name fun))) | ||
| 626 | :type 'help-function-def | ||
| 627 | 'help-args (list fun fun-file))) | ||
| 628 | ;; After any frame that uses eval-buffer, insert a comment that | ||
| 629 | ;; states the buffer position it's reading at. | ||
| 630 | (when (backtrace-frame-pos frame) | ||
| 631 | (insert (format " ; Reading at buffer position %d" | ||
| 632 | (backtrace-frame-pos frame)))) | ||
| 633 | (insert "\n") | ||
| 634 | (put-text-property beg (point) 'backtrace-section 'func))) | ||
| 635 | |||
| 636 | (defun backtrace--print-locals (frame _view) | ||
| 637 | "Print a backtrace FRAME's local variables. | ||
| 638 | Make them invisible initially." | ||
| 639 | (let* ((beg (point)) | ||
| 640 | (locals (backtrace-frame-locals frame))) | ||
| 641 | (if (null locals) | ||
| 642 | (insert " [no locals]\n") | ||
| 643 | (pcase-dolist (`(,symbol . ,value) locals) | ||
| 644 | (insert " ") | ||
| 645 | (backtrace--print symbol) | ||
| 646 | (insert " = ") | ||
| 647 | (insert (backtrace--print-to-string value)) | ||
| 648 | (insert "\n"))) | ||
| 649 | (put-text-property beg (point) 'backtrace-section 'locals) | ||
| 650 | (backtrace--set-locals-visible beg (point) nil))) | ||
| 651 | |||
| 652 | (defun backtrace--print (obj) | ||
| 653 | "Attempt to print OBJ using `backtrace-print-function'. | ||
| 654 | Fall back to `prin1' if there is an error." | ||
| 655 | (condition-case err | ||
| 656 | (funcall backtrace-print-function obj) | ||
| 657 | (error | ||
| 658 | (message "Error in backtrace printer: %S" err) | ||
| 659 | (prin1 obj)))) | ||
| 660 | |||
| 661 | (defun backtrace-update-flags () | ||
| 662 | "Update the display of the flags in the backtrace frame at point." | ||
| 663 | (let ((view (backtrace-get-view)) | ||
| 664 | (begin (backtrace-get-frame-start))) | ||
| 665 | (when (plist-get view :show-flags) | ||
| 666 | (save-excursion | ||
| 667 | (goto-char begin) | ||
| 668 | (let ((props (backtrace-get-text-properties begin)) | ||
| 669 | (inhibit-read-only t) | ||
| 670 | (standard-output (current-buffer))) | ||
| 671 | (delete-char 2) | ||
| 672 | (backtrace--print-flags (nth (backtrace-get-index) backtrace-frames) | ||
| 673 | view) | ||
| 674 | (add-text-properties begin (point) props)))))) | ||
| 675 | |||
| 676 | (defun backtrace--filter-visible (beg end &optional _delete) | ||
| 677 | "Return the visible text between BEG and END." | ||
| 678 | (let ((result "")) | ||
| 679 | (while (< beg end) | ||
| 680 | (let ((next (next-single-char-property-change beg 'invisible))) | ||
| 681 | (unless (get-char-property beg 'invisible) | ||
| 682 | (setq result (concat result (buffer-substring beg (min end next))))) | ||
| 683 | (setq beg next))) | ||
| 684 | result)) | ||
| 685 | |||
| 686 | ;;; The mode definition | ||
| 687 | |||
| 688 | (define-derived-mode backtrace-mode special-mode "Backtrace" | ||
| 689 | "Generic major mode for examining an Elisp stack backtrace. | ||
| 690 | This mode can be used directly, or other major modes can be | ||
| 691 | derived from it, using `define-derived-mode'. | ||
| 692 | |||
| 693 | In this major mode, the buffer contains some optional lines of | ||
| 694 | header text followed by backtrace frames, each consisting of one | ||
| 695 | or more whole lines. | ||
| 696 | |||
| 697 | Letters in this mode do not insert themselves; instead they are | ||
| 698 | commands. | ||
| 699 | \\<backtrace-mode-map> | ||
| 700 | \\{backtrace-mode-map} | ||
| 701 | |||
| 702 | A mode which inherits from Backtrace mode, or a command which | ||
| 703 | creates a backtrace-mode buffer, should usually do the following: | ||
| 704 | |||
| 705 | - Set `backtrace-revert-hook', if the buffer contents need | ||
| 706 | to be specially recomputed prior to `revert-buffer'. | ||
| 707 | - Maybe set `backtrace-insert-header-function' to a function to create | ||
| 708 | header text for the buffer. | ||
| 709 | - Set `backtrace-frames' (see below). | ||
| 710 | - Set `backtrace-view' if desired (see below). | ||
| 711 | - Maybe set `backtrace-print-function'. | ||
| 712 | |||
| 713 | A command which creates or switches to a Backtrace mode buffer, | ||
| 714 | such as `ert-results-pop-to-backtrace-for-test-at-point', should | ||
| 715 | initialize `backtrace-frames' to a list of `backtrace-frame' | ||
| 716 | objects (`backtrace-get-frames' is provided for that purpose, if | ||
| 717 | desired), and `backtrace-view' to a plist describing how it wants | ||
| 718 | the backtrace to appear. Finally, it should call `backtrace-print'. | ||
| 719 | |||
| 720 | `backtrace-print' calls `backtrace-insert-header-function' | ||
| 721 | followed by `backtrace-print-frame', once for each stack frame." | ||
| 722 | :syntax-table emacs-lisp-mode-syntax-table | ||
| 723 | (when backtrace-fontify | ||
| 724 | (setq font-lock-defaults | ||
| 725 | '((backtrace-font-lock-keywords | ||
| 726 | backtrace-font-lock-keywords-1 | ||
| 727 | backtrace-font-lock-keywords-2) | ||
| 728 | nil nil nil nil | ||
| 729 | ;; TODO This one doesn't look necessary: | ||
| 730 | ;; (font-lock-mark-block-function . mark-defun) | ||
| 731 | (font-lock-syntactic-face-function | ||
| 732 | . lisp-font-lock-syntactic-face-function)))) | ||
| 733 | (setq truncate-lines t) | ||
| 734 | (buffer-disable-undo) | ||
| 735 | ;; In debug.el, from 1998 to 2009 this was set to nil, reason stated | ||
| 736 | ;; was because of bytecode. Since 2009 it's been set to t, but the | ||
| 737 | ;; default is t so I think this isn't necessary. | ||
| 738 | ;; (set-buffer-multibyte t) | ||
| 739 | (setq-local revert-buffer-function #'backtrace-revert) | ||
| 740 | (setq-local filter-buffer-substring-function #'backtrace--filter-visible) | ||
| 741 | (add-hook 'xref-backend-functions #'backtrace--xref-backend nil t)) | ||
| 742 | |||
| 743 | (put 'backtrace-mode 'mode-class 'special) | ||
| 744 | |||
| 745 | ;;; Backtrace printing | ||
| 746 | |||
| 747 | (defun backtrace-backtrace () | ||
| 748 | "Print a trace of Lisp function calls currently active. | ||
| 749 | Output stream used is value of `standard-output'." | ||
| 750 | (princ (backtrace-to-string (backtrace-get-frames 'backtrace-backtrace)))) | ||
| 751 | |||
| 752 | (defun backtrace-to-string(frames) | ||
| 753 | "Format FRAMES, a list of `backtrace-frame' objects, for output. | ||
| 754 | Return the result as a string." | ||
| 755 | (let ((backtrace-fontify nil)) | ||
| 756 | (with-temp-buffer | ||
| 757 | (backtrace-mode) | ||
| 758 | (setq backtrace-view '(:show-flags t) | ||
| 759 | backtrace-frames frames | ||
| 760 | backtrace-print-function #'cl-prin1) | ||
| 761 | (backtrace-print) | ||
| 762 | (substring-no-properties (filter-buffer-substring (point-min) | ||
| 763 | (point-max)))))) | ||
| 764 | |||
| 765 | (provide 'backtrace) | ||
| 766 | |||
| 767 | ;;; backtrace.el ends here | ||
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0efaa637129..707e0cfa186 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el | |||
| @@ -28,6 +28,7 @@ | |||
| 28 | ;;; Code: | 28 | ;;; Code: |
| 29 | 29 | ||
| 30 | (require 'cl-lib) | 30 | (require 'cl-lib) |
| 31 | (require 'backtrace) | ||
| 31 | (require 'button) | 32 | (require 'button) |
| 32 | 33 | ||
| 33 | (defgroup debugger nil | 34 | (defgroup debugger nil |
| @@ -133,6 +134,25 @@ where CAUSE can be: | |||
| 133 | - exit: called because of exit of a flagged function. | 134 | - exit: called because of exit of a flagged function. |
| 134 | - error: called because of `debug-on-error'.") | 135 | - error: called because of `debug-on-error'.") |
| 135 | 136 | ||
| 137 | (cl-defstruct (debugger--buffer-state | ||
| 138 | (:constructor debugger--save-buffer-state | ||
| 139 | (&aux (mode major-mode) | ||
| 140 | (header backtrace-insert-header-function) | ||
| 141 | (frames backtrace-frames) | ||
| 142 | (content (buffer-string)) | ||
| 143 | (pos (point))))) | ||
| 144 | mode header frames content pos) | ||
| 145 | |||
| 146 | (defun debugger--restore-buffer-state (state) | ||
| 147 | (unless (derived-mode-p (debugger--buffer-state-mode state)) | ||
| 148 | (funcall (debugger--buffer-state-mode state))) | ||
| 149 | (setq backtrace-insert-header-function (debugger--buffer-state-header state) | ||
| 150 | backtrace-frames (debugger--buffer-state-frames state)) | ||
| 151 | (let ((inhibit-read-only t)) | ||
| 152 | (erase-buffer) | ||
| 153 | (insert (debugger--buffer-state-content state))) | ||
| 154 | (goto-char (debugger--buffer-state-pos state))) | ||
| 155 | |||
| 136 | ;;;###autoload | 156 | ;;;###autoload |
| 137 | (setq debugger 'debug) | 157 | (setq debugger 'debug) |
| 138 | ;;;###autoload | 158 | ;;;###autoload |
| @@ -174,7 +194,7 @@ first will be printed into the backtrace buffer." | |||
| 174 | (debugger-previous-state | 194 | (debugger-previous-state |
| 175 | (if (get-buffer "*Backtrace*") | 195 | (if (get-buffer "*Backtrace*") |
| 176 | (with-current-buffer (get-buffer "*Backtrace*") | 196 | (with-current-buffer (get-buffer "*Backtrace*") |
| 177 | (list major-mode (buffer-string))))) | 197 | (debugger--save-buffer-state)))) |
| 178 | (debugger-args args) | 198 | (debugger-args args) |
| 179 | (debugger-buffer (get-buffer-create "*Backtrace*")) | 199 | (debugger-buffer (get-buffer-create "*Backtrace*")) |
| 180 | (debugger-old-buffer (current-buffer)) | 200 | (debugger-old-buffer (current-buffer)) |
| @@ -236,7 +256,8 @@ first will be printed into the backtrace buffer." | |||
| 236 | (window-total-height debugger-window))) | 256 | (window-total-height debugger-window))) |
| 237 | (error nil))) | 257 | (error nil))) |
| 238 | (setq debugger-previous-window debugger-window)) | 258 | (setq debugger-previous-window debugger-window)) |
| 239 | (debugger-mode) | 259 | (unless (derived-mode-p 'debugger-mode) |
| 260 | (debugger-mode)) | ||
| 240 | (debugger-setup-buffer debugger-args) | 261 | (debugger-setup-buffer debugger-args) |
| 241 | (when noninteractive | 262 | (when noninteractive |
| 242 | ;; If the backtrace is long, save the beginning | 263 | ;; If the backtrace is long, save the beginning |
| @@ -280,15 +301,14 @@ first will be printed into the backtrace buffer." | |||
| 280 | (setq debugger-previous-window nil)) | 301 | (setq debugger-previous-window nil)) |
| 281 | ;; Restore previous state of debugger-buffer in case we were | 302 | ;; Restore previous state of debugger-buffer in case we were |
| 282 | ;; in a recursive invocation of the debugger, otherwise just | 303 | ;; in a recursive invocation of the debugger, otherwise just |
| 283 | ;; erase the buffer and put it into fundamental mode. | 304 | ;; erase the buffer. |
| 284 | (when (buffer-live-p debugger-buffer) | 305 | (when (buffer-live-p debugger-buffer) |
| 285 | (with-current-buffer debugger-buffer | 306 | (with-current-buffer debugger-buffer |
| 286 | (let ((inhibit-read-only t)) | 307 | (if debugger-previous-state |
| 287 | (erase-buffer) | 308 | (debugger--restore-buffer-state debugger-previous-state) |
| 288 | (if (null debugger-previous-state) | 309 | (setq backtrace-insert-header-function nil) |
| 289 | (fundamental-mode) | 310 | (setq backtrace-frames nil) |
| 290 | (insert (nth 1 debugger-previous-state)) | 311 | (backtrace-print)))) |
| 291 | (funcall (nth 0 debugger-previous-state)))))) | ||
| 292 | (with-timeout-unsuspend debugger-with-timeout-suspend) | 312 | (with-timeout-unsuspend debugger-with-timeout-suspend) |
| 293 | (set-match-data debugger-outer-match-data))) | 313 | (set-match-data debugger-outer-match-data))) |
| 294 | (setq debug-on-next-call debugger-step-after-exit) | 314 | (setq debug-on-next-call debugger-step-after-exit) |
| @@ -301,112 +321,80 @@ first will be printed into the backtrace buffer." | |||
| 301 | (message "Error in debug printer: %S" err) | 321 | (message "Error in debug printer: %S" err) |
| 302 | (prin1 obj stream)))) | 322 | (prin1 obj stream)))) |
| 303 | 323 | ||
| 304 | (defun debugger-insert-backtrace (frames do-xrefs) | ||
| 305 | "Format and insert the backtrace FRAMES at point. | ||
| 306 | Make functions into cross-reference buttons if DO-XREFS is non-nil." | ||
| 307 | (let ((standard-output (current-buffer)) | ||
| 308 | (eval-buffers eval-buffer-list)) | ||
| 309 | (require 'help-mode) ; Define `help-function-def' button type. | ||
| 310 | (pcase-dolist (`(,evald ,fun ,args ,flags) frames) | ||
| 311 | (insert (if (plist-get flags :debug-on-exit) | ||
| 312 | "* " " ")) | ||
| 313 | (let ((fun-file (and do-xrefs (symbol-file fun 'defun))) | ||
| 314 | (fun-pt (point))) | ||
| 315 | (cond | ||
| 316 | ((and evald (not debugger-stack-frame-as-list)) | ||
| 317 | (debugger--print fun) | ||
| 318 | (if args (debugger--print args) (princ "()"))) | ||
| 319 | (t | ||
| 320 | (debugger--print (cons fun args)) | ||
| 321 | (cl-incf fun-pt))) | ||
| 322 | (when fun-file | ||
| 323 | (make-text-button fun-pt (+ fun-pt (length (symbol-name fun))) | ||
| 324 | :type 'help-function-def | ||
| 325 | 'help-args (list fun fun-file)))) | ||
| 326 | ;; After any frame that uses eval-buffer, insert a line that | ||
| 327 | ;; states the buffer position it's reading at. | ||
| 328 | (when (and eval-buffers (memq fun '(eval-buffer eval-region))) | ||
| 329 | (insert (format " ; Reading at buffer position %d" | ||
| 330 | ;; This will get the wrong result if there are | ||
| 331 | ;; two nested eval-region calls for the same | ||
| 332 | ;; buffer. That's not a very useful case. | ||
| 333 | (with-current-buffer (pop eval-buffers) | ||
| 334 | (point))))) | ||
| 335 | (insert "\n")))) | ||
| 336 | |||
| 337 | (defun debugger-setup-buffer (args) | 324 | (defun debugger-setup-buffer (args) |
| 338 | "Initialize the `*Backtrace*' buffer for entry to the debugger. | 325 | "Initialize the `*Backtrace*' buffer for entry to the debugger. |
| 339 | That buffer should be current already." | 326 | That buffer should be current already and in debugger-mode." |
| 340 | (setq buffer-read-only nil) | 327 | (setq backtrace-frames (nthcdr |
| 341 | (erase-buffer) | 328 | ;; Remove debug--implement-debug-on-entry and the |
| 342 | (set-buffer-multibyte t) ;Why was it nil ? -stef | 329 | ;; advice's `apply' frame. |
| 343 | (setq buffer-undo-list t) | 330 | (if (eq (car args) 'debug) 3 1) |
| 331 | (backtrace-get-frames 'debug))) | ||
| 332 | (when (eq (car-safe args) 'exit) | ||
| 333 | (setq debugger-value (nth 1 args)) | ||
| 334 | (setf (cl-getf (backtrace-frame-flags (car backtrace-frames)) | ||
| 335 | :debug-on-exit) | ||
| 336 | nil)) | ||
| 337 | |||
| 338 | (setq backtrace-view '(:do-xrefs t :show-flags t) | ||
| 339 | backtrace-insert-header-function (lambda () | ||
| 340 | (debugger--insert-header args)) | ||
| 341 | backtrace-print-function debugger-print-function) | ||
| 342 | (backtrace-print) | ||
| 343 | ;; Place point on "stack frame 0" (bug#15101). | ||
| 344 | (goto-char (point-min)) | ||
| 345 | (search-forward ":" (line-end-position) t) | ||
| 346 | (when (and (< (point) (line-end-position)) | ||
| 347 | (= (char-after) ?\s)) | ||
| 348 | (forward-char))) | ||
| 349 | |||
| 350 | (defun debugger--insert-header (args) | ||
| 351 | "Insert the header for the debugger's Backtrace buffer. | ||
| 352 | Include the reason for debugger entry from ARGS." | ||
| 344 | (insert "Debugger entered") | 353 | (insert "Debugger entered") |
| 345 | (let ((frames (nthcdr | 354 | (pcase (car args) |
| 346 | ;; Remove debug--implement-debug-on-entry and the | 355 | ;; lambda is for debug-on-call when a function call is next. |
| 347 | ;; advice's `apply' frame. | 356 | ;; debug is for debug-on-entry function called. |
| 348 | (if (eq (car args) 'debug) 3 1) | 357 | ((or `lambda `debug) |
| 349 | (backtrace-frames 'debug))) | 358 | (insert "--entering a function:\n")) |
| 350 | (print-escape-newlines t) | 359 | ;; Exiting a function. |
| 351 | (print-escape-control-characters t) | 360 | (`exit |
| 352 | ;; If you increase print-level, add more depth in call_debugger. | 361 | (insert "--returning value: ") |
| 353 | (print-level 8) | 362 | (insert (backtrace-print-to-string debugger-value)) |
| 354 | (print-length 50) | 363 | (insert ?\n)) |
| 355 | (pos (point))) | 364 | ;; Watchpoint triggered. |
| 356 | (pcase (car args) | 365 | ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) |
| 357 | ;; lambda is for debug-on-call when a function call is next. | 366 | (insert |
| 358 | ;; debug is for debug-on-entry function called. | 367 | "--" |
| 359 | ((or `lambda `debug) | 368 | (pcase details |
| 360 | (insert "--entering a function:\n") | 369 | (`(makunbound nil) (format "making %s void" symbol)) |
| 361 | (setq pos (1- (point)))) | 370 | (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" |
| 362 | ;; Exiting a function. | 371 | symbol buffer)) |
| 363 | (`exit | 372 | (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) |
| 364 | (insert "--returning value: ") | 373 | (`(let ,_) (format "let-binding %s to %s" symbol |
| 365 | (setq pos (point)) | 374 | (backtrace-print-to-string newval))) |
| 366 | (setq debugger-value (nth 1 args)) | 375 | (`(unlet ,_) (format "ending let-binding of %s" symbol)) |
| 367 | (debugger--print debugger-value (current-buffer)) | 376 | (`(set nil) (format "setting %s to %s" symbol |
| 368 | (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil) | 377 | (backtrace-print-to-string newval))) |
| 369 | (insert ?\n)) | 378 | (`(set ,buffer) (format "setting %s in buffer %s to %s" |
| 370 | ;; Watchpoint triggered. | 379 | symbol buffer |
| 371 | ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) | 380 | (backtrace-print-to-string newval))) |
| 372 | (insert | 381 | (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) |
| 373 | "--" | 382 | ": ") |
| 374 | (pcase details | 383 | (insert ?\n)) |
| 375 | (`(makunbound nil) (format "making %s void" symbol)) | 384 | ;; Debugger entered for an error. |
| 376 | (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" | 385 | (`error |
| 377 | symbol buffer)) | 386 | (insert "--Lisp error: ") |
| 378 | (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) | 387 | (insert (backtrace-print-to-string (nth 1 args))) |
| 379 | (`(let ,_) (format "let-binding %s to %S" symbol newval)) | 388 | (insert ?\n)) |
| 380 | (`(unlet ,_) (format "ending let-binding of %s" symbol)) | 389 | ;; debug-on-call, when the next thing is an eval. |
| 381 | (`(set nil) (format "setting %s to %S" symbol newval)) | 390 | (`t |
| 382 | (`(set ,buffer) (format "setting %s in buffer %s to %S" | 391 | (insert "--beginning evaluation of function call form:\n")) |
| 383 | symbol buffer newval)) | 392 | ;; User calls debug directly. |
| 384 | (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) | 393 | (_ |
| 385 | ": ") | 394 | (insert ": ") |
| 386 | (setq pos (point)) | 395 | (insert (backtrace-print-to-string (if (eq (car args) 'nil) |
| 387 | (insert ?\n)) | 396 | (cdr args) args))) |
| 388 | ;; Debugger entered for an error. | 397 | (insert ?\n)))) |
| 389 | (`error | ||
| 390 | (insert "--Lisp error: ") | ||
| 391 | (setq pos (point)) | ||
| 392 | (debugger--print (nth 1 args) (current-buffer)) | ||
| 393 | (insert ?\n)) | ||
| 394 | ;; debug-on-call, when the next thing is an eval. | ||
| 395 | (`t | ||
| 396 | (insert "--beginning evaluation of function call form:\n") | ||
| 397 | (setq pos (1- (point)))) | ||
| 398 | ;; User calls debug directly. | ||
| 399 | (_ | ||
| 400 | (insert ": ") | ||
| 401 | (setq pos (point)) | ||
| 402 | (debugger--print | ||
| 403 | (if (eq (car args) 'nil) | ||
| 404 | (cdr args) args) | ||
| 405 | (current-buffer)) | ||
| 406 | (insert ?\n))) | ||
| 407 | (debugger-insert-backtrace frames t) | ||
| 408 | ;; Place point on "stack frame 0" (bug#15101). | ||
| 409 | (goto-char pos))) | ||
| 410 | 398 | ||
| 411 | 399 | ||
| 412 | (defun debugger-step-through () | 400 | (defun debugger-step-through () |
| @@ -426,12 +414,12 @@ Enter another debugger on next entry to eval, apply or funcall." | |||
| 426 | (unless debugger-may-continue | 414 | (unless debugger-may-continue |
| 427 | (error "Cannot continue")) | 415 | (error "Cannot continue")) |
| 428 | (message "Continuing.") | 416 | (message "Continuing.") |
| 429 | (save-excursion | 417 | |
| 430 | ;; Check to see if we've flagged some frame for debug-on-exit, in which | 418 | ;; Check to see if we've flagged some frame for debug-on-exit, in which |
| 431 | ;; case we'll probably come back to the debugger soon. | 419 | ;; case we'll probably come back to the debugger soon. |
| 432 | (goto-char (point-min)) | 420 | (dolist (frame backtrace-frames) |
| 433 | (if (re-search-forward "^\\* " nil t) | 421 | (when (plist-get (backtrace-frame-flags frame) :debug-on-exit) |
| 434 | (setq debugger-will-be-back t))) | 422 | (setq debugger-will-be-back t))) |
| 435 | (exit-recursive-edit)) | 423 | (exit-recursive-edit)) |
| 436 | 424 | ||
| 437 | (defun debugger-return-value (val) | 425 | (defun debugger-return-value (val) |
| @@ -446,12 +434,11 @@ will be used, such as in a debug on exit from a frame." | |||
| 446 | (setq debugger-value val) | 434 | (setq debugger-value val) |
| 447 | (princ "Returning " t) | 435 | (princ "Returning " t) |
| 448 | (debugger--print debugger-value) | 436 | (debugger--print debugger-value) |
| 449 | (save-excursion | ||
| 450 | ;; Check to see if we've flagged some frame for debug-on-exit, in which | 437 | ;; Check to see if we've flagged some frame for debug-on-exit, in which |
| 451 | ;; case we'll probably come back to the debugger soon. | 438 | ;; case we'll probably come back to the debugger soon. |
| 452 | (goto-char (point-min)) | 439 | (dolist (frame backtrace-frames) |
| 453 | (if (re-search-forward "^\\* " nil t) | 440 | (when (plist-get (backtrace-frame-flags frame) :debug-on-exit) |
| 454 | (setq debugger-will-be-back t))) | 441 | (setq debugger-will-be-back t))) |
| 455 | (exit-recursive-edit)) | 442 | (exit-recursive-edit)) |
| 456 | 443 | ||
| 457 | (defun debugger-jump () | 444 | (defun debugger-jump () |
| @@ -473,63 +460,40 @@ removes itself from that hook." | |||
| 473 | 460 | ||
| 474 | (defun debugger-frame-number (&optional skip-base) | 461 | (defun debugger-frame-number (&optional skip-base) |
| 475 | "Return number of frames in backtrace before the one point points at." | 462 | "Return number of frames in backtrace before the one point points at." |
| 476 | (save-excursion | 463 | (let ((index (backtrace-get-index)) |
| 477 | (beginning-of-line) | 464 | (count 0)) |
| 478 | (if (looking-at " *;;;\\|[a-z]") | 465 | (unless index |
| 479 | (error "This line is not a function call")) | 466 | (error "This line is not a function call")) |
| 480 | (let ((opoint (point)) | 467 | (unless skip-base |
| 481 | (count 0)) | ||
| 482 | (unless skip-base | ||
| 483 | (while (not (eq (cadr (backtrace-frame count)) 'debug)) | 468 | (while (not (eq (cadr (backtrace-frame count)) 'debug)) |
| 484 | (setq count (1+ count))) | 469 | (setq count (1+ count))) |
| 485 | ;; Skip debug--implement-debug-on-entry frame. | 470 | ;; Skip debug--implement-debug-on-entry frame. |
| 486 | (when (eq 'debug--implement-debug-on-entry | 471 | (when (eq 'debug--implement-debug-on-entry |
| 487 | (cadr (backtrace-frame (1+ count)))) | 472 | (cadr (backtrace-frame (1+ count)))) |
| 488 | (setq count (+ 2 count)))) | 473 | (setq count (+ 2 count)))) |
| 489 | (goto-char (point-min)) | 474 | (+ count index))) |
| 490 | (when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):") | ||
| 491 | (goto-char (match-end 0)) | ||
| 492 | (forward-sexp 1)) | ||
| 493 | (forward-line 1) | ||
| 494 | (while (progn | ||
| 495 | (forward-char 2) | ||
| 496 | (cond ((debugger--locals-visible-p) | ||
| 497 | (goto-char (next-single-char-property-change | ||
| 498 | (point) 'locals-visible))) | ||
| 499 | ((= (following-char) ?\() | ||
| 500 | (forward-sexp 1)) | ||
| 501 | (t | ||
| 502 | (forward-sexp 2))) | ||
| 503 | (forward-line 1) | ||
| 504 | (<= (point) opoint)) | ||
| 505 | (if (looking-at " *;;;") | ||
| 506 | (forward-line 1)) | ||
| 507 | (setq count (1+ count))) | ||
| 508 | count))) | ||
| 509 | 475 | ||
| 510 | (defun debugger-frame () | 476 | (defun debugger-frame () |
| 511 | "Request entry to debugger when this frame exits. | 477 | "Request entry to debugger when this frame exits. |
| 512 | Applies to the frame whose line point is on in the backtrace." | 478 | Applies to the frame whose line point is on in the backtrace." |
| 513 | (interactive) | 479 | (interactive) |
| 514 | (backtrace-debug (debugger-frame-number) t) | 480 | (backtrace-debug (debugger-frame-number) t) |
| 515 | (beginning-of-line) | 481 | (setf |
| 516 | (if (= (following-char) ? ) | 482 | (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) |
| 517 | (let ((inhibit-read-only t)) | 483 | :debug-on-exit) |
| 518 | (delete-char 1) | 484 | t) |
| 519 | (insert ?*))) | 485 | (backtrace-update-flags)) |
| 520 | (beginning-of-line)) | ||
| 521 | 486 | ||
| 522 | (defun debugger-frame-clear () | 487 | (defun debugger-frame-clear () |
| 523 | "Do not enter debugger when this frame exits. | 488 | "Do not enter debugger when this frame exits. |
| 524 | Applies to the frame whose line point is on in the backtrace." | 489 | Applies to the frame whose line point is on in the backtrace." |
| 525 | (interactive) | 490 | (interactive) |
| 526 | (backtrace-debug (debugger-frame-number) nil) | 491 | (backtrace-debug (debugger-frame-number) nil) |
| 527 | (beginning-of-line) | 492 | (setf |
| 528 | (if (= (following-char) ?*) | 493 | (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) |
| 529 | (let ((inhibit-read-only t)) | 494 | :debug-on-exit) |
| 530 | (delete-char 1) | 495 | nil) |
| 531 | (insert ? ))) | 496 | (backtrace-update-flags)) |
| 532 | (beginning-of-line)) | ||
| 533 | 497 | ||
| 534 | (defmacro debugger-env-macro (&rest body) | 498 | (defmacro debugger-env-macro (&rest body) |
| 535 | "Run BODY in original environment." | 499 | "Run BODY in original environment." |
| @@ -564,69 +528,11 @@ The environment used is the one when entering the activation frame at point." | |||
| 564 | (let ((str (eval-expression-print-format val))) | 528 | (let ((str (eval-expression-print-format val))) |
| 565 | (if str (princ str t)))))))) | 529 | (if str (princ str t)))))))) |
| 566 | 530 | ||
| 567 | (defun debugger--locals-visible-p () | ||
| 568 | "Are the local variables of the current stack frame visible?" | ||
| 569 | (save-excursion | ||
| 570 | (move-to-column 2) | ||
| 571 | (get-text-property (point) 'locals-visible))) | ||
| 572 | |||
| 573 | (defun debugger--insert-locals (locals) | ||
| 574 | "Insert the local variables LOCALS at point." | ||
| 575 | (cond ((null locals) | ||
| 576 | (insert "\n [no locals]")) | ||
| 577 | (t | ||
| 578 | (let ((print-escape-newlines t)) | ||
| 579 | (dolist (s+v locals) | ||
| 580 | (let ((symbol (car s+v)) | ||
| 581 | (value (cdr s+v))) | ||
| 582 | (insert "\n ") | ||
| 583 | (prin1 symbol (current-buffer)) | ||
| 584 | (insert " = ") | ||
| 585 | (debugger--print value (current-buffer)))))))) | ||
| 586 | |||
| 587 | (defun debugger--show-locals () | ||
| 588 | "For the frame at point, insert locals and add text properties." | ||
| 589 | (let* ((nframe (1+ (debugger-frame-number 'skip-base))) | ||
| 590 | (base (debugger--backtrace-base)) | ||
| 591 | (locals (backtrace--locals nframe base)) | ||
| 592 | (inhibit-read-only t)) | ||
| 593 | (save-excursion | ||
| 594 | (let ((start (progn | ||
| 595 | (move-to-column 2) | ||
| 596 | (point)))) | ||
| 597 | (end-of-line) | ||
| 598 | (debugger--insert-locals locals) | ||
| 599 | (add-text-properties start (point) '(locals-visible t)))))) | ||
| 600 | |||
| 601 | (defun debugger--hide-locals () | ||
| 602 | "Delete local variables and remove the text property." | ||
| 603 | (let* ((col (current-column)) | ||
| 604 | (end (progn | ||
| 605 | (move-to-column 2) | ||
| 606 | (next-single-char-property-change (point) 'locals-visible))) | ||
| 607 | (start (previous-single-char-property-change end 'locals-visible)) | ||
| 608 | (inhibit-read-only t)) | ||
| 609 | (remove-text-properties start end '(locals-visible)) | ||
| 610 | (goto-char start) | ||
| 611 | (end-of-line) | ||
| 612 | (delete-region (point) end) | ||
| 613 | (move-to-column col))) | ||
| 614 | |||
| 615 | (defun debugger-toggle-locals () | ||
| 616 | "Show or hide local variables of the current stack frame." | ||
| 617 | (interactive) | ||
| 618 | (cond ((debugger--locals-visible-p) | ||
| 619 | (debugger--hide-locals)) | ||
| 620 | (t | ||
| 621 | (debugger--show-locals)))) | ||
| 622 | |||
| 623 | 531 | ||
| 624 | (defvar debugger-mode-map | 532 | (defvar debugger-mode-map |
| 625 | (let ((map (make-keymap)) | 533 | (let ((map (make-keymap)) |
| 626 | (menu-map (make-sparse-keymap))) | 534 | (menu-map (make-sparse-keymap))) |
| 627 | (set-keymap-parent map button-buffer-map) | 535 | (set-keymap-parent map backtrace-mode-map) |
| 628 | (suppress-keymap map) | ||
| 629 | (define-key map "-" 'negative-argument) | ||
| 630 | (define-key map "b" 'debugger-frame) | 536 | (define-key map "b" 'debugger-frame) |
| 631 | (define-key map "c" 'debugger-continue) | 537 | (define-key map "c" 'debugger-continue) |
| 632 | (define-key map "j" 'debugger-jump) | 538 | (define-key map "j" 'debugger-jump) |
| @@ -634,24 +540,20 @@ The environment used is the one when entering the activation frame at point." | |||
| 634 | (define-key map "u" 'debugger-frame-clear) | 540 | (define-key map "u" 'debugger-frame-clear) |
| 635 | (define-key map "d" 'debugger-step-through) | 541 | (define-key map "d" 'debugger-step-through) |
| 636 | (define-key map "l" 'debugger-list-functions) | 542 | (define-key map "l" 'debugger-list-functions) |
| 637 | (define-key map "h" 'describe-mode) | 543 | (define-key map "q" 'debugger-quit) |
| 638 | (define-key map "q" 'top-level) | ||
| 639 | (define-key map "e" 'debugger-eval-expression) | 544 | (define-key map "e" 'debugger-eval-expression) |
| 640 | (define-key map "v" 'debugger-toggle-locals) ; "v" is for "variables". | ||
| 641 | (define-key map " " 'next-line) | ||
| 642 | (define-key map "R" 'debugger-record-expression) | 545 | (define-key map "R" 'debugger-record-expression) |
| 643 | (define-key map "\C-m" 'debug-help-follow) | ||
| 644 | (define-key map [mouse-2] 'push-button) | 546 | (define-key map [mouse-2] 'push-button) |
| 645 | (define-key map [menu-bar debugger] (cons "Debugger" menu-map)) | 547 | (define-key map [menu-bar debugger] (cons "Debugger" menu-map)) |
| 646 | (define-key menu-map [deb-top] | 548 | (define-key menu-map [deb-top] |
| 647 | '(menu-item "Quit" top-level | 549 | '(menu-item "Quit" debugger-quit |
| 648 | :help "Quit debugging and return to top level")) | 550 | :help "Quit debugging and return to top level")) |
| 649 | (define-key menu-map [deb-s0] '("--")) | 551 | (define-key menu-map [deb-s0] '("--")) |
| 650 | (define-key menu-map [deb-descr] | 552 | (define-key menu-map [deb-descr] |
| 651 | '(menu-item "Describe Debugger Mode" describe-mode | 553 | '(menu-item "Describe Debugger Mode" describe-mode |
| 652 | :help "Display documentation for debugger-mode")) | 554 | :help "Display documentation for debugger-mode")) |
| 653 | (define-key menu-map [deb-hfol] | 555 | (define-key menu-map [deb-hfol] |
| 654 | '(menu-item "Help Follow" debug-help-follow | 556 | '(menu-item "Help Follow" backtrace-help-follow-symbol |
| 655 | :help "Follow cross-reference")) | 557 | :help "Follow cross-reference")) |
| 656 | (define-key menu-map [deb-nxt] | 558 | (define-key menu-map [deb-nxt] |
| 657 | '(menu-item "Next Line" next-line | 559 | '(menu-item "Next Line" next-line |
| @@ -689,8 +591,8 @@ The environment used is the one when entering the activation frame at point." | |||
| 689 | 591 | ||
| 690 | (put 'debugger-mode 'mode-class 'special) | 592 | (put 'debugger-mode 'mode-class 'special) |
| 691 | 593 | ||
| 692 | (define-derived-mode debugger-mode fundamental-mode "Debugger" | 594 | (define-derived-mode debugger-mode backtrace-mode "Debugger" |
| 693 | "Mode for backtrace buffers, selected in debugger. | 595 | "Mode for debugging Emacs Lisp using a backtrace. |
| 694 | \\<debugger-mode-map> | 596 | \\<debugger-mode-map> |
| 695 | A line starts with `*' if exiting that frame will call the debugger. | 597 | A line starts with `*' if exiting that frame will call the debugger. |
| 696 | Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'. | 598 | Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'. |
| @@ -704,8 +606,6 @@ which functions will enter the debugger when called. | |||
| 704 | 606 | ||
| 705 | Complete list of commands: | 607 | Complete list of commands: |
| 706 | \\{debugger-mode-map}" | 608 | \\{debugger-mode-map}" |
| 707 | (setq truncate-lines t) | ||
| 708 | (set-syntax-table emacs-lisp-mode-syntax-table) | ||
| 709 | (add-hook 'kill-buffer-hook | 609 | (add-hook 'kill-buffer-hook |
| 710 | (lambda () (if (> (recursion-depth) 0) (top-level))) | 610 | (lambda () (if (> (recursion-depth) 0) (top-level))) |
| 711 | nil t) | 611 | nil t) |
| @@ -732,27 +632,6 @@ Complete list of commands: | |||
| 732 | (buffer-substring (line-beginning-position 0) | 632 | (buffer-substring (line-beginning-position 0) |
| 733 | (line-end-position 0))))) | 633 | (line-end-position 0))))) |
| 734 | 634 | ||
| 735 | (defun debug-help-follow (&optional pos) | ||
| 736 | "Follow cross-reference at POS, defaulting to point. | ||
| 737 | |||
| 738 | For the cross-reference format, see `help-make-xrefs'." | ||
| 739 | (interactive "d") | ||
| 740 | ;; Ideally we'd just do (call-interactively 'help-follow) except that this | ||
| 741 | ;; assumes we're already in a *Help* buffer and reuses it, so it ends up | ||
| 742 | ;; incorrectly "reusing" the *Backtrace* buffer to show the help info. | ||
| 743 | (unless pos | ||
| 744 | (setq pos (point))) | ||
| 745 | (unless (push-button pos) | ||
| 746 | ;; check if the symbol under point is a function or variable | ||
| 747 | (let ((sym | ||
| 748 | (intern | ||
| 749 | (save-excursion | ||
| 750 | (goto-char pos) (skip-syntax-backward "w_") | ||
| 751 | (buffer-substring (point) | ||
| 752 | (progn (skip-syntax-forward "w_") | ||
| 753 | (point))))))) | ||
| 754 | (when (or (boundp sym) (fboundp sym) (facep sym)) | ||
| 755 | (describe-symbol sym))))) | ||
| 756 | 635 | ||
| 757 | ;; When you change this, you may also need to change the number of | 636 | ;; When you change this, you may also need to change the number of |
| 758 | ;; frames that the debugger skips. | 637 | ;; frames that the debugger skips. |
| @@ -853,6 +732,13 @@ To specify a nil argument interactively, exit with an empty minibuffer." | |||
| 853 | ;;(princ "be set to debug on entry, even if it is in the list.") | 732 | ;;(princ "be set to debug on entry, even if it is in the list.") |
| 854 | ))))) | 733 | ))))) |
| 855 | 734 | ||
| 735 | (defun debugger-quit () | ||
| 736 | "Quit debugging and return to the top level." | ||
| 737 | (interactive) | ||
| 738 | (if (= (recursion-depth) 0) | ||
| 739 | (quit-window) | ||
| 740 | (top-level))) | ||
| 741 | |||
| 856 | (defun debug--implement-debug-watch (symbol newval op where) | 742 | (defun debug--implement-debug-watch (symbol newval op where) |
| 857 | "Conditionally call the debugger. | 743 | "Conditionally call the debugger. |
| 858 | This function is called when SYMBOL's value is modified." | 744 | This function is called when SYMBOL's value is modified." |
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index f0c0db182ed..b22c8952da0 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el | |||
| @@ -52,6 +52,7 @@ | |||
| 52 | 52 | ||
| 53 | ;;; Code: | 53 | ;;; Code: |
| 54 | 54 | ||
| 55 | (require 'backtrace) | ||
| 55 | (require 'macroexp) | 56 | (require 'macroexp) |
| 56 | (require 'cl-lib) | 57 | (require 'cl-lib) |
| 57 | (eval-when-compile (require 'pcase)) | 58 | (eval-when-compile (require 'pcase)) |
| @@ -206,8 +207,7 @@ Use this with caution since it is not debugged." | |||
| 206 | "Non-nil if Edebug should unwrap results of expressions. | 207 | "Non-nil if Edebug should unwrap results of expressions. |
| 207 | That is, Edebug will try to remove its own instrumentation from the result. | 208 | That is, Edebug will try to remove its own instrumentation from the result. |
| 208 | This is useful when debugging macros where the results of expressions | 209 | This is useful when debugging macros where the results of expressions |
| 209 | are instrumented expressions. But don't do this when results might be | 210 | are instrumented expressions." |
| 210 | circular or an infinite loop will result." | ||
| 211 | :type 'boolean | 211 | :type 'boolean |
| 212 | :group 'edebug) | 212 | :group 'edebug) |
| 213 | 213 | ||
| @@ -1265,25 +1265,59 @@ purpose by adding an entry to this alist, and setting | |||
| 1265 | (defun edebug-unwrap (sexp) | 1265 | (defun edebug-unwrap (sexp) |
| 1266 | "Return the unwrapped SEXP or return it as is if it is not wrapped. | 1266 | "Return the unwrapped SEXP or return it as is if it is not wrapped. |
| 1267 | The SEXP might be the result of wrapping a body, which is a list of | 1267 | The SEXP might be the result of wrapping a body, which is a list of |
| 1268 | expressions; a `progn' form will be returned enclosing these forms." | 1268 | expressions; a `progn' form will be returned enclosing these forms. |
| 1269 | (if (consp sexp) | 1269 | Does not unwrap inside vectors, records, structures, or hash tables." |
| 1270 | (cond | 1270 | (pcase sexp |
| 1271 | ((eq 'edebug-after (car sexp)) | 1271 | (`(edebug-after ,_before-form ,_after-index ,form) |
| 1272 | (nth 3 sexp)) | 1272 | form) |
| 1273 | ((eq 'edebug-enter (car sexp)) | 1273 | (`(lambda ,args (edebug-enter ',_sym ,_arglist |
| 1274 | (macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp))))) | 1274 | (function (lambda nil . ,body)))) |
| 1275 | (t sexp);; otherwise it is not wrapped, so just return it. | 1275 | `(lambda ,args ,@body)) |
| 1276 | ) | 1276 | (`(closure ,env ,args (edebug-enter ',_sym ,_arglist |
| 1277 | sexp)) | 1277 | (function (lambda nil . ,body)))) |
| 1278 | `(closure ,env ,args ,@body)) | ||
| 1279 | (`(edebug-enter ',_sym ,_args (function (lambda nil . ,body))) | ||
| 1280 | (macroexp-progn body)) | ||
| 1281 | (_ sexp))) | ||
| 1278 | 1282 | ||
| 1279 | (defun edebug-unwrap* (sexp) | 1283 | (defun edebug-unwrap* (sexp) |
| 1280 | "Return the SEXP recursively unwrapped." | 1284 | "Return the SEXP recursively unwrapped." |
| 1285 | (let ((ht (make-hash-table :test 'eq))) | ||
| 1286 | (edebug--unwrap1 sexp ht))) | ||
| 1287 | |||
| 1288 | (defun edebug--unwrap1 (sexp hash-table) | ||
| 1289 | "Unwrap SEXP using HASH-TABLE of things already unwrapped. | ||
| 1290 | HASH-TABLE contains the results of unwrapping cons cells within | ||
| 1291 | SEXP, which are reused to avoid infinite loops when SEXP is or | ||
| 1292 | contains a circular object." | ||
| 1281 | (let ((new-sexp (edebug-unwrap sexp))) | 1293 | (let ((new-sexp (edebug-unwrap sexp))) |
| 1282 | (while (not (eq sexp new-sexp)) | 1294 | (while (not (eq sexp new-sexp)) |
| 1283 | (setq sexp new-sexp | 1295 | (setq sexp new-sexp |
| 1284 | new-sexp (edebug-unwrap sexp))) | 1296 | new-sexp (edebug-unwrap sexp))) |
| 1285 | (if (consp new-sexp) | 1297 | (if (consp new-sexp) |
| 1286 | (mapcar #'edebug-unwrap* new-sexp) | 1298 | (let ((result (gethash new-sexp hash-table nil))) |
| 1299 | (unless result | ||
| 1300 | (let ((remainder new-sexp) | ||
| 1301 | current) | ||
| 1302 | (setq result (cons nil nil) | ||
| 1303 | current result) | ||
| 1304 | (while | ||
| 1305 | (progn | ||
| 1306 | (puthash remainder current hash-table) | ||
| 1307 | (setf (car current) | ||
| 1308 | (edebug--unwrap1 (car remainder) hash-table)) | ||
| 1309 | (setq remainder (cdr remainder)) | ||
| 1310 | (cond | ||
| 1311 | ((atom remainder) | ||
| 1312 | (setf (cdr current) | ||
| 1313 | (edebug--unwrap1 remainder hash-table)) | ||
| 1314 | nil) | ||
| 1315 | ((gethash remainder hash-table nil) | ||
| 1316 | (setf (cdr current) (gethash remainder hash-table nil)) | ||
| 1317 | nil) | ||
| 1318 | (t (setq current | ||
| 1319 | (setf (cdr current) (cons nil nil))))))))) | ||
| 1320 | result) | ||
| 1287 | new-sexp))) | 1321 | new-sexp))) |
| 1288 | 1322 | ||
| 1289 | 1323 | ||
| @@ -3916,8 +3950,10 @@ Global commands prefixed by `global-edebug-prefix': | |||
| 3916 | ;; (setq debugger 'debug) ; use the standard debugger | 3950 | ;; (setq debugger 'debug) ; use the standard debugger |
| 3917 | 3951 | ||
| 3918 | ;; Note that debug and its utilities must be byte-compiled to work, | 3952 | ;; Note that debug and its utilities must be byte-compiled to work, |
| 3919 | ;; since they depend on the backtrace looking a certain way. But | 3953 | ;; since they depend on the backtrace looking a certain way. Edebug |
| 3920 | ;; edebug is not dependent on this, yet. | 3954 | ;; will work if not byte-compiled, but it will not be able correctly |
| 3955 | ;; remove its instrumentation from backtraces unless it is | ||
| 3956 | ;; byte-compiled. | ||
| 3921 | 3957 | ||
| 3922 | (defun edebug (&optional arg-mode &rest args) | 3958 | (defun edebug (&optional arg-mode &rest args) |
| 3923 | "Replacement for `debug'. | 3959 | "Replacement for `debug'. |
| @@ -3947,48 +3983,96 @@ Otherwise call `debug' normally." | |||
| 3947 | (apply #'debug arg-mode args) | 3983 | (apply #'debug arg-mode args) |
| 3948 | )) | 3984 | )) |
| 3949 | 3985 | ||
| 3986 | ;;; Backtrace buffer | ||
| 3987 | |||
| 3988 | ;; Data structure for backtrace frames with information | ||
| 3989 | ;; from Edebug instrumentation found in the backtrace. | ||
| 3990 | (cl-defstruct | ||
| 3991 | (edebug--frame | ||
| 3992 | (:constructor edebug--make-frame) | ||
| 3993 | (:include backtrace-frame)) | ||
| 3994 | def-name before-index after-index) | ||
| 3950 | 3995 | ||
| 3951 | (defun edebug-backtrace () | 3996 | (defun edebug-backtrace () |
| 3952 | "Display a non-working backtrace. Better than nothing..." | 3997 | "Display the current backtrace in a `backtrace-mode' window." |
| 3953 | (interactive) | 3998 | (interactive) |
| 3954 | (if (or (not edebug-backtrace-buffer) | 3999 | (if (or (not edebug-backtrace-buffer) |
| 3955 | (null (buffer-name edebug-backtrace-buffer))) | 4000 | (null (buffer-name edebug-backtrace-buffer))) |
| 3956 | (setq edebug-backtrace-buffer | 4001 | (setq edebug-backtrace-buffer |
| 3957 | (generate-new-buffer "*Backtrace*")) | 4002 | (generate-new-buffer "*Edebug Backtrace*")) |
| 3958 | ;; Else, could just display edebug-backtrace-buffer. | 4003 | ;; Else, could just display edebug-backtrace-buffer. |
| 3959 | ) | 4004 | ) |
| 3960 | (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer) | 4005 | (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer) |
| 3961 | (setq edebug-backtrace-buffer standard-output) | 4006 | (setq edebug-backtrace-buffer standard-output) |
| 3962 | (let ((print-escape-newlines t) | 4007 | (with-current-buffer edebug-backtrace-buffer |
| 3963 | (print-length 50) ; FIXME cf edebug-safe-prin1-to-string | 4008 | (unless (derived-mode-p 'backtrace-mode) |
| 3964 | last-ok-point) | 4009 | (backtrace-mode)) |
| 3965 | (backtrace) | 4010 | (setq backtrace-frames (edebug--backtrace-frames) |
| 3966 | 4011 | backtrace-view '(:do-xrefs t)) | |
| 3967 | ;; Clean up the backtrace. | 4012 | (backtrace-print) |
| 3968 | ;; Not quite right for current edebug scheme. | 4013 | (goto-char (point-min))))) |
| 3969 | (set-buffer edebug-backtrace-buffer) | 4014 | |
| 3970 | (setq truncate-lines t) | 4015 | (defun edebug--backtrace-frames () |
| 3971 | (goto-char (point-min)) | 4016 | "Return backtrace frames with instrumentation removed. |
| 3972 | (setq last-ok-point (point)) | 4017 | Remove frames for Edebug's functions and the lambdas in |
| 3973 | (if t (progn | 4018 | `edebug-enter' wrappers." |
| 3974 | 4019 | (let* ((frames (backtrace-get-frames 'edebug-debugger | |
| 3975 | ;; Delete interspersed edebug internals. | 4020 | :constructor #'edebug--make-frame)) |
| 3976 | (while (re-search-forward "^ (?edebug" nil t) | 4021 | skip-next-lambda def-name before-index after-index |
| 3977 | (beginning-of-line) | 4022 | results |
| 3978 | (cond | 4023 | (index (length frames))) |
| 3979 | ((looking-at "^ (edebug-after") | 4024 | (dolist (frame (reverse frames)) |
| 3980 | ;; Previous lines may contain code, so just delete this line. | 4025 | (let ((fun (edebug--frame-fun frame)) |
| 3981 | (setq last-ok-point (point)) | 4026 | (args (edebug--frame-args frame))) |
| 3982 | (forward-line 1) | 4027 | (cl-decf index) |
| 3983 | (delete-region last-ok-point (point))) | 4028 | (when (edebug--frame-evald frame) |
| 3984 | 4029 | (setq before-index nil | |
| 3985 | ((looking-at (if debugger-stack-frame-as-list | 4030 | after-index nil)) |
| 3986 | "^ (edebug" | 4031 | (pcase fun |
| 3987 | "^ edebug")) | 4032 | ('edebug-enter |
| 3988 | (forward-line 1) | 4033 | (setq skip-next-lambda t |
| 3989 | (delete-region last-ok-point (point)) | 4034 | def-name (nth 0 args))) |
| 3990 | ))) | 4035 | ('edebug-after |
| 3991 | ))))) | 4036 | (setq before-index (if (consp (nth 0 args)) |
| 4037 | (nth 1 (nth 0 args)) | ||
| 4038 | (nth 0 args)) | ||
| 4039 | after-index (nth 1 args))) | ||
| 4040 | ((pred edebug--symbol-not-prefixed-p) | ||
| 4041 | (edebug--unwrap-and-add-info frame def-name before-index after-index) | ||
| 4042 | (setf (edebug--frame-def-name frame) (and before-index def-name)) | ||
| 4043 | (setf (edebug--frame-before-index frame) before-index) | ||
| 4044 | (setf (edebug--frame-after-index frame) after-index) | ||
| 4045 | (push frame results) | ||
| 4046 | (setq before-index nil | ||
| 4047 | after-index nil)) | ||
| 4048 | (`(,(or 'lambda 'closure) . ,_) | ||
| 4049 | (unless skip-next-lambda | ||
| 4050 | (edebug--unwrap-and-add-info frame def-name before-index after-index) | ||
| 4051 | (push frame results)) | ||
| 4052 | (setq before-index nil | ||
| 4053 | after-index nil | ||
| 4054 | skip-next-lambda nil))))) | ||
| 4055 | results)) | ||
| 4056 | |||
| 4057 | (defun edebug--symbol-not-prefixed-p (sym) | ||
| 4058 | "Return non-nil if SYM is a symbol not prefixed by \"edebug-\"." | ||
| 4059 | (and (symbolp sym) | ||
| 4060 | (not (string-prefix-p "edebug-" (symbol-name sym))))) | ||
| 4061 | |||
| 4062 | (defun edebug--unwrap-and-add-info (frame def-name before-index after-index) | ||
| 4063 | "Update FRAME with the additional info needed by an edebug--frame. | ||
| 4064 | Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME. Also | ||
| 4065 | remove Edebug's instrumentation from the function and any | ||
| 4066 | unevaluated arguments in FRAME." | ||
| 4067 | (setf (edebug--frame-def-name frame) (and before-index def-name)) | ||
| 4068 | (setf (edebug--frame-before-index frame) before-index) | ||
| 4069 | (setf (edebug--frame-after-index frame) after-index) | ||
| 4070 | (setf (edebug--frame-fun frame) (edebug-unwrap* (edebug--frame-fun frame))) | ||
| 4071 | (unless (edebug--frame-evald frame) | ||
| 4072 | (let (results) | ||
| 4073 | (dolist (arg (edebug--frame-args frame)) | ||
| 4074 | (push (edebug-unwrap* arg) results)) | ||
| 4075 | (setf (edebug--frame-args frame) (nreverse results))))) | ||
| 3992 | 4076 | ||
| 3993 | 4077 | ||
| 3994 | ;;; Trace display | 4078 | ;;; Trace display |
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index cad21044f15..7178493ebe5 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el | |||
| @@ -60,6 +60,7 @@ | |||
| 60 | (require 'cl-lib) | 60 | (require 'cl-lib) |
| 61 | (require 'button) | 61 | (require 'button) |
| 62 | (require 'debug) | 62 | (require 'debug) |
| 63 | (require 'backtrace) | ||
| 63 | (require 'easymenu) | 64 | (require 'easymenu) |
| 64 | (require 'ewoc) | 65 | (require 'ewoc) |
| 65 | (require 'find-func) | 66 | (require 'find-func) |
| @@ -677,13 +678,6 @@ and is displayed in front of the value of MESSAGE-FORM." | |||
| 677 | (cl-defstruct (ert-test-aborted-with-non-local-exit | 678 | (cl-defstruct (ert-test-aborted-with-non-local-exit |
| 678 | (:include ert-test-result))) | 679 | (:include ert-test-result))) |
| 679 | 680 | ||
| 680 | (defun ert--print-backtrace (backtrace do-xrefs) | ||
| 681 | "Format the backtrace BACKTRACE to the current buffer." | ||
| 682 | (let ((print-escape-newlines t) | ||
| 683 | (print-level 8) | ||
| 684 | (print-length 50)) | ||
| 685 | (debugger-insert-backtrace backtrace do-xrefs))) | ||
| 686 | |||
| 687 | ;; A container for the state of the execution of a single test and | 681 | ;; A container for the state of the execution of a single test and |
| 688 | ;; environment data needed during its execution. | 682 | ;; environment data needed during its execution. |
| 689 | (cl-defstruct ert--test-execution-info | 683 | (cl-defstruct ert--test-execution-info |
| @@ -732,7 +726,7 @@ run. ARGS are the arguments to `debugger'." | |||
| 732 | ;; use. | 726 | ;; use. |
| 733 | ;; | 727 | ;; |
| 734 | ;; Grab the frames above the debugger. | 728 | ;; Grab the frames above the debugger. |
| 735 | (backtrace (cdr (backtrace-frames debugger))) | 729 | (backtrace (cdr (backtrace-get-frames debugger))) |
| 736 | (infos (reverse ert--infos))) | 730 | (infos (reverse ert--infos))) |
| 737 | (setf (ert--test-execution-info-result info) | 731 | (setf (ert--test-execution-info-result info) |
| 738 | (cl-ecase type | 732 | (cl-ecase type |
| @@ -1406,9 +1400,8 @@ Returns the stats object." | |||
| 1406 | (ert-test-result-with-condition | 1400 | (ert-test-result-with-condition |
| 1407 | (message "Test %S backtrace:" (ert-test-name test)) | 1401 | (message "Test %S backtrace:" (ert-test-name test)) |
| 1408 | (with-temp-buffer | 1402 | (with-temp-buffer |
| 1409 | (ert--print-backtrace | 1403 | (insert (backtrace-to-string |
| 1410 | (ert-test-result-with-condition-backtrace result) | 1404 | (ert-test-result-with-condition-backtrace result))) |
| 1411 | nil) | ||
| 1412 | (if (not ert-batch-backtrace-right-margin) | 1405 | (if (not ert-batch-backtrace-right-margin) |
| 1413 | (message "%s" | 1406 | (message "%s" |
| 1414 | (buffer-substring-no-properties (point-min) | 1407 | (buffer-substring-no-properties (point-min) |
| @@ -2450,20 +2443,21 @@ To be used in the ERT results buffer." | |||
| 2450 | (cl-etypecase result | 2443 | (cl-etypecase result |
| 2451 | (ert-test-passed (error "Test passed, no backtrace available")) | 2444 | (ert-test-passed (error "Test passed, no backtrace available")) |
| 2452 | (ert-test-result-with-condition | 2445 | (ert-test-result-with-condition |
| 2453 | (let ((backtrace (ert-test-result-with-condition-backtrace result)) | 2446 | (let ((buffer (get-buffer-create "*ERT Backtrace*"))) |
| 2454 | (buffer (get-buffer-create "*ERT Backtrace*"))) | ||
| 2455 | (pop-to-buffer buffer) | 2447 | (pop-to-buffer buffer) |
| 2456 | (let ((inhibit-read-only t)) | 2448 | (unless (derived-mode-p 'backtrace-mode) |
| 2457 | (buffer-disable-undo) | 2449 | (backtrace-mode)) |
| 2458 | (erase-buffer) | 2450 | (setq backtrace-insert-header-function |
| 2459 | (ert-simple-view-mode) | 2451 | (lambda () (ert--insert-backtrace-header (ert-test-name test))) |
| 2460 | (set-buffer-multibyte t) ; mimic debugger-setup-buffer | 2452 | backtrace-frames (ert-test-result-with-condition-backtrace result) |
| 2461 | (setq truncate-lines t) | 2453 | backtrace-view '(:do-xrefs t)) |
| 2462 | (ert--print-backtrace backtrace t) | 2454 | (backtrace-print) |
| 2463 | (goto-char (point-min)) | 2455 | (goto-char (point-min))))))) |
| 2464 | (insert (substitute-command-keys "Backtrace for test `")) | 2456 | |
| 2465 | (ert-insert-test-name-button (ert-test-name test)) | 2457 | (defun ert--insert-backtrace-header (name) |
| 2466 | (insert (substitute-command-keys "':\n")))))))) | 2458 | (insert (substitute-command-keys "Backtrace for test `")) |
| 2459 | (ert-insert-test-name-button name) | ||
| 2460 | (insert (substitute-command-keys "':\n"))) | ||
| 2467 | 2461 | ||
| 2468 | (defun ert-results-pop-to-messages-for-test-at-point () | 2462 | (defun ert-results-pop-to-messages-for-test-at-point () |
| 2469 | "Display the part of the *Messages* buffer generated during the test at point. | 2463 | "Display the part of the *Messages* buffer generated during the test at point. |
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 6313c63ecfe..afb7cbd1dd7 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el | |||
| @@ -517,6 +517,16 @@ This will generate compile-time constants from BINDINGS." | |||
| 517 | (defvar lisp-cl-font-lock-keywords lisp-cl-font-lock-keywords-1 | 517 | (defvar lisp-cl-font-lock-keywords lisp-cl-font-lock-keywords-1 |
| 518 | "Default expressions to highlight in Lisp modes.") | 518 | "Default expressions to highlight in Lisp modes.") |
| 519 | 519 | ||
| 520 | ;; Support backtrace mode. | ||
| 521 | (defconst lisp-el-font-lock-keywords-for-backtraces lisp-el-font-lock-keywords | ||
| 522 | "Default highlighting from Emacs Lisp mod used in Backtrace mode.") | ||
| 523 | (defconst lisp-el-font-lock-keywords-for-backtraces-1 lisp-el-font-lock-keywords-1 | ||
| 524 | "Subdued highlighting from Emacs Lisp mode used in Backtrace mode.") | ||
| 525 | (defconst lisp-el-font-lock-keywords-for-backtraces-2 | ||
| 526 | (remove (assoc 'lisp--match-hidden-arg lisp-el-font-lock-keywords-2) | ||
| 527 | lisp-el-font-lock-keywords-2) | ||
| 528 | "Gaudy highlighting from Emacs Lisp mode used in Backtrace mode.") | ||
| 529 | |||
| 520 | (defun lisp-string-in-doc-position-p (listbeg startpos) | 530 | (defun lisp-string-in-doc-position-p (listbeg startpos) |
| 521 | "Return true if a doc string may occur at STARTPOS inside a list. | 531 | "Return true if a doc string may occur at STARTPOS inside a list. |
| 522 | LISTBEG is the position of the start of the innermost list | 532 | LISTBEG is the position of the start of the innermost list |
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el new file mode 100644 index 00000000000..75da468494b --- /dev/null +++ b/test/lisp/emacs-lisp/backtrace-tests.el | |||
| @@ -0,0 +1,89 @@ | |||
| 1 | ;;; backtrace-tests.el --- Tests for emacs-lisp/backtrace.el -*- lexical-binding: t; -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 2018 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Gemini Lasswell | ||
| 6 | |||
| 7 | ;; This file is part of GNU Emacs. | ||
| 8 | |||
| 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 10 | ;; it under the terms of the GNU General Public License as published by | ||
| 11 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 12 | ;; (at your option) any later version. | ||
| 13 | |||
| 14 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 17 | ;; GNU General Public License for more details. | ||
| 18 | |||
| 19 | ;; You should have received a copy of the GNU General Public License | ||
| 20 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
| 21 | |||
| 22 | ;;; Code: | ||
| 23 | |||
| 24 | (require 'backtrace) | ||
| 25 | (require 'ert) | ||
| 26 | (require 'seq) | ||
| 27 | |||
| 28 | ;; Create a backtrace frames list with several frames. | ||
| 29 | ;; TODO load this from an el file in backtrace-resources/ so the tests | ||
| 30 | ;; can be byte-compiled. | ||
| 31 | (defvar backtrace-tests--frames nil) | ||
| 32 | |||
| 33 | (defun backtrace-tests--func1 (arg1 arg2) | ||
| 34 | (setq backtrace-tests--frames (backtrace-get-frames nil)) | ||
| 35 | (list arg1 arg2)) | ||
| 36 | |||
| 37 | (defun backtrace-tests--func2 (arg) | ||
| 38 | (list arg)) | ||
| 39 | |||
| 40 | (defun backtrace-tests--func3 (arg) | ||
| 41 | (let ((foo (list 'a arg 'b))) | ||
| 42 | (list foo (backtrace-tests--func2 arg) (backtrace-tests--func1 arg 0)))) | ||
| 43 | |||
| 44 | (defun backtrace-tests--create-backtrace-frames () | ||
| 45 | (backtrace-tests--func3 "string") | ||
| 46 | ;; Discard frames before this one. | ||
| 47 | (let (this-index) | ||
| 48 | (dotimes (index (length backtrace-tests--frames)) | ||
| 49 | (when (eq (backtrace-frame-fun (nth index backtrace-tests--frames)) | ||
| 50 | 'backtrace-tests--create-backtrace-frames) | ||
| 51 | (setq this-index index))) | ||
| 52 | (setq backtrace-tests--frames (seq-subseq backtrace-tests--frames | ||
| 53 | 0 (1+ this-index))))) | ||
| 54 | |||
| 55 | (backtrace-tests--create-backtrace-frames) | ||
| 56 | |||
| 57 | ;; TODO check that debugger-batch-max-lines still works | ||
| 58 | |||
| 59 | (defun backtrace-tests--insert-header () | ||
| 60 | (insert "Test header\n")) | ||
| 61 | |||
| 62 | (defmacro backtrace-tests--with-buffer (&rest body) | ||
| 63 | `(with-temp-buffer | ||
| 64 | (backtrace-mode) | ||
| 65 | (setq backtrace-frames backtrace-tests--frames) | ||
| 66 | (setq backtrace-insert-header-function #'backtrace-tests--insert-header) | ||
| 67 | (backtrace-print) | ||
| 68 | ,@body)) | ||
| 69 | |||
| 70 | ;;; Tests | ||
| 71 | (ert-deftest backtrace-tests--to-string () | ||
| 72 | (should (string= (backtrace-to-string backtrace-tests--frames) | ||
| 73 | " backtrace-get-frames(nil) | ||
| 74 | (setq backtrace-tests--frames (backtrace-get-frames nil)) | ||
| 75 | backtrace-tests--func1(\"string\" 0) | ||
| 76 | (list foo (backtrace-tests--func2 arg) (backtrace-tests--func1 arg 0)) | ||
| 77 | (let ((foo (list 'a arg 'b))) (list foo (backtrace-tests--func2 arg) (backtrace-tests--func1 arg 0))) | ||
| 78 | backtrace-tests--func3(\"string\") | ||
| 79 | backtrace-tests--create-backtrace-frames() | ||
| 80 | "))) | ||
| 81 | |||
| 82 | (provide 'backtrace-tests) | ||
| 83 | |||
| 84 | ;; These tests expect to see non-byte compiled stack frames. | ||
| 85 | ;; Local Variables: | ||
| 86 | ;; no-byte-compile: t | ||
| 87 | ;; End: | ||
| 88 | |||
| 89 | ;;; backtrace-tests.el ends here | ||
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index cb957bd9fd6..1fe5b79ef36 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el | |||
| @@ -376,7 +376,7 @@ This macro is used to test if macroexpansion in `should' works." | |||
| 376 | (test (make-ert-test :body test-body)) | 376 | (test (make-ert-test :body test-body)) |
| 377 | (result (ert-run-test test))) | 377 | (result (ert-run-test test))) |
| 378 | (should (ert-test-failed-p result)) | 378 | (should (ert-test-failed-p result)) |
| 379 | (should (eq (nth 1 (car (ert-test-failed-backtrace result))) | 379 | (should (eq (backtrace-frame-fun (car (ert-test-failed-backtrace result))) |
| 380 | 'signal)))) | 380 | 'signal)))) |
| 381 | 381 | ||
| 382 | (ert-deftest ert-test-messages () | 382 | (ert-deftest ert-test-messages () |