Mercurial > emacs
changeset 106679:95a78f48ba00
This changeset reverts GDB Graphical Interface to use annotations. It incorporates features added
(and never released) on the EMACS_23_1_RC branch. Namely reverse debugging and the display of STL
collections as watch expressions.
The long term aim is to move to GDB/MI, so these changes will be re-instated at some time in the future.
At the moment, however, there are issues with gdb-mi.el that have not yet been solved, e.g, bug#5145.
| author | Nick Roberts <nickrob@snap.net.nz> |
|---|---|
| date | Tue, 29 Dec 2009 20:22:00 +1300 |
| parents | f147ed43b1d5 (current diff) 3a8fd7717b30 (diff) |
| children | 63c5fb6b67fc |
| files | lisp/progmodes/gdb-mi.el |
| diffstat | 7 files changed, 4302 insertions(+), 4474 deletions(-) [+] |
line wrap: on
line diff
--- a/doc/emacs/building.texi Mon Dec 28 22:46:08 2009 -0800 +++ b/doc/emacs/building.texi Tue Dec 29 20:22:00 2009 +1300 @@ -854,12 +854,11 @@ * Source Buffers:: Use the mouse in the fringe/margin to control your program. * Breakpoints Buffer:: A breakpoint control panel. -* Threads Buffer:: Displays your threads. * Stack Buffer:: Select a frame from the call stack. * Other GDB-UI Buffers:: Input/output, locals, registers, assembler, threads and memory buffers. * Watch Expressions:: Monitor variable values in the speedbar. -* Multithreaded Debugging:: Debugging programs with several threads. +* Reverse Debugging:: Execute and reverse debug your program. @end menu @node GDB-UI Layout @@ -884,7 +883,7 @@ |--------------------------------+--------------------------------+ | Primary Source buffer | I/O buffer for debugged pgm | |--------------------------------+--------------------------------+ -| Stack buffer | Breakpoints/Thread buffer | +| Stack buffer | Breakpoints/Threads buffer | +--------------------------------+--------------------------------+ @end group @end smallexample @@ -1012,92 +1011,10 @@ Visit the source line for the breakpoint you click on. @end table -@vindex gdb-show-threads-by-default When @code{gdb-many-windows} is non-@code{nil}, the breakpoints buffer shares its window with the threads buffer. To switch from one to the other click with @kbd{Mouse-1} on the relevant button in the header -line, or press @kbd{TAB} inside that buffer. If -@code{gdb-show-threads-by-default} is non-@code{nil}, the threads -buffer, rather than the breakpoints buffer, is shown at start up. - -@node Threads Buffer -@subsubsection Threads Buffer - -@findex gdb-select-thread -The threads buffer displays a summary of all threads currently in your -program (@pxref{Threads, Threads, Debugging programs with multiple -threads, gdb, The GNU debugger}). Move point to any thread in the list -and press @key{RET} to select it (@code{gdb-select-thread}) and -display the associated source in the primary source buffer. -Alternatively, click @kbd{Mouse-2} on a thread to select it. Contents -of all GDB buffers are updated whenever you select a thread. - - You can customize variables under @code{gdb-buffers} group to select -fields included in threads buffer. - -@table @code -@item gdb-thread-buffer-verbose-names -@vindex gdb-thread-buffer-verbose-names -Show long thread names like @samp{Thread 0x4e2ab70 (LWP 1983)} in -threads buffer. - -@item gdb-thread-buffer-arguments -@vindex gdb-thread-buffer-arguments -Show arguments of thread top frames in threads buffer. - -@item gdb-thread-buffer-locations -@vindex gdb-thread-buffer-locations -Show file information or library names in threads buffer. - -@item gdb-thread-buffer-addresses -@vindex gdb-thread-buffer-addresses -Show addresses for thread frames in threads buffer. -@end table - - It’s possible to observe information for several threads -simultaneously (in addition to buffers which show information for -currently selected thread) using the following keys from the threads -buffer. - -@table @kbd -@item d -@kindex d @r{(GDB threads buffer)} -@findex gdb-display-disassembly-for-thread -Display disassembly buffer for the thread at current line. -(@code{gdb-display-disassembly-for-thread}) - -@item f -@kindex f @r{(GDB threads buffer)} -@findex gdb-display-stack-for-thread -Display stack buffer for the thread at current line. -(@code{gdb-display-stack-for-thread}). - -@item l -@kindex l @r{(GDB threads buffer)} -@findex gdb-display-locals-for-thread -Display locals buffer for the thread at current line. -(@code{gdb-display-locals-for-thread}). - -@item r -@kindex r @r{(GDB threads buffer)} -@findex gdb-display-registers-for-thread -Display registers buffer for the thread at current line. -(@code{gdb-display-registers-for-thread}). -@end table - -Pressing their upper-case counterparts, @kbd{D}, @kbd{F} ,@kbd{L} and -@kbd{R} displays the corresponding buffer in a new frame. - - When you create a buffer showing information about some specific -thread, it becomes bound to that thread and keeps showing actual -information while you debug your program. Every GDB buffer contains a -number of thread it shows information for in its mode name. Thread -number is also included in the buffer name of bound buffers to prevent -buffer names clashing. - -Further commands are available in the threads buffer which depend on the -mode of GDB that is used for controlling execution of your program. -(@pxref{Multithreaded Debugging, Stopping and Starting Multi-threaded Programs}). +line. @node Stack Buffer @subsubsection Stack Buffer @@ -1134,7 +1051,7 @@ @item Locals Buffer The locals buffer displays the values of local variables of the current frame for simple data types (@pxref{Frame Info, Frame Info, -Information on a frame, gdb, The GNU debugger}). Press @key{RET} or +Information on a frame, gdb, The GNU debugger}). Press @key{RET} or click @kbd{Mouse-2} on the value if you want to edit it. Arrays and structures display their type only. With GDB 6.4 or later, @@ -1153,12 +1070,27 @@ press @key{SPC} to toggle the display of floating point registers (@code{toggle-gdb-all-registers}). -@item Disassembly Buffer -The disassembly buffer displays the current frame as machine code. An +@item Assembler Buffer +The assembler buffer displays the current frame as machine code. An arrow points to the current instruction, and you can set and remove breakpoints as in a source buffer. Breakpoint icons also appear in the fringe or margin. +@item Threads Buffer +@findex gdb-threads-select +The threads buffer displays a summary of all threads currently in your +program (@pxref{Threads, Threads, Debugging programs with multiple +threads, gdb, The GNU debugger}). Move point to any thread in the +list and press @key{RET} to select it (@code{gdb-threads-select}) and +display the associated source in the primary source buffer. +Alternatively, click @kbd{Mouse-2} on a thread to select it. If the +locals buffer is visible, its contents update to display the variables +that are local in the new thread. + +When there is more than one main thread and the threads buffer is +present, Emacs displays the selected thread number in the mode line of +many of the GDB-UI Buffers. + @item Memory Buffer The memory buffer lets you examine sections of program memory (@pxref{Memory, Memory, Examining memory, gdb, The GNU debugger}). @@ -1171,9 +1103,8 @@ When @code{gdb-many-windows} is non-@code{nil}, the threads buffer shares its window with the breakpoints buffer, and the locals buffer -with the registers buffer. To switch from one to the other click with -@kbd{Mouse-1} on the relevant button in the header line or press -@kbd{TAB} inside the buffer. +with the registers buffer. To switch from one to the other click with +@kbd{Mouse-1} on the relevant button in the header line. @node Watch Expressions @subsubsection Watch Expressions @@ -1241,96 +1172,26 @@ non-@code{nil}. This can be useful if you are debugging with a full screen Emacs frame. -@node Multithreaded Debugging -@subsubsection Stopping and Starting Multi-threaded Programs -@cindex Multithreaded debugging in GDB - -@subsubheading All-stop Debugging - -In all-stop mode, whenever your program stops, @emph{all} threads of -execution stop. Likewise, whenever you restart the program, all -threads start executing. @xref{All-Stop Mode, , All-Stop Mode, gdb, -The GNU debugger}. You can enable this behaviour in Emacs by setting -@code{gdb-non-stop-setting} to @code{nil} before starting a debugging -session. - -@subsubheading Non-stop Debugging -@cindex Non-stop debugging in GDB - -For some multi-threaded targets, GDB supports a further mode of -operation in which you can examine stopped program threads in the -debugger while other threads continue to execute freely. -@xref{Non-Stop Mode, , Non-Stop Mode, gdb, The GNU debugger}. -This is referred to as @dfn{non-stop} mode. - -Versions of GDB prior to 7.0 do not support non-stop mode and it does -not work on all targets. In such cases, Emacs uses all-stop mode -regardless of the value of @code{gdb-non-stop-setting}. - -@vindex gdb-non-stop-setting -If the variable @code{gdb-non-stop-setting} is non-@code{nil} (the -default value), Emacs tries to start GDB in non-stop mode. Note that -GDB debugging session needs to be restarted for change of this setting -to take effect. - -@vindex gdb-switch-when-another-stopped -When a thread stops in non-stop mode, Emacs automatically switches to -that thread. It may be undesirable to allow switching of current -thread when some other stopped thread is already selected. Set -@code{gdb-switch-when-another-stopped} to @code{nil} to prevent this. - -@vindex gdb-switch-reasons -Emacs can decide whether or not to switch to the stopped thread -depending on the reason which caused the stop. Customize -@code{gdb-switch-reasons} to select stop reasons which make Emacs -switch thread. +@node Reverse Debugging +@subsubsection Reverse Debugging -@vindex gdb-stopped-hooks -The variable @code{gdb-stopped-hooks} allows you to execute your -functions whenever some thread stops. - - In non-stop mode, you can switch between different modes for GUD -execution control commands. - -@vindex gdb-gud-control-all-threads -@table @dfn -@item Non-stop/A - -When @code{gdb-gud-control-all-threads} is @code{t} (the default -value), interruption and continuation commands apply to all threads, -so you can halt or continue all your threads with one command using -@code{gud-stop-subjob} and @code{gud-cont}, respectively. The -@samp{Go} button is shown on the toolbar when at least one thread is -stopped, whereas @samp{Stop} button is shown when at least one thread -is running. - -@item Non-stop/T + The GDB tool bar shares many buttons with the other GUD debuggers +for tasks like stepping and printing expressions. It also has a +further set of buttons that allow reverse debugging (@pxref{Process +Record and Replay, , ,gdb, The GNU debugger}). This is useful when it +takes a long time to reproduce the conditions where your program fails +or for transient problems, like race conditions in multi-threaded +programs, where a failure might otherwise be hard to reproduce. -When @code{gdb-gud-control-all-threads} is @code{nil}, only the -current thread is stopped/continued. @samp{Go} and @samp{Stop} -buttons on the GUD toolbar are shown depending on the state of current -thread. -@end table - -You can change the current value of @code{gdb-gud-control-all-threads} -from the tool bar or from @samp{GUD->GDB-MI} menu. - - Stepping commands always apply to the current thread. - -@subsubheading Fine Thread Control - - In non-stop mode, you can interrupt/continue your threads without -selecting them. Hitting @kbd{i} in threads buffer interrupts thread -under point, @kbd{c} continues it, @kbd{s} steps through. More such -commands may be added in the future. - -Combined with creating bound buffers for any thread, this allows you -to change and track state of many threads in the same time. - - Note that when you interrupt a thread, it stops with @samp{signal -received} reason. If that reason is included in your -@code{gdb-switch-reasons} (it is by default), Emacs will switch to -that thread. +To use reverse debugging, set a breakpoint slightly before the +location of interest and run your program to that point. Enable +process recording by clicking on the record button. At this point, a +new set of buttons appear. These buttons allow program execution in +the reverse direction. Run your program over the code where the +problem occurs, and then use the new set of buttons to retrace your +steps, examine values, and analyze the problem. When analysis is +complete, turn off process recording by clicking on the record button +again. @node Executing Lisp @section Executing Lisp Expressions
--- a/doc/emacs/emacs.texi Mon Dec 28 22:46:08 2009 -0800 +++ b/doc/emacs/emacs.texi Tue Dec 29 20:22:00 2009 +1300 @@ -745,16 +745,14 @@ GDB Graphical Interface -* GDB-UI Layout:: Control the number of displayed buffers. -* Source Buffers:: Use the mouse in the fringe/margin to - control your program. -* Breakpoints Buffer:: A breakpoint control panel. -* Threads Buffer:: Displays your threads. -* Stack Buffer:: Select a frame from the call stack. -* Other GDB-UI Buffers:: Input/output, locals, registers, - assembler, threads and memory buffers. -* Watch Expressions:: Monitor variable values in the speedbar. -* Multithreaded Debugging:: Debugging programs with several threads. +* GDB-UI Layout:: Control the number of displayed buffers. +* Source Buffers:: Use the mouse in the fringe/margin to + control your program. +* Breakpoints Buffer:: A breakpoint control panel. +* Stack Buffer:: Select a frame from the call stack. +* Other GDB-UI Buffers::Input/output, locals, registers, + assembler, threads and memory buffers. +* Watch Expressions:: Monitor variable values in the speedbar. Maintaining Large Programs
--- a/etc/NEWS Mon Dec 28 22:46:08 2009 -0800 +++ b/etc/NEWS Tue Dec 29 20:22:00 2009 +1300 @@ -218,11 +218,10 @@ *** When `doc-view-continuous' is non-nil, scrolling a line on the page edge advances to the next/previous page. -** gdb-mi - -*** GDB User Interface migrated to GDB Machine Interface and now -supports multithread non-stop debugging and debugging of several -threads simultaneously. +** GDB-UI + +*** Toolbar functionality for reverse debugging. Display of STL collections as + watch expressions. These features require GDB 7.0 or later. ** Grep
--- a/lisp/Makefile.in Mon Dec 28 22:46:08 2009 -0800 +++ b/lisp/Makefile.in Tue Dec 29 20:22:00 2009 +1300 @@ -1233,7 +1233,7 @@ $(lisp)/progmodes/f90.elc \ $(lisp)/progmodes/flymake.elc \ $(lisp)/progmodes/fortran.elc \ - $(lisp)/progmodes/gdb-mi.elc \ + $(lisp)/progmodes/gdb-ui.elc \ $(lisp)/progmodes/glasses.elc \ $(lisp)/progmodes/grep.elc \ $(lisp)/progmodes/gud.elc \
--- a/lisp/progmodes/gdb-mi.el Mon Dec 28 22:46:08 2009 -0800 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4192 +0,0 @@ -;;; gdb-mi.el --- User Interface for running GDB - -;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. - -;; Author: Nick Roberts <nickrob@gnu.org> -;; Maintainer: FSF -;; Keywords: unix, tools - -;; This file is part of GNU Emacs. - -;; Homepage: http://www.emacswiki.org/emacs/GDB-MI - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Credits: - -;; This file was written by by Nick Roberts following the general design -;; used in gdb-ui.el for Emacs 22.1 - 23.1. It is currently being developed -;; by Dmitry Dzhus <dima@sphinx.net.ru> as part of the Google Summer -;; of Code 2009 Project "Emacs GDB/MI migration". - -;;; Commentary: - -;; This mode acts as a graphical user interface to GDB. You can interact with -;; GDB through the GUD buffer in the usual way, but there are also further -;; buffers which control the execution and describe the state of your program. -;; It separates the input/output of your program from that of GDB and displays -;; expressions and their current values in their own buffers. It also uses -;; features of Emacs 21 such as the fringe/display margin for breakpoints, and -;; the toolbar (see the GDB Graphical Interface section in the Emacs info -;; manual). - -;; M-x gdb will start the debugger. - -;; This file uses GDB/MI as the primary interface to GDB. It is still under -;; development and is part of a process to migrate Emacs from annotations (as -;; used in gdb-ui.el) to GDB/MI. It runs gdb with GDB/MI (-interp=mi) and -;; access CLI using "-interpreter-exec console cli-command". This code works -;; without gdb-ui.el and uses MI tokens instead of queues. Eventually MI -;; should be asynchronous. - -;; This mode will PARTLY WORK WITH RECENT GDB RELEASES (status in modeline -;; doesn't update properly when execution commands are issued from GUD buffer) -;; and WORKS BEST when GDB runs asynchronously: maint set linux-async on. -;; -;; You need development version of GDB 7.0 for the thread buffer to work. - -;; This file replaces gdb-ui.el and is for development with GDB. Use the -;; release branch of Emacs 22 for the latest version of gdb-ui.el. - -;; Windows Platforms: - -;; If you are using Emacs and GDB on Windows you will need to flush the buffer -;; explicitly in your program if you want timely display of I/O in Emacs. -;; Alternatively you can make the output stream unbuffered, for example, by -;; using a macro: - -;; #ifdef UNBUFFERED -;; setvbuf (stdout, (char *) NULL, _IONBF, 0); -;; #endif - -;; and compiling with -DUNBUFFERED while debugging. - -;; If you are using Cygwin GDB and find that the source is not being displayed -;; in Emacs when you step through it, possible solutions are to: - -;; 1) Use Cygwin X Windows and Cygwin Emacs. -;; (Since 22.1 Emacs builds under Cygwin.) -;; 2) Use MinGW GDB instead. -;; 3) Use cygwin-mount.el - -;;; Mac OSX: - -;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made -;; some changes to the version that they include as part of Mac OSX. -;; This requires GDB version 7.0 or later (estimated release date Aug 2009) -;; as earlier versions don not compile on Mac OSX. - -;;; Known Bugs: - -;; 1) Stack buffer doesn't parse MI output if you stop in a routine without -;; line information, e.g., a routine in libc (just a TODO item). - -;; TODO: -;; 2) Watch windows to work with threads. -;; 3) Use treebuffer.el instead of the speedbar for watch-expressions? -;; 4) Mark breakpoint locations on scroll-bar of source buffer? - -;;; Code: - -(require 'gud) -(require 'json) -(require 'bindat) -(eval-when-compile (require 'cl)) - -(defvar tool-bar-map) -(defvar speedbar-initial-expansion-list-name) -(defvar speedbar-frame) - -(defvar gdb-memory-address "main") -(defvar gdb-memory-last-address nil - "Last successfully accessed memory address.") -(defvar gdb-memory-next-page nil - "Address of next memory page for program memory buffer.") -(defvar gdb-memory-prev-page nil - "Address of previous memory page for program memory buffer.") - -(defvar gdb-thread-number nil - "Main current thread. - -Invalidation triggers use this variable to query GDB for -information on the specified thread by wrapping GDB/MI commands -in `gdb-current-context-command'. - -This variable may be updated implicitly by GDB via `gdb-stopped' -or explicitly by `gdb-select-thread'. - -Only `gdb-setq-thread-number' should be used to change this -value.") - -(defvar gdb-frame-number nil - "Selected frame level for main current thread. - -Updated according to the following rules: - -When a thread is selected or current thread stops, set to \"0\". - -When current thread goes running (and possibly exits eventually), -set to nil. - -May be manually changed by user with `gdb-select-frame'.") - -(defvar gdb-frame-address nil "Identity of frame for watch expression.") - -;; Used to show overlay arrow in source buffer. All set in -;; gdb-get-main-selected-frame. Disassembly buffer should not use -;; these but rely on buffer-local thread information instead. -(defvar gdb-selected-frame nil - "Name of selected function for main current thread.") -(defvar gdb-selected-file nil - "Name of selected file for main current thread.") -(defvar gdb-selected-line nil - "Number of selected line for main current thread.") - -(defvar gdb-threads-list nil - "Associative list of threads provided by \"-thread-info\" MI command. - -Keys are thread numbers (in strings) and values are structures as -returned from -thread-info by `gdb-json-partial-output'. Updated in -`gdb-thread-list-handler-custom'.") - -(defvar gdb-running-threads-count nil - "Number of currently running threads. - -Nil means that no information is available. - -Updated in `gdb-thread-list-handler-custom'.") - -(defvar gdb-stopped-threads-count nil - "Number of currently stopped threads. - -See also `gdb-running-threads-count'.") - -(defvar gdb-breakpoints-list nil - "Associative list of breakpoints provided by \"-break-list\" MI command. - -Keys are breakpoint numbers (in string) and values are structures -as returned from \"-break-list\" by `gdb-json-partial-output' -\(\"body\" field is used). Updated in -`gdb-breakpoints-list-handler-custom'.") - -(defvar gdb-current-language nil) -(defvar gdb-var-list nil - "List of variables in watch window. -Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP) -where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame -address for root variables.") -(defvar gdb-main-file nil "Source file from which program execution begins.") - -;; Overlay arrow markers -(defvar gdb-stack-position nil) -(defvar gdb-thread-position nil) -(defvar gdb-disassembly-position nil) - -(defvar gdb-location-alist nil - "Alist of breakpoint numbers and full filenames. Only used for files that -Emacs can't find.") -(defvar gdb-active-process nil - "GUD tooltips display variable values when t, and macro definitions otherwise.") -(defvar gdb-error "Non-nil when GDB is reporting an error.") -(defvar gdb-macro-info nil - "Non-nil if GDB knows that the inferior includes preprocessor macro info.") -(defvar gdb-register-names nil "List of register names.") -(defvar gdb-changed-registers nil - "List of changed register numbers (strings).") -(defvar gdb-buffer-fringe-width nil) -(defvar gdb-last-command nil) -(defvar gdb-prompt-name nil) -(defvar gdb-token-number 0) -(defvar gdb-handler-alist '()) -(defvar gdb-handler-number nil) -(defvar gdb-source-file-list nil - "List of source files for the current executable.") -(defvar gdb-first-done-or-error t) -(defvar gdb-source-window nil) -(defvar gdb-inferior-status nil) -(defvar gdb-continuation nil) -(defvar gdb-version nil) -(defvar gdb-filter-output nil - "Message to be shown in GUD console. - -This variable is updated in `gdb-done-or-error' and returned by -`gud-gdbmi-marker-filter'.") - -(defvar gdb-non-stop nil - "Indicates whether current GDB session is using non-stop mode. - -It is initialized to `gdb-non-stop-setting' at the beginning of -every GDB session.") - -(defvar gdb-buffer-type nil - "One of the symbols bound in `gdb-buffer-rules'.") -(make-variable-buffer-local 'gdb-buffer-type) - -(defvar gdb-output-sink 'nil - "The disposition of the output of the current gdb command. -Possible values are these symbols: - - `user' -- gdb output should be copied to the GUD buffer - for the user to see. - - `emacs' -- output should be collected in the partial-output-buffer - for subsequent processing by a command. This is the - disposition of output generated by commands that - gdb mode sends to gdb on its own behalf.") - -;; Pending triggers prevent congestion: Emacs won't send two similar -;; consecutive requests. - -(defvar gdb-pending-triggers '() - "A list of trigger functions which have not yet been handled. - -Elements are either function names or pairs (buffer . function)") - -(defmacro gdb-add-pending (item) - `(push ,item gdb-pending-triggers)) -(defmacro gdb-pending-p (item) - `(member ,item gdb-pending-triggers)) -(defmacro gdb-delete-pending (item) - `(setq gdb-pending-triggers - (delete ,item gdb-pending-triggers))) - -(defmacro gdb-wait-for-pending (&rest body) - "Wait until `gdb-pending-triggers' is empty and evaluate FORM. - -This function checks `gdb-pending-triggers' value every -`gdb-wait-for-pending' seconds." - (run-with-timer - 0.5 nil - `(lambda () - (if (not gdb-pending-triggers) - (progn ,@body) - (gdb-wait-for-pending ,@body))))) - -;; Publish-subscribe - -(defmacro gdb-add-subscriber (publisher subscriber) - "Register new PUBLISHER's SUBSCRIBER. - -SUBSCRIBER must be a pair, where cdr is a function of one -argument (see `gdb-emit-signal')." - `(add-to-list ',publisher ,subscriber t)) - -(defmacro gdb-delete-subscriber (publisher subscriber) - "Unregister SUBSCRIBER from PUBLISHER." - `(setq ,publisher (delete ,subscriber - ,publisher))) - -(defun gdb-get-subscribers (publisher) - publisher) - -(defun gdb-emit-signal (publisher &optional signal) - "Call cdr for each subscriber of PUBLISHER with SIGNAL as argument." - (dolist (subscriber (gdb-get-subscribers publisher)) - (funcall (cdr subscriber) signal))) - -(defvar gdb-buf-publisher '() - "Used to invalidate GDB buffers by emitting a signal in -`gdb-update'. - -Must be a list of pairs with cars being buffers and cdr's being -valid signal handlers.") - -(defgroup gdb nil - "GDB graphical interface" - :group 'tools - :link '(info-link "(emacs)GDB Graphical Interface") - :version "23.2") - -(defgroup gdb-non-stop nil - "GDB non-stop debugging settings" - :group 'gdb - :version "23.2") - -(defgroup gdb-buffers nil - "GDB buffers" - :group 'gdb - :version "23.2") - -(defcustom gdb-debug-log-max 128 - "Maximum size of `gdb-debug-log'. If nil, size is unlimited." - :group 'gdb - :type '(choice (integer :tag "Number of elements") - (const :tag "Unlimited" nil)) - :version "22.1") - -(defcustom gdb-non-stop-setting t - "When in non-stop mode, stopped threads can be examined while -other threads continue to execute. - -GDB session needs to be restarted for this setting to take -effect." - :type 'boolean - :group 'gdb-non-stop - :version "23.2") - -;; TODO Some commands can't be called with --all (give a notice about -;; it in setting doc) -(defcustom gdb-gud-control-all-threads t - "When enabled, GUD execution commands affect all threads when -in non-stop mode. Otherwise, only current thread is affected." - :type 'boolean - :group 'gdb-non-stop - :version "23.2") - -(defcustom gdb-switch-reasons t - "List of stop reasons which cause Emacs to switch to the thread -which caused the stop. When t, switch to stopped thread no matter -what the reason was. When nil, never switch to stopped thread -automatically. - -This setting is used in non-stop mode only. In all-stop mode, -Emacs always switches to the thread which caused the stop." - ;; exited, exited-normally and exited-signalled are not - ;; thread-specific stop reasons and therefore are not included in - ;; this list - :type '(choice - (const :tag "All reasons" t) - (set :tag "Selection of reasons..." - (const :tag "A breakpoint was reached." "breakpoint-hit") - (const :tag "A watchpoint was triggered." "watchpoint-trigger") - (const :tag "A read watchpoint was triggered." "read-watchpoint-trigger") - (const :tag "An access watchpoint was triggered." "access-watchpoint-trigger") - (const :tag "Function finished execution." "function-finished") - (const :tag "Location reached." "location-reached") - (const :tag "Watchpoint has gone out of scope" "watchpoint-scope") - (const :tag "End of stepping range reached." "end-stepping-range") - (const :tag "Signal received (like interruption)." "signal-received")) - (const :tag "None" nil)) - :group 'gdb-non-stop - :version "23.2" - :link '(info-link "(gdb)GDB/MI Async Records")) - -(defcustom gdb-stopped-hooks nil - "This variable holds a list of functions to be called whenever -GDB stops. - -Each function takes one argument, a parsed MI response, which -contains fields of corresponding MI *stopped async record: - - ((stopped-threads . \"all\") - (thread-id . \"1\") - (frame (line . \"38\") - (fullname . \"/home/sphinx/projects/gsoc/server.c\") - (file . \"server.c\") - (args ((value . \"0x804b038\") - (name . \"arg\"))) - (func . \"hello\") - (addr . \"0x0804869e\")) - (reason . \"end-stepping-range\")) - -Note that \"reason\" is only present in non-stop debugging mode. - -`bindat-get-field' may be used to access the fields of response. - -Each function is called after the new current thread was selected -and GDB buffers were updated in `gdb-stopped'." - :type '(repeat function) - :group 'gdb - :version "23.2" - :link '(info-link "(gdb)GDB/MI Async Records")) - -(defcustom gdb-switch-when-another-stopped t - "When nil, Emacs won't switch to stopped thread if some other -stopped thread is already selected." - :type 'boolean - :group 'gdb-non-stop - :version "23.2") - -(defcustom gdb-stack-buffer-locations t - "Show file information or library names in stack buffers." - :type 'boolean - :group 'gdb-buffers - :version "23.2") - -(defcustom gdb-stack-buffer-addresses nil - "Show frame addresses in stack buffers." - :type 'boolean - :group 'gdb-buffers - :version "23.2") - -(defcustom gdb-thread-buffer-verbose-names t - "Show long thread names in threads buffer." - :type 'boolean - :group 'gdb-buffers - :version "23.2") - -(defcustom gdb-thread-buffer-arguments t - "Show function arguments in threads buffer." - :type 'boolean - :group 'gdb-buffers - :version "23.2") - -(defcustom gdb-thread-buffer-locations t - "Show file information or library names in threads buffer." - :type 'boolean - :group 'gdb-buffers - :version "23.2") - -(defcustom gdb-thread-buffer-addresses nil - "Show addresses for thread frames in threads buffer." - :type 'boolean - :group 'gdb-buffers - :version "23.2") - -(defcustom gdb-show-threads-by-default nil - "Show threads list buffer instead of breakpoints list by -default." - :type 'boolean - :group 'gdb-buffers - :version "23.2") - -(defvar gdb-debug-log nil - "List of commands sent to and replies received from GDB. -Most recent commands are listed first. This list stores only the last -`gdb-debug-log-max' values. This variable is used to debug GDB-MI.") - -;;;###autoload -(defcustom gdb-enable-debug nil - "Non-nil means record the process input and output in `gdb-debug-log'." - :type 'boolean - :group 'gdb - :version "22.1") - -(defcustom gdb-cpp-define-alist-program "gcc -E -dM -" - "Shell command for generating a list of defined macros in a source file. -This list is used to display the #define directive associated -with an identifier as a tooltip. It works in a debug session with -GDB, when `gud-tooltip-mode' is t. - -Set `gdb-cpp-define-alist-flags' for any include paths or -predefined macros." - :type 'string - :group 'gdb - :version "22.1") - -(defcustom gdb-cpp-define-alist-flags "" - "Preprocessor flags for `gdb-cpp-define-alist-program'." - :type 'string - :group 'gdb - :version "22.1") - - (defcustom gdb-create-source-file-list t - "Non-nil means create a list of files from which the executable was built. - Set this to nil if the GUD buffer displays \"initializing...\" in the mode - line for a long time when starting, possibly because your executable was - built from a large number of files. This allows quicker initialization - but means that these files are not automatically enabled for debugging, - e.g., you won't be able to click in the fringe to set a breakpoint until - execution has already stopped there." - :type 'boolean - :group 'gdb - :version "23.1") - -(defcustom gdb-show-main nil - "Non-nil means display source file containing the main routine at startup. -Also display the main routine in the disassembly buffer if present." - :type 'boolean - :group 'gdb - :version "22.1") - -(defun gdb-force-mode-line-update (status) - (let ((buffer gud-comint-buffer)) - (if (and buffer (buffer-name buffer)) - (with-current-buffer buffer - (setq mode-line-process - (format ":%s [%s]" - (process-status (get-buffer-process buffer)) status)) - ;; Force mode line redisplay soon. - (force-mode-line-update))))) - -(defun gdb-enable-debug (arg) - "Toggle logging of transaction between Emacs and Gdb. -The log is stored in `gdb-debug-log' as an alist with elements -whose cons is send, send-item or recv and whose cdr is the string -being transferred. This list may grow up to a size of -`gdb-debug-log-max' after which the oldest element (at the end of -the list) is deleted every time a new one is added (at the front)." - (interactive "P") - (setq gdb-enable-debug - (if (null arg) - (not gdb-enable-debug) - (> (prefix-numeric-value arg) 0))) - (message (format "Logging of transaction %sabled" - (if gdb-enable-debug "en" "dis")))) - -;; These two are used for menu and toolbar -(defun gdb-control-all-threads () - "Switch to non-stop/A mode." - (interactive) - (setq gdb-gud-control-all-threads t) - ;; Actually forcing the tool-bar to update. - (force-mode-line-update) - (message "Now in non-stop/A mode.")) - -(defun gdb-control-current-thread () - "Switch to non-stop/T mode." - (interactive) - (setq gdb-gud-control-all-threads nil) - ;; Actually forcing the tool-bar to update. - (force-mode-line-update) - (message "Now in non-stop/T mode.")) - -(defun gdb-find-watch-expression () - (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list)) - (varnum (car var)) expr array) - (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum) - (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet - (component-list (split-string (match-string 2 varnum) "\\." t))) - (setq expr (nth 1 var1)) - (setq varnumlet (car var1)) - (dolist (component component-list) - (setq var2 (assoc varnumlet gdb-var-list)) - (setq expr (concat expr - (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2)) - (concat "[" component "]") - (concat "." component)))) - (setq varnumlet (concat varnumlet "." component))) - expr))) - -;; noall is used for commands which don't take --all, but only -;; --thread. -(defun gdb-gud-context-command (command &optional noall) - "When `gdb-non-stop' is t, add --thread option to COMMAND if -`gdb-gud-control-all-threads' is nil and --all option otherwise. -If NOALL is t, always add --thread option no matter what -`gdb-gud-control-all-threads' value is. - -When `gdb-non-stop' is nil, return COMMAND unchanged." - (if gdb-non-stop - (if (and gdb-gud-control-all-threads - (not noall) - (string-equal gdb-version "7.0+")) - (concat command " --all ") - (gdb-current-context-command command)) - command)) - -(defmacro gdb-gud-context-call (cmd1 &optional cmd2 noall noarg) - "`gud-call' wrapper which adds --thread/--all options between -CMD1 and CMD2. NOALL is the same as in `gdb-gud-context-command'. - -NOARG must be t when this macro is used outside `gud-def'" - `(gud-call - (concat (gdb-gud-context-command ,cmd1 ,noall) " " ,cmd2) - ,(when (not noarg) 'arg))) - -;;;###autoload -(defun gdb (command-line) - "Run gdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger. - -If `gdb-many-windows' is nil (the default value) then gdb just -pops up the GUD buffer unless `gdb-show-main' is t. In this case -it starts with two windows: one displaying the GUD buffer and the -other with the source file with the main routine of the inferior. - -If `gdb-many-windows' is t, regardless of the value of -`gdb-show-main', the layout below will appear. Keybindings are -shown in some of the buffers. - -Watch expressions appear in the speedbar/slowbar. - -The following commands help control operation : - -`gdb-many-windows' - Toggle the number of windows gdb uses. -`gdb-restore-windows' - To restore the window layout. - -See Info node `(emacs)GDB Graphical Interface' for a more -detailed description of this mode. - - -+----------------------------------------------------------------------+ -| GDB Toolbar | -+-----------------------------------+----------------------------------+ -| GUD buffer (I/O of GDB) | Locals buffer | -| | | -| | | -| | | -+-----------------------------------+----------------------------------+ -| Source buffer | I/O buffer (of debugged program) | -| | (comint-mode) | -| | | -| | | -| | | -| | | -| | | -| | | -+-----------------------------------+----------------------------------+ -| Stack buffer | Breakpoints buffer | -| RET gdb-select-frame | SPC gdb-toggle-breakpoint | -| | RET gdb-goto-breakpoint | -| | D gdb-delete-breakpoint | -+-----------------------------------+----------------------------------+" - ;; - (interactive (list (gud-query-cmdline 'gdb))) - - (when (and gud-comint-buffer - (buffer-name gud-comint-buffer) - (get-buffer-process gud-comint-buffer) - (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) - (gdb-restore-windows) - (error - "Multiple debugging requires restarting in text command mode")) - ;; - (gud-common-init command-line nil 'gud-gdbmi-marker-filter) - (set (make-local-variable 'gud-minor-mode) 'gdbmi) - (setq comint-input-sender 'gdb-send) - - (gud-def gud-tbreak "tbreak %f:%l" "\C-t" - "Set temporary breakpoint at current line.") - (gud-def gud-jump - (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) - "\C-j" "Set execution address to current line.") - - (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") - (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") - (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") - (gud-def gud-pstar "print* %e" nil - "Evaluate C dereferenced pointer expression at point.") - - (gud-def gud-step (gdb-gud-context-call "-exec-step" "%p" t) - "\C-s" - "Step one source line with display.") - (gud-def gud-stepi (gdb-gud-context-call "-exec-step-instruction" "%p" t) - "\C-i" - "Step one instruction with display.") - (gud-def gud-next (gdb-gud-context-call "-exec-next" "%p" t) - "\C-n" - "Step one line (skip functions).") - (gud-def gud-nexti (gdb-gud-context-call "-exec-next-instruction" "%p" t) - nil - "Step one instruction (skip functions).") - (gud-def gud-cont (gdb-gud-context-call "-exec-continue") - "\C-r" - "Continue with display.") - (gud-def gud-finish (gdb-gud-context-call "-exec-finish" nil t) - "\C-f" - "Finish executing current function.") - (gud-def gud-run "-exec-run" - nil - "Run the program.") - - (gud-def gud-break (if (not (string-match "Disassembly" mode-name)) - (gud-call "break %f:%l" arg) - (save-excursion - (beginning-of-line) - (forward-char 2) - (gud-call "break *%a" arg))) - "\C-b" "Set breakpoint at current line or address.") - - (gud-def gud-remove (if (not (string-match "Disassembly" mode-name)) - (gud-call "clear %f:%l" arg) - (save-excursion - (beginning-of-line) - (forward-char 2) - (gud-call "clear *%a" arg))) - "\C-d" "Remove breakpoint at current line or address.") - - ;; -exec-until doesn't support --all yet - (gud-def gud-until (if (not (string-match "Disassembly" mode-name)) - (gud-call "-exec-until %f:%l" arg) - (save-excursion - (beginning-of-line) - (forward-char 2) - (gud-call "-exec-until *%a" arg))) - "\C-u" "Continue to current line or address.") - ;; TODO Why arg here? - (gud-def - gud-go (gud-call (if gdb-active-process - (gdb-gud-context-command "-exec-continue") - "-exec-run") arg) - nil "Start or continue execution.") - - ;; For debugging Emacs only. - (gud-def gud-pp - (gud-call - (concat - "pp1 " (if (eq (buffer-local-value - 'major-mode (window-buffer)) 'speedbar-mode) - (gdb-find-watch-expression) "%e")) arg) - nil "Print the Emacs s-expression.") - - (define-key gud-minor-mode-map [left-margin mouse-1] - 'gdb-mouse-set-clear-breakpoint) - (define-key gud-minor-mode-map [left-fringe mouse-1] - 'gdb-mouse-set-clear-breakpoint) - (define-key gud-minor-mode-map [left-margin C-mouse-1] - 'gdb-mouse-toggle-breakpoint-margin) - (define-key gud-minor-mode-map [left-fringe C-mouse-1] - 'gdb-mouse-toggle-breakpoint-fringe) - - (define-key gud-minor-mode-map [left-margin drag-mouse-1] - 'gdb-mouse-until) - (define-key gud-minor-mode-map [left-fringe drag-mouse-1] - 'gdb-mouse-until) - (define-key gud-minor-mode-map [left-margin mouse-3] - 'gdb-mouse-until) - (define-key gud-minor-mode-map [left-fringe mouse-3] - 'gdb-mouse-until) - - (define-key gud-minor-mode-map [left-margin C-drag-mouse-1] - 'gdb-mouse-jump) - (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1] - 'gdb-mouse-jump) - (define-key gud-minor-mode-map [left-fringe C-mouse-3] - 'gdb-mouse-jump) - (define-key gud-minor-mode-map [left-margin C-mouse-3] - 'gdb-mouse-jump) - - (local-set-key "\C-i" 'gud-gdb-complete-command) - (setq gdb-first-prompt t) - (setq gud-running nil) - - (gdb-update) - - (run-hooks 'gdb-mode-hook)) - -(defun gdb-init-1 () - ;; (re-)initialise - (setq gdb-selected-frame nil - gdb-frame-number nil - gdb-thread-number nil - gdb-var-list nil - gdb-pending-triggers nil - gdb-output-sink 'user - gdb-location-alist nil - gdb-source-file-list nil - gdb-last-command nil - gdb-token-number 0 - gdb-handler-alist '() - gdb-handler-number nil - gdb-prompt-name nil - gdb-first-done-or-error t - gdb-buffer-fringe-width (car (window-fringes)) - gdb-debug-log nil - gdb-source-window nil - gdb-inferior-status nil - gdb-continuation nil - gdb-buf-publisher '() - gdb-threads-list '() - gdb-breakpoints-list '() - gdb-register-names '() - gdb-non-stop gdb-non-stop-setting) - ;; - (setq gdb-buffer-type 'gdbmi) - ;; - (gdb-force-mode-line-update - (propertize "initializing..." 'face font-lock-variable-name-face)) - - (gdb-get-buffer-create 'gdb-inferior-io) - (gdb-clear-inferior-io) - (set-process-filter (get-process "gdb-inferior") 'gdb-inferior-filter) - (gdb-input - ;; Needs GDB 6.4 onwards - (list (concat "-inferior-tty-set " - (process-tty-name (get-process "gdb-inferior"))) - 'ignore)) - (if (eq window-system 'w32) - (gdb-input (list "-gdb-set new-console off" 'ignore))) - (gdb-input (list "-gdb-set height 0" 'ignore)) - - (when gdb-non-stop - (gdb-input (list "-gdb-set non-stop 1" 'gdb-non-stop-handler))) - - ;; find source file and compilation directory here - (gdb-input - ; Needs GDB 6.2 onwards. - (list "-file-list-exec-source-files" 'gdb-get-source-file-list)) - (if gdb-create-source-file-list - (gdb-input - ; Needs GDB 6.0 onwards. - (list "-file-list-exec-source-file" 'gdb-get-source-file))) - (gdb-input - (list "-gdb-show prompt" 'gdb-get-prompt))) - -(defun gdb-non-stop-handler () - (goto-char (point-min)) - (if (re-search-forward "No symbol" nil t) - (progn - (message "This version of GDB doesn't support non-stop mode. Turning it off.") - (setq gdb-non-stop nil) - (setq gdb-version "pre-7.0")) - (setq gdb-version "7.0+") - (gdb-input (list "-gdb-set target-async 1" 'ignore)) - (gdb-input (list "-enable-pretty-printing" 'ignore)))) - -(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.") - -(defun gdb-create-define-alist () - "Create an alist of #define directives for GUD tooltips." - (let* ((file (buffer-file-name)) - (output - (with-output-to-string - (with-current-buffer standard-output - (and file - (file-exists-p file) - ;; call-process doesn't work with remote file names. - (not (file-remote-p default-directory)) - (call-process shell-file-name file - (list t nil) nil "-c" - (concat gdb-cpp-define-alist-program " " - gdb-cpp-define-alist-flags)))))) - (define-list (split-string output "\n" t)) - (name)) - (setq gdb-define-alist nil) - (dolist (define define-list) - (setq name (nth 1 (split-string define "[( ]"))) - (push (cons name define) gdb-define-alist)))) - -(declare-function tooltip-show "tooltip" (text &optional use-echo-area)) -(defvar tooltip-use-echo-area) - -(defun gdb-tooltip-print (expr) - (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) - (goto-char (point-min)) - (if (re-search-forward ".*value=\\(\".*\"\\)" nil t) - (tooltip-show - (concat expr " = " (read (match-string 1))) - (or gud-tooltip-echo-area tooltip-use-echo-area - (not (display-graphic-p))))))) - -;; If expr is a macro for a function don't print because of possible dangerous -;; side-effects. Also printing a function within a tooltip generates an -;; unexpected starting annotation (phase error). -(defun gdb-tooltip-print-1 (expr) - (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) - (goto-char (point-min)) - (if (search-forward "expands to: " nil t) - (unless (looking-at "\\S-+.*(.*).*") - (gdb-input - (list (concat "-data-evaluate-expression " expr) - `(lambda () (gdb-tooltip-print ,expr)))))))) - -(defun gdb-init-buffer () - (set (make-local-variable 'gud-minor-mode) 'gdbmi) - (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) - (when gud-tooltip-mode - (make-local-variable 'gdb-define-alist) - (gdb-create-define-alist) - (add-hook 'after-save-hook 'gdb-create-define-alist nil t))) - -(defmacro gdb-if-arrow (arrow-position &rest body) - `(if ,arrow-position - (let ((buffer (marker-buffer ,arrow-position)) (line)) - (if (equal buffer (window-buffer (posn-window end))) - (with-current-buffer buffer - (when (or (equal start end) - (equal (posn-point start) - (marker-position ,arrow-position))) - ,@body)))))) - -(defun gdb-mouse-until (event) - "Continue running until a source line past the current line. -The destination source line can be selected either by clicking -with mouse-3 on the fringe/margin or dragging the arrow -with mouse-1 (default bindings)." - (interactive "e") - (let ((start (event-start event)) - (end (event-end event))) - (gdb-if-arrow gud-overlay-arrow-position - (setq line (line-number-at-pos (posn-point end))) - (gud-call (concat "until " (number-to-string line)))) - (gdb-if-arrow gdb-disassembly-position - (save-excursion - (goto-char (point-min)) - (forward-line (1- (line-number-at-pos (posn-point end)))) - (forward-char 2) - (gud-call (concat "until *%a")))))) - -(defun gdb-mouse-jump (event) - "Set execution address/line. -The destination source line can be selected either by clicking with C-mouse-3 -on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings). -Unlike `gdb-mouse-until' the destination address can be before the current -line, and no execution takes place." - (interactive "e") - (let ((start (event-start event)) - (end (event-end event))) - (gdb-if-arrow gud-overlay-arrow-position - (setq line (line-number-at-pos (posn-point end))) - (progn - (gud-call (concat "tbreak " (number-to-string line))) - (gud-call (concat "jump " (number-to-string line))))) - (gdb-if-arrow gdb-disassembly-position - (save-excursion - (goto-char (point-min)) - (forward-line (1- (line-number-at-pos (posn-point end)))) - (forward-char 2) - (progn - (gud-call (concat "tbreak *%a")) - (gud-call (concat "jump *%a"))))))) - -(defcustom gdb-show-changed-values t - "If non-nil change the face of out of scope variables and changed values. -Out of scope variables are suppressed with `shadow' face. -Changed values are highlighted with the face `font-lock-warning-face'." - :type 'boolean - :group 'gdb - :version "22.1") - -(defcustom gdb-max-children 40 - "Maximum number of children before expansion requires confirmation." - :type 'integer - :group 'gdb - :version "22.1") - -(defcustom gdb-delete-out-of-scope t - "If non-nil delete watch expressions automatically when they go out of scope." - :type 'boolean - :group 'gdb - :version "22.2") - -(defcustom gdb-speedbar-auto-raise nil - "If non-nil raise speedbar every time display of watch expressions is\ - updated." - :type 'boolean - :group 'gdb - :version "22.1") - -(defcustom gdb-use-colon-colon-notation nil - "If non-nil use FUN::VAR format to display variables in the speedbar." - :type 'boolean - :group 'gdb - :version "22.1") - -(defun gdb-speedbar-auto-raise (arg) - "Toggle automatic raising of the speedbar for watch expressions. -With prefix argument ARG, automatically raise speedbar if ARG is -positive, otherwise don't automatically raise it." - (interactive "P") - (setq gdb-speedbar-auto-raise - (if (null arg) - (not gdb-speedbar-auto-raise) - (> (prefix-numeric-value arg) 0))) - (message (format "Auto raising %sabled" - (if gdb-speedbar-auto-raise "en" "dis")))) - -(define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch) -(define-key global-map (concat gud-key-prefix "\C-w") 'gud-watch) - -(declare-function tooltip-identifier-from-point "tooltip" (point)) - -(defun gud-watch (&optional arg event) - "Watch expression at point. -With arg, enter name of variable to be watched in the minibuffer." - (interactive (list current-prefix-arg last-input-event)) - (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer))) - (if (eq minor-mode 'gdbmi) - (progn - (if event (posn-set-point (event-end event))) - (require 'tooltip) - (save-selected-window - (let ((expr - (if arg - (completing-read "Name of variable: " - 'gud-gdb-complete-command) - (if (and transient-mark-mode mark-active) - (buffer-substring (region-beginning) (region-end)) - (concat (if (eq major-mode 'gdb-registers-mode) "$") - (tooltip-identifier-from-point (point))))))) - (set-text-properties 0 (length expr) nil expr) - (gdb-input - (list (concat"-var-create - * " expr "") - `(lambda () (gdb-var-create-handler ,expr))))))) - (message "gud-watch is a no-op in this mode.")))) - -(defun gdb-var-create-handler (expr) - (let* ((result (gdb-json-partial-output))) - (if (not (bindat-get-field result 'msg)) - (let ((var - (list (bindat-get-field result 'name) - (if (and (string-equal gdb-current-language "c") - gdb-use-colon-colon-notation gdb-selected-frame) - (setq expr (concat gdb-selected-frame "::" expr)) - expr) - (bindat-get-field result 'numchild) - (bindat-get-field result 'type) - (bindat-get-field result 'value) - nil - (bindat-get-field result 'has_more) - gdb-frame-address))) - (push var gdb-var-list) - (speedbar 1) - (unless (string-equal - speedbar-initial-expansion-list-name "GUD") - (speedbar-change-initial-expansion-list "GUD"))) - (message-box "No symbol \"%s\" in current context." expr)))) - -(defun gdb-speedbar-update () - (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame) - (not (gdb-pending-p 'gdb-speedbar-timer))) - ;; Dummy command to update speedbar even when idle. - (gdb-input (list "-environment-pwd" 'gdb-speedbar-timer-fn)) - ;; Keep gdb-pending-triggers non-nil till end. - (gdb-add-pending 'gdb-speedbar-timer))) - -(defun gdb-speedbar-timer-fn () - (if gdb-speedbar-auto-raise - (raise-frame speedbar-frame)) - (gdb-delete-pending 'gdb-speedbar-timer) - (speedbar-timer-fn)) - -(defun gdb-var-evaluate-expression-handler (varnum changed) - (goto-char (point-min)) - (re-search-forward ".*value=\\(\".*\"\\)" nil t) - (let ((var (assoc varnum gdb-var-list))) - (when var - (if changed (setcar (nthcdr 5 var) 'changed)) - (setcar (nthcdr 4 var) (read (match-string 1))))) - (gdb-speedbar-update)) - -; Uses "-var-list-children --all-values". Needs GDB 6.1 onwards. -(defun gdb-var-list-children (varnum) - (gdb-input - (list (concat "-var-update " varnum) 'ignore)) - (gdb-input - (list (concat "-var-list-children --all-values " - varnum) - `(lambda () (gdb-var-list-children-handler ,varnum))))) - -(defun gdb-var-list-children-handler (varnum) - (let* ((var-list nil) - (output (bindat-get-field (gdb-json-partial-output "child"))) - (children (bindat-get-field output 'children))) - (catch 'child-already-watched - (dolist (var gdb-var-list) - (if (string-equal varnum (car var)) - (progn - ;; With dynamic varobjs numchild may have increased. - (setcar (nthcdr 2 var) (bindat-get-field output 'numchild)) - (push var var-list) - (dolist (child children) - (let ((varchild (list (bindat-get-field child 'name) - (bindat-get-field child 'exp) - (bindat-get-field child 'numchild) - (bindat-get-field child 'type) - (bindat-get-field child 'value) - nil - (bindat-get-field child 'has_more)))) - (if (assoc (car varchild) gdb-var-list) - (throw 'child-already-watched nil)) - (push varchild var-list)))) - (push var var-list))) - (setq gdb-var-list (nreverse var-list)))) - (gdb-speedbar-update)) - -(defun gdb-var-set-format (format) - "Set the output format for a variable displayed in the speedbar." - (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) - (varnum (car var))) - (gdb-input - (list (concat "-var-set-format " varnum " " format) 'ignore)) - (gdb-var-update))) - -(defun gdb-var-delete-1 (var varnum) - (gdb-input - (list (concat "-var-delete " varnum) 'ignore)) - (setq gdb-var-list (delq var gdb-var-list)) - (dolist (varchild gdb-var-list) - (if (string-match (concat (car var) "\\.") (car varchild)) - (setq gdb-var-list (delq varchild gdb-var-list))))) - -(defun gdb-var-delete () - "Delete watch expression at point from the speedbar." - (interactive) - (let ((text (speedbar-line-text))) - (string-match "\\(\\S-+\\)" text) - (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) - (varnum (car var))) - (if (string-match "\\." (car var)) - (message-box "Can only delete a root expression") - (gdb-var-delete-1 var varnum))))) - -(defun gdb-var-delete-children (varnum) - "Delete children of variable object at point from the speedbar." - (gdb-input - (list (concat "-var-delete -c " varnum) 'ignore))) - -(defun gdb-edit-value (text token indent) - "Assign a value to a variable displayed in the speedbar." - (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) - (varnum (car var)) (value)) - (setq value (read-string "New value: ")) - (gdb-input - (list (concat "-var-assign " varnum " " value) - `(lambda () (gdb-edit-value-handler ,value)))))) - -(defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)") - -(defun gdb-edit-value-handler (value) - (goto-char (point-min)) - (if (re-search-forward gdb-error-regexp nil t) - (message-box "Invalid number or expression (%s)" value))) - -; Uses "-var-update --all-values". Needs GDB 6.4 onwards. -(defun gdb-var-update () - (if (not (gdb-pending-p 'gdb-var-update)) - (gdb-input - (list "-var-update --all-values *" 'gdb-var-update-handler))) - (gdb-add-pending 'gdb-var-update)) - -(defun gdb-var-update-handler () - (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist))) - (dolist (var gdb-var-list) - (setcar (nthcdr 5 var) nil)) - (let ((temp-var-list gdb-var-list)) - (dolist (change changelist) - (let* ((varnum (bindat-get-field change 'name)) - (var (assoc varnum gdb-var-list)) - (new-num (bindat-get-field change 'new_num_children))) - (when var - (let ((scope (bindat-get-field change 'in_scope)) - (has-more (bindat-get-field change 'has_more))) - (cond ((string-equal scope "false") - (if gdb-delete-out-of-scope - (gdb-var-delete-1 var varnum) - (setcar (nthcdr 5 var) 'out-of-scope))) - ((string-equal scope "true") - (setcar (nthcdr 6 var) has-more) - (when (and (or (not has-more) - (string-equal has-more "0")) - (not new-num) - (string-equal (nth 2 var) "0")) - (setcar (nthcdr 4 var) - (bindat-get-field change 'value)) - (setcar (nthcdr 5 var) 'changed))) - ((string-equal scope "invalid") - (gdb-var-delete-1 var varnum))))) - (let ((var-list nil) var1 - (children (bindat-get-field change 'new_children))) - (if new-num - (progn - (setq var1 (pop temp-var-list)) - (while var1 - (if (string-equal varnum (car var1)) - (let ((new (string-to-number new-num)) - (previous (string-to-number (nth 2 var1)))) - (setcar (nthcdr 2 var1) new-num) - (push var1 var-list) - (cond ((> new previous) - ;; Add new children to list. - (dotimes (dummy previous) - (push (pop temp-var-list) var-list)) - (dolist (child children) - (let ((varchild - (list (bindat-get-field child 'name) - (bindat-get-field child 'exp) - (bindat-get-field child 'numchild) - (bindat-get-field child 'type) - (bindat-get-field child 'value) - 'changed - (bindat-get-field child 'has_more)))) - (push varchild var-list)))) - ;; Remove deleted children from list. - ((< new previous) - (dotimes (dummy new) - (push (pop temp-var-list) var-list)) - (dotimes (dummy (- previous new)) - (pop temp-var-list))))) - (push var1 var-list)) - (setq var1 (pop temp-var-list))) - (setq gdb-var-list (nreverse var-list))))))))) - (setq gdb-pending-triggers - (delq 'gdb-var-update gdb-pending-triggers)) - (gdb-speedbar-update)) - -(defun gdb-speedbar-expand-node (text token indent) - "Expand the node the user clicked on. -TEXT is the text of the button we clicked on, a + or - item. -TOKEN is data related to this node. -INDENT is the current indentation depth." - (cond ((string-match "+" text) ;expand this node - (let* ((var (assoc token gdb-var-list)) - (expr (nth 1 var)) (children (nth 2 var))) - (if (or (<= (string-to-number children) gdb-max-children) - (y-or-n-p - (format "%s has %s children. Continue? " expr children))) - (gdb-var-list-children token)))) - ((string-match "-" text) ;contract this node - (dolist (var gdb-var-list) - (if (string-match (concat token "\\.") (car var)) - (setq gdb-var-list (delq var gdb-var-list)))) - (gdb-var-delete-children token) - (speedbar-change-expand-button-char ?+) - (speedbar-delete-subblock indent)) - (t (error "Ooops... not sure what to do"))) - (speedbar-center-buffer-smartly)) - -(defun gdb-get-target-string () - (with-current-buffer gud-comint-buffer - gud-target-name)) - - -;; -;; gdb buffers. -;; -;; Each buffer has a TYPE -- a symbol that identifies the function -;; of that particular buffer. -;; -;; The usual gdb interaction buffer is given the type `gdbmi' and -;; is constructed specially. -;; -;; Others are constructed by gdb-get-buffer-create and -;; named according to the rules set forth in the gdb-buffer-rules - -(defvar gdb-buffer-rules '()) - -(defun gdb-rules-name-maker (rules-entry) - (cadr rules-entry)) -(defun gdb-rules-buffer-mode (rules-entry) - (nth 2 rules-entry)) -(defun gdb-rules-update-trigger (rules-entry) - (nth 3 rules-entry)) - -(defun gdb-update-buffer-name () - "Rename current buffer according to name-maker associated with -it in `gdb-buffer-rules'." - (let ((f (gdb-rules-name-maker (assoc gdb-buffer-type - gdb-buffer-rules)))) - (when f (rename-buffer (funcall f))))) - -(defun gdb-current-buffer-rules () - "Get `gdb-buffer-rules' entry for current buffer type." - (assoc gdb-buffer-type gdb-buffer-rules)) - -(defun gdb-current-buffer-thread () - "Get thread object of current buffer from `gdb-threads-list'. - -When current buffer is not bound to any thread, return main -thread." - (cdr (assoc gdb-thread-number gdb-threads-list))) - -(defun gdb-current-buffer-frame () - "Get current stack frame object for thread of current buffer." - (bindat-get-field (gdb-current-buffer-thread) 'frame)) - -(defun gdb-buffer-type (buffer) - "Get value of `gdb-buffer-type' for BUFFER." - (with-current-buffer buffer - gdb-buffer-type)) - -(defun gdb-buffer-shows-main-thread-p () - "Return t if current GDB buffer shows main selected thread and -is not bound to it." - (current-buffer) - (not (local-variable-p 'gdb-thread-number))) - -(defun gdb-get-buffer (buffer-type &optional thread) - "Get a specific GDB buffer. - -In that buffer, `gdb-buffer-type' must be equal to BUFFER-TYPE -and `gdb-thread-number' (if provided) must be equal to THREAD." - (catch 'found - (dolist (buffer (buffer-list) nil) - (with-current-buffer buffer - (when (and (eq gdb-buffer-type buffer-type) - (or (not thread) - (equal gdb-thread-number thread))) - (throw 'found buffer)))))) - -(defun gdb-get-buffer-create (buffer-type &optional thread) - "Create a new GDB buffer of the type specified by BUFFER-TYPE. -The buffer-type should be one of the cars in `gdb-buffer-rules'. - -If THREAD is non-nil, it is assigned to `gdb-thread-number' -buffer-local variable of the new buffer. - -Buffer mode and name are selected according to buffer type. - -If buffer has trigger associated with it in `gdb-buffer-rules', -this trigger is subscribed to `gdb-buf-publisher' and called with -'update argument." - (or (gdb-get-buffer buffer-type thread) - (let ((rules (assoc buffer-type gdb-buffer-rules)) - (new (generate-new-buffer "limbo"))) - (with-current-buffer new - (let ((mode (gdb-rules-buffer-mode rules)) - (trigger (gdb-rules-update-trigger rules))) - (when mode (funcall mode)) - (setq gdb-buffer-type buffer-type) - (when thread - (set (make-local-variable 'gdb-thread-number) thread)) - (set (make-local-variable 'gud-minor-mode) - (buffer-local-value 'gud-minor-mode gud-comint-buffer)) - (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) - (rename-buffer (funcall (gdb-rules-name-maker rules))) - (when trigger - (gdb-add-subscriber gdb-buf-publisher - (cons (current-buffer) - (gdb-bind-function-to-buffer trigger (current-buffer)))) - (funcall trigger 'start)) - (current-buffer)))))) - -(defun gdb-bind-function-to-buffer (expr buffer) - "Return a function which will evaluate EXPR in BUFFER." - `(lambda (&rest args) - (with-current-buffer ,buffer - (apply ',expr args)))) - -;; Used to define all gdb-frame-*-buffer functions except -;; `gdb-frame-io-buffer' -(defmacro def-gdb-frame-for-buffer (name buffer &optional doc) - "Define a function NAME which shows gdb BUFFER in a separate frame. - -DOC is an optional documentation string." - `(defun ,name (&optional thread) - ,(when doc doc) - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create ,buffer thread))))) - -(defmacro def-gdb-display-buffer (name buffer &optional doc) - "Define a function NAME which shows gdb BUFFER. - -DOC is an optional documentation string." - `(defun ,name (&optional thread) - ,(when doc doc) - (interactive) - (gdb-display-buffer - (gdb-get-buffer-create ,buffer thread) t))) - -;; Used to display windows with thread-bound buffers -(defmacro def-gdb-preempt-display-buffer (name buffer &optional doc - split-horizontal) - `(defun ,name (&optional thread) - ,(when doc doc) - (message thread) - (gdb-preempt-existing-or-display-buffer - (gdb-get-buffer-create ,buffer thread) - ,split-horizontal))) - -;; This assoc maps buffer type symbols to rules. Each rule is a list of -;; at least one and possible more functions. The functions have these -;; roles in defining a buffer type: -;; -;; NAME - Return a name for this buffer type. -;; -;; The remaining function(s) are optional: -;; -;; MODE - called in a new buffer with no arguments, should establish -;; the proper mode for the buffer. -;; - -(defun gdb-set-buffer-rules (buffer-type &rest rules) - (let ((binding (assoc buffer-type gdb-buffer-rules))) - (if binding - (setcdr binding rules) - (push (cons buffer-type rules) - gdb-buffer-rules)))) - -(defun gdb-parent-mode () - "Generic mode to derive all other GDB buffer modes from." - (kill-all-local-variables) - (setq buffer-read-only t) - (buffer-disable-undo) - ;; Delete buffer from gdb-buf-publisher when it's killed - ;; (if it has an associated update trigger) - (add-hook - 'kill-buffer-hook - (function - (lambda () - (let ((trigger (gdb-rules-update-trigger - (gdb-current-buffer-rules)))) - (when trigger - (gdb-delete-subscriber - gdb-buf-publisher - ;; This should match gdb-add-subscriber done in - ;; gdb-get-buffer-create - (cons (current-buffer) - (gdb-bind-function-to-buffer trigger (current-buffer)))))))) - nil t)) - -;; Partial-output buffer : This accumulates output from a command executed on -;; behalf of emacs (rather than the user). -;; -(gdb-set-buffer-rules 'gdb-partial-output-buffer - 'gdb-partial-output-name) - -(defun gdb-partial-output-name () - (concat " *partial-output-" - (gdb-get-target-string) - "*")) - - -(gdb-set-buffer-rules 'gdb-inferior-io - 'gdb-inferior-io-name - 'gdb-inferior-io-mode) - -(defun gdb-inferior-io-name () - (concat "*input/output of " - (gdb-get-target-string) - "*")) - -(defun gdb-display-io-buffer () - "Display IO of debugged program in a separate window." - (interactive) - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-inferior-io) t)) - -(defconst gdb-frame-parameters - '((height . 14) (width . 80) - (unsplittable . t) - (tool-bar-lines . nil) - (menu-bar-lines . nil) - (minibuffer . nil))) - -(defun gdb-frame-io-buffer () - "Display IO of debugged program in a new frame." - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create 'gdb-inferior-io)))) - -(defvar gdb-inferior-io-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" 'gdb-io-interrupt) - (define-key map "\C-c\C-z" 'gdb-io-stop) - (define-key map "\C-c\C-\\" 'gdb-io-quit) - (define-key map "\C-c\C-d" 'gdb-io-eof) - (define-key map "\C-d" 'gdb-io-eof) - map)) - -;; We want to use comint because it has various nifty and familiar features. -(define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O" - "Major mode for gdb inferior-io. - -The following commands are available: -\\{gdb-inferior-io-mode-map}" - - :syntax-table nil :abbrev-table nil - -(make-comint-in-buffer "gdb-inferior" (current-buffer) nil)) - -(defun gdb-inferior-filter (proc string) - (unless (string-equal string "") - (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t)) - (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) - (comint-output-filter proc string))) - -(defun gdb-io-interrupt () - "Interrupt the program being debugged." - (interactive) - (interrupt-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) - -(defun gdb-io-quit () - "Send quit signal to the program being debugged." - (interactive) - (quit-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) - -(defun gdb-io-stop () - "Stop the program being debugged." - (interactive) - (stop-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) - -(defun gdb-io-eof () - "Send end-of-file to the program being debugged." - (interactive) - (process-send-eof - (get-buffer-process gud-comint-buffer))) - -(defun gdb-clear-inferior-io () - (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) - (erase-buffer))) - - -(defconst breakpoint-xpm-data - "/* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -\"10 10 2 1\", -\" c red\", -\"+ c None\", -/* pixels */ -\"+++ +++\", -\"++ ++\", -\"+ +\", -\" \", -\" \", -\" \", -\" \", -\"+ +\", -\"++ ++\", -\"+++ +++\", -};" - "XPM data used for breakpoint icon.") - -(defconst breakpoint-enabled-pbm-data - "P1 -10 10\", -0 0 0 0 1 1 1 1 0 0 0 0 -0 0 0 1 1 1 1 1 1 0 0 0 -0 0 1 1 1 1 1 1 1 1 0 0 -0 1 1 1 1 1 1 1 1 1 1 0 -0 1 1 1 1 1 1 1 1 1 1 0 -0 1 1 1 1 1 1 1 1 1 1 0 -0 1 1 1 1 1 1 1 1 1 1 0 -0 0 1 1 1 1 1 1 1 1 0 0 -0 0 0 1 1 1 1 1 1 0 0 0 -0 0 0 0 1 1 1 1 0 0 0 0" - "PBM data used for enabled breakpoint icon.") - -(defconst breakpoint-disabled-pbm-data - "P1 -10 10\", -0 0 1 0 1 0 1 0 0 0 -0 1 0 1 0 1 0 1 0 0 -1 0 1 0 1 0 1 0 1 0 -0 1 0 1 0 1 0 1 0 1 -1 0 1 0 1 0 1 0 1 0 -0 1 0 1 0 1 0 1 0 1 -1 0 1 0 1 0 1 0 1 0 -0 1 0 1 0 1 0 1 0 1 -0 0 1 0 1 0 1 0 1 0 -0 0 0 1 0 1 0 1 0 0" - "PBM data used for disabled breakpoint icon.") - -(defvar breakpoint-enabled-icon nil - "Icon for enabled breakpoint in display margin.") - -(defvar breakpoint-disabled-icon nil - "Icon for disabled breakpoint in display margin.") - -(declare-function define-fringe-bitmap "fringe.c" - (bitmap bits &optional height width align)) - -(and (display-images-p) - ;; Bitmap for breakpoint in fringe - (define-fringe-bitmap 'breakpoint - "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") - ;; Bitmap for gud-overlay-arrow in fringe - (define-fringe-bitmap 'hollow-right-triangle - "\xe0\x90\x88\x84\x84\x88\x90\xe0")) - -(defface breakpoint-enabled - '((t - :foreground "red1" - :weight bold)) - "Face for enabled breakpoint icon in fringe." - :group 'gdb) - -(defface breakpoint-disabled - '((((class color) (min-colors 88)) :foreground "grey70") - ;; Ensure that on low-color displays that we end up something visible. - (((class color) (min-colors 8) (background light)) - :foreground "black") - (((class color) (min-colors 8) (background dark)) - :foreground "white") - (((type tty) (class mono)) - :inverse-video t) - (t :background "gray")) - "Face for disabled breakpoint icon in fringe." - :group 'gdb) - - -(defun gdb-send (proc string) - "A comint send filter for gdb." - (with-current-buffer gud-comint-buffer - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(face)))) - ;; mimic <RET> key to repeat previous command in GDB - (if (not (string= "" string)) - (setq gdb-last-command string) - (if gdb-last-command (setq string gdb-last-command))) - (if gdb-enable-debug - (push (cons 'mi-send (concat string "\n")) gdb-debug-log)) - (if (string-match "^-" string) - ;; MI command - (progn - (setq gdb-first-done-or-error t) - (process-send-string proc (concat string "\n"))) - ;; CLI command - (if (string-match "\\\\$" string) - (setq gdb-continuation (concat gdb-continuation string "\n")) - (setq gdb-first-done-or-error t) - (process-send-string proc (concat "-interpreter-exec console \"" - gdb-continuation string "\"\n")) - (setq gdb-continuation nil)))) - -(defun gdb-input (item) - (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log)) - (setq gdb-token-number (1+ gdb-token-number)) - (setcar item (concat (number-to-string gdb-token-number) (car item))) - (push (cons gdb-token-number (car (cdr item))) gdb-handler-alist) - (process-send-string (get-buffer-process gud-comint-buffer) - (concat (car item) "\n"))) - -;; NOFRAME is used for gud execution control commands -(defun gdb-current-context-command (command) - "Add --thread to gdb COMMAND when needed." - (if (and gdb-thread-number - (string-equal gdb-version "7.0+")) - (concat command " --thread " gdb-thread-number) - command)) - -(defun gdb-current-context-buffer-name (name) - "Add thread information and asterisks to string NAME. - -If `gdb-thread-number' is nil, just wrap NAME in asterisks." - (concat "*" name - (if (local-variable-p 'gdb-thread-number) - (format " (bound to thread %s)" gdb-thread-number) - "") - "*")) - -(defun gdb-current-context-mode-name (mode) - "Add thread information to MODE which is to be used as -`mode-name'." - (concat mode - (if gdb-thread-number - (format " [thread %s]" gdb-thread-number) - ""))) - - -(defcustom gud-gdb-command-name "gdb -i=mi" - "Default command to execute an executable under the GDB debugger." - :type 'string - :group 'gdb) - -(defun gdb-resync() - (setq gud-running nil) - (setq gdb-output-sink 'user) - (setq gdb-pending-triggers nil)) - -(defun gdb-update () - "Update buffers showing status of debug session." - (when gdb-first-prompt - (gdb-force-mode-line-update - (propertize "initializing..." 'face font-lock-variable-name-face)) - (gdb-init-1) - (setq gdb-first-prompt nil)) - - (gdb-get-main-selected-frame) - ;; We may need to update gdb-threads-list so we can use - (gdb-get-buffer-create 'gdb-threads-buffer) - ;; gdb-break-list is maintained in breakpoints handler - (gdb-get-buffer-create 'gdb-breakpoints-buffer) - - (gdb-emit-signal gdb-buf-publisher 'update) - - (gdb-get-changed-registers) - - (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) - (dolist (var gdb-var-list) - (setcar (nthcdr 5 var) nil)) - (gdb-var-update))) - -;; gdb-setq-thread-number and gdb-update-gud-running are decoupled -;; because we may need to update current gud-running value without -;; changing current thread (see gdb-running) -(defun gdb-setq-thread-number (number) - "Only this function must be used to change `gdb-thread-number' -value to NUMBER, because `gud-running' and `gdb-frame-number' -need to be updated appropriately when current thread changes." - ;; GDB 6.8 and earlier always output thread-id="0" when stopping. - (unless (string-equal number "0") (setq gdb-thread-number number)) - (setq gdb-frame-number "0") - (gdb-update-gud-running)) - -(defun gdb-update-gud-running () - "Set `gud-running' according to the state of current thread. - -`gdb-frame-number' is set to 0 if current thread is now stopped. - -Note that when `gdb-gud-control-all-threads' is t, `gud-running' -cannot be reliably used to determine whether or not execution -control buttons should be shown in menu or toolbar. Use -`gdb-running-threads-count' and `gdb-stopped-threads-count' -instead. - -For all-stop mode, thread information is unavailable while target -is running." - (let ((old-value gud-running)) - (setq gud-running - (string= (bindat-get-field (gdb-current-buffer-thread) 'state) - "running")) - ;; Set frame number to "0" when _current_ threads stops - (when (and (gdb-current-buffer-thread) - (not (eq gud-running old-value))) - (setq gdb-frame-number "0")))) - -(defun gdb-show-run-p () - "Return t if \"Run/continue\" should be shown on the toolbar." - (or (not gdb-active-process) - (and (or - (not gdb-gud-control-all-threads) - (not gdb-non-stop)) - (not gud-running)) - (and gdb-gud-control-all-threads - (> gdb-stopped-threads-count 0)))) - -(defun gdb-show-stop-p () - "Return t if \"Stop\" should be shown on the toolbar." - (or (and (or - (not gdb-gud-control-all-threads) - (not gdb-non-stop)) - gud-running) - (and gdb-gud-control-all-threads - (> gdb-running-threads-count 0)))) - -;; GUD displays the selected GDB frame. This might might not be the current -;; GDB frame (after up, down etc). If no GDB frame is visible but the last -;; visited breakpoint is, use that window. -(defun gdb-display-source-buffer (buffer) - (let* ((last-window (if gud-last-last-frame - (get-buffer-window - (gud-find-file (car gud-last-last-frame))))) - (source-window (or last-window - (if (and gdb-source-window - (window-live-p gdb-source-window)) - gdb-source-window)))) - (when source-window - (setq gdb-source-window source-window) - (set-window-buffer source-window buffer)) - source-window)) - -(defun gdb-car< (a b) - (< (car a) (car b))) - -(defvar gdbmi-record-list - '((gdb-gdb . "(gdb) \n") - (gdb-done . "\\([0-9]*\\)\\^done,?\\(.*?\\)\n") - (gdb-starting . "\\([0-9]*\\)\\^running\n") - (gdb-error . "\\([0-9]*\\)\\^error,\\(.*?\\)\n") - (gdb-console . "~\\(\".*?\"\\)\n") - (gdb-internals . "&\\(\".*?\"\\)\n") - (gdb-stopped . "\\*stopped,?\\(.*?\\)\n") - (gdb-running . "\\*running,\\(.*?\n\\)") - (gdb-thread-created . "=thread-created,\\(.*?\n\\)") - (gdb-thread-selected . "=thread-selected,\\(.*?\\)\n") - (gdb-thread-exited . "=thread-exited,\\(.*?\n\\)") - (gdb-ignored-notification . "=[-[:alpha:]]+,?\\(.*?\\)\n") - (gdb-shell . "\\(\\(?:^.+\n\\)+\\)"))) - -(defun gud-gdbmi-marker-filter (string) - "Filter GDB/MI output." - - ;; Record transactions if logging is enabled. - (when gdb-enable-debug - (push (cons 'recv string) gdb-debug-log) - (if (and gdb-debug-log-max - (> (length gdb-debug-log) gdb-debug-log-max)) - (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil))) - - ;; Recall the left over gud-marker-acc from last time - (setq gud-marker-acc (concat gud-marker-acc string)) - - ;; Start accumulating output for the GUD buffer - (setq gdb-filter-output "") - (let ((output-record) (output-record-list)) - - ;; Process all the complete markers in this chunk. - (dolist (gdbmi-record gdbmi-record-list) - (while (string-match (cdr gdbmi-record) gud-marker-acc) - (push (list (match-beginning 0) - (car gdbmi-record) - (match-string 1 gud-marker-acc) - (match-string 2 gud-marker-acc) - (match-end 0)) - output-record-list) - (setq gud-marker-acc - (concat (substring gud-marker-acc 0 (match-beginning 0)) - ;; Pad with spaces to preserve position. - (make-string (length (match-string 0 gud-marker-acc)) 32) - (substring gud-marker-acc (match-end 0)))))) - - (setq output-record-list (sort output-record-list 'gdb-car<)) - - (dolist (output-record output-record-list) - (let ((record-type (cadr output-record)) - (arg1 (nth 2 output-record)) - (arg2 (nth 3 output-record))) - (if (eq record-type 'gdb-error) - (gdb-done-or-error arg2 arg1 'error) - (if (eq record-type 'gdb-done) - (gdb-done-or-error arg2 arg1 'done) - ;; Suppress "No registers." since GDB 6.8 and earlier duplicates MI - ;; error message on internal stream. Don't print to GUD buffer. - (unless (and (eq record-type 'gdb-internals) - (string-equal (read arg1) "No registers.\n")) - (funcall record-type arg1)))))) - - (setq gdb-output-sink 'user) - ;; Remove padding. - (string-match "^ *" gud-marker-acc) - (setq gud-marker-acc (substring gud-marker-acc (match-end 0))) - - gdb-filter-output)) - -(defun gdb-gdb (output-field)) - -(defun gdb-shell (output-field) - (let ((gdb-output-sink gdb-output-sink)) - (setq gdb-filter-output - (concat output-field gdb-filter-output)))) - -(defun gdb-ignored-notification (output-field)) - -;; gdb-invalidate-threads is defined to accept 'update-threads signal -(defun gdb-thread-created (output-field)) -(defun gdb-thread-exited (output-field) - "Handle =thread-exited async record: unset `gdb-thread-number' - if current thread exited and update threads list." - (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'id))) - (if (string= gdb-thread-number thread-id) - (gdb-setq-thread-number nil)) - ;; When we continue current thread and it quickly exits, - ;; gdb-pending-triggers left after gdb-running disallow us to - ;; properly call -thread-info without --thread option. Thus we - ;; need to use gdb-wait-for-pending. - (gdb-wait-for-pending - (gdb-emit-signal gdb-buf-publisher 'update-threads)))) - -(defun gdb-thread-selected (output-field) - "Handler for =thread-selected MI output record. - -Sets `gdb-thread-number' to new id." - (let* ((result (gdb-json-string output-field)) - (thread-id (bindat-get-field result 'id))) - (gdb-setq-thread-number thread-id) - ;; Typing `thread N` in GUD buffer makes GDB emit `^done` followed - ;; by `=thread-selected` notification. `^done` causes `gdb-update` - ;; as usually. Things happen to fast and second call (from - ;; gdb-thread-selected handler) gets cut off by our beloved - ;; gdb-pending-triggers. - ;; Solution is `gdb-wait-for-pending` macro: it guarantees that its - ;; body will get executed when `gdb-pending-triggers` is empty. - (gdb-wait-for-pending - (gdb-update)))) - -(defun gdb-running (output-field) - (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'thread-id))) - ;; We reset gdb-frame-number to nil if current thread has gone - ;; running. This can't be done in gdb-thread-list-handler-custom - ;; because we need correct gdb-frame-number by the time - ;; -thread-info command is sent. - (when (or (string-equal thread-id "all") - (string-equal thread-id gdb-thread-number)) - (setq gdb-frame-number nil))) - (setq gdb-inferior-status "running") - (gdb-force-mode-line-update - (propertize gdb-inferior-status 'face font-lock-type-face)) - (when (not gdb-non-stop) - (setq gud-running t)) - (setq gdb-active-process t) - (gdb-emit-signal gdb-buf-publisher 'update-threads)) - -(defun gdb-starting (output-field) - ;; CLI commands don't emit ^running at the moment so use gdb-running too. - (setq gdb-inferior-status "running") - (gdb-force-mode-line-update - (propertize gdb-inferior-status 'face font-lock-type-face)) - (setq gdb-active-process t) - (setq gud-running t) - ;; GDB doesn't seem to respond to -thread-info before first stop or - ;; thread exit (even in non-stop mode), so this is useless. - ;; Behaviour may change in the future. - (gdb-emit-signal gdb-buf-publisher 'update-threads)) - -;; -break-insert -t didn't give a reason before gdb 6.9 - -(defun gdb-stopped (output-field) - "Given the contents of *stopped MI async record, select new -current thread and update GDB buffers." - ;; Reason is available with target-async only - (let* ((result (gdb-json-string output-field)) - (reason (bindat-get-field result 'reason)) - (thread-id (bindat-get-field result 'thread-id))) - - ;; -data-list-register-names needs to be issued for any stopped - ;; thread - (when (not gdb-register-names) - (gdb-input - (list (concat "-data-list-register-names" - (if (string-equal gdb-version "7.0+") - (concat" --thread " thread-id))) - 'gdb-register-names-handler))) - -;;; Don't set gud-last-frame here as it's currently done in gdb-frame-handler -;;; because synchronous GDB doesn't give these fields with CLI. -;;; (when file -;;; (setq -;;; ;; Extract the frame position from the marker. -;;; gud-last-frame (cons file -;;; (string-to-number -;;; (match-string 6 gud-marker-acc))))) - - (setq gdb-inferior-status (or reason "unknown")) - (gdb-force-mode-line-update - (propertize gdb-inferior-status 'face font-lock-warning-face)) - (if (string-equal reason "exited-normally") - (setq gdb-active-process nil)) - - ;; Select new current thread. - - ;; Don't switch if we have no reasons selected - (when gdb-switch-reasons - ;; Switch from another stopped thread only if we have - ;; gdb-switch-when-another-stopped: - (when (or gdb-switch-when-another-stopped - (not (string= "stopped" - (bindat-get-field (gdb-current-buffer-thread) 'state)))) - ;; Switch if current reason has been selected or we have no - ;; reasons - (if (or (eq gdb-switch-reasons t) - (member reason gdb-switch-reasons)) - (when (not (string-equal gdb-thread-number thread-id)) - (message (concat "Switched to thread " thread-id)) - (gdb-setq-thread-number thread-id)) - (message (format "Thread %s stopped" thread-id))))) - - ;; Print "(gdb)" to GUD console - (when gdb-first-done-or-error - (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) - - ;; In non-stop, we update information as soon as another thread gets - ;; stopped - (when (or gdb-first-done-or-error - gdb-non-stop) - ;; In all-stop this updates gud-running properly as well. - (gdb-update) - (setq gdb-first-done-or-error nil)) - (run-hook-with-args 'gdb-stopped-hooks result))) - -;; Remove the trimmings from log stream containing debugging messages -;; being produced by GDB's internals, use warning face and send to GUD -;; buffer. -(defun gdb-internals (output-field) - (setq gdb-filter-output - (gdb-concat-output - gdb-filter-output - (let ((error-message - (read output-field))) - (put-text-property - 0 (length error-message) - 'face font-lock-warning-face - error-message) - error-message)))) - -;; Remove the trimmings from the console stream and send to GUD buffer -;; (frontend MI commands should not print to this stream) -(defun gdb-console (output-field) - (setq gdb-filter-output - (gdb-concat-output - gdb-filter-output - (read output-field)))) - -(defun gdb-done-or-error (output-field token-number type) - (if (string-equal token-number "") - ;; Output from command entered by user - (progn - (setq gdb-output-sink 'user) - (setq token-number nil) - ;; MI error - send to minibuffer - (when (eq type 'error) - ;; Skip "msg=" from `output-field' - (message (read (substring output-field 4))) - ;; Don't send to the console twice. (If it is a console error - ;; it is also in the console stream.) - (setq output-field nil))) - ;; Output from command from frontend. - (setq gdb-output-sink 'emacs)) - - (gdb-clear-partial-output) - (when gdb-first-done-or-error - (unless (or token-number gud-running) - (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) - (gdb-update) - (setq gdb-first-done-or-error nil)) - - (setq gdb-filter-output - (gdb-concat-output gdb-filter-output output-field)) - - (if token-number - (progn - (with-current-buffer - (gdb-get-buffer-create 'gdb-partial-output-buffer) - (funcall - (cdr (assoc (string-to-number token-number) gdb-handler-alist)))) - (setq gdb-handler-alist - (assq-delete-all token-number gdb-handler-alist))))) - -(defun gdb-concat-output (so-far new) - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'user) (concat so-far new)) - ((eq sink 'emacs) - (gdb-append-to-partial-output new) - so-far)))) - -(defun gdb-append-to-partial-output (string) - (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (goto-char (point-max)) - (insert string))) - -(defun gdb-clear-partial-output () - (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (erase-buffer))) - -(defun gdb-jsonify-buffer (&optional fix-key fix-list) - "Prepare GDB/MI output in current buffer for parsing with `json-read'. - -Field names are wrapped in double quotes and equal signs are -replaced with semicolons. - -If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurences from -partial output. This is used to get rid of useless keys in lists -in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and --break-info are examples of MI commands which issue such -responses. - -If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with -\"FIX-LIST=[..]\" prior to parsing. This is used to fix broken --break-info output when it contains breakpoint script field -incompatible with GDB/MI output syntax." - (save-excursion - (goto-char (point-min)) - (when fix-key - (save-excursion - (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t) - (replace-match "" nil nil nil 1)))) - (when fix-list - (save-excursion - ;; Find positions of braces which enclose broken list - (while (re-search-forward (concat fix-list "={\"") nil t) - (let ((p1 (goto-char (- (point) 2))) - (p2 (progn (forward-sexp) - (1- (point))))) - ;; Replace braces with brackets - (save-excursion - (goto-char p1) - (delete-char 1) - (insert "[") - (goto-char p2) - (delete-char 1) - (insert "]")))))) - (goto-char (point-min)) - (insert "{") - (while (re-search-forward - "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t) - (replace-match "\"\\1\":\\2" nil nil)) - (goto-char (point-max)) - (insert "}"))) - -(defun gdb-json-read-buffer (&optional fix-key fix-list) - "Prepare and parse GDB/MI output in current buffer with `json-read'. - -FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." - (gdb-jsonify-buffer fix-key fix-list) - (save-excursion - (goto-char (point-min)) - (let ((json-array-type 'list)) - (json-read)))) - -(defun gdb-json-string (string &optional fix-key fix-list) - "Prepare and parse STRING containing GDB/MI output with `json-read'. - -FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." - (with-temp-buffer - (insert string) - (gdb-json-read-buffer fix-key fix-list))) - -(defun gdb-json-partial-output (&optional fix-key fix-list) - "Prepare and parse gdb-partial-output-buffer with `json-read'. - -FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'." - (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (gdb-json-read-buffer fix-key fix-list))) - -(defun gdb-line-posns (line) - "Return a pair of LINE beginning and end positions." - (let ((offset (1+ (- line (line-number-at-pos))))) - (cons - (line-beginning-position offset) - (line-end-position offset)))) - -(defmacro gdb-mark-line (line variable) - "Set VARIABLE marker to point at beginning of LINE. - -If current window has no fringes, inverse colors on LINE. - -Return position where LINE begins." - `(save-excursion - (let* ((posns (gdb-line-posns ,line)) - (start-posn (car posns)) - (end-posn (cdr posns))) - (set-marker ,variable (copy-marker start-posn)) - (when (not (> (car (window-fringes)) 0)) - (put-text-property start-posn end-posn - 'font-lock-face '(:inverse-video t))) - start-posn))) - -(defun gdb-pad-string (string padding) - (format (concat "%" (number-to-string padding) "s") string)) - -;; gdb-table struct is a way to programmatically construct simple -;; tables. It help to reliably align columns of data in GDB buffers -;; and provides -(defstruct - gdb-table - (column-sizes nil) - (rows nil) - (row-properties nil) - (right-align nil)) - -(defun gdb-mapcar* (function &rest seqs) - "Apply FUNCTION to each element of SEQS, and make a list of the results. -If there are several SEQS, FUNCTION is called with that many -arugments, and mapping stops as sson as the shortest list runs -out." - (let ((shortest (apply #'min (mapcar #'length seqs)))) - (mapcar (lambda (i) - (apply function - (mapcar - (lambda (seq) - (nth i seq)) - seqs))) - (number-sequence 0 (1- shortest))))) - -(defun gdb-table-add-row (table row &optional properties) - "Add ROW of string to TABLE and recalculate column sizes. - -When non-nil, PROPERTIES will be added to the whole row when -calling `gdb-table-string'." - (let ((rows (gdb-table-rows table)) - (row-properties (gdb-table-row-properties table)) - (column-sizes (gdb-table-column-sizes table)) - (right-align (gdb-table-right-align table))) - (when (not column-sizes) - (setf (gdb-table-column-sizes table) - (make-list (length row) 0))) - (setf (gdb-table-rows table) - (append rows (list row))) - (setf (gdb-table-row-properties table) - (append row-properties (list properties))) - (setf (gdb-table-column-sizes table) - (gdb-mapcar* (lambda (x s) - (let ((new-x - (max (abs x) (string-width (or s ""))))) - (if right-align new-x (- new-x)))) - (gdb-table-column-sizes table) - row)) - ;; Avoid trailing whitespace at eol - (if (not (gdb-table-right-align table)) - (setcar (last (gdb-table-column-sizes table)) 0)))) - -(defun gdb-table-string (table &optional sep) - "Return TABLE as a string with columns separated with SEP." - (let ((column-sizes (gdb-table-column-sizes table)) - (res "")) - (mapconcat - 'identity - (gdb-mapcar* - (lambda (row properties) - (apply 'propertize - (mapconcat 'identity - (gdb-mapcar* (lambda (s x) (gdb-pad-string s x)) - row column-sizes) - sep) - properties)) - (gdb-table-rows table) - (gdb-table-row-properties table)) - "\n"))) - -;; bindat-get-field goes deep, gdb-get-many-fields goes wide -(defun gdb-get-many-fields (struct &rest fields) - "Return a list of FIELDS values from STRUCT." - (let ((values)) - (dolist (field fields values) - (setq values (append values (list (bindat-get-field struct field))))))) - -(defmacro def-gdb-auto-update-trigger (trigger-name gdb-command - handler-name - &optional signal-list) - "Define a trigger TRIGGER-NAME which sends GDB-COMMAND and sets -HANDLER-NAME as its handler. HANDLER-NAME is bound to current -buffer with `gdb-bind-function-to-buffer'. - -If SIGNAL-LIST is non-nil, GDB-COMMAND is sent only when the -defined trigger is called with an argument from SIGNAL-LIST. It's -not recommended to define triggers with empty SIGNAL-LIST. -Normally triggers should respond at least to 'update signal. - -Normally the trigger defined by this command must be called from -the buffer where HANDLER-NAME must work. This should be done so -that buffer-local thread number may be used in GDB-COMMAND (by -calling `gdb-current-context-command'). -`gdb-bind-function-to-buffer' is used to achieve this, see -`gdb-get-buffer-create'. - -Triggers defined by this command are meant to be used as a -trigger argument when describing buffer types with -`gdb-set-buffer-rules'." - `(defun ,trigger-name (&optional signal) - (when - (or (not ,signal-list) - (memq signal ,signal-list)) - (when (not (gdb-pending-p - (cons (current-buffer) ',trigger-name))) - (gdb-input - (list ,gdb-command - (gdb-bind-function-to-buffer ',handler-name (current-buffer)))) - (gdb-add-pending (cons (current-buffer) ',trigger-name)))))) - -;; Used by disassembly buffer only, the rest use -;; def-gdb-trigger-and-handler -(defmacro def-gdb-auto-update-handler (handler-name trigger-name custom-defun - &optional nopreserve) - "Define a handler HANDLER-NAME for TRIGGER-NAME with CUSTOM-DEFUN. - -Handlers are normally called from the buffers they put output in. - -Delete ((current-buffer) . TRIGGER-NAME) from -`gdb-pending-triggers', erase current buffer and evaluate -CUSTOM-DEFUN. Then `gdb-update-buffer-name' is called. - -If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN." - `(defun ,handler-name () - (gdb-delete-pending (cons (current-buffer) ',trigger-name)) - (let* ((buffer-read-only nil) - (window (get-buffer-window (current-buffer) 0)) - (start (window-start window)) - (p (window-point window))) - (erase-buffer) - (,custom-defun) - (gdb-update-buffer-name) - ,(when (not nopreserve) - '(set-window-start window start) - '(set-window-point window p))))) - -(defmacro def-gdb-trigger-and-handler (trigger-name gdb-command - handler-name custom-defun - &optional signal-list) - "Define trigger and handler. - -TRIGGER-NAME trigger is defined to send GDB-COMMAND. See -`def-gdb-auto-update-trigger'. - -HANDLER-NAME handler uses customization of CUSTOM-DEFUN. See -`def-gdb-auto-update-handler'." - `(progn - (def-gdb-auto-update-trigger ,trigger-name - ,gdb-command - ,handler-name ,signal-list) - (def-gdb-auto-update-handler ,handler-name - ,trigger-name ,custom-defun))) - - - -;; Breakpoint buffer : This displays the output of `-break-list'. -(def-gdb-trigger-and-handler - gdb-invalidate-breakpoints "-break-list" - gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom - '(start update)) - -(gdb-set-buffer-rules - 'gdb-breakpoints-buffer - 'gdb-breakpoints-buffer-name - 'gdb-breakpoints-mode - 'gdb-invalidate-breakpoints) - -(defun gdb-breakpoints-list-handler-custom () - (let ((breakpoints-list (bindat-get-field - (gdb-json-partial-output "bkpt" "script") - 'BreakpointTable 'body)) - (table (make-gdb-table))) - (setq gdb-breakpoints-list nil) - (gdb-table-add-row table '("Num" "Type" "Disp" "Enb" "Addr" "Hits" "What")) - (dolist (breakpoint breakpoints-list) - (add-to-list 'gdb-breakpoints-list - (cons (bindat-get-field breakpoint 'number) - breakpoint)) - (let ((at (bindat-get-field breakpoint 'at)) - (pending (bindat-get-field breakpoint 'pending)) - (func (bindat-get-field breakpoint 'func)) - (type (bindat-get-field breakpoint 'type))) - (gdb-table-add-row table - (list - (bindat-get-field breakpoint 'number) - type - (bindat-get-field breakpoint 'disp) - (let ((flag (bindat-get-field breakpoint 'enabled))) - (if (string-equal flag "y") - (propertize "y" 'font-lock-face font-lock-warning-face) - (propertize "n" 'font-lock-face font-lock-comment-face))) - (bindat-get-field breakpoint 'addr) - (bindat-get-field breakpoint 'times) - (if (string-match ".*watchpoint" type) - (bindat-get-field breakpoint 'what) - (or pending at - (concat "in " - (propertize func 'font-lock-face font-lock-function-name-face) - (gdb-frame-location breakpoint))))) - ;; Add clickable properties only for breakpoints with file:line - ;; information - (append (list 'gdb-breakpoint breakpoint) - (when func '(help-echo "mouse-2, RET: visit breakpoint" - mouse-face highlight)))))) - (insert (gdb-table-string table " ")) - (gdb-place-breakpoints))) - -;; Put breakpoint icons in relevant margins (even those set in the GUD buffer). -(defun gdb-place-breakpoints () - (let ((flag) (bptno)) - ;; Remove all breakpoint-icons in source buffers but not assembler buffer. - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (if (and (eq gud-minor-mode 'gdbmi) - (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name)))) - (gdb-remove-breakpoint-icons (point-min) (point-max))))) - (dolist (breakpoint gdb-breakpoints-list) - (let* ((breakpoint (cdr breakpoint)) ; gdb-breakpoints-list is - ; an associative list - (line (bindat-get-field breakpoint 'line))) - (when line - (let ((file (bindat-get-field breakpoint 'fullname)) - (flag (bindat-get-field breakpoint 'enabled)) - (bptno (bindat-get-field breakpoint 'number))) - (unless (file-exists-p file) - (setq file (cdr (assoc bptno gdb-location-alist)))) - (if (and file - (not (string-equal file "File not found"))) - (with-current-buffer - (find-file-noselect file 'nowarn) - (gdb-init-buffer) - ;; Only want one breakpoint icon at each location. - (gdb-put-breakpoint-icon (string-equal flag "y") bptno - (string-to-number line))) - (gdb-input - (list (concat "list " file ":1") - 'ignore)) - (gdb-input - (list "-file-list-exec-source-file" - `(lambda () (gdb-get-location - ,bptno ,line ,flag))))))))))) - -(defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"") - -(defun gdb-get-location (bptno line flag) - "Find the directory containing the relevant source file. -Put in buffer and place breakpoint icon." - (goto-char (point-min)) - (catch 'file-not-found - (if (re-search-forward gdb-source-file-regexp nil t) - (delete (cons bptno "File not found") gdb-location-alist) - (push (cons bptno (match-string 1)) gdb-location-alist) - (gdb-resync) - (unless (assoc bptno gdb-location-alist) - (push (cons bptno "File not found") gdb-location-alist) - (message-box "Cannot find source file for breakpoint location. -Add directory to search path for source files using the GDB command, dir.")) - (throw 'file-not-found nil)) - (with-current-buffer (find-file-noselect (match-string 1)) - (gdb-init-buffer) - ;; only want one breakpoint icon at each location - (gdb-put-breakpoint-icon (eq flag ?y) bptno (string-to-number line))))) - -(add-hook 'find-file-hook 'gdb-find-file-hook) - -(defun gdb-find-file-hook () - "Set up buffer for debugging if file is part of the source code -of the current session." - (if (and (buffer-name gud-comint-buffer) - ;; in case gud or gdb-ui is just loaded - gud-comint-buffer - (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - 'gdbmi)) - (if (member buffer-file-name gdb-source-file-list) - (with-current-buffer (find-buffer-visiting buffer-file-name) - (gdb-init-buffer))))) - -(declare-function gud-remove "gdb-mi" t t) ; gud-def -(declare-function gud-break "gdb-mi" t t) ; gud-def -(declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window)) - -(defun gdb-mouse-set-clear-breakpoint (event) - "Set/clear breakpoint in left fringe/margin at mouse click. -If not in a source or disassembly buffer just set point." - (interactive "e") - (mouse-minibuffer-check event) - (let ((posn (event-end event))) - (with-selected-window (posn-window posn) - (if (or (buffer-file-name) (eq major-mode 'gdb-disassembly-mode)) - (if (numberp (posn-point posn)) - (save-excursion - (goto-char (posn-point posn)) - (if (or (posn-object posn) - (eq (car (fringe-bitmaps-at-pos (posn-point posn))) - 'breakpoint)) - (gud-remove nil) - (gud-break nil))))) - (posn-set-point posn)))) - -(defun gdb-mouse-toggle-breakpoint-margin (event) - "Enable/disable breakpoint in left margin with mouse click." - (interactive "e") - (mouse-minibuffer-check event) - (let ((posn (event-end event))) - (if (numberp (posn-point posn)) - (with-selected-window (posn-window posn) - (save-excursion - (goto-char (posn-point posn)) - (if (posn-object posn) - (gud-basic-call - (let ((bptno (get-text-property - 0 'gdb-bptno (car (posn-string posn))))) - (concat - (if (get-text-property - 0 'gdb-enabled (car (posn-string posn))) - "-break-disable " - "-break-enable ") - bptno))))))))) - -(defun gdb-mouse-toggle-breakpoint-fringe (event) - "Enable/disable breakpoint in left fringe with mouse click." - (interactive "e") - (mouse-minibuffer-check event) - (let* ((posn (event-end event)) - (pos (posn-point posn)) - obj) - (when (numberp pos) - (with-selected-window (posn-window posn) - (with-current-buffer (window-buffer (selected-window)) - (goto-char pos) - (dolist (overlay (overlays-in pos pos)) - (when (overlay-get overlay 'put-break) - (setq obj (overlay-get overlay 'before-string)))) - (when (stringp obj) - (gud-basic-call - (concat - (if (get-text-property 0 'gdb-enabled obj) - "-break-disable " - "-break-enable ") - (get-text-property 0 'gdb-bptno obj))))))))) - -(defun gdb-breakpoints-buffer-name () - (concat "*breakpoints of " (gdb-get-target-string) "*")) - -(def-gdb-display-buffer - gdb-display-breakpoints-buffer - 'gdb-breakpoints-buffer - "Display status of user-settable breakpoints.") - -(def-gdb-frame-for-buffer - gdb-frame-breakpoints-buffer - 'gdb-breakpoints-buffer - "Display status of user-settable breakpoints in a new frame.") - -(defvar gdb-breakpoints-mode-map - (let ((map (make-sparse-keymap)) - (menu (make-sparse-keymap "Breakpoints"))) - (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window)) - (define-key menu [goto] '("Goto" . gdb-goto-breakpoint)) - (define-key menu [delete] '("Delete" . gdb-delete-breakpoint)) - (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint)) - (suppress-keymap map) - (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu)) - (define-key map " " 'gdb-toggle-breakpoint) - (define-key map "D" 'gdb-delete-breakpoint) - ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons. - (define-key map "q" 'gdb-delete-frame-or-window) - (define-key map "\r" 'gdb-goto-breakpoint) - (define-key map "\t" '(lambda () - (interactive) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-threads-buffer) t))) - (define-key map [mouse-2] 'gdb-goto-breakpoint) - (define-key map [follow-link] 'mouse-face) - map)) - -(defun gdb-delete-frame-or-window () - "Delete frame if there is only one window. Otherwise delete the window." - (interactive) - (if (one-window-p) (delete-frame) - (delete-window))) - -;;from make-mode-line-mouse-map -(defun gdb-make-header-line-mouse-map (mouse function) "\ -Return a keymap with single entry for mouse key MOUSE on the header line. -MOUSE is defined to run function FUNCTION with no args in the buffer -corresponding to the mode line clicked." - (let ((map (make-sparse-keymap))) - (define-key map (vector 'header-line mouse) function) - (define-key map (vector 'header-line 'down-mouse-1) 'ignore) - map)) - -(defmacro gdb-propertize-header (name buffer help-echo mouse-face face) - `(propertize ,name - 'help-echo ,help-echo - 'mouse-face ',mouse-face - 'face ',face - 'local-map - (gdb-make-header-line-mouse-map - 'mouse-1 - (lambda (event) (interactive "e") - (save-selected-window - (select-window (posn-window (event-start event))) - (gdb-set-window-buffer - (gdb-get-buffer-create ',buffer) t) ))))) - - -;; uses "-thread-info". Needs GDB 7.0 onwards. -;;; Threads view - -(defun gdb-threads-buffer-name () - (concat "*threads of " (gdb-get-target-string) "*")) - -(def-gdb-display-buffer - gdb-display-threads-buffer - 'gdb-threads-buffer - "Display GDB threads.") - -(def-gdb-frame-for-buffer - gdb-frame-threads-buffer - 'gdb-threads-buffer - "Display GDB threads in a new frame.") - -(def-gdb-trigger-and-handler - gdb-invalidate-threads (gdb-current-context-command "-thread-info") - gdb-thread-list-handler gdb-thread-list-handler-custom - '(start update update-threads)) - -(gdb-set-buffer-rules - 'gdb-threads-buffer - 'gdb-threads-buffer-name - 'gdb-threads-mode - 'gdb-invalidate-threads) - -(defvar gdb-threads-font-lock-keywords - '(("in \\([^ ]+\\)" (1 font-lock-function-name-face)) - (" \\(stopped\\)" (1 font-lock-warning-face)) - (" \\(running\\)" (1 font-lock-string-face)) - ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face))) - "Font lock keywords used in `gdb-threads-mode'.") - -(defvar gdb-threads-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'gdb-select-thread) - (define-key map "f" 'gdb-display-stack-for-thread) - (define-key map "F" 'gdb-frame-stack-for-thread) - (define-key map "l" 'gdb-display-locals-for-thread) - (define-key map "L" 'gdb-frame-locals-for-thread) - (define-key map "r" 'gdb-display-registers-for-thread) - (define-key map "R" 'gdb-frame-registers-for-thread) - (define-key map "d" 'gdb-display-disassembly-for-thread) - (define-key map "D" 'gdb-frame-disassembly-for-thread) - (define-key map "i" 'gdb-interrupt-thread) - (define-key map "c" 'gdb-continue-thread) - (define-key map "s" 'gdb-step-thread) - (define-key map "\t" '(lambda () - (interactive) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-breakpoints-buffer) t))) - (define-key map [mouse-2] 'gdb-select-thread) - (define-key map [follow-link] 'mouse-face) - map)) - -(defvar gdb-threads-header - (list - (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive) - " " - (gdb-propertize-header "Threads" gdb-threads-buffer - nil nil mode-line))) - -(define-derived-mode gdb-threads-mode gdb-parent-mode "Threads" - "Major mode for GDB threads. - -\\{gdb-threads-mode-map}" - (setq gdb-thread-position (make-marker)) - (add-to-list 'overlay-arrow-variable-list 'gdb-thread-position) - (setq header-line-format gdb-threads-header) - (set (make-local-variable 'font-lock-defaults) - '(gdb-threads-font-lock-keywords)) - (run-mode-hooks 'gdb-threads-mode-hook) - 'gdb-invalidate-threads) - -(defun gdb-thread-list-handler-custom () - (let ((threads-list (bindat-get-field (gdb-json-partial-output) 'threads)) - (table (make-gdb-table)) - (marked-line nil)) - (setq gdb-threads-list nil) - (setq gdb-running-threads-count 0) - (setq gdb-stopped-threads-count 0) - (set-marker gdb-thread-position nil) - - (dolist (thread (reverse threads-list)) - (let ((running (string-equal (bindat-get-field thread 'state) "running"))) - (add-to-list 'gdb-threads-list - (cons (bindat-get-field thread 'id) - thread)) - (if running - (incf gdb-running-threads-count) - (incf gdb-stopped-threads-count)) - - (gdb-table-add-row table - (list - (bindat-get-field thread 'id) - (concat - (if gdb-thread-buffer-verbose-names - (concat (bindat-get-field thread 'target-id) " ") "") - (bindat-get-field thread 'state) - ;; Include frame information for stopped threads - (if (not running) - (concat - " in " (bindat-get-field thread 'frame 'func) - (if gdb-thread-buffer-arguments - (concat - " (" - (let ((args (bindat-get-field thread 'frame 'args))) - (mapconcat - (lambda (arg) - (apply 'format `("%s=%s" ,@(gdb-get-many-fields arg 'name 'value)))) - args ",")) - ")") - "") - (if gdb-thread-buffer-locations - (gdb-frame-location (bindat-get-field thread 'frame)) "") - (if gdb-thread-buffer-addresses - (concat " at " (bindat-get-field thread 'frame 'addr)) "")) - ""))) - (list - 'gdb-thread thread - 'mouse-face 'highlight - 'help-echo "mouse-2, RET: select thread"))) - (when (string-equal gdb-thread-number - (bindat-get-field thread 'id)) - (setq marked-line (length gdb-threads-list)))) - (insert (gdb-table-string table " ")) - (when marked-line - (gdb-mark-line marked-line gdb-thread-position))) - ;; We update gud-running here because we need to make sure that - ;; gdb-threads-list is up-to-date - (gdb-update-gud-running) - (gdb-emit-signal gdb-buf-publisher 'update-disassembly)) - -(defmacro def-gdb-thread-buffer-command (name custom-defun &optional doc) - "Define a NAME command which will act upon thread on the current line. - -CUSTOM-DEFUN may use locally bound `thread' variable, which will -be the value of 'gdb-thread property of the current line. If -'gdb-thread is nil, error is signaled." - `(defun ,name (&optional event) - ,(when doc doc) - (interactive (list last-input-event)) - (if event (posn-set-point (event-end event))) - (save-excursion - (beginning-of-line) - (let ((thread (get-text-property (point) 'gdb-thread))) - (if thread - ,custom-defun - (error "Not recognized as thread line")))))) - -(defmacro def-gdb-thread-buffer-simple-command (name buffer-command &optional doc) - "Define a NAME which will call BUFFER-COMMAND with id of thread -on the current line." - `(def-gdb-thread-buffer-command ,name - (,buffer-command (bindat-get-field thread 'id)) - ,doc)) - -(def-gdb-thread-buffer-command gdb-select-thread - (let ((new-id (bindat-get-field thread 'id))) - (gdb-setq-thread-number new-id) - (gdb-input (list (concat "-thread-select " new-id) 'ignore)) - (gdb-update)) - "Select the thread at current line of threads buffer.") - -(def-gdb-thread-buffer-simple-command - gdb-display-stack-for-thread - gdb-preemptively-display-stack-buffer - "Display stack buffer for the thread at current line.") - -(def-gdb-thread-buffer-simple-command - gdb-display-locals-for-thread - gdb-preemptively-display-locals-buffer - "Display locals buffer for the thread at current line.") - -(def-gdb-thread-buffer-simple-command - gdb-display-registers-for-thread - gdb-preemptively-display-registers-buffer - "Display registers buffer for the thread at current line.") - -(def-gdb-thread-buffer-simple-command - gdb-display-disassembly-for-thread - gdb-preemptively-display-disassembly-buffer - "Display disassembly buffer for the thread at current line.") - -(def-gdb-thread-buffer-simple-command - gdb-frame-stack-for-thread - gdb-frame-stack-buffer - "Display a new frame with stack buffer for the thread at -current line.") - -(def-gdb-thread-buffer-simple-command - gdb-frame-locals-for-thread - gdb-frame-locals-buffer - "Display a new frame with locals buffer for the thread at -current line.") - -(def-gdb-thread-buffer-simple-command - gdb-frame-registers-for-thread - gdb-frame-registers-buffer - "Display a new frame with registers buffer for the thread at -current line.") - -(def-gdb-thread-buffer-simple-command - gdb-frame-disassembly-for-thread - gdb-frame-disassembly-buffer - "Display a new frame with disassembly buffer for the thread at -current line.") - -(defmacro def-gdb-thread-buffer-gud-command (name gud-command &optional doc) - "Define a NAME which will execute GUD-COMMAND with -`gdb-thread-number' locally bound to id of thread on the current -line." - `(def-gdb-thread-buffer-command ,name - (if gdb-non-stop - (let ((gdb-thread-number (bindat-get-field thread 'id)) - (gdb-gud-control-all-threads nil)) - (call-interactively #',gud-command)) - (error "Available in non-stop mode only, customize `gdb-non-stop-setting'")) - ,doc)) - -(def-gdb-thread-buffer-gud-command - gdb-interrupt-thread - gud-stop-subjob - "Interrupt thread at current line.") - -(def-gdb-thread-buffer-gud-command - gdb-continue-thread - gud-cont - "Continue thread at current line.") - -(def-gdb-thread-buffer-gud-command - gdb-step-thread - gud-step - "Step thread at current line.") - - -;;; Memory view - -(defcustom gdb-memory-rows 8 - "Number of data rows in memory window." - :type 'integer - :group 'gud - :version "23.2") - -(defcustom gdb-memory-columns 4 - "Number of data columns in memory window." - :type 'integer - :group 'gud - :version "23.2") - -(defcustom gdb-memory-format "x" - "Display format of data items in memory window." - :type '(choice (const :tag "Hexadecimal" "x") - (const :tag "Signed decimal" "d") - (const :tag "Unsigned decimal" "u") - (const :tag "Octal" "o") - (const :tag "Binary" "t")) - :group 'gud - :version "22.1") - -(defcustom gdb-memory-unit 4 - "Unit size of data items in memory window." - :type '(choice (const :tag "Byte" 1) - (const :tag "Halfword" 2) - (const :tag "Word" 4) - (const :tag "Giant word" 8)) - :group 'gud - :version "23.2") - -(def-gdb-trigger-and-handler - gdb-invalidate-memory - (format "-data-read-memory %s %s %d %d %d" - gdb-memory-address - gdb-memory-format - gdb-memory-unit - gdb-memory-rows - gdb-memory-columns) - gdb-read-memory-handler - gdb-read-memory-custom - '(start update)) - -(gdb-set-buffer-rules - 'gdb-memory-buffer - 'gdb-memory-buffer-name - 'gdb-memory-mode - 'gdb-invalidate-memory) - -(defun gdb-memory-column-width (size format) - "Return length of string with memory unit of SIZE in FORMAT. - -SIZE is in bytes, as in `gdb-memory-unit'. FORMAT is a string as -in `gdb-memory-format'." - (let ((format-base (cdr (assoc format - '(("x" . 16) - ("d" . 10) ("u" . 10) - ("o" . 8) - ("t" . 2)))))) - (if format-base - (let ((res (ceiling (log (expt 2.0 (* size 8)) format-base)))) - (cond ((string-equal format "x") - (+ 2 res)) ; hexadecimal numbers have 0x in front - ((or (string-equal format "d") - (string-equal format "o")) - (1+ res)) - (t res))) - (error "Unknown format")))) - -(defun gdb-read-memory-custom () - (let* ((res (gdb-json-partial-output)) - (err-msg (bindat-get-field res 'msg))) - (if (not err-msg) - (let ((memory (bindat-get-field res 'memory))) - (setq gdb-memory-address (bindat-get-field res 'addr)) - (setq gdb-memory-next-page (bindat-get-field res 'next-page)) - (setq gdb-memory-prev-page (bindat-get-field res 'prev-page)) - (setq gdb-memory-last-address gdb-memory-address) - (dolist (row memory) - (insert (concat (bindat-get-field row 'addr) ":")) - (dolist (column (bindat-get-field row 'data)) - (insert (gdb-pad-string column - (+ 2 (gdb-memory-column-width - gdb-memory-unit - gdb-memory-format))))) - (newline))) - ;; Show last page instead of empty buffer when out of bounds - (progn - (let ((gdb-memory-address gdb-memory-last-address)) - (gdb-invalidate-memory 'update) - (error err-msg)))))) - -(defvar gdb-memory-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map t) - (define-key map "q" 'kill-this-buffer) - (define-key map "n" 'gdb-memory-show-next-page) - (define-key map "p" 'gdb-memory-show-previous-page) - (define-key map "a" 'gdb-memory-set-address) - (define-key map "t" 'gdb-memory-format-binary) - (define-key map "o" 'gdb-memory-format-octal) - (define-key map "u" 'gdb-memory-format-unsigned) - (define-key map "d" 'gdb-memory-format-signed) - (define-key map "x" 'gdb-memory-format-hexadecimal) - (define-key map "b" 'gdb-memory-unit-byte) - (define-key map "h" 'gdb-memory-unit-halfword) - (define-key map "w" 'gdb-memory-unit-word) - (define-key map "g" 'gdb-memory-unit-giant) - (define-key map "R" 'gdb-memory-set-rows) - (define-key map "C" 'gdb-memory-set-columns) - map)) - -(defun gdb-memory-set-address-event (event) - "Handle a click on address field in memory buffer header." - (interactive "e") - (save-selected-window - (select-window (posn-window (event-start event))) - (gdb-memory-set-address))) - -;; Non-event version for use within keymap -(defun gdb-memory-set-address () - "Set the start memory address." - (interactive) - (let ((arg (read-from-minibuffer "Memory address: "))) - (setq gdb-memory-address arg)) - (gdb-invalidate-memory 'update)) - -(defmacro def-gdb-set-positive-number (name variable echo-string &optional doc) - "Define a function NAME which reads new VAR value from minibuffer." - `(defun ,name (event) - ,(when doc doc) - (interactive "e") - (save-selected-window - (select-window (posn-window (event-start event))) - (let* ((arg (read-from-minibuffer ,echo-string)) - (count (string-to-number arg))) - (if (<= count 0) - (error "Positive number only") - (customize-set-variable ',variable count) - (gdb-invalidate-memory 'update)))))) - -(def-gdb-set-positive-number - gdb-memory-set-rows - gdb-memory-rows - "Rows: " - "Set the number of data rows in memory window.") - -(def-gdb-set-positive-number - gdb-memory-set-columns - gdb-memory-columns - "Columns: " - "Set the number of data columns in memory window.") - -(defmacro def-gdb-memory-format (name format doc) - "Define a function NAME to switch memory buffer to use FORMAT. - -DOC is an optional documentation string." - `(defun ,name () ,(when doc doc) - (interactive) - (customize-set-variable 'gdb-memory-format ,format) - (gdb-invalidate-memory 'update))) - -(def-gdb-memory-format - gdb-memory-format-binary "t" - "Set the display format to binary.") - -(def-gdb-memory-format - gdb-memory-format-octal "o" - "Set the display format to octal.") - -(def-gdb-memory-format - gdb-memory-format-unsigned "u" - "Set the display format to unsigned decimal.") - -(def-gdb-memory-format - gdb-memory-format-signed "d" - "Set the display format to decimal.") - -(def-gdb-memory-format - gdb-memory-format-hexadecimal "x" - "Set the display format to hexadecimal.") - -(defvar gdb-memory-format-map - (let ((map (make-sparse-keymap))) - (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1) - map) - "Keymap to select format in the header line.") - -(defvar gdb-memory-format-menu (make-sparse-keymap "Format") - "Menu of display formats in the header line.") - -(define-key gdb-memory-format-menu [binary] - '(menu-item "Binary" gdb-memory-format-binary - :button (:radio . (equal gdb-memory-format "t")))) -(define-key gdb-memory-format-menu [octal] - '(menu-item "Octal" gdb-memory-format-octal - :button (:radio . (equal gdb-memory-format "o")))) -(define-key gdb-memory-format-menu [unsigned] - '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned - :button (:radio . (equal gdb-memory-format "u")))) -(define-key gdb-memory-format-menu [signed] - '(menu-item "Signed Decimal" gdb-memory-format-signed - :button (:radio . (equal gdb-memory-format "d")))) -(define-key gdb-memory-format-menu [hexadecimal] - '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal - :button (:radio . (equal gdb-memory-format "x")))) - -(defun gdb-memory-format-menu (event) - (interactive "@e") - (x-popup-menu event gdb-memory-format-menu)) - -(defun gdb-memory-format-menu-1 (event) - (interactive "e") - (save-selected-window - (select-window (posn-window (event-start event))) - (let* ((selection (gdb-memory-format-menu event)) - (binding (and selection (lookup-key gdb-memory-format-menu - (vector (car selection)))))) - (if binding (call-interactively binding))))) - -(defmacro def-gdb-memory-unit (name unit-size doc) - "Define a function NAME to switch memory unit size to UNIT-SIZE. - -DOC is an optional documentation string." - `(defun ,name () ,(when doc doc) - (interactive) - (customize-set-variable 'gdb-memory-unit ,unit-size) - (gdb-invalidate-memory 'update))) - -(def-gdb-memory-unit gdb-memory-unit-giant 8 - "Set the unit size to giant words (eight bytes).") - -(def-gdb-memory-unit gdb-memory-unit-word 4 - "Set the unit size to words (four bytes).") - -(def-gdb-memory-unit gdb-memory-unit-halfword 2 - "Set the unit size to halfwords (two bytes).") - -(def-gdb-memory-unit gdb-memory-unit-byte 1 - "Set the unit size to bytes.") - -(defmacro def-gdb-memory-show-page (name address-var &optional doc) - "Define a function NAME which show new address in memory buffer. - -The defined function switches Memory buffer to show address -stored in ADDRESS-VAR variable. - -DOC is an optional documentation string." - `(defun ,name - ,(when doc doc) - (interactive) - (let ((gdb-memory-address ,address-var)) - (gdb-invalidate-memory)))) - -(def-gdb-memory-show-page gdb-memory-show-previous-page - gdb-memory-prev-page) - -(def-gdb-memory-show-page gdb-memory-show-next-page - gdb-memory-next-page) - -(defvar gdb-memory-unit-map - (let ((map (make-sparse-keymap))) - (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1) - map) - "Keymap to select units in the header line.") - -(defvar gdb-memory-unit-menu (make-sparse-keymap "Unit") - "Menu of units in the header line.") - -(define-key gdb-memory-unit-menu [giantwords] - '(menu-item "Giant words" gdb-memory-unit-giant - :button (:radio . (equal gdb-memory-unit 8)))) -(define-key gdb-memory-unit-menu [words] - '(menu-item "Words" gdb-memory-unit-word - :button (:radio . (equal gdb-memory-unit 4)))) -(define-key gdb-memory-unit-menu [halfwords] - '(menu-item "Halfwords" gdb-memory-unit-halfword - :button (:radio . (equal gdb-memory-unit 2)))) -(define-key gdb-memory-unit-menu [bytes] - '(menu-item "Bytes" gdb-memory-unit-byte - :button (:radio . (equal gdb-memory-unit 1)))) - -(defun gdb-memory-unit-menu (event) - (interactive "@e") - (x-popup-menu event gdb-memory-unit-menu)) - -(defun gdb-memory-unit-menu-1 (event) - (interactive "e") - (save-selected-window - (select-window (posn-window (event-start event))) - (let* ((selection (gdb-memory-unit-menu event)) - (binding (and selection (lookup-key gdb-memory-unit-menu - (vector (car selection)))))) - (if binding (call-interactively binding))))) - -(defvar gdb-memory-font-lock-keywords - '(;; <__function.name+n> - ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face)) - ) - "Font lock keywords used in `gdb-memory-mode'.") - -(defvar gdb-memory-header - '(:eval - (concat - "Start address[" - (propertize "-" - 'face font-lock-warning-face - 'help-echo "mouse-1: decrement address" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-show-previous-page)) - "|" - (propertize "+" - 'face font-lock-warning-face - 'help-echo "mouse-1: increment address" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-show-next-page)) - "]: " - (propertize gdb-memory-address - 'face font-lock-warning-face - 'help-echo "mouse-1: set start address" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-set-address-event)) - " Rows: " - (propertize (number-to-string gdb-memory-rows) - 'face font-lock-warning-face - 'help-echo "mouse-1: set number of columns" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-set-rows)) - " Columns: " - (propertize (number-to-string gdb-memory-columns) - 'face font-lock-warning-face - 'help-echo "mouse-1: set number of columns" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-set-columns)) - " Display Format: " - (propertize gdb-memory-format - 'face font-lock-warning-face - 'help-echo "mouse-3: select display format" - 'mouse-face 'mode-line-highlight - 'local-map gdb-memory-format-map) - " Unit Size: " - (propertize (number-to-string gdb-memory-unit) - 'face font-lock-warning-face - 'help-echo "mouse-3: select unit size" - 'mouse-face 'mode-line-highlight - 'local-map gdb-memory-unit-map))) - "Header line used in `gdb-memory-mode'.") - -(define-derived-mode gdb-memory-mode gdb-parent-mode "Memory" - "Major mode for examining memory. - -\\{gdb-memory-mode-map}" - (setq header-line-format gdb-memory-header) - (set (make-local-variable 'font-lock-defaults) - '(gdb-memory-font-lock-keywords)) - (run-mode-hooks 'gdb-memory-mode-hook) - 'gdb-invalidate-memory) - -(defun gdb-memory-buffer-name () - (concat "*memory of " (gdb-get-target-string) "*")) - -(def-gdb-display-buffer - gdb-display-memory-buffer - 'gdb-memory-buffer - "Display memory contents.") - -(defun gdb-frame-memory-buffer () - "Display memory contents in a new frame." - (interactive) - (let* ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist - `((left-fringe . 0) - (right-fringe . 0) - (width . 83) - ,@gdb-frame-parameters))) - (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer)))) - - -;;; Disassembly view - -(defun gdb-disassembly-buffer-name () - (gdb-current-context-buffer-name - (concat "disassembly of " (gdb-get-target-string)))) - -(def-gdb-display-buffer - gdb-display-disassembly-buffer - 'gdb-disassembly-buffer - "Display disassembly for current stack frame.") - -(def-gdb-preempt-display-buffer - gdb-preemptively-display-disassembly-buffer - 'gdb-disassembly-buffer) - -(def-gdb-frame-for-buffer - gdb-frame-disassembly-buffer - 'gdb-disassembly-buffer - "Display disassembly in a new frame.") - -(def-gdb-auto-update-trigger gdb-invalidate-disassembly - (let* ((frame (gdb-current-buffer-frame)) - (file (bindat-get-field frame 'fullname)) - (line (bindat-get-field frame 'line))) - (when file - (format "-data-disassemble -f %s -l %s -n -1 -- 0" file line))) - gdb-disassembly-handler - ;; We update disassembly only after we have actual frame information - ;; about all threads, so no there's `update' signal in this list - '(start update-disassembly)) - -(def-gdb-auto-update-handler - gdb-disassembly-handler - gdb-invalidate-disassembly - gdb-disassembly-handler-custom - t) - -(gdb-set-buffer-rules - 'gdb-disassembly-buffer - 'gdb-disassembly-buffer-name - 'gdb-disassembly-mode - 'gdb-invalidate-disassembly) - -(defvar gdb-disassembly-font-lock-keywords - '(;; <__function.name+n> - ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" - (1 font-lock-function-name-face)) - ;; 0xNNNNNNNN <__function.name+n>: opcode - ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)" - (4 font-lock-keyword-face)) - ;; %register(at least i386) - ("%\\sw+" . font-lock-variable-name-face) - ("^\\(Dump of assembler code for function\\) \\(.+\\):" - (1 font-lock-comment-face) - (2 font-lock-function-name-face)) - ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face)) - "Font lock keywords used in `gdb-disassembly-mode'.") - -(defvar gdb-disassembly-mode-map - ;; TODO - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'kill-this-buffer) - map)) - -(define-derived-mode gdb-disassembly-mode gdb-parent-mode "Disassembly" - "Major mode for GDB disassembly information. - -\\{gdb-disassembly-mode-map}" - ;; TODO Rename overlay variable for disassembly mode - (add-to-list 'overlay-arrow-variable-list 'gdb-disassembly-position) - (setq fringes-outside-margins t) - (set (make-local-variable 'gdb-disassembly-position) (make-marker)) - (set (make-local-variable 'font-lock-defaults) - '(gdb-disassembly-font-lock-keywords)) - (run-mode-hooks 'gdb-disassembly-mode-hook) - 'gdb-invalidate-disassembly) - -(defun gdb-disassembly-handler-custom () - (let* ((instructions (bindat-get-field (gdb-json-partial-output) 'asm_insns)) - (address (bindat-get-field (gdb-current-buffer-frame) 'addr)) - (pos 1) - (table (make-gdb-table)) - (marked-line nil)) - (dolist (instr instructions) - (gdb-table-add-row table - (list - (bindat-get-field instr 'address) - (apply 'format `("<%s+%s>:" ,@(gdb-get-many-fields instr 'func-name 'offset))) - (bindat-get-field instr 'inst))) - (when (string-equal (bindat-get-field instr 'address) - address) - (progn - (setq marked-line (length (gdb-table-rows table))) - (setq fringe-indicator-alist - (if (string-equal gdb-frame-number "0") - nil - '((overlay-arrow . hollow-right-triangle))))))) - (insert (gdb-table-string table " ")) - (gdb-disassembly-place-breakpoints) - ;; Mark current position with overlay arrow and scroll window to - ;; that point - (when marked-line - (let ((window (get-buffer-window (current-buffer) 0))) - (set-window-point window (gdb-mark-line marked-line gdb-disassembly-position)))) - (setq mode-name - (gdb-current-context-mode-name - (concat "Disassembly: " - (bindat-get-field (gdb-current-buffer-frame) 'func)))))) - -(defun gdb-disassembly-place-breakpoints () - (gdb-remove-breakpoint-icons (point-min) (point-max)) - (dolist (breakpoint gdb-breakpoints-list) - (let* ((breakpoint (cdr breakpoint)) - (bptno (bindat-get-field breakpoint 'number)) - (flag (bindat-get-field breakpoint 'enabled)) - (address (bindat-get-field breakpoint 'addr))) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward (concat "^" address) nil t) - (gdb-put-breakpoint-icon (string-equal flag "y") bptno)))))) - - -(defvar gdb-breakpoints-header - (list - (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer - nil nil mode-line) - " " - (gdb-propertize-header "Threads" gdb-threads-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive))) - -;;; Breakpoints view -(define-derived-mode gdb-breakpoints-mode gdb-parent-mode "Breakpoints" - "Major mode for gdb breakpoints. - -\\{gdb-breakpoints-mode-map}" - (setq header-line-format gdb-breakpoints-header) - (run-mode-hooks 'gdb-breakpoints-mode-hook) - 'gdb-invalidate-breakpoints) - -(defun gdb-toggle-breakpoint () - "Enable/disable breakpoint at current line of breakpoints buffer." - (interactive) - (save-excursion - (beginning-of-line) - (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) - (if breakpoint - (gud-basic-call - (concat (if (string-equal "y" (bindat-get-field breakpoint 'enabled)) - "-break-disable " - "-break-enable ") - (bindat-get-field breakpoint 'number))) - (error "Not recognized as break/watchpoint line"))))) - -(defun gdb-delete-breakpoint () - "Delete the breakpoint at current line of breakpoints buffer." - (interactive) - (save-excursion - (beginning-of-line) - (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) - (if breakpoint - (gud-basic-call (concat "-break-delete " (bindat-get-field breakpoint 'number))) - (error "Not recognized as break/watchpoint line"))))) - -(defun gdb-goto-breakpoint (&optional event) - "Go to the location of breakpoint at current line of -breakpoints buffer." - (interactive (list last-input-event)) - (if event (posn-set-point (event-end event))) - ;; Hack to stop gdb-goto-breakpoint displaying in GUD buffer. - (let ((window (get-buffer-window gud-comint-buffer))) - (if window (save-selected-window (select-window window)))) - (save-excursion - (beginning-of-line) - (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) - (if breakpoint - (let ((bptno (bindat-get-field breakpoint 'number)) - (file (bindat-get-field breakpoint 'fullname)) - (line (bindat-get-field breakpoint 'line))) - (save-selected-window - (let* ((buffer (find-file-noselect - (if (file-exists-p file) file - (cdr (assoc bptno gdb-location-alist))))) - (window (or (gdb-display-source-buffer buffer) - (display-buffer buffer)))) - (setq gdb-source-window window) - (with-current-buffer buffer - (goto-char (point-min)) - (forward-line (1- (string-to-number line))) - (set-window-point window (point)))))) - (error "Not recognized as break/watchpoint line"))))) - - -;; Frames buffer. This displays a perpetually correct bactrack trace. -;; -(def-gdb-trigger-and-handler - gdb-invalidate-frames (gdb-current-context-command "-stack-list-frames") - gdb-stack-list-frames-handler gdb-stack-list-frames-custom - '(start update)) - -(gdb-set-buffer-rules - 'gdb-stack-buffer - 'gdb-stack-buffer-name - 'gdb-frames-mode - 'gdb-invalidate-frames) - -(defun gdb-frame-location (frame) - "Return \" of file:line\" or \" of library\" for structure FRAME. - -FRAME must have either \"file\" and \"line\" members or \"from\" -member." - (let ((file (bindat-get-field frame 'file)) - (line (bindat-get-field frame 'line)) - (from (bindat-get-field frame 'from))) - (let ((res (or (and file line (concat file ":" line)) - from))) - (if res (concat " of " res) "")))) - -(defun gdb-stack-list-frames-custom () - (let ((stack (bindat-get-field (gdb-json-partial-output "frame") 'stack)) - (table (make-gdb-table))) - (set-marker gdb-stack-position nil) - (dolist (frame stack) - (gdb-table-add-row table - (list - (bindat-get-field frame 'level) - "in" - (concat - (bindat-get-field frame 'func) - (if gdb-stack-buffer-locations - (gdb-frame-location frame) "") - (if gdb-stack-buffer-addresses - (concat " at " (bindat-get-field frame 'addr)) ""))) - `(mouse-face highlight - help-echo "mouse-2, RET: Select frame" - gdb-frame ,frame))) - (insert (gdb-table-string table " "))) - (when (and gdb-frame-number - (gdb-buffer-shows-main-thread-p)) - (gdb-mark-line (1+ (string-to-number gdb-frame-number)) - gdb-stack-position)) - (setq mode-name - (gdb-current-context-mode-name "Frames"))) - -(defun gdb-stack-buffer-name () - (gdb-current-context-buffer-name - (concat "stack frames of " (gdb-get-target-string)))) - -(def-gdb-display-buffer - gdb-display-stack-buffer - 'gdb-stack-buffer - "Display backtrace of current stack.") - -(def-gdb-preempt-display-buffer - gdb-preemptively-display-stack-buffer - 'gdb-stack-buffer nil t) - -(def-gdb-frame-for-buffer - gdb-frame-stack-buffer - 'gdb-stack-buffer - "Display backtrace of current stack in a new frame.") - -(defvar gdb-frames-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'kill-this-buffer) - (define-key map "\r" 'gdb-select-frame) - (define-key map [mouse-2] 'gdb-select-frame) - (define-key map [follow-link] 'mouse-face) - map)) - -(defvar gdb-frames-font-lock-keywords - '(("in \\([^ ]+\\)" (1 font-lock-function-name-face))) - "Font lock keywords used in `gdb-frames-mode'.") - -(define-derived-mode gdb-frames-mode gdb-parent-mode "Frames" - "Major mode for gdb call stack. - -\\{gdb-frames-mode-map}" - (setq gdb-stack-position (make-marker)) - (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position) - (setq truncate-lines t) ;; Make it easier to see overlay arrow. - (set (make-local-variable 'font-lock-defaults) - '(gdb-frames-font-lock-keywords)) - (run-mode-hooks 'gdb-frames-mode-hook) - 'gdb-invalidate-frames) - -(defun gdb-select-frame (&optional event) - "Select the frame and display the relevant source." - (interactive (list last-input-event)) - (if event (posn-set-point (event-end event))) - (let ((frame (get-text-property (point) 'gdb-frame))) - (if frame - (if (gdb-buffer-shows-main-thread-p) - (let ((new-level (bindat-get-field frame 'level))) - (setq gdb-frame-number new-level) - (gdb-input (list (concat "-stack-select-frame " new-level) 'ignore)) - (gdb-update)) - (error "Could not select frame for non-current thread")) - (error "Not recognized as frame line")))) - - -;; Locals buffer. -;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards. -(def-gdb-trigger-and-handler - gdb-invalidate-locals - (concat (gdb-current-context-command "-stack-list-locals") " --simple-values") - gdb-locals-handler gdb-locals-handler-custom - '(start update)) - -(gdb-set-buffer-rules - 'gdb-locals-buffer - 'gdb-locals-buffer-name - 'gdb-locals-mode - 'gdb-invalidate-locals) - -(defvar gdb-locals-watch-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "\r" 'gud-watch) - (define-key map [mouse-2] 'gud-watch) - map) - "Keymap to create watch expression of a complex data type local variable.") - -(defvar gdb-edit-locals-map-1 - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "\r" 'gdb-edit-locals-value) - (define-key map [mouse-2] 'gdb-edit-locals-value) - map) - "Keymap to edit value of a simple data type local variable.") - -(defun gdb-edit-locals-value (&optional event) - "Assign a value to a variable displayed in the locals buffer." - (interactive (list last-input-event)) - (save-excursion - (if event (posn-set-point (event-end event))) - (beginning-of-line) - (let* ((var (bindat-get-field - (get-text-property (point) 'gdb-local-variable) 'name)) - (value (read-string (format "New value (%s): " var)))) - (gud-basic-call - (concat "-gdb-set variable " var " = " value))))) - -;; Dont display values of arrays or structures. -;; These can be expanded using gud-watch. -(defun gdb-locals-handler-custom () - (let ((locals-list (bindat-get-field (gdb-json-partial-output) 'locals)) - (table (make-gdb-table))) - (dolist (local locals-list) - (let ((name (bindat-get-field local 'name)) - (value (bindat-get-field local 'value)) - (type (bindat-get-field local 'type))) - (if (or (not value) - (string-match "\\0x" value)) - (add-text-properties 0 (length name) - `(mouse-face highlight - help-echo "mouse-2: create watch expression" - local-map ,gdb-locals-watch-map) - name) - (add-text-properties 0 (length value) - `(mouse-face highlight - help-echo "mouse-2: edit value" - local-map ,gdb-edit-locals-map-1) - value)) - (gdb-table-add-row - table - (list - (propertize type 'font-lock-face font-lock-type-face) - (propertize name 'font-lock-face font-lock-variable-name-face) - value) - `(gdb-local-variable ,local)))) - (insert (gdb-table-string table " ")) - (setq mode-name - (gdb-current-context-mode-name - (concat "Locals: " (bindat-get-field (gdb-current-buffer-frame) 'func)))))) - -(defvar gdb-locals-header - (list - (gdb-propertize-header "Locals" gdb-locals-buffer - nil nil mode-line) - " " - (gdb-propertize-header "Registers" gdb-registers-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive))) - -(defvar gdb-locals-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'kill-this-buffer) - (define-key map "\t" '(lambda () - (interactive) - (gdb-set-window-buffer - (gdb-get-buffer-create - 'gdb-registers-buffer - gdb-thread-number) t))) - map)) - -(define-derived-mode gdb-locals-mode gdb-parent-mode "Locals" - "Major mode for gdb locals. - -\\{gdb-locals-mode-map}" - (setq header-line-format gdb-locals-header) - (run-mode-hooks 'gdb-locals-mode-hook) - 'gdb-invalidate-locals) - -(defun gdb-locals-buffer-name () - (gdb-current-context-buffer-name - (concat "locals of " (gdb-get-target-string)))) - -(def-gdb-display-buffer - gdb-display-locals-buffer - 'gdb-locals-buffer - "Display local variables of current stack and their values.") - -(def-gdb-preempt-display-buffer - gdb-preemptively-display-locals-buffer - 'gdb-locals-buffer nil t) - -(def-gdb-frame-for-buffer - gdb-frame-locals-buffer - 'gdb-locals-buffer - "Display local variables of current stack and their values in a new frame.") - - -;; Registers buffer. - -(def-gdb-trigger-and-handler - gdb-invalidate-registers - (concat (gdb-current-context-command "-data-list-register-values") " x") - gdb-registers-handler - gdb-registers-handler-custom - '(start update)) - -(gdb-set-buffer-rules - 'gdb-registers-buffer - 'gdb-registers-buffer-name - 'gdb-registers-mode - 'gdb-invalidate-registers) - -(defun gdb-registers-handler-custom () - (when gdb-register-names - (let ((register-values (bindat-get-field (gdb-json-partial-output) 'register-values)) - (table (make-gdb-table))) - (dolist (register register-values) - (let* ((register-number (bindat-get-field register 'number)) - (value (bindat-get-field register 'value)) - (register-name (nth (string-to-number register-number) - gdb-register-names))) - (gdb-table-add-row - table - (list - (propertize register-name 'font-lock-face font-lock-variable-name-face) - (if (member register-number gdb-changed-registers) - (propertize value 'font-lock-face font-lock-warning-face) - value)) - `(mouse-face highlight - help-echo "mouse-2: edit value" - gdb-register-name ,register-name)))) - (insert (gdb-table-string table " "))) - (setq mode-name - (gdb-current-context-mode-name "Registers")))) - -(defun gdb-edit-register-value (&optional event) - "Assign a value to a register displayed in the registers buffer." - (interactive (list last-input-event)) - (save-excursion - (if event (posn-set-point (event-end event))) - (beginning-of-line) - (let* ((var (bindat-get-field - (get-text-property (point) 'gdb-register-name))) - (value (read-string (format "New value (%s): " var)))) - (gud-basic-call - (concat "-gdb-set variable $" var " = " value))))) - -(defvar gdb-registers-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "\r" 'gdb-edit-register-value) - (define-key map [mouse-2] 'gdb-edit-register-value) - (define-key map "q" 'kill-this-buffer) - (define-key map "\t" '(lambda () - (interactive) - (gdb-set-window-buffer - (gdb-get-buffer-create - 'gdb-locals-buffer - gdb-thread-number) t))) - map)) - -(defvar gdb-registers-header - (list - (gdb-propertize-header "Locals" gdb-locals-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive) - " " - (gdb-propertize-header "Registers" gdb-registers-buffer - nil nil mode-line))) - -(define-derived-mode gdb-registers-mode gdb-parent-mode "Registers" - "Major mode for gdb registers. - -\\{gdb-registers-mode-map}" - (setq header-line-format gdb-registers-header) - (run-mode-hooks 'gdb-registers-mode-hook) - 'gdb-invalidate-registers) - -(defun gdb-registers-buffer-name () - (gdb-current-context-buffer-name - (concat "registers of " (gdb-get-target-string)))) - -(def-gdb-display-buffer - gdb-display-registers-buffer - 'gdb-registers-buffer - "Display integer register contents.") - -(def-gdb-preempt-display-buffer - gdb-preemptively-display-registers-buffer - 'gdb-registers-buffer nil t) - -(def-gdb-frame-for-buffer - gdb-frame-registers-buffer - 'gdb-registers-buffer - "Display integer register contents in a new frame.") - -;; Needs GDB 6.4 onwards (used to fail with no stack). -(defun gdb-get-changed-registers () - (if (and (gdb-get-buffer 'gdb-registers-buffer) - (not (gdb-pending-p 'gdb-get-changed-registers))) - (progn - (gdb-input - (list - "-data-list-changed-registers" - 'gdb-changed-registers-handler)) - (gdb-add-pending 'gdb-get-changed-registers)))) - -(defun gdb-changed-registers-handler () - (gdb-delete-pending 'gdb-get-changed-registers) - (setq gdb-changed-registers nil) - (dolist (register-number (bindat-get-field (gdb-json-partial-output) 'changed-registers)) - (push register-number gdb-changed-registers))) - -(defun gdb-register-names-handler () - ;; Don't use gdb-pending-triggers because this handler is called - ;; only once (in gdb-init-1) - (setq gdb-register-names nil) - (dolist (register-name (bindat-get-field (gdb-json-partial-output) 'register-names)) - (push register-name gdb-register-names)) - (setq gdb-register-names (reverse gdb-register-names))) - - -(defun gdb-get-source-file-list () - "Create list of source files for current GDB session. -If buffers already exist for any of these files, gud-minor-mode -is set in them." - (goto-char (point-min)) - (while (re-search-forward gdb-source-file-regexp nil t) - (push (match-string 1) gdb-source-file-list)) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (member buffer-file-name gdb-source-file-list) - (gdb-init-buffer)))) - (gdb-force-mode-line-update - (propertize "ready" 'face font-lock-variable-name-face))) - -(defun gdb-get-main-selected-frame () - "Trigger for `gdb-frame-handler' which uses main current -thread. Called from `gdb-update'." - (if (not (gdb-pending-p 'gdb-get-main-selected-frame)) - (progn - (gdb-input - (list (gdb-current-context-command "-stack-info-frame") 'gdb-frame-handler)) - (gdb-add-pending 'gdb-get-main-selected-frame)))) - -(defun gdb-frame-handler () - "Sets `gdb-selected-frame' and `gdb-selected-file' to show -overlay arrow in source buffer." - (gdb-delete-pending 'gdb-get-main-selected-frame) - (let ((frame (bindat-get-field (gdb-json-partial-output) 'frame))) - (when frame - (setq gdb-selected-frame (bindat-get-field frame 'func)) - (setq gdb-selected-file (bindat-get-field frame 'fullname)) - (setq gdb-frame-number (bindat-get-field frame 'level)) - (setq gdb-frame-address (bindat-get-field frame 'addr)) - (let ((line (bindat-get-field frame 'line))) - (setq gdb-selected-line (and line (string-to-number line))) - (when (and gdb-selected-file gdb-selected-line) - (setq gud-last-frame (cons gdb-selected-file gdb-selected-line)) - (gud-display-frame))) - (if gud-overlay-arrow-position - (let ((buffer (marker-buffer gud-overlay-arrow-position)) - (position (marker-position gud-overlay-arrow-position))) - (when buffer - (with-current-buffer buffer - (setq fringe-indicator-alist - (if (string-equal gdb-frame-number "0") - nil - '((overlay-arrow . hollow-right-triangle)))) - (setq gud-overlay-arrow-position (make-marker)) - (set-marker gud-overlay-arrow-position position)))))))) - -(defvar gdb-prompt-name-regexp "value=\"\\(.*?\\)\"") - -(defun gdb-get-prompt () - "Find prompt for GDB session." - (goto-char (point-min)) - (setq gdb-prompt-name nil) - (re-search-forward gdb-prompt-name-regexp nil t) - (setq gdb-prompt-name (match-string 1)) - ;; Insert first prompt. - (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) - -;;;; Window management -(defun gdb-display-buffer (buf dedicated &optional frame) - "Show buffer BUF. - -If BUF is already displayed in some window, show it, deiconifying -the frame if necessary. Otherwise, find least recently used -window and show BUF there, if the window is not used for GDB -already, in which case that window is splitted first." - (let ((answer (get-buffer-window buf (or frame 0)))) - (if answer - (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary. - (let ((window (get-lru-window))) - (if (eq (buffer-local-value 'gud-minor-mode (window-buffer window)) - 'gdbmi) - (let* ((largest (get-largest-window)) - (cur-size (window-height largest))) - (setq answer (split-window largest)) - (set-window-buffer answer buf) - (set-window-dedicated-p answer dedicated) - answer) - (set-window-buffer window buf) - window))))) - -(defun gdb-preempt-existing-or-display-buffer (buf &optional split-horizontal) - "Find window displaying a buffer with the same -`gdb-buffer-type' as BUF and show BUF there. If no such window -exists, just call `gdb-display-buffer' for BUF. If the window -found is already dedicated, split window according to -SPLIT-HORIZONTAL and show BUF in the new window." - (if buf - (when (not (get-buffer-window buf)) - (let* ((buf-type (gdb-buffer-type buf)) - (existing-window - (get-window-with-predicate - #'(lambda (w) - (and (eq buf-type - (gdb-buffer-type (window-buffer w))) - (not (window-dedicated-p w))))))) - (if existing-window - (set-window-buffer existing-window buf) - (let ((dedicated-window - (get-window-with-predicate - #'(lambda (w) - (eq buf-type - (gdb-buffer-type (window-buffer w))))))) - (if dedicated-window - (set-window-buffer - (split-window dedicated-window nil split-horizontal) buf) - (gdb-display-buffer buf t)))))) - (error "Null buffer"))) - -;;; Shared keymap initialization: - -(let ((menu (make-sparse-keymap "GDB-Windows"))) - (define-key gud-menu-map [displays] - `(menu-item "GDB-Windows" ,menu - :visible (eq gud-minor-mode 'gdbmi))) - (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer)) - (define-key menu [threads] '("Threads" . gdb-display-threads-buffer)) - (define-key menu [memory] '("Memory" . gdb-display-memory-buffer)) - (define-key menu [disassembly] - '("Disassembly" . gdb-display-disassembly-buffer)) - (define-key menu [registers] '("Registers" . gdb-display-registers-buffer)) - (define-key menu [inferior] - '("IO" . gdb-display-io-buffer)) - (define-key menu [locals] '("Locals" . gdb-display-locals-buffer)) - (define-key menu [frames] '("Stack" . gdb-display-stack-buffer)) - (define-key menu [breakpoints] - '("Breakpoints" . gdb-display-breakpoints-buffer))) - -(let ((menu (make-sparse-keymap "GDB-Frames"))) - (define-key gud-menu-map [frames] - `(menu-item "GDB-Frames" ,menu - :visible (eq gud-minor-mode 'gdbmi))) - (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer)) - (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer)) - (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer)) - (define-key menu [disassembly] '("Disassembly" . gdb-frame-disassembly-buffer)) - (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer)) - (define-key menu [inferior] - '("IO" . gdb-frame-io-buffer)) - (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer)) - (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer)) - (define-key menu [breakpoints] - '("Breakpoints" . gdb-frame-breakpoints-buffer))) - -(let ((menu (make-sparse-keymap "GDB-MI"))) - (define-key menu [gdb-customize] - '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb)) - :help "Customize Gdb Graphical Mode options.")) - (define-key menu [gdb-many-windows] - '(menu-item "Display Other Windows" gdb-many-windows - :help "Toggle display of locals, stack and breakpoint information" - :button (:toggle . gdb-many-windows))) - (define-key menu [gdb-restore-windows] - '(menu-item "Restore Window Layout" gdb-restore-windows - :help "Restore standard layout for debug session.")) - (define-key menu [sep1] - '(menu-item "--")) - (define-key menu [all-threads] - '(menu-item "GUD controls all threads" - (lambda () - (interactive) - (setq gdb-gud-control-all-threads t)) - :help "GUD start/stop commands apply to all threads" - :button (:radio . gdb-gud-control-all-threads))) - (define-key menu [current-thread] - '(menu-item "GUD controls current thread" - (lambda () - (interactive) - (setq gdb-gud-control-all-threads nil)) - :help "GUD start/stop commands apply to current thread only" - :button (:radio . (not gdb-gud-control-all-threads)))) - (define-key menu [sep2] - '(menu-item "--")) - (define-key menu [gdb-customize-reasons] - '(menu-item "Customize switching..." - (lambda () - (interactive) - (customize-option 'gdb-switch-reasons)))) - (define-key menu [gdb-switch-when-another-stopped] - (menu-bar-make-toggle gdb-toggle-switch-when-another-stopped gdb-switch-when-another-stopped - "Automatically switch to stopped thread" - "GDB thread switching %s" - "Switch to stopped thread")) - (define-key gud-menu-map [mi] - `(menu-item "GDB-MI" ,menu :visible (eq gud-minor-mode 'gdbmi)))) - -;; TODO Fit these into tool-bar-local-item-from-menu call in gud.el. -;; GDB-MI menu will need to be moved to gud.el. We can't use -;; tool-bar-local-item-from-menu here because it appends new buttons -;; to toolbar from right to left while we want our A/T throttle to -;; show up right before Run button. -(define-key-after gud-tool-bar-map [all-threads] - '(menu-item "Switch to non-stop/A mode" gdb-control-all-threads - :image (find-image '((:type xpm :file "gud/thread.xpm"))) - :visible (and (eq gud-minor-mode 'gdbmi) - gdb-non-stop - (not gdb-gud-control-all-threads))) - 'run) - -(define-key-after gud-tool-bar-map [current-thread] - '(menu-item "Switch to non-stop/T mode" gdb-control-current-thread - :image (find-image '((:type xpm :file "gud/all.xpm"))) - :visible (and (eq gud-minor-mode 'gdbmi) - gdb-non-stop - gdb-gud-control-all-threads)) - 'all-threads) - -(defun gdb-frame-gdb-buffer () - "Display GUD buffer in a new frame." - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist - (remove '(menu-bar-lines) (remove '(tool-bar-lines) - gdb-frame-parameters))) - (same-window-regexps nil)) - (display-buffer gud-comint-buffer))) - -(defun gdb-display-gdb-buffer () - "Display GUD buffer." - (interactive) - (let ((same-window-regexps nil)) - (select-window (display-buffer gud-comint-buffer nil 0)))) - -(defun gdb-set-window-buffer (name &optional ignore-dedicated) - "Set buffer of selected window to NAME and dedicate window. - -When IGNORE-DEDICATED is non-nil, buffer is set even if selected -window is dedicated." - (when ignore-dedicated - (set-window-dedicated-p (selected-window) nil)) - (set-window-buffer (selected-window) (get-buffer name)) - (set-window-dedicated-p (selected-window) t)) - -(defun gdb-setup-windows () - "Layout the window pattern for `gdb-many-windows'." - (gdb-display-locals-buffer) - (gdb-display-stack-buffer) - (delete-other-windows) - (gdb-display-breakpoints-buffer) - (delete-other-windows) - ; Don't dedicate. - (pop-to-buffer gud-comint-buffer) - (split-window nil ( / ( * (window-height) 3) 4)) - (split-window nil ( / (window-height) 3)) - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer (gdb-locals-buffer-name)) - (other-window 1) - (switch-to-buffer - (if gud-last-last-frame - (gud-find-file (car gud-last-last-frame)) - (if gdb-main-file - (gud-find-file gdb-main-file) - ;; Put buffer list in window if we - ;; can't find a source file. - (list-buffers-noselect)))) - (setq gdb-source-window (selected-window)) - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-inferior-io)) - (other-window 1) - (gdb-set-window-buffer (gdb-stack-buffer-name)) - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer (if gdb-show-threads-by-default - (gdb-threads-buffer-name) - (gdb-breakpoints-buffer-name))) - (other-window 1)) - -(defcustom gdb-many-windows nil - "If nil just pop up the GUD buffer unless `gdb-show-main' is t. -In this case it starts with two windows: one displaying the GUD -buffer and the other with the source file with the main routine -of the debugged program. Non-nil means display the layout shown for -`gdb'." - :type 'boolean - :group 'gdb - :version "22.1") - -(defun gdb-many-windows (arg) - "Toggle the number of windows in the basic arrangement. -With arg, display additional buffers iff arg is positive." - (interactive "P") - (setq gdb-many-windows - (if (null arg) - (not gdb-many-windows) - (> (prefix-numeric-value arg) 0))) - (message (format "Display of other windows %sabled" - (if gdb-many-windows "en" "dis"))) - (if (and gud-comint-buffer - (buffer-name gud-comint-buffer)) - (condition-case nil - (gdb-restore-windows) - (error nil)))) - -(defun gdb-restore-windows () - "Restore the basic arrangement of windows used by gdb. -This arrangement depends on the value of `gdb-many-windows'." - (interactive) - (pop-to-buffer gud-comint-buffer) ;Select the right window and frame. - (delete-other-windows) - (if gdb-many-windows - (gdb-setup-windows) - (when (or gud-last-last-frame gdb-show-main) - (split-window) - (other-window 1) - (switch-to-buffer - (if gud-last-last-frame - (gud-find-file (car gud-last-last-frame)) - (gud-find-file gdb-main-file))) - (setq gdb-source-window (selected-window)) - (other-window 1)))) - -(defun gdb-reset () - "Exit a debugging session cleanly. -Kills the gdb buffers, and resets variables and the source buffers." - (dolist (buffer (buffer-list)) - (unless (eq buffer gud-comint-buffer) - (with-current-buffer buffer - (if (eq gud-minor-mode 'gdbmi) - (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name)) - (kill-buffer nil) - (gdb-remove-breakpoint-icons (point-min) (point-max) t) - (setq gud-minor-mode nil) - (kill-local-variable 'tool-bar-map) - (kill-local-variable 'gdb-define-alist)))))) - (setq gdb-disassembly-position nil) - (setq overlay-arrow-variable-list - (delq 'gdb-disassembly-position overlay-arrow-variable-list)) - (setq fringe-indicator-alist '((overlay-arrow . right-triangle))) - (setq gdb-stack-position nil) - (setq overlay-arrow-variable-list - (delq 'gdb-stack-position overlay-arrow-variable-list)) - (setq gdb-thread-position nil) - (setq overlay-arrow-variable-list - (delq 'gdb-thread-position overlay-arrow-variable-list)) - (if (boundp 'speedbar-frame) (speedbar-timer-fn)) - (setq gud-running nil) - (setq gdb-active-process nil) - (remove-hook 'after-save-hook 'gdb-create-define-alist t)) - -(defun gdb-get-source-file () - "Find the source file where the program starts and display it with related -buffers, if required." - (goto-char (point-min)) - (if (re-search-forward gdb-source-file-regexp nil t) - (setq gdb-main-file (match-string 1))) - (if gdb-many-windows - (gdb-setup-windows) - (gdb-get-buffer-create 'gdb-breakpoints-buffer) - (if gdb-show-main - (let ((pop-up-windows t)) - (display-buffer (gud-find-file gdb-main-file)))))) - -;;from put-image -(defun gdb-put-string (putstring pos &optional dprop &rest sprops) - "Put string PUTSTRING in front of POS in the current buffer. -PUTSTRING is displayed by putting an overlay into the current buffer with a -`before-string' string that has a `display' property whose value is -PUTSTRING." - (let ((string (make-string 1 ?x)) - (buffer (current-buffer))) - (setq putstring (copy-sequence putstring)) - (let ((overlay (make-overlay pos pos buffer)) - (prop (or dprop - (list (list 'margin 'left-margin) putstring)))) - (put-text-property 0 1 'display prop string) - (if sprops - (add-text-properties 0 1 sprops string)) - (overlay-put overlay 'put-break t) - (overlay-put overlay 'before-string string)))) - -;;from remove-images -(defun gdb-remove-strings (start end &optional buffer) - "Remove strings between START and END in BUFFER. -Remove only strings that were put in BUFFER with calls to `gdb-put-string'. -BUFFER nil or omitted means use the current buffer." - (unless buffer - (setq buffer (current-buffer))) - (dolist (overlay (overlays-in start end)) - (when (overlay-get overlay 'put-break) - (delete-overlay overlay)))) - -(defun gdb-put-breakpoint-icon (enabled bptno &optional line) - (let* ((posns (gdb-line-posns (or line (line-number-at-pos)))) - (start (- (car posns) 1)) - (end (+ (cdr posns) 1)) - (putstring (if enabled "B" "b")) - (source-window (get-buffer-window (current-buffer) 0))) - (add-text-properties - 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt") - putstring) - (if enabled - (add-text-properties - 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring) - (add-text-properties - 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring)) - (gdb-remove-breakpoint-icons start end) - (if (display-images-p) - (if (>= (or left-fringe-width - (if source-window (car (window-fringes source-window))) - gdb-buffer-fringe-width) 8) - (gdb-put-string - nil (1+ start) - `(left-fringe breakpoint - ,(if enabled - 'breakpoint-enabled - 'breakpoint-disabled)) - 'gdb-bptno bptno - 'gdb-enabled enabled) - (when (< left-margin-width 2) - (save-current-buffer - (setq left-margin-width 2) - (if source-window - (set-window-margins - source-window - left-margin-width right-margin-width)))) - (put-image - (if enabled - (or breakpoint-enabled-icon - (setq breakpoint-enabled-icon - (find-image `((:type xpm :data - ,breakpoint-xpm-data - :ascent 100 :pointer hand) - (:type pbm :data - ,breakpoint-enabled-pbm-data - :ascent 100 :pointer hand))))) - (or breakpoint-disabled-icon - (setq breakpoint-disabled-icon - (find-image `((:type xpm :data - ,breakpoint-xpm-data - :conversion disabled - :ascent 100 :pointer hand) - (:type pbm :data - ,breakpoint-disabled-pbm-data - :ascent 100 :pointer hand)))))) - (+ start 1) - putstring - 'left-margin)) - (when (< left-margin-width 2) - (save-current-buffer - (setq left-margin-width 2) - (let ((window (get-buffer-window (current-buffer) 0))) - (if window - (set-window-margins - window left-margin-width right-margin-width))))) - (gdb-put-string - (propertize putstring - 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled)) - (1+ start))))) - -(defun gdb-remove-breakpoint-icons (start end &optional remove-margin) - (gdb-remove-strings start end) - (if (display-images-p) - (remove-images start end)) - (when remove-margin - (setq left-margin-width 0) - (let ((window (get-buffer-window (current-buffer) 0))) - (if window - (set-window-margins - window left-margin-width right-margin-width))))) - -(provide 'gdb-mi) - -;; arch-tag: 1b41ea2b-f364-4cec-8f35-e02e4fe01912 -;;; gdb-mi.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/progmodes/gdb-ui.el Tue Dec 29 20:22:00 2009 +1300 @@ -0,0 +1,4129 @@ +;;; gdb-ui.el --- User Interface for running GDB + +;; Author: Nick Roberts <nickrob@gnu.org> +;; Maintainer: FSF +;; Keywords: unix, tools + +;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 +;; Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This mode acts as a graphical user interface to GDB. You can interact with +;; GDB through the GUD buffer in the usual way, but there are also further +;; buffers which control the execution and describe the state of your program. +;; It separates the input/output of your program from that of GDB, if +;; required, and watches expressions in the speedbar. It also uses features of +;; Emacs 21 such as the fringe/display margin for breakpoints, and the toolbar +;; (see the GDB Graphical Interface section in the Emacs info manual). + +;; By default, M-x gdb will start the debugger. + +;; This file has evolved from gdba.el that was included with GDB 5.0 and +;; written by Tom Lord and Jim Kingdon. It uses GDB's annotation interface. +;; You don't need to know about annotations to use this mode as a debugger, +;; but if you are interested developing the mode itself, see the Annotations +;; section in the GDB info manual. + +;; GDB developers plan to make the annotation interface obsolete. A new +;; interface called GDB/MI (machine interface) has been designed to replace it. +;; Some GDB/MI commands are used in this file through the CLI command +;; 'interpreter mi <mi-command>'. To help with the process of fully migrating +;; Emacs from annotations to GDB/MI, there is an experimental package called +;; gdb-mi in the Emacs Lisp Package Archive ("http://tromey.com/elpa/"). It +;; comprises of modified gud.el and a file called gdb-mi.el which replaces +;; gdb-ui.el. When installed, this overrides the current files and invoking +;; M-x gdb will use GDB/MI directly (starts with "gdb -i=mi"). When deleted +;; ('d' followed by 'x' in Package Menu mode), the files are deleted and old +;; functionality restored. This provides a convenient way to review the +;; current status/contribute to its improvement. For someone who just wants to +;; use GDB, however, the current mode in Emacs 22 is a much better option. +;; There is also a file, also called gdb-mi.el, a version of which is included +;; the GDB distribution. This will probably only work with versions +;; distributed with GDB 6.5 or later. Unlike the version in ELPA it works on +;; top of gdb-ui.el and you can only start it with M-x gdbmi. + +;; This mode SHOULD WORK WITH GDB 5.0 or later but you will NEED AT LEAST +;; GDB 6.0 to use watch expressions. It works best with GDB 6.4 or later +;; where watch expressions will update more quickly. + +;;; Windows Platforms: + +;; If you are using Emacs and GDB on Windows you will need to flush the buffer +;; explicitly in your program if you want timely display of I/O in Emacs. +;; Alternatively you can make the output stream unbuffered, for example, by +;; using a macro: + +;; #ifdef UNBUFFERED +;; setvbuf (stdout, (char *) NULL, _IONBF, 0); +;; #endif + +;; and compiling with -DUNBUFFERED while debugging. + +;; If you are using Cygwin GDB and find that the source is not being displayed +;; in Emacs when you step through it, possible solutions are to: + +;; 1) Use Cygwin X Windows and Cygwin Emacs. +;; (Since 22.1 Emacs builds under Cygwin.) +;; 2) Use MinGW GDB instead. +;; 3) Use cygwin-mount.el + +;;; Mac OSX: + +;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made +;; some changes to the version that they include as part of Mac OSX. +;; This requires GDB version 7.0 or later (estimated release date June 2009) +;; as earlier versions don not compile on Mac OSX. + +;;; Known Bugs: + +;; 1) Cannot handle multiple debug sessions. +;; 2) If you wish to call procedures from your program in GDB +;; e.g "call myproc ()", "p mysquare (5)" then use level 2 annotations +;; "gdb --annotate=2 myprog" to keep source buffer/selected frame fixed. +;; 3) After detaching from a process, clicking on the "GO" icon on toolbar +;; (gud-go) sends "continue" to GDB (should be "run"). + +;;; TODO: + +;; 1) Use MI command -data-read-memory for memory window. +;; 2) Use tree-buffer.el (from ECB) instead of the speedbar for +;; watch-expressions? Handling of watch-expressions needs to be +;; overhauled to work for large arrays/structures by creating variable +;; objects for visible watch-expressions only. +;; 3) Mark breakpoint locations on scroll-bar of source buffer? + +;;; Code: + +(require 'gud) +(require 'json) +(require 'bindat) + +(defvar tool-bar-map) +(defvar speedbar-initial-expansion-list-name) +(defvar speedbar-frame) + +(defvar gdb-pc-address nil "Initialization for Assembler buffer. +Set to \"main\" at start if `gdb-show-main' is t.") +(defvar gdb-frame-address nil "Identity of frame for watch expression.") +(defvar gdb-previous-frame-pc-address nil) +(defvar gdb-memory-address "main") +(defvar gdb-previous-frame nil) +(defvar gdb-selected-frame nil) +(defvar gdb-frame-number nil) +(defvar gdb-current-language nil) +(defvar gdb-var-list nil + "List of variables in watch window. +Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP) +where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame +address for root variables.") +(defvar gdb-main-file nil "Source file from which program execution begins.") +(defvar gud-old-arrow nil) +(defvar gdb-thread-indicator nil) +(defvar gdb-overlay-arrow-position nil) +(defvar gdb-stack-position nil) +(defvar gdb-server-prefix nil) +(defvar gdb-flush-pending-output nil) +(defvar gdb-location-alist nil + "Alist of breakpoint numbers and full filenames. Only used for files that +Emacs can't find.") +(defvar gdb-active-process nil + "GUD tooltips display variable values when t, and macro definitions otherwise.") +(defvar gdb-recording nil + "If t, then record session for playback and reverse execution") +(defvar gdb-error "Non-nil when GDB is reporting an error.") +(defvar gdb-macro-info nil + "Non-nil if GDB knows that the inferior includes preprocessor macro info.") +(defvar gdb-buffer-fringe-width nil) +(defvar gdb-signalled nil) +(defvar gdb-source-window nil) +(defvar gdb-inferior-status nil) +(defvar gdb-continuation nil) +(defvar gdb-look-up-stack nil) +(defvar gdb-frame-begin nil + "Non-nil when GDB generates frame-begin annotation.") +(defvar gdb-printing t) +(defvar gdb-parent-bptno-enabled nil) +(defvar gdb-ready nil) +(defvar gdb-stack-update nil) +(defvar gdb-early-user-input nil) + +(defvar gdb-buffer-type nil + "One of the symbols bound in `gdb-buffer-rules'.") +(make-variable-buffer-local 'gdb-buffer-type) + +(defvar gdb-input-queue () + "A list of gdb command objects.") + +(defvar gdb-prompting nil + "True when gdb is idle with no pending input.") + +(defvar gdb-output-sink nil + "The disposition of the output of the current gdb command. +Possible values are these symbols: + + `user' -- gdb output should be copied to the GUD buffer + for the user to see. + + `inferior' -- gdb output should be copied to the inferior-io buffer. + + `pre-emacs' -- output should be ignored util the post-prompt + annotation is received. Then the output-sink + becomes:... + `emacs' -- output should be collected in the partial-output-buffer + for subsequent processing by a command. This is the + disposition of output generated by commands that + gdb mode sends to gdb on its own behalf. + `post-emacs' -- ignore output until the prompt annotation is + received, then go to USER disposition. + +gdba (gdb-ui.el) uses all five values, gdbmi (gdb-mi.el) only two +\(`user' and `emacs').") + +(defvar gdb-current-item nil + "The most recent command item sent to gdb.") + +(defvar gdb-pending-triggers '() + "A list of trigger functions that have run later than their output handlers.") + +(defvar gdb-first-post-prompt nil) +(defvar gdb-version nil) +(defvar gdb-locals-font-lock-keywords nil) +(defvar gdb-source-file-list nil + "List of source files for the current executable.") +(defconst gdb-error-regexp "\\^error,msg=\"\\(.+\\)\"") + +(defvar gdb-locals-font-lock-keywords-1 + '(;; var = (struct struct_tag) value + ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(struct\\) \\(\\(\\sw\\|[_.]\\)+\\)" + (1 font-lock-variable-name-face) + (3 font-lock-keyword-face) + (4 font-lock-type-face)) + ;; var = (type) value + ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(\\(\\sw\\|[_.]\\)+\\)" + (1 font-lock-variable-name-face) + (3 font-lock-type-face)) + ;; var = val + ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +[^(]" + (1 font-lock-variable-name-face))) + "Font lock keywords used in `gdb-local-mode'.") + +(defvar gdb-locals-font-lock-keywords-2 + '(;; var = type value + ( "\\(^\\(\\sw\\|[_.]\\)+\\)\t+\\(\\(\\sw\\|[_.]\\)+\\)" + (1 font-lock-variable-name-face) + (3 font-lock-type-face))) + "Font lock keywords used in `gdb-local-mode'.") + +;; Variables for GDB 6.4+ +(defvar gdb-register-names nil "List of register names.") +(defvar gdb-changed-registers nil + "List of changed register numbers (strings).") + +;;;###autoload +(defun gdb (command-line) + "Run gdb on program FILE in buffer *gud-FILE*. +The directory containing FILE becomes the initial working +directory and source-file directory for your debugger. + +If `gdb-many-windows' is nil (the default value) then gdb just +pops up the GUD buffer unless `gdb-show-main' is t. In this case +it starts with two windows: one displaying the GUD buffer and the +other with the source file with the main routine of the inferior. + +If `gdb-many-windows' is t, regardless of the value of +`gdb-show-main', the layout below will appear unless +`gdb-use-separate-io-buffer' is nil when the source buffer +occupies the full width of the frame. Keybindings are shown in +some of the buffers. + +Watch expressions appear in the speedbar/slowbar. + +The following commands help control operation : + +`gdb-many-windows' - Toggle the number of windows gdb uses. +`gdb-restore-windows' - To restore the window layout. + +See Info node `(emacs)GDB Graphical Interface' for a more +detailed description of this mode. + ++----------------------------------------------------------------------+ +| GDB Toolbar | ++-----------------------------------+----------------------------------+ +| GUD buffer (I/O of GDB) | Locals buffer | +|-----------------------------------+----------------------------------+ +| | | +| Source buffer | I/O buffer for debugged program | +| | | +|-----------------------------------+----------------------------------+ +| Stack buffer | Breakpoints/threads buffer | ++-----------------------------------+----------------------------------+ + +The option \"--annotate=3\" must be included in this value. To +run GDB in text command mode, use `gud-gdb'. You need to use +text command mode to debug multiple programs within one Emacs +session." + (interactive (list (gud-query-cmdline 'gdb))) + + (when (and gud-comint-buffer + (buffer-name gud-comint-buffer) + (get-buffer-process gud-comint-buffer) + (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) + (gdb-restore-windows) + (error + "Multiple debugging requires restarting in text command mode")) + + (gud-common-init command-line nil 'gud-gdba-marker-filter) + (set (make-local-variable 'gud-minor-mode) 'gdba) + (setq comint-input-sender 'gdb-send) + + (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") + (gud-def gud-tbreak "tbreak %f:%l" "\C-t" + "Set temporary breakpoint at current line.") + (gud-def gud-remove "clear %f:%l" "\C-d" "Remove breakpoint at current line.") + (gud-def gud-step "step %p" "\C-s" "Step one source line with display.") + (gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.") + (gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).") + (gud-def gud-nexti "nexti %p" nil "Step one instruction (skip functions).") + (gud-def gud-cont "continue" "\C-r" "Continue with display.") + (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") + (gud-def gud-jump + (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) + "\C-j" "Set execution address to current line.") + + (gud-def gud-rstep "reverse-step %p" nil "Reverse step one source line with display.") + (gud-def gud-rstepi "reverse-stepi %p" nil "Reverse step one instruction with display.") + (gud-def gud-rnext "reverse-next %p" nil "Reverse step one line (skip functions).") + (gud-def gud-rnexti "reverse-nexti %p" nil "Reverse step one instruction (skip functions).") + (gud-def gud-rcont "reverse-continue" nil "Reverse continue with display.") + (gud-def gud-rfinish "reverse-finish" nil "Reverse finish executing current function.") + + (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") + (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") + (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") + (gud-def gud-pstar "print* %e" nil + "Evaluate C dereferenced pointer expression at point.") + + ;; For debugging Emacs only. + (gud-def gud-pv "pv1 %e" "\C-v" "Print the value of the lisp variable.") + + (gud-def gud-until "until %l" "\C-u" "Continue to current line.") + (gud-def gud-run "run" nil "Run the program.") + + (local-set-key "\C-i" 'gud-gdb-complete-command) + (setq comint-prompt-regexp "^(.*gdb[+]?) *") + (setq paragraph-start comint-prompt-regexp) + (setq gdb-output-sink 'user) + (setq gdb-first-prompt t) + (setq gud-running nil) + (setq gdb-ready nil) + (setq gdb-stack-update nil) + (setq gdb-flush-pending-output nil) + (setq gdb-early-user-input nil) + (setq gud-filter-pending-text nil) + (gdb-thread-identification) + (run-hooks 'gdb-mode-hook)) + +;; Keep as an alias for compatibility with Emacs 22.1. +;;;###autoload +(defalias 'gdba 'gdb) + +(defgroup gdb nil + "Gdb Graphical Mode options specifically for running Gdb in Emacs." + :group 'processes + :group 'tools) + +(defcustom gdb-debug-log-max 128 + "Maximum size of `gdb-debug-log'. If nil, size is unlimited." + :group 'gdb + :type '(choice (integer :tag "Number of elements") + (const :tag "Unlimited" nil)) + :version "22.1") + +(defvar gdb-debug-log nil + "List of commands sent to and replies received from GDB. +Most recent commands are listed first. This list stores only the last +`gdb-debug-log-max' values. This variable is used to debug GDB-UI.") + +;;;###autoload +(defcustom gdb-enable-debug nil + "Non-nil means record the process input and output in `gdb-debug-log'." + :type 'boolean + :group 'gdb + :version "22.1") + +(defcustom gdb-cpp-define-alist-program "gcc -E -dM -" + "Shell command for generating a list of defined macros in a source file. +This list is used to display the #define directive associated +with an identifier as a tooltip. It works in a debug session with +GDB, when `gud-tooltip-mode' is t. + +Set `gdb-cpp-define-alist-flags' for any include paths or +predefined macros." + :type 'string + :group 'gdb + :version "22.1") + +(defcustom gdb-cpp-define-alist-flags "" + "Preprocessor flags for `gdb-cpp-define-alist-program'." + :type 'string + :group 'gdb + :version "22.1") + +(defcustom gdb-create-source-file-list t + "Non-nil means create a list of files from which the executable was built. +Set this to nil if the GUD buffer displays \"initializing...\" in the mode +line for a long time when starting, possibly because your executable was +built from a large number of files. This allows quicker initialization +but means that these files are not automatically enabled for debugging, +e.g., you won't be able to click in the fringe to set a breakpoint until +execution has already stopped there." + :type 'boolean + :group 'gdb + :version "23.1") + +(defcustom gdb-show-main nil + "Non-nil means display source file containing the main routine at startup. +Also display the main routine in the disassembly buffer if present." + :type 'boolean + :group 'gdb + :version "22.1") + +(defcustom gdb-many-windows nil + "If nil, just pop up the GUD buffer unless `gdb-show-main' is t. +In this case start with two windows: one displaying the GUD +buffer and the other with the source file with the main routine +of the debugged program. Non-nil means display the layout shown +for `gdba'." + :type 'boolean + :group 'gdb + :version "22.1") + +(defcustom gdb-use-separate-io-buffer nil + "Non-nil means display output from the debugged program in a separate buffer." + :type 'boolean + :group 'gdb + :version "22.1") + +(defun gdb-force-mode-line-update (status) + (let ((buffer gud-comint-buffer)) + (if (and buffer (buffer-name buffer)) + (with-current-buffer buffer + (setq mode-line-process + (format ":%s [%s]" + (process-status (get-buffer-process buffer)) status)) + ;; Force mode line redisplay soon. + (force-mode-line-update))))) + +(defun gdb-enable-debug (arg) + "Toggle logging of transaction between Emacs and Gdb. +The log is stored in `gdb-debug-log' as an alist with elements +whose cons is send, send-item or recv and whose cdr is the string +being transferred. This list may grow up to a size of +`gdb-debug-log-max' after which the oldest element (at the end of +the list) is deleted every time a new one is added (at the front)." + (interactive "P") + (setq gdb-enable-debug + (if (null arg) + (not gdb-enable-debug) + (> (prefix-numeric-value arg) 0))) + (message (format "Logging of transaction %sabled" + (if gdb-enable-debug "en" "dis")))) + +(defun gdb-many-windows (arg) + "Toggle the number of windows in the basic arrangement. +With prefix argument ARG, display additional buffers if ARG is positive, +otherwise use a single window." + (interactive "P") + (setq gdb-many-windows + (if (null arg) + (not gdb-many-windows) + (> (prefix-numeric-value arg) 0))) + (message (format "Display of other windows %sabled" + (if gdb-many-windows "en" "dis"))) + (if (and gud-comint-buffer + (buffer-name gud-comint-buffer)) + (condition-case nil + (gdb-restore-windows) + (error nil)))) + +(defun gdb-use-separate-io-buffer (arg) + "Toggle separate IO for debugged program. +With prefix argument ARG, use separate IO if ARG is positive, +otherwise do not." + (interactive "P") + (setq gdb-use-separate-io-buffer + (if (null arg) + (not gdb-use-separate-io-buffer) + (> (prefix-numeric-value arg) 0))) + (message (format "Separate IO %sabled" + (if gdb-use-separate-io-buffer "en" "dis"))) + (if (and gud-comint-buffer + (buffer-name gud-comint-buffer)) + (condition-case nil + (if gdb-use-separate-io-buffer + (if gdb-many-windows (gdb-restore-windows)) + (kill-buffer (gdb-inferior-io-name))) + (error nil)))) + +(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.") + +(defun gdb-create-define-alist () + "Create an alist of #define directives for GUD tooltips." + (let* ((file (buffer-file-name)) + (output + (with-output-to-string + (with-current-buffer standard-output + (and file + (file-exists-p file) + ;; call-process doesn't work with remote file names. + (not (file-remote-p default-directory)) + (call-process shell-file-name file + (list t nil) nil "-c" + (concat gdb-cpp-define-alist-program " " + gdb-cpp-define-alist-flags)))))) + (define-list (split-string output "\n" t)) (name)) + (setq gdb-define-alist nil) + (dolist (define define-list) + (setq name (nth 1 (split-string define "[( ]"))) + (push (cons name define) gdb-define-alist)))) + +(declare-function tooltip-show "tooltip" (text &optional use-echo-area)) +(defvar tooltip-use-echo-area) + +(defun gdb-tooltip-print (expr) + (tooltip-show + (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) + (goto-char (point-min)) + (let ((string + (if (search-forward "=" nil t) + (concat expr (buffer-substring (- (point) 2) (point-max))) + (buffer-string)))) + ;; remove newline for gud-tooltip-echo-area + (substring string 0 (- (length string) 1)))) + (or gud-tooltip-echo-area tooltip-use-echo-area + (not (display-graphic-p))))) + +;; If expr is a macro for a function don't print because of possible dangerous +;; side-effects. Also printing a function within a tooltip generates an +;; unexpected starting annotation (phase error). +(defun gdb-tooltip-print-1 (expr) + (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) + (goto-char (point-min)) + (if (search-forward "expands to: " nil t) + (unless (looking-at "\\S-+.*(.*).*") + (gdb-enqueue-input + (list (concat gdb-server-prefix "print " expr "\n") + `(lambda () (gdb-tooltip-print ,expr)))))))) + +(defconst gdb-source-file-regexp "\\(.+?\\), \\|\\([^, \n].*$\\)") + +(defun gdb-init-buffer () + (set (make-local-variable 'gud-minor-mode) + (buffer-local-value 'gud-minor-mode gud-comint-buffer)) + (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) + (when gud-tooltip-mode + (make-local-variable 'gdb-define-alist) + (gdb-create-define-alist) + (add-hook 'after-save-hook 'gdb-create-define-alist nil t))) + +(defun gdb-set-gud-minor-mode-existing-buffers () + "Create list of source files for current GDB session." + (goto-char (point-min)) + (when (search-forward "read in on demand:" nil t) + (while (re-search-forward gdb-source-file-regexp nil t) + (push (file-name-nondirectory (or (match-string 1) (match-string 2))) + gdb-source-file-list)) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (and buffer-file-name + (member (file-name-nondirectory buffer-file-name) + gdb-source-file-list)) + (gdb-init-buffer))))) + (gdb-force-mode-line-update + (propertize "ready" 'face font-lock-variable-name-face))) + +(defun gdb-find-watch-expression () + (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list)) + (varnum (car var)) expr array) + (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum) + (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet + (component-list (split-string (match-string 2 varnum) "\\." t))) + (setq expr (nth 1 var1)) + (setq varnumlet (car var1)) + (dolist (component component-list) + (setq var2 (assoc varnumlet gdb-var-list)) + (setq expr (concat expr + (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2)) + (concat "[" component "]") + (concat "." component)))) + (setq varnumlet (concat varnumlet "." component))) + expr))) + +(defun gdb-toggle-recording () +"Start/stop recording of debug session." + (interactive) + (if gud-running + (message-box "Recording cannot be started or stopped while your program is still running") + (gdb-enqueue-input + (list (concat gdb-server-prefix + (if gdb-recording "record stop\n" "target record\n")) + 'gdb-recording-handler)))) + +;; Convenience function for tool bar. +(defalias 'gdb-toggle-recording-1 'gdb-toggle-recording) + +(defun gdb-recording-handler () + (goto-char (point-min)) + (if (re-search-forward "current architecture doesn't support record function" nil t) + (message-box "Not enabled. The current architecture doesn't support the process record function.") + (goto-char (point-min)) + (if (re-search-forward "Undefined target command" nil t) + (message-box "Not enabled. Process record requires GDB 7.0 onwards.") + (goto-char (point-min)) + (if (re-search-forward "the program is not being run" nil t) + (message-box "Not enabled. Starting process recording requires an active target (running process).") + (setq gdb-recording (not gdb-recording)) + ;; Actually forcing the tool-bar to update. + (force-mode-line-update))))) + +(defun gdb-init-1 () + (gud-def gud-break (if (not (string-match "Machine" mode-name)) + (gud-call "break %f:%l" arg) + (save-excursion + (beginning-of-line) + (forward-char 2) + (gud-call "break *%a" arg))) + "\C-b" "Set breakpoint at current line or address.") + ;; + (gud-def gud-remove (if (not (string-match "Machine" mode-name)) + (gud-call "clear %f:%l" arg) + (save-excursion + (beginning-of-line) + (forward-char 2) + (gud-call "clear *%a" arg))) + "\C-d" "Remove breakpoint at current line or address.") + ;; + (gud-def gud-until (if (not (string-match "Machine" mode-name)) + (gud-call "until %f:%l" arg) + (save-excursion + (beginning-of-line) + (forward-char 2) + (gud-call "until *%a" arg))) + "\C-u" "Continue to current line or address.") + ;; + (gud-def gud-go (gud-call (if gdb-active-process "continue" "run") arg) + nil "Start or continue execution.") + + ;; For debugging Emacs only. + (gud-def gud-pp + (gud-call + (concat + "pp1 " (if (eq (buffer-local-value + 'major-mode (window-buffer)) 'speedbar-mode) + (gdb-find-watch-expression) "%e")) arg) + nil "Print the Emacs s-expression.") + + (define-key gud-minor-mode-map [left-margin mouse-1] + 'gdb-mouse-set-clear-breakpoint) + (define-key gud-minor-mode-map [left-fringe mouse-1] + 'gdb-mouse-set-clear-breakpoint) + (define-key gud-minor-mode-map [left-margin C-mouse-1] + 'gdb-mouse-toggle-breakpoint-margin) + (define-key gud-minor-mode-map [left-fringe C-mouse-1] + 'gdb-mouse-toggle-breakpoint-fringe) + + (define-key gud-minor-mode-map [left-margin drag-mouse-1] + 'gdb-mouse-until) + (define-key gud-minor-mode-map [left-fringe drag-mouse-1] + 'gdb-mouse-until) + (define-key gud-minor-mode-map [left-margin mouse-3] + 'gdb-mouse-until) + (define-key gud-minor-mode-map [left-fringe mouse-3] + 'gdb-mouse-until) + + (define-key gud-minor-mode-map [left-margin C-drag-mouse-1] + 'gdb-mouse-jump) + (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1] + 'gdb-mouse-jump) + (define-key gud-minor-mode-map [left-fringe C-mouse-3] + 'gdb-mouse-jump) + (define-key gud-minor-mode-map [left-margin C-mouse-3] + 'gdb-mouse-jump) + + ;; (re-)initialize + (setq gdb-pc-address (if gdb-show-main "main" nil)) + (setq gdb-previous-frame-pc-address nil + gdb-memory-address "main" + gdb-previous-frame nil + gdb-selected-frame nil + gdb-current-language nil + gdb-frame-number nil + gdb-var-list nil + gdb-main-file nil + gdb-first-post-prompt t + gdb-prompting nil + gdb-input-queue nil + gdb-current-item nil + gdb-pending-triggers nil + gdb-output-sink 'user + gdb-server-prefix "server " + gdb-location-alist nil + gdb-source-file-list nil + gdb-error nil + gdb-macro-info nil + gdb-buffer-fringe-width (car (window-fringes)) + gdb-debug-log nil + gdb-signalled nil + gdb-source-window nil + gdb-inferior-status nil + gdb-continuation nil + gdb-look-up-stack nil + gdb-frame-begin nil + gdb-printing t + gud-old-arrow nil + gdb-thread-indicator nil + gdb-register-names nil + gdb-recording nil) + + (setq gdb-buffer-type 'gdba) + + (if gdb-use-separate-io-buffer (gdb-clear-inferior-io)) + + ;; Hack to see test for GDB 6.4+ (-stack-info-frame was implemented in 6.4) + (gdb-enqueue-input (list "server interpreter mi -stack-info-frame\n" + 'gdb-get-version))) + +(defun gdb-init-2 () + (if (eq window-system 'w32) + (gdb-enqueue-input (list "set new-console off\n" 'ignore))) + (gdb-enqueue-input (list "set height 0\n" 'ignore)) + (gdb-enqueue-input (list "set width 0\n" 'ignore)) + + (if (string-equal gdb-version "pre-6.4") + (if gdb-create-source-file-list + (gdb-enqueue-input (list (concat gdb-server-prefix "info sources\n") + 'gdb-set-gud-minor-mode-existing-buffers)) + (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-1)) + ; Needs GDB 6.2 onwards. + (if gdb-create-source-file-list + (gdb-enqueue-input + (list "server interpreter mi \"-file-list-exec-source-files\"\n" + 'gdb-set-gud-minor-mode-existing-buffers-1))) + (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-2) + ; Needs GDB 7.0 onwards. + (gdb-enqueue-input + (list "server interpreter mi -enable-pretty-printing\n" 'ignore))) + + ;; Find source file and compilation directory here. + ;; Works for C, C++, Fortran and Ada but not Java (GDB 6.4) + (gdb-enqueue-input (list "server list\n" 'ignore)) + (gdb-enqueue-input (list "server list MAIN__\n" 'ignore)) + (gdb-enqueue-input (list "server info source\n" 'gdb-source-info))) + +(defun gdb-get-version () + (goto-char (point-min)) + (if (re-search-forward "Undefined\\( mi\\)* command:" nil t) + (setq gdb-version "pre-6.4") + (setq gdb-version "6.4+")) + (gdb-init-2)) + +(defmacro gdb-if-arrow (arrow-position &rest body) + `(if ,arrow-position + (let ((buffer (marker-buffer ,arrow-position)) (line)) + (if (equal buffer (window-buffer (posn-window end))) + (with-current-buffer buffer + (when (or (equal start end) + (equal (posn-point start) + (marker-position ,arrow-position))) + ,@body)))))) + +(defun gdb-mouse-until (event) + "Continue running until a source line past the current line. +The destination source line can be selected either by clicking +with mouse-3 on the fringe/margin or dragging the arrow +with mouse-1 (default bindings)." + (interactive "e") + (let ((start (event-start event)) + (end (event-end event))) + (gdb-if-arrow gud-overlay-arrow-position + (setq line (line-number-at-pos (posn-point end))) + (gud-call (concat "until " (number-to-string line)))) + (gdb-if-arrow gdb-overlay-arrow-position + (save-excursion + (goto-char (point-min)) + (forward-line (1- (line-number-at-pos (posn-point end)))) + (forward-char 2) + (gud-call (concat "until *%a")))))) + +(defun gdb-mouse-jump (event) + "Set execution address/line. +The destination source line can be selected either by clicking with C-mouse-3 +on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings). +Unlike `gdb-mouse-until' the destination address can be before the current +line, and no execution takes place." + (interactive "e") + (let ((start (event-start event)) + (end (event-end event))) + (gdb-if-arrow gud-overlay-arrow-position + (setq line (line-number-at-pos (posn-point end))) + (progn + (gud-call (concat "tbreak " (number-to-string line))) + (gud-call (concat "jump " (number-to-string line))))) + (gdb-if-arrow gdb-overlay-arrow-position + (save-excursion + (goto-char (point-min)) + (forward-line (1- (line-number-at-pos (posn-point end)))) + (forward-char 2) + (progn + (gud-call (concat "tbreak *%a")) + (gud-call (concat "jump *%a"))))))) + +(defcustom gdb-speedbar-auto-raise nil + "If non-nil raise speedbar every time display of watch expressions is\ + updated." + :type 'boolean + :group 'gdb + :version "22.1") + +(defun gdb-speedbar-auto-raise (arg) + "Toggle automatic raising of the speedbar for watch expressions. +With prefix argument ARG, automatically raise speedbar if ARG is +positive, otherwise don't automatically raise it." + (interactive "P") + (setq gdb-speedbar-auto-raise + (if (null arg) + (not gdb-speedbar-auto-raise) + (> (prefix-numeric-value arg) 0))) + (message (format "Auto raising %sabled" + (if gdb-speedbar-auto-raise "en" "dis")))) + +(defcustom gdb-use-colon-colon-notation nil + "If non-nil use FUN::VAR format to display variables in the speedbar." + :type 'boolean + :group 'gdb + :version "22.1") + +(define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch) +(define-key global-map (concat gud-key-prefix "\C-w") 'gud-watch) + +(declare-function tooltip-identifier-from-point "tooltip" (point)) + +(defun gud-watch (&optional arg event) + "Watch expression at point. +With arg, enter name of variable to be watched in the minibuffer." + (interactive (list current-prefix-arg last-input-event)) + (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer))) + (if (memq minor-mode '(gdbmi gdba)) + (progn + (if event (posn-set-point (event-end event))) + (require 'tooltip) + (save-selected-window + (let ((expr + (if arg + (completing-read "Name of variable: " + 'gud-gdb-complete-command) + (if (and transient-mark-mode mark-active) + (buffer-substring (region-beginning) (region-end)) + (concat (if (eq major-mode 'gdb-registers-mode) "$") + (tooltip-identifier-from-point (point))))))) + (set-text-properties 0 (length expr) nil expr) + (gdb-enqueue-input + (list + (if (eq minor-mode 'gdba) + (concat + "server interpreter mi \"-var-create - * " expr "\"\n") + (concat"-var-create - * " expr "\n")) + `(lambda () (gdb-var-create-handler ,expr))))))) + (message "gud-watch is a no-op in this mode.")))) + +(defun gdb-var-create-handler (expr) + (let* ((result (gdb-json-partial-output))) + (if (not (bindat-get-field result 'msg)) + (let ((var + (list (bindat-get-field result 'name) + (if (and (string-equal gdb-current-language "c") + gdb-use-colon-colon-notation gdb-selected-frame) + (setq expr (concat gdb-selected-frame "::" expr)) + expr) + (bindat-get-field result 'numchild) + (bindat-get-field result 'type) + (bindat-get-field result 'value) + nil + (bindat-get-field result 'has_more) + gdb-frame-address))) + (push var gdb-var-list) + (speedbar 1) + (unless (string-equal + speedbar-initial-expansion-list-name "GUD") + (speedbar-change-initial-expansion-list "GUD"))) + (message-box "No symbol \"%s\" in current context." expr)))) + +(defun gdb-speedbar-update () + (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame) + (not (member 'gdb-speedbar-timer gdb-pending-triggers))) + ;; Dummy command to update speedbar even when idle. + (gdb-enqueue-input (list "server pwd\n" 'gdb-speedbar-timer-fn)) + ;; Keep gdb-pending-triggers non-nil till end. + (push 'gdb-speedbar-timer gdb-pending-triggers))) + +(defun gdb-speedbar-timer-fn () + (if gdb-speedbar-auto-raise + (raise-frame speedbar-frame)) + (setq gdb-pending-triggers + (delq 'gdb-speedbar-timer gdb-pending-triggers)) + (speedbar-timer-fn)) + +(defun gdb-var-evaluate-expression-handler (varnum changed) + (goto-char (point-min)) + (re-search-forward "\\(.+\\)\\^done,value=\\(\".*\"\\)" nil t) + (setq gdb-pending-triggers + (delq (string-to-number (match-string 1)) gdb-pending-triggers)) + (let ((var (assoc varnum gdb-var-list))) + (when var + (if changed (setcar (nthcdr 5 var) 'changed)) + (setcar (nthcdr 4 var) (read (match-string 2))))) + (gdb-speedbar-update)) + +(defun gdb-var-list-children (varnum) + (gdb-enqueue-input + (list (concat "server interpreter mi \"-var-list-children " varnum "\"\n") + `(lambda () (gdb-var-list-children-handler ,varnum))))) + +(defconst gdb-var-list-children-regexp + "child={.*?name=\"\\(.*?\\)\".*?,exp=\"\\(.*?\\)\".*?,\ +numchild=\"\\(.*?\\)\"\\(}\\|.*?,\\(type=\"\\(.*?\\)\"\\)?.*?}\\)") + +(defun gdb-var-list-children-handler (varnum) + (goto-char (point-min)) + (let ((var-list nil)) + (catch 'child-already-watched + (dolist (var gdb-var-list) + (if (string-equal varnum (car var)) + (progn + (push var var-list) + (while (re-search-forward gdb-var-list-children-regexp nil t) + (let ((varchild (list (match-string 1) + (match-string 2) + (match-string 3) + (match-string 6) + nil nil))) + (if (assoc (car varchild) gdb-var-list) + (throw 'child-already-watched nil)) + (push varchild var-list) + (gdb-enqueue-input + (list + (concat + "server interpreter mi \"0-var-evaluate-expression " + (car varchild) "\"\n") + `(lambda () (gdb-var-evaluate-expression-handler + ,(car varchild) nil))))))) + (push var var-list))) + (setq gdb-var-list (nreverse var-list))))) + +(defun gdb-var-update () + (when (not (member 'gdb-var-update gdb-pending-triggers)) + (gdb-enqueue-input + (list "server interpreter mi \"-var-update *\"\n" + 'gdb-var-update-handler)) + (push 'gdb-var-update gdb-pending-triggers))) + +(defconst gdb-var-update-regexp + "{.*?name=\"\\(.*?\\)\".*?,in_scope=\"\\(.*?\\)\".*?,\ +type_changed=\".*?\".*?}") + +(defun gdb-var-update-handler () + (dolist (var gdb-var-list) + (setcar (nthcdr 5 var) nil)) + (goto-char (point-min)) + (let ((n 0)) + (while (re-search-forward gdb-var-update-regexp nil t) + (let ((varnum (match-string 1))) + (if (string-equal (match-string 2) "false") + (let ((var (assoc varnum gdb-var-list))) + (if var (setcar (nthcdr 5 var) 'out-of-scope))) + (setq n (1+ n)) + (push n gdb-pending-triggers) + (gdb-enqueue-input + (list + (concat "server interpreter mi \"" (number-to-string n) + "-var-evaluate-expression " varnum "\"\n") + `(lambda () (gdb-var-evaluate-expression-handler ,varnum t)))))))) + (setq gdb-pending-triggers + (delq 'gdb-var-update gdb-pending-triggers))) + +(defun gdb-var-set-format (format) + "Set the output format for a variable displayed in the speedbar." + (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) + (varnum (car var))) + (gdb-enqueue-input + (list + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + (concat "server interpreter mi \"-var-set-format " + varnum " " format "\"\n") + (concat "-var-set-format " varnum " " format "\n")) + `(lambda () (gdb-var-set-format-handler ,varnum)))))) + +(defconst gdb-var-set-format-regexp + "format=\"\\(.*?\\)\",.*value=\"\\(.*?\\)\"") + +(defun gdb-var-set-format-handler (varnum) + (goto-char (point-min)) + (if (re-search-forward gdb-var-set-format-regexp nil t) + (let ((var (assoc varnum gdb-var-list))) + (setcar (nthcdr 4 var) (match-string 2)) + (gdb-var-update-1)))) + +(defun gdb-var-delete-1 (var varnum) + (gdb-enqueue-input + (list + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + (concat "server interpreter mi \"-var-delete " varnum "\"\n") + (concat "-var-delete " varnum "\n")) + 'ignore)) + (setq gdb-var-list (delq var gdb-var-list)) + (dolist (varchild gdb-var-list) + (if (string-match (concat (car var) "\\.") (car varchild)) + (setq gdb-var-list (delq varchild gdb-var-list))))) + +(defun gdb-var-delete () + "Delete watch expression at point from the speedbar." + (interactive) + (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdbmi gdba)) + (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) + (varnum (car var))) + (if (string-match "\\." (car var)) + (message-box "Can only delete a root expression") + (gdb-var-delete-1 var varnum))))) + +(defun gdb-var-delete-children (varnum) + "Delete children of variable object at point from the speedbar." + (gdb-enqueue-input + (list + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + (concat "server interpreter mi \"-var-delete -c " varnum "\"\n") + (concat "-var-delete -c " varnum "\n")) 'ignore))) + +(defun gdb-edit-value (text token indent) + "Assign a value to a variable displayed in the speedbar." + (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) + (varnum (car var)) (value)) + (setq value (read-string "New value: ")) + (gdb-enqueue-input + (list + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + (concat "server interpreter mi \"-var-assign " + varnum " " value "\"\n") + (concat "-var-assign " varnum " " value "\n")) + `(lambda () (gdb-edit-value-handler ,value)))))) + +(defun gdb-edit-value-handler (value) + (goto-char (point-min)) + (if (re-search-forward gdb-error-regexp nil t) + (message-box "Invalid number or expression (%s)" value))) + +(defcustom gdb-show-changed-values t + "If non-nil change the face of out of scope variables and changed values. +Out of scope variables are suppressed with `shadow' face. +Changed values are highlighted with the face `font-lock-warning-face'." + :type 'boolean + :group 'gdb + :version "22.1") + +(defcustom gdb-max-children 40 + "Maximum number of children before expansion requires confirmation." + :type 'integer + :group 'gdb + :version "22.1") + +(defcustom gdb-delete-out-of-scope t + "If non-nil delete watch expressions automatically when they go out of scope." + :type 'boolean + :group 'gdb + :version "22.2") + +(defun gdb-speedbar-expand-node (text token indent) + "Expand the node the user clicked on. +TEXT is the text of the button we clicked on, a + or - item. +TOKEN is data related to this node. +INDENT is the current indentation depth." + (if (and gud-comint-buffer (buffer-name gud-comint-buffer)) + (progn + (cond ((string-match "+" text) ;expand this node + (let* ((var (assoc token gdb-var-list)) + (expr (nth 1 var)) (children (nth 2 var))) + (if (or (<= (string-to-number children) gdb-max-children) + (y-or-n-p + (format + "%s has %s children. Continue? " expr children))) + (if (and (eq (buffer-local-value + 'gud-minor-mode gud-comint-buffer) 'gdba) + (string-equal gdb-version "pre-6.4")) + (gdb-var-list-children token) + (gdb-var-list-children-1 token))))) + ((string-match "-" text) ;contract this node + (dolist (var gdb-var-list) + (if (string-match (concat token "\\.") (car var)) + (setq gdb-var-list (delq var gdb-var-list)))) + (gdb-var-delete-children token) + (speedbar-change-expand-button-char ?+) + (speedbar-delete-subblock indent)) + (t (error "Ooops... not sure what to do"))) + (speedbar-center-buffer-smartly)) + (message-box "GUD session has been killed"))) + +(defun gdb-get-target-string () + (with-current-buffer gud-comint-buffer + gud-target-name)) + + +;; +;; gdb buffers. +;; +;; Each buffer has a TYPE -- a symbol that identifies the function +;; of that particular buffer. +;; +;; The usual gdb interaction buffer is given the type `gdba' and +;; is constructed specially. +;; +;; Others are constructed by gdb-get-buffer-create and +;; named according to the rules set forth in the gdb-buffer-rules-assoc + +(defvar gdb-buffer-rules-assoc '()) + +(defun gdb-get-buffer (key) + "Return the gdb buffer tagged with type KEY. +The key should be one of the cars in `gdb-buffer-rules-assoc'." + (save-excursion + (gdb-look-for-tagged-buffer key (buffer-list)))) + +(defun gdb-get-buffer-create (key) + "Create a new gdb buffer of the type specified by KEY. +The key should be one of the cars in `gdb-buffer-rules-assoc'." + (or (gdb-get-buffer key) + (let* ((rules (assoc key gdb-buffer-rules-assoc)) + (name (funcall (gdb-rules-name-maker rules))) + (new (get-buffer-create name))) + (with-current-buffer new + (let ((trigger)) + (if (cdr (cdr rules)) + (setq trigger (funcall (car (cdr (cdr rules)))))) + (setq gdb-buffer-type key) + (set (make-local-variable 'gud-minor-mode) + (buffer-local-value 'gud-minor-mode gud-comint-buffer)) + (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) + (if trigger (funcall trigger))) + new)))) + +(defun gdb-rules-name-maker (rules) (car (cdr rules))) + +(defun gdb-look-for-tagged-buffer (key bufs) + (let ((retval nil)) + (while (and (not retval) bufs) + (set-buffer (car bufs)) + (if (eq gdb-buffer-type key) + (setq retval (car bufs))) + (setq bufs (cdr bufs))) + retval)) + +;; +;; This assoc maps buffer type symbols to rules. Each rule is a list of +;; at least one and possible more functions. The functions have these +;; roles in defining a buffer type: +;; +;; NAME - Return a name for this buffer type. +;; +;; The remaining function(s) are optional: +;; +;; MODE - called in a new buffer with no arguments, should establish +;; the proper mode for the buffer. +;; + +(defun gdb-set-buffer-rules (buffer-type &rest rules) + (let ((binding (assoc buffer-type gdb-buffer-rules-assoc))) + (if binding + (setcdr binding rules) + (push (cons buffer-type rules) + gdb-buffer-rules-assoc)))) + +;; GUD buffers are an exception to the rules +(gdb-set-buffer-rules 'gdba 'error) + +;; Partial-output buffer : This accumulates output from a command executed on +;; behalf of emacs (rather than the user). +;; +(gdb-set-buffer-rules 'gdb-partial-output-buffer + 'gdb-partial-output-name) + +(defun gdb-partial-output-name () + (concat " *partial-output-" + (gdb-get-target-string) + "*")) + + +(gdb-set-buffer-rules 'gdb-inferior-io + 'gdb-inferior-io-name + 'gdb-inferior-io-mode) + +(defun gdb-inferior-io-name () + (concat "*input/output of " + (gdb-get-target-string) + "*")) + +(defun gdb-display-separate-io-buffer () + "Display IO of debugged program in a separate window." + (interactive) + (if gdb-use-separate-io-buffer + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-inferior-io) t))) + +(defconst gdb-frame-parameters + '((height . 14) (width . 80) + (unsplittable . t) + (tool-bar-lines . nil) + (menu-bar-lines . nil) + (minibuffer . nil))) + +(defun gdb-frame-separate-io-buffer () + "Display IO of debugged program in a new frame." + (interactive) + (if gdb-use-separate-io-buffer + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create 'gdb-inferior-io))))) + +(defvar gdb-inferior-io-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-c" 'gdb-separate-io-interrupt) + (define-key map "\C-c\C-z" 'gdb-separate-io-stop) + (define-key map "\C-c\C-\\" 'gdb-separate-io-quit) + (define-key map "\C-c\C-d" 'gdb-separate-io-eof) + (define-key map "\C-d" 'gdb-separate-io-eof) + map)) + +(define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O" + "Major mode for gdb inferior-io." + :syntax-table nil :abbrev-table nil + ;; We want to use comint because it has various nifty and familiar + ;; features. We don't need a process, but comint wants one, so create + ;; a dummy one. + (make-comint-in-buffer + (substring (buffer-name) 1 (- (length (buffer-name)) 1)) + (current-buffer) "hexl") + (setq comint-input-sender 'gdb-inferior-io-sender)) + +(defun gdb-inferior-io-sender (proc string) + ;; PROC is the pseudo-process created to satisfy comint. + (with-current-buffer (process-buffer proc) + (setq proc (get-buffer-process gud-comint-buffer)) + (process-send-string proc string) + (process-send-string proc "\n"))) + +(defun gdb-separate-io-interrupt () + "Interrupt the program being debugged." + (interactive) + (interrupt-process + (get-buffer-process gud-comint-buffer) comint-ptyp)) + +(defun gdb-separate-io-quit () + "Send quit signal to the program being debugged." + (interactive) + (quit-process + (get-buffer-process gud-comint-buffer) comint-ptyp)) + +(defun gdb-separate-io-stop () + "Stop the program being debugged." + (interactive) + (stop-process + (get-buffer-process gud-comint-buffer) comint-ptyp)) + +(defun gdb-separate-io-eof () + "Send end-of-file to the program being debugged." + (interactive) + (process-send-eof + (get-buffer-process gud-comint-buffer))) + + +;; gdb communications +;; + +;; INPUT: things sent to gdb +;; +;; The queues are lists. Each element is either a string (indicating user or +;; user-like input) or a list of the form: +;; +;; (INPUT-STRING HANDLER-FN) +;; +;; The handler function will be called from the partial-output buffer when the +;; command completes. This is the way to write commands which invoke gdb +;; commands autonomously. +;; +;; These lists are consumed tail first. +;; + +(defun gdb-send (proc string) + "A comint send filter for gdb. +This filter may simply queue input for a later time." + (if gdb-ready + (progn + (with-current-buffer gud-comint-buffer + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(face)))) + (if gud-running + (progn + (let ((item (concat string "\n"))) + (if gdb-enable-debug (push (cons 'send item) gdb-debug-log)) + (process-send-string proc item))) + (if (string-match "\\\\\\'" string) + (setq gdb-continuation (concat gdb-continuation string "\n")) + (let ((item (concat + gdb-continuation string + (if (not comint-input-sender-no-newline) "\n")))) + (gdb-enqueue-input item) + (setq gdb-continuation nil))))) + (push (concat string "\n") gdb-early-user-input))) + +;; Note: Stuff enqueued here will be sent to the next prompt, even if it +;; is a query, or other non-top-level prompt. + +(defun gdb-enqueue-input (item) + (if (not gud-running) + (if gdb-prompting + (progn + (gdb-send-item item) + (setq gdb-prompting nil)) + (push item gdb-input-queue)))) + +(defun gdb-dequeue-input () + (let ((queue gdb-input-queue)) + (if queue + (let ((last (car (last queue)))) + (unless (nbutlast queue) (setq gdb-input-queue '())) + last) + ;; This should be nil here anyway but set it just to make sure. + (setq gdb-pending-triggers nil)))) + +(defun gdb-send-item (item) + (setq gdb-flush-pending-output nil) + (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log)) + (setq gdb-current-item item) + (let ((process (get-buffer-process gud-comint-buffer))) + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + (if (stringp item) + (progn + (setq gdb-output-sink 'user) + (process-send-string process item)) + (progn + (gdb-clear-partial-output) + (setq gdb-output-sink 'pre-emacs) + (process-send-string process + (car item)))) + ;; case: eq gud-minor-mode 'gdbmi + (gdb-clear-partial-output) + (setq gdb-output-sink 'emacs) + (process-send-string process (car item))))) + +;; +;; output -- things gdb prints to emacs +;; +;; GDB output is a stream interrupted by annotations. +;; Annotations can be recognized by their beginning +;; with \C-j\C-z\C-z<tag><opt>\C-j +;; +;; The tag is a string obeying symbol syntax. +;; +;; The optional part `<opt>' can be either the empty string +;; or a space followed by more data relating to the annotation. +;; For example, the SOURCE annotation is followed by a filename, +;; line number and various useless goo. This data must not include +;; any newlines. +;; + +(defcustom gud-gdb-command-name "gdb --annotate=3" + "Default command to execute an executable under the GDB debugger. +The option \"--annotate=3\" must be included in this value if you +want the GDB Graphical Interface." + :type 'string + :group 'gud + :version "22.1") + +(defvar gdb-annotation-rules + '(("pre-prompt" gdb-pre-prompt) + ("prompt" gdb-prompt) + ("commands" gdb-subprompt) + ("overload-choice" gdb-subprompt) + ("query" gdb-subprompt) + ;; Need this prompt for GDB 6.1 + ("nquery" gdb-subprompt) + ("prompt-for-continue" gdb-subprompt) + ("post-prompt" gdb-post-prompt) + ("source" gdb-source) + ("starting" gdb-starting) + ("exited" gdb-exited) + ("signalled" gdb-signalled) + ("signal" gdb-signal) + ("breakpoint" gdb-stopping) + ("watchpoint" gdb-stopping) + ("frame-begin" gdb-frame-begin) + ("stopped" gdb-stopped) + ("error-begin" gdb-error) + ("error" gdb-error) + ("new-thread" (lambda (ignored) + (gdb-get-buffer-create 'gdb-threads-buffer))) + ("thread-changed" gdb-thread-changed)) + "An assoc mapping annotation tags to functions which process them.") + +(defun gdb-resync() + (setq gdb-flush-pending-output t) + (setq gud-running nil) + (gdb-force-mode-line-update + (propertize "stopped" 'face font-lock-warning-face)) + (setq gdb-output-sink 'user) + (setq gdb-input-queue nil) + (setq gdb-pending-triggers nil) + (setq gdb-prompting t)) + +(defconst gdb-source-spec-regexp + "\\(.*\\):\\([0-9]*\\):[0-9]*:[a-z]*:0x0*\\([a-f0-9]*\\)") + +;; Do not use this except as an annotation handler. +(defun gdb-source (args) + (string-match gdb-source-spec-regexp args) + ;; Extract the frame position from the marker. + (setq gud-last-frame + (cons + (match-string 1 args) + (string-to-number (match-string 2 args)))) + (setq gdb-pc-address (match-string 3 args)) + ;; cover for auto-display output which comes *before* + ;; stopped annotation + (if (eq gdb-output-sink 'inferior) (setq gdb-output-sink 'user))) + +(defun gdb-pre-prompt (ignored) + "An annotation handler for `pre-prompt'. +This terminates the collection of output from a previous command if that +happens to be in effect." + (setq gdb-error nil) + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'user) t) + ((eq sink 'emacs) + (setq gdb-output-sink 'post-emacs)) + (t + (gdb-resync) + (error "Phase error in gdb-pre-prompt (got %s)" sink))))) + +(defun gdb-prompt (ignored) + "An annotation handler for `prompt'. +This sends the next command (if any) to gdb." + (when gdb-first-prompt + (gdb-force-mode-line-update + (propertize "initializing..." 'face font-lock-variable-name-face)) + (gdb-init-1) + (setq gdb-first-prompt nil)) + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'user) t) + ((eq sink 'post-emacs) + (setq gdb-output-sink 'user) + (let ((handler + (car (cdr gdb-current-item)))) + (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) + (funcall handler)))) + (t + (gdb-resync) + (error "Phase error in gdb-prompt (got %s)" sink)))) + (let ((input (gdb-dequeue-input))) + (if input + (gdb-send-item input) + (progn + (setq gdb-prompting t) + (gud-display-frame) + (setq gdb-early-user-input (nreverse gdb-early-user-input)) + (while gdb-early-user-input + (gdb-enqueue-input (car gdb-early-user-input)) + (setq gdb-early-user-input (cdr gdb-early-user-input))))))) + +(defun gdb-subprompt (ignored) + "An annotation handler for non-top-level prompts." + (setq gdb-prompting t)) + +(defun gdb-starting (ignored) + "An annotation handler for `starting'. +This says that I/O for the subprocess is now the program being debugged, +not GDB." + (setq gdb-active-process t) + (setq gdb-printing t) + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'user) + (progn + (setq gud-running t) + (setq gdb-stack-update t) + ;; Temporarily set gud-running to nil to force "info stack" onto queue. + (let ((gud-running nil)) + (gdb-invalidate-frames) + (unless (or gdb-register-names + (string-equal gdb-version "pre-6.4")) + (gdb-enqueue-input + (list "server interpreter mi -data-list-register-names\n" + 'gdb-get-register-names)))) + (setq gdb-inferior-status "running") + (setq gdb-signalled nil) + (gdb-force-mode-line-update + (propertize gdb-inferior-status 'face font-lock-type-face)) + (gdb-remove-text-properties) + (setq gud-old-arrow gud-overlay-arrow-position) + (setq gud-overlay-arrow-position nil) + (setq gdb-overlay-arrow-position nil) + (setq gdb-stack-position nil) + (if gdb-use-separate-io-buffer + (setq gdb-output-sink 'inferior)))) + (t + (gdb-resync) + (error "Unexpected `starting' annotation"))))) + +(defun gdb-signal (ignored) + (setq gdb-inferior-status "signal") + (gdb-force-mode-line-update + (propertize gdb-inferior-status 'face font-lock-warning-face)) + (gdb-stopping ignored)) + +(defun gdb-stopping (ignored) + "An annotation handler for `breakpoint' and other annotations. +They say that I/O for the subprocess is now GDB, not the program +being debugged." + (if gdb-use-separate-io-buffer + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'inferior) + (setq gdb-output-sink 'user)) + (t + (gdb-resync) + (error "Unexpected stopping annotation")))))) + +(defun gdb-exited (ignored) + "An annotation handler for `exited' and `signalled'. +They say that I/O for the subprocess is now GDB, not the program +being debugged and that the program is no longer running. This +function is used to change the focus of GUD tooltips to #define +directives." + (setq gdb-active-process nil) + (setq gud-overlay-arrow-position nil) + (setq gdb-overlay-arrow-position nil) + (setq gdb-stack-position nil) + (setq gud-old-arrow nil) + (setq gdb-inferior-status "exited") + (gdb-force-mode-line-update + (propertize gdb-inferior-status 'face font-lock-warning-face)) + (gdb-stopping ignored)) + +(defun gdb-signalled (ignored) + (setq gdb-signalled t)) + +(defun gdb-frame-begin (ignored) + (setq gdb-frame-begin t) + (setq gdb-printing nil) + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'inferior) + (setq gdb-output-sink 'user)) + ((eq sink 'user) t) + ((eq sink 'emacs) t) + (t + (gdb-resync) + (error "Unexpected frame-begin annotation (%S)" sink))))) + +(defcustom gdb-same-frame (not focus-follows-mouse) + "Non-nil means pop up GUD buffer in same frame." + :group 'gdb + :type 'boolean + :version "22.1") + +(defcustom gdb-find-source-frame nil + "Non-nil means try to find a source frame further up stack e.g after signal." + :group 'gdb + :type 'boolean + :version "22.1") + +(defun gdb-find-source-frame (arg) + "Toggle looking for a source frame further up call stack. +The code associated with current (innermost) frame may not have +been compiled with debug information, e.g., C library routine. +With prefix argument ARG, look for a source frame further up +stack to display in the source buffer if ARG is positive, +otherwise don't look further up." + (interactive "P") + (setq gdb-find-source-frame + (if (null arg) + (not gdb-find-source-frame) + (> (prefix-numeric-value arg) 0))) + (message (format "Looking for source frame %sabled" + (if gdb-find-source-frame "en" "dis")))) + +(defun gdb-stopped (ignored) + "An annotation handler for `stopped'. +It is just like `gdb-stopping', except that if we already set the output +sink to `user' in `gdb-stopping', that is fine." + (setq gud-running nil) + (unless (or gud-overlay-arrow-position gud-last-frame) + (if (and gdb-frame-begin gdb-printing) + (setq gud-overlay-arrow-position gud-old-arrow) + ;;Pop up GUD buffer to display current frame when it doesn't have source + ;;information i.e if not compiled with -g as with libc routines generally. + (if gdb-same-frame + (gdb-display-gdb-buffer) + (gdb-frame-gdb-buffer)) + (if gdb-find-source-frame + ;;Try to find source further up stack e.g after signal. + (setq gdb-look-up-stack + (if (gdb-get-buffer 'gdb-stack-buffer) + 'keep + (progn + (gdb-get-buffer-create 'gdb-stack-buffer) + (gdb-invalidate-frames) + 'delete)))))) + (unless (member gdb-inferior-status '("exited" "signal")) + (setq gdb-active-process t) ;Just for attaching case. + (setq gdb-inferior-status "stopped") + (gdb-force-mode-line-update + (propertize gdb-inferior-status 'face font-lock-warning-face))) + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'inferior) + (setq gdb-output-sink 'user)) + ((eq sink 'user) t) + (t + (gdb-resync) + (error "Unexpected stopped annotation")))) + (if gdb-signalled (gdb-exited ignored))) + +(defun gdb-error (ignored) + (setq gdb-error (not gdb-error))) + +(defun gdb-thread-changed (ignored) + (gdb-frames-force-update)) + +(defun gdb-post-prompt (ignored) + "An annotation handler for `post-prompt'. +This begins the collection of output from the current command if that +happens to be appropriate." + ;; Don't add to queue if there outstanding items or gdb-version is not known + ;; yet. + (unless (or gdb-pending-triggers gdb-first-post-prompt) + (gdb-get-selected-frame) + (gdb-invalidate-frames) + ;; Regenerate breakpoints buffer in case it has been inadvertantly deleted. + (gdb-get-buffer-create 'gdb-breakpoints-buffer) + (gdb-invalidate-breakpoints) + ;; Do this through gdb-get-selected-frame -> gdb-frame-handler + ;; so gdb-pc-address is updated. + ;; (gdb-invalidate-assembler) + + (if (string-equal gdb-version "pre-6.4") + (gdb-invalidate-registers) + (gdb-get-changed-registers) + (gdb-invalidate-registers-1)) + + (gdb-invalidate-memory) + (if (string-equal gdb-version "pre-6.4") + (gdb-invalidate-locals) + (gdb-invalidate-locals-1)) + + (gdb-invalidate-threads) + (unless (or (null gdb-var-list) + (eq system-type 'darwin)) ;Breaks on Darwin's GDB-5.3. + ;; FIXME: with GDB-6 on Darwin, this might very well work. + ;; Only needed/used with speedbar/watch expressions. + (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) + (if (string-equal gdb-version "pre-6.4") + (gdb-var-update) + (gdb-var-update-1))))) + (setq gdb-first-post-prompt nil) + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'user) t) + ((eq sink 'pre-emacs) + (setq gdb-output-sink 'emacs)) + (t + (gdb-resync) + (error "Phase error in gdb-post-prompt (got %s)" sink))))) + +(defconst gdb-buffer-list +'(gdb-stack-buffer gdb-locals-buffer gdb-registers-buffer gdb-threads-buffer)) + +(defun gdb-remove-text-properties () + (dolist (buffertype gdb-buffer-list) + (let ((buffer (gdb-get-buffer buffertype))) + (if buffer + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (remove-text-properties + (point-min) (point-max) '(mouse-face nil help-echo nil)))))))) + +;; GUD displays the selected GDB frame. This might might not be the current +;; GDB frame (after up, down etc). If no GDB frame is visible but the last +;; visited breakpoint is, use that window. +(defun gdb-display-source-buffer (buffer) + (let* ((last-window (if gud-last-last-frame + (get-buffer-window + (gud-find-file (car gud-last-last-frame))))) + (source-window (or last-window + (if (and gdb-source-window + (window-live-p gdb-source-window)) + gdb-source-window)))) + (when source-window + (setq gdb-source-window source-window) + (set-window-buffer source-window buffer)) + source-window)) + +;; Derived from gud-gdb-marker-regexp +(defvar gdb-fullname-regexp + (concat "\\(.:?[^" ":" "\n]*\\)" ":" "\\([0-9]*\\)" ":" ".*")) + +(defun gud-gdba-marker-filter (string) + "A gud marker filter for gdb. Handle a burst of output from GDB." + (if gdb-flush-pending-output + nil + (when gdb-enable-debug + (push (cons 'recv string) gdb-debug-log) + (if (and gdb-debug-log-max + (> (length gdb-debug-log) gdb-debug-log-max)) + (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil))) + ;; Recall the left over gud-marker-acc from last time. + (setq gud-marker-acc (concat gud-marker-acc string)) + ;; Start accumulating output for the GUD buffer. + (let ((output "")) + ;; + ;; Process all the complete markers in this chunk. + (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) + (let ((annotation (match-string 1 gud-marker-acc)) + (before (substring gud-marker-acc 0 (match-beginning 0))) + (after (substring gud-marker-acc (match-end 0)))) + ;; + ;; Parse the tag from the annotation, and maybe its arguments. + (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation) + (let* ((annotation-type (match-string 1 annotation)) + (annotation-arguments (match-string 2 annotation)) + (annotation-rule (assoc annotation-type + gdb-annotation-rules))) + + ;; Stuff prior to the match is just ordinary output. + ;; It is either concatenated to OUTPUT or directed + ;; elsewhere. + (setq output (gdb-concat-output output before)) + + ;; Take that stuff off the gud-marker-acc. + (setq gud-marker-acc after) + + ;; Call the handler for this annotation. + (if annotation-rule + (funcall (car (cdr annotation-rule)) + annotation-arguments)) + + ;; Else the annotation is not recognized. Ignore it silently, + ;; so that GDB can add new annotations without causing + ;; us to blow up. + ))) + + ;; Does the remaining text end in a partial line? + ;; If it does, then keep part of the gud-marker-acc until we get more. + (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'" + gud-marker-acc) + (progn + ;; Everything before the potential marker start can be output. + (setq output + (gdb-concat-output output + (substring gud-marker-acc 0 + (match-beginning 0)))) + ;; + ;; Everything after, we save, to combine with later input. + (setq gud-marker-acc (substring gud-marker-acc + (match-beginning 0)))) + ;; + ;; In case we know the gud-marker-acc contains no partial annotations: + (progn + (setq output (gdb-concat-output output gud-marker-acc)) + (setq gud-marker-acc ""))) + output))) + +(defun gdb-concat-output (so-far new) + (if gdb-error + (put-text-property 0 (length new) 'face font-lock-warning-face new)) + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'user) (concat so-far new)) + ((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far) + ((eq sink 'emacs) + (gdb-append-to-partial-output new) + so-far) + ((eq sink 'inferior) + (gdb-append-to-inferior-io new) + so-far) + (t + (gdb-resync) + (error "Bogon output sink %S" sink))))) + +(defun gdb-append-to-partial-output (string) + (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) + (goto-char (point-max)) + (insert string))) + +(defun gdb-clear-partial-output () + (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) + (erase-buffer))) + +(defun gdb-append-to-inferior-io (string) + (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) + (goto-char (point-max)) + (insert-before-markers string)) + (if (not (string-equal string "")) + (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t))) + +(defun gdb-clear-inferior-io () + (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) + (erase-buffer))) + +(defun gdb-jsonify-buffer (&optional fix-key fix-list) + "Prepare GDB/MI output in current buffer for parsing with `json-read'. + +Field names are wrapped in double quotes and equal signs are +replaced with semicolons. + +If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurences from +partial output. This is used to get rid of useless keys in lists +in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and +-break-info are examples of MI commands which issue such +responses. + +If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with +\"FIX-LIST=[..]\" prior to parsing. This is used to fix broken +-break-info output when it contains breakpoint script field +incompatible with GDB/MI output syntax." + (save-excursion + (goto-char (point-min)) + ;; Sometimes missing symbol information precedes "^done" record. + (re-search-forward "[[:ascii:]]*?\\^done," nil t) + (replace-match "") + (re-search-forward "(gdb) \n" nil t) + (replace-match "") + (goto-char (point-min)) + (when fix-key + (save-excursion + (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t) + (replace-match "" nil nil nil 1)))) + (when fix-list + (save-excursion + ;; Find positions of braces which enclose broken list + (while (re-search-forward (concat fix-list "={\"") nil t) + (let ((p1 (goto-char (- (point) 2))) + (p2 (progn (forward-sexp) + (1- (point))))) + ;; Replace braces with brackets + (save-excursion + (goto-char p1) + (delete-char 1) + (insert "[") + (goto-char p2) + (delete-char 1) + (insert "]")))))) + (goto-char (point-min)) + (insert "{") + (while (re-search-forward + "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t) + (replace-match "\"\\1\":\\2" nil nil)) + (goto-char (point-max)) + (insert "}"))) + +(defun gdb-json-read-buffer (&optional fix-key fix-list) + "Prepare and parse GDB/MI output in current buffer with `json-read'. + +FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." + (gdb-jsonify-buffer fix-key fix-list) + (save-excursion + (goto-char (point-min)) + (let ((json-array-type 'list)) + (json-read)))) + +(defun gdb-json-partial-output (&optional fix-key fix-list) + "Prepare and parse gdb-partial-output-buffer with `json-read'. + +FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'." + (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) + (gdb-json-read-buffer fix-key fix-list))) + + +;; One trick is to have a command who's output is always available in a buffer +;; of it's own, and is always up to date. We build several buffers of this +;; type. +;; +;; There are two aspects to this: gdb has to tell us when the output for that +;; command might have changed, and we have to be able to run the command +;; behind the user's back. +;; +;; The output phasing associated with the variable gdb-output-sink +;; help us to run commands behind the user's back. +;; +;; Below is the code for specificly managing buffers of output from one +;; command. +;; + +;; The trigger function is suitable for use in the assoc GDB-ANNOTATION-RULES +;; It adds an input for the command we are tracking. It should be the +;; annotation rule binding of whatever gdb sends to tell us this command +;; might have changed it's output. +;; +;; NAME is the function name. DEMAND-PREDICATE tests if output is really needed. +;; GDB-COMMAND is a string of such. OUTPUT-HANDLER is the function bound to the +;; input in the input queue (see comment about ``gdb communications'' above). + +(defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command + output-handler) + `(defun ,name (&optional ignored) + (if (and ,demand-predicate + (not (member ',name + gdb-pending-triggers))) + (progn + (gdb-enqueue-input + (list ,gdb-command ',output-handler)) + (push ',name gdb-pending-triggers))))) + +(defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun) + `(defun ,name () + (setq gdb-pending-triggers + (delq ',trigger + gdb-pending-triggers)) + (let ((buf (gdb-get-buffer ',buf-key))) + (and buf + (with-current-buffer buf + (let* ((window (get-buffer-window buf 0)) + (start (window-start window)) + (p (if window (window-point window) (point))) + (buffer-read-only nil)) + (erase-buffer) + (insert-buffer-substring (gdb-get-buffer-create + 'gdb-partial-output-buffer)) + (if window + (progn + (set-window-start window start) + (set-window-point window p)) + (goto-char p)))))) + ;; put customisation here + (,custom-defun))) + +(defmacro def-gdb-auto-updated-buffer (buffer-key + trigger-name gdb-command + output-handler-name custom-defun) + `(progn + (def-gdb-auto-update-trigger ,trigger-name + ;; The demand predicate: + (gdb-get-buffer ',buffer-key) + ,gdb-command + ,output-handler-name) + (def-gdb-auto-update-handler ,output-handler-name + ,trigger-name ,buffer-key ,custom-defun))) + + +;; +;; Breakpoint buffer : This displays the output of `info breakpoints'. +;; +(gdb-set-buffer-rules 'gdb-breakpoints-buffer + 'gdb-breakpoints-buffer-name + 'gdb-breakpoints-mode) + +(def-gdb-auto-updated-buffer gdb-breakpoints-buffer + ;; This defines the auto update rule for buffers of type + ;; `gdb-breakpoints-buffer'. + ;; + ;; It defines a function to serve as the annotation handler that + ;; handles the `foo-invalidated' message. That function is called: + gdb-invalidate-breakpoints + ;; + ;; To update the buffer, this command is sent to gdb. + "server info breakpoints\n" + ;; + ;; This also defines a function to be the handler for the output + ;; from the command above. That function will copy the output into + ;; the appropriately typed buffer. That function will be called: + gdb-info-breakpoints-handler + ;; buffer specific functions + gdb-info-breakpoints-custom) + +(defconst breakpoint-xpm-data + "/* XPM */ +static char *magick[] = { +/* columns rows colors chars-per-pixel */ +\"10 10 2 1\", +\" c red\", +\"+ c None\", +/* pixels */ +\"+++ +++\", +\"++ ++\", +\"+ +\", +\" \", +\" \", +\" \", +\" \", +\"+ +\", +\"++ ++\", +\"+++ +++\", +};" + "XPM data used for breakpoint icon.") + +(defconst breakpoint-enabled-pbm-data + "P1 +10 10\", +0 0 0 0 1 1 1 1 0 0 0 0 +0 0 0 1 1 1 1 1 1 0 0 0 +0 0 1 1 1 1 1 1 1 1 0 0 +0 1 1 1 1 1 1 1 1 1 1 0 +0 1 1 1 1 1 1 1 1 1 1 0 +0 1 1 1 1 1 1 1 1 1 1 0 +0 1 1 1 1 1 1 1 1 1 1 0 +0 0 1 1 1 1 1 1 1 1 0 0 +0 0 0 1 1 1 1 1 1 0 0 0 +0 0 0 0 1 1 1 1 0 0 0 0" + "PBM data used for enabled breakpoint icon.") + +(defconst breakpoint-disabled-pbm-data + "P1 +10 10\", +0 0 1 0 1 0 1 0 0 0 +0 1 0 1 0 1 0 1 0 0 +1 0 1 0 1 0 1 0 1 0 +0 1 0 1 0 1 0 1 0 1 +1 0 1 0 1 0 1 0 1 0 +0 1 0 1 0 1 0 1 0 1 +1 0 1 0 1 0 1 0 1 0 +0 1 0 1 0 1 0 1 0 1 +0 0 1 0 1 0 1 0 1 0 +0 0 0 1 0 1 0 1 0 0" + "PBM data used for disabled breakpoint icon.") + +(defvar breakpoint-enabled-icon nil + "Icon for enabled breakpoint in display margin.") + +(defvar breakpoint-disabled-icon nil + "Icon for disabled breakpoint in display margin.") + +(declare-function define-fringe-bitmap "fringe.c" + (bitmap bits &optional height width align)) + +(and (display-images-p) + ;; Bitmap for breakpoint in fringe + (define-fringe-bitmap 'breakpoint + "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") + ;; Bitmap for gud-overlay-arrow in fringe + (define-fringe-bitmap 'hollow-right-triangle + "\xe0\x90\x88\x84\x84\x88\x90\xe0")) + +(defface breakpoint-enabled + '((t + :foreground "red1" + :weight bold)) + "Face for enabled breakpoint icon in fringe." + :group 'gdb) + +(defface breakpoint-disabled + '((((class color) (min-colors 88)) :foreground "grey70") + ;; Ensure that on low-color displays that we end up something visible. + (((class color) (min-colors 8) (background light)) + :foreground "black") + (((class color) (min-colors 8) (background dark)) + :foreground "white") + (((type tty) (class mono)) + :inverse-video t) + (t :background "gray")) + "Face for disabled breakpoint icon in fringe." + :group 'gdb) + +(defconst gdb-breakpoint-regexp + "\\(?:\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\|\\([0-9]+\\.[0-9]+\\)\\)\\s-+\\(.\\)\\s-+") + +;; Put breakpoint icons in relevant margins (even those set in the GUD buffer). +(defun gdb-info-breakpoints-custom () + (let ((flag) (bptno)) + ;; Remove all breakpoint-icons in source buffers but not assembler buffer. + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (if (and (memq gud-minor-mode '(gdba gdbmi)) + (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name)))) + (gdb-remove-breakpoint-icons (point-min) (point-max))))) + (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (< (point) (- (point-max) 1)) + (forward-line 1) + (if (looking-at gdb-breakpoint-regexp) + (progn + (setq bptno (or (match-string 1) (match-string 2))) + (setq flag (char-after (match-beginning 3))) + (if (match-string 1) + (setq gdb-parent-bptno-enabled (eq flag ?y))) + (add-text-properties + (match-beginning 3) (match-end 3) + (if (eq flag ?y) + '(face font-lock-warning-face) + '(face font-lock-type-face))) + (let ((bl (point)) + (el (line-end-position))) + (when (re-search-forward " in \\(.*\\) at" el t) + (add-text-properties + (match-beginning 1) (match-end 1) + '(face font-lock-function-name-face))) + (if (re-search-forward + ".*\\s-+\\(\\S-+\\):\\([0-9]+\\)$" el t) + (let ((line (match-string 2)) + (file (match-string 1))) + (add-text-properties bl el + '(mouse-face highlight + help-echo "mouse-2, RET: visit breakpoint")) + (unless (file-exists-p file) + (setq file (cdr (assoc bptno gdb-location-alist)))) + (if (and file + (not (string-equal file "File not found"))) + (with-current-buffer + (find-file-noselect file 'nowarn) + (gdb-init-buffer) + ;; Only want one breakpoint icon at each + ;; location. + (save-excursion + (goto-char (point-min)) + (forward-line (1- (string-to-number line))) + (gdb-put-breakpoint-icon (eq flag ?y) bptno))) + (gdb-enqueue-input + (list + (concat gdb-server-prefix "list " + (match-string-no-properties 1) ":1\n") + 'ignore)) + (gdb-enqueue-input + (list (concat gdb-server-prefix "info source\n") + `(lambda () (gdb-get-location + ,bptno ,line ,flag)))))) + (if (re-search-forward + "<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" + el t) + (add-text-properties + (match-beginning 1) (match-end 1) + '(face font-lock-function-name-face)) + (end-of-line) + (re-search-backward "\\s-\\(\\S-*\\)" + bl t) + (add-text-properties + (match-beginning 1) (match-end 1) + '(face font-lock-variable-name-face))))))) + (end-of-line)))))) + (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)) + + ;; Breakpoints buffer is always present. Hack to just update + ;; current frame if there's been no execution. + (if gdb-stack-update + (setq gdb-stack-update nil) + (if (gdb-get-buffer 'gdb-stack-buffer) (gdb-info-stack-custom)))) + +(declare-function gud-remove "gdb-ui" t t) ; gud-def +(declare-function gud-break "gdb-ui" t t) ; gud-def +(declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window)) + +(defun gdb-mouse-set-clear-breakpoint (event) + "Set/clear breakpoint in left fringe/margin at mouse click. +If not in a source or disassembly buffer just set point." + (interactive "e") + (mouse-minibuffer-check event) + (let ((posn (event-end event))) + (with-selected-window (posn-window posn) + (if (or (buffer-file-name) (eq major-mode 'gdb-assembler-mode)) + (if (numberp (posn-point posn)) + (save-excursion + (goto-char (posn-point posn)) + (if (or (posn-object posn) + (eq (car (fringe-bitmaps-at-pos (posn-point posn))) + 'breakpoint)) + (gud-remove nil) + (gud-break nil))))) + (posn-set-point posn)))) + +(defun gdb-mouse-toggle-breakpoint-margin (event) + "Enable/disable breakpoint in left margin with mouse click." + (interactive "e") + (mouse-minibuffer-check event) + (let ((posn (event-end event))) + (if (numberp (posn-point posn)) + (with-selected-window (posn-window posn) + (save-excursion + (goto-char (posn-point posn)) + (if (posn-object posn) + (let* ((bptno (get-text-property + 0 'gdb-bptno (car (posn-string posn))))) + (string-match "\\([0-9+]\\)*" bptno) + (gdb-enqueue-input + (list + (concat gdb-server-prefix + (if (get-text-property + 0 'gdb-enabled (car (posn-string posn))) + "disable " + "enable ") + (match-string 1 bptno) "\n") + 'ignore))))))))) + +(defun gdb-mouse-toggle-breakpoint-fringe (event) + "Enable/disable breakpoint in left fringe with mouse click." + (interactive "e") + (mouse-minibuffer-check event) + (let* ((posn (event-end event)) + (pos (posn-point posn)) + obj) + (when (numberp pos) + (with-selected-window (posn-window posn) + (with-current-buffer (window-buffer (selected-window)) + (goto-char pos) + (dolist (overlay (overlays-in pos pos)) + (when (overlay-get overlay 'put-break) + (setq obj (overlay-get overlay 'before-string)))) + (when (stringp obj) + (let* ((bptno (get-text-property 0 'gdb-bptno obj))) + (string-match "\\([0-9+]\\)*" bptno) + (gdb-enqueue-input + (list + (concat gdb-server-prefix + (if (get-text-property 0 'gdb-enabled obj) + "disable " + "enable ") + (match-string 1 bptno) "\n") + 'ignore))))))))) + +(defun gdb-breakpoints-buffer-name () + (with-current-buffer gud-comint-buffer + (concat "*breakpoints of " (gdb-get-target-string) "*"))) + +(defun gdb-display-breakpoints-buffer () + "Display status of user-settable breakpoints." + (interactive) + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-breakpoints-buffer) t)) + +(defun gdb-frame-breakpoints-buffer () + "Display status of user-settable breakpoints in a new frame." + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create 'gdb-breakpoints-buffer)))) + +(defvar gdb-breakpoints-mode-map + (let ((map (make-sparse-keymap)) + (menu (make-sparse-keymap "Breakpoints"))) + (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window)) + (define-key menu [goto] '("Goto" . gdb-goto-breakpoint)) + (define-key menu [delete] '("Delete" . gdb-delete-breakpoint)) + (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint)) + (suppress-keymap map) + (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu)) + (define-key map " " 'gdb-toggle-breakpoint) + (define-key map "D" 'gdb-delete-breakpoint) + ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons. + (define-key map "q" 'gdb-delete-frame-or-window) + (define-key map "\r" 'gdb-goto-breakpoint) + (define-key map [mouse-2] 'gdb-goto-breakpoint) + (define-key map [follow-link] 'mouse-face) + map)) + +(defun gdb-delete-frame-or-window () + "Delete frame if there is only one window. Otherwise delete the window." + (interactive) + (if (one-window-p) (delete-frame) + (delete-window))) + +;;from make-mode-line-mouse-map +(defun gdb-make-header-line-mouse-map (mouse function) "\ +Return a keymap with single entry for mouse key MOUSE on the header line. +MOUSE is defined to run function FUNCTION with no args in the buffer +corresponding to the mode line clicked." + (let ((map (make-sparse-keymap))) + (define-key map (vector 'header-line mouse) function) + (define-key map (vector 'header-line 'down-mouse-1) 'ignore) + map)) + +(defmacro gdb-propertize-header (name buffer help-echo mouse-face face) + `(propertize ,name + 'help-echo ,help-echo + 'mouse-face ',mouse-face + 'face ',face + 'local-map + (gdb-make-header-line-mouse-map + 'mouse-1 + (lambda (event) (interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (set-window-dedicated-p (selected-window) nil) + (switch-to-buffer + (gdb-get-buffer-create ',buffer)) + (setq header-line-format(gdb-set-header ',buffer)) + (set-window-dedicated-p (selected-window) t)))))) + +(defun gdb-set-header (buffer) + (cond ((eq buffer 'gdb-locals-buffer) + (list + (gdb-propertize-header "Locals" gdb-locals-buffer + nil nil mode-line) + " " + (gdb-propertize-header "Registers" gdb-registers-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive))) + ((eq buffer 'gdb-registers-buffer) + (list + (gdb-propertize-header "Locals" gdb-locals-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive) + " " + (gdb-propertize-header "Registers" gdb-registers-buffer + nil nil mode-line))) + ((eq buffer 'gdb-breakpoints-buffer) + (list + (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer + nil nil mode-line) + " " + (gdb-propertize-header "Threads" gdb-threads-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive))) + ((eq buffer 'gdb-threads-buffer) + (list + (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive) + " " + (gdb-propertize-header "Threads" gdb-threads-buffer + nil nil mode-line))))) + +(defvar gdb-breakpoints-header + (list + (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer + nil nil mode-line) + " " + (gdb-propertize-header "Threads" gdb-threads-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive))) + +(defun gdb-breakpoints-mode () + "Major mode for gdb breakpoints. + +\\{gdb-breakpoints-mode-map}" + (kill-all-local-variables) + (setq major-mode 'gdb-breakpoints-mode) + (setq mode-name "Breakpoints") + (use-local-map gdb-breakpoints-mode-map) + (setq buffer-read-only t) + (buffer-disable-undo) + (setq header-line-format gdb-breakpoints-header) + (run-mode-hooks 'gdb-breakpoints-mode-hook) + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + 'gdb-invalidate-breakpoints + 'gdbmi-invalidate-breakpoints)) + +(defun gdb-toggle-breakpoint () + "Enable/disable breakpoint at current line." + (interactive) + (save-excursion + (beginning-of-line 1) + (if (looking-at gdb-breakpoint-regexp) + (gdb-enqueue-input + (list + (concat gdb-server-prefix + (if (eq ?y (char-after (match-beginning 3))) + "disable " + "enable ") + (or (match-string 1) (match-string 2)) "\n") 'ignore)) + (error "Not recognized as break/watchpoint line")))) + +(defun gdb-delete-breakpoint () + "Delete the breakpoint at current line." + (interactive) + (save-excursion + (beginning-of-line 1) + (if (looking-at gdb-breakpoint-regexp) + (if (match-string 1) + (gdb-enqueue-input + (list + (concat gdb-server-prefix "delete " (match-string 1) "\n") + 'ignore)) + (message-box "This breakpoint cannot be deleted on its own.")) + (error "Not recognized as break/watchpoint line")))) + +(defun gdb-goto-breakpoint (&optional event) + "Display the breakpoint location specified at current line." + (interactive (list last-input-event)) + (if event (posn-set-point (event-end event))) + (save-excursion + (beginning-of-line 1) + (if (looking-at "\\([0-9]+\\.?[0-9]*\\) .*\\s-+\\(\\S-+\\):\\([0-9]+\\)$") + (let ((bptno (match-string 1)) + (file (match-string 2)) + (line (match-string 3))) + (save-selected-window + (let* ((buffer (find-file-noselect + (if (file-exists-p file) file + (cdr (assoc bptno gdb-location-alist))))) + (window (or (gdb-display-source-buffer buffer) + (display-buffer buffer)))) + (setq gdb-source-window window) + (with-current-buffer buffer + (goto-char (point-min)) + (forward-line (1- (string-to-number line))) + (set-window-point window (point)))))) + (error "No location specified.")))) + + +;; Frames buffer. This displays a perpetually correct backtrace +;; (from the command `where'). +;; +;; Alas, if your stack is deep, it is costly. +;; +(defcustom gdb-max-frames 40 + "Maximum number of frames displayed in call stack." + :type 'integer + :group 'gdb + :version "22.1") + +(gdb-set-buffer-rules 'gdb-stack-buffer + 'gdb-stack-buffer-name + 'gdb-frames-mode) + +(def-gdb-auto-updated-buffer gdb-stack-buffer + gdb-invalidate-frames + (concat "server info stack " (number-to-string gdb-max-frames) "\n") + gdb-info-stack-handler + gdb-info-stack-custom) + +;; This may be more important for embedded targets where unwinding the +;; stack may take a long time. +(defadvice gdb-invalidate-frames (around gdb-invalidate-frames-advice + (&optional ignored) activate compile) + "Only queue \"info stack\" if execution has occurred." + (if gdb-stack-update ad-do-it)) + +(defun gdb-info-stack-custom () + (with-current-buffer (gdb-get-buffer 'gdb-stack-buffer) + (let (move-to) + (save-excursion + (unless (eq gdb-look-up-stack 'delete) + (let ((buffer-read-only nil) + bl el) + (goto-char (point-min)) + (while (< (point) (point-max)) + (setq bl (line-beginning-position) + el (line-end-position)) + (when (looking-at "#") + (add-text-properties bl el + '(mouse-face highlight + help-echo "mouse-2, RET: Select frame"))) + (goto-char bl) + (when (looking-at "^#\\([0-9]+\\)") + (when (string-equal (match-string 1) gdb-frame-number) + (if (gud-tool-bar-item-visible-no-fringe) + (progn + (put-text-property bl (+ bl 4) + 'face '(:inverse-video t)) + (setq move-to bl)) + (or gdb-stack-position + (setq gdb-stack-position (make-marker))) + (set-marker gdb-stack-position (point)) + (setq move-to gdb-stack-position))) + (when (re-search-forward "\\([^ ]+\\) (" el t) + (put-text-property (match-beginning 1) (match-end 1) + 'face font-lock-function-name-face) + (setq bl (match-end 0)) + (while (re-search-forward "<\\([^>]+\\)>" el t) + (put-text-property (match-beginning 1) (match-end 1) + 'face font-lock-function-name-face)) + (goto-char bl) + (while (re-search-forward "\\(\\(\\sw\\|[_.]\\)+\\)=" el t) + (put-text-property (match-beginning 1) (match-end 1) + 'face font-lock-variable-name-face)))) + (forward-line 1)) + (forward-line -1) + (when (looking-at "(More stack frames follow...)") + (add-text-properties + (match-beginning 0) (match-end 0) + '(mouse-face highlight + gdb-max-frames t + help-echo + "mouse-2, RET: customize gdb-max-frames to see more frames" + ))))) + (when gdb-look-up-stack + (goto-char (point-min)) + (when (re-search-forward "\\(\\S-+?\\):\\([0-9]+\\)" nil t) + (let ((start (line-beginning-position)) + (file (match-string 1)) + (line (match-string 2))) + (re-search-backward "^#*\\([0-9]+\\)" start t) + (gdb-enqueue-input + (list (concat gdb-server-prefix "frame " + (match-string 1) "\n") 'gdb-set-hollow)) + (gdb-enqueue-input + (list (concat gdb-server-prefix "frame 0\n") 'ignore)))))) + (when move-to + (let ((window (get-buffer-window (current-buffer) 0))) + (when window + (with-selected-window window + (goto-char move-to) + (unless (pos-visible-in-window-p) + (recenter '(center))))))))) + (if (eq gdb-look-up-stack 'delete) + (kill-buffer (gdb-get-buffer 'gdb-stack-buffer))) + (setq gdb-look-up-stack nil)) + +(defun gdb-set-hollow () + (if gud-last-last-frame + (with-current-buffer (gud-find-file (car gud-last-last-frame)) + (setq fringe-indicator-alist + '((overlay-arrow . hollow-right-triangle)))))) + +(defun gdb-stack-buffer-name () + (with-current-buffer gud-comint-buffer + (concat "*stack frames of " (gdb-get-target-string) "*"))) + +(defun gdb-display-stack-buffer () + "Display backtrace of current stack." + (interactive) + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-stack-buffer) t)) + +(defun gdb-frame-stack-buffer () + "Display backtrace of current stack in a new frame." + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create 'gdb-stack-buffer)))) + +(defvar gdb-frames-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'kill-this-buffer) + (define-key map "\r" 'gdb-frames-select) + (define-key map "F" 'gdb-frames-force-update) + (define-key map [mouse-2] 'gdb-frames-select) + (define-key map [follow-link] 'mouse-face) + map)) + +(declare-function gdbmi-invalidate-frames "ext:gdb-mi" nil t) + +(defun gdb-frames-force-update () + "Force update of call stack. +Use when the displayed call stack gets out of sync with the +actual one, e.g after using the Gdb command \"return\" or setting +$pc directly from the GUD buffer. This command isn't normally needed." + (interactive) + (setq gdb-stack-update t) + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + (gdb-invalidate-frames) + (gdbmi-invalidate-frames))) + +(defun gdb-frames-mode () + "Major mode for gdb call stack. + +\\{gdb-frames-mode-map}" + (kill-all-local-variables) + (setq major-mode 'gdb-frames-mode) + (setq mode-name "Frames") + (setq gdb-stack-position nil) + (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position) + (setq truncate-lines t) ;; Make it easier to see overlay arrow. + (setq buffer-read-only t) + (buffer-disable-undo) + (gdb-thread-identification) + (use-local-map gdb-frames-mode-map) + (run-mode-hooks 'gdb-frames-mode-hook) + (setq gdb-stack-update t) + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + 'gdb-invalidate-frames + 'gdbmi-invalidate-frames)) + +(defun gdb-get-frame-number () + (save-excursion + (end-of-line) + (let* ((start (line-beginning-position)) + (pos (re-search-backward "^#*\\([0-9]+\\)" start t)) + (n (or (and pos (match-string 1)) "0"))) + n))) + +(defun gdb-frames-select (&optional event) + "Select the frame and display the relevant source." + (interactive (list last-input-event)) + (if event (posn-set-point (event-end event))) + (if (get-text-property (point) 'gdb-max-frames) + (progn + (message-box "After setting gdb-max-frames, you need to enter\n\ +another GDB command e.g pwd, to see new frames") + (customize-variable-other-window 'gdb-max-frames)) + (gdb-enqueue-input + (list (concat gdb-server-prefix "frame " + (gdb-get-frame-number) "\n") 'ignore)))) + + +;; Threads buffer. This displays a selectable thread list. +;; +(gdb-set-buffer-rules 'gdb-threads-buffer + 'gdb-threads-buffer-name + 'gdb-threads-mode) + +(def-gdb-auto-updated-buffer gdb-threads-buffer + gdb-invalidate-threads + (concat gdb-server-prefix "info threads\n") + gdb-info-threads-handler + gdb-info-threads-custom) + +(defun gdb-info-threads-custom () + (with-current-buffer (gdb-get-buffer 'gdb-threads-buffer) + (let ((buffer-read-only nil)) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "\\* \\([0-9]+\\)" nil t) + (setq gdb-thread-indicator + (propertize (concat " [" (match-string 1) "]") + ; FIXME: this help-echo doesn't work + 'help-echo "thread id"))) + (goto-char (point-min)) + (while (< (point) (point-max)) + (unless (looking-at "No ") + (add-text-properties (line-beginning-position) (line-end-position) + '(mouse-face highlight + help-echo "mouse-2, RET: select thread"))) + (forward-line 1)))))) + +(defun gdb-threads-buffer-name () + (with-current-buffer gud-comint-buffer + (concat "*threads of " (gdb-get-target-string) "*"))) + +(defun gdb-display-threads-buffer () + "Display IDs of currently known threads." + (interactive) + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-threads-buffer) t)) + +(defun gdb-frame-threads-buffer () + "Display IDs of currently known threads in a new frame." + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create 'gdb-threads-buffer)))) + +(defvar gdb-threads-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'kill-this-buffer) + (define-key map "\r" 'gdb-threads-select) + (define-key map [mouse-2] 'gdb-threads-select) + (define-key map [follow-link] 'mouse-face) + map)) + +(defvar gdb-threads-font-lock-keywords + '((") +\\([^ ]+\\) (" (1 font-lock-function-name-face)) + ("in \\([^ ]+\\) (" (1 font-lock-function-name-face)) + ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face))) + "Font lock keywords used in `gdb-threads-mode'.") + +(defun gdb-threads-mode () + "Major mode for gdb threads. + +\\{gdb-threads-mode-map}" + (kill-all-local-variables) + (setq major-mode 'gdb-threads-mode) + (setq mode-name "Threads") + (setq buffer-read-only t) + (buffer-disable-undo) + (setq header-line-format gdb-breakpoints-header) + (use-local-map gdb-threads-mode-map) + (set (make-local-variable 'font-lock-defaults) + '(gdb-threads-font-lock-keywords)) + (run-mode-hooks 'gdb-threads-mode-hook) + ;; Force "info threads" onto queue. + (lambda () (let ((gud-running nil)) (gdb-invalidate-threads)))) + +(defun gdb-get-thread-number () + (save-excursion + (re-search-backward "^\\s-*\\([0-9]*\\)" nil t) + (match-string-no-properties 1))) + +(defun gdb-threads-select (&optional event) + "Select the thread and display the relevant source." + (interactive (list last-input-event)) + (if event (posn-set-point (event-end event))) + (setq gdb-stack-update t) + (gdb-enqueue-input + (list (concat gdb-server-prefix "thread " + (gdb-get-thread-number) "\n") 'ignore)) + (gud-display-frame)) + +(defun gdb-thread-identification () + (setq mode-line-buffer-identification + (list (car mode-line-buffer-identification) + '(gdb-thread-indicator gdb-thread-indicator)))) + +;; Registers buffer. +;; +(defcustom gdb-all-registers nil + "Non-nil means include floating-point registers." + :type 'boolean + :group 'gdb + :version "22.1") + +(gdb-set-buffer-rules 'gdb-registers-buffer + 'gdb-registers-buffer-name + 'gdb-registers-mode) + +(def-gdb-auto-updated-buffer gdb-registers-buffer + gdb-invalidate-registers + (concat + gdb-server-prefix "info " (if gdb-all-registers "all-") "registers\n") + gdb-info-registers-handler + gdb-info-registers-custom) + +(defun gdb-info-registers-custom () + (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) + (save-excursion + (let ((buffer-read-only nil) + start end) + (goto-char (point-min)) + (while (< (point) (point-max)) + (setq start (line-beginning-position)) + (setq end (line-end-position)) + (when (looking-at "^[^ ]+") + (unless (string-equal (match-string 0) "The") + (put-text-property start (match-end 0) + 'face font-lock-variable-name-face) + (add-text-properties start end + '(help-echo "mouse-2: edit value" + mouse-face highlight)))) + (forward-line 1)))))) + +(defun gdb-edit-register-value (&optional event) + (interactive (list last-input-event)) + (save-excursion + (if event (posn-set-point (event-end event))) + (beginning-of-line) + (let* ((register (current-word)) + (value (read-string (format "New value (%s): " register)))) + (gdb-enqueue-input + (list (concat gdb-server-prefix "set $" register "=" value "\n") + 'ignore))))) + +(defvar gdb-registers-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "\r" 'gdb-edit-register-value) + (define-key map [mouse-2] 'gdb-edit-register-value) + (define-key map " " 'gdb-all-registers) + (define-key map "q" 'kill-this-buffer) + map)) + +(defvar gdb-locals-header + (list + (gdb-propertize-header "Locals" gdb-locals-buffer + nil nil mode-line) + " " + (gdb-propertize-header "Registers" gdb-registers-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive))) + + +(defun gdb-registers-mode () + "Major mode for gdb registers. + +\\{gdb-registers-mode-map}" + (kill-all-local-variables) + (setq major-mode 'gdb-registers-mode) + (setq mode-name "Registers") + (setq header-line-format gdb-locals-header) + (setq buffer-read-only t) + (buffer-disable-undo) + (gdb-thread-identification) + (use-local-map gdb-registers-mode-map) + (run-mode-hooks 'gdb-registers-mode-hook) + (if (string-equal gdb-version "pre-6.4") + (progn + (if gdb-all-registers (setq mode-name "Registers:All")) + 'gdb-invalidate-registers) + 'gdb-invalidate-registers-1)) + +(defun gdb-registers-buffer-name () + (with-current-buffer gud-comint-buffer + (concat "*registers of " (gdb-get-target-string) "*"))) + +(defun gdb-display-registers-buffer () + "Display integer register contents." + (interactive) + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-registers-buffer) t)) + +(defun gdb-frame-registers-buffer () + "Display integer register contents in a new frame." + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create 'gdb-registers-buffer)))) + +(defun gdb-all-registers () + "Toggle the display of floating-point registers (pre GDB 6.4 only)." + (interactive) + (when (string-equal gdb-version "pre-6.4") + (if gdb-all-registers + (progn + (setq gdb-all-registers nil) + (with-current-buffer (gdb-get-buffer-create 'gdb-registers-buffer) + (setq mode-name "Registers"))) + (setq gdb-all-registers t) + (with-current-buffer (gdb-get-buffer-create 'gdb-registers-buffer) + (setq mode-name "Registers:All"))) + (message (format "Display of floating-point registers %sabled" + (if gdb-all-registers "en" "dis"))) + (gdb-invalidate-registers))) + + +;; Memory buffer. +;; +(defcustom gdb-memory-repeat-count 32 + "Number of data items in memory window." + :type 'integer + :group 'gdb + :version "22.1") + +(defcustom gdb-memory-format "x" + "Display format of data items in memory window." + :type '(choice (const :tag "Hexadecimal" "x") + (const :tag "Signed decimal" "d") + (const :tag "Unsigned decimal" "u") + (const :tag "Octal" "o") + (const :tag "Binary" "t")) + :group 'gdb + :version "22.1") + +(defcustom gdb-memory-unit "w" + "Unit size of data items in memory window." + :type '(choice (const :tag "Byte" "b") + (const :tag "Halfword" "h") + (const :tag "Word" "w") + (const :tag "Giant word" "g")) + :group 'gdb + :version "22.1") + +(gdb-set-buffer-rules 'gdb-memory-buffer + 'gdb-memory-buffer-name + 'gdb-memory-mode) + +(def-gdb-auto-updated-buffer gdb-memory-buffer + gdb-invalidate-memory + (concat gdb-server-prefix "x/" (number-to-string gdb-memory-repeat-count) + gdb-memory-format gdb-memory-unit " " gdb-memory-address "\n") + gdb-read-memory-handler + gdb-read-memory-custom) + +(defun gdb-read-memory-custom () + (save-excursion + (goto-char (point-min)) + (if (looking-at "0x[[:xdigit:]]+") + (setq gdb-memory-address (match-string 0))))) + +(defvar gdb-memory-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "S" 'gdb-memory-set-address) + (define-key map "N" 'gdb-memory-set-repeat-count) + (define-key map "q" 'kill-this-buffer) + map)) + +(defun gdb-memory-set-address (&optional event) + "Set the start memory address." + (interactive) + (let ((arg (read-from-minibuffer "Start address: "))) + (setq gdb-memory-address arg)) + (gdb-invalidate-memory)) + +(defun gdb-memory-set-repeat-count (&optional event) + "Set the number of data items in memory window." + (interactive) + (let* ((arg (read-from-minibuffer "Repeat count: ")) + (count (string-to-number arg))) + (if (<= count 0) + (error "Positive numbers only") + (customize-set-variable 'gdb-memory-repeat-count count) + (gdb-invalidate-memory)))) + +(defun gdb-memory-format-binary () + "Set the display format to binary." + (interactive) + (customize-set-variable 'gdb-memory-format "t") + (gdb-invalidate-memory)) + +(defun gdb-memory-format-octal () + "Set the display format to octal." + (interactive) + (customize-set-variable 'gdb-memory-format "o") + (gdb-invalidate-memory)) + +(defun gdb-memory-format-unsigned () + "Set the display format to unsigned decimal." + (interactive) + (customize-set-variable 'gdb-memory-format "u") + (gdb-invalidate-memory)) + +(defun gdb-memory-format-signed () + "Set the display format to decimal." + (interactive) + (customize-set-variable 'gdb-memory-format "d") + (gdb-invalidate-memory)) + +(defun gdb-memory-format-hexadecimal () + "Set the display format to hexadecimal." + (interactive) + (customize-set-variable 'gdb-memory-format "x") + (gdb-invalidate-memory)) + +(defvar gdb-memory-format-map + (let ((map (make-sparse-keymap))) + (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1) + map) + "Keymap to select format in the header line.") + +(defvar gdb-memory-format-menu (make-sparse-keymap "Format") + "Menu of display formats in the header line.") + +(define-key gdb-memory-format-menu [binary] + '(menu-item "Binary" gdb-memory-format-binary + :button (:radio . (equal gdb-memory-format "t")))) +(define-key gdb-memory-format-menu [octal] + '(menu-item "Octal" gdb-memory-format-octal + :button (:radio . (equal gdb-memory-format "o")))) +(define-key gdb-memory-format-menu [unsigned] + '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned + :button (:radio . (equal gdb-memory-format "u")))) +(define-key gdb-memory-format-menu [signed] + '(menu-item "Signed Decimal" gdb-memory-format-signed + :button (:radio . (equal gdb-memory-format "d")))) +(define-key gdb-memory-format-menu [hexadecimal] + '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal + :button (:radio . (equal gdb-memory-format "x")))) + +(defun gdb-memory-format-menu (event) + (interactive "@e") + (x-popup-menu event gdb-memory-format-menu)) + +(defun gdb-memory-format-menu-1 (event) + (interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (let* ((selection (gdb-memory-format-menu event)) + (binding (and selection (lookup-key gdb-memory-format-menu + (vector (car selection)))))) + (if binding (call-interactively binding))))) + +(defun gdb-memory-unit-giant () + "Set the unit size to giant words (eight bytes)." + (interactive) + (customize-set-variable 'gdb-memory-unit "g") + (gdb-invalidate-memory)) + +(defun gdb-memory-unit-word () + "Set the unit size to words (four bytes)." + (interactive) + (customize-set-variable 'gdb-memory-unit "w") + (gdb-invalidate-memory)) + +(defun gdb-memory-unit-halfword () + "Set the unit size to halfwords (two bytes)." + (interactive) + (customize-set-variable 'gdb-memory-unit "h") + (gdb-invalidate-memory)) + +(defun gdb-memory-unit-byte () + "Set the unit size to bytes." + (interactive) + (customize-set-variable 'gdb-memory-unit "b") + (gdb-invalidate-memory)) + +(defvar gdb-memory-unit-map + (let ((map (make-sparse-keymap))) + (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1) + map) + "Keymap to select units in the header line.") + +(defvar gdb-memory-unit-menu (make-sparse-keymap "Unit") + "Menu of units in the header line.") + +(define-key gdb-memory-unit-menu [giantwords] + '(menu-item "Giant words" gdb-memory-unit-giant + :button (:radio . (equal gdb-memory-unit "g")))) +(define-key gdb-memory-unit-menu [words] + '(menu-item "Words" gdb-memory-unit-word + :button (:radio . (equal gdb-memory-unit "w")))) +(define-key gdb-memory-unit-menu [halfwords] + '(menu-item "Halfwords" gdb-memory-unit-halfword + :button (:radio . (equal gdb-memory-unit "h")))) +(define-key gdb-memory-unit-menu [bytes] + '(menu-item "Bytes" gdb-memory-unit-byte + :button (:radio . (equal gdb-memory-unit "b")))) + +(defun gdb-memory-unit-menu (event) + (interactive "@e") + (x-popup-menu event gdb-memory-unit-menu)) + +(defun gdb-memory-unit-menu-1 (event) + (interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (let* ((selection (gdb-memory-unit-menu event)) + (binding (and selection (lookup-key gdb-memory-unit-menu + (vector (car selection)))))) + (if binding (call-interactively binding))))) + +(defvar gdb-memory-font-lock-keywords + '(;; <__function.name+n> + ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face)) + ) + "Font lock keywords used in `gdb-memory-mode'.") + +(defun gdb-memory-mode () + "Major mode for examining memory. + +\\{gdb-memory-mode-map}" + (kill-all-local-variables) + (setq major-mode 'gdb-memory-mode) + (setq mode-name "Memory") + (setq buffer-read-only t) + (buffer-disable-undo) + (use-local-map gdb-memory-mode-map) + (setq header-line-format + '(:eval + (concat + "Start address[" + (propertize + "-" + 'face font-lock-warning-face + 'help-echo "mouse-1: decrement address" + 'mouse-face 'mode-line-highlight + 'local-map + (gdb-make-header-line-mouse-map + 'mouse-1 + (lambda () (interactive) + (let ((gdb-memory-address + ;; Let GDB do the arithmetic. + (concat + gdb-memory-address " - " + (number-to-string + (* gdb-memory-repeat-count + (cond ((string= gdb-memory-unit "b") 1) + ((string= gdb-memory-unit "h") 2) + ((string= gdb-memory-unit "w") 4) + ((string= gdb-memory-unit "g") 8))))))) + (gdb-invalidate-memory))))) + "|" + (propertize "+" + 'face font-lock-warning-face + 'help-echo "mouse-1: increment address" + 'mouse-face 'mode-line-highlight + 'local-map (gdb-make-header-line-mouse-map + 'mouse-1 + (lambda () (interactive) + (let ((gdb-memory-address nil)) + (gdb-invalidate-memory))))) + "]: " + (propertize gdb-memory-address + 'face font-lock-warning-face + 'help-echo "mouse-1: set start address" + 'mouse-face 'mode-line-highlight + 'local-map (gdb-make-header-line-mouse-map + 'mouse-1 + #'gdb-memory-set-address)) + " Repeat Count: " + (propertize (number-to-string gdb-memory-repeat-count) + 'face font-lock-warning-face + 'help-echo "mouse-1: set repeat count" + 'mouse-face 'mode-line-highlight + 'local-map (gdb-make-header-line-mouse-map + 'mouse-1 + #'gdb-memory-set-repeat-count)) + " Display Format: " + (propertize gdb-memory-format + 'face font-lock-warning-face + 'help-echo "mouse-3: select display format" + 'mouse-face 'mode-line-highlight + 'local-map gdb-memory-format-map) + " Unit Size: " + (propertize gdb-memory-unit + 'face font-lock-warning-face + 'help-echo "mouse-3: select unit size" + 'mouse-face 'mode-line-highlight + 'local-map gdb-memory-unit-map)))) + (set (make-local-variable 'font-lock-defaults) + '(gdb-memory-font-lock-keywords)) + (run-mode-hooks 'gdb-memory-mode-hook) + 'gdb-invalidate-memory) + +(defun gdb-memory-buffer-name () + (with-current-buffer gud-comint-buffer + (concat "*memory of " (gdb-get-target-string) "*"))) + +(defun gdb-display-memory-buffer () + "Display memory contents." + (interactive) + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-memory-buffer) t)) + +(defun gdb-frame-memory-buffer () + "Display memory contents in a new frame." + (interactive) + (let* ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist + (cons '(left-fringe . 0) + (cons '(right-fringe . 0) + (cons '(width . 83) gdb-frame-parameters))))) + (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer)))) + + +;; Locals buffer. +;; +(gdb-set-buffer-rules 'gdb-locals-buffer + 'gdb-locals-buffer-name + 'gdb-locals-mode) + +(def-gdb-auto-update-trigger gdb-invalidate-locals + (gdb-get-buffer 'gdb-locals-buffer) + "server info locals\n" + gdb-info-locals-handler) + +(defvar gdb-locals-watch-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "\r" (lambda () (interactive) + (beginning-of-line) + (gud-watch))) + (define-key map [mouse-2] (lambda (event) (interactive "e") + (mouse-set-point event) + (beginning-of-line) + (gud-watch))) + map) + "Keymap to create watch expression of a complex data type local variable.") + +(defconst gdb-struct-string + (concat (propertize "[struct/union]" + 'mouse-face 'highlight + 'help-echo "mouse-2: create watch expression" + 'local-map gdb-locals-watch-map) "\n")) + +(defconst gdb-array-string + (concat " " (propertize "[array]" + 'mouse-face 'highlight + 'help-echo "mouse-2: create watch expression" + 'local-map gdb-locals-watch-map) "\n")) + +;; Abbreviate for arrays and structures. +;; These can be expanded using gud-display. +(defun gdb-info-locals-handler () + (setq gdb-pending-triggers (delq 'gdb-invalidate-locals + gdb-pending-triggers)) + (let ((buf (gdb-get-buffer 'gdb-partial-output-buffer))) + (with-current-buffer buf + (goto-char (point-min)) + ;; Need this in case "set print pretty" is on. + (while (re-search-forward "^[ }].*\n" nil t) + (replace-match "" nil nil)) + (goto-char (point-min)) + (while (re-search-forward "{\\(.*=.*\n\\|\n\\)" nil t) + (replace-match gdb-struct-string nil nil)) + (goto-char (point-min)) + (while (re-search-forward "\\s-*{[^.].*\n" nil t) + (replace-match gdb-array-string nil nil)))) + (let ((buf (gdb-get-buffer 'gdb-locals-buffer))) + (and buf + (with-current-buffer buf + (let* ((window (get-buffer-window buf 0)) + (start (window-start window)) + (p (window-point window)) + (buffer-read-only nil)) + (erase-buffer) + (insert-buffer-substring (gdb-get-buffer-create + 'gdb-partial-output-buffer)) + (set-window-start window start) + (set-window-point window p))))) + (run-hooks 'gdb-info-locals-hook)) + +(defvar gdb-locals-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'kill-this-buffer) + map)) + +(defun gdb-locals-mode () + "Major mode for gdb locals. + +\\{gdb-locals-mode-map}" + (kill-all-local-variables) + (setq major-mode 'gdb-locals-mode) + (setq mode-name (concat "Locals:" gdb-selected-frame)) + (use-local-map gdb-locals-mode-map) + (setq buffer-read-only t) + (buffer-disable-undo) + (setq header-line-format gdb-locals-header) + (gdb-thread-identification) + (set (make-local-variable 'font-lock-defaults) + '(gdb-locals-font-lock-keywords)) + (run-mode-hooks 'gdb-locals-mode-hook) + (if (and (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + (string-equal gdb-version "pre-6.4")) + 'gdb-invalidate-locals + 'gdb-invalidate-locals-1)) + +(defun gdb-locals-buffer-name () + (with-current-buffer gud-comint-buffer + (concat "*locals of " (gdb-get-target-string) "*"))) + +(defun gdb-display-locals-buffer () + "Display local variables of current stack and their values." + (interactive) + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-locals-buffer) t)) + +(defun gdb-frame-locals-buffer () + "Display local variables of current stack and their values in a new frame." + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create 'gdb-locals-buffer)))) + + +;;;; Window management +(defun gdb-display-buffer (buf dedicated &optional frame) + (let ((answer (get-buffer-window buf (or frame 0)))) + (if answer + (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary. + (let ((window (get-lru-window))) + (if (memq (buffer-local-value 'gud-minor-mode (window-buffer window)) + '(gdba gdbmi)) + (let* ((largest (get-largest-window)) + (cur-size (window-height largest))) + (setq answer (split-window largest)) + (set-window-buffer answer buf) + (set-window-dedicated-p answer dedicated) + answer) + (set-window-buffer window buf) + window))))) + + +;;; Shared keymap initialization: + +(let ((menu (make-sparse-keymap "GDB-Windows"))) + (define-key gud-menu-map [displays] + `(menu-item "GDB-Windows" ,menu + :help "Open a GDB-UI buffer in a new window." + :visible (memq gud-minor-mode '(gdbmi gdba)))) + (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer)) + (define-key menu [threads] '("Threads" . gdb-display-threads-buffer)) + (define-key menu [inferior] + '(menu-item "Separate IO" gdb-display-separate-io-buffer + :enable gdb-use-separate-io-buffer)) + (define-key menu [memory] '("Memory" . gdb-display-memory-buffer)) + (define-key menu [registers] '("Registers" . gdb-display-registers-buffer)) + (define-key menu [disassembly] + '("Disassembly" . gdb-display-assembler-buffer)) + (define-key menu [breakpoints] + '("Breakpoints" . gdb-display-breakpoints-buffer)) + (define-key menu [locals] '("Locals" . gdb-display-locals-buffer)) + (define-key menu [frames] '("Stack" . gdb-display-stack-buffer))) + +(let ((menu (make-sparse-keymap "GDB-Frames"))) + (define-key gud-menu-map [frames] + `(menu-item "GDB-Frames" ,menu + :help "Open a GDB-UI buffer in a new frame." + :visible (memq gud-minor-mode '(gdbmi gdba)))) + (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer)) + (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer)) + (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer)) + (define-key menu [inferior] + '(menu-item "Separate IO" gdb-frame-separate-io-buffer + :enable gdb-use-separate-io-buffer)) + (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer)) + (define-key menu [disassembly] '("Disassembly" . gdb-frame-assembler-buffer)) + (define-key menu [breakpoints] + '("Breakpoints" . gdb-frame-breakpoints-buffer)) + (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer)) + (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))) + +(let ((menu (make-sparse-keymap "GDB-UI/MI"))) + (define-key gud-menu-map [ui] + `(menu-item (if (eq gud-minor-mode 'gdba) "GDB-UI" "GDB-MI") + ,menu :visible (memq gud-minor-mode '(gdbmi gdba)))) + (define-key menu [gdb-customize] + '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb)) + :help "Customize Gdb Graphical Mode options.")) + (define-key menu [gdb-find-source-frame] + '(menu-item "Look For Source Frame" gdb-find-source-frame + :visible (eq gud-minor-mode 'gdba) + :help "Toggle looking for source frame further up call stack." + :button (:toggle . gdb-find-source-frame))) + (define-key menu [gdb-use-separate-io] + '(menu-item "Separate IO" gdb-use-separate-io-buffer + :visible (eq gud-minor-mode 'gdba) + :help "Toggle separate IO for debugged program." + :button (:toggle . gdb-use-separate-io-buffer))) + (define-key menu [gdb-many-windows] + '(menu-item "Display Other Windows" gdb-many-windows + :help "Toggle display of locals, stack and breakpoint information" + :button (:toggle . gdb-many-windows))) + (define-key menu [gdb-restore-windows] + '(menu-item "Restore Window Layout" gdb-restore-windows + :help "Restore standard layout for debug session."))) + +(defun gdb-frame-gdb-buffer () + "Display GUD buffer in a new frame." + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist + (remove '(menu-bar-lines) (remove '(tool-bar-lines) + gdb-frame-parameters))) + (same-window-regexps nil)) + (display-buffer gud-comint-buffer))) + +(defun gdb-display-gdb-buffer () + "Display GUD buffer." + (interactive) + (let ((same-window-regexps nil)) + (select-window (display-buffer gud-comint-buffer nil 0)))) + +(defun gdb-set-window-buffer (name) + (set-window-buffer (selected-window) (get-buffer name)) + (set-window-dedicated-p (selected-window) t)) + +(defun gdb-setup-windows () + "Layout the window pattern for `gdb-many-windows'." + (gdb-display-locals-buffer) + (gdb-display-stack-buffer) + (delete-other-windows) + (gdb-display-breakpoints-buffer) + (delete-other-windows) + ; Don't dedicate. + (pop-to-buffer gud-comint-buffer) + (split-window nil ( / ( * (window-height) 3) 4)) + (split-window nil ( / (window-height) 3)) + (split-window-horizontally) + (other-window 1) + (gdb-set-window-buffer (gdb-locals-buffer-name)) + (other-window 1) + (switch-to-buffer + (if gud-last-last-frame + (gud-find-file (car gud-last-last-frame)) + (if gdb-main-file + (gud-find-file gdb-main-file) + ;; Put buffer list in window if we + ;; can't find a source file. + (list-buffers-noselect)))) + (setq gdb-source-window (selected-window)) + (when gdb-use-separate-io-buffer + (split-window-horizontally) + (other-window 1) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-inferior-io))) + (other-window 1) + (gdb-set-window-buffer (gdb-stack-buffer-name)) + (split-window-horizontally) + (other-window 1) + (gdb-set-window-buffer (gdb-breakpoints-buffer-name)) + (other-window 1)) + +(defun gdb-restore-windows () + "Restore the basic arrangement of windows used by gdba. +This arrangement depends on the value of `gdb-many-windows'." + (interactive) + (pop-to-buffer gud-comint-buffer) ;Select the right window and frame. + (delete-other-windows) + (if gdb-many-windows + (gdb-setup-windows) + (when (or gud-last-last-frame gdb-show-main) + (split-window) + (other-window 1) + (switch-to-buffer + (if gud-last-last-frame + (gud-find-file (car gud-last-last-frame)) + (gud-find-file gdb-main-file))) + (setq gdb-source-window (selected-window)) + (other-window 1)))) + +(defun gdb-reset () + "Exit a debugging session cleanly. +Kills the gdb buffers, and resets variables and the source buffers." + (dolist (buffer (buffer-list)) + (unless (eq buffer gud-comint-buffer) + (with-current-buffer buffer + (if (memq gud-minor-mode '(gdbmi gdba)) + (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name)) + (kill-buffer nil) + (gdb-remove-breakpoint-icons (point-min) (point-max) t) + (setq gud-minor-mode nil) + (kill-local-variable 'tool-bar-map) + (kill-local-variable 'gdb-define-alist)))))) + (setq gdb-overlay-arrow-position nil) + (setq overlay-arrow-variable-list + (delq 'gdb-overlay-arrow-position overlay-arrow-variable-list)) + (setq fringe-indicator-alist '((overlay-arrow . right-triangle))) + (setq gdb-stack-position nil) + (setq overlay-arrow-variable-list + (delq 'gdb-stack-position overlay-arrow-variable-list)) + (if (boundp 'speedbar-frame) (speedbar-timer-fn)) + (setq gud-running nil) + (setq gdb-active-process nil) + (setq gdb-var-list nil) + (remove-hook 'after-save-hook 'gdb-create-define-alist t)) + +(defun gdb-source-info () + "Find the source file where the program starts and display it with related +buffers." + (goto-char (point-min)) + (if (and (search-forward "Located in " nil t) + (looking-at "\\S-+")) + (setq gdb-main-file (match-string 0))) + (goto-char (point-min)) + (if (search-forward "Includes preprocessor macro info." nil t) + (setq gdb-macro-info t)) + (if gdb-many-windows + (gdb-setup-windows) + (gdb-get-buffer-create 'gdb-breakpoints-buffer) + (if (and gdb-show-main gdb-main-file) + (let ((pop-up-windows t)) + (display-buffer (gud-find-file gdb-main-file))))) + (setq gdb-ready t)) + +(defun gdb-get-location (bptno line flag) + "Find the directory containing the relevant source file. +Put in buffer and place breakpoint icon." + (goto-char (point-min)) + (catch 'file-not-found + (if (search-forward "Located in " nil t) + (when (looking-at "\\S-+") + (delete (cons bptno "File not found") gdb-location-alist) + (push (cons bptno (match-string 0)) gdb-location-alist)) + (gdb-resync) + (unless (assoc bptno gdb-location-alist) + (push (cons bptno "File not found") gdb-location-alist) + (message-box "Cannot find source file for breakpoint location.\n\ +Add directory to search path for source files using the GDB command, dir.")) + (throw 'file-not-found nil)) + (with-current-buffer + (find-file-noselect (match-string 0)) + (gdb-init-buffer) + ;; only want one breakpoint icon at each location + (save-excursion + (goto-char (point-min)) + (forward-line (1- (string-to-number line))) + (gdb-put-breakpoint-icon (eq flag ?y) bptno))))) + +(add-hook 'find-file-hook 'gdb-find-file-hook) + +(defun gdb-find-file-hook () + "Set up buffer for debugging if file is part of the source code +of the current session." + (if (and (buffer-name gud-comint-buffer) + ;; in case gud or gdb-ui is just loaded + gud-comint-buffer + (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdba gdbmi))) + ;;Pre GDB 6.3 "info sources" doesn't give absolute file name. + (if (member (if (string-equal gdb-version "pre-6.4") + (file-name-nondirectory buffer-file-name) + buffer-file-name) + gdb-source-file-list) + (with-current-buffer (find-buffer-visiting buffer-file-name) + (gdb-init-buffer))))) + +;;from put-image +(defun gdb-put-string (putstring pos &optional dprop &rest sprops) + "Put string PUTSTRING in front of POS in the current buffer. +PUTSTRING is displayed by putting an overlay into the current buffer with a +`before-string' string that has a `display' property whose value is +PUTSTRING." + (let ((string (make-string 1 ?x)) + (buffer (current-buffer))) + (setq putstring (copy-sequence putstring)) + (let ((overlay (make-overlay pos pos buffer)) + (prop (or dprop + (list (list 'margin 'left-margin) putstring)))) + (put-text-property 0 1 'display prop string) + (if sprops + (add-text-properties 0 1 sprops string)) + (overlay-put overlay 'put-break t) + (overlay-put overlay 'before-string string)))) + +;;from remove-images +(defun gdb-remove-strings (start end &optional buffer) + "Remove strings between START and END in BUFFER. +Remove only strings that were put in BUFFER with calls to `gdb-put-string'. +BUFFER nil or omitted means use the current buffer." + (unless buffer + (setq buffer (current-buffer))) + (dolist (overlay (overlays-in start end)) + (when (overlay-get overlay 'put-break) + (delete-overlay overlay)))) + +(defun gdb-put-breakpoint-icon (enabled bptno) + (if (string-match "[0-9+]+\\." bptno) + (setq enabled gdb-parent-bptno-enabled)) + (let ((start (- (line-beginning-position) 1)) + (end (+ (line-end-position) 1)) + (putstring (if enabled "B" "b")) + (source-window (get-buffer-window (current-buffer) 0))) + (add-text-properties + 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt") + putstring) + (if enabled + (add-text-properties + 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring) + (add-text-properties + 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring)) + (gdb-remove-breakpoint-icons start end) + (if (display-images-p) + (if (>= (or left-fringe-width + (if source-window (car (window-fringes source-window))) + gdb-buffer-fringe-width) 8) + (gdb-put-string + nil (1+ start) + `(left-fringe breakpoint + ,(if enabled + 'breakpoint-enabled + 'breakpoint-disabled)) + 'gdb-bptno bptno + 'gdb-enabled enabled) + (when (< left-margin-width 2) + (save-current-buffer + (setq left-margin-width 2) + (if source-window + (set-window-margins + source-window + left-margin-width right-margin-width)))) + (put-image + (if enabled + (or breakpoint-enabled-icon + (setq breakpoint-enabled-icon + (find-image `((:type xpm :data + ,breakpoint-xpm-data + :ascent 100 :pointer hand) + (:type pbm :data + ,breakpoint-enabled-pbm-data + :ascent 100 :pointer hand))))) + (or breakpoint-disabled-icon + (setq breakpoint-disabled-icon + (find-image `((:type xpm :data + ,breakpoint-xpm-data + :conversion disabled + :ascent 100 :pointer hand) + (:type pbm :data + ,breakpoint-disabled-pbm-data + :ascent 100 :pointer hand)))))) + (+ start 1) + putstring + 'left-margin)) + (when (< left-margin-width 2) + (save-current-buffer + (setq left-margin-width 2) + (let ((window (get-buffer-window (current-buffer) 0))) + (if window + (set-window-margins + window left-margin-width right-margin-width))))) + (gdb-put-string + (propertize putstring + 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled)) + (1+ start))))) + +(defun gdb-remove-breakpoint-icons (start end &optional remove-margin) + (gdb-remove-strings start end) + (if (display-images-p) + (remove-images start end)) + (when remove-margin + (setq left-margin-width 0) + (let ((window (get-buffer-window (current-buffer) 0))) + (if window + (set-window-margins + window left-margin-width right-margin-width))))) + + +;; +;; Assembler buffer. +;; +(gdb-set-buffer-rules 'gdb-assembler-buffer + 'gdb-assembler-buffer-name + 'gdb-assembler-mode) + +;; We can't use def-gdb-auto-update-handler because we don't want to use +;; window-start but keep the overlay arrow/current line visible. +(defun gdb-assembler-handler () + (setq gdb-pending-triggers + (delq 'gdb-invalidate-assembler + gdb-pending-triggers)) + (let ((buf (gdb-get-buffer 'gdb-assembler-buffer))) + (and buf + (with-current-buffer buf + (let* ((window (get-buffer-window buf 0)) + (p (window-point window)) + (buffer-read-only nil)) + (erase-buffer) + (insert-buffer-substring (gdb-get-buffer-create + 'gdb-partial-output-buffer)) + (set-window-point window p))))) + ;; put customisation here + (gdb-assembler-custom)) + +(defun gdb-assembler-custom () + (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer)) + (pos 1) (address) (flag) (bptno)) + (with-current-buffer buffer + (save-excursion + (if (not (equal gdb-pc-address "main")) + (progn + (goto-char (point-min)) + (if (and gdb-pc-address + (search-forward gdb-pc-address nil t)) + (progn + (setq pos (point)) + (beginning-of-line) + (setq fringe-indicator-alist + (if (string-equal gdb-frame-number "0") + nil + '((overlay-arrow . hollow-right-triangle)))) + (or gdb-overlay-arrow-position + (setq gdb-overlay-arrow-position (make-marker))) + (set-marker gdb-overlay-arrow-position (point)))))) + ;; remove all breakpoint-icons in assembler buffer before updating. + (gdb-remove-breakpoint-icons (point-min) (point-max)))) + (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer) + (goto-char (point-min)) + (while (< (point) (- (point-max) 1)) + (forward-line 1) + (when (looking-at + "\\([0-9]+\\.?[0-9]*\\).*?\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)") + (setq bptno (match-string 1)) + (setq flag (char-after (match-beginning 2))) + (setq address (match-string 3)) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (if (re-search-forward (concat "^0x0*" address) nil t) + (gdb-put-breakpoint-icon (eq flag ?y) bptno))))))) + (if (not (equal gdb-pc-address "main")) + (with-current-buffer buffer + (set-window-point (get-buffer-window buffer 0) pos))))) + +(defvar gdb-assembler-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'kill-this-buffer) + map)) + +(defvar gdb-assembler-font-lock-keywords + '(;; <__function.name+n> + ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" + (1 font-lock-function-name-face)) + ;; 0xNNNNNNNN <__function.name+n>: opcode + ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)" + (4 font-lock-keyword-face)) + ;; %register(at least i386) + ("%\\sw+" . font-lock-variable-name-face) + ("^\\(Dump of assembler code for function\\) \\(.+\\):" + (1 font-lock-comment-face) + (2 font-lock-function-name-face)) + ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face)) + "Font lock keywords used in `gdb-assembler-mode'.") + +(defun gdb-assembler-mode () + "Major mode for viewing code assembler. + +\\{gdb-assembler-mode-map}" + (kill-all-local-variables) + (setq major-mode 'gdb-assembler-mode) + (setq mode-name (concat "Machine:" gdb-selected-frame)) + (setq gdb-overlay-arrow-position nil) + (add-to-list 'overlay-arrow-variable-list 'gdb-overlay-arrow-position) + (setq fringes-outside-margins t) + (setq buffer-read-only t) + (buffer-disable-undo) + (gdb-thread-identification) + (use-local-map gdb-assembler-mode-map) + (gdb-invalidate-assembler) + (set (make-local-variable 'font-lock-defaults) + '(gdb-assembler-font-lock-keywords)) + (run-mode-hooks 'gdb-assembler-mode-hook) + 'gdb-invalidate-assembler) + +(defun gdb-assembler-buffer-name () + (with-current-buffer gud-comint-buffer + (concat "*disassembly of " (gdb-get-target-string) "*"))) + +(defun gdb-display-assembler-buffer () + "Display disassembly view." + (interactive) + (setq gdb-previous-frame nil) + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-assembler-buffer) t)) + +(defun gdb-frame-assembler-buffer () + "Display disassembly view in a new frame." + (interactive) + (setq gdb-previous-frame nil) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create 'gdb-assembler-buffer)))) + +;; modified because if gdb-pc-address has changed value a new command +;; must be enqueued to update the buffer with the new output +(defun gdb-invalidate-assembler (&optional ignored) + (if (gdb-get-buffer 'gdb-assembler-buffer) + (progn + (unless (and gdb-selected-frame + (string-equal gdb-selected-frame gdb-previous-frame)) + (if (or (not (member 'gdb-invalidate-assembler + gdb-pending-triggers)) + (not (equal (string-to-number gdb-pc-address) + (string-to-number + gdb-previous-frame-pc-address)))) + (progn + ;; take previous disassemble command, if any, off the queue + (with-current-buffer gud-comint-buffer + (let ((queue gdb-input-queue)) + (dolist (item queue) + (if (equal (cdr item) '(gdb-assembler-handler)) + (setq gdb-input-queue + (delete item gdb-input-queue)))))) + (gdb-enqueue-input + (list + (concat gdb-server-prefix "disassemble " gdb-pc-address "\n") + 'gdb-assembler-handler)) + (push 'gdb-invalidate-assembler gdb-pending-triggers) + (setq gdb-previous-frame-pc-address gdb-pc-address) + (setq gdb-previous-frame gdb-selected-frame))))))) + +(defun gdb-get-selected-frame () + (if (not (member 'gdb-get-selected-frame gdb-pending-triggers)) + (progn + (if (string-equal gdb-version "pre-6.4") + (gdb-enqueue-input + (list (concat gdb-server-prefix "info frame\n") + 'gdb-frame-handler)) + (gdb-enqueue-input + (list "server interpreter mi -stack-info-frame\n" + 'gdb-frame-handler-1))) + (push 'gdb-get-selected-frame gdb-pending-triggers)))) + +(defun gdb-frame-handler () + (setq gdb-pending-triggers + (delq 'gdb-get-selected-frame gdb-pending-triggers)) + (goto-char (point-min)) + (when (re-search-forward + "Stack level \\([0-9]+\\), frame at \\(0x[[:xdigit:]]+\\)" nil t) + (setq gdb-frame-number (match-string 1)) + (setq gdb-frame-address (match-string 2))) + (goto-char (point-min)) + (when (re-search-forward ".*=\\s-+\\(\\S-*\\)\\s-+in\\s-+\\(.*?\\)\ +\\(?: (\\(\\S-+?\\):[0-9]+?)\\)*; " + nil t) + (setq gdb-selected-frame (match-string 2)) + (if (gdb-get-buffer 'gdb-locals-buffer) + (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) + (setq mode-name (concat "Locals:" gdb-selected-frame)))) + (if (gdb-get-buffer 'gdb-assembler-buffer) + (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer) + (setq mode-name (concat "Machine:" gdb-selected-frame)))) + (setq gdb-pc-address (match-string 1)) + (if (and (match-string 3) gud-overlay-arrow-position) + (let ((buffer (marker-buffer gud-overlay-arrow-position)) + (position (marker-position gud-overlay-arrow-position))) + (when (and buffer + (string-equal (file-name-nondirectory + (buffer-file-name buffer)) + (file-name-nondirectory (match-string 3)))) + (with-current-buffer buffer + (setq fringe-indicator-alist + (if (string-equal gdb-frame-number "0") + nil + '((overlay-arrow . hollow-right-triangle)))) + (set-marker gud-overlay-arrow-position position)))))) + (goto-char (point-min)) + (if (re-search-forward " source language \\(\\S-+\\)\." nil t) + (setq gdb-current-language (match-string 1))) + (gdb-invalidate-assembler)) + + +;; Code specific to GDB 6.4 +(defconst gdb-source-file-regexp-1 "fullname=\"\\(.*?\\)\"") + +(defun gdb-set-gud-minor-mode-existing-buffers-1 () + "Create list of source files for current GDB session. +If buffers already exist for any of these files, `gud-minor-mode' +is set in them." + (goto-char (point-min)) + (while (re-search-forward gdb-source-file-regexp-1 nil t) + (push (match-string 1) gdb-source-file-list)) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (member buffer-file-name gdb-source-file-list) + (gdb-init-buffer)))) + (gdb-force-mode-line-update + (propertize "ready" 'face font-lock-variable-name-face))) + +;; Used for -stack-info-frame but could be used for -stack-list-frames too. +(defconst gdb-stack-list-frames-regexp +".*?level=\"\\(.*?\\)\".*?,addr=\"\\(.*?\\)\".*?,func=\"\\(.*?\\)\",\ +\\(?:.*?file=\".*?\".*?,fullname=\"\\(.*?\\)\".*?,line=\"\\(.*?\\)\".*?}\\|\ +from=\"\\(.*?\\)\"\\)") + +(defun gdb-frame-handler-1 () + (setq gdb-pending-triggers + (delq 'gdb-get-selected-frame gdb-pending-triggers)) + (goto-char (point-min)) + (when (re-search-forward gdb-stack-list-frames-regexp nil t) + (setq gdb-frame-number (match-string 1)) + (setq gdb-pc-address (match-string 2)) + (setq gdb-selected-frame (match-string 3)) + (if (gdb-get-buffer 'gdb-locals-buffer) + (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) + (setq mode-name (concat "Locals:" gdb-selected-frame)))) + (if (gdb-get-buffer 'gdb-assembler-buffer) + (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer) + (setq mode-name (concat "Machine:" gdb-selected-frame))))) + (if (and (match-string 4) (match-string 5) gud-overlay-arrow-position) + (let ((buffer (marker-buffer gud-overlay-arrow-position)) + (position (marker-position gud-overlay-arrow-position))) + (when (and buffer + (string-equal (file-name-nondirectory + (buffer-file-name buffer)) + (file-name-nondirectory (match-string 4)))) + (with-current-buffer buffer + (setq fringe-indicator-alist + (if (string-equal gdb-frame-number "0") + nil + '((overlay-arrow . hollow-right-triangle)))) + (set-marker gud-overlay-arrow-position position))))) + (gdb-invalidate-assembler)) + +; Uses "-var-list-children --all-values". Needs GDB 6.4 onwards. +(defun gdb-var-list-children-1 (varnum) + (gdb-enqueue-input + (list + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + (concat "server interpreter mi \"-var-list-children --all-values \\\"" + varnum "\\\"\"\n") + (concat "-var-list-children --all-values \"" varnum "\"\n")) + `(lambda () (gdb-var-list-children-handler-1 ,varnum))))) + +(defun gdb-var-list-children-handler-1 (varnum) + (let* ((var-list nil) + (output (bindat-get-field (gdb-json-partial-output "child"))) + (children (bindat-get-field output 'children))) + (catch 'child-already-watched + (dolist (var gdb-var-list) + (if (string-equal varnum (car var)) + (progn + ;; With dynamic varobjs numchild may have increased. + (setcar (nthcdr 2 var) (bindat-get-field output 'numchild)) + (push var var-list) + (dolist (child children) + (let ((varchild (list (bindat-get-field child 'name) + (bindat-get-field child 'exp) + (bindat-get-field child 'numchild) + (bindat-get-field child 'type) + (bindat-get-field child 'value) + nil + (bindat-get-field child 'has_more)))) + (if (assoc (car varchild) gdb-var-list) + (throw 'child-already-watched nil)) + (push varchild var-list)))) + (push var var-list))) + (setq gdb-var-list (nreverse var-list)))) + (gdb-speedbar-update)) + +; Uses "-var-update --all-values". Needs GDB 6.4 onwards. +(defun gdb-var-update-1 () + (if (not (member 'gdb-var-update gdb-pending-triggers)) + (progn + (gdb-enqueue-input + (list + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + "server interpreter mi \"-var-update --all-values *\"\n" + "-var-update --all-values *\n") + 'gdb-var-update-handler-1)) + (push 'gdb-var-update gdb-pending-triggers)))) + +(defun gdb-var-update-handler-1 () + (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist))) + (dolist (var gdb-var-list) + (setcar (nthcdr 5 var) nil)) + (let ((temp-var-list gdb-var-list)) + (dolist (change changelist) + (let* ((varnum (bindat-get-field change 'name)) + (var (assoc varnum gdb-var-list)) + (new-num (bindat-get-field change 'new_num_children))) + (when var + (let ((scope (bindat-get-field change 'in_scope)) + (has-more (bindat-get-field change 'has_more))) + (cond ((string-equal scope "false") + (if gdb-delete-out-of-scope + (gdb-var-delete-1 var varnum) + (setcar (nthcdr 5 var) 'out-of-scope))) + ((string-equal scope "true") + (setcar (nthcdr 6 var) has-more) + (when (and (or (not has-more) + (string-equal has-more "0")) + (not new-num) + (string-equal (nth 2 var) "0")) + (setcar (nthcdr 4 var) + (bindat-get-field change 'value)) + (setcar (nthcdr 5 var) 'changed))) + ((string-equal scope "invalid") + (gdb-var-delete-1 var varnum))))) + (let ((var-list nil) var1 + (children (bindat-get-field change 'new_children))) + (if new-num + (progn + (setq var1 (pop temp-var-list)) + (while var1 + (if (string-equal varnum (car var1)) + (let ((new (string-to-number new-num)) + (previous (string-to-number (nth 2 var1)))) + (setcar (nthcdr 2 var1) new-num) + (push var1 var-list) + (cond ((> new previous) + ;; Add new children to list. + (dotimes (dummy previous) + (push (pop temp-var-list) var-list)) + (dolist (child children) + (let ((varchild + (list (bindat-get-field child 'name) + (bindat-get-field child 'exp) + (bindat-get-field child 'numchild) + (bindat-get-field child 'type) + (bindat-get-field child 'value) + 'changed + (bindat-get-field child 'has_more)))) + (push varchild var-list)))) + ;; Remove deleted children from list. + ((< new previous) + (dotimes (dummy new) + (push (pop temp-var-list) var-list)) + (dotimes (dummy (- previous new)) + (pop temp-var-list))))) + (push var1 var-list)) + (setq var1 (pop temp-var-list))) + (setq gdb-var-list (nreverse var-list))))))))) + (setq gdb-pending-triggers + (delq 'gdb-var-update gdb-pending-triggers)) + (gdb-speedbar-update)) + +;; Registers buffer. +;; +(gdb-set-buffer-rules 'gdb-registers-buffer + 'gdb-registers-buffer-name + 'gdb-registers-mode) + +(def-gdb-auto-update-trigger gdb-invalidate-registers-1 + (gdb-get-buffer 'gdb-registers-buffer) + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + "server interpreter mi \"-data-list-register-values x\"\n" + "-data-list-register-values x\n") + gdb-data-list-register-values-handler) + +(defconst gdb-data-list-register-values-regexp + "{.*?number=\"\\(.*?\\)\".*?,value=\"\\(.*?\\)\".*?}") + +(defun gdb-data-list-register-values-handler () + (setq gdb-pending-triggers (delq 'gdb-invalidate-registers-1 + gdb-pending-triggers)) + (goto-char (point-min)) + (if (re-search-forward gdb-error-regexp nil t) + (let ((err (match-string 1))) + (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) + (let ((buffer-read-only nil)) + (erase-buffer) + (put-text-property 0 (length err) 'face font-lock-warning-face err) + (insert err) + (goto-char (point-min))))) + (let ((register-list (reverse gdb-register-names)) + (register nil) (register-string nil) (register-values nil)) + (goto-char (point-min)) + (while (re-search-forward gdb-data-list-register-values-regexp nil t) + (setq register (pop register-list)) + (setq register-string (concat register "\t" (match-string 2) "\n")) + (if (member (match-string 1) gdb-changed-registers) + (put-text-property 0 (length register-string) + 'face 'font-lock-warning-face + register-string)) + (setq register-values + (concat register-values register-string))) + (let ((buf (gdb-get-buffer 'gdb-registers-buffer))) + (with-current-buffer buf + (let* ((window (get-buffer-window buf 0)) + (start (window-start window)) + (p (if window (window-point window) (point))) + (buffer-read-only nil)) + (erase-buffer) + (insert register-values) + (if window + (progn + (set-window-start window start) + (set-window-point window p)) + (goto-char p))))))) + (gdb-data-list-register-values-custom)) + +(defun gdb-data-list-register-values-custom () + (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) + (save-excursion + (let ((buffer-read-only nil) + start end) + (goto-char (point-min)) + (while (< (point) (point-max)) + (setq start (line-beginning-position)) + (setq end (line-end-position)) + (when (looking-at "^[^\t]+") + (unless (string-equal (match-string 0) "No registers.") + (put-text-property start (match-end 0) + 'face font-lock-variable-name-face) + (add-text-properties start end + '(help-echo "mouse-2: edit value" + mouse-face highlight)))) + (forward-line 1)))))) + +;; Needs GDB 6.4 onwards (used to fail with no stack). +(defun gdb-get-changed-registers () + (if (and (gdb-get-buffer 'gdb-registers-buffer) + (not (member 'gdb-get-changed-registers gdb-pending-triggers))) + (progn + (gdb-enqueue-input + (list + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + "server interpreter mi -data-list-changed-registers\n" + "-data-list-changed-registers\n") + 'gdb-get-changed-registers-handler)) + (push 'gdb-get-changed-registers gdb-pending-triggers)))) + +(defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"") + +(defun gdb-get-changed-registers-handler () + (setq gdb-pending-triggers + (delq 'gdb-get-changed-registers gdb-pending-triggers)) + (setq gdb-changed-registers nil) + (goto-char (point-min)) + (while (re-search-forward gdb-data-list-register-names-regexp nil t) + (push (match-string 1) gdb-changed-registers))) + + +;; Locals buffer. +;; +;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards. +(gdb-set-buffer-rules 'gdb-locals-buffer + 'gdb-locals-buffer-name + 'gdb-locals-mode) + +(def-gdb-auto-update-trigger gdb-invalidate-locals-1 + (gdb-get-buffer 'gdb-locals-buffer) + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) + "server interpreter mi -\"stack-list-locals --simple-values\"\n" + "-stack-list-locals --simple-values\n") + gdb-stack-list-locals-handler) + +(defconst gdb-stack-list-locals-regexp + "{.*?name=\"\\(.*?\\)\".*?,type=\"\\(.*?\\)\"") + +(defvar gdb-locals-watch-map-1 + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "\r" 'gud-watch) + (define-key map [mouse-2] 'gud-watch) + map) + "Keymap to create watch expression of a complex data type local variable.") + +(defvar gdb-edit-locals-map-1 + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "\r" 'gdb-edit-locals-value) + (define-key map [mouse-2] 'gdb-edit-locals-value) + map) + "Keymap to edit value of a simple data type local variable.") + +(defun gdb-edit-locals-value (&optional event) + "Assign a value to a variable displayed in the locals buffer." + (interactive (list last-input-event)) + (save-excursion + (if event (posn-set-point (event-end event))) + (beginning-of-line) + (let* ((var (current-word)) + (value (read-string (format "New value (%s): " var)))) + (gdb-enqueue-input + (list (concat gdb-server-prefix "set variable " var " = " value "\n") + 'ignore))))) + +;; Dont display values of arrays or structures. +;; These can be expanded using gud-watch. +(defun gdb-stack-list-locals-handler () + (setq gdb-pending-triggers (delq 'gdb-invalidate-locals-1 + gdb-pending-triggers)) + (goto-char (point-min)) + (if (re-search-forward gdb-error-regexp nil t) + (let ((err (match-string 1))) + (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert err) + (goto-char (point-min))))) + (let (local locals-list) + (goto-char (point-min)) + (while (re-search-forward gdb-stack-list-locals-regexp nil t) + (let ((local (list (match-string 1) + (match-string 2) + nil))) + (if (looking-at ",value=\\(\".*\"\\).*?}") + (setcar (nthcdr 2 local) (read (match-string 1)))) + (push local locals-list))) + (let ((buf (gdb-get-buffer 'gdb-locals-buffer))) + (and buf (with-current-buffer buf + (let* ((window (get-buffer-window buf 0)) + (start (window-start window)) + (p (if window (window-point window) (point))) + (buffer-read-only nil) (name) (value)) + (erase-buffer) + (dolist (local locals-list) + (setq name (car local)) + (setq value (nth 2 local)) + (if (or (not value) + (string-match "^\\0x" value)) + (add-text-properties 0 (length name) + `(mouse-face highlight + help-echo "mouse-2: create watch expression" + local-map ,gdb-locals-watch-map-1) + name) + (add-text-properties 0 (length value) + `(mouse-face highlight + help-echo "mouse-2: edit value" + local-map ,gdb-edit-locals-map-1) + value)) + (insert + (concat name "\t" (nth 1 local) + "\t" value "\n"))) + (if window + (progn + (set-window-start window start) + (set-window-point window p)) + (goto-char p))))))))) + +(defun gdb-get-register-names () + "Create a list of register names." + (goto-char (point-min)) + (while (re-search-forward gdb-data-list-register-names-regexp nil t) + (push (match-string 1) gdb-register-names))) + +(provide 'gdb-ui) + +;; arch-tag: e9fb00c5-74ef-469f-a088-37384caae352 +;;; gdb-ui.el ends here
--- a/lisp/progmodes/gud.el Mon Dec 28 22:46:08 2009 -0800 +++ b/lisp/progmodes/gud.el Tue Dec 29 20:22:00 2009 +1300 @@ -43,8 +43,10 @@ (require 'comint) (defvar gdb-active-process) +(defvar gdb-recording) (defvar gdb-define-alist) (defvar gdb-macro-info) +(defvar gdb-server-prefix) (defvar gdb-show-changed-values) (defvar gdb-source-window) (defvar gdb-var-list) @@ -124,51 +126,77 @@ (throw 'info-found nil)))) nil 0) (select-frame (make-frame))) - (if (eq gud-minor-mode 'gdbmi) + (if (memq gud-minor-mode '(gdbmi gdba)) (info "(emacs)GDB Graphical Interface") (info "(emacs)Debuggers")))) (defun gud-tool-bar-item-visible-no-fringe () (not (or (eq (buffer-local-value 'major-mode (window-buffer)) 'speedbar-mode) - (and (eq gud-minor-mode 'gdbmi) + (and (memq gud-minor-mode '(gdbmi gdba)) (> (car (window-fringes)) 0))))) -(declare-function gdb-gud-context-command "gdb-mi.el") - (defun gud-stop-subjob () (interactive) (with-current-buffer gud-comint-buffer - (cond ((string-equal gud-target-name "emacs") - (comint-stop-subjob)) - ((eq gud-minor-mode 'jdb) - (gud-call "suspend")) - ((eq gud-minor-mode 'gdbmi) - (gud-call (gdb-gud-context-command "-exec-interrupt"))) - (t - (comint-interrupt-subjob))))) + (if (string-equal gud-target-name "emacs") + (comint-stop-subjob) + (if (eq gud-minor-mode 'jdb) + (gud-call "suspend") + (comint-interrupt-subjob))))) (easy-mmode-defmap gud-menu-map '(([help] "Info (debugger)" . gud-goto-info) + ([rfinish] menu-item "Reverse Finish Function" gud-rfinish + :enable (not gud-running) + :visible (and gdb-recording + (eq gud-minor-mode 'gdba))) + ([rstepi] menu-item "Reverse Step Instruction" gud-rstepi + :enable (not gud-running) + :visible (and gdb-recording + (eq gud-minor-mode 'gdba))) + ([rnexti] menu-item "Reverse Next Instruction" gud-rnexti + :enable (not gud-running) + :visible (and gdb-recording + (eq gud-minor-mode 'gdba))) + ([rstep] menu-item "Reverse Step Line" gud-rstep + :enable (not gud-running) + :visible (and gdb-recording + (eq gud-minor-mode 'gdba))) + ([rnext] menu-item "Reverse Next Line" gud-rnext + :enable (not gud-running) + :visible (and gdb-recording + (eq gud-minor-mode 'gdba))) + ([rcont] menu-item "Reverse Continue" gud-rcont + :enable (not gud-running) + :visible (and gdb-recording + (eq gud-minor-mode 'gdba))) + ([recstart] menu-item "Start Recording" gdb-toggle-recording-1 + :visible (and (not gdb-recording) + (eq gud-minor-mode 'gdba))) + ([recstop] menu-item "Stop Recording" gdb-toggle-recording + :visible (and gdb-recording + (eq gud-minor-mode 'gdba))) ([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode :enable (and (not emacs-basic-display) (display-graphic-p) (fboundp 'x-show-tip)) :visible (memq gud-minor-mode - '(gdbmi dbx sdb xdb pdb)) + '(gdbmi gdba dbx sdb xdb pdb)) :button (:toggle . gud-tooltip-mode)) ([refresh] "Refresh" . gud-refresh) ([run] menu-item "Run" gud-run :enable (not gud-running) :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) ([go] menu-item (if gdb-active-process "Continue" "Run") gud-go - :visible (and (eq gud-minor-mode 'gdbmi) - (gdb-show-run-p))) + :visible (and (not gud-running) + (eq gud-minor-mode 'gdba))) ([stop] menu-item "Stop" gud-stop-subjob - :visible (or (not (memq gud-minor-mode '(gdbmi pdb))) - (gdb-show-stop-p))) + :visible (or (not (memq gud-minor-mode '(gdba pdb))) + (and gud-running + (eq gud-minor-mode 'gdba)))) ([until] menu-item "Continue to selection" gud-until :enable (not gud-running) - :visible (and (memq gud-minor-mode '(gdbmi gdb perldb)) + :visible (and (memq gud-minor-mode '(gdbmi gdba gdb perldb)) (gud-tool-bar-item-visible-no-fringe))) ([remove] menu-item "Remove Breakpoint" gud-remove :enable (not gud-running) @@ -176,52 +204,50 @@ ([tbreak] menu-item "Temporary Breakpoint" gud-tbreak :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdb sdb xdb))) + '(gdbmi gdba gdb sdb xdb))) ([break] menu-item "Set Breakpoint" gud-break :enable (not gud-running) :visible (gud-tool-bar-item-visible-no-fringe)) ([up] menu-item "Up Stack" gud-up :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdb dbx xdb jdb pdb))) + '(gdbmi gdba gdb dbx xdb jdb pdb))) ([down] menu-item "Down Stack" gud-down :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdb dbx xdb jdb pdb))) + '(gdbmi gdba gdb dbx xdb jdb pdb))) ([pp] menu-item "Print S-expression" gud-pp :enable (and (not gud-running) gdb-active-process) :visible (and (string-equal (buffer-local-value 'gud-target-name gud-comint-buffer) "emacs") - (eq gud-minor-mode 'gdbmi))) - ([print*] menu-item (if (eq gud-minor-mode 'jdb) - "Dump object" - "Print Dereference") gud-pstar + (eq gud-minor-mode 'gdba))) + ([print*] menu-item "Print Dereference" gud-pstar :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdb jdb))) + :visible (memq gud-minor-mode '(gdbmi gdba gdb))) ([print] menu-item "Print Expression" gud-print :enable (not gud-running)) ([watch] menu-item "Watch Expression" gud-watch :enable (not gud-running) - :visible (eq gud-minor-mode 'gdbmi)) + :visible (memq gud-minor-mode '(gdbmi gdba))) ([finish] menu-item "Finish Function" gud-finish :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdb xdb jdb pdb))) + '(gdbmi gdba gdb xdb jdb pdb))) ([stepi] menu-item "Step Instruction" gud-stepi :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdb dbx))) + :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) ([nexti] menu-item "Next Instruction" gud-nexti :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdb dbx))) + :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) ([step] menu-item "Step Line" gud-step :enable (not gud-running)) ([next] menu-item "Next Line" gud-next :enable (not gud-running)) ([cont] menu-item "Continue" gud-cont :enable (not gud-running) - :visible (not (eq gud-minor-mode 'gdbmi)))) + :visible (not (eq gud-minor-mode 'gdba)))) "Menu for `gud-mode'." :name "Gud") @@ -243,22 +269,21 @@ . (,(propertize "next" 'face 'font-lock-doc-face) . gud-next)) ([menu-bar until] menu-item ,(propertize "until" 'face 'font-lock-doc-face) gud-until - :visible (memq gud-minor-mode '(gdbmi gdb perldb))) + :visible (memq gud-minor-mode '(gdbmi gdba gdb perldb))) ([menu-bar cont] menu-item ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont - :visible (not (eq gud-minor-mode 'gdbmi))) + :visible (not (eq gud-minor-mode 'gdba))) ([menu-bar run] menu-item ,(propertize "run" 'face 'font-lock-doc-face) gud-run :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) ([menu-bar go] menu-item ,(propertize " go " 'face 'font-lock-doc-face) gud-go - :visible (and (eq gud-minor-mode 'gdbmi) - (gdb-show-run-p))) + :visible (and (not gud-running) + (eq gud-minor-mode 'gdba))) ([menu-bar stop] menu-item ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob - :visible (or (and (eq gud-minor-mode 'gdbmi) - (gdb-show-stop-p)) - (not (eq gud-minor-mode 'gdbmi)))) + :visible (and gud-running + (eq gud-minor-mode 'gdba))) ([menu-bar print] . (,(propertize "print" 'face 'font-lock-doc-face) . gud-print)) ([menu-bar tools] . undefined) @@ -297,6 +322,14 @@ (gud-stepi . "gud/stepi") (gud-up . "gud/up") (gud-down . "gud/down") + (gdb-toggle-recording-1 . "gud/recstart") + (gdb-toggle-recording . "gud/recstop") + (gud-rcont . "gud/rcont") + (gud-rnext . "gud/rnext") + (gud-rstep . "gud/rstep") + (gud-rfinish . "gud/rfinish") + (gud-rnexti . "gud/rnexti") + (gud-rstepi . "gud/rstepi") (gud-goto-info . "info")) map) (tool-bar-local-item-from-menu @@ -321,7 +354,7 @@ (setq directories (cdr directories))) result))) -(declare-function gdb-create-define-alist "gdb-mi" ()) +(declare-function gdb-create-define-alist "gdb-ui" ()) (defun gud-find-file (file) ;; Don't get confused by double slashes in the name that comes from GDB. @@ -337,7 +370,7 @@ (set (make-local-variable 'gud-minor-mode) minor-mode) (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) (when (and gud-tooltip-mode - (eq gud-minor-mode 'gdbmi)) + (memq gud-minor-mode '(gdbmi gdba))) (make-local-variable 'gdb-define-alist) (unless gdb-define-alist (gdb-create-define-alist)) (add-hook 'after-save-hook 'gdb-create-define-alist nil t)) @@ -466,21 +499,21 @@ (defvar gud-speedbar-menu-items '(["Jump to stack frame" speedbar-edit-line - :visible (not (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - 'gdbmi))] + :visible (not (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdbmi gdba)))] ["Edit value" speedbar-edit-line - :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - 'gdbmi)] + :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdbmi gdba))] ["Delete expression" gdb-var-delete - :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - 'gdbmi)] + :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdbmi gdba))] ["Auto raise frame" gdb-speedbar-auto-raise :style toggle :selected gdb-speedbar-auto-raise - :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - 'gdbmi)] + :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdbmi gdba))] ("Output Format" - :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - 'gdbmi) + :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdbmi gdba)) ["Binary" (gdb-var-set-format "binary") t] ["Natural" (gdb-var-set-format "natural") t] ["Hexadecimal" (gdb-var-set-format "hexadecimal") t])) @@ -509,7 +542,7 @@ (start (window-start window)) (p (window-point window))) (cond - ((eq minor-mode 'gdbmi) + ((memq minor-mode '(gdbmi gdba)) (erase-buffer) (insert "Watch Expressions:\n") (let ((var-list gdb-var-list) parent) @@ -599,7 +632,7 @@ (car frame) 'speedbar-file-face 'speedbar-highlight-face - (cond ((memq minor-mode '(gdbmi gdb)) + (cond ((memq minor-mode '(gdbmi gdba gdb)) 'gud-gdb-goto-stackframe) (t (error "Should never be here"))) frame t)))) @@ -656,6 +689,8 @@ ;; Set the accumulator to the remaining text. gud-marker-acc (substring gud-marker-acc (match-end 0)))) + ;; Check for annotations and change gud-minor-mode to 'gdba if + ;; they are found. (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) (let ((match (match-string 1 gud-marker-acc))) @@ -719,10 +754,10 @@ (defvar gud-filter-pending-text nil "Non-nil means this is text that has been saved for later in `gud-filter'.") -;; If in gdb mode, gdb-mi is loaded. -(declare-function gdb-restore-windows "gdb-mi" ()) - -;; The old gdb command (text command mode). The new one is in gdb-mi.el. +;; If in gdba mode, gdb-ui is loaded. +(declare-function gdb-restore-windows "gdb-ui" ()) + +;; The old gdb command (text command mode). The new one is in gdb-ui.el. ;;;###autoload (defun gud-gdb (command-line) "Run gdb on program FILE in buffer *gud-FILE*. @@ -733,10 +768,10 @@ (when (and gud-comint-buffer (buffer-name gud-comint-buffer) (get-buffer-process gud-comint-buffer) - (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdbmi))) - (gdb-restore-windows) - (error - "Multiple debugging requires restarting in text command mode")) + (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) + (gdb-restore-windows) + (error + "Multiple debugging requires restarting in text command mode")) (gud-common-init command-line nil 'gud-gdb-marker-filter) (set (make-local-variable 'gud-minor-mode) 'gdb) @@ -2607,7 +2642,7 @@ (defvar gud-overlay-arrow-position nil) (add-to-list 'overlay-arrow-variable-list 'gud-overlay-arrow-position) -(declare-function gdb-reset "gdb-mi" ()) +(declare-function gdb-reset "gdb-ui" ()) (defun gud-sentinel (proc msg) (cond ((null (buffer-name (process-buffer proc))) @@ -2619,14 +2654,14 @@ (string-equal speedbar-initial-expansion-list-name "GUD")) (speedbar-change-initial-expansion-list speedbar-previously-used-expansion-list-name)) - (if (eq gud-minor-mode-type 'gdbmi) + (if (memq gud-minor-mode-type '(gdbmi gdba)) (gdb-reset) (gud-reset))) ((memq (process-status proc) '(signal exit)) ;; Stop displaying an arrow in a source file. (setq gud-overlay-arrow-position nil) - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - 'gdbmi) + (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdba gdbmi)) (gdb-reset) (gud-reset)) (let* ((obuf (current-buffer))) @@ -2657,9 +2692,7 @@ (defun gud-kill-buffer-hook () (setq gud-minor-mode-type gud-minor-mode) (condition-case nil - (progn - (kill-process (get-buffer-process (current-buffer))) - (delete-process (get-process "gdb-inferior"))) + (kill-process (get-buffer-process (current-buffer))) (error nil))) (defun gud-reset () @@ -2682,8 +2715,8 @@ (declare-function global-hl-line-highlight "hl-line" ()) (declare-function hl-line-highlight "hl-line" ()) -(declare-function gdb-display-source-buffer "gdb-mi" (buffer)) -(declare-function gdb-display-buffer "gdb-mi" (buf dedicated &optional size)) +(declare-function gdb-display-source-buffer "gdb-ui" (buffer)) +(declare-function gdb-display-buffer "gdb-ui" (buf dedicated &optional size)) ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen ;; and that its line LINE is visible. @@ -2699,7 +2732,7 @@ (gud-find-file true-file))) (window (and buffer (or (get-buffer-window buffer) - (if (eq gud-minor-mode 'gdbmi) + (if (memq gud-minor-mode '(gdbmi gdba)) (or (if (get-buffer-window buffer 'visible) (display-buffer buffer nil 'visible)) (unless (gdb-display-source-buffer buffer) @@ -2736,7 +2769,7 @@ (goto-char pos)))) (when window (set-window-point window gud-overlay-arrow-position) - (if (eq gud-minor-mode 'gdbmi) + (if (memq gud-minor-mode '(gdbmi gdba)) (setq gdb-source-window window))))))) ;; The gud-call function must do the right thing whether its invoking @@ -2842,7 +2875,7 @@ (forward-line 0)) (if (looking-at comint-prompt-regexp) (set-marker gud-delete-prompt-marker (point))) - (if (eq gud-minor-mode 'gdbmi) + (if (memq gud-minor-mode '(gdbmi gdba)) (apply comint-input-sender (list proc command)) (process-send-string proc (concat command "\n")))))))) @@ -3268,14 +3301,14 @@ (gud-tooltip-activate-mouse-motions-if-enabled) (if (and gud-comint-buffer (buffer-name gud-comint-buffer); gud-comint-buffer might be killed - (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - 'gdbmi)) + (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdbmi gdba))) (if gud-tooltip-mode (progn (dolist (buffer (buffer-list)) (unless (eq buffer gud-comint-buffer) (with-current-buffer buffer - (when (and (eq gud-minor-mode 'gdbmi) + (when (and (memq gud-minor-mode '(gdbmi gdba)) (not (string-match "\\`\\*.+\\*\\'" (buffer-name)))) (make-local-variable 'gdb-define-alist) @@ -3400,8 +3433,8 @@ ; Larger arrays (say 400 elements) are displayed in ; the tooltip incompletely and spill over into the gud buffer. ; Switching the process-filter creates timing problems and -; it may be difficult to do better. Using GDB/MI as in -; gdb-mi.el gets round this problem. +; it may be difficult to do better. Using annotations as in +; gdb-ui.el gets round this problem. (defun gud-tooltip-process-output (process output) "Process debugger output and show it in a tooltip window." (set-process-filter process gud-tooltip-original-filter) @@ -3411,12 +3444,12 @@ (defun gud-tooltip-print-command (expr) "Return a suitable command to print the expression EXPR." (case gud-minor-mode - (gdbmi (concat "-data-evaluate-expression " expr)) - (dbx (concat "print " expr)) + (gdba (concat "server print " expr)) + ((dbx gdbmi) (concat "print " expr)) ((xdb pdb) (concat "p " expr)) (sdb (concat expr "/")))) -(declare-function gdb-input "gdb-mi" (item)) +(declare-function gdb-enqueue-input "gdb-ui" (item)) (declare-function tooltip-expr-to-print "tooltip" (event)) (declare-function tooltip-event-buffer "tooltip" (event)) @@ -3436,12 +3469,12 @@ (buffer-name gud-comint-buffer); might be killed (setq process (get-buffer-process gud-comint-buffer)) (posn-point (event-end event)) - (or (and (eq gud-minor-mode 'gdbmi) (not gdb-active-process)) + (or (and (eq gud-minor-mode 'gdba) (not gdb-active-process)) (progn (setq gud-tooltip-event event) (eval (cons 'and gud-tooltip-display))))) (let ((expr (tooltip-expr-to-print event))) (when expr - (if (and (eq gud-minor-mode 'gdbmi) + (if (and (eq gud-minor-mode 'gdba) (not gdb-active-process)) (progn (with-current-buffer (tooltip-event-buffer event) @@ -3459,13 +3492,13 @@ (message-box "Using GUD tooltips in this mode is unsafe\n\ so they have been disabled.")) (unless (null cmd) ; CMD can be nil if unknown debugger - (if (eq gud-minor-mode 'gdbmi) + (if (memq gud-minor-mode '(gdba gdbmi)) (if gdb-macro-info - (gdb-input + (gdb-enqueue-input (list (concat - "server macro expand " expr "\n") + gdb-server-prefix "macro expand " expr "\n") `(lambda () (gdb-tooltip-print-1 ,expr)))) - (gdb-input + (gdb-enqueue-input (list (concat cmd "\n") `(lambda () (gdb-tooltip-print ,expr))))) (setq gud-tooltip-original-filter (process-filter process))