diff options
| -rw-r--r-- | doc/emacs/building.texi | 225 | ||||
| -rw-r--r-- | doc/emacs/emacs.texi | 18 | ||||
| -rw-r--r-- | etc/NEWS | 7 | ||||
| -rw-r--r-- | lisp/Makefile.in | 2 | ||||
| -rw-r--r-- | lisp/progmodes/gdb-mi.el | 4192 | ||||
| -rw-r--r-- | lisp/progmodes/gdb-ui.el | 4129 | ||||
| -rw-r--r-- | lisp/progmodes/gud.el | 203 |
7 files changed, 4302 insertions, 4474 deletions
diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi index a5ce5f20c7b..343eb646a83 100644 --- a/doc/emacs/building.texi +++ b/doc/emacs/building.texi | |||
| @@ -854,12 +854,11 @@ multiple programs within one Emacs session. | |||
| 854 | * Source Buffers:: Use the mouse in the fringe/margin to | 854 | * Source Buffers:: Use the mouse in the fringe/margin to |
| 855 | control your program. | 855 | control your program. |
| 856 | * Breakpoints Buffer:: A breakpoint control panel. | 856 | * Breakpoints Buffer:: A breakpoint control panel. |
| 857 | * Threads Buffer:: Displays your threads. | ||
| 858 | * Stack Buffer:: Select a frame from the call stack. | 857 | * Stack Buffer:: Select a frame from the call stack. |
| 859 | * Other GDB-UI Buffers:: Input/output, locals, registers, | 858 | * Other GDB-UI Buffers:: Input/output, locals, registers, |
| 860 | assembler, threads and memory buffers. | 859 | assembler, threads and memory buffers. |
| 861 | * Watch Expressions:: Monitor variable values in the speedbar. | 860 | * Watch Expressions:: Monitor variable values in the speedbar. |
| 862 | * Multithreaded Debugging:: Debugging programs with several threads. | 861 | * Reverse Debugging:: Execute and reverse debug your program. |
| 863 | @end menu | 862 | @end menu |
| 864 | 863 | ||
| 865 | @node GDB-UI Layout | 864 | @node GDB-UI Layout |
| @@ -884,7 +883,7 @@ displays the following frame layout: | |||
| 884 | |--------------------------------+--------------------------------+ | 883 | |--------------------------------+--------------------------------+ |
| 885 | | Primary Source buffer | I/O buffer for debugged pgm | | 884 | | Primary Source buffer | I/O buffer for debugged pgm | |
| 886 | |--------------------------------+--------------------------------+ | 885 | |--------------------------------+--------------------------------+ |
| 887 | | Stack buffer | Breakpoints/Thread buffer | | 886 | | Stack buffer | Breakpoints/Threads buffer | |
| 888 | +--------------------------------+--------------------------------+ | 887 | +--------------------------------+--------------------------------+ |
| 889 | @end group | 888 | @end group |
| 890 | @end smallexample | 889 | @end smallexample |
| @@ -1012,92 +1011,10 @@ Visit the source line for the current breakpoint | |||
| 1012 | Visit the source line for the breakpoint you click on. | 1011 | Visit the source line for the breakpoint you click on. |
| 1013 | @end table | 1012 | @end table |
| 1014 | 1013 | ||
| 1015 | @vindex gdb-show-threads-by-default | ||
| 1016 | When @code{gdb-many-windows} is non-@code{nil}, the breakpoints buffer | 1014 | When @code{gdb-many-windows} is non-@code{nil}, the breakpoints buffer |
| 1017 | shares its window with the threads buffer. To switch from one to the | 1015 | shares its window with the threads buffer. To switch from one to the |
| 1018 | other click with @kbd{Mouse-1} on the relevant button in the header | 1016 | other click with @kbd{Mouse-1} on the relevant button in the header |
| 1019 | line, or press @kbd{TAB} inside that buffer. If | 1017 | line. |
| 1020 | @code{gdb-show-threads-by-default} is non-@code{nil}, the threads | ||
| 1021 | buffer, rather than the breakpoints buffer, is shown at start up. | ||
| 1022 | |||
| 1023 | @node Threads Buffer | ||
| 1024 | @subsubsection Threads Buffer | ||
| 1025 | |||
| 1026 | @findex gdb-select-thread | ||
| 1027 | The threads buffer displays a summary of all threads currently in your | ||
| 1028 | program (@pxref{Threads, Threads, Debugging programs with multiple | ||
| 1029 | threads, gdb, The GNU debugger}). Move point to any thread in the list | ||
| 1030 | and press @key{RET} to select it (@code{gdb-select-thread}) and | ||
| 1031 | display the associated source in the primary source buffer. | ||
| 1032 | Alternatively, click @kbd{Mouse-2} on a thread to select it. Contents | ||
| 1033 | of all GDB buffers are updated whenever you select a thread. | ||
| 1034 | |||
| 1035 | You can customize variables under @code{gdb-buffers} group to select | ||
| 1036 | fields included in threads buffer. | ||
| 1037 | |||
| 1038 | @table @code | ||
| 1039 | @item gdb-thread-buffer-verbose-names | ||
| 1040 | @vindex gdb-thread-buffer-verbose-names | ||
| 1041 | Show long thread names like @samp{Thread 0x4e2ab70 (LWP 1983)} in | ||
| 1042 | threads buffer. | ||
| 1043 | |||
| 1044 | @item gdb-thread-buffer-arguments | ||
| 1045 | @vindex gdb-thread-buffer-arguments | ||
| 1046 | Show arguments of thread top frames in threads buffer. | ||
| 1047 | |||
| 1048 | @item gdb-thread-buffer-locations | ||
| 1049 | @vindex gdb-thread-buffer-locations | ||
| 1050 | Show file information or library names in threads buffer. | ||
| 1051 | |||
| 1052 | @item gdb-thread-buffer-addresses | ||
| 1053 | @vindex gdb-thread-buffer-addresses | ||
| 1054 | Show addresses for thread frames in threads buffer. | ||
| 1055 | @end table | ||
| 1056 | |||
| 1057 | It’s possible to observe information for several threads | ||
| 1058 | simultaneously (in addition to buffers which show information for | ||
| 1059 | currently selected thread) using the following keys from the threads | ||
| 1060 | buffer. | ||
| 1061 | |||
| 1062 | @table @kbd | ||
| 1063 | @item d | ||
| 1064 | @kindex d @r{(GDB threads buffer)} | ||
| 1065 | @findex gdb-display-disassembly-for-thread | ||
| 1066 | Display disassembly buffer for the thread at current line. | ||
| 1067 | (@code{gdb-display-disassembly-for-thread}) | ||
| 1068 | |||
| 1069 | @item f | ||
| 1070 | @kindex f @r{(GDB threads buffer)} | ||
| 1071 | @findex gdb-display-stack-for-thread | ||
| 1072 | Display stack buffer for the thread at current line. | ||
| 1073 | (@code{gdb-display-stack-for-thread}). | ||
| 1074 | |||
| 1075 | @item l | ||
| 1076 | @kindex l @r{(GDB threads buffer)} | ||
| 1077 | @findex gdb-display-locals-for-thread | ||
| 1078 | Display locals buffer for the thread at current line. | ||
| 1079 | (@code{gdb-display-locals-for-thread}). | ||
| 1080 | |||
| 1081 | @item r | ||
| 1082 | @kindex r @r{(GDB threads buffer)} | ||
| 1083 | @findex gdb-display-registers-for-thread | ||
| 1084 | Display registers buffer for the thread at current line. | ||
| 1085 | (@code{gdb-display-registers-for-thread}). | ||
| 1086 | @end table | ||
| 1087 | |||
| 1088 | Pressing their upper-case counterparts, @kbd{D}, @kbd{F} ,@kbd{L} and | ||
| 1089 | @kbd{R} displays the corresponding buffer in a new frame. | ||
| 1090 | |||
| 1091 | When you create a buffer showing information about some specific | ||
| 1092 | thread, it becomes bound to that thread and keeps showing actual | ||
| 1093 | information while you debug your program. Every GDB buffer contains a | ||
| 1094 | number of thread it shows information for in its mode name. Thread | ||
| 1095 | number is also included in the buffer name of bound buffers to prevent | ||
| 1096 | buffer names clashing. | ||
| 1097 | |||
| 1098 | Further commands are available in the threads buffer which depend on the | ||
| 1099 | mode of GDB that is used for controlling execution of your program. | ||
| 1100 | (@pxref{Multithreaded Debugging, Stopping and Starting Multi-threaded Programs}). | ||
| 1101 | 1018 | ||
| 1102 | @node Stack Buffer | 1019 | @node Stack Buffer |
| 1103 | @subsubsection Stack Buffer | 1020 | @subsubsection Stack Buffer |
| @@ -1134,7 +1051,7 @@ as are the commands to send signals to the debugged program. | |||
| 1134 | @item Locals Buffer | 1051 | @item Locals Buffer |
| 1135 | The locals buffer displays the values of local variables of the | 1052 | The locals buffer displays the values of local variables of the |
| 1136 | current frame for simple data types (@pxref{Frame Info, Frame Info, | 1053 | current frame for simple data types (@pxref{Frame Info, Frame Info, |
| 1137 | Information on a frame, gdb, The GNU debugger}). Press @key{RET} or | 1054 | Information on a frame, gdb, The GNU debugger}). Press @key{RET} or |
| 1138 | click @kbd{Mouse-2} on the value if you want to edit it. | 1055 | click @kbd{Mouse-2} on the value if you want to edit it. |
| 1139 | 1056 | ||
| 1140 | Arrays and structures display their type only. With GDB 6.4 or later, | 1057 | Arrays and structures display their type only. With GDB 6.4 or later, |
| @@ -1153,12 +1070,27 @@ With GDB 6.4 or later, recently changed register values display with | |||
| 1153 | press @key{SPC} to toggle the display of floating point registers | 1070 | press @key{SPC} to toggle the display of floating point registers |
| 1154 | (@code{toggle-gdb-all-registers}). | 1071 | (@code{toggle-gdb-all-registers}). |
| 1155 | 1072 | ||
| 1156 | @item Disassembly Buffer | 1073 | @item Assembler Buffer |
| 1157 | The disassembly buffer displays the current frame as machine code. An | 1074 | The assembler buffer displays the current frame as machine code. An |
| 1158 | arrow points to the current instruction, and you can set and remove | 1075 | arrow points to the current instruction, and you can set and remove |
| 1159 | breakpoints as in a source buffer. Breakpoint icons also appear in | 1076 | breakpoints as in a source buffer. Breakpoint icons also appear in |
| 1160 | the fringe or margin. | 1077 | the fringe or margin. |
| 1161 | 1078 | ||
| 1079 | @item Threads Buffer | ||
| 1080 | @findex gdb-threads-select | ||
| 1081 | The threads buffer displays a summary of all threads currently in your | ||
| 1082 | program (@pxref{Threads, Threads, Debugging programs with multiple | ||
| 1083 | threads, gdb, The GNU debugger}). Move point to any thread in the | ||
| 1084 | list and press @key{RET} to select it (@code{gdb-threads-select}) and | ||
| 1085 | display the associated source in the primary source buffer. | ||
| 1086 | Alternatively, click @kbd{Mouse-2} on a thread to select it. If the | ||
| 1087 | locals buffer is visible, its contents update to display the variables | ||
| 1088 | that are local in the new thread. | ||
| 1089 | |||
| 1090 | When there is more than one main thread and the threads buffer is | ||
| 1091 | present, Emacs displays the selected thread number in the mode line of | ||
| 1092 | many of the GDB-UI Buffers. | ||
| 1093 | |||
| 1162 | @item Memory Buffer | 1094 | @item Memory Buffer |
| 1163 | The memory buffer lets you examine sections of program memory | 1095 | The memory buffer lets you examine sections of program memory |
| 1164 | (@pxref{Memory, Memory, Examining memory, gdb, The GNU debugger}). | 1096 | (@pxref{Memory, Memory, Examining memory, gdb, The GNU debugger}). |
| @@ -1171,9 +1103,8 @@ size for these data items. | |||
| 1171 | 1103 | ||
| 1172 | When @code{gdb-many-windows} is non-@code{nil}, the threads buffer | 1104 | When @code{gdb-many-windows} is non-@code{nil}, the threads buffer |
| 1173 | shares its window with the breakpoints buffer, and the locals buffer | 1105 | shares its window with the breakpoints buffer, and the locals buffer |
| 1174 | with the registers buffer. To switch from one to the other click with | 1106 | with the registers buffer. To switch from one to the other click with |
| 1175 | @kbd{Mouse-1} on the relevant button in the header line or press | 1107 | @kbd{Mouse-1} on the relevant button in the header line. |
| 1176 | @kbd{TAB} inside the buffer. | ||
| 1177 | 1108 | ||
| 1178 | @node Watch Expressions | 1109 | @node Watch Expressions |
| 1179 | @subsubsection Watch Expressions | 1110 | @subsubsection Watch Expressions |
| @@ -1241,96 +1172,26 @@ expressions updates, set @code{gdb-speedbar-auto-raise} to | |||
| 1241 | non-@code{nil}. This can be useful if you are debugging with a full | 1172 | non-@code{nil}. This can be useful if you are debugging with a full |
| 1242 | screen Emacs frame. | 1173 | screen Emacs frame. |
| 1243 | 1174 | ||
| 1244 | @node Multithreaded Debugging | 1175 | @node Reverse Debugging |
| 1245 | @subsubsection Stopping and Starting Multi-threaded Programs | 1176 | @subsubsection Reverse Debugging |
| 1246 | @cindex Multithreaded debugging in GDB | 1177 | |
| 1247 | 1178 | The GDB tool bar shares many buttons with the other GUD debuggers | |
| 1248 | @subsubheading All-stop Debugging | 1179 | for tasks like stepping and printing expressions. It also has a |
| 1249 | 1180 | further set of buttons that allow reverse debugging (@pxref{Process | |
| 1250 | In all-stop mode, whenever your program stops, @emph{all} threads of | 1181 | Record and Replay, , ,gdb, The GNU debugger}). This is useful when it |
| 1251 | execution stop. Likewise, whenever you restart the program, all | 1182 | takes a long time to reproduce the conditions where your program fails |
| 1252 | threads start executing. @xref{All-Stop Mode, , All-Stop Mode, gdb, | 1183 | or for transient problems, like race conditions in multi-threaded |
| 1253 | The GNU debugger}. You can enable this behaviour in Emacs by setting | 1184 | programs, where a failure might otherwise be hard to reproduce. |
| 1254 | @code{gdb-non-stop-setting} to @code{nil} before starting a debugging | 1185 | |
| 1255 | session. | 1186 | To use reverse debugging, set a breakpoint slightly before the |
| 1256 | 1187 | location of interest and run your program to that point. Enable | |
| 1257 | @subsubheading Non-stop Debugging | 1188 | process recording by clicking on the record button. At this point, a |
| 1258 | @cindex Non-stop debugging in GDB | 1189 | new set of buttons appear. These buttons allow program execution in |
| 1259 | 1190 | the reverse direction. Run your program over the code where the | |
| 1260 | For some multi-threaded targets, GDB supports a further mode of | 1191 | problem occurs, and then use the new set of buttons to retrace your |
| 1261 | operation in which you can examine stopped program threads in the | 1192 | steps, examine values, and analyze the problem. When analysis is |
| 1262 | debugger while other threads continue to execute freely. | 1193 | complete, turn off process recording by clicking on the record button |
| 1263 | @xref{Non-Stop Mode, , Non-Stop Mode, gdb, The GNU debugger}. | 1194 | again. |
| 1264 | This is referred to as @dfn{non-stop} mode. | ||
| 1265 | |||
| 1266 | Versions of GDB prior to 7.0 do not support non-stop mode and it does | ||
| 1267 | not work on all targets. In such cases, Emacs uses all-stop mode | ||
| 1268 | regardless of the value of @code{gdb-non-stop-setting}. | ||
| 1269 | |||
| 1270 | @vindex gdb-non-stop-setting | ||
| 1271 | If the variable @code{gdb-non-stop-setting} is non-@code{nil} (the | ||
| 1272 | default value), Emacs tries to start GDB in non-stop mode. Note that | ||
| 1273 | GDB debugging session needs to be restarted for change of this setting | ||
| 1274 | to take effect. | ||
| 1275 | |||
| 1276 | @vindex gdb-switch-when-another-stopped | ||
| 1277 | When a thread stops in non-stop mode, Emacs automatically switches to | ||
| 1278 | that thread. It may be undesirable to allow switching of current | ||
| 1279 | thread when some other stopped thread is already selected. Set | ||
| 1280 | @code{gdb-switch-when-another-stopped} to @code{nil} to prevent this. | ||
| 1281 | |||
| 1282 | @vindex gdb-switch-reasons | ||
| 1283 | Emacs can decide whether or not to switch to the stopped thread | ||
| 1284 | depending on the reason which caused the stop. Customize | ||
| 1285 | @code{gdb-switch-reasons} to select stop reasons which make Emacs | ||
| 1286 | switch thread. | ||
| 1287 | |||
| 1288 | @vindex gdb-stopped-hooks | ||
| 1289 | The variable @code{gdb-stopped-hooks} allows you to execute your | ||
| 1290 | functions whenever some thread stops. | ||
| 1291 | |||
| 1292 | In non-stop mode, you can switch between different modes for GUD | ||
| 1293 | execution control commands. | ||
| 1294 | |||
| 1295 | @vindex gdb-gud-control-all-threads | ||
| 1296 | @table @dfn | ||
| 1297 | @item Non-stop/A | ||
| 1298 | |||
| 1299 | When @code{gdb-gud-control-all-threads} is @code{t} (the default | ||
| 1300 | value), interruption and continuation commands apply to all threads, | ||
| 1301 | so you can halt or continue all your threads with one command using | ||
| 1302 | @code{gud-stop-subjob} and @code{gud-cont}, respectively. The | ||
| 1303 | @samp{Go} button is shown on the toolbar when at least one thread is | ||
| 1304 | stopped, whereas @samp{Stop} button is shown when at least one thread | ||
| 1305 | is running. | ||
| 1306 | |||
| 1307 | @item Non-stop/T | ||
| 1308 | |||
| 1309 | When @code{gdb-gud-control-all-threads} is @code{nil}, only the | ||
| 1310 | current thread is stopped/continued. @samp{Go} and @samp{Stop} | ||
| 1311 | buttons on the GUD toolbar are shown depending on the state of current | ||
| 1312 | thread. | ||
| 1313 | @end table | ||
| 1314 | |||
| 1315 | You can change the current value of @code{gdb-gud-control-all-threads} | ||
| 1316 | from the tool bar or from @samp{GUD->GDB-MI} menu. | ||
| 1317 | |||
| 1318 | Stepping commands always apply to the current thread. | ||
| 1319 | |||
| 1320 | @subsubheading Fine Thread Control | ||
| 1321 | |||
| 1322 | In non-stop mode, you can interrupt/continue your threads without | ||
| 1323 | selecting them. Hitting @kbd{i} in threads buffer interrupts thread | ||
| 1324 | under point, @kbd{c} continues it, @kbd{s} steps through. More such | ||
| 1325 | commands may be added in the future. | ||
| 1326 | |||
| 1327 | Combined with creating bound buffers for any thread, this allows you | ||
| 1328 | to change and track state of many threads in the same time. | ||
| 1329 | |||
| 1330 | Note that when you interrupt a thread, it stops with @samp{signal | ||
| 1331 | received} reason. If that reason is included in your | ||
| 1332 | @code{gdb-switch-reasons} (it is by default), Emacs will switch to | ||
| 1333 | that thread. | ||
| 1334 | 1195 | ||
| 1335 | @node Executing Lisp | 1196 | @node Executing Lisp |
| 1336 | @section Executing Lisp Expressions | 1197 | @section Executing Lisp Expressions |
diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 4b9ea28dcc3..7037574245a 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi | |||
| @@ -745,16 +745,14 @@ Running Debuggers Under Emacs | |||
| 745 | 745 | ||
| 746 | GDB Graphical Interface | 746 | GDB Graphical Interface |
| 747 | 747 | ||
| 748 | * GDB-UI Layout:: Control the number of displayed buffers. | 748 | * GDB-UI Layout:: Control the number of displayed buffers. |
| 749 | * Source Buffers:: Use the mouse in the fringe/margin to | 749 | * Source Buffers:: Use the mouse in the fringe/margin to |
| 750 | control your program. | 750 | control your program. |
| 751 | * Breakpoints Buffer:: A breakpoint control panel. | 751 | * Breakpoints Buffer:: A breakpoint control panel. |
| 752 | * Threads Buffer:: Displays your threads. | 752 | * Stack Buffer:: Select a frame from the call stack. |
| 753 | * Stack Buffer:: Select a frame from the call stack. | 753 | * Other GDB-UI Buffers::Input/output, locals, registers, |
| 754 | * Other GDB-UI Buffers:: Input/output, locals, registers, | 754 | assembler, threads and memory buffers. |
| 755 | assembler, threads and memory buffers. | 755 | * Watch Expressions:: Monitor variable values in the speedbar. |
| 756 | * Watch Expressions:: Monitor variable values in the speedbar. | ||
| 757 | * Multithreaded Debugging:: Debugging programs with several threads. | ||
| 758 | 756 | ||
| 759 | Maintaining Large Programs | 757 | Maintaining Large Programs |
| 760 | 758 | ||
| @@ -218,11 +218,10 @@ dired buffers automatically on revisiting. | |||
| 218 | *** When `doc-view-continuous' is non-nil, scrolling a line | 218 | *** When `doc-view-continuous' is non-nil, scrolling a line |
| 219 | on the page edge advances to the next/previous page. | 219 | on the page edge advances to the next/previous page. |
| 220 | 220 | ||
| 221 | ** gdb-mi | 221 | ** GDB-UI |
| 222 | 222 | ||
| 223 | *** GDB User Interface migrated to GDB Machine Interface and now | 223 | *** Toolbar functionality for reverse debugging. Display of STL collections as |
| 224 | supports multithread non-stop debugging and debugging of several | 224 | watch expressions. These features require GDB 7.0 or later. |
| 225 | threads simultaneously. | ||
| 226 | 225 | ||
| 227 | ** Grep | 226 | ** Grep |
| 228 | 227 | ||
diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 387144c19d7..dfa3a98871e 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in | |||
| @@ -1233,7 +1233,7 @@ ELCFILES = \ | |||
| 1233 | $(lisp)/progmodes/f90.elc \ | 1233 | $(lisp)/progmodes/f90.elc \ |
| 1234 | $(lisp)/progmodes/flymake.elc \ | 1234 | $(lisp)/progmodes/flymake.elc \ |
| 1235 | $(lisp)/progmodes/fortran.elc \ | 1235 | $(lisp)/progmodes/fortran.elc \ |
| 1236 | $(lisp)/progmodes/gdb-mi.elc \ | 1236 | $(lisp)/progmodes/gdb-ui.elc \ |
| 1237 | $(lisp)/progmodes/glasses.elc \ | 1237 | $(lisp)/progmodes/glasses.elc \ |
| 1238 | $(lisp)/progmodes/grep.elc \ | 1238 | $(lisp)/progmodes/grep.elc \ |
| 1239 | $(lisp)/progmodes/gud.elc \ | 1239 | $(lisp)/progmodes/gud.elc \ |
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el deleted file mode 100644 index 0f9532dcb3e..00000000000 --- a/lisp/progmodes/gdb-mi.el +++ /dev/null | |||
| @@ -1,4192 +0,0 @@ | |||
| 1 | ;;; gdb-mi.el --- User Interface for running GDB | ||
| 2 | |||
| 3 | ;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Nick Roberts <nickrob@gnu.org> | ||
| 6 | ;; Maintainer: FSF | ||
| 7 | ;; Keywords: unix, tools | ||
| 8 | |||
| 9 | ;; This file is part of GNU Emacs. | ||
| 10 | |||
| 11 | ;; Homepage: http://www.emacswiki.org/emacs/GDB-MI | ||
| 12 | |||
| 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 14 | ;; it under the terms of the GNU General Public License as published by | ||
| 15 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 16 | ;; (at your option) any later version. | ||
| 17 | |||
| 18 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 21 | ;; GNU General Public License for more details. | ||
| 22 | |||
| 23 | ;; You should have received a copy of the GNU General Public License | ||
| 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 25 | |||
| 26 | ;;; Credits: | ||
| 27 | |||
| 28 | ;; This file was written by by Nick Roberts following the general design | ||
| 29 | ;; used in gdb-ui.el for Emacs 22.1 - 23.1. It is currently being developed | ||
| 30 | ;; by Dmitry Dzhus <dima@sphinx.net.ru> as part of the Google Summer | ||
| 31 | ;; of Code 2009 Project "Emacs GDB/MI migration". | ||
| 32 | |||
| 33 | ;;; Commentary: | ||
| 34 | |||
| 35 | ;; This mode acts as a graphical user interface to GDB. You can interact with | ||
| 36 | ;; GDB through the GUD buffer in the usual way, but there are also further | ||
| 37 | ;; buffers which control the execution and describe the state of your program. | ||
| 38 | ;; It separates the input/output of your program from that of GDB and displays | ||
| 39 | ;; expressions and their current values in their own buffers. It also uses | ||
| 40 | ;; features of Emacs 21 such as the fringe/display margin for breakpoints, and | ||
| 41 | ;; the toolbar (see the GDB Graphical Interface section in the Emacs info | ||
| 42 | ;; manual). | ||
| 43 | |||
| 44 | ;; M-x gdb will start the debugger. | ||
| 45 | |||
| 46 | ;; This file uses GDB/MI as the primary interface to GDB. It is still under | ||
| 47 | ;; development and is part of a process to migrate Emacs from annotations (as | ||
| 48 | ;; used in gdb-ui.el) to GDB/MI. It runs gdb with GDB/MI (-interp=mi) and | ||
| 49 | ;; access CLI using "-interpreter-exec console cli-command". This code works | ||
| 50 | ;; without gdb-ui.el and uses MI tokens instead of queues. Eventually MI | ||
| 51 | ;; should be asynchronous. | ||
| 52 | |||
| 53 | ;; This mode will PARTLY WORK WITH RECENT GDB RELEASES (status in modeline | ||
| 54 | ;; doesn't update properly when execution commands are issued from GUD buffer) | ||
| 55 | ;; and WORKS BEST when GDB runs asynchronously: maint set linux-async on. | ||
| 56 | ;; | ||
| 57 | ;; You need development version of GDB 7.0 for the thread buffer to work. | ||
| 58 | |||
| 59 | ;; This file replaces gdb-ui.el and is for development with GDB. Use the | ||
| 60 | ;; release branch of Emacs 22 for the latest version of gdb-ui.el. | ||
| 61 | |||
| 62 | ;; Windows Platforms: | ||
| 63 | |||
| 64 | ;; If you are using Emacs and GDB on Windows you will need to flush the buffer | ||
| 65 | ;; explicitly in your program if you want timely display of I/O in Emacs. | ||
| 66 | ;; Alternatively you can make the output stream unbuffered, for example, by | ||
| 67 | ;; using a macro: | ||
| 68 | |||
| 69 | ;; #ifdef UNBUFFERED | ||
| 70 | ;; setvbuf (stdout, (char *) NULL, _IONBF, 0); | ||
| 71 | ;; #endif | ||
| 72 | |||
| 73 | ;; and compiling with -DUNBUFFERED while debugging. | ||
| 74 | |||
| 75 | ;; If you are using Cygwin GDB and find that the source is not being displayed | ||
| 76 | ;; in Emacs when you step through it, possible solutions are to: | ||
| 77 | |||
| 78 | ;; 1) Use Cygwin X Windows and Cygwin Emacs. | ||
| 79 | ;; (Since 22.1 Emacs builds under Cygwin.) | ||
| 80 | ;; 2) Use MinGW GDB instead. | ||
| 81 | ;; 3) Use cygwin-mount.el | ||
| 82 | |||
| 83 | ;;; Mac OSX: | ||
| 84 | |||
| 85 | ;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made | ||
| 86 | ;; some changes to the version that they include as part of Mac OSX. | ||
| 87 | ;; This requires GDB version 7.0 or later (estimated release date Aug 2009) | ||
| 88 | ;; as earlier versions don not compile on Mac OSX. | ||
| 89 | |||
| 90 | ;;; Known Bugs: | ||
| 91 | |||
| 92 | ;; 1) Stack buffer doesn't parse MI output if you stop in a routine without | ||
| 93 | ;; line information, e.g., a routine in libc (just a TODO item). | ||
| 94 | |||
| 95 | ;; TODO: | ||
| 96 | ;; 2) Watch windows to work with threads. | ||
| 97 | ;; 3) Use treebuffer.el instead of the speedbar for watch-expressions? | ||
| 98 | ;; 4) Mark breakpoint locations on scroll-bar of source buffer? | ||
| 99 | |||
| 100 | ;;; Code: | ||
| 101 | |||
| 102 | (require 'gud) | ||
| 103 | (require 'json) | ||
| 104 | (require 'bindat) | ||
| 105 | (eval-when-compile (require 'cl)) | ||
| 106 | |||
| 107 | (defvar tool-bar-map) | ||
| 108 | (defvar speedbar-initial-expansion-list-name) | ||
| 109 | (defvar speedbar-frame) | ||
| 110 | |||
| 111 | (defvar gdb-memory-address "main") | ||
| 112 | (defvar gdb-memory-last-address nil | ||
| 113 | "Last successfully accessed memory address.") | ||
| 114 | (defvar gdb-memory-next-page nil | ||
| 115 | "Address of next memory page for program memory buffer.") | ||
| 116 | (defvar gdb-memory-prev-page nil | ||
| 117 | "Address of previous memory page for program memory buffer.") | ||
| 118 | |||
| 119 | (defvar gdb-thread-number nil | ||
| 120 | "Main current thread. | ||
| 121 | |||
| 122 | Invalidation triggers use this variable to query GDB for | ||
| 123 | information on the specified thread by wrapping GDB/MI commands | ||
| 124 | in `gdb-current-context-command'. | ||
| 125 | |||
| 126 | This variable may be updated implicitly by GDB via `gdb-stopped' | ||
| 127 | or explicitly by `gdb-select-thread'. | ||
| 128 | |||
| 129 | Only `gdb-setq-thread-number' should be used to change this | ||
| 130 | value.") | ||
| 131 | |||
| 132 | (defvar gdb-frame-number nil | ||
| 133 | "Selected frame level for main current thread. | ||
| 134 | |||
| 135 | Updated according to the following rules: | ||
| 136 | |||
| 137 | When a thread is selected or current thread stops, set to \"0\". | ||
| 138 | |||
| 139 | When current thread goes running (and possibly exits eventually), | ||
| 140 | set to nil. | ||
| 141 | |||
| 142 | May be manually changed by user with `gdb-select-frame'.") | ||
| 143 | |||
| 144 | (defvar gdb-frame-address nil "Identity of frame for watch expression.") | ||
| 145 | |||
| 146 | ;; Used to show overlay arrow in source buffer. All set in | ||
| 147 | ;; gdb-get-main-selected-frame. Disassembly buffer should not use | ||
| 148 | ;; these but rely on buffer-local thread information instead. | ||
| 149 | (defvar gdb-selected-frame nil | ||
| 150 | "Name of selected function for main current thread.") | ||
| 151 | (defvar gdb-selected-file nil | ||
| 152 | "Name of selected file for main current thread.") | ||
| 153 | (defvar gdb-selected-line nil | ||
| 154 | "Number of selected line for main current thread.") | ||
| 155 | |||
| 156 | (defvar gdb-threads-list nil | ||
| 157 | "Associative list of threads provided by \"-thread-info\" MI command. | ||
| 158 | |||
| 159 | Keys are thread numbers (in strings) and values are structures as | ||
| 160 | returned from -thread-info by `gdb-json-partial-output'. Updated in | ||
| 161 | `gdb-thread-list-handler-custom'.") | ||
| 162 | |||
| 163 | (defvar gdb-running-threads-count nil | ||
| 164 | "Number of currently running threads. | ||
| 165 | |||
| 166 | Nil means that no information is available. | ||
| 167 | |||
| 168 | Updated in `gdb-thread-list-handler-custom'.") | ||
| 169 | |||
| 170 | (defvar gdb-stopped-threads-count nil | ||
| 171 | "Number of currently stopped threads. | ||
| 172 | |||
| 173 | See also `gdb-running-threads-count'.") | ||
| 174 | |||
| 175 | (defvar gdb-breakpoints-list nil | ||
| 176 | "Associative list of breakpoints provided by \"-break-list\" MI command. | ||
| 177 | |||
| 178 | Keys are breakpoint numbers (in string) and values are structures | ||
| 179 | as returned from \"-break-list\" by `gdb-json-partial-output' | ||
| 180 | \(\"body\" field is used). Updated in | ||
| 181 | `gdb-breakpoints-list-handler-custom'.") | ||
| 182 | |||
| 183 | (defvar gdb-current-language nil) | ||
| 184 | (defvar gdb-var-list nil | ||
| 185 | "List of variables in watch window. | ||
| 186 | Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP) | ||
| 187 | where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame | ||
| 188 | address for root variables.") | ||
| 189 | (defvar gdb-main-file nil "Source file from which program execution begins.") | ||
| 190 | |||
| 191 | ;; Overlay arrow markers | ||
| 192 | (defvar gdb-stack-position nil) | ||
| 193 | (defvar gdb-thread-position nil) | ||
| 194 | (defvar gdb-disassembly-position nil) | ||
| 195 | |||
| 196 | (defvar gdb-location-alist nil | ||
| 197 | "Alist of breakpoint numbers and full filenames. Only used for files that | ||
| 198 | Emacs can't find.") | ||
| 199 | (defvar gdb-active-process nil | ||
| 200 | "GUD tooltips display variable values when t, and macro definitions otherwise.") | ||
| 201 | (defvar gdb-error "Non-nil when GDB is reporting an error.") | ||
| 202 | (defvar gdb-macro-info nil | ||
| 203 | "Non-nil if GDB knows that the inferior includes preprocessor macro info.") | ||
| 204 | (defvar gdb-register-names nil "List of register names.") | ||
| 205 | (defvar gdb-changed-registers nil | ||
| 206 | "List of changed register numbers (strings).") | ||
| 207 | (defvar gdb-buffer-fringe-width nil) | ||
| 208 | (defvar gdb-last-command nil) | ||
| 209 | (defvar gdb-prompt-name nil) | ||
| 210 | (defvar gdb-token-number 0) | ||
| 211 | (defvar gdb-handler-alist '()) | ||
| 212 | (defvar gdb-handler-number nil) | ||
| 213 | (defvar gdb-source-file-list nil | ||
| 214 | "List of source files for the current executable.") | ||
| 215 | (defvar gdb-first-done-or-error t) | ||
| 216 | (defvar gdb-source-window nil) | ||
| 217 | (defvar gdb-inferior-status nil) | ||
| 218 | (defvar gdb-continuation nil) | ||
| 219 | (defvar gdb-version nil) | ||
| 220 | (defvar gdb-filter-output nil | ||
| 221 | "Message to be shown in GUD console. | ||
| 222 | |||
| 223 | This variable is updated in `gdb-done-or-error' and returned by | ||
| 224 | `gud-gdbmi-marker-filter'.") | ||
| 225 | |||
| 226 | (defvar gdb-non-stop nil | ||
| 227 | "Indicates whether current GDB session is using non-stop mode. | ||
| 228 | |||
| 229 | It is initialized to `gdb-non-stop-setting' at the beginning of | ||
| 230 | every GDB session.") | ||
| 231 | |||
| 232 | (defvar gdb-buffer-type nil | ||
| 233 | "One of the symbols bound in `gdb-buffer-rules'.") | ||
| 234 | (make-variable-buffer-local 'gdb-buffer-type) | ||
| 235 | |||
| 236 | (defvar gdb-output-sink 'nil | ||
| 237 | "The disposition of the output of the current gdb command. | ||
| 238 | Possible values are these symbols: | ||
| 239 | |||
| 240 | `user' -- gdb output should be copied to the GUD buffer | ||
| 241 | for the user to see. | ||
| 242 | |||
| 243 | `emacs' -- output should be collected in the partial-output-buffer | ||
| 244 | for subsequent processing by a command. This is the | ||
| 245 | disposition of output generated by commands that | ||
| 246 | gdb mode sends to gdb on its own behalf.") | ||
| 247 | |||
| 248 | ;; Pending triggers prevent congestion: Emacs won't send two similar | ||
| 249 | ;; consecutive requests. | ||
| 250 | |||
| 251 | (defvar gdb-pending-triggers '() | ||
| 252 | "A list of trigger functions which have not yet been handled. | ||
| 253 | |||
| 254 | Elements are either function names or pairs (buffer . function)") | ||
| 255 | |||
| 256 | (defmacro gdb-add-pending (item) | ||
| 257 | `(push ,item gdb-pending-triggers)) | ||
| 258 | (defmacro gdb-pending-p (item) | ||
| 259 | `(member ,item gdb-pending-triggers)) | ||
| 260 | (defmacro gdb-delete-pending (item) | ||
| 261 | `(setq gdb-pending-triggers | ||
| 262 | (delete ,item gdb-pending-triggers))) | ||
| 263 | |||
| 264 | (defmacro gdb-wait-for-pending (&rest body) | ||
| 265 | "Wait until `gdb-pending-triggers' is empty and evaluate FORM. | ||
| 266 | |||
| 267 | This function checks `gdb-pending-triggers' value every | ||
| 268 | `gdb-wait-for-pending' seconds." | ||
| 269 | (run-with-timer | ||
| 270 | 0.5 nil | ||
| 271 | `(lambda () | ||
| 272 | (if (not gdb-pending-triggers) | ||
| 273 | (progn ,@body) | ||
| 274 | (gdb-wait-for-pending ,@body))))) | ||
| 275 | |||
| 276 | ;; Publish-subscribe | ||
| 277 | |||
| 278 | (defmacro gdb-add-subscriber (publisher subscriber) | ||
| 279 | "Register new PUBLISHER's SUBSCRIBER. | ||
| 280 | |||
| 281 | SUBSCRIBER must be a pair, where cdr is a function of one | ||
| 282 | argument (see `gdb-emit-signal')." | ||
| 283 | `(add-to-list ',publisher ,subscriber t)) | ||
| 284 | |||
| 285 | (defmacro gdb-delete-subscriber (publisher subscriber) | ||
| 286 | "Unregister SUBSCRIBER from PUBLISHER." | ||
| 287 | `(setq ,publisher (delete ,subscriber | ||
| 288 | ,publisher))) | ||
| 289 | |||
| 290 | (defun gdb-get-subscribers (publisher) | ||
| 291 | publisher) | ||
| 292 | |||
| 293 | (defun gdb-emit-signal (publisher &optional signal) | ||
| 294 | "Call cdr for each subscriber of PUBLISHER with SIGNAL as argument." | ||
| 295 | (dolist (subscriber (gdb-get-subscribers publisher)) | ||
| 296 | (funcall (cdr subscriber) signal))) | ||
| 297 | |||
| 298 | (defvar gdb-buf-publisher '() | ||
| 299 | "Used to invalidate GDB buffers by emitting a signal in | ||
| 300 | `gdb-update'. | ||
| 301 | |||
| 302 | Must be a list of pairs with cars being buffers and cdr's being | ||
| 303 | valid signal handlers.") | ||
| 304 | |||
| 305 | (defgroup gdb nil | ||
| 306 | "GDB graphical interface" | ||
| 307 | :group 'tools | ||
| 308 | :link '(info-link "(emacs)GDB Graphical Interface") | ||
| 309 | :version "23.2") | ||
| 310 | |||
| 311 | (defgroup gdb-non-stop nil | ||
| 312 | "GDB non-stop debugging settings" | ||
| 313 | :group 'gdb | ||
| 314 | :version "23.2") | ||
| 315 | |||
| 316 | (defgroup gdb-buffers nil | ||
| 317 | "GDB buffers" | ||
| 318 | :group 'gdb | ||
| 319 | :version "23.2") | ||
| 320 | |||
| 321 | (defcustom gdb-debug-log-max 128 | ||
| 322 | "Maximum size of `gdb-debug-log'. If nil, size is unlimited." | ||
| 323 | :group 'gdb | ||
| 324 | :type '(choice (integer :tag "Number of elements") | ||
| 325 | (const :tag "Unlimited" nil)) | ||
| 326 | :version "22.1") | ||
| 327 | |||
| 328 | (defcustom gdb-non-stop-setting t | ||
| 329 | "When in non-stop mode, stopped threads can be examined while | ||
| 330 | other threads continue to execute. | ||
| 331 | |||
| 332 | GDB session needs to be restarted for this setting to take | ||
| 333 | effect." | ||
| 334 | :type 'boolean | ||
| 335 | :group 'gdb-non-stop | ||
| 336 | :version "23.2") | ||
| 337 | |||
| 338 | ;; TODO Some commands can't be called with --all (give a notice about | ||
| 339 | ;; it in setting doc) | ||
| 340 | (defcustom gdb-gud-control-all-threads t | ||
| 341 | "When enabled, GUD execution commands affect all threads when | ||
| 342 | in non-stop mode. Otherwise, only current thread is affected." | ||
| 343 | :type 'boolean | ||
| 344 | :group 'gdb-non-stop | ||
| 345 | :version "23.2") | ||
| 346 | |||
| 347 | (defcustom gdb-switch-reasons t | ||
| 348 | "List of stop reasons which cause Emacs to switch to the thread | ||
| 349 | which caused the stop. When t, switch to stopped thread no matter | ||
| 350 | what the reason was. When nil, never switch to stopped thread | ||
| 351 | automatically. | ||
| 352 | |||
| 353 | This setting is used in non-stop mode only. In all-stop mode, | ||
| 354 | Emacs always switches to the thread which caused the stop." | ||
| 355 | ;; exited, exited-normally and exited-signalled are not | ||
| 356 | ;; thread-specific stop reasons and therefore are not included in | ||
| 357 | ;; this list | ||
| 358 | :type '(choice | ||
| 359 | (const :tag "All reasons" t) | ||
| 360 | (set :tag "Selection of reasons..." | ||
| 361 | (const :tag "A breakpoint was reached." "breakpoint-hit") | ||
| 362 | (const :tag "A watchpoint was triggered." "watchpoint-trigger") | ||
| 363 | (const :tag "A read watchpoint was triggered." "read-watchpoint-trigger") | ||
| 364 | (const :tag "An access watchpoint was triggered." "access-watchpoint-trigger") | ||
| 365 | (const :tag "Function finished execution." "function-finished") | ||
| 366 | (const :tag "Location reached." "location-reached") | ||
| 367 | (const :tag "Watchpoint has gone out of scope" "watchpoint-scope") | ||
| 368 | (const :tag "End of stepping range reached." "end-stepping-range") | ||
| 369 | (const :tag "Signal received (like interruption)." "signal-received")) | ||
| 370 | (const :tag "None" nil)) | ||
| 371 | :group 'gdb-non-stop | ||
| 372 | :version "23.2" | ||
| 373 | :link '(info-link "(gdb)GDB/MI Async Records")) | ||
| 374 | |||
| 375 | (defcustom gdb-stopped-hooks nil | ||
| 376 | "This variable holds a list of functions to be called whenever | ||
| 377 | GDB stops. | ||
| 378 | |||
| 379 | Each function takes one argument, a parsed MI response, which | ||
| 380 | contains fields of corresponding MI *stopped async record: | ||
| 381 | |||
| 382 | ((stopped-threads . \"all\") | ||
| 383 | (thread-id . \"1\") | ||
| 384 | (frame (line . \"38\") | ||
| 385 | (fullname . \"/home/sphinx/projects/gsoc/server.c\") | ||
| 386 | (file . \"server.c\") | ||
| 387 | (args ((value . \"0x804b038\") | ||
| 388 | (name . \"arg\"))) | ||
| 389 | (func . \"hello\") | ||
| 390 | (addr . \"0x0804869e\")) | ||
| 391 | (reason . \"end-stepping-range\")) | ||
| 392 | |||
| 393 | Note that \"reason\" is only present in non-stop debugging mode. | ||
| 394 | |||
| 395 | `bindat-get-field' may be used to access the fields of response. | ||
| 396 | |||
| 397 | Each function is called after the new current thread was selected | ||
| 398 | and GDB buffers were updated in `gdb-stopped'." | ||
| 399 | :type '(repeat function) | ||
| 400 | :group 'gdb | ||
| 401 | :version "23.2" | ||
| 402 | :link '(info-link "(gdb)GDB/MI Async Records")) | ||
| 403 | |||
| 404 | (defcustom gdb-switch-when-another-stopped t | ||
| 405 | "When nil, Emacs won't switch to stopped thread if some other | ||
| 406 | stopped thread is already selected." | ||
| 407 | :type 'boolean | ||
| 408 | :group 'gdb-non-stop | ||
| 409 | :version "23.2") | ||
| 410 | |||
| 411 | (defcustom gdb-stack-buffer-locations t | ||
| 412 | "Show file information or library names in stack buffers." | ||
| 413 | :type 'boolean | ||
| 414 | :group 'gdb-buffers | ||
| 415 | :version "23.2") | ||
| 416 | |||
| 417 | (defcustom gdb-stack-buffer-addresses nil | ||
| 418 | "Show frame addresses in stack buffers." | ||
| 419 | :type 'boolean | ||
| 420 | :group 'gdb-buffers | ||
| 421 | :version "23.2") | ||
| 422 | |||
| 423 | (defcustom gdb-thread-buffer-verbose-names t | ||
| 424 | "Show long thread names in threads buffer." | ||
| 425 | :type 'boolean | ||
| 426 | :group 'gdb-buffers | ||
| 427 | :version "23.2") | ||
| 428 | |||
| 429 | (defcustom gdb-thread-buffer-arguments t | ||
| 430 | "Show function arguments in threads buffer." | ||
| 431 | :type 'boolean | ||
| 432 | :group 'gdb-buffers | ||
| 433 | :version "23.2") | ||
| 434 | |||
| 435 | (defcustom gdb-thread-buffer-locations t | ||
| 436 | "Show file information or library names in threads buffer." | ||
| 437 | :type 'boolean | ||
| 438 | :group 'gdb-buffers | ||
| 439 | :version "23.2") | ||
| 440 | |||
| 441 | (defcustom gdb-thread-buffer-addresses nil | ||
| 442 | "Show addresses for thread frames in threads buffer." | ||
| 443 | :type 'boolean | ||
| 444 | :group 'gdb-buffers | ||
| 445 | :version "23.2") | ||
| 446 | |||
| 447 | (defcustom gdb-show-threads-by-default nil | ||
| 448 | "Show threads list buffer instead of breakpoints list by | ||
| 449 | default." | ||
| 450 | :type 'boolean | ||
| 451 | :group 'gdb-buffers | ||
| 452 | :version "23.2") | ||
| 453 | |||
| 454 | (defvar gdb-debug-log nil | ||
| 455 | "List of commands sent to and replies received from GDB. | ||
| 456 | Most recent commands are listed first. This list stores only the last | ||
| 457 | `gdb-debug-log-max' values. This variable is used to debug GDB-MI.") | ||
| 458 | |||
| 459 | ;;;###autoload | ||
| 460 | (defcustom gdb-enable-debug nil | ||
| 461 | "Non-nil means record the process input and output in `gdb-debug-log'." | ||
| 462 | :type 'boolean | ||
| 463 | :group 'gdb | ||
| 464 | :version "22.1") | ||
| 465 | |||
| 466 | (defcustom gdb-cpp-define-alist-program "gcc -E -dM -" | ||
| 467 | "Shell command for generating a list of defined macros in a source file. | ||
| 468 | This list is used to display the #define directive associated | ||
| 469 | with an identifier as a tooltip. It works in a debug session with | ||
| 470 | GDB, when `gud-tooltip-mode' is t. | ||
| 471 | |||
| 472 | Set `gdb-cpp-define-alist-flags' for any include paths or | ||
| 473 | predefined macros." | ||
| 474 | :type 'string | ||
| 475 | :group 'gdb | ||
| 476 | :version "22.1") | ||
| 477 | |||
| 478 | (defcustom gdb-cpp-define-alist-flags "" | ||
| 479 | "Preprocessor flags for `gdb-cpp-define-alist-program'." | ||
| 480 | :type 'string | ||
| 481 | :group 'gdb | ||
| 482 | :version "22.1") | ||
| 483 | |||
| 484 | (defcustom gdb-create-source-file-list t | ||
| 485 | "Non-nil means create a list of files from which the executable was built. | ||
| 486 | Set this to nil if the GUD buffer displays \"initializing...\" in the mode | ||
| 487 | line for a long time when starting, possibly because your executable was | ||
| 488 | built from a large number of files. This allows quicker initialization | ||
| 489 | but means that these files are not automatically enabled for debugging, | ||
| 490 | e.g., you won't be able to click in the fringe to set a breakpoint until | ||
| 491 | execution has already stopped there." | ||
| 492 | :type 'boolean | ||
| 493 | :group 'gdb | ||
| 494 | :version "23.1") | ||
| 495 | |||
| 496 | (defcustom gdb-show-main nil | ||
| 497 | "Non-nil means display source file containing the main routine at startup. | ||
| 498 | Also display the main routine in the disassembly buffer if present." | ||
| 499 | :type 'boolean | ||
| 500 | :group 'gdb | ||
| 501 | :version "22.1") | ||
| 502 | |||
| 503 | (defun gdb-force-mode-line-update (status) | ||
| 504 | (let ((buffer gud-comint-buffer)) | ||
| 505 | (if (and buffer (buffer-name buffer)) | ||
| 506 | (with-current-buffer buffer | ||
| 507 | (setq mode-line-process | ||
| 508 | (format ":%s [%s]" | ||
| 509 | (process-status (get-buffer-process buffer)) status)) | ||
| 510 | ;; Force mode line redisplay soon. | ||
| 511 | (force-mode-line-update))))) | ||
| 512 | |||
| 513 | (defun gdb-enable-debug (arg) | ||
| 514 | "Toggle logging of transaction between Emacs and Gdb. | ||
| 515 | The log is stored in `gdb-debug-log' as an alist with elements | ||
| 516 | whose cons is send, send-item or recv and whose cdr is the string | ||
| 517 | being transferred. This list may grow up to a size of | ||
| 518 | `gdb-debug-log-max' after which the oldest element (at the end of | ||
| 519 | the list) is deleted every time a new one is added (at the front)." | ||
| 520 | (interactive "P") | ||
| 521 | (setq gdb-enable-debug | ||
| 522 | (if (null arg) | ||
| 523 | (not gdb-enable-debug) | ||
| 524 | (> (prefix-numeric-value arg) 0))) | ||
| 525 | (message (format "Logging of transaction %sabled" | ||
| 526 | (if gdb-enable-debug "en" "dis")))) | ||
| 527 | |||
| 528 | ;; These two are used for menu and toolbar | ||
| 529 | (defun gdb-control-all-threads () | ||
| 530 | "Switch to non-stop/A mode." | ||
| 531 | (interactive) | ||
| 532 | (setq gdb-gud-control-all-threads t) | ||
| 533 | ;; Actually forcing the tool-bar to update. | ||
| 534 | (force-mode-line-update) | ||
| 535 | (message "Now in non-stop/A mode.")) | ||
| 536 | |||
| 537 | (defun gdb-control-current-thread () | ||
| 538 | "Switch to non-stop/T mode." | ||
| 539 | (interactive) | ||
| 540 | (setq gdb-gud-control-all-threads nil) | ||
| 541 | ;; Actually forcing the tool-bar to update. | ||
| 542 | (force-mode-line-update) | ||
| 543 | (message "Now in non-stop/T mode.")) | ||
| 544 | |||
| 545 | (defun gdb-find-watch-expression () | ||
| 546 | (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list)) | ||
| 547 | (varnum (car var)) expr array) | ||
| 548 | (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum) | ||
| 549 | (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet | ||
| 550 | (component-list (split-string (match-string 2 varnum) "\\." t))) | ||
| 551 | (setq expr (nth 1 var1)) | ||
| 552 | (setq varnumlet (car var1)) | ||
| 553 | (dolist (component component-list) | ||
| 554 | (setq var2 (assoc varnumlet gdb-var-list)) | ||
| 555 | (setq expr (concat expr | ||
| 556 | (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2)) | ||
| 557 | (concat "[" component "]") | ||
| 558 | (concat "." component)))) | ||
| 559 | (setq varnumlet (concat varnumlet "." component))) | ||
| 560 | expr))) | ||
| 561 | |||
| 562 | ;; noall is used for commands which don't take --all, but only | ||
| 563 | ;; --thread. | ||
| 564 | (defun gdb-gud-context-command (command &optional noall) | ||
| 565 | "When `gdb-non-stop' is t, add --thread option to COMMAND if | ||
| 566 | `gdb-gud-control-all-threads' is nil and --all option otherwise. | ||
| 567 | If NOALL is t, always add --thread option no matter what | ||
| 568 | `gdb-gud-control-all-threads' value is. | ||
| 569 | |||
| 570 | When `gdb-non-stop' is nil, return COMMAND unchanged." | ||
| 571 | (if gdb-non-stop | ||
| 572 | (if (and gdb-gud-control-all-threads | ||
| 573 | (not noall) | ||
| 574 | (string-equal gdb-version "7.0+")) | ||
| 575 | (concat command " --all ") | ||
| 576 | (gdb-current-context-command command)) | ||
| 577 | command)) | ||
| 578 | |||
| 579 | (defmacro gdb-gud-context-call (cmd1 &optional cmd2 noall noarg) | ||
| 580 | "`gud-call' wrapper which adds --thread/--all options between | ||
| 581 | CMD1 and CMD2. NOALL is the same as in `gdb-gud-context-command'. | ||
| 582 | |||
| 583 | NOARG must be t when this macro is used outside `gud-def'" | ||
| 584 | `(gud-call | ||
| 585 | (concat (gdb-gud-context-command ,cmd1 ,noall) " " ,cmd2) | ||
| 586 | ,(when (not noarg) 'arg))) | ||
| 587 | |||
| 588 | ;;;###autoload | ||
| 589 | (defun gdb (command-line) | ||
| 590 | "Run gdb on program FILE in buffer *gud-FILE*. | ||
| 591 | The directory containing FILE becomes the initial working directory | ||
| 592 | and source-file directory for your debugger. | ||
| 593 | |||
| 594 | If `gdb-many-windows' is nil (the default value) then gdb just | ||
| 595 | pops up the GUD buffer unless `gdb-show-main' is t. In this case | ||
| 596 | it starts with two windows: one displaying the GUD buffer and the | ||
| 597 | other with the source file with the main routine of the inferior. | ||
| 598 | |||
| 599 | If `gdb-many-windows' is t, regardless of the value of | ||
| 600 | `gdb-show-main', the layout below will appear. Keybindings are | ||
| 601 | shown in some of the buffers. | ||
| 602 | |||
| 603 | Watch expressions appear in the speedbar/slowbar. | ||
| 604 | |||
| 605 | The following commands help control operation : | ||
| 606 | |||
| 607 | `gdb-many-windows' - Toggle the number of windows gdb uses. | ||
| 608 | `gdb-restore-windows' - To restore the window layout. | ||
| 609 | |||
| 610 | See Info node `(emacs)GDB Graphical Interface' for a more | ||
| 611 | detailed description of this mode. | ||
| 612 | |||
| 613 | |||
| 614 | +----------------------------------------------------------------------+ | ||
| 615 | | GDB Toolbar | | ||
| 616 | +-----------------------------------+----------------------------------+ | ||
| 617 | | GUD buffer (I/O of GDB) | Locals buffer | | ||
| 618 | | | | | ||
| 619 | | | | | ||
| 620 | | | | | ||
| 621 | +-----------------------------------+----------------------------------+ | ||
| 622 | | Source buffer | I/O buffer (of debugged program) | | ||
| 623 | | | (comint-mode) | | ||
| 624 | | | | | ||
| 625 | | | | | ||
| 626 | | | | | ||
| 627 | | | | | ||
| 628 | | | | | ||
| 629 | | | | | ||
| 630 | +-----------------------------------+----------------------------------+ | ||
| 631 | | Stack buffer | Breakpoints buffer | | ||
| 632 | | RET gdb-select-frame | SPC gdb-toggle-breakpoint | | ||
| 633 | | | RET gdb-goto-breakpoint | | ||
| 634 | | | D gdb-delete-breakpoint | | ||
| 635 | +-----------------------------------+----------------------------------+" | ||
| 636 | ;; | ||
| 637 | (interactive (list (gud-query-cmdline 'gdb))) | ||
| 638 | |||
| 639 | (when (and gud-comint-buffer | ||
| 640 | (buffer-name gud-comint-buffer) | ||
| 641 | (get-buffer-process gud-comint-buffer) | ||
| 642 | (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) | ||
| 643 | (gdb-restore-windows) | ||
| 644 | (error | ||
| 645 | "Multiple debugging requires restarting in text command mode")) | ||
| 646 | ;; | ||
| 647 | (gud-common-init command-line nil 'gud-gdbmi-marker-filter) | ||
| 648 | (set (make-local-variable 'gud-minor-mode) 'gdbmi) | ||
| 649 | (setq comint-input-sender 'gdb-send) | ||
| 650 | |||
| 651 | (gud-def gud-tbreak "tbreak %f:%l" "\C-t" | ||
| 652 | "Set temporary breakpoint at current line.") | ||
| 653 | (gud-def gud-jump | ||
| 654 | (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) | ||
| 655 | "\C-j" "Set execution address to current line.") | ||
| 656 | |||
| 657 | (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") | ||
| 658 | (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") | ||
| 659 | (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") | ||
| 660 | (gud-def gud-pstar "print* %e" nil | ||
| 661 | "Evaluate C dereferenced pointer expression at point.") | ||
| 662 | |||
| 663 | (gud-def gud-step (gdb-gud-context-call "-exec-step" "%p" t) | ||
| 664 | "\C-s" | ||
| 665 | "Step one source line with display.") | ||
| 666 | (gud-def gud-stepi (gdb-gud-context-call "-exec-step-instruction" "%p" t) | ||
| 667 | "\C-i" | ||
| 668 | "Step one instruction with display.") | ||
| 669 | (gud-def gud-next (gdb-gud-context-call "-exec-next" "%p" t) | ||
| 670 | "\C-n" | ||
| 671 | "Step one line (skip functions).") | ||
| 672 | (gud-def gud-nexti (gdb-gud-context-call "-exec-next-instruction" "%p" t) | ||
| 673 | nil | ||
| 674 | "Step one instruction (skip functions).") | ||
| 675 | (gud-def gud-cont (gdb-gud-context-call "-exec-continue") | ||
| 676 | "\C-r" | ||
| 677 | "Continue with display.") | ||
| 678 | (gud-def gud-finish (gdb-gud-context-call "-exec-finish" nil t) | ||
| 679 | "\C-f" | ||
| 680 | "Finish executing current function.") | ||
| 681 | (gud-def gud-run "-exec-run" | ||
| 682 | nil | ||
| 683 | "Run the program.") | ||
| 684 | |||
| 685 | (gud-def gud-break (if (not (string-match "Disassembly" mode-name)) | ||
| 686 | (gud-call "break %f:%l" arg) | ||
| 687 | (save-excursion | ||
| 688 | (beginning-of-line) | ||
| 689 | (forward-char 2) | ||
| 690 | (gud-call "break *%a" arg))) | ||
| 691 | "\C-b" "Set breakpoint at current line or address.") | ||
| 692 | |||
| 693 | (gud-def gud-remove (if (not (string-match "Disassembly" mode-name)) | ||
| 694 | (gud-call "clear %f:%l" arg) | ||
| 695 | (save-excursion | ||
| 696 | (beginning-of-line) | ||
| 697 | (forward-char 2) | ||
| 698 | (gud-call "clear *%a" arg))) | ||
| 699 | "\C-d" "Remove breakpoint at current line or address.") | ||
| 700 | |||
| 701 | ;; -exec-until doesn't support --all yet | ||
| 702 | (gud-def gud-until (if (not (string-match "Disassembly" mode-name)) | ||
| 703 | (gud-call "-exec-until %f:%l" arg) | ||
| 704 | (save-excursion | ||
| 705 | (beginning-of-line) | ||
| 706 | (forward-char 2) | ||
| 707 | (gud-call "-exec-until *%a" arg))) | ||
| 708 | "\C-u" "Continue to current line or address.") | ||
| 709 | ;; TODO Why arg here? | ||
| 710 | (gud-def | ||
| 711 | gud-go (gud-call (if gdb-active-process | ||
| 712 | (gdb-gud-context-command "-exec-continue") | ||
| 713 | "-exec-run") arg) | ||
| 714 | nil "Start or continue execution.") | ||
| 715 | |||
| 716 | ;; For debugging Emacs only. | ||
| 717 | (gud-def gud-pp | ||
| 718 | (gud-call | ||
| 719 | (concat | ||
| 720 | "pp1 " (if (eq (buffer-local-value | ||
| 721 | 'major-mode (window-buffer)) 'speedbar-mode) | ||
| 722 | (gdb-find-watch-expression) "%e")) arg) | ||
| 723 | nil "Print the Emacs s-expression.") | ||
| 724 | |||
| 725 | (define-key gud-minor-mode-map [left-margin mouse-1] | ||
| 726 | 'gdb-mouse-set-clear-breakpoint) | ||
| 727 | (define-key gud-minor-mode-map [left-fringe mouse-1] | ||
| 728 | 'gdb-mouse-set-clear-breakpoint) | ||
| 729 | (define-key gud-minor-mode-map [left-margin C-mouse-1] | ||
| 730 | 'gdb-mouse-toggle-breakpoint-margin) | ||
| 731 | (define-key gud-minor-mode-map [left-fringe C-mouse-1] | ||
| 732 | 'gdb-mouse-toggle-breakpoint-fringe) | ||
| 733 | |||
| 734 | (define-key gud-minor-mode-map [left-margin drag-mouse-1] | ||
| 735 | 'gdb-mouse-until) | ||
| 736 | (define-key gud-minor-mode-map [left-fringe drag-mouse-1] | ||
| 737 | 'gdb-mouse-until) | ||
| 738 | (define-key gud-minor-mode-map [left-margin mouse-3] | ||
| 739 | 'gdb-mouse-until) | ||
| 740 | (define-key gud-minor-mode-map [left-fringe mouse-3] | ||
| 741 | 'gdb-mouse-until) | ||
| 742 | |||
| 743 | (define-key gud-minor-mode-map [left-margin C-drag-mouse-1] | ||
| 744 | 'gdb-mouse-jump) | ||
| 745 | (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1] | ||
| 746 | 'gdb-mouse-jump) | ||
| 747 | (define-key gud-minor-mode-map [left-fringe C-mouse-3] | ||
| 748 | 'gdb-mouse-jump) | ||
| 749 | (define-key gud-minor-mode-map [left-margin C-mouse-3] | ||
| 750 | 'gdb-mouse-jump) | ||
| 751 | |||
| 752 | (local-set-key "\C-i" 'gud-gdb-complete-command) | ||
| 753 | (setq gdb-first-prompt t) | ||
| 754 | (setq gud-running nil) | ||
| 755 | |||
| 756 | (gdb-update) | ||
| 757 | |||
| 758 | (run-hooks 'gdb-mode-hook)) | ||
| 759 | |||
| 760 | (defun gdb-init-1 () | ||
| 761 | ;; (re-)initialise | ||
| 762 | (setq gdb-selected-frame nil | ||
| 763 | gdb-frame-number nil | ||
| 764 | gdb-thread-number nil | ||
| 765 | gdb-var-list nil | ||
| 766 | gdb-pending-triggers nil | ||
| 767 | gdb-output-sink 'user | ||
| 768 | gdb-location-alist nil | ||
| 769 | gdb-source-file-list nil | ||
| 770 | gdb-last-command nil | ||
| 771 | gdb-token-number 0 | ||
| 772 | gdb-handler-alist '() | ||
| 773 | gdb-handler-number nil | ||
| 774 | gdb-prompt-name nil | ||
| 775 | gdb-first-done-or-error t | ||
| 776 | gdb-buffer-fringe-width (car (window-fringes)) | ||
| 777 | gdb-debug-log nil | ||
| 778 | gdb-source-window nil | ||
| 779 | gdb-inferior-status nil | ||
| 780 | gdb-continuation nil | ||
| 781 | gdb-buf-publisher '() | ||
| 782 | gdb-threads-list '() | ||
| 783 | gdb-breakpoints-list '() | ||
| 784 | gdb-register-names '() | ||
| 785 | gdb-non-stop gdb-non-stop-setting) | ||
| 786 | ;; | ||
| 787 | (setq gdb-buffer-type 'gdbmi) | ||
| 788 | ;; | ||
| 789 | (gdb-force-mode-line-update | ||
| 790 | (propertize "initializing..." 'face font-lock-variable-name-face)) | ||
| 791 | |||
| 792 | (gdb-get-buffer-create 'gdb-inferior-io) | ||
| 793 | (gdb-clear-inferior-io) | ||
| 794 | (set-process-filter (get-process "gdb-inferior") 'gdb-inferior-filter) | ||
| 795 | (gdb-input | ||
| 796 | ;; Needs GDB 6.4 onwards | ||
| 797 | (list (concat "-inferior-tty-set " | ||
| 798 | (process-tty-name (get-process "gdb-inferior"))) | ||
| 799 | 'ignore)) | ||
| 800 | (if (eq window-system 'w32) | ||
| 801 | (gdb-input (list "-gdb-set new-console off" 'ignore))) | ||
| 802 | (gdb-input (list "-gdb-set height 0" 'ignore)) | ||
| 803 | |||
| 804 | (when gdb-non-stop | ||
| 805 | (gdb-input (list "-gdb-set non-stop 1" 'gdb-non-stop-handler))) | ||
| 806 | |||
| 807 | ;; find source file and compilation directory here | ||
| 808 | (gdb-input | ||
| 809 | ; Needs GDB 6.2 onwards. | ||
| 810 | (list "-file-list-exec-source-files" 'gdb-get-source-file-list)) | ||
| 811 | (if gdb-create-source-file-list | ||
| 812 | (gdb-input | ||
| 813 | ; Needs GDB 6.0 onwards. | ||
| 814 | (list "-file-list-exec-source-file" 'gdb-get-source-file))) | ||
| 815 | (gdb-input | ||
| 816 | (list "-gdb-show prompt" 'gdb-get-prompt))) | ||
| 817 | |||
| 818 | (defun gdb-non-stop-handler () | ||
| 819 | (goto-char (point-min)) | ||
| 820 | (if (re-search-forward "No symbol" nil t) | ||
| 821 | (progn | ||
| 822 | (message "This version of GDB doesn't support non-stop mode. Turning it off.") | ||
| 823 | (setq gdb-non-stop nil) | ||
| 824 | (setq gdb-version "pre-7.0")) | ||
| 825 | (setq gdb-version "7.0+") | ||
| 826 | (gdb-input (list "-gdb-set target-async 1" 'ignore)) | ||
| 827 | (gdb-input (list "-enable-pretty-printing" 'ignore)))) | ||
| 828 | |||
| 829 | (defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.") | ||
| 830 | |||
| 831 | (defun gdb-create-define-alist () | ||
| 832 | "Create an alist of #define directives for GUD tooltips." | ||
| 833 | (let* ((file (buffer-file-name)) | ||
| 834 | (output | ||
| 835 | (with-output-to-string | ||
| 836 | (with-current-buffer standard-output | ||
| 837 | (and file | ||
| 838 | (file-exists-p file) | ||
| 839 | ;; call-process doesn't work with remote file names. | ||
| 840 | (not (file-remote-p default-directory)) | ||
| 841 | (call-process shell-file-name file | ||
| 842 | (list t nil) nil "-c" | ||
| 843 | (concat gdb-cpp-define-alist-program " " | ||
| 844 | gdb-cpp-define-alist-flags)))))) | ||
| 845 | (define-list (split-string output "\n" t)) | ||
| 846 | (name)) | ||
| 847 | (setq gdb-define-alist nil) | ||
| 848 | (dolist (define define-list) | ||
| 849 | (setq name (nth 1 (split-string define "[( ]"))) | ||
| 850 | (push (cons name define) gdb-define-alist)))) | ||
| 851 | |||
| 852 | (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) | ||
| 853 | (defvar tooltip-use-echo-area) | ||
| 854 | |||
| 855 | (defun gdb-tooltip-print (expr) | ||
| 856 | (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) | ||
| 857 | (goto-char (point-min)) | ||
| 858 | (if (re-search-forward ".*value=\\(\".*\"\\)" nil t) | ||
| 859 | (tooltip-show | ||
| 860 | (concat expr " = " (read (match-string 1))) | ||
| 861 | (or gud-tooltip-echo-area tooltip-use-echo-area | ||
| 862 | (not (display-graphic-p))))))) | ||
| 863 | |||
| 864 | ;; If expr is a macro for a function don't print because of possible dangerous | ||
| 865 | ;; side-effects. Also printing a function within a tooltip generates an | ||
| 866 | ;; unexpected starting annotation (phase error). | ||
| 867 | (defun gdb-tooltip-print-1 (expr) | ||
| 868 | (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) | ||
| 869 | (goto-char (point-min)) | ||
| 870 | (if (search-forward "expands to: " nil t) | ||
| 871 | (unless (looking-at "\\S-+.*(.*).*") | ||
| 872 | (gdb-input | ||
| 873 | (list (concat "-data-evaluate-expression " expr) | ||
| 874 | `(lambda () (gdb-tooltip-print ,expr)))))))) | ||
| 875 | |||
| 876 | (defun gdb-init-buffer () | ||
| 877 | (set (make-local-variable 'gud-minor-mode) 'gdbmi) | ||
| 878 | (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) | ||
| 879 | (when gud-tooltip-mode | ||
| 880 | (make-local-variable 'gdb-define-alist) | ||
| 881 | (gdb-create-define-alist) | ||
| 882 | (add-hook 'after-save-hook 'gdb-create-define-alist nil t))) | ||
| 883 | |||
| 884 | (defmacro gdb-if-arrow (arrow-position &rest body) | ||
| 885 | `(if ,arrow-position | ||
| 886 | (let ((buffer (marker-buffer ,arrow-position)) (line)) | ||
| 887 | (if (equal buffer (window-buffer (posn-window end))) | ||
| 888 | (with-current-buffer buffer | ||
| 889 | (when (or (equal start end) | ||
| 890 | (equal (posn-point start) | ||
| 891 | (marker-position ,arrow-position))) | ||
| 892 | ,@body)))))) | ||
| 893 | |||
| 894 | (defun gdb-mouse-until (event) | ||
| 895 | "Continue running until a source line past the current line. | ||
| 896 | The destination source line can be selected either by clicking | ||
| 897 | with mouse-3 on the fringe/margin or dragging the arrow | ||
| 898 | with mouse-1 (default bindings)." | ||
| 899 | (interactive "e") | ||
| 900 | (let ((start (event-start event)) | ||
| 901 | (end (event-end event))) | ||
| 902 | (gdb-if-arrow gud-overlay-arrow-position | ||
| 903 | (setq line (line-number-at-pos (posn-point end))) | ||
| 904 | (gud-call (concat "until " (number-to-string line)))) | ||
| 905 | (gdb-if-arrow gdb-disassembly-position | ||
| 906 | (save-excursion | ||
| 907 | (goto-char (point-min)) | ||
| 908 | (forward-line (1- (line-number-at-pos (posn-point end)))) | ||
| 909 | (forward-char 2) | ||
| 910 | (gud-call (concat "until *%a")))))) | ||
| 911 | |||
| 912 | (defun gdb-mouse-jump (event) | ||
| 913 | "Set execution address/line. | ||
| 914 | The destination source line can be selected either by clicking with C-mouse-3 | ||
| 915 | on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings). | ||
| 916 | Unlike `gdb-mouse-until' the destination address can be before the current | ||
| 917 | line, and no execution takes place." | ||
| 918 | (interactive "e") | ||
| 919 | (let ((start (event-start event)) | ||
| 920 | (end (event-end event))) | ||
| 921 | (gdb-if-arrow gud-overlay-arrow-position | ||
| 922 | (setq line (line-number-at-pos (posn-point end))) | ||
| 923 | (progn | ||
| 924 | (gud-call (concat "tbreak " (number-to-string line))) | ||
| 925 | (gud-call (concat "jump " (number-to-string line))))) | ||
| 926 | (gdb-if-arrow gdb-disassembly-position | ||
| 927 | (save-excursion | ||
| 928 | (goto-char (point-min)) | ||
| 929 | (forward-line (1- (line-number-at-pos (posn-point end)))) | ||
| 930 | (forward-char 2) | ||
| 931 | (progn | ||
| 932 | (gud-call (concat "tbreak *%a")) | ||
| 933 | (gud-call (concat "jump *%a"))))))) | ||
| 934 | |||
| 935 | (defcustom gdb-show-changed-values t | ||
| 936 | "If non-nil change the face of out of scope variables and changed values. | ||
| 937 | Out of scope variables are suppressed with `shadow' face. | ||
| 938 | Changed values are highlighted with the face `font-lock-warning-face'." | ||
| 939 | :type 'boolean | ||
| 940 | :group 'gdb | ||
| 941 | :version "22.1") | ||
| 942 | |||
| 943 | (defcustom gdb-max-children 40 | ||
| 944 | "Maximum number of children before expansion requires confirmation." | ||
| 945 | :type 'integer | ||
| 946 | :group 'gdb | ||
| 947 | :version "22.1") | ||
| 948 | |||
| 949 | (defcustom gdb-delete-out-of-scope t | ||
| 950 | "If non-nil delete watch expressions automatically when they go out of scope." | ||
| 951 | :type 'boolean | ||
| 952 | :group 'gdb | ||
| 953 | :version "22.2") | ||
| 954 | |||
| 955 | (defcustom gdb-speedbar-auto-raise nil | ||
| 956 | "If non-nil raise speedbar every time display of watch expressions is\ | ||
| 957 | updated." | ||
| 958 | :type 'boolean | ||
| 959 | :group 'gdb | ||
| 960 | :version "22.1") | ||
| 961 | |||
| 962 | (defcustom gdb-use-colon-colon-notation nil | ||
| 963 | "If non-nil use FUN::VAR format to display variables in the speedbar." | ||
| 964 | :type 'boolean | ||
| 965 | :group 'gdb | ||
| 966 | :version "22.1") | ||
| 967 | |||
| 968 | (defun gdb-speedbar-auto-raise (arg) | ||
| 969 | "Toggle automatic raising of the speedbar for watch expressions. | ||
| 970 | With prefix argument ARG, automatically raise speedbar if ARG is | ||
| 971 | positive, otherwise don't automatically raise it." | ||
| 972 | (interactive "P") | ||
| 973 | (setq gdb-speedbar-auto-raise | ||
| 974 | (if (null arg) | ||
| 975 | (not gdb-speedbar-auto-raise) | ||
| 976 | (> (prefix-numeric-value arg) 0))) | ||
| 977 | (message (format "Auto raising %sabled" | ||
| 978 | (if gdb-speedbar-auto-raise "en" "dis")))) | ||
| 979 | |||
| 980 | (define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch) | ||
| 981 | (define-key global-map (concat gud-key-prefix "\C-w") 'gud-watch) | ||
| 982 | |||
| 983 | (declare-function tooltip-identifier-from-point "tooltip" (point)) | ||
| 984 | |||
| 985 | (defun gud-watch (&optional arg event) | ||
| 986 | "Watch expression at point. | ||
| 987 | With arg, enter name of variable to be watched in the minibuffer." | ||
| 988 | (interactive (list current-prefix-arg last-input-event)) | ||
| 989 | (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer))) | ||
| 990 | (if (eq minor-mode 'gdbmi) | ||
| 991 | (progn | ||
| 992 | (if event (posn-set-point (event-end event))) | ||
| 993 | (require 'tooltip) | ||
| 994 | (save-selected-window | ||
| 995 | (let ((expr | ||
| 996 | (if arg | ||
| 997 | (completing-read "Name of variable: " | ||
| 998 | 'gud-gdb-complete-command) | ||
| 999 | (if (and transient-mark-mode mark-active) | ||
| 1000 | (buffer-substring (region-beginning) (region-end)) | ||
| 1001 | (concat (if (eq major-mode 'gdb-registers-mode) "$") | ||
| 1002 | (tooltip-identifier-from-point (point))))))) | ||
| 1003 | (set-text-properties 0 (length expr) nil expr) | ||
| 1004 | (gdb-input | ||
| 1005 | (list (concat"-var-create - * " expr "") | ||
| 1006 | `(lambda () (gdb-var-create-handler ,expr))))))) | ||
| 1007 | (message "gud-watch is a no-op in this mode.")))) | ||
| 1008 | |||
| 1009 | (defun gdb-var-create-handler (expr) | ||
| 1010 | (let* ((result (gdb-json-partial-output))) | ||
| 1011 | (if (not (bindat-get-field result 'msg)) | ||
| 1012 | (let ((var | ||
| 1013 | (list (bindat-get-field result 'name) | ||
| 1014 | (if (and (string-equal gdb-current-language "c") | ||
| 1015 | gdb-use-colon-colon-notation gdb-selected-frame) | ||
| 1016 | (setq expr (concat gdb-selected-frame "::" expr)) | ||
| 1017 | expr) | ||
| 1018 | (bindat-get-field result 'numchild) | ||
| 1019 | (bindat-get-field result 'type) | ||
| 1020 | (bindat-get-field result 'value) | ||
| 1021 | nil | ||
| 1022 | (bindat-get-field result 'has_more) | ||
| 1023 | gdb-frame-address))) | ||
| 1024 | (push var gdb-var-list) | ||
| 1025 | (speedbar 1) | ||
| 1026 | (unless (string-equal | ||
| 1027 | speedbar-initial-expansion-list-name "GUD") | ||
| 1028 | (speedbar-change-initial-expansion-list "GUD"))) | ||
| 1029 | (message-box "No symbol \"%s\" in current context." expr)))) | ||
| 1030 | |||
| 1031 | (defun gdb-speedbar-update () | ||
| 1032 | (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame) | ||
| 1033 | (not (gdb-pending-p 'gdb-speedbar-timer))) | ||
| 1034 | ;; Dummy command to update speedbar even when idle. | ||
| 1035 | (gdb-input (list "-environment-pwd" 'gdb-speedbar-timer-fn)) | ||
| 1036 | ;; Keep gdb-pending-triggers non-nil till end. | ||
| 1037 | (gdb-add-pending 'gdb-speedbar-timer))) | ||
| 1038 | |||
| 1039 | (defun gdb-speedbar-timer-fn () | ||
| 1040 | (if gdb-speedbar-auto-raise | ||
| 1041 | (raise-frame speedbar-frame)) | ||
| 1042 | (gdb-delete-pending 'gdb-speedbar-timer) | ||
| 1043 | (speedbar-timer-fn)) | ||
| 1044 | |||
| 1045 | (defun gdb-var-evaluate-expression-handler (varnum changed) | ||
| 1046 | (goto-char (point-min)) | ||
| 1047 | (re-search-forward ".*value=\\(\".*\"\\)" nil t) | ||
| 1048 | (let ((var (assoc varnum gdb-var-list))) | ||
| 1049 | (when var | ||
| 1050 | (if changed (setcar (nthcdr 5 var) 'changed)) | ||
| 1051 | (setcar (nthcdr 4 var) (read (match-string 1))))) | ||
| 1052 | (gdb-speedbar-update)) | ||
| 1053 | |||
| 1054 | ; Uses "-var-list-children --all-values". Needs GDB 6.1 onwards. | ||
| 1055 | (defun gdb-var-list-children (varnum) | ||
| 1056 | (gdb-input | ||
| 1057 | (list (concat "-var-update " varnum) 'ignore)) | ||
| 1058 | (gdb-input | ||
| 1059 | (list (concat "-var-list-children --all-values " | ||
| 1060 | varnum) | ||
| 1061 | `(lambda () (gdb-var-list-children-handler ,varnum))))) | ||
| 1062 | |||
| 1063 | (defun gdb-var-list-children-handler (varnum) | ||
| 1064 | (let* ((var-list nil) | ||
| 1065 | (output (bindat-get-field (gdb-json-partial-output "child"))) | ||
| 1066 | (children (bindat-get-field output 'children))) | ||
| 1067 | (catch 'child-already-watched | ||
| 1068 | (dolist (var gdb-var-list) | ||
| 1069 | (if (string-equal varnum (car var)) | ||
| 1070 | (progn | ||
| 1071 | ;; With dynamic varobjs numchild may have increased. | ||
| 1072 | (setcar (nthcdr 2 var) (bindat-get-field output 'numchild)) | ||
| 1073 | (push var var-list) | ||
| 1074 | (dolist (child children) | ||
| 1075 | (let ((varchild (list (bindat-get-field child 'name) | ||
| 1076 | (bindat-get-field child 'exp) | ||
| 1077 | (bindat-get-field child 'numchild) | ||
| 1078 | (bindat-get-field child 'type) | ||
| 1079 | (bindat-get-field child 'value) | ||
| 1080 | nil | ||
| 1081 | (bindat-get-field child 'has_more)))) | ||
| 1082 | (if (assoc (car varchild) gdb-var-list) | ||
| 1083 | (throw 'child-already-watched nil)) | ||
| 1084 | (push varchild var-list)))) | ||
| 1085 | (push var var-list))) | ||
| 1086 | (setq gdb-var-list (nreverse var-list)))) | ||
| 1087 | (gdb-speedbar-update)) | ||
| 1088 | |||
| 1089 | (defun gdb-var-set-format (format) | ||
| 1090 | "Set the output format for a variable displayed in the speedbar." | ||
| 1091 | (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) | ||
| 1092 | (varnum (car var))) | ||
| 1093 | (gdb-input | ||
| 1094 | (list (concat "-var-set-format " varnum " " format) 'ignore)) | ||
| 1095 | (gdb-var-update))) | ||
| 1096 | |||
| 1097 | (defun gdb-var-delete-1 (var varnum) | ||
| 1098 | (gdb-input | ||
| 1099 | (list (concat "-var-delete " varnum) 'ignore)) | ||
| 1100 | (setq gdb-var-list (delq var gdb-var-list)) | ||
| 1101 | (dolist (varchild gdb-var-list) | ||
| 1102 | (if (string-match (concat (car var) "\\.") (car varchild)) | ||
| 1103 | (setq gdb-var-list (delq varchild gdb-var-list))))) | ||
| 1104 | |||
| 1105 | (defun gdb-var-delete () | ||
| 1106 | "Delete watch expression at point from the speedbar." | ||
| 1107 | (interactive) | ||
| 1108 | (let ((text (speedbar-line-text))) | ||
| 1109 | (string-match "\\(\\S-+\\)" text) | ||
| 1110 | (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) | ||
| 1111 | (varnum (car var))) | ||
| 1112 | (if (string-match "\\." (car var)) | ||
| 1113 | (message-box "Can only delete a root expression") | ||
| 1114 | (gdb-var-delete-1 var varnum))))) | ||
| 1115 | |||
| 1116 | (defun gdb-var-delete-children (varnum) | ||
| 1117 | "Delete children of variable object at point from the speedbar." | ||
| 1118 | (gdb-input | ||
| 1119 | (list (concat "-var-delete -c " varnum) 'ignore))) | ||
| 1120 | |||
| 1121 | (defun gdb-edit-value (text token indent) | ||
| 1122 | "Assign a value to a variable displayed in the speedbar." | ||
| 1123 | (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) | ||
| 1124 | (varnum (car var)) (value)) | ||
| 1125 | (setq value (read-string "New value: ")) | ||
| 1126 | (gdb-input | ||
| 1127 | (list (concat "-var-assign " varnum " " value) | ||
| 1128 | `(lambda () (gdb-edit-value-handler ,value)))))) | ||
| 1129 | |||
| 1130 | (defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)") | ||
| 1131 | |||
| 1132 | (defun gdb-edit-value-handler (value) | ||
| 1133 | (goto-char (point-min)) | ||
| 1134 | (if (re-search-forward gdb-error-regexp nil t) | ||
| 1135 | (message-box "Invalid number or expression (%s)" value))) | ||
| 1136 | |||
| 1137 | ; Uses "-var-update --all-values". Needs GDB 6.4 onwards. | ||
| 1138 | (defun gdb-var-update () | ||
| 1139 | (if (not (gdb-pending-p 'gdb-var-update)) | ||
| 1140 | (gdb-input | ||
| 1141 | (list "-var-update --all-values *" 'gdb-var-update-handler))) | ||
| 1142 | (gdb-add-pending 'gdb-var-update)) | ||
| 1143 | |||
| 1144 | (defun gdb-var-update-handler () | ||
| 1145 | (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist))) | ||
| 1146 | (dolist (var gdb-var-list) | ||
| 1147 | (setcar (nthcdr 5 var) nil)) | ||
| 1148 | (let ((temp-var-list gdb-var-list)) | ||
| 1149 | (dolist (change changelist) | ||
| 1150 | (let* ((varnum (bindat-get-field change 'name)) | ||
| 1151 | (var (assoc varnum gdb-var-list)) | ||
| 1152 | (new-num (bindat-get-field change 'new_num_children))) | ||
| 1153 | (when var | ||
| 1154 | (let ((scope (bindat-get-field change 'in_scope)) | ||
| 1155 | (has-more (bindat-get-field change 'has_more))) | ||
| 1156 | (cond ((string-equal scope "false") | ||
| 1157 | (if gdb-delete-out-of-scope | ||
| 1158 | (gdb-var-delete-1 var varnum) | ||
| 1159 | (setcar (nthcdr 5 var) 'out-of-scope))) | ||
| 1160 | ((string-equal scope "true") | ||
| 1161 | (setcar (nthcdr 6 var) has-more) | ||
| 1162 | (when (and (or (not has-more) | ||
| 1163 | (string-equal has-more "0")) | ||
| 1164 | (not new-num) | ||
| 1165 | (string-equal (nth 2 var) "0")) | ||
| 1166 | (setcar (nthcdr 4 var) | ||
| 1167 | (bindat-get-field change 'value)) | ||
| 1168 | (setcar (nthcdr 5 var) 'changed))) | ||
| 1169 | ((string-equal scope "invalid") | ||
| 1170 | (gdb-var-delete-1 var varnum))))) | ||
| 1171 | (let ((var-list nil) var1 | ||
| 1172 | (children (bindat-get-field change 'new_children))) | ||
| 1173 | (if new-num | ||
| 1174 | (progn | ||
| 1175 | (setq var1 (pop temp-var-list)) | ||
| 1176 | (while var1 | ||
| 1177 | (if (string-equal varnum (car var1)) | ||
| 1178 | (let ((new (string-to-number new-num)) | ||
| 1179 | (previous (string-to-number (nth 2 var1)))) | ||
| 1180 | (setcar (nthcdr 2 var1) new-num) | ||
| 1181 | (push var1 var-list) | ||
| 1182 | (cond ((> new previous) | ||
| 1183 | ;; Add new children to list. | ||
| 1184 | (dotimes (dummy previous) | ||
| 1185 | (push (pop temp-var-list) var-list)) | ||
| 1186 | (dolist (child children) | ||
| 1187 | (let ((varchild | ||
| 1188 | (list (bindat-get-field child 'name) | ||
| 1189 | (bindat-get-field child 'exp) | ||
| 1190 | (bindat-get-field child 'numchild) | ||
| 1191 | (bindat-get-field child 'type) | ||
| 1192 | (bindat-get-field child 'value) | ||
| 1193 | 'changed | ||
| 1194 | (bindat-get-field child 'has_more)))) | ||
| 1195 | (push varchild var-list)))) | ||
| 1196 | ;; Remove deleted children from list. | ||
| 1197 | ((< new previous) | ||
| 1198 | (dotimes (dummy new) | ||
| 1199 | (push (pop temp-var-list) var-list)) | ||
| 1200 | (dotimes (dummy (- previous new)) | ||
| 1201 | (pop temp-var-list))))) | ||
| 1202 | (push var1 var-list)) | ||
| 1203 | (setq var1 (pop temp-var-list))) | ||
| 1204 | (setq gdb-var-list (nreverse var-list))))))))) | ||
| 1205 | (setq gdb-pending-triggers | ||
| 1206 | (delq 'gdb-var-update gdb-pending-triggers)) | ||
| 1207 | (gdb-speedbar-update)) | ||
| 1208 | |||
| 1209 | (defun gdb-speedbar-expand-node (text token indent) | ||
| 1210 | "Expand the node the user clicked on. | ||
| 1211 | TEXT is the text of the button we clicked on, a + or - item. | ||
| 1212 | TOKEN is data related to this node. | ||
| 1213 | INDENT is the current indentation depth." | ||
| 1214 | (cond ((string-match "+" text) ;expand this node | ||
| 1215 | (let* ((var (assoc token gdb-var-list)) | ||
| 1216 | (expr (nth 1 var)) (children (nth 2 var))) | ||
| 1217 | (if (or (<= (string-to-number children) gdb-max-children) | ||
| 1218 | (y-or-n-p | ||
| 1219 | (format "%s has %s children. Continue? " expr children))) | ||
| 1220 | (gdb-var-list-children token)))) | ||
| 1221 | ((string-match "-" text) ;contract this node | ||
| 1222 | (dolist (var gdb-var-list) | ||
| 1223 | (if (string-match (concat token "\\.") (car var)) | ||
| 1224 | (setq gdb-var-list (delq var gdb-var-list)))) | ||
| 1225 | (gdb-var-delete-children token) | ||
| 1226 | (speedbar-change-expand-button-char ?+) | ||
| 1227 | (speedbar-delete-subblock indent)) | ||
| 1228 | (t (error "Ooops... not sure what to do"))) | ||
| 1229 | (speedbar-center-buffer-smartly)) | ||
| 1230 | |||
| 1231 | (defun gdb-get-target-string () | ||
| 1232 | (with-current-buffer gud-comint-buffer | ||
| 1233 | gud-target-name)) | ||
| 1234 | |||
| 1235 | |||
| 1236 | ;; | ||
| 1237 | ;; gdb buffers. | ||
| 1238 | ;; | ||
| 1239 | ;; Each buffer has a TYPE -- a symbol that identifies the function | ||
| 1240 | ;; of that particular buffer. | ||
| 1241 | ;; | ||
| 1242 | ;; The usual gdb interaction buffer is given the type `gdbmi' and | ||
| 1243 | ;; is constructed specially. | ||
| 1244 | ;; | ||
| 1245 | ;; Others are constructed by gdb-get-buffer-create and | ||
| 1246 | ;; named according to the rules set forth in the gdb-buffer-rules | ||
| 1247 | |||
| 1248 | (defvar gdb-buffer-rules '()) | ||
| 1249 | |||
| 1250 | (defun gdb-rules-name-maker (rules-entry) | ||
| 1251 | (cadr rules-entry)) | ||
| 1252 | (defun gdb-rules-buffer-mode (rules-entry) | ||
| 1253 | (nth 2 rules-entry)) | ||
| 1254 | (defun gdb-rules-update-trigger (rules-entry) | ||
| 1255 | (nth 3 rules-entry)) | ||
| 1256 | |||
| 1257 | (defun gdb-update-buffer-name () | ||
| 1258 | "Rename current buffer according to name-maker associated with | ||
| 1259 | it in `gdb-buffer-rules'." | ||
| 1260 | (let ((f (gdb-rules-name-maker (assoc gdb-buffer-type | ||
| 1261 | gdb-buffer-rules)))) | ||
| 1262 | (when f (rename-buffer (funcall f))))) | ||
| 1263 | |||
| 1264 | (defun gdb-current-buffer-rules () | ||
| 1265 | "Get `gdb-buffer-rules' entry for current buffer type." | ||
| 1266 | (assoc gdb-buffer-type gdb-buffer-rules)) | ||
| 1267 | |||
| 1268 | (defun gdb-current-buffer-thread () | ||
| 1269 | "Get thread object of current buffer from `gdb-threads-list'. | ||
| 1270 | |||
| 1271 | When current buffer is not bound to any thread, return main | ||
| 1272 | thread." | ||
| 1273 | (cdr (assoc gdb-thread-number gdb-threads-list))) | ||
| 1274 | |||
| 1275 | (defun gdb-current-buffer-frame () | ||
| 1276 | "Get current stack frame object for thread of current buffer." | ||
| 1277 | (bindat-get-field (gdb-current-buffer-thread) 'frame)) | ||
| 1278 | |||
| 1279 | (defun gdb-buffer-type (buffer) | ||
| 1280 | "Get value of `gdb-buffer-type' for BUFFER." | ||
| 1281 | (with-current-buffer buffer | ||
| 1282 | gdb-buffer-type)) | ||
| 1283 | |||
| 1284 | (defun gdb-buffer-shows-main-thread-p () | ||
| 1285 | "Return t if current GDB buffer shows main selected thread and | ||
| 1286 | is not bound to it." | ||
| 1287 | (current-buffer) | ||
| 1288 | (not (local-variable-p 'gdb-thread-number))) | ||
| 1289 | |||
| 1290 | (defun gdb-get-buffer (buffer-type &optional thread) | ||
| 1291 | "Get a specific GDB buffer. | ||
| 1292 | |||
| 1293 | In that buffer, `gdb-buffer-type' must be equal to BUFFER-TYPE | ||
| 1294 | and `gdb-thread-number' (if provided) must be equal to THREAD." | ||
| 1295 | (catch 'found | ||
| 1296 | (dolist (buffer (buffer-list) nil) | ||
| 1297 | (with-current-buffer buffer | ||
| 1298 | (when (and (eq gdb-buffer-type buffer-type) | ||
| 1299 | (or (not thread) | ||
| 1300 | (equal gdb-thread-number thread))) | ||
| 1301 | (throw 'found buffer)))))) | ||
| 1302 | |||
| 1303 | (defun gdb-get-buffer-create (buffer-type &optional thread) | ||
| 1304 | "Create a new GDB buffer of the type specified by BUFFER-TYPE. | ||
| 1305 | The buffer-type should be one of the cars in `gdb-buffer-rules'. | ||
| 1306 | |||
| 1307 | If THREAD is non-nil, it is assigned to `gdb-thread-number' | ||
| 1308 | buffer-local variable of the new buffer. | ||
| 1309 | |||
| 1310 | Buffer mode and name are selected according to buffer type. | ||
| 1311 | |||
| 1312 | If buffer has trigger associated with it in `gdb-buffer-rules', | ||
| 1313 | this trigger is subscribed to `gdb-buf-publisher' and called with | ||
| 1314 | 'update argument." | ||
| 1315 | (or (gdb-get-buffer buffer-type thread) | ||
| 1316 | (let ((rules (assoc buffer-type gdb-buffer-rules)) | ||
| 1317 | (new (generate-new-buffer "limbo"))) | ||
| 1318 | (with-current-buffer new | ||
| 1319 | (let ((mode (gdb-rules-buffer-mode rules)) | ||
| 1320 | (trigger (gdb-rules-update-trigger rules))) | ||
| 1321 | (when mode (funcall mode)) | ||
| 1322 | (setq gdb-buffer-type buffer-type) | ||
| 1323 | (when thread | ||
| 1324 | (set (make-local-variable 'gdb-thread-number) thread)) | ||
| 1325 | (set (make-local-variable 'gud-minor-mode) | ||
| 1326 | (buffer-local-value 'gud-minor-mode gud-comint-buffer)) | ||
| 1327 | (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) | ||
| 1328 | (rename-buffer (funcall (gdb-rules-name-maker rules))) | ||
| 1329 | (when trigger | ||
| 1330 | (gdb-add-subscriber gdb-buf-publisher | ||
| 1331 | (cons (current-buffer) | ||
| 1332 | (gdb-bind-function-to-buffer trigger (current-buffer)))) | ||
| 1333 | (funcall trigger 'start)) | ||
| 1334 | (current-buffer)))))) | ||
| 1335 | |||
| 1336 | (defun gdb-bind-function-to-buffer (expr buffer) | ||
| 1337 | "Return a function which will evaluate EXPR in BUFFER." | ||
| 1338 | `(lambda (&rest args) | ||
| 1339 | (with-current-buffer ,buffer | ||
| 1340 | (apply ',expr args)))) | ||
| 1341 | |||
| 1342 | ;; Used to define all gdb-frame-*-buffer functions except | ||
| 1343 | ;; `gdb-frame-io-buffer' | ||
| 1344 | (defmacro def-gdb-frame-for-buffer (name buffer &optional doc) | ||
| 1345 | "Define a function NAME which shows gdb BUFFER in a separate frame. | ||
| 1346 | |||
| 1347 | DOC is an optional documentation string." | ||
| 1348 | `(defun ,name (&optional thread) | ||
| 1349 | ,(when doc doc) | ||
| 1350 | (interactive) | ||
| 1351 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 1352 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 1353 | (display-buffer (gdb-get-buffer-create ,buffer thread))))) | ||
| 1354 | |||
| 1355 | (defmacro def-gdb-display-buffer (name buffer &optional doc) | ||
| 1356 | "Define a function NAME which shows gdb BUFFER. | ||
| 1357 | |||
| 1358 | DOC is an optional documentation string." | ||
| 1359 | `(defun ,name (&optional thread) | ||
| 1360 | ,(when doc doc) | ||
| 1361 | (interactive) | ||
| 1362 | (gdb-display-buffer | ||
| 1363 | (gdb-get-buffer-create ,buffer thread) t))) | ||
| 1364 | |||
| 1365 | ;; Used to display windows with thread-bound buffers | ||
| 1366 | (defmacro def-gdb-preempt-display-buffer (name buffer &optional doc | ||
| 1367 | split-horizontal) | ||
| 1368 | `(defun ,name (&optional thread) | ||
| 1369 | ,(when doc doc) | ||
| 1370 | (message thread) | ||
| 1371 | (gdb-preempt-existing-or-display-buffer | ||
| 1372 | (gdb-get-buffer-create ,buffer thread) | ||
| 1373 | ,split-horizontal))) | ||
| 1374 | |||
| 1375 | ;; This assoc maps buffer type symbols to rules. Each rule is a list of | ||
| 1376 | ;; at least one and possible more functions. The functions have these | ||
| 1377 | ;; roles in defining a buffer type: | ||
| 1378 | ;; | ||
| 1379 | ;; NAME - Return a name for this buffer type. | ||
| 1380 | ;; | ||
| 1381 | ;; The remaining function(s) are optional: | ||
| 1382 | ;; | ||
| 1383 | ;; MODE - called in a new buffer with no arguments, should establish | ||
| 1384 | ;; the proper mode for the buffer. | ||
| 1385 | ;; | ||
| 1386 | |||
| 1387 | (defun gdb-set-buffer-rules (buffer-type &rest rules) | ||
| 1388 | (let ((binding (assoc buffer-type gdb-buffer-rules))) | ||
| 1389 | (if binding | ||
| 1390 | (setcdr binding rules) | ||
| 1391 | (push (cons buffer-type rules) | ||
| 1392 | gdb-buffer-rules)))) | ||
| 1393 | |||
| 1394 | (defun gdb-parent-mode () | ||
| 1395 | "Generic mode to derive all other GDB buffer modes from." | ||
| 1396 | (kill-all-local-variables) | ||
| 1397 | (setq buffer-read-only t) | ||
| 1398 | (buffer-disable-undo) | ||
| 1399 | ;; Delete buffer from gdb-buf-publisher when it's killed | ||
| 1400 | ;; (if it has an associated update trigger) | ||
| 1401 | (add-hook | ||
| 1402 | 'kill-buffer-hook | ||
| 1403 | (function | ||
| 1404 | (lambda () | ||
| 1405 | (let ((trigger (gdb-rules-update-trigger | ||
| 1406 | (gdb-current-buffer-rules)))) | ||
| 1407 | (when trigger | ||
| 1408 | (gdb-delete-subscriber | ||
| 1409 | gdb-buf-publisher | ||
| 1410 | ;; This should match gdb-add-subscriber done in | ||
| 1411 | ;; gdb-get-buffer-create | ||
| 1412 | (cons (current-buffer) | ||
| 1413 | (gdb-bind-function-to-buffer trigger (current-buffer)))))))) | ||
| 1414 | nil t)) | ||
| 1415 | |||
| 1416 | ;; Partial-output buffer : This accumulates output from a command executed on | ||
| 1417 | ;; behalf of emacs (rather than the user). | ||
| 1418 | ;; | ||
| 1419 | (gdb-set-buffer-rules 'gdb-partial-output-buffer | ||
| 1420 | 'gdb-partial-output-name) | ||
| 1421 | |||
| 1422 | (defun gdb-partial-output-name () | ||
| 1423 | (concat " *partial-output-" | ||
| 1424 | (gdb-get-target-string) | ||
| 1425 | "*")) | ||
| 1426 | |||
| 1427 | |||
| 1428 | (gdb-set-buffer-rules 'gdb-inferior-io | ||
| 1429 | 'gdb-inferior-io-name | ||
| 1430 | 'gdb-inferior-io-mode) | ||
| 1431 | |||
| 1432 | (defun gdb-inferior-io-name () | ||
| 1433 | (concat "*input/output of " | ||
| 1434 | (gdb-get-target-string) | ||
| 1435 | "*")) | ||
| 1436 | |||
| 1437 | (defun gdb-display-io-buffer () | ||
| 1438 | "Display IO of debugged program in a separate window." | ||
| 1439 | (interactive) | ||
| 1440 | (gdb-display-buffer | ||
| 1441 | (gdb-get-buffer-create 'gdb-inferior-io) t)) | ||
| 1442 | |||
| 1443 | (defconst gdb-frame-parameters | ||
| 1444 | '((height . 14) (width . 80) | ||
| 1445 | (unsplittable . t) | ||
| 1446 | (tool-bar-lines . nil) | ||
| 1447 | (menu-bar-lines . nil) | ||
| 1448 | (minibuffer . nil))) | ||
| 1449 | |||
| 1450 | (defun gdb-frame-io-buffer () | ||
| 1451 | "Display IO of debugged program in a new frame." | ||
| 1452 | (interactive) | ||
| 1453 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 1454 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 1455 | (display-buffer (gdb-get-buffer-create 'gdb-inferior-io)))) | ||
| 1456 | |||
| 1457 | (defvar gdb-inferior-io-mode-map | ||
| 1458 | (let ((map (make-sparse-keymap))) | ||
| 1459 | (define-key map "\C-c\C-c" 'gdb-io-interrupt) | ||
| 1460 | (define-key map "\C-c\C-z" 'gdb-io-stop) | ||
| 1461 | (define-key map "\C-c\C-\\" 'gdb-io-quit) | ||
| 1462 | (define-key map "\C-c\C-d" 'gdb-io-eof) | ||
| 1463 | (define-key map "\C-d" 'gdb-io-eof) | ||
| 1464 | map)) | ||
| 1465 | |||
| 1466 | ;; We want to use comint because it has various nifty and familiar features. | ||
| 1467 | (define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O" | ||
| 1468 | "Major mode for gdb inferior-io. | ||
| 1469 | |||
| 1470 | The following commands are available: | ||
| 1471 | \\{gdb-inferior-io-mode-map}" | ||
| 1472 | |||
| 1473 | :syntax-table nil :abbrev-table nil | ||
| 1474 | |||
| 1475 | (make-comint-in-buffer "gdb-inferior" (current-buffer) nil)) | ||
| 1476 | |||
| 1477 | (defun gdb-inferior-filter (proc string) | ||
| 1478 | (unless (string-equal string "") | ||
| 1479 | (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t)) | ||
| 1480 | (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) | ||
| 1481 | (comint-output-filter proc string))) | ||
| 1482 | |||
| 1483 | (defun gdb-io-interrupt () | ||
| 1484 | "Interrupt the program being debugged." | ||
| 1485 | (interactive) | ||
| 1486 | (interrupt-process | ||
| 1487 | (get-buffer-process gud-comint-buffer) comint-ptyp)) | ||
| 1488 | |||
| 1489 | (defun gdb-io-quit () | ||
| 1490 | "Send quit signal to the program being debugged." | ||
| 1491 | (interactive) | ||
| 1492 | (quit-process | ||
| 1493 | (get-buffer-process gud-comint-buffer) comint-ptyp)) | ||
| 1494 | |||
| 1495 | (defun gdb-io-stop () | ||
| 1496 | "Stop the program being debugged." | ||
| 1497 | (interactive) | ||
| 1498 | (stop-process | ||
| 1499 | (get-buffer-process gud-comint-buffer) comint-ptyp)) | ||
| 1500 | |||
| 1501 | (defun gdb-io-eof () | ||
| 1502 | "Send end-of-file to the program being debugged." | ||
| 1503 | (interactive) | ||
| 1504 | (process-send-eof | ||
| 1505 | (get-buffer-process gud-comint-buffer))) | ||
| 1506 | |||
| 1507 | (defun gdb-clear-inferior-io () | ||
| 1508 | (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) | ||
| 1509 | (erase-buffer))) | ||
| 1510 | |||
| 1511 | |||
| 1512 | (defconst breakpoint-xpm-data | ||
| 1513 | "/* XPM */ | ||
| 1514 | static char *magick[] = { | ||
| 1515 | /* columns rows colors chars-per-pixel */ | ||
| 1516 | \"10 10 2 1\", | ||
| 1517 | \" c red\", | ||
| 1518 | \"+ c None\", | ||
| 1519 | /* pixels */ | ||
| 1520 | \"+++ +++\", | ||
| 1521 | \"++ ++\", | ||
| 1522 | \"+ +\", | ||
| 1523 | \" \", | ||
| 1524 | \" \", | ||
| 1525 | \" \", | ||
| 1526 | \" \", | ||
| 1527 | \"+ +\", | ||
| 1528 | \"++ ++\", | ||
| 1529 | \"+++ +++\", | ||
| 1530 | };" | ||
| 1531 | "XPM data used for breakpoint icon.") | ||
| 1532 | |||
| 1533 | (defconst breakpoint-enabled-pbm-data | ||
| 1534 | "P1 | ||
| 1535 | 10 10\", | ||
| 1536 | 0 0 0 0 1 1 1 1 0 0 0 0 | ||
| 1537 | 0 0 0 1 1 1 1 1 1 0 0 0 | ||
| 1538 | 0 0 1 1 1 1 1 1 1 1 0 0 | ||
| 1539 | 0 1 1 1 1 1 1 1 1 1 1 0 | ||
| 1540 | 0 1 1 1 1 1 1 1 1 1 1 0 | ||
| 1541 | 0 1 1 1 1 1 1 1 1 1 1 0 | ||
| 1542 | 0 1 1 1 1 1 1 1 1 1 1 0 | ||
| 1543 | 0 0 1 1 1 1 1 1 1 1 0 0 | ||
| 1544 | 0 0 0 1 1 1 1 1 1 0 0 0 | ||
| 1545 | 0 0 0 0 1 1 1 1 0 0 0 0" | ||
| 1546 | "PBM data used for enabled breakpoint icon.") | ||
| 1547 | |||
| 1548 | (defconst breakpoint-disabled-pbm-data | ||
| 1549 | "P1 | ||
| 1550 | 10 10\", | ||
| 1551 | 0 0 1 0 1 0 1 0 0 0 | ||
| 1552 | 0 1 0 1 0 1 0 1 0 0 | ||
| 1553 | 1 0 1 0 1 0 1 0 1 0 | ||
| 1554 | 0 1 0 1 0 1 0 1 0 1 | ||
| 1555 | 1 0 1 0 1 0 1 0 1 0 | ||
| 1556 | 0 1 0 1 0 1 0 1 0 1 | ||
| 1557 | 1 0 1 0 1 0 1 0 1 0 | ||
| 1558 | 0 1 0 1 0 1 0 1 0 1 | ||
| 1559 | 0 0 1 0 1 0 1 0 1 0 | ||
| 1560 | 0 0 0 1 0 1 0 1 0 0" | ||
| 1561 | "PBM data used for disabled breakpoint icon.") | ||
| 1562 | |||
| 1563 | (defvar breakpoint-enabled-icon nil | ||
| 1564 | "Icon for enabled breakpoint in display margin.") | ||
| 1565 | |||
| 1566 | (defvar breakpoint-disabled-icon nil | ||
| 1567 | "Icon for disabled breakpoint in display margin.") | ||
| 1568 | |||
| 1569 | (declare-function define-fringe-bitmap "fringe.c" | ||
| 1570 | (bitmap bits &optional height width align)) | ||
| 1571 | |||
| 1572 | (and (display-images-p) | ||
| 1573 | ;; Bitmap for breakpoint in fringe | ||
| 1574 | (define-fringe-bitmap 'breakpoint | ||
| 1575 | "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") | ||
| 1576 | ;; Bitmap for gud-overlay-arrow in fringe | ||
| 1577 | (define-fringe-bitmap 'hollow-right-triangle | ||
| 1578 | "\xe0\x90\x88\x84\x84\x88\x90\xe0")) | ||
| 1579 | |||
| 1580 | (defface breakpoint-enabled | ||
| 1581 | '((t | ||
| 1582 | :foreground "red1" | ||
| 1583 | :weight bold)) | ||
| 1584 | "Face for enabled breakpoint icon in fringe." | ||
| 1585 | :group 'gdb) | ||
| 1586 | |||
| 1587 | (defface breakpoint-disabled | ||
| 1588 | '((((class color) (min-colors 88)) :foreground "grey70") | ||
| 1589 | ;; Ensure that on low-color displays that we end up something visible. | ||
| 1590 | (((class color) (min-colors 8) (background light)) | ||
| 1591 | :foreground "black") | ||
| 1592 | (((class color) (min-colors 8) (background dark)) | ||
| 1593 | :foreground "white") | ||
| 1594 | (((type tty) (class mono)) | ||
| 1595 | :inverse-video t) | ||
| 1596 | (t :background "gray")) | ||
| 1597 | "Face for disabled breakpoint icon in fringe." | ||
| 1598 | :group 'gdb) | ||
| 1599 | |||
| 1600 | |||
| 1601 | (defun gdb-send (proc string) | ||
| 1602 | "A comint send filter for gdb." | ||
| 1603 | (with-current-buffer gud-comint-buffer | ||
| 1604 | (let ((inhibit-read-only t)) | ||
| 1605 | (remove-text-properties (point-min) (point-max) '(face)))) | ||
| 1606 | ;; mimic <RET> key to repeat previous command in GDB | ||
| 1607 | (if (not (string= "" string)) | ||
| 1608 | (setq gdb-last-command string) | ||
| 1609 | (if gdb-last-command (setq string gdb-last-command))) | ||
| 1610 | (if gdb-enable-debug | ||
| 1611 | (push (cons 'mi-send (concat string "\n")) gdb-debug-log)) | ||
| 1612 | (if (string-match "^-" string) | ||
| 1613 | ;; MI command | ||
| 1614 | (progn | ||
| 1615 | (setq gdb-first-done-or-error t) | ||
| 1616 | (process-send-string proc (concat string "\n"))) | ||
| 1617 | ;; CLI command | ||
| 1618 | (if (string-match "\\\\$" string) | ||
| 1619 | (setq gdb-continuation (concat gdb-continuation string "\n")) | ||
| 1620 | (setq gdb-first-done-or-error t) | ||
| 1621 | (process-send-string proc (concat "-interpreter-exec console \"" | ||
| 1622 | gdb-continuation string "\"\n")) | ||
| 1623 | (setq gdb-continuation nil)))) | ||
| 1624 | |||
| 1625 | (defun gdb-input (item) | ||
| 1626 | (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log)) | ||
| 1627 | (setq gdb-token-number (1+ gdb-token-number)) | ||
| 1628 | (setcar item (concat (number-to-string gdb-token-number) (car item))) | ||
| 1629 | (push (cons gdb-token-number (car (cdr item))) gdb-handler-alist) | ||
| 1630 | (process-send-string (get-buffer-process gud-comint-buffer) | ||
| 1631 | (concat (car item) "\n"))) | ||
| 1632 | |||
| 1633 | ;; NOFRAME is used for gud execution control commands | ||
| 1634 | (defun gdb-current-context-command (command) | ||
| 1635 | "Add --thread to gdb COMMAND when needed." | ||
| 1636 | (if (and gdb-thread-number | ||
| 1637 | (string-equal gdb-version "7.0+")) | ||
| 1638 | (concat command " --thread " gdb-thread-number) | ||
| 1639 | command)) | ||
| 1640 | |||
| 1641 | (defun gdb-current-context-buffer-name (name) | ||
| 1642 | "Add thread information and asterisks to string NAME. | ||
| 1643 | |||
| 1644 | If `gdb-thread-number' is nil, just wrap NAME in asterisks." | ||
| 1645 | (concat "*" name | ||
| 1646 | (if (local-variable-p 'gdb-thread-number) | ||
| 1647 | (format " (bound to thread %s)" gdb-thread-number) | ||
| 1648 | "") | ||
| 1649 | "*")) | ||
| 1650 | |||
| 1651 | (defun gdb-current-context-mode-name (mode) | ||
| 1652 | "Add thread information to MODE which is to be used as | ||
| 1653 | `mode-name'." | ||
| 1654 | (concat mode | ||
| 1655 | (if gdb-thread-number | ||
| 1656 | (format " [thread %s]" gdb-thread-number) | ||
| 1657 | ""))) | ||
| 1658 | |||
| 1659 | |||
| 1660 | (defcustom gud-gdb-command-name "gdb -i=mi" | ||
| 1661 | "Default command to execute an executable under the GDB debugger." | ||
| 1662 | :type 'string | ||
| 1663 | :group 'gdb) | ||
| 1664 | |||
| 1665 | (defun gdb-resync() | ||
| 1666 | (setq gud-running nil) | ||
| 1667 | (setq gdb-output-sink 'user) | ||
| 1668 | (setq gdb-pending-triggers nil)) | ||
| 1669 | |||
| 1670 | (defun gdb-update () | ||
| 1671 | "Update buffers showing status of debug session." | ||
| 1672 | (when gdb-first-prompt | ||
| 1673 | (gdb-force-mode-line-update | ||
| 1674 | (propertize "initializing..." 'face font-lock-variable-name-face)) | ||
| 1675 | (gdb-init-1) | ||
| 1676 | (setq gdb-first-prompt nil)) | ||
| 1677 | |||
| 1678 | (gdb-get-main-selected-frame) | ||
| 1679 | ;; We may need to update gdb-threads-list so we can use | ||
| 1680 | (gdb-get-buffer-create 'gdb-threads-buffer) | ||
| 1681 | ;; gdb-break-list is maintained in breakpoints handler | ||
| 1682 | (gdb-get-buffer-create 'gdb-breakpoints-buffer) | ||
| 1683 | |||
| 1684 | (gdb-emit-signal gdb-buf-publisher 'update) | ||
| 1685 | |||
| 1686 | (gdb-get-changed-registers) | ||
| 1687 | |||
| 1688 | (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) | ||
| 1689 | (dolist (var gdb-var-list) | ||
| 1690 | (setcar (nthcdr 5 var) nil)) | ||
| 1691 | (gdb-var-update))) | ||
| 1692 | |||
| 1693 | ;; gdb-setq-thread-number and gdb-update-gud-running are decoupled | ||
| 1694 | ;; because we may need to update current gud-running value without | ||
| 1695 | ;; changing current thread (see gdb-running) | ||
| 1696 | (defun gdb-setq-thread-number (number) | ||
| 1697 | "Only this function must be used to change `gdb-thread-number' | ||
| 1698 | value to NUMBER, because `gud-running' and `gdb-frame-number' | ||
| 1699 | need to be updated appropriately when current thread changes." | ||
| 1700 | ;; GDB 6.8 and earlier always output thread-id="0" when stopping. | ||
| 1701 | (unless (string-equal number "0") (setq gdb-thread-number number)) | ||
| 1702 | (setq gdb-frame-number "0") | ||
| 1703 | (gdb-update-gud-running)) | ||
| 1704 | |||
| 1705 | (defun gdb-update-gud-running () | ||
| 1706 | "Set `gud-running' according to the state of current thread. | ||
| 1707 | |||
| 1708 | `gdb-frame-number' is set to 0 if current thread is now stopped. | ||
| 1709 | |||
| 1710 | Note that when `gdb-gud-control-all-threads' is t, `gud-running' | ||
| 1711 | cannot be reliably used to determine whether or not execution | ||
| 1712 | control buttons should be shown in menu or toolbar. Use | ||
| 1713 | `gdb-running-threads-count' and `gdb-stopped-threads-count' | ||
| 1714 | instead. | ||
| 1715 | |||
| 1716 | For all-stop mode, thread information is unavailable while target | ||
| 1717 | is running." | ||
| 1718 | (let ((old-value gud-running)) | ||
| 1719 | (setq gud-running | ||
| 1720 | (string= (bindat-get-field (gdb-current-buffer-thread) 'state) | ||
| 1721 | "running")) | ||
| 1722 | ;; Set frame number to "0" when _current_ threads stops | ||
| 1723 | (when (and (gdb-current-buffer-thread) | ||
| 1724 | (not (eq gud-running old-value))) | ||
| 1725 | (setq gdb-frame-number "0")))) | ||
| 1726 | |||
| 1727 | (defun gdb-show-run-p () | ||
| 1728 | "Return t if \"Run/continue\" should be shown on the toolbar." | ||
| 1729 | (or (not gdb-active-process) | ||
| 1730 | (and (or | ||
| 1731 | (not gdb-gud-control-all-threads) | ||
| 1732 | (not gdb-non-stop)) | ||
| 1733 | (not gud-running)) | ||
| 1734 | (and gdb-gud-control-all-threads | ||
| 1735 | (> gdb-stopped-threads-count 0)))) | ||
| 1736 | |||
| 1737 | (defun gdb-show-stop-p () | ||
| 1738 | "Return t if \"Stop\" should be shown on the toolbar." | ||
| 1739 | (or (and (or | ||
| 1740 | (not gdb-gud-control-all-threads) | ||
| 1741 | (not gdb-non-stop)) | ||
| 1742 | gud-running) | ||
| 1743 | (and gdb-gud-control-all-threads | ||
| 1744 | (> gdb-running-threads-count 0)))) | ||
| 1745 | |||
| 1746 | ;; GUD displays the selected GDB frame. This might might not be the current | ||
| 1747 | ;; GDB frame (after up, down etc). If no GDB frame is visible but the last | ||
| 1748 | ;; visited breakpoint is, use that window. | ||
| 1749 | (defun gdb-display-source-buffer (buffer) | ||
| 1750 | (let* ((last-window (if gud-last-last-frame | ||
| 1751 | (get-buffer-window | ||
| 1752 | (gud-find-file (car gud-last-last-frame))))) | ||
| 1753 | (source-window (or last-window | ||
| 1754 | (if (and gdb-source-window | ||
| 1755 | (window-live-p gdb-source-window)) | ||
| 1756 | gdb-source-window)))) | ||
| 1757 | (when source-window | ||
| 1758 | (setq gdb-source-window source-window) | ||
| 1759 | (set-window-buffer source-window buffer)) | ||
| 1760 | source-window)) | ||
| 1761 | |||
| 1762 | (defun gdb-car< (a b) | ||
| 1763 | (< (car a) (car b))) | ||
| 1764 | |||
| 1765 | (defvar gdbmi-record-list | ||
| 1766 | '((gdb-gdb . "(gdb) \n") | ||
| 1767 | (gdb-done . "\\([0-9]*\\)\\^done,?\\(.*?\\)\n") | ||
| 1768 | (gdb-starting . "\\([0-9]*\\)\\^running\n") | ||
| 1769 | (gdb-error . "\\([0-9]*\\)\\^error,\\(.*?\\)\n") | ||
| 1770 | (gdb-console . "~\\(\".*?\"\\)\n") | ||
| 1771 | (gdb-internals . "&\\(\".*?\"\\)\n") | ||
| 1772 | (gdb-stopped . "\\*stopped,?\\(.*?\\)\n") | ||
| 1773 | (gdb-running . "\\*running,\\(.*?\n\\)") | ||
| 1774 | (gdb-thread-created . "=thread-created,\\(.*?\n\\)") | ||
| 1775 | (gdb-thread-selected . "=thread-selected,\\(.*?\\)\n") | ||
| 1776 | (gdb-thread-exited . "=thread-exited,\\(.*?\n\\)") | ||
| 1777 | (gdb-ignored-notification . "=[-[:alpha:]]+,?\\(.*?\\)\n") | ||
| 1778 | (gdb-shell . "\\(\\(?:^.+\n\\)+\\)"))) | ||
| 1779 | |||
| 1780 | (defun gud-gdbmi-marker-filter (string) | ||
| 1781 | "Filter GDB/MI output." | ||
| 1782 | |||
| 1783 | ;; Record transactions if logging is enabled. | ||
| 1784 | (when gdb-enable-debug | ||
| 1785 | (push (cons 'recv string) gdb-debug-log) | ||
| 1786 | (if (and gdb-debug-log-max | ||
| 1787 | (> (length gdb-debug-log) gdb-debug-log-max)) | ||
| 1788 | (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil))) | ||
| 1789 | |||
| 1790 | ;; Recall the left over gud-marker-acc from last time | ||
| 1791 | (setq gud-marker-acc (concat gud-marker-acc string)) | ||
| 1792 | |||
| 1793 | ;; Start accumulating output for the GUD buffer | ||
| 1794 | (setq gdb-filter-output "") | ||
| 1795 | (let ((output-record) (output-record-list)) | ||
| 1796 | |||
| 1797 | ;; Process all the complete markers in this chunk. | ||
| 1798 | (dolist (gdbmi-record gdbmi-record-list) | ||
| 1799 | (while (string-match (cdr gdbmi-record) gud-marker-acc) | ||
| 1800 | (push (list (match-beginning 0) | ||
| 1801 | (car gdbmi-record) | ||
| 1802 | (match-string 1 gud-marker-acc) | ||
| 1803 | (match-string 2 gud-marker-acc) | ||
| 1804 | (match-end 0)) | ||
| 1805 | output-record-list) | ||
| 1806 | (setq gud-marker-acc | ||
| 1807 | (concat (substring gud-marker-acc 0 (match-beginning 0)) | ||
| 1808 | ;; Pad with spaces to preserve position. | ||
| 1809 | (make-string (length (match-string 0 gud-marker-acc)) 32) | ||
| 1810 | (substring gud-marker-acc (match-end 0)))))) | ||
| 1811 | |||
| 1812 | (setq output-record-list (sort output-record-list 'gdb-car<)) | ||
| 1813 | |||
| 1814 | (dolist (output-record output-record-list) | ||
| 1815 | (let ((record-type (cadr output-record)) | ||
| 1816 | (arg1 (nth 2 output-record)) | ||
| 1817 | (arg2 (nth 3 output-record))) | ||
| 1818 | (if (eq record-type 'gdb-error) | ||
| 1819 | (gdb-done-or-error arg2 arg1 'error) | ||
| 1820 | (if (eq record-type 'gdb-done) | ||
| 1821 | (gdb-done-or-error arg2 arg1 'done) | ||
| 1822 | ;; Suppress "No registers." since GDB 6.8 and earlier duplicates MI | ||
| 1823 | ;; error message on internal stream. Don't print to GUD buffer. | ||
| 1824 | (unless (and (eq record-type 'gdb-internals) | ||
| 1825 | (string-equal (read arg1) "No registers.\n")) | ||
| 1826 | (funcall record-type arg1)))))) | ||
| 1827 | |||
| 1828 | (setq gdb-output-sink 'user) | ||
| 1829 | ;; Remove padding. | ||
| 1830 | (string-match "^ *" gud-marker-acc) | ||
| 1831 | (setq gud-marker-acc (substring gud-marker-acc (match-end 0))) | ||
| 1832 | |||
| 1833 | gdb-filter-output)) | ||
| 1834 | |||
| 1835 | (defun gdb-gdb (output-field)) | ||
| 1836 | |||
| 1837 | (defun gdb-shell (output-field) | ||
| 1838 | (let ((gdb-output-sink gdb-output-sink)) | ||
| 1839 | (setq gdb-filter-output | ||
| 1840 | (concat output-field gdb-filter-output)))) | ||
| 1841 | |||
| 1842 | (defun gdb-ignored-notification (output-field)) | ||
| 1843 | |||
| 1844 | ;; gdb-invalidate-threads is defined to accept 'update-threads signal | ||
| 1845 | (defun gdb-thread-created (output-field)) | ||
| 1846 | (defun gdb-thread-exited (output-field) | ||
| 1847 | "Handle =thread-exited async record: unset `gdb-thread-number' | ||
| 1848 | if current thread exited and update threads list." | ||
| 1849 | (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'id))) | ||
| 1850 | (if (string= gdb-thread-number thread-id) | ||
| 1851 | (gdb-setq-thread-number nil)) | ||
| 1852 | ;; When we continue current thread and it quickly exits, | ||
| 1853 | ;; gdb-pending-triggers left after gdb-running disallow us to | ||
| 1854 | ;; properly call -thread-info without --thread option. Thus we | ||
| 1855 | ;; need to use gdb-wait-for-pending. | ||
| 1856 | (gdb-wait-for-pending | ||
| 1857 | (gdb-emit-signal gdb-buf-publisher 'update-threads)))) | ||
| 1858 | |||
| 1859 | (defun gdb-thread-selected (output-field) | ||
| 1860 | "Handler for =thread-selected MI output record. | ||
| 1861 | |||
| 1862 | Sets `gdb-thread-number' to new id." | ||
| 1863 | (let* ((result (gdb-json-string output-field)) | ||
| 1864 | (thread-id (bindat-get-field result 'id))) | ||
| 1865 | (gdb-setq-thread-number thread-id) | ||
| 1866 | ;; Typing `thread N` in GUD buffer makes GDB emit `^done` followed | ||
| 1867 | ;; by `=thread-selected` notification. `^done` causes `gdb-update` | ||
| 1868 | ;; as usually. Things happen to fast and second call (from | ||
| 1869 | ;; gdb-thread-selected handler) gets cut off by our beloved | ||
| 1870 | ;; gdb-pending-triggers. | ||
| 1871 | ;; Solution is `gdb-wait-for-pending` macro: it guarantees that its | ||
| 1872 | ;; body will get executed when `gdb-pending-triggers` is empty. | ||
| 1873 | (gdb-wait-for-pending | ||
| 1874 | (gdb-update)))) | ||
| 1875 | |||
| 1876 | (defun gdb-running (output-field) | ||
| 1877 | (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'thread-id))) | ||
| 1878 | ;; We reset gdb-frame-number to nil if current thread has gone | ||
| 1879 | ;; running. This can't be done in gdb-thread-list-handler-custom | ||
| 1880 | ;; because we need correct gdb-frame-number by the time | ||
| 1881 | ;; -thread-info command is sent. | ||
| 1882 | (when (or (string-equal thread-id "all") | ||
| 1883 | (string-equal thread-id gdb-thread-number)) | ||
| 1884 | (setq gdb-frame-number nil))) | ||
| 1885 | (setq gdb-inferior-status "running") | ||
| 1886 | (gdb-force-mode-line-update | ||
| 1887 | (propertize gdb-inferior-status 'face font-lock-type-face)) | ||
| 1888 | (when (not gdb-non-stop) | ||
| 1889 | (setq gud-running t)) | ||
| 1890 | (setq gdb-active-process t) | ||
| 1891 | (gdb-emit-signal gdb-buf-publisher 'update-threads)) | ||
| 1892 | |||
| 1893 | (defun gdb-starting (output-field) | ||
| 1894 | ;; CLI commands don't emit ^running at the moment so use gdb-running too. | ||
| 1895 | (setq gdb-inferior-status "running") | ||
| 1896 | (gdb-force-mode-line-update | ||
| 1897 | (propertize gdb-inferior-status 'face font-lock-type-face)) | ||
| 1898 | (setq gdb-active-process t) | ||
| 1899 | (setq gud-running t) | ||
| 1900 | ;; GDB doesn't seem to respond to -thread-info before first stop or | ||
| 1901 | ;; thread exit (even in non-stop mode), so this is useless. | ||
| 1902 | ;; Behaviour may change in the future. | ||
| 1903 | (gdb-emit-signal gdb-buf-publisher 'update-threads)) | ||
| 1904 | |||
| 1905 | ;; -break-insert -t didn't give a reason before gdb 6.9 | ||
| 1906 | |||
| 1907 | (defun gdb-stopped (output-field) | ||
| 1908 | "Given the contents of *stopped MI async record, select new | ||
| 1909 | current thread and update GDB buffers." | ||
| 1910 | ;; Reason is available with target-async only | ||
| 1911 | (let* ((result (gdb-json-string output-field)) | ||
| 1912 | (reason (bindat-get-field result 'reason)) | ||
| 1913 | (thread-id (bindat-get-field result 'thread-id))) | ||
| 1914 | |||
| 1915 | ;; -data-list-register-names needs to be issued for any stopped | ||
| 1916 | ;; thread | ||
| 1917 | (when (not gdb-register-names) | ||
| 1918 | (gdb-input | ||
| 1919 | (list (concat "-data-list-register-names" | ||
| 1920 | (if (string-equal gdb-version "7.0+") | ||
| 1921 | (concat" --thread " thread-id))) | ||
| 1922 | 'gdb-register-names-handler))) | ||
| 1923 | |||
| 1924 | ;;; Don't set gud-last-frame here as it's currently done in gdb-frame-handler | ||
| 1925 | ;;; because synchronous GDB doesn't give these fields with CLI. | ||
| 1926 | ;;; (when file | ||
| 1927 | ;;; (setq | ||
| 1928 | ;;; ;; Extract the frame position from the marker. | ||
| 1929 | ;;; gud-last-frame (cons file | ||
| 1930 | ;;; (string-to-number | ||
| 1931 | ;;; (match-string 6 gud-marker-acc))))) | ||
| 1932 | |||
| 1933 | (setq gdb-inferior-status (or reason "unknown")) | ||
| 1934 | (gdb-force-mode-line-update | ||
| 1935 | (propertize gdb-inferior-status 'face font-lock-warning-face)) | ||
| 1936 | (if (string-equal reason "exited-normally") | ||
| 1937 | (setq gdb-active-process nil)) | ||
| 1938 | |||
| 1939 | ;; Select new current thread. | ||
| 1940 | |||
| 1941 | ;; Don't switch if we have no reasons selected | ||
| 1942 | (when gdb-switch-reasons | ||
| 1943 | ;; Switch from another stopped thread only if we have | ||
| 1944 | ;; gdb-switch-when-another-stopped: | ||
| 1945 | (when (or gdb-switch-when-another-stopped | ||
| 1946 | (not (string= "stopped" | ||
| 1947 | (bindat-get-field (gdb-current-buffer-thread) 'state)))) | ||
| 1948 | ;; Switch if current reason has been selected or we have no | ||
| 1949 | ;; reasons | ||
| 1950 | (if (or (eq gdb-switch-reasons t) | ||
| 1951 | (member reason gdb-switch-reasons)) | ||
| 1952 | (when (not (string-equal gdb-thread-number thread-id)) | ||
| 1953 | (message (concat "Switched to thread " thread-id)) | ||
| 1954 | (gdb-setq-thread-number thread-id)) | ||
| 1955 | (message (format "Thread %s stopped" thread-id))))) | ||
| 1956 | |||
| 1957 | ;; Print "(gdb)" to GUD console | ||
| 1958 | (when gdb-first-done-or-error | ||
| 1959 | (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) | ||
| 1960 | |||
| 1961 | ;; In non-stop, we update information as soon as another thread gets | ||
| 1962 | ;; stopped | ||
| 1963 | (when (or gdb-first-done-or-error | ||
| 1964 | gdb-non-stop) | ||
| 1965 | ;; In all-stop this updates gud-running properly as well. | ||
| 1966 | (gdb-update) | ||
| 1967 | (setq gdb-first-done-or-error nil)) | ||
| 1968 | (run-hook-with-args 'gdb-stopped-hooks result))) | ||
| 1969 | |||
| 1970 | ;; Remove the trimmings from log stream containing debugging messages | ||
| 1971 | ;; being produced by GDB's internals, use warning face and send to GUD | ||
| 1972 | ;; buffer. | ||
| 1973 | (defun gdb-internals (output-field) | ||
| 1974 | (setq gdb-filter-output | ||
| 1975 | (gdb-concat-output | ||
| 1976 | gdb-filter-output | ||
| 1977 | (let ((error-message | ||
| 1978 | (read output-field))) | ||
| 1979 | (put-text-property | ||
| 1980 | 0 (length error-message) | ||
| 1981 | 'face font-lock-warning-face | ||
| 1982 | error-message) | ||
| 1983 | error-message)))) | ||
| 1984 | |||
| 1985 | ;; Remove the trimmings from the console stream and send to GUD buffer | ||
| 1986 | ;; (frontend MI commands should not print to this stream) | ||
| 1987 | (defun gdb-console (output-field) | ||
| 1988 | (setq gdb-filter-output | ||
| 1989 | (gdb-concat-output | ||
| 1990 | gdb-filter-output | ||
| 1991 | (read output-field)))) | ||
| 1992 | |||
| 1993 | (defun gdb-done-or-error (output-field token-number type) | ||
| 1994 | (if (string-equal token-number "") | ||
| 1995 | ;; Output from command entered by user | ||
| 1996 | (progn | ||
| 1997 | (setq gdb-output-sink 'user) | ||
| 1998 | (setq token-number nil) | ||
| 1999 | ;; MI error - send to minibuffer | ||
| 2000 | (when (eq type 'error) | ||
| 2001 | ;; Skip "msg=" from `output-field' | ||
| 2002 | (message (read (substring output-field 4))) | ||
| 2003 | ;; Don't send to the console twice. (If it is a console error | ||
| 2004 | ;; it is also in the console stream.) | ||
| 2005 | (setq output-field nil))) | ||
| 2006 | ;; Output from command from frontend. | ||
| 2007 | (setq gdb-output-sink 'emacs)) | ||
| 2008 | |||
| 2009 | (gdb-clear-partial-output) | ||
| 2010 | (when gdb-first-done-or-error | ||
| 2011 | (unless (or token-number gud-running) | ||
| 2012 | (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) | ||
| 2013 | (gdb-update) | ||
| 2014 | (setq gdb-first-done-or-error nil)) | ||
| 2015 | |||
| 2016 | (setq gdb-filter-output | ||
| 2017 | (gdb-concat-output gdb-filter-output output-field)) | ||
| 2018 | |||
| 2019 | (if token-number | ||
| 2020 | (progn | ||
| 2021 | (with-current-buffer | ||
| 2022 | (gdb-get-buffer-create 'gdb-partial-output-buffer) | ||
| 2023 | (funcall | ||
| 2024 | (cdr (assoc (string-to-number token-number) gdb-handler-alist)))) | ||
| 2025 | (setq gdb-handler-alist | ||
| 2026 | (assq-delete-all token-number gdb-handler-alist))))) | ||
| 2027 | |||
| 2028 | (defun gdb-concat-output (so-far new) | ||
| 2029 | (let ((sink gdb-output-sink)) | ||
| 2030 | (cond | ||
| 2031 | ((eq sink 'user) (concat so-far new)) | ||
| 2032 | ((eq sink 'emacs) | ||
| 2033 | (gdb-append-to-partial-output new) | ||
| 2034 | so-far)))) | ||
| 2035 | |||
| 2036 | (defun gdb-append-to-partial-output (string) | ||
| 2037 | (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) | ||
| 2038 | (goto-char (point-max)) | ||
| 2039 | (insert string))) | ||
| 2040 | |||
| 2041 | (defun gdb-clear-partial-output () | ||
| 2042 | (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) | ||
| 2043 | (erase-buffer))) | ||
| 2044 | |||
| 2045 | (defun gdb-jsonify-buffer (&optional fix-key fix-list) | ||
| 2046 | "Prepare GDB/MI output in current buffer for parsing with `json-read'. | ||
| 2047 | |||
| 2048 | Field names are wrapped in double quotes and equal signs are | ||
| 2049 | replaced with semicolons. | ||
| 2050 | |||
| 2051 | If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurences from | ||
| 2052 | partial output. This is used to get rid of useless keys in lists | ||
| 2053 | in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and | ||
| 2054 | -break-info are examples of MI commands which issue such | ||
| 2055 | responses. | ||
| 2056 | |||
| 2057 | If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with | ||
| 2058 | \"FIX-LIST=[..]\" prior to parsing. This is used to fix broken | ||
| 2059 | -break-info output when it contains breakpoint script field | ||
| 2060 | incompatible with GDB/MI output syntax." | ||
| 2061 | (save-excursion | ||
| 2062 | (goto-char (point-min)) | ||
| 2063 | (when fix-key | ||
| 2064 | (save-excursion | ||
| 2065 | (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t) | ||
| 2066 | (replace-match "" nil nil nil 1)))) | ||
| 2067 | (when fix-list | ||
| 2068 | (save-excursion | ||
| 2069 | ;; Find positions of braces which enclose broken list | ||
| 2070 | (while (re-search-forward (concat fix-list "={\"") nil t) | ||
| 2071 | (let ((p1 (goto-char (- (point) 2))) | ||
| 2072 | (p2 (progn (forward-sexp) | ||
| 2073 | (1- (point))))) | ||
| 2074 | ;; Replace braces with brackets | ||
| 2075 | (save-excursion | ||
| 2076 | (goto-char p1) | ||
| 2077 | (delete-char 1) | ||
| 2078 | (insert "[") | ||
| 2079 | (goto-char p2) | ||
| 2080 | (delete-char 1) | ||
| 2081 | (insert "]")))))) | ||
| 2082 | (goto-char (point-min)) | ||
| 2083 | (insert "{") | ||
| 2084 | (while (re-search-forward | ||
| 2085 | "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t) | ||
| 2086 | (replace-match "\"\\1\":\\2" nil nil)) | ||
| 2087 | (goto-char (point-max)) | ||
| 2088 | (insert "}"))) | ||
| 2089 | |||
| 2090 | (defun gdb-json-read-buffer (&optional fix-key fix-list) | ||
| 2091 | "Prepare and parse GDB/MI output in current buffer with `json-read'. | ||
| 2092 | |||
| 2093 | FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." | ||
| 2094 | (gdb-jsonify-buffer fix-key fix-list) | ||
| 2095 | (save-excursion | ||
| 2096 | (goto-char (point-min)) | ||
| 2097 | (let ((json-array-type 'list)) | ||
| 2098 | (json-read)))) | ||
| 2099 | |||
| 2100 | (defun gdb-json-string (string &optional fix-key fix-list) | ||
| 2101 | "Prepare and parse STRING containing GDB/MI output with `json-read'. | ||
| 2102 | |||
| 2103 | FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." | ||
| 2104 | (with-temp-buffer | ||
| 2105 | (insert string) | ||
| 2106 | (gdb-json-read-buffer fix-key fix-list))) | ||
| 2107 | |||
| 2108 | (defun gdb-json-partial-output (&optional fix-key fix-list) | ||
| 2109 | "Prepare and parse gdb-partial-output-buffer with `json-read'. | ||
| 2110 | |||
| 2111 | FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'." | ||
| 2112 | (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) | ||
| 2113 | (gdb-json-read-buffer fix-key fix-list))) | ||
| 2114 | |||
| 2115 | (defun gdb-line-posns (line) | ||
| 2116 | "Return a pair of LINE beginning and end positions." | ||
| 2117 | (let ((offset (1+ (- line (line-number-at-pos))))) | ||
| 2118 | (cons | ||
| 2119 | (line-beginning-position offset) | ||
| 2120 | (line-end-position offset)))) | ||
| 2121 | |||
| 2122 | (defmacro gdb-mark-line (line variable) | ||
| 2123 | "Set VARIABLE marker to point at beginning of LINE. | ||
| 2124 | |||
| 2125 | If current window has no fringes, inverse colors on LINE. | ||
| 2126 | |||
| 2127 | Return position where LINE begins." | ||
| 2128 | `(save-excursion | ||
| 2129 | (let* ((posns (gdb-line-posns ,line)) | ||
| 2130 | (start-posn (car posns)) | ||
| 2131 | (end-posn (cdr posns))) | ||
| 2132 | (set-marker ,variable (copy-marker start-posn)) | ||
| 2133 | (when (not (> (car (window-fringes)) 0)) | ||
| 2134 | (put-text-property start-posn end-posn | ||
| 2135 | 'font-lock-face '(:inverse-video t))) | ||
| 2136 | start-posn))) | ||
| 2137 | |||
| 2138 | (defun gdb-pad-string (string padding) | ||
| 2139 | (format (concat "%" (number-to-string padding) "s") string)) | ||
| 2140 | |||
| 2141 | ;; gdb-table struct is a way to programmatically construct simple | ||
| 2142 | ;; tables. It help to reliably align columns of data in GDB buffers | ||
| 2143 | ;; and provides | ||
| 2144 | (defstruct | ||
| 2145 | gdb-table | ||
| 2146 | (column-sizes nil) | ||
| 2147 | (rows nil) | ||
| 2148 | (row-properties nil) | ||
| 2149 | (right-align nil)) | ||
| 2150 | |||
| 2151 | (defun gdb-mapcar* (function &rest seqs) | ||
| 2152 | "Apply FUNCTION to each element of SEQS, and make a list of the results. | ||
| 2153 | If there are several SEQS, FUNCTION is called with that many | ||
| 2154 | arugments, and mapping stops as sson as the shortest list runs | ||
| 2155 | out." | ||
| 2156 | (let ((shortest (apply #'min (mapcar #'length seqs)))) | ||
| 2157 | (mapcar (lambda (i) | ||
| 2158 | (apply function | ||
| 2159 | (mapcar | ||
| 2160 | (lambda (seq) | ||
| 2161 | (nth i seq)) | ||
| 2162 | seqs))) | ||
| 2163 | (number-sequence 0 (1- shortest))))) | ||
| 2164 | |||
| 2165 | (defun gdb-table-add-row (table row &optional properties) | ||
| 2166 | "Add ROW of string to TABLE and recalculate column sizes. | ||
| 2167 | |||
| 2168 | When non-nil, PROPERTIES will be added to the whole row when | ||
| 2169 | calling `gdb-table-string'." | ||
| 2170 | (let ((rows (gdb-table-rows table)) | ||
| 2171 | (row-properties (gdb-table-row-properties table)) | ||
| 2172 | (column-sizes (gdb-table-column-sizes table)) | ||
| 2173 | (right-align (gdb-table-right-align table))) | ||
| 2174 | (when (not column-sizes) | ||
| 2175 | (setf (gdb-table-column-sizes table) | ||
| 2176 | (make-list (length row) 0))) | ||
| 2177 | (setf (gdb-table-rows table) | ||
| 2178 | (append rows (list row))) | ||
| 2179 | (setf (gdb-table-row-properties table) | ||
| 2180 | (append row-properties (list properties))) | ||
| 2181 | (setf (gdb-table-column-sizes table) | ||
| 2182 | (gdb-mapcar* (lambda (x s) | ||
| 2183 | (let ((new-x | ||
| 2184 | (max (abs x) (string-width (or s ""))))) | ||
| 2185 | (if right-align new-x (- new-x)))) | ||
| 2186 | (gdb-table-column-sizes table) | ||
| 2187 | row)) | ||
| 2188 | ;; Avoid trailing whitespace at eol | ||
| 2189 | (if (not (gdb-table-right-align table)) | ||
| 2190 | (setcar (last (gdb-table-column-sizes table)) 0)))) | ||
| 2191 | |||
| 2192 | (defun gdb-table-string (table &optional sep) | ||
| 2193 | "Return TABLE as a string with columns separated with SEP." | ||
| 2194 | (let ((column-sizes (gdb-table-column-sizes table)) | ||
| 2195 | (res "")) | ||
| 2196 | (mapconcat | ||
| 2197 | 'identity | ||
| 2198 | (gdb-mapcar* | ||
| 2199 | (lambda (row properties) | ||
| 2200 | (apply 'propertize | ||
| 2201 | (mapconcat 'identity | ||
| 2202 | (gdb-mapcar* (lambda (s x) (gdb-pad-string s x)) | ||
| 2203 | row column-sizes) | ||
| 2204 | sep) | ||
| 2205 | properties)) | ||
| 2206 | (gdb-table-rows table) | ||
| 2207 | (gdb-table-row-properties table)) | ||
| 2208 | "\n"))) | ||
| 2209 | |||
| 2210 | ;; bindat-get-field goes deep, gdb-get-many-fields goes wide | ||
| 2211 | (defun gdb-get-many-fields (struct &rest fields) | ||
| 2212 | "Return a list of FIELDS values from STRUCT." | ||
| 2213 | (let ((values)) | ||
| 2214 | (dolist (field fields values) | ||
| 2215 | (setq values (append values (list (bindat-get-field struct field))))))) | ||
| 2216 | |||
| 2217 | (defmacro def-gdb-auto-update-trigger (trigger-name gdb-command | ||
| 2218 | handler-name | ||
| 2219 | &optional signal-list) | ||
| 2220 | "Define a trigger TRIGGER-NAME which sends GDB-COMMAND and sets | ||
| 2221 | HANDLER-NAME as its handler. HANDLER-NAME is bound to current | ||
| 2222 | buffer with `gdb-bind-function-to-buffer'. | ||
| 2223 | |||
| 2224 | If SIGNAL-LIST is non-nil, GDB-COMMAND is sent only when the | ||
| 2225 | defined trigger is called with an argument from SIGNAL-LIST. It's | ||
| 2226 | not recommended to define triggers with empty SIGNAL-LIST. | ||
| 2227 | Normally triggers should respond at least to 'update signal. | ||
| 2228 | |||
| 2229 | Normally the trigger defined by this command must be called from | ||
| 2230 | the buffer where HANDLER-NAME must work. This should be done so | ||
| 2231 | that buffer-local thread number may be used in GDB-COMMAND (by | ||
| 2232 | calling `gdb-current-context-command'). | ||
| 2233 | `gdb-bind-function-to-buffer' is used to achieve this, see | ||
| 2234 | `gdb-get-buffer-create'. | ||
| 2235 | |||
| 2236 | Triggers defined by this command are meant to be used as a | ||
| 2237 | trigger argument when describing buffer types with | ||
| 2238 | `gdb-set-buffer-rules'." | ||
| 2239 | `(defun ,trigger-name (&optional signal) | ||
| 2240 | (when | ||
| 2241 | (or (not ,signal-list) | ||
| 2242 | (memq signal ,signal-list)) | ||
| 2243 | (when (not (gdb-pending-p | ||
| 2244 | (cons (current-buffer) ',trigger-name))) | ||
| 2245 | (gdb-input | ||
| 2246 | (list ,gdb-command | ||
| 2247 | (gdb-bind-function-to-buffer ',handler-name (current-buffer)))) | ||
| 2248 | (gdb-add-pending (cons (current-buffer) ',trigger-name)))))) | ||
| 2249 | |||
| 2250 | ;; Used by disassembly buffer only, the rest use | ||
| 2251 | ;; def-gdb-trigger-and-handler | ||
| 2252 | (defmacro def-gdb-auto-update-handler (handler-name trigger-name custom-defun | ||
| 2253 | &optional nopreserve) | ||
| 2254 | "Define a handler HANDLER-NAME for TRIGGER-NAME with CUSTOM-DEFUN. | ||
| 2255 | |||
| 2256 | Handlers are normally called from the buffers they put output in. | ||
| 2257 | |||
| 2258 | Delete ((current-buffer) . TRIGGER-NAME) from | ||
| 2259 | `gdb-pending-triggers', erase current buffer and evaluate | ||
| 2260 | CUSTOM-DEFUN. Then `gdb-update-buffer-name' is called. | ||
| 2261 | |||
| 2262 | If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN." | ||
| 2263 | `(defun ,handler-name () | ||
| 2264 | (gdb-delete-pending (cons (current-buffer) ',trigger-name)) | ||
| 2265 | (let* ((buffer-read-only nil) | ||
| 2266 | (window (get-buffer-window (current-buffer) 0)) | ||
| 2267 | (start (window-start window)) | ||
| 2268 | (p (window-point window))) | ||
| 2269 | (erase-buffer) | ||
| 2270 | (,custom-defun) | ||
| 2271 | (gdb-update-buffer-name) | ||
| 2272 | ,(when (not nopreserve) | ||
| 2273 | '(set-window-start window start) | ||
| 2274 | '(set-window-point window p))))) | ||
| 2275 | |||
| 2276 | (defmacro def-gdb-trigger-and-handler (trigger-name gdb-command | ||
| 2277 | handler-name custom-defun | ||
| 2278 | &optional signal-list) | ||
| 2279 | "Define trigger and handler. | ||
| 2280 | |||
| 2281 | TRIGGER-NAME trigger is defined to send GDB-COMMAND. See | ||
| 2282 | `def-gdb-auto-update-trigger'. | ||
| 2283 | |||
| 2284 | HANDLER-NAME handler uses customization of CUSTOM-DEFUN. See | ||
| 2285 | `def-gdb-auto-update-handler'." | ||
| 2286 | `(progn | ||
| 2287 | (def-gdb-auto-update-trigger ,trigger-name | ||
| 2288 | ,gdb-command | ||
| 2289 | ,handler-name ,signal-list) | ||
| 2290 | (def-gdb-auto-update-handler ,handler-name | ||
| 2291 | ,trigger-name ,custom-defun))) | ||
| 2292 | |||
| 2293 | |||
| 2294 | |||
| 2295 | ;; Breakpoint buffer : This displays the output of `-break-list'. | ||
| 2296 | (def-gdb-trigger-and-handler | ||
| 2297 | gdb-invalidate-breakpoints "-break-list" | ||
| 2298 | gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom | ||
| 2299 | '(start update)) | ||
| 2300 | |||
| 2301 | (gdb-set-buffer-rules | ||
| 2302 | 'gdb-breakpoints-buffer | ||
| 2303 | 'gdb-breakpoints-buffer-name | ||
| 2304 | 'gdb-breakpoints-mode | ||
| 2305 | 'gdb-invalidate-breakpoints) | ||
| 2306 | |||
| 2307 | (defun gdb-breakpoints-list-handler-custom () | ||
| 2308 | (let ((breakpoints-list (bindat-get-field | ||
| 2309 | (gdb-json-partial-output "bkpt" "script") | ||
| 2310 | 'BreakpointTable 'body)) | ||
| 2311 | (table (make-gdb-table))) | ||
| 2312 | (setq gdb-breakpoints-list nil) | ||
| 2313 | (gdb-table-add-row table '("Num" "Type" "Disp" "Enb" "Addr" "Hits" "What")) | ||
| 2314 | (dolist (breakpoint breakpoints-list) | ||
| 2315 | (add-to-list 'gdb-breakpoints-list | ||
| 2316 | (cons (bindat-get-field breakpoint 'number) | ||
| 2317 | breakpoint)) | ||
| 2318 | (let ((at (bindat-get-field breakpoint 'at)) | ||
| 2319 | (pending (bindat-get-field breakpoint 'pending)) | ||
| 2320 | (func (bindat-get-field breakpoint 'func)) | ||
| 2321 | (type (bindat-get-field breakpoint 'type))) | ||
| 2322 | (gdb-table-add-row table | ||
| 2323 | (list | ||
| 2324 | (bindat-get-field breakpoint 'number) | ||
| 2325 | type | ||
| 2326 | (bindat-get-field breakpoint 'disp) | ||
| 2327 | (let ((flag (bindat-get-field breakpoint 'enabled))) | ||
| 2328 | (if (string-equal flag "y") | ||
| 2329 | (propertize "y" 'font-lock-face font-lock-warning-face) | ||
| 2330 | (propertize "n" 'font-lock-face font-lock-comment-face))) | ||
| 2331 | (bindat-get-field breakpoint 'addr) | ||
| 2332 | (bindat-get-field breakpoint 'times) | ||
| 2333 | (if (string-match ".*watchpoint" type) | ||
| 2334 | (bindat-get-field breakpoint 'what) | ||
| 2335 | (or pending at | ||
| 2336 | (concat "in " | ||
| 2337 | (propertize func 'font-lock-face font-lock-function-name-face) | ||
| 2338 | (gdb-frame-location breakpoint))))) | ||
| 2339 | ;; Add clickable properties only for breakpoints with file:line | ||
| 2340 | ;; information | ||
| 2341 | (append (list 'gdb-breakpoint breakpoint) | ||
| 2342 | (when func '(help-echo "mouse-2, RET: visit breakpoint" | ||
| 2343 | mouse-face highlight)))))) | ||
| 2344 | (insert (gdb-table-string table " ")) | ||
| 2345 | (gdb-place-breakpoints))) | ||
| 2346 | |||
| 2347 | ;; Put breakpoint icons in relevant margins (even those set in the GUD buffer). | ||
| 2348 | (defun gdb-place-breakpoints () | ||
| 2349 | (let ((flag) (bptno)) | ||
| 2350 | ;; Remove all breakpoint-icons in source buffers but not assembler buffer. | ||
| 2351 | (dolist (buffer (buffer-list)) | ||
| 2352 | (with-current-buffer buffer | ||
| 2353 | (if (and (eq gud-minor-mode 'gdbmi) | ||
| 2354 | (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name)))) | ||
| 2355 | (gdb-remove-breakpoint-icons (point-min) (point-max))))) | ||
| 2356 | (dolist (breakpoint gdb-breakpoints-list) | ||
| 2357 | (let* ((breakpoint (cdr breakpoint)) ; gdb-breakpoints-list is | ||
| 2358 | ; an associative list | ||
| 2359 | (line (bindat-get-field breakpoint 'line))) | ||
| 2360 | (when line | ||
| 2361 | (let ((file (bindat-get-field breakpoint 'fullname)) | ||
| 2362 | (flag (bindat-get-field breakpoint 'enabled)) | ||
| 2363 | (bptno (bindat-get-field breakpoint 'number))) | ||
| 2364 | (unless (file-exists-p file) | ||
| 2365 | (setq file (cdr (assoc bptno gdb-location-alist)))) | ||
| 2366 | (if (and file | ||
| 2367 | (not (string-equal file "File not found"))) | ||
| 2368 | (with-current-buffer | ||
| 2369 | (find-file-noselect file 'nowarn) | ||
| 2370 | (gdb-init-buffer) | ||
| 2371 | ;; Only want one breakpoint icon at each location. | ||
| 2372 | (gdb-put-breakpoint-icon (string-equal flag "y") bptno | ||
| 2373 | (string-to-number line))) | ||
| 2374 | (gdb-input | ||
| 2375 | (list (concat "list " file ":1") | ||
| 2376 | 'ignore)) | ||
| 2377 | (gdb-input | ||
| 2378 | (list "-file-list-exec-source-file" | ||
| 2379 | `(lambda () (gdb-get-location | ||
| 2380 | ,bptno ,line ,flag))))))))))) | ||
| 2381 | |||
| 2382 | (defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"") | ||
| 2383 | |||
| 2384 | (defun gdb-get-location (bptno line flag) | ||
| 2385 | "Find the directory containing the relevant source file. | ||
| 2386 | Put in buffer and place breakpoint icon." | ||
| 2387 | (goto-char (point-min)) | ||
| 2388 | (catch 'file-not-found | ||
| 2389 | (if (re-search-forward gdb-source-file-regexp nil t) | ||
| 2390 | (delete (cons bptno "File not found") gdb-location-alist) | ||
| 2391 | (push (cons bptno (match-string 1)) gdb-location-alist) | ||
| 2392 | (gdb-resync) | ||
| 2393 | (unless (assoc bptno gdb-location-alist) | ||
| 2394 | (push (cons bptno "File not found") gdb-location-alist) | ||
| 2395 | (message-box "Cannot find source file for breakpoint location. | ||
| 2396 | Add directory to search path for source files using the GDB command, dir.")) | ||
| 2397 | (throw 'file-not-found nil)) | ||
| 2398 | (with-current-buffer (find-file-noselect (match-string 1)) | ||
| 2399 | (gdb-init-buffer) | ||
| 2400 | ;; only want one breakpoint icon at each location | ||
| 2401 | (gdb-put-breakpoint-icon (eq flag ?y) bptno (string-to-number line))))) | ||
| 2402 | |||
| 2403 | (add-hook 'find-file-hook 'gdb-find-file-hook) | ||
| 2404 | |||
| 2405 | (defun gdb-find-file-hook () | ||
| 2406 | "Set up buffer for debugging if file is part of the source code | ||
| 2407 | of the current session." | ||
| 2408 | (if (and (buffer-name gud-comint-buffer) | ||
| 2409 | ;; in case gud or gdb-ui is just loaded | ||
| 2410 | gud-comint-buffer | ||
| 2411 | (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | ||
| 2412 | 'gdbmi)) | ||
| 2413 | (if (member buffer-file-name gdb-source-file-list) | ||
| 2414 | (with-current-buffer (find-buffer-visiting buffer-file-name) | ||
| 2415 | (gdb-init-buffer))))) | ||
| 2416 | |||
| 2417 | (declare-function gud-remove "gdb-mi" t t) ; gud-def | ||
| 2418 | (declare-function gud-break "gdb-mi" t t) ; gud-def | ||
| 2419 | (declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window)) | ||
| 2420 | |||
| 2421 | (defun gdb-mouse-set-clear-breakpoint (event) | ||
| 2422 | "Set/clear breakpoint in left fringe/margin at mouse click. | ||
| 2423 | If not in a source or disassembly buffer just set point." | ||
| 2424 | (interactive "e") | ||
| 2425 | (mouse-minibuffer-check event) | ||
| 2426 | (let ((posn (event-end event))) | ||
| 2427 | (with-selected-window (posn-window posn) | ||
| 2428 | (if (or (buffer-file-name) (eq major-mode 'gdb-disassembly-mode)) | ||
| 2429 | (if (numberp (posn-point posn)) | ||
| 2430 | (save-excursion | ||
| 2431 | (goto-char (posn-point posn)) | ||
| 2432 | (if (or (posn-object posn) | ||
| 2433 | (eq (car (fringe-bitmaps-at-pos (posn-point posn))) | ||
| 2434 | 'breakpoint)) | ||
| 2435 | (gud-remove nil) | ||
| 2436 | (gud-break nil))))) | ||
| 2437 | (posn-set-point posn)))) | ||
| 2438 | |||
| 2439 | (defun gdb-mouse-toggle-breakpoint-margin (event) | ||
| 2440 | "Enable/disable breakpoint in left margin with mouse click." | ||
| 2441 | (interactive "e") | ||
| 2442 | (mouse-minibuffer-check event) | ||
| 2443 | (let ((posn (event-end event))) | ||
| 2444 | (if (numberp (posn-point posn)) | ||
| 2445 | (with-selected-window (posn-window posn) | ||
| 2446 | (save-excursion | ||
| 2447 | (goto-char (posn-point posn)) | ||
| 2448 | (if (posn-object posn) | ||
| 2449 | (gud-basic-call | ||
| 2450 | (let ((bptno (get-text-property | ||
| 2451 | 0 'gdb-bptno (car (posn-string posn))))) | ||
| 2452 | (concat | ||
| 2453 | (if (get-text-property | ||
| 2454 | 0 'gdb-enabled (car (posn-string posn))) | ||
| 2455 | "-break-disable " | ||
| 2456 | "-break-enable ") | ||
| 2457 | bptno))))))))) | ||
| 2458 | |||
| 2459 | (defun gdb-mouse-toggle-breakpoint-fringe (event) | ||
| 2460 | "Enable/disable breakpoint in left fringe with mouse click." | ||
| 2461 | (interactive "e") | ||
| 2462 | (mouse-minibuffer-check event) | ||
| 2463 | (let* ((posn (event-end event)) | ||
| 2464 | (pos (posn-point posn)) | ||
| 2465 | obj) | ||
| 2466 | (when (numberp pos) | ||
| 2467 | (with-selected-window (posn-window posn) | ||
| 2468 | (with-current-buffer (window-buffer (selected-window)) | ||
| 2469 | (goto-char pos) | ||
| 2470 | (dolist (overlay (overlays-in pos pos)) | ||
| 2471 | (when (overlay-get overlay 'put-break) | ||
| 2472 | (setq obj (overlay-get overlay 'before-string)))) | ||
| 2473 | (when (stringp obj) | ||
| 2474 | (gud-basic-call | ||
| 2475 | (concat | ||
| 2476 | (if (get-text-property 0 'gdb-enabled obj) | ||
| 2477 | "-break-disable " | ||
| 2478 | "-break-enable ") | ||
| 2479 | (get-text-property 0 'gdb-bptno obj))))))))) | ||
| 2480 | |||
| 2481 | (defun gdb-breakpoints-buffer-name () | ||
| 2482 | (concat "*breakpoints of " (gdb-get-target-string) "*")) | ||
| 2483 | |||
| 2484 | (def-gdb-display-buffer | ||
| 2485 | gdb-display-breakpoints-buffer | ||
| 2486 | 'gdb-breakpoints-buffer | ||
| 2487 | "Display status of user-settable breakpoints.") | ||
| 2488 | |||
| 2489 | (def-gdb-frame-for-buffer | ||
| 2490 | gdb-frame-breakpoints-buffer | ||
| 2491 | 'gdb-breakpoints-buffer | ||
| 2492 | "Display status of user-settable breakpoints in a new frame.") | ||
| 2493 | |||
| 2494 | (defvar gdb-breakpoints-mode-map | ||
| 2495 | (let ((map (make-sparse-keymap)) | ||
| 2496 | (menu (make-sparse-keymap "Breakpoints"))) | ||
| 2497 | (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window)) | ||
| 2498 | (define-key menu [goto] '("Goto" . gdb-goto-breakpoint)) | ||
| 2499 | (define-key menu [delete] '("Delete" . gdb-delete-breakpoint)) | ||
| 2500 | (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint)) | ||
| 2501 | (suppress-keymap map) | ||
| 2502 | (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu)) | ||
| 2503 | (define-key map " " 'gdb-toggle-breakpoint) | ||
| 2504 | (define-key map "D" 'gdb-delete-breakpoint) | ||
| 2505 | ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons. | ||
| 2506 | (define-key map "q" 'gdb-delete-frame-or-window) | ||
| 2507 | (define-key map "\r" 'gdb-goto-breakpoint) | ||
| 2508 | (define-key map "\t" '(lambda () | ||
| 2509 | (interactive) | ||
| 2510 | (gdb-set-window-buffer | ||
| 2511 | (gdb-get-buffer-create 'gdb-threads-buffer) t))) | ||
| 2512 | (define-key map [mouse-2] 'gdb-goto-breakpoint) | ||
| 2513 | (define-key map [follow-link] 'mouse-face) | ||
| 2514 | map)) | ||
| 2515 | |||
| 2516 | (defun gdb-delete-frame-or-window () | ||
| 2517 | "Delete frame if there is only one window. Otherwise delete the window." | ||
| 2518 | (interactive) | ||
| 2519 | (if (one-window-p) (delete-frame) | ||
| 2520 | (delete-window))) | ||
| 2521 | |||
| 2522 | ;;from make-mode-line-mouse-map | ||
| 2523 | (defun gdb-make-header-line-mouse-map (mouse function) "\ | ||
| 2524 | Return a keymap with single entry for mouse key MOUSE on the header line. | ||
| 2525 | MOUSE is defined to run function FUNCTION with no args in the buffer | ||
| 2526 | corresponding to the mode line clicked." | ||
| 2527 | (let ((map (make-sparse-keymap))) | ||
| 2528 | (define-key map (vector 'header-line mouse) function) | ||
| 2529 | (define-key map (vector 'header-line 'down-mouse-1) 'ignore) | ||
| 2530 | map)) | ||
| 2531 | |||
| 2532 | (defmacro gdb-propertize-header (name buffer help-echo mouse-face face) | ||
| 2533 | `(propertize ,name | ||
| 2534 | 'help-echo ,help-echo | ||
| 2535 | 'mouse-face ',mouse-face | ||
| 2536 | 'face ',face | ||
| 2537 | 'local-map | ||
| 2538 | (gdb-make-header-line-mouse-map | ||
| 2539 | 'mouse-1 | ||
| 2540 | (lambda (event) (interactive "e") | ||
| 2541 | (save-selected-window | ||
| 2542 | (select-window (posn-window (event-start event))) | ||
| 2543 | (gdb-set-window-buffer | ||
| 2544 | (gdb-get-buffer-create ',buffer) t) ))))) | ||
| 2545 | |||
| 2546 | |||
| 2547 | ;; uses "-thread-info". Needs GDB 7.0 onwards. | ||
| 2548 | ;;; Threads view | ||
| 2549 | |||
| 2550 | (defun gdb-threads-buffer-name () | ||
| 2551 | (concat "*threads of " (gdb-get-target-string) "*")) | ||
| 2552 | |||
| 2553 | (def-gdb-display-buffer | ||
| 2554 | gdb-display-threads-buffer | ||
| 2555 | 'gdb-threads-buffer | ||
| 2556 | "Display GDB threads.") | ||
| 2557 | |||
| 2558 | (def-gdb-frame-for-buffer | ||
| 2559 | gdb-frame-threads-buffer | ||
| 2560 | 'gdb-threads-buffer | ||
| 2561 | "Display GDB threads in a new frame.") | ||
| 2562 | |||
| 2563 | (def-gdb-trigger-and-handler | ||
| 2564 | gdb-invalidate-threads (gdb-current-context-command "-thread-info") | ||
| 2565 | gdb-thread-list-handler gdb-thread-list-handler-custom | ||
| 2566 | '(start update update-threads)) | ||
| 2567 | |||
| 2568 | (gdb-set-buffer-rules | ||
| 2569 | 'gdb-threads-buffer | ||
| 2570 | 'gdb-threads-buffer-name | ||
| 2571 | 'gdb-threads-mode | ||
| 2572 | 'gdb-invalidate-threads) | ||
| 2573 | |||
| 2574 | (defvar gdb-threads-font-lock-keywords | ||
| 2575 | '(("in \\([^ ]+\\)" (1 font-lock-function-name-face)) | ||
| 2576 | (" \\(stopped\\)" (1 font-lock-warning-face)) | ||
| 2577 | (" \\(running\\)" (1 font-lock-string-face)) | ||
| 2578 | ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face))) | ||
| 2579 | "Font lock keywords used in `gdb-threads-mode'.") | ||
| 2580 | |||
| 2581 | (defvar gdb-threads-mode-map | ||
| 2582 | (let ((map (make-sparse-keymap))) | ||
| 2583 | (define-key map "\r" 'gdb-select-thread) | ||
| 2584 | (define-key map "f" 'gdb-display-stack-for-thread) | ||
| 2585 | (define-key map "F" 'gdb-frame-stack-for-thread) | ||
| 2586 | (define-key map "l" 'gdb-display-locals-for-thread) | ||
| 2587 | (define-key map "L" 'gdb-frame-locals-for-thread) | ||
| 2588 | (define-key map "r" 'gdb-display-registers-for-thread) | ||
| 2589 | (define-key map "R" 'gdb-frame-registers-for-thread) | ||
| 2590 | (define-key map "d" 'gdb-display-disassembly-for-thread) | ||
| 2591 | (define-key map "D" 'gdb-frame-disassembly-for-thread) | ||
| 2592 | (define-key map "i" 'gdb-interrupt-thread) | ||
| 2593 | (define-key map "c" 'gdb-continue-thread) | ||
| 2594 | (define-key map "s" 'gdb-step-thread) | ||
| 2595 | (define-key map "\t" '(lambda () | ||
| 2596 | (interactive) | ||
| 2597 | (gdb-set-window-buffer | ||
| 2598 | (gdb-get-buffer-create 'gdb-breakpoints-buffer) t))) | ||
| 2599 | (define-key map [mouse-2] 'gdb-select-thread) | ||
| 2600 | (define-key map [follow-link] 'mouse-face) | ||
| 2601 | map)) | ||
| 2602 | |||
| 2603 | (defvar gdb-threads-header | ||
| 2604 | (list | ||
| 2605 | (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer | ||
| 2606 | "mouse-1: select" mode-line-highlight mode-line-inactive) | ||
| 2607 | " " | ||
| 2608 | (gdb-propertize-header "Threads" gdb-threads-buffer | ||
| 2609 | nil nil mode-line))) | ||
| 2610 | |||
| 2611 | (define-derived-mode gdb-threads-mode gdb-parent-mode "Threads" | ||
| 2612 | "Major mode for GDB threads. | ||
| 2613 | |||
| 2614 | \\{gdb-threads-mode-map}" | ||
| 2615 | (setq gdb-thread-position (make-marker)) | ||
| 2616 | (add-to-list 'overlay-arrow-variable-list 'gdb-thread-position) | ||
| 2617 | (setq header-line-format gdb-threads-header) | ||
| 2618 | (set (make-local-variable 'font-lock-defaults) | ||
| 2619 | '(gdb-threads-font-lock-keywords)) | ||
| 2620 | (run-mode-hooks 'gdb-threads-mode-hook) | ||
| 2621 | 'gdb-invalidate-threads) | ||
| 2622 | |||
| 2623 | (defun gdb-thread-list-handler-custom () | ||
| 2624 | (let ((threads-list (bindat-get-field (gdb-json-partial-output) 'threads)) | ||
| 2625 | (table (make-gdb-table)) | ||
| 2626 | (marked-line nil)) | ||
| 2627 | (setq gdb-threads-list nil) | ||
| 2628 | (setq gdb-running-threads-count 0) | ||
| 2629 | (setq gdb-stopped-threads-count 0) | ||
| 2630 | (set-marker gdb-thread-position nil) | ||
| 2631 | |||
| 2632 | (dolist (thread (reverse threads-list)) | ||
| 2633 | (let ((running (string-equal (bindat-get-field thread 'state) "running"))) | ||
| 2634 | (add-to-list 'gdb-threads-list | ||
| 2635 | (cons (bindat-get-field thread 'id) | ||
| 2636 | thread)) | ||
| 2637 | (if running | ||
| 2638 | (incf gdb-running-threads-count) | ||
| 2639 | (incf gdb-stopped-threads-count)) | ||
| 2640 | |||
| 2641 | (gdb-table-add-row table | ||
| 2642 | (list | ||
| 2643 | (bindat-get-field thread 'id) | ||
| 2644 | (concat | ||
| 2645 | (if gdb-thread-buffer-verbose-names | ||
| 2646 | (concat (bindat-get-field thread 'target-id) " ") "") | ||
| 2647 | (bindat-get-field thread 'state) | ||
| 2648 | ;; Include frame information for stopped threads | ||
| 2649 | (if (not running) | ||
| 2650 | (concat | ||
| 2651 | " in " (bindat-get-field thread 'frame 'func) | ||
| 2652 | (if gdb-thread-buffer-arguments | ||
| 2653 | (concat | ||
| 2654 | " (" | ||
| 2655 | (let ((args (bindat-get-field thread 'frame 'args))) | ||
| 2656 | (mapconcat | ||
| 2657 | (lambda (arg) | ||
| 2658 | (apply 'format `("%s=%s" ,@(gdb-get-many-fields arg 'name 'value)))) | ||
| 2659 | args ",")) | ||
| 2660 | ")") | ||
| 2661 | "") | ||
| 2662 | (if gdb-thread-buffer-locations | ||
| 2663 | (gdb-frame-location (bindat-get-field thread 'frame)) "") | ||
| 2664 | (if gdb-thread-buffer-addresses | ||
| 2665 | (concat " at " (bindat-get-field thread 'frame 'addr)) "")) | ||
| 2666 | ""))) | ||
| 2667 | (list | ||
| 2668 | 'gdb-thread thread | ||
| 2669 | 'mouse-face 'highlight | ||
| 2670 | 'help-echo "mouse-2, RET: select thread"))) | ||
| 2671 | (when (string-equal gdb-thread-number | ||
| 2672 | (bindat-get-field thread 'id)) | ||
| 2673 | (setq marked-line (length gdb-threads-list)))) | ||
| 2674 | (insert (gdb-table-string table " ")) | ||
| 2675 | (when marked-line | ||
| 2676 | (gdb-mark-line marked-line gdb-thread-position))) | ||
| 2677 | ;; We update gud-running here because we need to make sure that | ||
| 2678 | ;; gdb-threads-list is up-to-date | ||
| 2679 | (gdb-update-gud-running) | ||
| 2680 | (gdb-emit-signal gdb-buf-publisher 'update-disassembly)) | ||
| 2681 | |||
| 2682 | (defmacro def-gdb-thread-buffer-command (name custom-defun &optional doc) | ||
| 2683 | "Define a NAME command which will act upon thread on the current line. | ||
| 2684 | |||
| 2685 | CUSTOM-DEFUN may use locally bound `thread' variable, which will | ||
| 2686 | be the value of 'gdb-thread property of the current line. If | ||
| 2687 | 'gdb-thread is nil, error is signaled." | ||
| 2688 | `(defun ,name (&optional event) | ||
| 2689 | ,(when doc doc) | ||
| 2690 | (interactive (list last-input-event)) | ||
| 2691 | (if event (posn-set-point (event-end event))) | ||
| 2692 | (save-excursion | ||
| 2693 | (beginning-of-line) | ||
| 2694 | (let ((thread (get-text-property (point) 'gdb-thread))) | ||
| 2695 | (if thread | ||
| 2696 | ,custom-defun | ||
| 2697 | (error "Not recognized as thread line")))))) | ||
| 2698 | |||
| 2699 | (defmacro def-gdb-thread-buffer-simple-command (name buffer-command &optional doc) | ||
| 2700 | "Define a NAME which will call BUFFER-COMMAND with id of thread | ||
| 2701 | on the current line." | ||
| 2702 | `(def-gdb-thread-buffer-command ,name | ||
| 2703 | (,buffer-command (bindat-get-field thread 'id)) | ||
| 2704 | ,doc)) | ||
| 2705 | |||
| 2706 | (def-gdb-thread-buffer-command gdb-select-thread | ||
| 2707 | (let ((new-id (bindat-get-field thread 'id))) | ||
| 2708 | (gdb-setq-thread-number new-id) | ||
| 2709 | (gdb-input (list (concat "-thread-select " new-id) 'ignore)) | ||
| 2710 | (gdb-update)) | ||
| 2711 | "Select the thread at current line of threads buffer.") | ||
| 2712 | |||
| 2713 | (def-gdb-thread-buffer-simple-command | ||
| 2714 | gdb-display-stack-for-thread | ||
| 2715 | gdb-preemptively-display-stack-buffer | ||
| 2716 | "Display stack buffer for the thread at current line.") | ||
| 2717 | |||
| 2718 | (def-gdb-thread-buffer-simple-command | ||
| 2719 | gdb-display-locals-for-thread | ||
| 2720 | gdb-preemptively-display-locals-buffer | ||
| 2721 | "Display locals buffer for the thread at current line.") | ||
| 2722 | |||
| 2723 | (def-gdb-thread-buffer-simple-command | ||
| 2724 | gdb-display-registers-for-thread | ||
| 2725 | gdb-preemptively-display-registers-buffer | ||
| 2726 | "Display registers buffer for the thread at current line.") | ||
| 2727 | |||
| 2728 | (def-gdb-thread-buffer-simple-command | ||
| 2729 | gdb-display-disassembly-for-thread | ||
| 2730 | gdb-preemptively-display-disassembly-buffer | ||
| 2731 | "Display disassembly buffer for the thread at current line.") | ||
| 2732 | |||
| 2733 | (def-gdb-thread-buffer-simple-command | ||
| 2734 | gdb-frame-stack-for-thread | ||
| 2735 | gdb-frame-stack-buffer | ||
| 2736 | "Display a new frame with stack buffer for the thread at | ||
| 2737 | current line.") | ||
| 2738 | |||
| 2739 | (def-gdb-thread-buffer-simple-command | ||
| 2740 | gdb-frame-locals-for-thread | ||
| 2741 | gdb-frame-locals-buffer | ||
| 2742 | "Display a new frame with locals buffer for the thread at | ||
| 2743 | current line.") | ||
| 2744 | |||
| 2745 | (def-gdb-thread-buffer-simple-command | ||
| 2746 | gdb-frame-registers-for-thread | ||
| 2747 | gdb-frame-registers-buffer | ||
| 2748 | "Display a new frame with registers buffer for the thread at | ||
| 2749 | current line.") | ||
| 2750 | |||
| 2751 | (def-gdb-thread-buffer-simple-command | ||
| 2752 | gdb-frame-disassembly-for-thread | ||
| 2753 | gdb-frame-disassembly-buffer | ||
| 2754 | "Display a new frame with disassembly buffer for the thread at | ||
| 2755 | current line.") | ||
| 2756 | |||
| 2757 | (defmacro def-gdb-thread-buffer-gud-command (name gud-command &optional doc) | ||
| 2758 | "Define a NAME which will execute GUD-COMMAND with | ||
| 2759 | `gdb-thread-number' locally bound to id of thread on the current | ||
| 2760 | line." | ||
| 2761 | `(def-gdb-thread-buffer-command ,name | ||
| 2762 | (if gdb-non-stop | ||
| 2763 | (let ((gdb-thread-number (bindat-get-field thread 'id)) | ||
| 2764 | (gdb-gud-control-all-threads nil)) | ||
| 2765 | (call-interactively #',gud-command)) | ||
| 2766 | (error "Available in non-stop mode only, customize `gdb-non-stop-setting'")) | ||
| 2767 | ,doc)) | ||
| 2768 | |||
| 2769 | (def-gdb-thread-buffer-gud-command | ||
| 2770 | gdb-interrupt-thread | ||
| 2771 | gud-stop-subjob | ||
| 2772 | "Interrupt thread at current line.") | ||
| 2773 | |||
| 2774 | (def-gdb-thread-buffer-gud-command | ||
| 2775 | gdb-continue-thread | ||
| 2776 | gud-cont | ||
| 2777 | "Continue thread at current line.") | ||
| 2778 | |||
| 2779 | (def-gdb-thread-buffer-gud-command | ||
| 2780 | gdb-step-thread | ||
| 2781 | gud-step | ||
| 2782 | "Step thread at current line.") | ||
| 2783 | |||
| 2784 | |||
| 2785 | ;;; Memory view | ||
| 2786 | |||
| 2787 | (defcustom gdb-memory-rows 8 | ||
| 2788 | "Number of data rows in memory window." | ||
| 2789 | :type 'integer | ||
| 2790 | :group 'gud | ||
| 2791 | :version "23.2") | ||
| 2792 | |||
| 2793 | (defcustom gdb-memory-columns 4 | ||
| 2794 | "Number of data columns in memory window." | ||
| 2795 | :type 'integer | ||
| 2796 | :group 'gud | ||
| 2797 | :version "23.2") | ||
| 2798 | |||
| 2799 | (defcustom gdb-memory-format "x" | ||
| 2800 | "Display format of data items in memory window." | ||
| 2801 | :type '(choice (const :tag "Hexadecimal" "x") | ||
| 2802 | (const :tag "Signed decimal" "d") | ||
| 2803 | (const :tag "Unsigned decimal" "u") | ||
| 2804 | (const :tag "Octal" "o") | ||
| 2805 | (const :tag "Binary" "t")) | ||
| 2806 | :group 'gud | ||
| 2807 | :version "22.1") | ||
| 2808 | |||
| 2809 | (defcustom gdb-memory-unit 4 | ||
| 2810 | "Unit size of data items in memory window." | ||
| 2811 | :type '(choice (const :tag "Byte" 1) | ||
| 2812 | (const :tag "Halfword" 2) | ||
| 2813 | (const :tag "Word" 4) | ||
| 2814 | (const :tag "Giant word" 8)) | ||
| 2815 | :group 'gud | ||
| 2816 | :version "23.2") | ||
| 2817 | |||
| 2818 | (def-gdb-trigger-and-handler | ||
| 2819 | gdb-invalidate-memory | ||
| 2820 | (format "-data-read-memory %s %s %d %d %d" | ||
| 2821 | gdb-memory-address | ||
| 2822 | gdb-memory-format | ||
| 2823 | gdb-memory-unit | ||
| 2824 | gdb-memory-rows | ||
| 2825 | gdb-memory-columns) | ||
| 2826 | gdb-read-memory-handler | ||
| 2827 | gdb-read-memory-custom | ||
| 2828 | '(start update)) | ||
| 2829 | |||
| 2830 | (gdb-set-buffer-rules | ||
| 2831 | 'gdb-memory-buffer | ||
| 2832 | 'gdb-memory-buffer-name | ||
| 2833 | 'gdb-memory-mode | ||
| 2834 | 'gdb-invalidate-memory) | ||
| 2835 | |||
| 2836 | (defun gdb-memory-column-width (size format) | ||
| 2837 | "Return length of string with memory unit of SIZE in FORMAT. | ||
| 2838 | |||
| 2839 | SIZE is in bytes, as in `gdb-memory-unit'. FORMAT is a string as | ||
| 2840 | in `gdb-memory-format'." | ||
| 2841 | (let ((format-base (cdr (assoc format | ||
| 2842 | '(("x" . 16) | ||
| 2843 | ("d" . 10) ("u" . 10) | ||
| 2844 | ("o" . 8) | ||
| 2845 | ("t" . 2)))))) | ||
| 2846 | (if format-base | ||
| 2847 | (let ((res (ceiling (log (expt 2.0 (* size 8)) format-base)))) | ||
| 2848 | (cond ((string-equal format "x") | ||
| 2849 | (+ 2 res)) ; hexadecimal numbers have 0x in front | ||
| 2850 | ((or (string-equal format "d") | ||
| 2851 | (string-equal format "o")) | ||
| 2852 | (1+ res)) | ||
| 2853 | (t res))) | ||
| 2854 | (error "Unknown format")))) | ||
| 2855 | |||
| 2856 | (defun gdb-read-memory-custom () | ||
| 2857 | (let* ((res (gdb-json-partial-output)) | ||
| 2858 | (err-msg (bindat-get-field res 'msg))) | ||
| 2859 | (if (not err-msg) | ||
| 2860 | (let ((memory (bindat-get-field res 'memory))) | ||
| 2861 | (setq gdb-memory-address (bindat-get-field res 'addr)) | ||
| 2862 | (setq gdb-memory-next-page (bindat-get-field res 'next-page)) | ||
| 2863 | (setq gdb-memory-prev-page (bindat-get-field res 'prev-page)) | ||
| 2864 | (setq gdb-memory-last-address gdb-memory-address) | ||
| 2865 | (dolist (row memory) | ||
| 2866 | (insert (concat (bindat-get-field row 'addr) ":")) | ||
| 2867 | (dolist (column (bindat-get-field row 'data)) | ||
| 2868 | (insert (gdb-pad-string column | ||
| 2869 | (+ 2 (gdb-memory-column-width | ||
| 2870 | gdb-memory-unit | ||
| 2871 | gdb-memory-format))))) | ||
| 2872 | (newline))) | ||
| 2873 | ;; Show last page instead of empty buffer when out of bounds | ||
| 2874 | (progn | ||
| 2875 | (let ((gdb-memory-address gdb-memory-last-address)) | ||
| 2876 | (gdb-invalidate-memory 'update) | ||
| 2877 | (error err-msg)))))) | ||
| 2878 | |||
| 2879 | (defvar gdb-memory-mode-map | ||
| 2880 | (let ((map (make-sparse-keymap))) | ||
| 2881 | (suppress-keymap map t) | ||
| 2882 | (define-key map "q" 'kill-this-buffer) | ||
| 2883 | (define-key map "n" 'gdb-memory-show-next-page) | ||
| 2884 | (define-key map "p" 'gdb-memory-show-previous-page) | ||
| 2885 | (define-key map "a" 'gdb-memory-set-address) | ||
| 2886 | (define-key map "t" 'gdb-memory-format-binary) | ||
| 2887 | (define-key map "o" 'gdb-memory-format-octal) | ||
| 2888 | (define-key map "u" 'gdb-memory-format-unsigned) | ||
| 2889 | (define-key map "d" 'gdb-memory-format-signed) | ||
| 2890 | (define-key map "x" 'gdb-memory-format-hexadecimal) | ||
| 2891 | (define-key map "b" 'gdb-memory-unit-byte) | ||
| 2892 | (define-key map "h" 'gdb-memory-unit-halfword) | ||
| 2893 | (define-key map "w" 'gdb-memory-unit-word) | ||
| 2894 | (define-key map "g" 'gdb-memory-unit-giant) | ||
| 2895 | (define-key map "R" 'gdb-memory-set-rows) | ||
| 2896 | (define-key map "C" 'gdb-memory-set-columns) | ||
| 2897 | map)) | ||
| 2898 | |||
| 2899 | (defun gdb-memory-set-address-event (event) | ||
| 2900 | "Handle a click on address field in memory buffer header." | ||
| 2901 | (interactive "e") | ||
| 2902 | (save-selected-window | ||
| 2903 | (select-window (posn-window (event-start event))) | ||
| 2904 | (gdb-memory-set-address))) | ||
| 2905 | |||
| 2906 | ;; Non-event version for use within keymap | ||
| 2907 | (defun gdb-memory-set-address () | ||
| 2908 | "Set the start memory address." | ||
| 2909 | (interactive) | ||
| 2910 | (let ((arg (read-from-minibuffer "Memory address: "))) | ||
| 2911 | (setq gdb-memory-address arg)) | ||
| 2912 | (gdb-invalidate-memory 'update)) | ||
| 2913 | |||
| 2914 | (defmacro def-gdb-set-positive-number (name variable echo-string &optional doc) | ||
| 2915 | "Define a function NAME which reads new VAR value from minibuffer." | ||
| 2916 | `(defun ,name (event) | ||
| 2917 | ,(when doc doc) | ||
| 2918 | (interactive "e") | ||
| 2919 | (save-selected-window | ||
| 2920 | (select-window (posn-window (event-start event))) | ||
| 2921 | (let* ((arg (read-from-minibuffer ,echo-string)) | ||
| 2922 | (count (string-to-number arg))) | ||
| 2923 | (if (<= count 0) | ||
| 2924 | (error "Positive number only") | ||
| 2925 | (customize-set-variable ',variable count) | ||
| 2926 | (gdb-invalidate-memory 'update)))))) | ||
| 2927 | |||
| 2928 | (def-gdb-set-positive-number | ||
| 2929 | gdb-memory-set-rows | ||
| 2930 | gdb-memory-rows | ||
| 2931 | "Rows: " | ||
| 2932 | "Set the number of data rows in memory window.") | ||
| 2933 | |||
| 2934 | (def-gdb-set-positive-number | ||
| 2935 | gdb-memory-set-columns | ||
| 2936 | gdb-memory-columns | ||
| 2937 | "Columns: " | ||
| 2938 | "Set the number of data columns in memory window.") | ||
| 2939 | |||
| 2940 | (defmacro def-gdb-memory-format (name format doc) | ||
| 2941 | "Define a function NAME to switch memory buffer to use FORMAT. | ||
| 2942 | |||
| 2943 | DOC is an optional documentation string." | ||
| 2944 | `(defun ,name () ,(when doc doc) | ||
| 2945 | (interactive) | ||
| 2946 | (customize-set-variable 'gdb-memory-format ,format) | ||
| 2947 | (gdb-invalidate-memory 'update))) | ||
| 2948 | |||
| 2949 | (def-gdb-memory-format | ||
| 2950 | gdb-memory-format-binary "t" | ||
| 2951 | "Set the display format to binary.") | ||
| 2952 | |||
| 2953 | (def-gdb-memory-format | ||
| 2954 | gdb-memory-format-octal "o" | ||
| 2955 | "Set the display format to octal.") | ||
| 2956 | |||
| 2957 | (def-gdb-memory-format | ||
| 2958 | gdb-memory-format-unsigned "u" | ||
| 2959 | "Set the display format to unsigned decimal.") | ||
| 2960 | |||
| 2961 | (def-gdb-memory-format | ||
| 2962 | gdb-memory-format-signed "d" | ||
| 2963 | "Set the display format to decimal.") | ||
| 2964 | |||
| 2965 | (def-gdb-memory-format | ||
| 2966 | gdb-memory-format-hexadecimal "x" | ||
| 2967 | "Set the display format to hexadecimal.") | ||
| 2968 | |||
| 2969 | (defvar gdb-memory-format-map | ||
| 2970 | (let ((map (make-sparse-keymap))) | ||
| 2971 | (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1) | ||
| 2972 | map) | ||
| 2973 | "Keymap to select format in the header line.") | ||
| 2974 | |||
| 2975 | (defvar gdb-memory-format-menu (make-sparse-keymap "Format") | ||
| 2976 | "Menu of display formats in the header line.") | ||
| 2977 | |||
| 2978 | (define-key gdb-memory-format-menu [binary] | ||
| 2979 | '(menu-item "Binary" gdb-memory-format-binary | ||
| 2980 | :button (:radio . (equal gdb-memory-format "t")))) | ||
| 2981 | (define-key gdb-memory-format-menu [octal] | ||
| 2982 | '(menu-item "Octal" gdb-memory-format-octal | ||
| 2983 | :button (:radio . (equal gdb-memory-format "o")))) | ||
| 2984 | (define-key gdb-memory-format-menu [unsigned] | ||
| 2985 | '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned | ||
| 2986 | :button (:radio . (equal gdb-memory-format "u")))) | ||
| 2987 | (define-key gdb-memory-format-menu [signed] | ||
| 2988 | '(menu-item "Signed Decimal" gdb-memory-format-signed | ||
| 2989 | :button (:radio . (equal gdb-memory-format "d")))) | ||
| 2990 | (define-key gdb-memory-format-menu [hexadecimal] | ||
| 2991 | '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal | ||
| 2992 | :button (:radio . (equal gdb-memory-format "x")))) | ||
| 2993 | |||
| 2994 | (defun gdb-memory-format-menu (event) | ||
| 2995 | (interactive "@e") | ||
| 2996 | (x-popup-menu event gdb-memory-format-menu)) | ||
| 2997 | |||
| 2998 | (defun gdb-memory-format-menu-1 (event) | ||
| 2999 | (interactive "e") | ||
| 3000 | (save-selected-window | ||
| 3001 | (select-window (posn-window (event-start event))) | ||
| 3002 | (let* ((selection (gdb-memory-format-menu event)) | ||
| 3003 | (binding (and selection (lookup-key gdb-memory-format-menu | ||
| 3004 | (vector (car selection)))))) | ||
| 3005 | (if binding (call-interactively binding))))) | ||
| 3006 | |||
| 3007 | (defmacro def-gdb-memory-unit (name unit-size doc) | ||
| 3008 | "Define a function NAME to switch memory unit size to UNIT-SIZE. | ||
| 3009 | |||
| 3010 | DOC is an optional documentation string." | ||
| 3011 | `(defun ,name () ,(when doc doc) | ||
| 3012 | (interactive) | ||
| 3013 | (customize-set-variable 'gdb-memory-unit ,unit-size) | ||
| 3014 | (gdb-invalidate-memory 'update))) | ||
| 3015 | |||
| 3016 | (def-gdb-memory-unit gdb-memory-unit-giant 8 | ||
| 3017 | "Set the unit size to giant words (eight bytes).") | ||
| 3018 | |||
| 3019 | (def-gdb-memory-unit gdb-memory-unit-word 4 | ||
| 3020 | "Set the unit size to words (four bytes).") | ||
| 3021 | |||
| 3022 | (def-gdb-memory-unit gdb-memory-unit-halfword 2 | ||
| 3023 | "Set the unit size to halfwords (two bytes).") | ||
| 3024 | |||
| 3025 | (def-gdb-memory-unit gdb-memory-unit-byte 1 | ||
| 3026 | "Set the unit size to bytes.") | ||
| 3027 | |||
| 3028 | (defmacro def-gdb-memory-show-page (name address-var &optional doc) | ||
| 3029 | "Define a function NAME which show new address in memory buffer. | ||
| 3030 | |||
| 3031 | The defined function switches Memory buffer to show address | ||
| 3032 | stored in ADDRESS-VAR variable. | ||
| 3033 | |||
| 3034 | DOC is an optional documentation string." | ||
| 3035 | `(defun ,name | ||
| 3036 | ,(when doc doc) | ||
| 3037 | (interactive) | ||
| 3038 | (let ((gdb-memory-address ,address-var)) | ||
| 3039 | (gdb-invalidate-memory)))) | ||
| 3040 | |||
| 3041 | (def-gdb-memory-show-page gdb-memory-show-previous-page | ||
| 3042 | gdb-memory-prev-page) | ||
| 3043 | |||
| 3044 | (def-gdb-memory-show-page gdb-memory-show-next-page | ||
| 3045 | gdb-memory-next-page) | ||
| 3046 | |||
| 3047 | (defvar gdb-memory-unit-map | ||
| 3048 | (let ((map (make-sparse-keymap))) | ||
| 3049 | (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1) | ||
| 3050 | map) | ||
| 3051 | "Keymap to select units in the header line.") | ||
| 3052 | |||
| 3053 | (defvar gdb-memory-unit-menu (make-sparse-keymap "Unit") | ||
| 3054 | "Menu of units in the header line.") | ||
| 3055 | |||
| 3056 | (define-key gdb-memory-unit-menu [giantwords] | ||
| 3057 | '(menu-item "Giant words" gdb-memory-unit-giant | ||
| 3058 | :button (:radio . (equal gdb-memory-unit 8)))) | ||
| 3059 | (define-key gdb-memory-unit-menu [words] | ||
| 3060 | '(menu-item "Words" gdb-memory-unit-word | ||
| 3061 | :button (:radio . (equal gdb-memory-unit 4)))) | ||
| 3062 | (define-key gdb-memory-unit-menu [halfwords] | ||
| 3063 | '(menu-item "Halfwords" gdb-memory-unit-halfword | ||
| 3064 | :button (:radio . (equal gdb-memory-unit 2)))) | ||
| 3065 | (define-key gdb-memory-unit-menu [bytes] | ||
| 3066 | '(menu-item "Bytes" gdb-memory-unit-byte | ||
| 3067 | :button (:radio . (equal gdb-memory-unit 1)))) | ||
| 3068 | |||
| 3069 | (defun gdb-memory-unit-menu (event) | ||
| 3070 | (interactive "@e") | ||
| 3071 | (x-popup-menu event gdb-memory-unit-menu)) | ||
| 3072 | |||
| 3073 | (defun gdb-memory-unit-menu-1 (event) | ||
| 3074 | (interactive "e") | ||
| 3075 | (save-selected-window | ||
| 3076 | (select-window (posn-window (event-start event))) | ||
| 3077 | (let* ((selection (gdb-memory-unit-menu event)) | ||
| 3078 | (binding (and selection (lookup-key gdb-memory-unit-menu | ||
| 3079 | (vector (car selection)))))) | ||
| 3080 | (if binding (call-interactively binding))))) | ||
| 3081 | |||
| 3082 | (defvar gdb-memory-font-lock-keywords | ||
| 3083 | '(;; <__function.name+n> | ||
| 3084 | ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face)) | ||
| 3085 | ) | ||
| 3086 | "Font lock keywords used in `gdb-memory-mode'.") | ||
| 3087 | |||
| 3088 | (defvar gdb-memory-header | ||
| 3089 | '(:eval | ||
| 3090 | (concat | ||
| 3091 | "Start address[" | ||
| 3092 | (propertize "-" | ||
| 3093 | 'face font-lock-warning-face | ||
| 3094 | 'help-echo "mouse-1: decrement address" | ||
| 3095 | 'mouse-face 'mode-line-highlight | ||
| 3096 | 'local-map (gdb-make-header-line-mouse-map | ||
| 3097 | 'mouse-1 | ||
| 3098 | #'gdb-memory-show-previous-page)) | ||
| 3099 | "|" | ||
| 3100 | (propertize "+" | ||
| 3101 | 'face font-lock-warning-face | ||
| 3102 | 'help-echo "mouse-1: increment address" | ||
| 3103 | 'mouse-face 'mode-line-highlight | ||
| 3104 | 'local-map (gdb-make-header-line-mouse-map | ||
| 3105 | 'mouse-1 | ||
| 3106 | #'gdb-memory-show-next-page)) | ||
| 3107 | "]: " | ||
| 3108 | (propertize gdb-memory-address | ||
| 3109 | 'face font-lock-warning-face | ||
| 3110 | 'help-echo "mouse-1: set start address" | ||
| 3111 | 'mouse-face 'mode-line-highlight | ||
| 3112 | 'local-map (gdb-make-header-line-mouse-map | ||
| 3113 | 'mouse-1 | ||
| 3114 | #'gdb-memory-set-address-event)) | ||
| 3115 | " Rows: " | ||
| 3116 | (propertize (number-to-string gdb-memory-rows) | ||
| 3117 | 'face font-lock-warning-face | ||
| 3118 | 'help-echo "mouse-1: set number of columns" | ||
| 3119 | 'mouse-face 'mode-line-highlight | ||
| 3120 | 'local-map (gdb-make-header-line-mouse-map | ||
| 3121 | 'mouse-1 | ||
| 3122 | #'gdb-memory-set-rows)) | ||
| 3123 | " Columns: " | ||
| 3124 | (propertize (number-to-string gdb-memory-columns) | ||
| 3125 | 'face font-lock-warning-face | ||
| 3126 | 'help-echo "mouse-1: set number of columns" | ||
| 3127 | 'mouse-face 'mode-line-highlight | ||
| 3128 | 'local-map (gdb-make-header-line-mouse-map | ||
| 3129 | 'mouse-1 | ||
| 3130 | #'gdb-memory-set-columns)) | ||
| 3131 | " Display Format: " | ||
| 3132 | (propertize gdb-memory-format | ||
| 3133 | 'face font-lock-warning-face | ||
| 3134 | 'help-echo "mouse-3: select display format" | ||
| 3135 | 'mouse-face 'mode-line-highlight | ||
| 3136 | 'local-map gdb-memory-format-map) | ||
| 3137 | " Unit Size: " | ||
| 3138 | (propertize (number-to-string gdb-memory-unit) | ||
| 3139 | 'face font-lock-warning-face | ||
| 3140 | 'help-echo "mouse-3: select unit size" | ||
| 3141 | 'mouse-face 'mode-line-highlight | ||
| 3142 | 'local-map gdb-memory-unit-map))) | ||
| 3143 | "Header line used in `gdb-memory-mode'.") | ||
| 3144 | |||
| 3145 | (define-derived-mode gdb-memory-mode gdb-parent-mode "Memory" | ||
| 3146 | "Major mode for examining memory. | ||
| 3147 | |||
| 3148 | \\{gdb-memory-mode-map}" | ||
| 3149 | (setq header-line-format gdb-memory-header) | ||
| 3150 | (set (make-local-variable 'font-lock-defaults) | ||
| 3151 | '(gdb-memory-font-lock-keywords)) | ||
| 3152 | (run-mode-hooks 'gdb-memory-mode-hook) | ||
| 3153 | 'gdb-invalidate-memory) | ||
| 3154 | |||
| 3155 | (defun gdb-memory-buffer-name () | ||
| 3156 | (concat "*memory of " (gdb-get-target-string) "*")) | ||
| 3157 | |||
| 3158 | (def-gdb-display-buffer | ||
| 3159 | gdb-display-memory-buffer | ||
| 3160 | 'gdb-memory-buffer | ||
| 3161 | "Display memory contents.") | ||
| 3162 | |||
| 3163 | (defun gdb-frame-memory-buffer () | ||
| 3164 | "Display memory contents in a new frame." | ||
| 3165 | (interactive) | ||
| 3166 | (let* ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 3167 | (special-display-frame-alist | ||
| 3168 | `((left-fringe . 0) | ||
| 3169 | (right-fringe . 0) | ||
| 3170 | (width . 83) | ||
| 3171 | ,@gdb-frame-parameters))) | ||
| 3172 | (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer)))) | ||
| 3173 | |||
| 3174 | |||
| 3175 | ;;; Disassembly view | ||
| 3176 | |||
| 3177 | (defun gdb-disassembly-buffer-name () | ||
| 3178 | (gdb-current-context-buffer-name | ||
| 3179 | (concat "disassembly of " (gdb-get-target-string)))) | ||
| 3180 | |||
| 3181 | (def-gdb-display-buffer | ||
| 3182 | gdb-display-disassembly-buffer | ||
| 3183 | 'gdb-disassembly-buffer | ||
| 3184 | "Display disassembly for current stack frame.") | ||
| 3185 | |||
| 3186 | (def-gdb-preempt-display-buffer | ||
| 3187 | gdb-preemptively-display-disassembly-buffer | ||
| 3188 | 'gdb-disassembly-buffer) | ||
| 3189 | |||
| 3190 | (def-gdb-frame-for-buffer | ||
| 3191 | gdb-frame-disassembly-buffer | ||
| 3192 | 'gdb-disassembly-buffer | ||
| 3193 | "Display disassembly in a new frame.") | ||
| 3194 | |||
| 3195 | (def-gdb-auto-update-trigger gdb-invalidate-disassembly | ||
| 3196 | (let* ((frame (gdb-current-buffer-frame)) | ||
| 3197 | (file (bindat-get-field frame 'fullname)) | ||
| 3198 | (line (bindat-get-field frame 'line))) | ||
| 3199 | (when file | ||
| 3200 | (format "-data-disassemble -f %s -l %s -n -1 -- 0" file line))) | ||
| 3201 | gdb-disassembly-handler | ||
| 3202 | ;; We update disassembly only after we have actual frame information | ||
| 3203 | ;; about all threads, so no there's `update' signal in this list | ||
| 3204 | '(start update-disassembly)) | ||
| 3205 | |||
| 3206 | (def-gdb-auto-update-handler | ||
| 3207 | gdb-disassembly-handler | ||
| 3208 | gdb-invalidate-disassembly | ||
| 3209 | gdb-disassembly-handler-custom | ||
| 3210 | t) | ||
| 3211 | |||
| 3212 | (gdb-set-buffer-rules | ||
| 3213 | 'gdb-disassembly-buffer | ||
| 3214 | 'gdb-disassembly-buffer-name | ||
| 3215 | 'gdb-disassembly-mode | ||
| 3216 | 'gdb-invalidate-disassembly) | ||
| 3217 | |||
| 3218 | (defvar gdb-disassembly-font-lock-keywords | ||
| 3219 | '(;; <__function.name+n> | ||
| 3220 | ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" | ||
| 3221 | (1 font-lock-function-name-face)) | ||
| 3222 | ;; 0xNNNNNNNN <__function.name+n>: opcode | ||
| 3223 | ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)" | ||
| 3224 | (4 font-lock-keyword-face)) | ||
| 3225 | ;; %register(at least i386) | ||
| 3226 | ("%\\sw+" . font-lock-variable-name-face) | ||
| 3227 | ("^\\(Dump of assembler code for function\\) \\(.+\\):" | ||
| 3228 | (1 font-lock-comment-face) | ||
| 3229 | (2 font-lock-function-name-face)) | ||
| 3230 | ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face)) | ||
| 3231 | "Font lock keywords used in `gdb-disassembly-mode'.") | ||
| 3232 | |||
| 3233 | (defvar gdb-disassembly-mode-map | ||
| 3234 | ;; TODO | ||
| 3235 | (let ((map (make-sparse-keymap))) | ||
| 3236 | (suppress-keymap map) | ||
| 3237 | (define-key map "q" 'kill-this-buffer) | ||
| 3238 | map)) | ||
| 3239 | |||
| 3240 | (define-derived-mode gdb-disassembly-mode gdb-parent-mode "Disassembly" | ||
| 3241 | "Major mode for GDB disassembly information. | ||
| 3242 | |||
| 3243 | \\{gdb-disassembly-mode-map}" | ||
| 3244 | ;; TODO Rename overlay variable for disassembly mode | ||
| 3245 | (add-to-list 'overlay-arrow-variable-list 'gdb-disassembly-position) | ||
| 3246 | (setq fringes-outside-margins t) | ||
| 3247 | (set (make-local-variable 'gdb-disassembly-position) (make-marker)) | ||
| 3248 | (set (make-local-variable 'font-lock-defaults) | ||
| 3249 | '(gdb-disassembly-font-lock-keywords)) | ||
| 3250 | (run-mode-hooks 'gdb-disassembly-mode-hook) | ||
| 3251 | 'gdb-invalidate-disassembly) | ||
| 3252 | |||
| 3253 | (defun gdb-disassembly-handler-custom () | ||
| 3254 | (let* ((instructions (bindat-get-field (gdb-json-partial-output) 'asm_insns)) | ||
| 3255 | (address (bindat-get-field (gdb-current-buffer-frame) 'addr)) | ||
| 3256 | (pos 1) | ||
| 3257 | (table (make-gdb-table)) | ||
| 3258 | (marked-line nil)) | ||
| 3259 | (dolist (instr instructions) | ||
| 3260 | (gdb-table-add-row table | ||
| 3261 | (list | ||
| 3262 | (bindat-get-field instr 'address) | ||
| 3263 | (apply 'format `("<%s+%s>:" ,@(gdb-get-many-fields instr 'func-name 'offset))) | ||
| 3264 | (bindat-get-field instr 'inst))) | ||
| 3265 | (when (string-equal (bindat-get-field instr 'address) | ||
| 3266 | address) | ||
| 3267 | (progn | ||
| 3268 | (setq marked-line (length (gdb-table-rows table))) | ||
| 3269 | (setq fringe-indicator-alist | ||
| 3270 | (if (string-equal gdb-frame-number "0") | ||
| 3271 | nil | ||
| 3272 | '((overlay-arrow . hollow-right-triangle))))))) | ||
| 3273 | (insert (gdb-table-string table " ")) | ||
| 3274 | (gdb-disassembly-place-breakpoints) | ||
| 3275 | ;; Mark current position with overlay arrow and scroll window to | ||
| 3276 | ;; that point | ||
| 3277 | (when marked-line | ||
| 3278 | (let ((window (get-buffer-window (current-buffer) 0))) | ||
| 3279 | (set-window-point window (gdb-mark-line marked-line gdb-disassembly-position)))) | ||
| 3280 | (setq mode-name | ||
| 3281 | (gdb-current-context-mode-name | ||
| 3282 | (concat "Disassembly: " | ||
| 3283 | (bindat-get-field (gdb-current-buffer-frame) 'func)))))) | ||
| 3284 | |||
| 3285 | (defun gdb-disassembly-place-breakpoints () | ||
| 3286 | (gdb-remove-breakpoint-icons (point-min) (point-max)) | ||
| 3287 | (dolist (breakpoint gdb-breakpoints-list) | ||
| 3288 | (let* ((breakpoint (cdr breakpoint)) | ||
| 3289 | (bptno (bindat-get-field breakpoint 'number)) | ||
| 3290 | (flag (bindat-get-field breakpoint 'enabled)) | ||
| 3291 | (address (bindat-get-field breakpoint 'addr))) | ||
| 3292 | (save-excursion | ||
| 3293 | (goto-char (point-min)) | ||
| 3294 | (if (re-search-forward (concat "^" address) nil t) | ||
| 3295 | (gdb-put-breakpoint-icon (string-equal flag "y") bptno)))))) | ||
| 3296 | |||
| 3297 | |||
| 3298 | (defvar gdb-breakpoints-header | ||
| 3299 | (list | ||
| 3300 | (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer | ||
| 3301 | nil nil mode-line) | ||
| 3302 | " " | ||
| 3303 | (gdb-propertize-header "Threads" gdb-threads-buffer | ||
| 3304 | "mouse-1: select" mode-line-highlight mode-line-inactive))) | ||
| 3305 | |||
| 3306 | ;;; Breakpoints view | ||
| 3307 | (define-derived-mode gdb-breakpoints-mode gdb-parent-mode "Breakpoints" | ||
| 3308 | "Major mode for gdb breakpoints. | ||
| 3309 | |||
| 3310 | \\{gdb-breakpoints-mode-map}" | ||
| 3311 | (setq header-line-format gdb-breakpoints-header) | ||
| 3312 | (run-mode-hooks 'gdb-breakpoints-mode-hook) | ||
| 3313 | 'gdb-invalidate-breakpoints) | ||
| 3314 | |||
| 3315 | (defun gdb-toggle-breakpoint () | ||
| 3316 | "Enable/disable breakpoint at current line of breakpoints buffer." | ||
| 3317 | (interactive) | ||
| 3318 | (save-excursion | ||
| 3319 | (beginning-of-line) | ||
| 3320 | (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) | ||
| 3321 | (if breakpoint | ||
| 3322 | (gud-basic-call | ||
| 3323 | (concat (if (string-equal "y" (bindat-get-field breakpoint 'enabled)) | ||
| 3324 | "-break-disable " | ||
| 3325 | "-break-enable ") | ||
| 3326 | (bindat-get-field breakpoint 'number))) | ||
| 3327 | (error "Not recognized as break/watchpoint line"))))) | ||
| 3328 | |||
| 3329 | (defun gdb-delete-breakpoint () | ||
| 3330 | "Delete the breakpoint at current line of breakpoints buffer." | ||
| 3331 | (interactive) | ||
| 3332 | (save-excursion | ||
| 3333 | (beginning-of-line) | ||
| 3334 | (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) | ||
| 3335 | (if breakpoint | ||
| 3336 | (gud-basic-call (concat "-break-delete " (bindat-get-field breakpoint 'number))) | ||
| 3337 | (error "Not recognized as break/watchpoint line"))))) | ||
| 3338 | |||
| 3339 | (defun gdb-goto-breakpoint (&optional event) | ||
| 3340 | "Go to the location of breakpoint at current line of | ||
| 3341 | breakpoints buffer." | ||
| 3342 | (interactive (list last-input-event)) | ||
| 3343 | (if event (posn-set-point (event-end event))) | ||
| 3344 | ;; Hack to stop gdb-goto-breakpoint displaying in GUD buffer. | ||
| 3345 | (let ((window (get-buffer-window gud-comint-buffer))) | ||
| 3346 | (if window (save-selected-window (select-window window)))) | ||
| 3347 | (save-excursion | ||
| 3348 | (beginning-of-line) | ||
| 3349 | (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) | ||
| 3350 | (if breakpoint | ||
| 3351 | (let ((bptno (bindat-get-field breakpoint 'number)) | ||
| 3352 | (file (bindat-get-field breakpoint 'fullname)) | ||
| 3353 | (line (bindat-get-field breakpoint 'line))) | ||
| 3354 | (save-selected-window | ||
| 3355 | (let* ((buffer (find-file-noselect | ||
| 3356 | (if (file-exists-p file) file | ||
| 3357 | (cdr (assoc bptno gdb-location-alist))))) | ||
| 3358 | (window (or (gdb-display-source-buffer buffer) | ||
| 3359 | (display-buffer buffer)))) | ||
| 3360 | (setq gdb-source-window window) | ||
| 3361 | (with-current-buffer buffer | ||
| 3362 | (goto-char (point-min)) | ||
| 3363 | (forward-line (1- (string-to-number line))) | ||
| 3364 | (set-window-point window (point)))))) | ||
| 3365 | (error "Not recognized as break/watchpoint line"))))) | ||
| 3366 | |||
| 3367 | |||
| 3368 | ;; Frames buffer. This displays a perpetually correct bactrack trace. | ||
| 3369 | ;; | ||
| 3370 | (def-gdb-trigger-and-handler | ||
| 3371 | gdb-invalidate-frames (gdb-current-context-command "-stack-list-frames") | ||
| 3372 | gdb-stack-list-frames-handler gdb-stack-list-frames-custom | ||
| 3373 | '(start update)) | ||
| 3374 | |||
| 3375 | (gdb-set-buffer-rules | ||
| 3376 | 'gdb-stack-buffer | ||
| 3377 | 'gdb-stack-buffer-name | ||
| 3378 | 'gdb-frames-mode | ||
| 3379 | 'gdb-invalidate-frames) | ||
| 3380 | |||
| 3381 | (defun gdb-frame-location (frame) | ||
| 3382 | "Return \" of file:line\" or \" of library\" for structure FRAME. | ||
| 3383 | |||
| 3384 | FRAME must have either \"file\" and \"line\" members or \"from\" | ||
| 3385 | member." | ||
| 3386 | (let ((file (bindat-get-field frame 'file)) | ||
| 3387 | (line (bindat-get-field frame 'line)) | ||
| 3388 | (from (bindat-get-field frame 'from))) | ||
| 3389 | (let ((res (or (and file line (concat file ":" line)) | ||
| 3390 | from))) | ||
| 3391 | (if res (concat " of " res) "")))) | ||
| 3392 | |||
| 3393 | (defun gdb-stack-list-frames-custom () | ||
| 3394 | (let ((stack (bindat-get-field (gdb-json-partial-output "frame") 'stack)) | ||
| 3395 | (table (make-gdb-table))) | ||
| 3396 | (set-marker gdb-stack-position nil) | ||
| 3397 | (dolist (frame stack) | ||
| 3398 | (gdb-table-add-row table | ||
| 3399 | (list | ||
| 3400 | (bindat-get-field frame 'level) | ||
| 3401 | "in" | ||
| 3402 | (concat | ||
| 3403 | (bindat-get-field frame 'func) | ||
| 3404 | (if gdb-stack-buffer-locations | ||
| 3405 | (gdb-frame-location frame) "") | ||
| 3406 | (if gdb-stack-buffer-addresses | ||
| 3407 | (concat " at " (bindat-get-field frame 'addr)) ""))) | ||
| 3408 | `(mouse-face highlight | ||
| 3409 | help-echo "mouse-2, RET: Select frame" | ||
| 3410 | gdb-frame ,frame))) | ||
| 3411 | (insert (gdb-table-string table " "))) | ||
| 3412 | (when (and gdb-frame-number | ||
| 3413 | (gdb-buffer-shows-main-thread-p)) | ||
| 3414 | (gdb-mark-line (1+ (string-to-number gdb-frame-number)) | ||
| 3415 | gdb-stack-position)) | ||
| 3416 | (setq mode-name | ||
| 3417 | (gdb-current-context-mode-name "Frames"))) | ||
| 3418 | |||
| 3419 | (defun gdb-stack-buffer-name () | ||
| 3420 | (gdb-current-context-buffer-name | ||
| 3421 | (concat "stack frames of " (gdb-get-target-string)))) | ||
| 3422 | |||
| 3423 | (def-gdb-display-buffer | ||
| 3424 | gdb-display-stack-buffer | ||
| 3425 | 'gdb-stack-buffer | ||
| 3426 | "Display backtrace of current stack.") | ||
| 3427 | |||
| 3428 | (def-gdb-preempt-display-buffer | ||
| 3429 | gdb-preemptively-display-stack-buffer | ||
| 3430 | 'gdb-stack-buffer nil t) | ||
| 3431 | |||
| 3432 | (def-gdb-frame-for-buffer | ||
| 3433 | gdb-frame-stack-buffer | ||
| 3434 | 'gdb-stack-buffer | ||
| 3435 | "Display backtrace of current stack in a new frame.") | ||
| 3436 | |||
| 3437 | (defvar gdb-frames-mode-map | ||
| 3438 | (let ((map (make-sparse-keymap))) | ||
| 3439 | (suppress-keymap map) | ||
| 3440 | (define-key map "q" 'kill-this-buffer) | ||
| 3441 | (define-key map "\r" 'gdb-select-frame) | ||
| 3442 | (define-key map [mouse-2] 'gdb-select-frame) | ||
| 3443 | (define-key map [follow-link] 'mouse-face) | ||
| 3444 | map)) | ||
| 3445 | |||
| 3446 | (defvar gdb-frames-font-lock-keywords | ||
| 3447 | '(("in \\([^ ]+\\)" (1 font-lock-function-name-face))) | ||
| 3448 | "Font lock keywords used in `gdb-frames-mode'.") | ||
| 3449 | |||
| 3450 | (define-derived-mode gdb-frames-mode gdb-parent-mode "Frames" | ||
| 3451 | "Major mode for gdb call stack. | ||
| 3452 | |||
| 3453 | \\{gdb-frames-mode-map}" | ||
| 3454 | (setq gdb-stack-position (make-marker)) | ||
| 3455 | (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position) | ||
| 3456 | (setq truncate-lines t) ;; Make it easier to see overlay arrow. | ||
| 3457 | (set (make-local-variable 'font-lock-defaults) | ||
| 3458 | '(gdb-frames-font-lock-keywords)) | ||
| 3459 | (run-mode-hooks 'gdb-frames-mode-hook) | ||
| 3460 | 'gdb-invalidate-frames) | ||
| 3461 | |||
| 3462 | (defun gdb-select-frame (&optional event) | ||
| 3463 | "Select the frame and display the relevant source." | ||
| 3464 | (interactive (list last-input-event)) | ||
| 3465 | (if event (posn-set-point (event-end event))) | ||
| 3466 | (let ((frame (get-text-property (point) 'gdb-frame))) | ||
| 3467 | (if frame | ||
| 3468 | (if (gdb-buffer-shows-main-thread-p) | ||
| 3469 | (let ((new-level (bindat-get-field frame 'level))) | ||
| 3470 | (setq gdb-frame-number new-level) | ||
| 3471 | (gdb-input (list (concat "-stack-select-frame " new-level) 'ignore)) | ||
| 3472 | (gdb-update)) | ||
| 3473 | (error "Could not select frame for non-current thread")) | ||
| 3474 | (error "Not recognized as frame line")))) | ||
| 3475 | |||
| 3476 | |||
| 3477 | ;; Locals buffer. | ||
| 3478 | ;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards. | ||
| 3479 | (def-gdb-trigger-and-handler | ||
| 3480 | gdb-invalidate-locals | ||
| 3481 | (concat (gdb-current-context-command "-stack-list-locals") " --simple-values") | ||
| 3482 | gdb-locals-handler gdb-locals-handler-custom | ||
| 3483 | '(start update)) | ||
| 3484 | |||
| 3485 | (gdb-set-buffer-rules | ||
| 3486 | 'gdb-locals-buffer | ||
| 3487 | 'gdb-locals-buffer-name | ||
| 3488 | 'gdb-locals-mode | ||
| 3489 | 'gdb-invalidate-locals) | ||
| 3490 | |||
| 3491 | (defvar gdb-locals-watch-map | ||
| 3492 | (let ((map (make-sparse-keymap))) | ||
| 3493 | (suppress-keymap map) | ||
| 3494 | (define-key map "\r" 'gud-watch) | ||
| 3495 | (define-key map [mouse-2] 'gud-watch) | ||
| 3496 | map) | ||
| 3497 | "Keymap to create watch expression of a complex data type local variable.") | ||
| 3498 | |||
| 3499 | (defvar gdb-edit-locals-map-1 | ||
| 3500 | (let ((map (make-sparse-keymap))) | ||
| 3501 | (suppress-keymap map) | ||
| 3502 | (define-key map "\r" 'gdb-edit-locals-value) | ||
| 3503 | (define-key map [mouse-2] 'gdb-edit-locals-value) | ||
| 3504 | map) | ||
| 3505 | "Keymap to edit value of a simple data type local variable.") | ||
| 3506 | |||
| 3507 | (defun gdb-edit-locals-value (&optional event) | ||
| 3508 | "Assign a value to a variable displayed in the locals buffer." | ||
| 3509 | (interactive (list last-input-event)) | ||
| 3510 | (save-excursion | ||
| 3511 | (if event (posn-set-point (event-end event))) | ||
| 3512 | (beginning-of-line) | ||
| 3513 | (let* ((var (bindat-get-field | ||
| 3514 | (get-text-property (point) 'gdb-local-variable) 'name)) | ||
| 3515 | (value (read-string (format "New value (%s): " var)))) | ||
| 3516 | (gud-basic-call | ||
| 3517 | (concat "-gdb-set variable " var " = " value))))) | ||
| 3518 | |||
| 3519 | ;; Dont display values of arrays or structures. | ||
| 3520 | ;; These can be expanded using gud-watch. | ||
| 3521 | (defun gdb-locals-handler-custom () | ||
| 3522 | (let ((locals-list (bindat-get-field (gdb-json-partial-output) 'locals)) | ||
| 3523 | (table (make-gdb-table))) | ||
| 3524 | (dolist (local locals-list) | ||
| 3525 | (let ((name (bindat-get-field local 'name)) | ||
| 3526 | (value (bindat-get-field local 'value)) | ||
| 3527 | (type (bindat-get-field local 'type))) | ||
| 3528 | (if (or (not value) | ||
| 3529 | (string-match "\\0x" value)) | ||
| 3530 | (add-text-properties 0 (length name) | ||
| 3531 | `(mouse-face highlight | ||
| 3532 | help-echo "mouse-2: create watch expression" | ||
| 3533 | local-map ,gdb-locals-watch-map) | ||
| 3534 | name) | ||
| 3535 | (add-text-properties 0 (length value) | ||
| 3536 | `(mouse-face highlight | ||
| 3537 | help-echo "mouse-2: edit value" | ||
| 3538 | local-map ,gdb-edit-locals-map-1) | ||
| 3539 | value)) | ||
| 3540 | (gdb-table-add-row | ||
| 3541 | table | ||
| 3542 | (list | ||
| 3543 | (propertize type 'font-lock-face font-lock-type-face) | ||
| 3544 | (propertize name 'font-lock-face font-lock-variable-name-face) | ||
| 3545 | value) | ||
| 3546 | `(gdb-local-variable ,local)))) | ||
| 3547 | (insert (gdb-table-string table " ")) | ||
| 3548 | (setq mode-name | ||
| 3549 | (gdb-current-context-mode-name | ||
| 3550 | (concat "Locals: " (bindat-get-field (gdb-current-buffer-frame) 'func)))))) | ||
| 3551 | |||
| 3552 | (defvar gdb-locals-header | ||
| 3553 | (list | ||
| 3554 | (gdb-propertize-header "Locals" gdb-locals-buffer | ||
| 3555 | nil nil mode-line) | ||
| 3556 | " " | ||
| 3557 | (gdb-propertize-header "Registers" gdb-registers-buffer | ||
| 3558 | "mouse-1: select" mode-line-highlight mode-line-inactive))) | ||
| 3559 | |||
| 3560 | (defvar gdb-locals-mode-map | ||
| 3561 | (let ((map (make-sparse-keymap))) | ||
| 3562 | (suppress-keymap map) | ||
| 3563 | (define-key map "q" 'kill-this-buffer) | ||
| 3564 | (define-key map "\t" '(lambda () | ||
| 3565 | (interactive) | ||
| 3566 | (gdb-set-window-buffer | ||
| 3567 | (gdb-get-buffer-create | ||
| 3568 | 'gdb-registers-buffer | ||
| 3569 | gdb-thread-number) t))) | ||
| 3570 | map)) | ||
| 3571 | |||
| 3572 | (define-derived-mode gdb-locals-mode gdb-parent-mode "Locals" | ||
| 3573 | "Major mode for gdb locals. | ||
| 3574 | |||
| 3575 | \\{gdb-locals-mode-map}" | ||
| 3576 | (setq header-line-format gdb-locals-header) | ||
| 3577 | (run-mode-hooks 'gdb-locals-mode-hook) | ||
| 3578 | 'gdb-invalidate-locals) | ||
| 3579 | |||
| 3580 | (defun gdb-locals-buffer-name () | ||
| 3581 | (gdb-current-context-buffer-name | ||
| 3582 | (concat "locals of " (gdb-get-target-string)))) | ||
| 3583 | |||
| 3584 | (def-gdb-display-buffer | ||
| 3585 | gdb-display-locals-buffer | ||
| 3586 | 'gdb-locals-buffer | ||
| 3587 | "Display local variables of current stack and their values.") | ||
| 3588 | |||
| 3589 | (def-gdb-preempt-display-buffer | ||
| 3590 | gdb-preemptively-display-locals-buffer | ||
| 3591 | 'gdb-locals-buffer nil t) | ||
| 3592 | |||
| 3593 | (def-gdb-frame-for-buffer | ||
| 3594 | gdb-frame-locals-buffer | ||
| 3595 | 'gdb-locals-buffer | ||
| 3596 | "Display local variables of current stack and their values in a new frame.") | ||
| 3597 | |||
| 3598 | |||
| 3599 | ;; Registers buffer. | ||
| 3600 | |||
| 3601 | (def-gdb-trigger-and-handler | ||
| 3602 | gdb-invalidate-registers | ||
| 3603 | (concat (gdb-current-context-command "-data-list-register-values") " x") | ||
| 3604 | gdb-registers-handler | ||
| 3605 | gdb-registers-handler-custom | ||
| 3606 | '(start update)) | ||
| 3607 | |||
| 3608 | (gdb-set-buffer-rules | ||
| 3609 | 'gdb-registers-buffer | ||
| 3610 | 'gdb-registers-buffer-name | ||
| 3611 | 'gdb-registers-mode | ||
| 3612 | 'gdb-invalidate-registers) | ||
| 3613 | |||
| 3614 | (defun gdb-registers-handler-custom () | ||
| 3615 | (when gdb-register-names | ||
| 3616 | (let ((register-values (bindat-get-field (gdb-json-partial-output) 'register-values)) | ||
| 3617 | (table (make-gdb-table))) | ||
| 3618 | (dolist (register register-values) | ||
| 3619 | (let* ((register-number (bindat-get-field register 'number)) | ||
| 3620 | (value (bindat-get-field register 'value)) | ||
| 3621 | (register-name (nth (string-to-number register-number) | ||
| 3622 | gdb-register-names))) | ||
| 3623 | (gdb-table-add-row | ||
| 3624 | table | ||
| 3625 | (list | ||
| 3626 | (propertize register-name 'font-lock-face font-lock-variable-name-face) | ||
| 3627 | (if (member register-number gdb-changed-registers) | ||
| 3628 | (propertize value 'font-lock-face font-lock-warning-face) | ||
| 3629 | value)) | ||
| 3630 | `(mouse-face highlight | ||
| 3631 | help-echo "mouse-2: edit value" | ||
| 3632 | gdb-register-name ,register-name)))) | ||
| 3633 | (insert (gdb-table-string table " "))) | ||
| 3634 | (setq mode-name | ||
| 3635 | (gdb-current-context-mode-name "Registers")))) | ||
| 3636 | |||
| 3637 | (defun gdb-edit-register-value (&optional event) | ||
| 3638 | "Assign a value to a register displayed in the registers buffer." | ||
| 3639 | (interactive (list last-input-event)) | ||
| 3640 | (save-excursion | ||
| 3641 | (if event (posn-set-point (event-end event))) | ||
| 3642 | (beginning-of-line) | ||
| 3643 | (let* ((var (bindat-get-field | ||
| 3644 | (get-text-property (point) 'gdb-register-name))) | ||
| 3645 | (value (read-string (format "New value (%s): " var)))) | ||
| 3646 | (gud-basic-call | ||
| 3647 | (concat "-gdb-set variable $" var " = " value))))) | ||
| 3648 | |||
| 3649 | (defvar gdb-registers-mode-map | ||
| 3650 | (let ((map (make-sparse-keymap))) | ||
| 3651 | (suppress-keymap map) | ||
| 3652 | (define-key map "\r" 'gdb-edit-register-value) | ||
| 3653 | (define-key map [mouse-2] 'gdb-edit-register-value) | ||
| 3654 | (define-key map "q" 'kill-this-buffer) | ||
| 3655 | (define-key map "\t" '(lambda () | ||
| 3656 | (interactive) | ||
| 3657 | (gdb-set-window-buffer | ||
| 3658 | (gdb-get-buffer-create | ||
| 3659 | 'gdb-locals-buffer | ||
| 3660 | gdb-thread-number) t))) | ||
| 3661 | map)) | ||
| 3662 | |||
| 3663 | (defvar gdb-registers-header | ||
| 3664 | (list | ||
| 3665 | (gdb-propertize-header "Locals" gdb-locals-buffer | ||
| 3666 | "mouse-1: select" mode-line-highlight mode-line-inactive) | ||
| 3667 | " " | ||
| 3668 | (gdb-propertize-header "Registers" gdb-registers-buffer | ||
| 3669 | nil nil mode-line))) | ||
| 3670 | |||
| 3671 | (define-derived-mode gdb-registers-mode gdb-parent-mode "Registers" | ||
| 3672 | "Major mode for gdb registers. | ||
| 3673 | |||
| 3674 | \\{gdb-registers-mode-map}" | ||
| 3675 | (setq header-line-format gdb-registers-header) | ||
| 3676 | (run-mode-hooks 'gdb-registers-mode-hook) | ||
| 3677 | 'gdb-invalidate-registers) | ||
| 3678 | |||
| 3679 | (defun gdb-registers-buffer-name () | ||
| 3680 | (gdb-current-context-buffer-name | ||
| 3681 | (concat "registers of " (gdb-get-target-string)))) | ||
| 3682 | |||
| 3683 | (def-gdb-display-buffer | ||
| 3684 | gdb-display-registers-buffer | ||
| 3685 | 'gdb-registers-buffer | ||
| 3686 | "Display integer register contents.") | ||
| 3687 | |||
| 3688 | (def-gdb-preempt-display-buffer | ||
| 3689 | gdb-preemptively-display-registers-buffer | ||
| 3690 | 'gdb-registers-buffer nil t) | ||
| 3691 | |||
| 3692 | (def-gdb-frame-for-buffer | ||
| 3693 | gdb-frame-registers-buffer | ||
| 3694 | 'gdb-registers-buffer | ||
| 3695 | "Display integer register contents in a new frame.") | ||
| 3696 | |||
| 3697 | ;; Needs GDB 6.4 onwards (used to fail with no stack). | ||
| 3698 | (defun gdb-get-changed-registers () | ||
| 3699 | (if (and (gdb-get-buffer 'gdb-registers-buffer) | ||
| 3700 | (not (gdb-pending-p 'gdb-get-changed-registers))) | ||
| 3701 | (progn | ||
| 3702 | (gdb-input | ||
| 3703 | (list | ||
| 3704 | "-data-list-changed-registers" | ||
| 3705 | 'gdb-changed-registers-handler)) | ||
| 3706 | (gdb-add-pending 'gdb-get-changed-registers)))) | ||
| 3707 | |||
| 3708 | (defun gdb-changed-registers-handler () | ||
| 3709 | (gdb-delete-pending 'gdb-get-changed-registers) | ||
| 3710 | (setq gdb-changed-registers nil) | ||
| 3711 | (dolist (register-number (bindat-get-field (gdb-json-partial-output) 'changed-registers)) | ||
| 3712 | (push register-number gdb-changed-registers))) | ||
| 3713 | |||
| 3714 | (defun gdb-register-names-handler () | ||
| 3715 | ;; Don't use gdb-pending-triggers because this handler is called | ||
| 3716 | ;; only once (in gdb-init-1) | ||
| 3717 | (setq gdb-register-names nil) | ||
| 3718 | (dolist (register-name (bindat-get-field (gdb-json-partial-output) 'register-names)) | ||
| 3719 | (push register-name gdb-register-names)) | ||
| 3720 | (setq gdb-register-names (reverse gdb-register-names))) | ||
| 3721 | |||
| 3722 | |||
| 3723 | (defun gdb-get-source-file-list () | ||
| 3724 | "Create list of source files for current GDB session. | ||
| 3725 | If buffers already exist for any of these files, gud-minor-mode | ||
| 3726 | is set in them." | ||
| 3727 | (goto-char (point-min)) | ||
| 3728 | (while (re-search-forward gdb-source-file-regexp nil t) | ||
| 3729 | (push (match-string 1) gdb-source-file-list)) | ||
| 3730 | (dolist (buffer (buffer-list)) | ||
| 3731 | (with-current-buffer buffer | ||
| 3732 | (when (member buffer-file-name gdb-source-file-list) | ||
| 3733 | (gdb-init-buffer)))) | ||
| 3734 | (gdb-force-mode-line-update | ||
| 3735 | (propertize "ready" 'face font-lock-variable-name-face))) | ||
| 3736 | |||
| 3737 | (defun gdb-get-main-selected-frame () | ||
| 3738 | "Trigger for `gdb-frame-handler' which uses main current | ||
| 3739 | thread. Called from `gdb-update'." | ||
| 3740 | (if (not (gdb-pending-p 'gdb-get-main-selected-frame)) | ||
| 3741 | (progn | ||
| 3742 | (gdb-input | ||
| 3743 | (list (gdb-current-context-command "-stack-info-frame") 'gdb-frame-handler)) | ||
| 3744 | (gdb-add-pending 'gdb-get-main-selected-frame)))) | ||
| 3745 | |||
| 3746 | (defun gdb-frame-handler () | ||
| 3747 | "Sets `gdb-selected-frame' and `gdb-selected-file' to show | ||
| 3748 | overlay arrow in source buffer." | ||
| 3749 | (gdb-delete-pending 'gdb-get-main-selected-frame) | ||
| 3750 | (let ((frame (bindat-get-field (gdb-json-partial-output) 'frame))) | ||
| 3751 | (when frame | ||
| 3752 | (setq gdb-selected-frame (bindat-get-field frame 'func)) | ||
| 3753 | (setq gdb-selected-file (bindat-get-field frame 'fullname)) | ||
| 3754 | (setq gdb-frame-number (bindat-get-field frame 'level)) | ||
| 3755 | (setq gdb-frame-address (bindat-get-field frame 'addr)) | ||
| 3756 | (let ((line (bindat-get-field frame 'line))) | ||
| 3757 | (setq gdb-selected-line (and line (string-to-number line))) | ||
| 3758 | (when (and gdb-selected-file gdb-selected-line) | ||
| 3759 | (setq gud-last-frame (cons gdb-selected-file gdb-selected-line)) | ||
| 3760 | (gud-display-frame))) | ||
| 3761 | (if gud-overlay-arrow-position | ||
| 3762 | (let ((buffer (marker-buffer gud-overlay-arrow-position)) | ||
| 3763 | (position (marker-position gud-overlay-arrow-position))) | ||
| 3764 | (when buffer | ||
| 3765 | (with-current-buffer buffer | ||
| 3766 | (setq fringe-indicator-alist | ||
| 3767 | (if (string-equal gdb-frame-number "0") | ||
| 3768 | nil | ||
| 3769 | '((overlay-arrow . hollow-right-triangle)))) | ||
| 3770 | (setq gud-overlay-arrow-position (make-marker)) | ||
| 3771 | (set-marker gud-overlay-arrow-position position)))))))) | ||
| 3772 | |||
| 3773 | (defvar gdb-prompt-name-regexp "value=\"\\(.*?\\)\"") | ||
| 3774 | |||
| 3775 | (defun gdb-get-prompt () | ||
| 3776 | "Find prompt for GDB session." | ||
| 3777 | (goto-char (point-min)) | ||
| 3778 | (setq gdb-prompt-name nil) | ||
| 3779 | (re-search-forward gdb-prompt-name-regexp nil t) | ||
| 3780 | (setq gdb-prompt-name (match-string 1)) | ||
| 3781 | ;; Insert first prompt. | ||
| 3782 | (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) | ||
| 3783 | |||
| 3784 | ;;;; Window management | ||
| 3785 | (defun gdb-display-buffer (buf dedicated &optional frame) | ||
| 3786 | "Show buffer BUF. | ||
| 3787 | |||
| 3788 | If BUF is already displayed in some window, show it, deiconifying | ||
| 3789 | the frame if necessary. Otherwise, find least recently used | ||
| 3790 | window and show BUF there, if the window is not used for GDB | ||
| 3791 | already, in which case that window is splitted first." | ||
| 3792 | (let ((answer (get-buffer-window buf (or frame 0)))) | ||
| 3793 | (if answer | ||
| 3794 | (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary. | ||
| 3795 | (let ((window (get-lru-window))) | ||
| 3796 | (if (eq (buffer-local-value 'gud-minor-mode (window-buffer window)) | ||
| 3797 | 'gdbmi) | ||
| 3798 | (let* ((largest (get-largest-window)) | ||
| 3799 | (cur-size (window-height largest))) | ||
| 3800 | (setq answer (split-window largest)) | ||
| 3801 | (set-window-buffer answer buf) | ||
| 3802 | (set-window-dedicated-p answer dedicated) | ||
| 3803 | answer) | ||
| 3804 | (set-window-buffer window buf) | ||
| 3805 | window))))) | ||
| 3806 | |||
| 3807 | (defun gdb-preempt-existing-or-display-buffer (buf &optional split-horizontal) | ||
| 3808 | "Find window displaying a buffer with the same | ||
| 3809 | `gdb-buffer-type' as BUF and show BUF there. If no such window | ||
| 3810 | exists, just call `gdb-display-buffer' for BUF. If the window | ||
| 3811 | found is already dedicated, split window according to | ||
| 3812 | SPLIT-HORIZONTAL and show BUF in the new window." | ||
| 3813 | (if buf | ||
| 3814 | (when (not (get-buffer-window buf)) | ||
| 3815 | (let* ((buf-type (gdb-buffer-type buf)) | ||
| 3816 | (existing-window | ||
| 3817 | (get-window-with-predicate | ||
| 3818 | #'(lambda (w) | ||
| 3819 | (and (eq buf-type | ||
| 3820 | (gdb-buffer-type (window-buffer w))) | ||
| 3821 | (not (window-dedicated-p w))))))) | ||
| 3822 | (if existing-window | ||
| 3823 | (set-window-buffer existing-window buf) | ||
| 3824 | (let ((dedicated-window | ||
| 3825 | (get-window-with-predicate | ||
| 3826 | #'(lambda (w) | ||
| 3827 | (eq buf-type | ||
| 3828 | (gdb-buffer-type (window-buffer w))))))) | ||
| 3829 | (if dedicated-window | ||
| 3830 | (set-window-buffer | ||
| 3831 | (split-window dedicated-window nil split-horizontal) buf) | ||
| 3832 | (gdb-display-buffer buf t)))))) | ||
| 3833 | (error "Null buffer"))) | ||
| 3834 | |||
| 3835 | ;;; Shared keymap initialization: | ||
| 3836 | |||
| 3837 | (let ((menu (make-sparse-keymap "GDB-Windows"))) | ||
| 3838 | (define-key gud-menu-map [displays] | ||
| 3839 | `(menu-item "GDB-Windows" ,menu | ||
| 3840 | :visible (eq gud-minor-mode 'gdbmi))) | ||
| 3841 | (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer)) | ||
| 3842 | (define-key menu [threads] '("Threads" . gdb-display-threads-buffer)) | ||
| 3843 | (define-key menu [memory] '("Memory" . gdb-display-memory-buffer)) | ||
| 3844 | (define-key menu [disassembly] | ||
| 3845 | '("Disassembly" . gdb-display-disassembly-buffer)) | ||
| 3846 | (define-key menu [registers] '("Registers" . gdb-display-registers-buffer)) | ||
| 3847 | (define-key menu [inferior] | ||
| 3848 | '("IO" . gdb-display-io-buffer)) | ||
| 3849 | (define-key menu [locals] '("Locals" . gdb-display-locals-buffer)) | ||
| 3850 | (define-key menu [frames] '("Stack" . gdb-display-stack-buffer)) | ||
| 3851 | (define-key menu [breakpoints] | ||
| 3852 | '("Breakpoints" . gdb-display-breakpoints-buffer))) | ||
| 3853 | |||
| 3854 | (let ((menu (make-sparse-keymap "GDB-Frames"))) | ||
| 3855 | (define-key gud-menu-map [frames] | ||
| 3856 | `(menu-item "GDB-Frames" ,menu | ||
| 3857 | :visible (eq gud-minor-mode 'gdbmi))) | ||
| 3858 | (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer)) | ||
| 3859 | (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer)) | ||
| 3860 | (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer)) | ||
| 3861 | (define-key menu [disassembly] '("Disassembly" . gdb-frame-disassembly-buffer)) | ||
| 3862 | (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer)) | ||
| 3863 | (define-key menu [inferior] | ||
| 3864 | '("IO" . gdb-frame-io-buffer)) | ||
| 3865 | (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer)) | ||
| 3866 | (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer)) | ||
| 3867 | (define-key menu [breakpoints] | ||
| 3868 | '("Breakpoints" . gdb-frame-breakpoints-buffer))) | ||
| 3869 | |||
| 3870 | (let ((menu (make-sparse-keymap "GDB-MI"))) | ||
| 3871 | (define-key menu [gdb-customize] | ||
| 3872 | '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb)) | ||
| 3873 | :help "Customize Gdb Graphical Mode options.")) | ||
| 3874 | (define-key menu [gdb-many-windows] | ||
| 3875 | '(menu-item "Display Other Windows" gdb-many-windows | ||
| 3876 | :help "Toggle display of locals, stack and breakpoint information" | ||
| 3877 | :button (:toggle . gdb-many-windows))) | ||
| 3878 | (define-key menu [gdb-restore-windows] | ||
| 3879 | '(menu-item "Restore Window Layout" gdb-restore-windows | ||
| 3880 | :help "Restore standard layout for debug session.")) | ||
| 3881 | (define-key menu [sep1] | ||
| 3882 | '(menu-item "--")) | ||
| 3883 | (define-key menu [all-threads] | ||
| 3884 | '(menu-item "GUD controls all threads" | ||
| 3885 | (lambda () | ||
| 3886 | (interactive) | ||
| 3887 | (setq gdb-gud-control-all-threads t)) | ||
| 3888 | :help "GUD start/stop commands apply to all threads" | ||
| 3889 | :button (:radio . gdb-gud-control-all-threads))) | ||
| 3890 | (define-key menu [current-thread] | ||
| 3891 | '(menu-item "GUD controls current thread" | ||
| 3892 | (lambda () | ||
| 3893 | (interactive) | ||
| 3894 | (setq gdb-gud-control-all-threads nil)) | ||
| 3895 | :help "GUD start/stop commands apply to current thread only" | ||
| 3896 | :button (:radio . (not gdb-gud-control-all-threads)))) | ||
| 3897 | (define-key menu [sep2] | ||
| 3898 | '(menu-item "--")) | ||
| 3899 | (define-key menu [gdb-customize-reasons] | ||
| 3900 | '(menu-item "Customize switching..." | ||
| 3901 | (lambda () | ||
| 3902 | (interactive) | ||
| 3903 | (customize-option 'gdb-switch-reasons)))) | ||
| 3904 | (define-key menu [gdb-switch-when-another-stopped] | ||
| 3905 | (menu-bar-make-toggle gdb-toggle-switch-when-another-stopped gdb-switch-when-another-stopped | ||
| 3906 | "Automatically switch to stopped thread" | ||
| 3907 | "GDB thread switching %s" | ||
| 3908 | "Switch to stopped thread")) | ||
| 3909 | (define-key gud-menu-map [mi] | ||
| 3910 | `(menu-item "GDB-MI" ,menu :visible (eq gud-minor-mode 'gdbmi)))) | ||
| 3911 | |||
| 3912 | ;; TODO Fit these into tool-bar-local-item-from-menu call in gud.el. | ||
| 3913 | ;; GDB-MI menu will need to be moved to gud.el. We can't use | ||
| 3914 | ;; tool-bar-local-item-from-menu here because it appends new buttons | ||
| 3915 | ;; to toolbar from right to left while we want our A/T throttle to | ||
| 3916 | ;; show up right before Run button. | ||
| 3917 | (define-key-after gud-tool-bar-map [all-threads] | ||
| 3918 | '(menu-item "Switch to non-stop/A mode" gdb-control-all-threads | ||
| 3919 | :image (find-image '((:type xpm :file "gud/thread.xpm"))) | ||
| 3920 | :visible (and (eq gud-minor-mode 'gdbmi) | ||
| 3921 | gdb-non-stop | ||
| 3922 | (not gdb-gud-control-all-threads))) | ||
| 3923 | 'run) | ||
| 3924 | |||
| 3925 | (define-key-after gud-tool-bar-map [current-thread] | ||
| 3926 | '(menu-item "Switch to non-stop/T mode" gdb-control-current-thread | ||
| 3927 | :image (find-image '((:type xpm :file "gud/all.xpm"))) | ||
| 3928 | :visible (and (eq gud-minor-mode 'gdbmi) | ||
| 3929 | gdb-non-stop | ||
| 3930 | gdb-gud-control-all-threads)) | ||
| 3931 | 'all-threads) | ||
| 3932 | |||
| 3933 | (defun gdb-frame-gdb-buffer () | ||
| 3934 | "Display GUD buffer in a new frame." | ||
| 3935 | (interactive) | ||
| 3936 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 3937 | (special-display-frame-alist | ||
| 3938 | (remove '(menu-bar-lines) (remove '(tool-bar-lines) | ||
| 3939 | gdb-frame-parameters))) | ||
| 3940 | (same-window-regexps nil)) | ||
| 3941 | (display-buffer gud-comint-buffer))) | ||
| 3942 | |||
| 3943 | (defun gdb-display-gdb-buffer () | ||
| 3944 | "Display GUD buffer." | ||
| 3945 | (interactive) | ||
| 3946 | (let ((same-window-regexps nil)) | ||
| 3947 | (select-window (display-buffer gud-comint-buffer nil 0)))) | ||
| 3948 | |||
| 3949 | (defun gdb-set-window-buffer (name &optional ignore-dedicated) | ||
| 3950 | "Set buffer of selected window to NAME and dedicate window. | ||
| 3951 | |||
| 3952 | When IGNORE-DEDICATED is non-nil, buffer is set even if selected | ||
| 3953 | window is dedicated." | ||
| 3954 | (when ignore-dedicated | ||
| 3955 | (set-window-dedicated-p (selected-window) nil)) | ||
| 3956 | (set-window-buffer (selected-window) (get-buffer name)) | ||
| 3957 | (set-window-dedicated-p (selected-window) t)) | ||
| 3958 | |||
| 3959 | (defun gdb-setup-windows () | ||
| 3960 | "Layout the window pattern for `gdb-many-windows'." | ||
| 3961 | (gdb-display-locals-buffer) | ||
| 3962 | (gdb-display-stack-buffer) | ||
| 3963 | (delete-other-windows) | ||
| 3964 | (gdb-display-breakpoints-buffer) | ||
| 3965 | (delete-other-windows) | ||
| 3966 | ; Don't dedicate. | ||
| 3967 | (pop-to-buffer gud-comint-buffer) | ||
| 3968 | (split-window nil ( / ( * (window-height) 3) 4)) | ||
| 3969 | (split-window nil ( / (window-height) 3)) | ||
| 3970 | (split-window-horizontally) | ||
| 3971 | (other-window 1) | ||
| 3972 | (gdb-set-window-buffer (gdb-locals-buffer-name)) | ||
| 3973 | (other-window 1) | ||
| 3974 | (switch-to-buffer | ||
| 3975 | (if gud-last-last-frame | ||
| 3976 | (gud-find-file (car gud-last-last-frame)) | ||
| 3977 | (if gdb-main-file | ||
| 3978 | (gud-find-file gdb-main-file) | ||
| 3979 | ;; Put buffer list in window if we | ||
| 3980 | ;; can't find a source file. | ||
| 3981 | (list-buffers-noselect)))) | ||
| 3982 | (setq gdb-source-window (selected-window)) | ||
| 3983 | (split-window-horizontally) | ||
| 3984 | (other-window 1) | ||
| 3985 | (gdb-set-window-buffer | ||
| 3986 | (gdb-get-buffer-create 'gdb-inferior-io)) | ||
| 3987 | (other-window 1) | ||
| 3988 | (gdb-set-window-buffer (gdb-stack-buffer-name)) | ||
| 3989 | (split-window-horizontally) | ||
| 3990 | (other-window 1) | ||
| 3991 | (gdb-set-window-buffer (if gdb-show-threads-by-default | ||
| 3992 | (gdb-threads-buffer-name) | ||
| 3993 | (gdb-breakpoints-buffer-name))) | ||
| 3994 | (other-window 1)) | ||
| 3995 | |||
| 3996 | (defcustom gdb-many-windows nil | ||
| 3997 | "If nil just pop up the GUD buffer unless `gdb-show-main' is t. | ||
| 3998 | In this case it starts with two windows: one displaying the GUD | ||
| 3999 | buffer and the other with the source file with the main routine | ||
| 4000 | of the debugged program. Non-nil means display the layout shown for | ||
| 4001 | `gdb'." | ||
| 4002 | :type 'boolean | ||
| 4003 | :group 'gdb | ||
| 4004 | :version "22.1") | ||
| 4005 | |||
| 4006 | (defun gdb-many-windows (arg) | ||
| 4007 | "Toggle the number of windows in the basic arrangement. | ||
| 4008 | With arg, display additional buffers iff arg is positive." | ||
| 4009 | (interactive "P") | ||
| 4010 | (setq gdb-many-windows | ||
| 4011 | (if (null arg) | ||
| 4012 | (not gdb-many-windows) | ||
| 4013 | (> (prefix-numeric-value arg) 0))) | ||
| 4014 | (message (format "Display of other windows %sabled" | ||
| 4015 | (if gdb-many-windows "en" "dis"))) | ||
| 4016 | (if (and gud-comint-buffer | ||
| 4017 | (buffer-name gud-comint-buffer)) | ||
| 4018 | (condition-case nil | ||
| 4019 | (gdb-restore-windows) | ||
| 4020 | (error nil)))) | ||
| 4021 | |||
| 4022 | (defun gdb-restore-windows () | ||
| 4023 | "Restore the basic arrangement of windows used by gdb. | ||
| 4024 | This arrangement depends on the value of `gdb-many-windows'." | ||
| 4025 | (interactive) | ||
| 4026 | (pop-to-buffer gud-comint-buffer) ;Select the right window and frame. | ||
| 4027 | (delete-other-windows) | ||
| 4028 | (if gdb-many-windows | ||
| 4029 | (gdb-setup-windows) | ||
| 4030 | (when (or gud-last-last-frame gdb-show-main) | ||
| 4031 | (split-window) | ||
| 4032 | (other-window 1) | ||
| 4033 | (switch-to-buffer | ||
| 4034 | (if gud-last-last-frame | ||
| 4035 | (gud-find-file (car gud-last-last-frame)) | ||
| 4036 | (gud-find-file gdb-main-file))) | ||
| 4037 | (setq gdb-source-window (selected-window)) | ||
| 4038 | (other-window 1)))) | ||
| 4039 | |||
| 4040 | (defun gdb-reset () | ||
| 4041 | "Exit a debugging session cleanly. | ||
| 4042 | Kills the gdb buffers, and resets variables and the source buffers." | ||
| 4043 | (dolist (buffer (buffer-list)) | ||
| 4044 | (unless (eq buffer gud-comint-buffer) | ||
| 4045 | (with-current-buffer buffer | ||
| 4046 | (if (eq gud-minor-mode 'gdbmi) | ||
| 4047 | (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name)) | ||
| 4048 | (kill-buffer nil) | ||
| 4049 | (gdb-remove-breakpoint-icons (point-min) (point-max) t) | ||
| 4050 | (setq gud-minor-mode nil) | ||
| 4051 | (kill-local-variable 'tool-bar-map) | ||
| 4052 | (kill-local-variable 'gdb-define-alist)))))) | ||
| 4053 | (setq gdb-disassembly-position nil) | ||
| 4054 | (setq overlay-arrow-variable-list | ||
| 4055 | (delq 'gdb-disassembly-position overlay-arrow-variable-list)) | ||
| 4056 | (setq fringe-indicator-alist '((overlay-arrow . right-triangle))) | ||
| 4057 | (setq gdb-stack-position nil) | ||
| 4058 | (setq overlay-arrow-variable-list | ||
| 4059 | (delq 'gdb-stack-position overlay-arrow-variable-list)) | ||
| 4060 | (setq gdb-thread-position nil) | ||
| 4061 | (setq overlay-arrow-variable-list | ||
| 4062 | (delq 'gdb-thread-position overlay-arrow-variable-list)) | ||
| 4063 | (if (boundp 'speedbar-frame) (speedbar-timer-fn)) | ||
| 4064 | (setq gud-running nil) | ||
| 4065 | (setq gdb-active-process nil) | ||
| 4066 | (remove-hook 'after-save-hook 'gdb-create-define-alist t)) | ||
| 4067 | |||
| 4068 | (defun gdb-get-source-file () | ||
| 4069 | "Find the source file where the program starts and display it with related | ||
| 4070 | buffers, if required." | ||
| 4071 | (goto-char (point-min)) | ||
| 4072 | (if (re-search-forward gdb-source-file-regexp nil t) | ||
| 4073 | (setq gdb-main-file (match-string 1))) | ||
| 4074 | (if gdb-many-windows | ||
| 4075 | (gdb-setup-windows) | ||
| 4076 | (gdb-get-buffer-create 'gdb-breakpoints-buffer) | ||
| 4077 | (if gdb-show-main | ||
| 4078 | (let ((pop-up-windows t)) | ||
| 4079 | (display-buffer (gud-find-file gdb-main-file)))))) | ||
| 4080 | |||
| 4081 | ;;from put-image | ||
| 4082 | (defun gdb-put-string (putstring pos &optional dprop &rest sprops) | ||
| 4083 | "Put string PUTSTRING in front of POS in the current buffer. | ||
| 4084 | PUTSTRING is displayed by putting an overlay into the current buffer with a | ||
| 4085 | `before-string' string that has a `display' property whose value is | ||
| 4086 | PUTSTRING." | ||
| 4087 | (let ((string (make-string 1 ?x)) | ||
| 4088 | (buffer (current-buffer))) | ||
| 4089 | (setq putstring (copy-sequence putstring)) | ||
| 4090 | (let ((overlay (make-overlay pos pos buffer)) | ||
| 4091 | (prop (or dprop | ||
| 4092 | (list (list 'margin 'left-margin) putstring)))) | ||
| 4093 | (put-text-property 0 1 'display prop string) | ||
| 4094 | (if sprops | ||
| 4095 | (add-text-properties 0 1 sprops string)) | ||
| 4096 | (overlay-put overlay 'put-break t) | ||
| 4097 | (overlay-put overlay 'before-string string)))) | ||
| 4098 | |||
| 4099 | ;;from remove-images | ||
| 4100 | (defun gdb-remove-strings (start end &optional buffer) | ||
| 4101 | "Remove strings between START and END in BUFFER. | ||
| 4102 | Remove only strings that were put in BUFFER with calls to `gdb-put-string'. | ||
| 4103 | BUFFER nil or omitted means use the current buffer." | ||
| 4104 | (unless buffer | ||
| 4105 | (setq buffer (current-buffer))) | ||
| 4106 | (dolist (overlay (overlays-in start end)) | ||
| 4107 | (when (overlay-get overlay 'put-break) | ||
| 4108 | (delete-overlay overlay)))) | ||
| 4109 | |||
| 4110 | (defun gdb-put-breakpoint-icon (enabled bptno &optional line) | ||
| 4111 | (let* ((posns (gdb-line-posns (or line (line-number-at-pos)))) | ||
| 4112 | (start (- (car posns) 1)) | ||
| 4113 | (end (+ (cdr posns) 1)) | ||
| 4114 | (putstring (if enabled "B" "b")) | ||
| 4115 | (source-window (get-buffer-window (current-buffer) 0))) | ||
| 4116 | (add-text-properties | ||
| 4117 | 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt") | ||
| 4118 | putstring) | ||
| 4119 | (if enabled | ||
| 4120 | (add-text-properties | ||
| 4121 | 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring) | ||
| 4122 | (add-text-properties | ||
| 4123 | 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring)) | ||
| 4124 | (gdb-remove-breakpoint-icons start end) | ||
| 4125 | (if (display-images-p) | ||
| 4126 | (if (>= (or left-fringe-width | ||
| 4127 | (if source-window (car (window-fringes source-window))) | ||
| 4128 | gdb-buffer-fringe-width) 8) | ||
| 4129 | (gdb-put-string | ||
| 4130 | nil (1+ start) | ||
| 4131 | `(left-fringe breakpoint | ||
| 4132 | ,(if enabled | ||
| 4133 | 'breakpoint-enabled | ||
| 4134 | 'breakpoint-disabled)) | ||
| 4135 | 'gdb-bptno bptno | ||
| 4136 | 'gdb-enabled enabled) | ||
| 4137 | (when (< left-margin-width 2) | ||
| 4138 | (save-current-buffer | ||
| 4139 | (setq left-margin-width 2) | ||
| 4140 | (if source-window | ||
| 4141 | (set-window-margins | ||
| 4142 | source-window | ||
| 4143 | left-margin-width right-margin-width)))) | ||
| 4144 | (put-image | ||
| 4145 | (if enabled | ||
| 4146 | (or breakpoint-enabled-icon | ||
| 4147 | (setq breakpoint-enabled-icon | ||
| 4148 | (find-image `((:type xpm :data | ||
| 4149 | ,breakpoint-xpm-data | ||
| 4150 | :ascent 100 :pointer hand) | ||
| 4151 | (:type pbm :data | ||
| 4152 | ,breakpoint-enabled-pbm-data | ||
| 4153 | :ascent 100 :pointer hand))))) | ||
| 4154 | (or breakpoint-disabled-icon | ||
| 4155 | (setq breakpoint-disabled-icon | ||
| 4156 | (find-image `((:type xpm :data | ||
| 4157 | ,breakpoint-xpm-data | ||
| 4158 | :conversion disabled | ||
| 4159 | :ascent 100 :pointer hand) | ||
| 4160 | (:type pbm :data | ||
| 4161 | ,breakpoint-disabled-pbm-data | ||
| 4162 | :ascent 100 :pointer hand)))))) | ||
| 4163 | (+ start 1) | ||
| 4164 | putstring | ||
| 4165 | 'left-margin)) | ||
| 4166 | (when (< left-margin-width 2) | ||
| 4167 | (save-current-buffer | ||
| 4168 | (setq left-margin-width 2) | ||
| 4169 | (let ((window (get-buffer-window (current-buffer) 0))) | ||
| 4170 | (if window | ||
| 4171 | (set-window-margins | ||
| 4172 | window left-margin-width right-margin-width))))) | ||
| 4173 | (gdb-put-string | ||
| 4174 | (propertize putstring | ||
| 4175 | 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled)) | ||
| 4176 | (1+ start))))) | ||
| 4177 | |||
| 4178 | (defun gdb-remove-breakpoint-icons (start end &optional remove-margin) | ||
| 4179 | (gdb-remove-strings start end) | ||
| 4180 | (if (display-images-p) | ||
| 4181 | (remove-images start end)) | ||
| 4182 | (when remove-margin | ||
| 4183 | (setq left-margin-width 0) | ||
| 4184 | (let ((window (get-buffer-window (current-buffer) 0))) | ||
| 4185 | (if window | ||
| 4186 | (set-window-margins | ||
| 4187 | window left-margin-width right-margin-width))))) | ||
| 4188 | |||
| 4189 | (provide 'gdb-mi) | ||
| 4190 | |||
| 4191 | ;; arch-tag: 1b41ea2b-f364-4cec-8f35-e02e4fe01912 | ||
| 4192 | ;;; gdb-mi.el ends here | ||
diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el new file mode 100644 index 00000000000..6a8ca89cda5 --- /dev/null +++ b/lisp/progmodes/gdb-ui.el | |||
| @@ -0,0 +1,4129 @@ | |||
| 1 | ;;; gdb-ui.el --- User Interface for running GDB | ||
| 2 | |||
| 3 | ;; Author: Nick Roberts <nickrob@gnu.org> | ||
| 4 | ;; Maintainer: FSF | ||
| 5 | ;; Keywords: unix, tools | ||
| 6 | |||
| 7 | ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 | ||
| 8 | ;; Free Software Foundation, Inc. | ||
| 9 | |||
| 10 | ;; This file is part of GNU Emacs. | ||
| 11 | |||
| 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 13 | ;; it under the terms of the GNU General Public License as published by | ||
| 14 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 15 | ;; (at your option) any later version. | ||
| 16 | |||
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 20 | ;; GNU General Public License for more details. | ||
| 21 | |||
| 22 | ;; You should have received a copy of the GNU General Public License | ||
| 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 24 | |||
| 25 | ;;; Commentary: | ||
| 26 | |||
| 27 | ;; This mode acts as a graphical user interface to GDB. You can interact with | ||
| 28 | ;; GDB through the GUD buffer in the usual way, but there are also further | ||
| 29 | ;; buffers which control the execution and describe the state of your program. | ||
| 30 | ;; It separates the input/output of your program from that of GDB, if | ||
| 31 | ;; required, and watches expressions in the speedbar. It also uses features of | ||
| 32 | ;; Emacs 21 such as the fringe/display margin for breakpoints, and the toolbar | ||
| 33 | ;; (see the GDB Graphical Interface section in the Emacs info manual). | ||
| 34 | |||
| 35 | ;; By default, M-x gdb will start the debugger. | ||
| 36 | |||
| 37 | ;; This file has evolved from gdba.el that was included with GDB 5.0 and | ||
| 38 | ;; written by Tom Lord and Jim Kingdon. It uses GDB's annotation interface. | ||
| 39 | ;; You don't need to know about annotations to use this mode as a debugger, | ||
| 40 | ;; but if you are interested developing the mode itself, see the Annotations | ||
| 41 | ;; section in the GDB info manual. | ||
| 42 | |||
| 43 | ;; GDB developers plan to make the annotation interface obsolete. A new | ||
| 44 | ;; interface called GDB/MI (machine interface) has been designed to replace it. | ||
| 45 | ;; Some GDB/MI commands are used in this file through the CLI command | ||
| 46 | ;; 'interpreter mi <mi-command>'. To help with the process of fully migrating | ||
| 47 | ;; Emacs from annotations to GDB/MI, there is an experimental package called | ||
| 48 | ;; gdb-mi in the Emacs Lisp Package Archive ("http://tromey.com/elpa/"). It | ||
| 49 | ;; comprises of modified gud.el and a file called gdb-mi.el which replaces | ||
| 50 | ;; gdb-ui.el. When installed, this overrides the current files and invoking | ||
| 51 | ;; M-x gdb will use GDB/MI directly (starts with "gdb -i=mi"). When deleted | ||
| 52 | ;; ('d' followed by 'x' in Package Menu mode), the files are deleted and old | ||
| 53 | ;; functionality restored. This provides a convenient way to review the | ||
| 54 | ;; current status/contribute to its improvement. For someone who just wants to | ||
| 55 | ;; use GDB, however, the current mode in Emacs 22 is a much better option. | ||
| 56 | ;; There is also a file, also called gdb-mi.el, a version of which is included | ||
| 57 | ;; the GDB distribution. This will probably only work with versions | ||
| 58 | ;; distributed with GDB 6.5 or later. Unlike the version in ELPA it works on | ||
| 59 | ;; top of gdb-ui.el and you can only start it with M-x gdbmi. | ||
| 60 | |||
| 61 | ;; This mode SHOULD WORK WITH GDB 5.0 or later but you will NEED AT LEAST | ||
| 62 | ;; GDB 6.0 to use watch expressions. It works best with GDB 6.4 or later | ||
| 63 | ;; where watch expressions will update more quickly. | ||
| 64 | |||
| 65 | ;;; Windows Platforms: | ||
| 66 | |||
| 67 | ;; If you are using Emacs and GDB on Windows you will need to flush the buffer | ||
| 68 | ;; explicitly in your program if you want timely display of I/O in Emacs. | ||
| 69 | ;; Alternatively you can make the output stream unbuffered, for example, by | ||
| 70 | ;; using a macro: | ||
| 71 | |||
| 72 | ;; #ifdef UNBUFFERED | ||
| 73 | ;; setvbuf (stdout, (char *) NULL, _IONBF, 0); | ||
| 74 | ;; #endif | ||
| 75 | |||
| 76 | ;; and compiling with -DUNBUFFERED while debugging. | ||
| 77 | |||
| 78 | ;; If you are using Cygwin GDB and find that the source is not being displayed | ||
| 79 | ;; in Emacs when you step through it, possible solutions are to: | ||
| 80 | |||
| 81 | ;; 1) Use Cygwin X Windows and Cygwin Emacs. | ||
| 82 | ;; (Since 22.1 Emacs builds under Cygwin.) | ||
| 83 | ;; 2) Use MinGW GDB instead. | ||
| 84 | ;; 3) Use cygwin-mount.el | ||
| 85 | |||
| 86 | ;;; Mac OSX: | ||
| 87 | |||
| 88 | ;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made | ||
| 89 | ;; some changes to the version that they include as part of Mac OSX. | ||
| 90 | ;; This requires GDB version 7.0 or later (estimated release date June 2009) | ||
| 91 | ;; as earlier versions don not compile on Mac OSX. | ||
| 92 | |||
| 93 | ;;; Known Bugs: | ||
| 94 | |||
| 95 | ;; 1) Cannot handle multiple debug sessions. | ||
| 96 | ;; 2) If you wish to call procedures from your program in GDB | ||
| 97 | ;; e.g "call myproc ()", "p mysquare (5)" then use level 2 annotations | ||
| 98 | ;; "gdb --annotate=2 myprog" to keep source buffer/selected frame fixed. | ||
| 99 | ;; 3) After detaching from a process, clicking on the "GO" icon on toolbar | ||
| 100 | ;; (gud-go) sends "continue" to GDB (should be "run"). | ||
| 101 | |||
| 102 | ;;; TODO: | ||
| 103 | |||
| 104 | ;; 1) Use MI command -data-read-memory for memory window. | ||
| 105 | ;; 2) Use tree-buffer.el (from ECB) instead of the speedbar for | ||
| 106 | ;; watch-expressions? Handling of watch-expressions needs to be | ||
| 107 | ;; overhauled to work for large arrays/structures by creating variable | ||
| 108 | ;; objects for visible watch-expressions only. | ||
| 109 | ;; 3) Mark breakpoint locations on scroll-bar of source buffer? | ||
| 110 | |||
| 111 | ;;; Code: | ||
| 112 | |||
| 113 | (require 'gud) | ||
| 114 | (require 'json) | ||
| 115 | (require 'bindat) | ||
| 116 | |||
| 117 | (defvar tool-bar-map) | ||
| 118 | (defvar speedbar-initial-expansion-list-name) | ||
| 119 | (defvar speedbar-frame) | ||
| 120 | |||
| 121 | (defvar gdb-pc-address nil "Initialization for Assembler buffer. | ||
| 122 | Set to \"main\" at start if `gdb-show-main' is t.") | ||
| 123 | (defvar gdb-frame-address nil "Identity of frame for watch expression.") | ||
| 124 | (defvar gdb-previous-frame-pc-address nil) | ||
| 125 | (defvar gdb-memory-address "main") | ||
| 126 | (defvar gdb-previous-frame nil) | ||
| 127 | (defvar gdb-selected-frame nil) | ||
| 128 | (defvar gdb-frame-number nil) | ||
| 129 | (defvar gdb-current-language nil) | ||
| 130 | (defvar gdb-var-list nil | ||
| 131 | "List of variables in watch window. | ||
| 132 | Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP) | ||
| 133 | where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame | ||
| 134 | address for root variables.") | ||
| 135 | (defvar gdb-main-file nil "Source file from which program execution begins.") | ||
| 136 | (defvar gud-old-arrow nil) | ||
| 137 | (defvar gdb-thread-indicator nil) | ||
| 138 | (defvar gdb-overlay-arrow-position nil) | ||
| 139 | (defvar gdb-stack-position nil) | ||
| 140 | (defvar gdb-server-prefix nil) | ||
| 141 | (defvar gdb-flush-pending-output nil) | ||
| 142 | (defvar gdb-location-alist nil | ||
| 143 | "Alist of breakpoint numbers and full filenames. Only used for files that | ||
| 144 | Emacs can't find.") | ||
| 145 | (defvar gdb-active-process nil | ||
| 146 | "GUD tooltips display variable values when t, and macro definitions otherwise.") | ||
| 147 | (defvar gdb-recording nil | ||
| 148 | "If t, then record session for playback and reverse execution") | ||
| 149 | (defvar gdb-error "Non-nil when GDB is reporting an error.") | ||
| 150 | (defvar gdb-macro-info nil | ||
| 151 | "Non-nil if GDB knows that the inferior includes preprocessor macro info.") | ||
| 152 | (defvar gdb-buffer-fringe-width nil) | ||
| 153 | (defvar gdb-signalled nil) | ||
| 154 | (defvar gdb-source-window nil) | ||
| 155 | (defvar gdb-inferior-status nil) | ||
| 156 | (defvar gdb-continuation nil) | ||
| 157 | (defvar gdb-look-up-stack nil) | ||
| 158 | (defvar gdb-frame-begin nil | ||
| 159 | "Non-nil when GDB generates frame-begin annotation.") | ||
| 160 | (defvar gdb-printing t) | ||
| 161 | (defvar gdb-parent-bptno-enabled nil) | ||
| 162 | (defvar gdb-ready nil) | ||
| 163 | (defvar gdb-stack-update nil) | ||
| 164 | (defvar gdb-early-user-input nil) | ||
| 165 | |||
| 166 | (defvar gdb-buffer-type nil | ||
| 167 | "One of the symbols bound in `gdb-buffer-rules'.") | ||
| 168 | (make-variable-buffer-local 'gdb-buffer-type) | ||
| 169 | |||
| 170 | (defvar gdb-input-queue () | ||
| 171 | "A list of gdb command objects.") | ||
| 172 | |||
| 173 | (defvar gdb-prompting nil | ||
| 174 | "True when gdb is idle with no pending input.") | ||
| 175 | |||
| 176 | (defvar gdb-output-sink nil | ||
| 177 | "The disposition of the output of the current gdb command. | ||
| 178 | Possible values are these symbols: | ||
| 179 | |||
| 180 | `user' -- gdb output should be copied to the GUD buffer | ||
| 181 | for the user to see. | ||
| 182 | |||
| 183 | `inferior' -- gdb output should be copied to the inferior-io buffer. | ||
| 184 | |||
| 185 | `pre-emacs' -- output should be ignored util the post-prompt | ||
| 186 | annotation is received. Then the output-sink | ||
| 187 | becomes:... | ||
| 188 | `emacs' -- output should be collected in the partial-output-buffer | ||
| 189 | for subsequent processing by a command. This is the | ||
| 190 | disposition of output generated by commands that | ||
| 191 | gdb mode sends to gdb on its own behalf. | ||
| 192 | `post-emacs' -- ignore output until the prompt annotation is | ||
| 193 | received, then go to USER disposition. | ||
| 194 | |||
| 195 | gdba (gdb-ui.el) uses all five values, gdbmi (gdb-mi.el) only two | ||
| 196 | \(`user' and `emacs').") | ||
| 197 | |||
| 198 | (defvar gdb-current-item nil | ||
| 199 | "The most recent command item sent to gdb.") | ||
| 200 | |||
| 201 | (defvar gdb-pending-triggers '() | ||
| 202 | "A list of trigger functions that have run later than their output handlers.") | ||
| 203 | |||
| 204 | (defvar gdb-first-post-prompt nil) | ||
| 205 | (defvar gdb-version nil) | ||
| 206 | (defvar gdb-locals-font-lock-keywords nil) | ||
| 207 | (defvar gdb-source-file-list nil | ||
| 208 | "List of source files for the current executable.") | ||
| 209 | (defconst gdb-error-regexp "\\^error,msg=\"\\(.+\\)\"") | ||
| 210 | |||
| 211 | (defvar gdb-locals-font-lock-keywords-1 | ||
| 212 | '(;; var = (struct struct_tag) value | ||
| 213 | ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(struct\\) \\(\\(\\sw\\|[_.]\\)+\\)" | ||
| 214 | (1 font-lock-variable-name-face) | ||
| 215 | (3 font-lock-keyword-face) | ||
| 216 | (4 font-lock-type-face)) | ||
| 217 | ;; var = (type) value | ||
| 218 | ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(\\(\\sw\\|[_.]\\)+\\)" | ||
| 219 | (1 font-lock-variable-name-face) | ||
| 220 | (3 font-lock-type-face)) | ||
| 221 | ;; var = val | ||
| 222 | ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +[^(]" | ||
| 223 | (1 font-lock-variable-name-face))) | ||
| 224 | "Font lock keywords used in `gdb-local-mode'.") | ||
| 225 | |||
| 226 | (defvar gdb-locals-font-lock-keywords-2 | ||
| 227 | '(;; var = type value | ||
| 228 | ( "\\(^\\(\\sw\\|[_.]\\)+\\)\t+\\(\\(\\sw\\|[_.]\\)+\\)" | ||
| 229 | (1 font-lock-variable-name-face) | ||
| 230 | (3 font-lock-type-face))) | ||
| 231 | "Font lock keywords used in `gdb-local-mode'.") | ||
| 232 | |||
| 233 | ;; Variables for GDB 6.4+ | ||
| 234 | (defvar gdb-register-names nil "List of register names.") | ||
| 235 | (defvar gdb-changed-registers nil | ||
| 236 | "List of changed register numbers (strings).") | ||
| 237 | |||
| 238 | ;;;###autoload | ||
| 239 | (defun gdb (command-line) | ||
| 240 | "Run gdb on program FILE in buffer *gud-FILE*. | ||
| 241 | The directory containing FILE becomes the initial working | ||
| 242 | directory and source-file directory for your debugger. | ||
| 243 | |||
| 244 | If `gdb-many-windows' is nil (the default value) then gdb just | ||
| 245 | pops up the GUD buffer unless `gdb-show-main' is t. In this case | ||
| 246 | it starts with two windows: one displaying the GUD buffer and the | ||
| 247 | other with the source file with the main routine of the inferior. | ||
| 248 | |||
| 249 | If `gdb-many-windows' is t, regardless of the value of | ||
| 250 | `gdb-show-main', the layout below will appear unless | ||
| 251 | `gdb-use-separate-io-buffer' is nil when the source buffer | ||
| 252 | occupies the full width of the frame. Keybindings are shown in | ||
| 253 | some of the buffers. | ||
| 254 | |||
| 255 | Watch expressions appear in the speedbar/slowbar. | ||
| 256 | |||
| 257 | The following commands help control operation : | ||
| 258 | |||
| 259 | `gdb-many-windows' - Toggle the number of windows gdb uses. | ||
| 260 | `gdb-restore-windows' - To restore the window layout. | ||
| 261 | |||
| 262 | See Info node `(emacs)GDB Graphical Interface' for a more | ||
| 263 | detailed description of this mode. | ||
| 264 | |||
| 265 | +----------------------------------------------------------------------+ | ||
| 266 | | GDB Toolbar | | ||
| 267 | +-----------------------------------+----------------------------------+ | ||
| 268 | | GUD buffer (I/O of GDB) | Locals buffer | | ||
| 269 | |-----------------------------------+----------------------------------+ | ||
| 270 | | | | | ||
| 271 | | Source buffer | I/O buffer for debugged program | | ||
| 272 | | | | | ||
| 273 | |-----------------------------------+----------------------------------+ | ||
| 274 | | Stack buffer | Breakpoints/threads buffer | | ||
| 275 | +-----------------------------------+----------------------------------+ | ||
| 276 | |||
| 277 | The option \"--annotate=3\" must be included in this value. To | ||
| 278 | run GDB in text command mode, use `gud-gdb'. You need to use | ||
| 279 | text command mode to debug multiple programs within one Emacs | ||
| 280 | session." | ||
| 281 | (interactive (list (gud-query-cmdline 'gdb))) | ||
| 282 | |||
| 283 | (when (and gud-comint-buffer | ||
| 284 | (buffer-name gud-comint-buffer) | ||
| 285 | (get-buffer-process gud-comint-buffer) | ||
| 286 | (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) | ||
| 287 | (gdb-restore-windows) | ||
| 288 | (error | ||
| 289 | "Multiple debugging requires restarting in text command mode")) | ||
| 290 | |||
| 291 | (gud-common-init command-line nil 'gud-gdba-marker-filter) | ||
| 292 | (set (make-local-variable 'gud-minor-mode) 'gdba) | ||
| 293 | (setq comint-input-sender 'gdb-send) | ||
| 294 | |||
| 295 | (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") | ||
| 296 | (gud-def gud-tbreak "tbreak %f:%l" "\C-t" | ||
| 297 | "Set temporary breakpoint at current line.") | ||
| 298 | (gud-def gud-remove "clear %f:%l" "\C-d" "Remove breakpoint at current line.") | ||
| 299 | (gud-def gud-step "step %p" "\C-s" "Step one source line with display.") | ||
| 300 | (gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.") | ||
| 301 | (gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).") | ||
| 302 | (gud-def gud-nexti "nexti %p" nil "Step one instruction (skip functions).") | ||
| 303 | (gud-def gud-cont "continue" "\C-r" "Continue with display.") | ||
| 304 | (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") | ||
| 305 | (gud-def gud-jump | ||
| 306 | (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) | ||
| 307 | "\C-j" "Set execution address to current line.") | ||
| 308 | |||
| 309 | (gud-def gud-rstep "reverse-step %p" nil "Reverse step one source line with display.") | ||
| 310 | (gud-def gud-rstepi "reverse-stepi %p" nil "Reverse step one instruction with display.") | ||
| 311 | (gud-def gud-rnext "reverse-next %p" nil "Reverse step one line (skip functions).") | ||
| 312 | (gud-def gud-rnexti "reverse-nexti %p" nil "Reverse step one instruction (skip functions).") | ||
| 313 | (gud-def gud-rcont "reverse-continue" nil "Reverse continue with display.") | ||
| 314 | (gud-def gud-rfinish "reverse-finish" nil "Reverse finish executing current function.") | ||
| 315 | |||
| 316 | (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") | ||
| 317 | (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") | ||
| 318 | (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") | ||
| 319 | (gud-def gud-pstar "print* %e" nil | ||
| 320 | "Evaluate C dereferenced pointer expression at point.") | ||
| 321 | |||
| 322 | ;; For debugging Emacs only. | ||
| 323 | (gud-def gud-pv "pv1 %e" "\C-v" "Print the value of the lisp variable.") | ||
| 324 | |||
| 325 | (gud-def gud-until "until %l" "\C-u" "Continue to current line.") | ||
| 326 | (gud-def gud-run "run" nil "Run the program.") | ||
| 327 | |||
| 328 | (local-set-key "\C-i" 'gud-gdb-complete-command) | ||
| 329 | (setq comint-prompt-regexp "^(.*gdb[+]?) *") | ||
| 330 | (setq paragraph-start comint-prompt-regexp) | ||
| 331 | (setq gdb-output-sink 'user) | ||
| 332 | (setq gdb-first-prompt t) | ||
| 333 | (setq gud-running nil) | ||
| 334 | (setq gdb-ready nil) | ||
| 335 | (setq gdb-stack-update nil) | ||
| 336 | (setq gdb-flush-pending-output nil) | ||
| 337 | (setq gdb-early-user-input nil) | ||
| 338 | (setq gud-filter-pending-text nil) | ||
| 339 | (gdb-thread-identification) | ||
| 340 | (run-hooks 'gdb-mode-hook)) | ||
| 341 | |||
| 342 | ;; Keep as an alias for compatibility with Emacs 22.1. | ||
| 343 | ;;;###autoload | ||
| 344 | (defalias 'gdba 'gdb) | ||
| 345 | |||
| 346 | (defgroup gdb nil | ||
| 347 | "Gdb Graphical Mode options specifically for running Gdb in Emacs." | ||
| 348 | :group 'processes | ||
| 349 | :group 'tools) | ||
| 350 | |||
| 351 | (defcustom gdb-debug-log-max 128 | ||
| 352 | "Maximum size of `gdb-debug-log'. If nil, size is unlimited." | ||
| 353 | :group 'gdb | ||
| 354 | :type '(choice (integer :tag "Number of elements") | ||
| 355 | (const :tag "Unlimited" nil)) | ||
| 356 | :version "22.1") | ||
| 357 | |||
| 358 | (defvar gdb-debug-log nil | ||
| 359 | "List of commands sent to and replies received from GDB. | ||
| 360 | Most recent commands are listed first. This list stores only the last | ||
| 361 | `gdb-debug-log-max' values. This variable is used to debug GDB-UI.") | ||
| 362 | |||
| 363 | ;;;###autoload | ||
| 364 | (defcustom gdb-enable-debug nil | ||
| 365 | "Non-nil means record the process input and output in `gdb-debug-log'." | ||
| 366 | :type 'boolean | ||
| 367 | :group 'gdb | ||
| 368 | :version "22.1") | ||
| 369 | |||
| 370 | (defcustom gdb-cpp-define-alist-program "gcc -E -dM -" | ||
| 371 | "Shell command for generating a list of defined macros in a source file. | ||
| 372 | This list is used to display the #define directive associated | ||
| 373 | with an identifier as a tooltip. It works in a debug session with | ||
| 374 | GDB, when `gud-tooltip-mode' is t. | ||
| 375 | |||
| 376 | Set `gdb-cpp-define-alist-flags' for any include paths or | ||
| 377 | predefined macros." | ||
| 378 | :type 'string | ||
| 379 | :group 'gdb | ||
| 380 | :version "22.1") | ||
| 381 | |||
| 382 | (defcustom gdb-cpp-define-alist-flags "" | ||
| 383 | "Preprocessor flags for `gdb-cpp-define-alist-program'." | ||
| 384 | :type 'string | ||
| 385 | :group 'gdb | ||
| 386 | :version "22.1") | ||
| 387 | |||
| 388 | (defcustom gdb-create-source-file-list t | ||
| 389 | "Non-nil means create a list of files from which the executable was built. | ||
| 390 | Set this to nil if the GUD buffer displays \"initializing...\" in the mode | ||
| 391 | line for a long time when starting, possibly because your executable was | ||
| 392 | built from a large number of files. This allows quicker initialization | ||
| 393 | but means that these files are not automatically enabled for debugging, | ||
| 394 | e.g., you won't be able to click in the fringe to set a breakpoint until | ||
| 395 | execution has already stopped there." | ||
| 396 | :type 'boolean | ||
| 397 | :group 'gdb | ||
| 398 | :version "23.1") | ||
| 399 | |||
| 400 | (defcustom gdb-show-main nil | ||
| 401 | "Non-nil means display source file containing the main routine at startup. | ||
| 402 | Also display the main routine in the disassembly buffer if present." | ||
| 403 | :type 'boolean | ||
| 404 | :group 'gdb | ||
| 405 | :version "22.1") | ||
| 406 | |||
| 407 | (defcustom gdb-many-windows nil | ||
| 408 | "If nil, just pop up the GUD buffer unless `gdb-show-main' is t. | ||
| 409 | In this case start with two windows: one displaying the GUD | ||
| 410 | buffer and the other with the source file with the main routine | ||
| 411 | of the debugged program. Non-nil means display the layout shown | ||
| 412 | for `gdba'." | ||
| 413 | :type 'boolean | ||
| 414 | :group 'gdb | ||
| 415 | :version "22.1") | ||
| 416 | |||
| 417 | (defcustom gdb-use-separate-io-buffer nil | ||
| 418 | "Non-nil means display output from the debugged program in a separate buffer." | ||
| 419 | :type 'boolean | ||
| 420 | :group 'gdb | ||
| 421 | :version "22.1") | ||
| 422 | |||
| 423 | (defun gdb-force-mode-line-update (status) | ||
| 424 | (let ((buffer gud-comint-buffer)) | ||
| 425 | (if (and buffer (buffer-name buffer)) | ||
| 426 | (with-current-buffer buffer | ||
| 427 | (setq mode-line-process | ||
| 428 | (format ":%s [%s]" | ||
| 429 | (process-status (get-buffer-process buffer)) status)) | ||
| 430 | ;; Force mode line redisplay soon. | ||
| 431 | (force-mode-line-update))))) | ||
| 432 | |||
| 433 | (defun gdb-enable-debug (arg) | ||
| 434 | "Toggle logging of transaction between Emacs and Gdb. | ||
| 435 | The log is stored in `gdb-debug-log' as an alist with elements | ||
| 436 | whose cons is send, send-item or recv and whose cdr is the string | ||
| 437 | being transferred. This list may grow up to a size of | ||
| 438 | `gdb-debug-log-max' after which the oldest element (at the end of | ||
| 439 | the list) is deleted every time a new one is added (at the front)." | ||
| 440 | (interactive "P") | ||
| 441 | (setq gdb-enable-debug | ||
| 442 | (if (null arg) | ||
| 443 | (not gdb-enable-debug) | ||
| 444 | (> (prefix-numeric-value arg) 0))) | ||
| 445 | (message (format "Logging of transaction %sabled" | ||
| 446 | (if gdb-enable-debug "en" "dis")))) | ||
| 447 | |||
| 448 | (defun gdb-many-windows (arg) | ||
| 449 | "Toggle the number of windows in the basic arrangement. | ||
| 450 | With prefix argument ARG, display additional buffers if ARG is positive, | ||
| 451 | otherwise use a single window." | ||
| 452 | (interactive "P") | ||
| 453 | (setq gdb-many-windows | ||
| 454 | (if (null arg) | ||
| 455 | (not gdb-many-windows) | ||
| 456 | (> (prefix-numeric-value arg) 0))) | ||
| 457 | (message (format "Display of other windows %sabled" | ||
| 458 | (if gdb-many-windows "en" "dis"))) | ||
| 459 | (if (and gud-comint-buffer | ||
| 460 | (buffer-name gud-comint-buffer)) | ||
| 461 | (condition-case nil | ||
| 462 | (gdb-restore-windows) | ||
| 463 | (error nil)))) | ||
| 464 | |||
| 465 | (defun gdb-use-separate-io-buffer (arg) | ||
| 466 | "Toggle separate IO for debugged program. | ||
| 467 | With prefix argument ARG, use separate IO if ARG is positive, | ||
| 468 | otherwise do not." | ||
| 469 | (interactive "P") | ||
| 470 | (setq gdb-use-separate-io-buffer | ||
| 471 | (if (null arg) | ||
| 472 | (not gdb-use-separate-io-buffer) | ||
| 473 | (> (prefix-numeric-value arg) 0))) | ||
| 474 | (message (format "Separate IO %sabled" | ||
| 475 | (if gdb-use-separate-io-buffer "en" "dis"))) | ||
| 476 | (if (and gud-comint-buffer | ||
| 477 | (buffer-name gud-comint-buffer)) | ||
| 478 | (condition-case nil | ||
| 479 | (if gdb-use-separate-io-buffer | ||
| 480 | (if gdb-many-windows (gdb-restore-windows)) | ||
| 481 | (kill-buffer (gdb-inferior-io-name))) | ||
| 482 | (error nil)))) | ||
| 483 | |||
| 484 | (defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.") | ||
| 485 | |||
| 486 | (defun gdb-create-define-alist () | ||
| 487 | "Create an alist of #define directives for GUD tooltips." | ||
| 488 | (let* ((file (buffer-file-name)) | ||
| 489 | (output | ||
| 490 | (with-output-to-string | ||
| 491 | (with-current-buffer standard-output | ||
| 492 | (and file | ||
| 493 | (file-exists-p file) | ||
| 494 | ;; call-process doesn't work with remote file names. | ||
| 495 | (not (file-remote-p default-directory)) | ||
| 496 | (call-process shell-file-name file | ||
| 497 | (list t nil) nil "-c" | ||
| 498 | (concat gdb-cpp-define-alist-program " " | ||
| 499 | gdb-cpp-define-alist-flags)))))) | ||
| 500 | (define-list (split-string output "\n" t)) (name)) | ||
| 501 | (setq gdb-define-alist nil) | ||
| 502 | (dolist (define define-list) | ||
| 503 | (setq name (nth 1 (split-string define "[( ]"))) | ||
| 504 | (push (cons name define) gdb-define-alist)))) | ||
| 505 | |||
| 506 | (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) | ||
| 507 | (defvar tooltip-use-echo-area) | ||
| 508 | |||
| 509 | (defun gdb-tooltip-print (expr) | ||
| 510 | (tooltip-show | ||
| 511 | (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) | ||
| 512 | (goto-char (point-min)) | ||
| 513 | (let ((string | ||
| 514 | (if (search-forward "=" nil t) | ||
| 515 | (concat expr (buffer-substring (- (point) 2) (point-max))) | ||
| 516 | (buffer-string)))) | ||
| 517 | ;; remove newline for gud-tooltip-echo-area | ||
| 518 | (substring string 0 (- (length string) 1)))) | ||
| 519 | (or gud-tooltip-echo-area tooltip-use-echo-area | ||
| 520 | (not (display-graphic-p))))) | ||
| 521 | |||
| 522 | ;; If expr is a macro for a function don't print because of possible dangerous | ||
| 523 | ;; side-effects. Also printing a function within a tooltip generates an | ||
| 524 | ;; unexpected starting annotation (phase error). | ||
| 525 | (defun gdb-tooltip-print-1 (expr) | ||
| 526 | (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) | ||
| 527 | (goto-char (point-min)) | ||
| 528 | (if (search-forward "expands to: " nil t) | ||
| 529 | (unless (looking-at "\\S-+.*(.*).*") | ||
| 530 | (gdb-enqueue-input | ||
| 531 | (list (concat gdb-server-prefix "print " expr "\n") | ||
| 532 | `(lambda () (gdb-tooltip-print ,expr)))))))) | ||
| 533 | |||
| 534 | (defconst gdb-source-file-regexp "\\(.+?\\), \\|\\([^, \n].*$\\)") | ||
| 535 | |||
| 536 | (defun gdb-init-buffer () | ||
| 537 | (set (make-local-variable 'gud-minor-mode) | ||
| 538 | (buffer-local-value 'gud-minor-mode gud-comint-buffer)) | ||
| 539 | (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) | ||
| 540 | (when gud-tooltip-mode | ||
| 541 | (make-local-variable 'gdb-define-alist) | ||
| 542 | (gdb-create-define-alist) | ||
| 543 | (add-hook 'after-save-hook 'gdb-create-define-alist nil t))) | ||
| 544 | |||
| 545 | (defun gdb-set-gud-minor-mode-existing-buffers () | ||
| 546 | "Create list of source files for current GDB session." | ||
| 547 | (goto-char (point-min)) | ||
| 548 | (when (search-forward "read in on demand:" nil t) | ||
| 549 | (while (re-search-forward gdb-source-file-regexp nil t) | ||
| 550 | (push (file-name-nondirectory (or (match-string 1) (match-string 2))) | ||
| 551 | gdb-source-file-list)) | ||
| 552 | (dolist (buffer (buffer-list)) | ||
| 553 | (with-current-buffer buffer | ||
| 554 | (when (and buffer-file-name | ||
| 555 | (member (file-name-nondirectory buffer-file-name) | ||
| 556 | gdb-source-file-list)) | ||
| 557 | (gdb-init-buffer))))) | ||
| 558 | (gdb-force-mode-line-update | ||
| 559 | (propertize "ready" 'face font-lock-variable-name-face))) | ||
| 560 | |||
| 561 | (defun gdb-find-watch-expression () | ||
| 562 | (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list)) | ||
| 563 | (varnum (car var)) expr array) | ||
| 564 | (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum) | ||
| 565 | (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet | ||
| 566 | (component-list (split-string (match-string 2 varnum) "\\." t))) | ||
| 567 | (setq expr (nth 1 var1)) | ||
| 568 | (setq varnumlet (car var1)) | ||
| 569 | (dolist (component component-list) | ||
| 570 | (setq var2 (assoc varnumlet gdb-var-list)) | ||
| 571 | (setq expr (concat expr | ||
| 572 | (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2)) | ||
| 573 | (concat "[" component "]") | ||
| 574 | (concat "." component)))) | ||
| 575 | (setq varnumlet (concat varnumlet "." component))) | ||
| 576 | expr))) | ||
| 577 | |||
| 578 | (defun gdb-toggle-recording () | ||
| 579 | "Start/stop recording of debug session." | ||
| 580 | (interactive) | ||
| 581 | (if gud-running | ||
| 582 | (message-box "Recording cannot be started or stopped while your program is still running") | ||
| 583 | (gdb-enqueue-input | ||
| 584 | (list (concat gdb-server-prefix | ||
| 585 | (if gdb-recording "record stop\n" "target record\n")) | ||
| 586 | 'gdb-recording-handler)))) | ||
| 587 | |||
| 588 | ;; Convenience function for tool bar. | ||
| 589 | (defalias 'gdb-toggle-recording-1 'gdb-toggle-recording) | ||
| 590 | |||
| 591 | (defun gdb-recording-handler () | ||
| 592 | (goto-char (point-min)) | ||
| 593 | (if (re-search-forward "current architecture doesn't support record function" nil t) | ||
| 594 | (message-box "Not enabled. The current architecture doesn't support the process record function.") | ||
| 595 | (goto-char (point-min)) | ||
| 596 | (if (re-search-forward "Undefined target command" nil t) | ||
| 597 | (message-box "Not enabled. Process record requires GDB 7.0 onwards.") | ||
| 598 | (goto-char (point-min)) | ||
| 599 | (if (re-search-forward "the program is not being run" nil t) | ||
| 600 | (message-box "Not enabled. Starting process recording requires an active target (running process).") | ||
| 601 | (setq gdb-recording (not gdb-recording)) | ||
| 602 | ;; Actually forcing the tool-bar to update. | ||
| 603 | (force-mode-line-update))))) | ||
| 604 | |||
| 605 | (defun gdb-init-1 () | ||
| 606 | (gud-def gud-break (if (not (string-match "Machine" mode-name)) | ||
| 607 | (gud-call "break %f:%l" arg) | ||
| 608 | (save-excursion | ||
| 609 | (beginning-of-line) | ||
| 610 | (forward-char 2) | ||
| 611 | (gud-call "break *%a" arg))) | ||
| 612 | "\C-b" "Set breakpoint at current line or address.") | ||
| 613 | ;; | ||
| 614 | (gud-def gud-remove (if (not (string-match "Machine" mode-name)) | ||
| 615 | (gud-call "clear %f:%l" arg) | ||
| 616 | (save-excursion | ||
| 617 | (beginning-of-line) | ||
| 618 | (forward-char 2) | ||
| 619 | (gud-call "clear *%a" arg))) | ||
| 620 | "\C-d" "Remove breakpoint at current line or address.") | ||
| 621 | ;; | ||
| 622 | (gud-def gud-until (if (not (string-match "Machine" mode-name)) | ||
| 623 | (gud-call "until %f:%l" arg) | ||
| 624 | (save-excursion | ||
| 625 | (beginning-of-line) | ||
| 626 | (forward-char 2) | ||
| 627 | (gud-call "until *%a" arg))) | ||
| 628 | "\C-u" "Continue to current line or address.") | ||
| 629 | ;; | ||
| 630 | (gud-def gud-go (gud-call (if gdb-active-process "continue" "run") arg) | ||
| 631 | nil "Start or continue execution.") | ||
| 632 | |||
| 633 | ;; For debugging Emacs only. | ||
| 634 | (gud-def gud-pp | ||
| 635 | (gud-call | ||
| 636 | (concat | ||
| 637 | "pp1 " (if (eq (buffer-local-value | ||
| 638 | 'major-mode (window-buffer)) 'speedbar-mode) | ||
| 639 | (gdb-find-watch-expression) "%e")) arg) | ||
| 640 | nil "Print the Emacs s-expression.") | ||
| 641 | |||
| 642 | (define-key gud-minor-mode-map [left-margin mouse-1] | ||
| 643 | 'gdb-mouse-set-clear-breakpoint) | ||
| 644 | (define-key gud-minor-mode-map [left-fringe mouse-1] | ||
| 645 | 'gdb-mouse-set-clear-breakpoint) | ||
| 646 | (define-key gud-minor-mode-map [left-margin C-mouse-1] | ||
| 647 | 'gdb-mouse-toggle-breakpoint-margin) | ||
| 648 | (define-key gud-minor-mode-map [left-fringe C-mouse-1] | ||
| 649 | 'gdb-mouse-toggle-breakpoint-fringe) | ||
| 650 | |||
| 651 | (define-key gud-minor-mode-map [left-margin drag-mouse-1] | ||
| 652 | 'gdb-mouse-until) | ||
| 653 | (define-key gud-minor-mode-map [left-fringe drag-mouse-1] | ||
| 654 | 'gdb-mouse-until) | ||
| 655 | (define-key gud-minor-mode-map [left-margin mouse-3] | ||
| 656 | 'gdb-mouse-until) | ||
| 657 | (define-key gud-minor-mode-map [left-fringe mouse-3] | ||
| 658 | 'gdb-mouse-until) | ||
| 659 | |||
| 660 | (define-key gud-minor-mode-map [left-margin C-drag-mouse-1] | ||
| 661 | 'gdb-mouse-jump) | ||
| 662 | (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1] | ||
| 663 | 'gdb-mouse-jump) | ||
| 664 | (define-key gud-minor-mode-map [left-fringe C-mouse-3] | ||
| 665 | 'gdb-mouse-jump) | ||
| 666 | (define-key gud-minor-mode-map [left-margin C-mouse-3] | ||
| 667 | 'gdb-mouse-jump) | ||
| 668 | |||
| 669 | ;; (re-)initialize | ||
| 670 | (setq gdb-pc-address (if gdb-show-main "main" nil)) | ||
| 671 | (setq gdb-previous-frame-pc-address nil | ||
| 672 | gdb-memory-address "main" | ||
| 673 | gdb-previous-frame nil | ||
| 674 | gdb-selected-frame nil | ||
| 675 | gdb-current-language nil | ||
| 676 | gdb-frame-number nil | ||
| 677 | gdb-var-list nil | ||
| 678 | gdb-main-file nil | ||
| 679 | gdb-first-post-prompt t | ||
| 680 | gdb-prompting nil | ||
| 681 | gdb-input-queue nil | ||
| 682 | gdb-current-item nil | ||
| 683 | gdb-pending-triggers nil | ||
| 684 | gdb-output-sink 'user | ||
| 685 | gdb-server-prefix "server " | ||
| 686 | gdb-location-alist nil | ||
| 687 | gdb-source-file-list nil | ||
| 688 | gdb-error nil | ||
| 689 | gdb-macro-info nil | ||
| 690 | gdb-buffer-fringe-width (car (window-fringes)) | ||
| 691 | gdb-debug-log nil | ||
| 692 | gdb-signalled nil | ||
| 693 | gdb-source-window nil | ||
| 694 | gdb-inferior-status nil | ||
| 695 | gdb-continuation nil | ||
| 696 | gdb-look-up-stack nil | ||
| 697 | gdb-frame-begin nil | ||
| 698 | gdb-printing t | ||
| 699 | gud-old-arrow nil | ||
| 700 | gdb-thread-indicator nil | ||
| 701 | gdb-register-names nil | ||
| 702 | gdb-recording nil) | ||
| 703 | |||
| 704 | (setq gdb-buffer-type 'gdba) | ||
| 705 | |||
| 706 | (if gdb-use-separate-io-buffer (gdb-clear-inferior-io)) | ||
| 707 | |||
| 708 | ;; Hack to see test for GDB 6.4+ (-stack-info-frame was implemented in 6.4) | ||
| 709 | (gdb-enqueue-input (list "server interpreter mi -stack-info-frame\n" | ||
| 710 | 'gdb-get-version))) | ||
| 711 | |||
| 712 | (defun gdb-init-2 () | ||
| 713 | (if (eq window-system 'w32) | ||
| 714 | (gdb-enqueue-input (list "set new-console off\n" 'ignore))) | ||
| 715 | (gdb-enqueue-input (list "set height 0\n" 'ignore)) | ||
| 716 | (gdb-enqueue-input (list "set width 0\n" 'ignore)) | ||
| 717 | |||
| 718 | (if (string-equal gdb-version "pre-6.4") | ||
| 719 | (if gdb-create-source-file-list | ||
| 720 | (gdb-enqueue-input (list (concat gdb-server-prefix "info sources\n") | ||
| 721 | 'gdb-set-gud-minor-mode-existing-buffers)) | ||
| 722 | (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-1)) | ||
| 723 | ; Needs GDB 6.2 onwards. | ||
| 724 | (if gdb-create-source-file-list | ||
| 725 | (gdb-enqueue-input | ||
| 726 | (list "server interpreter mi \"-file-list-exec-source-files\"\n" | ||
| 727 | 'gdb-set-gud-minor-mode-existing-buffers-1))) | ||
| 728 | (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-2) | ||
| 729 | ; Needs GDB 7.0 onwards. | ||
| 730 | (gdb-enqueue-input | ||
| 731 | (list "server interpreter mi -enable-pretty-printing\n" 'ignore))) | ||
| 732 | |||
| 733 | ;; Find source file and compilation directory here. | ||
| 734 | ;; Works for C, C++, Fortran and Ada but not Java (GDB 6.4) | ||
| 735 | (gdb-enqueue-input (list "server list\n" 'ignore)) | ||
| 736 | (gdb-enqueue-input (list "server list MAIN__\n" 'ignore)) | ||
| 737 | (gdb-enqueue-input (list "server info source\n" 'gdb-source-info))) | ||
| 738 | |||
| 739 | (defun gdb-get-version () | ||
| 740 | (goto-char (point-min)) | ||
| 741 | (if (re-search-forward "Undefined\\( mi\\)* command:" nil t) | ||
| 742 | (setq gdb-version "pre-6.4") | ||
| 743 | (setq gdb-version "6.4+")) | ||
| 744 | (gdb-init-2)) | ||
| 745 | |||
| 746 | (defmacro gdb-if-arrow (arrow-position &rest body) | ||
| 747 | `(if ,arrow-position | ||
| 748 | (let ((buffer (marker-buffer ,arrow-position)) (line)) | ||
| 749 | (if (equal buffer (window-buffer (posn-window end))) | ||
| 750 | (with-current-buffer buffer | ||
| 751 | (when (or (equal start end) | ||
| 752 | (equal (posn-point start) | ||
| 753 | (marker-position ,arrow-position))) | ||
| 754 | ,@body)))))) | ||
| 755 | |||
| 756 | (defun gdb-mouse-until (event) | ||
| 757 | "Continue running until a source line past the current line. | ||
| 758 | The destination source line can be selected either by clicking | ||
| 759 | with mouse-3 on the fringe/margin or dragging the arrow | ||
| 760 | with mouse-1 (default bindings)." | ||
| 761 | (interactive "e") | ||
| 762 | (let ((start (event-start event)) | ||
| 763 | (end (event-end event))) | ||
| 764 | (gdb-if-arrow gud-overlay-arrow-position | ||
| 765 | (setq line (line-number-at-pos (posn-point end))) | ||
| 766 | (gud-call (concat "until " (number-to-string line)))) | ||
| 767 | (gdb-if-arrow gdb-overlay-arrow-position | ||
| 768 | (save-excursion | ||
| 769 | (goto-char (point-min)) | ||
| 770 | (forward-line (1- (line-number-at-pos (posn-point end)))) | ||
| 771 | (forward-char 2) | ||
| 772 | (gud-call (concat "until *%a")))))) | ||
| 773 | |||
| 774 | (defun gdb-mouse-jump (event) | ||
| 775 | "Set execution address/line. | ||
| 776 | The destination source line can be selected either by clicking with C-mouse-3 | ||
| 777 | on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings). | ||
| 778 | Unlike `gdb-mouse-until' the destination address can be before the current | ||
| 779 | line, and no execution takes place." | ||
| 780 | (interactive "e") | ||
| 781 | (let ((start (event-start event)) | ||
| 782 | (end (event-end event))) | ||
| 783 | (gdb-if-arrow gud-overlay-arrow-position | ||
| 784 | (setq line (line-number-at-pos (posn-point end))) | ||
| 785 | (progn | ||
| 786 | (gud-call (concat "tbreak " (number-to-string line))) | ||
| 787 | (gud-call (concat "jump " (number-to-string line))))) | ||
| 788 | (gdb-if-arrow gdb-overlay-arrow-position | ||
| 789 | (save-excursion | ||
| 790 | (goto-char (point-min)) | ||
| 791 | (forward-line (1- (line-number-at-pos (posn-point end)))) | ||
| 792 | (forward-char 2) | ||
| 793 | (progn | ||
| 794 | (gud-call (concat "tbreak *%a")) | ||
| 795 | (gud-call (concat "jump *%a"))))))) | ||
| 796 | |||
| 797 | (defcustom gdb-speedbar-auto-raise nil | ||
| 798 | "If non-nil raise speedbar every time display of watch expressions is\ | ||
| 799 | updated." | ||
| 800 | :type 'boolean | ||
| 801 | :group 'gdb | ||
| 802 | :version "22.1") | ||
| 803 | |||
| 804 | (defun gdb-speedbar-auto-raise (arg) | ||
| 805 | "Toggle automatic raising of the speedbar for watch expressions. | ||
| 806 | With prefix argument ARG, automatically raise speedbar if ARG is | ||
| 807 | positive, otherwise don't automatically raise it." | ||
| 808 | (interactive "P") | ||
| 809 | (setq gdb-speedbar-auto-raise | ||
| 810 | (if (null arg) | ||
| 811 | (not gdb-speedbar-auto-raise) | ||
| 812 | (> (prefix-numeric-value arg) 0))) | ||
| 813 | (message (format "Auto raising %sabled" | ||
| 814 | (if gdb-speedbar-auto-raise "en" "dis")))) | ||
| 815 | |||
| 816 | (defcustom gdb-use-colon-colon-notation nil | ||
| 817 | "If non-nil use FUN::VAR format to display variables in the speedbar." | ||
| 818 | :type 'boolean | ||
| 819 | :group 'gdb | ||
| 820 | :version "22.1") | ||
| 821 | |||
| 822 | (define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch) | ||
| 823 | (define-key global-map (concat gud-key-prefix "\C-w") 'gud-watch) | ||
| 824 | |||
| 825 | (declare-function tooltip-identifier-from-point "tooltip" (point)) | ||
| 826 | |||
| 827 | (defun gud-watch (&optional arg event) | ||
| 828 | "Watch expression at point. | ||
| 829 | With arg, enter name of variable to be watched in the minibuffer." | ||
| 830 | (interactive (list current-prefix-arg last-input-event)) | ||
| 831 | (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer))) | ||
| 832 | (if (memq minor-mode '(gdbmi gdba)) | ||
| 833 | (progn | ||
| 834 | (if event (posn-set-point (event-end event))) | ||
| 835 | (require 'tooltip) | ||
| 836 | (save-selected-window | ||
| 837 | (let ((expr | ||
| 838 | (if arg | ||
| 839 | (completing-read "Name of variable: " | ||
| 840 | 'gud-gdb-complete-command) | ||
| 841 | (if (and transient-mark-mode mark-active) | ||
| 842 | (buffer-substring (region-beginning) (region-end)) | ||
| 843 | (concat (if (eq major-mode 'gdb-registers-mode) "$") | ||
| 844 | (tooltip-identifier-from-point (point))))))) | ||
| 845 | (set-text-properties 0 (length expr) nil expr) | ||
| 846 | (gdb-enqueue-input | ||
| 847 | (list | ||
| 848 | (if (eq minor-mode 'gdba) | ||
| 849 | (concat | ||
| 850 | "server interpreter mi \"-var-create - * " expr "\"\n") | ||
| 851 | (concat"-var-create - * " expr "\n")) | ||
| 852 | `(lambda () (gdb-var-create-handler ,expr))))))) | ||
| 853 | (message "gud-watch is a no-op in this mode.")))) | ||
| 854 | |||
| 855 | (defun gdb-var-create-handler (expr) | ||
| 856 | (let* ((result (gdb-json-partial-output))) | ||
| 857 | (if (not (bindat-get-field result 'msg)) | ||
| 858 | (let ((var | ||
| 859 | (list (bindat-get-field result 'name) | ||
| 860 | (if (and (string-equal gdb-current-language "c") | ||
| 861 | gdb-use-colon-colon-notation gdb-selected-frame) | ||
| 862 | (setq expr (concat gdb-selected-frame "::" expr)) | ||
| 863 | expr) | ||
| 864 | (bindat-get-field result 'numchild) | ||
| 865 | (bindat-get-field result 'type) | ||
| 866 | (bindat-get-field result 'value) | ||
| 867 | nil | ||
| 868 | (bindat-get-field result 'has_more) | ||
| 869 | gdb-frame-address))) | ||
| 870 | (push var gdb-var-list) | ||
| 871 | (speedbar 1) | ||
| 872 | (unless (string-equal | ||
| 873 | speedbar-initial-expansion-list-name "GUD") | ||
| 874 | (speedbar-change-initial-expansion-list "GUD"))) | ||
| 875 | (message-box "No symbol \"%s\" in current context." expr)))) | ||
| 876 | |||
| 877 | (defun gdb-speedbar-update () | ||
| 878 | (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame) | ||
| 879 | (not (member 'gdb-speedbar-timer gdb-pending-triggers))) | ||
| 880 | ;; Dummy command to update speedbar even when idle. | ||
| 881 | (gdb-enqueue-input (list "server pwd\n" 'gdb-speedbar-timer-fn)) | ||
| 882 | ;; Keep gdb-pending-triggers non-nil till end. | ||
| 883 | (push 'gdb-speedbar-timer gdb-pending-triggers))) | ||
| 884 | |||
| 885 | (defun gdb-speedbar-timer-fn () | ||
| 886 | (if gdb-speedbar-auto-raise | ||
| 887 | (raise-frame speedbar-frame)) | ||
| 888 | (setq gdb-pending-triggers | ||
| 889 | (delq 'gdb-speedbar-timer gdb-pending-triggers)) | ||
| 890 | (speedbar-timer-fn)) | ||
| 891 | |||
| 892 | (defun gdb-var-evaluate-expression-handler (varnum changed) | ||
| 893 | (goto-char (point-min)) | ||
| 894 | (re-search-forward "\\(.+\\)\\^done,value=\\(\".*\"\\)" nil t) | ||
| 895 | (setq gdb-pending-triggers | ||
| 896 | (delq (string-to-number (match-string 1)) gdb-pending-triggers)) | ||
| 897 | (let ((var (assoc varnum gdb-var-list))) | ||
| 898 | (when var | ||
| 899 | (if changed (setcar (nthcdr 5 var) 'changed)) | ||
| 900 | (setcar (nthcdr 4 var) (read (match-string 2))))) | ||
| 901 | (gdb-speedbar-update)) | ||
| 902 | |||
| 903 | (defun gdb-var-list-children (varnum) | ||
| 904 | (gdb-enqueue-input | ||
| 905 | (list (concat "server interpreter mi \"-var-list-children " varnum "\"\n") | ||
| 906 | `(lambda () (gdb-var-list-children-handler ,varnum))))) | ||
| 907 | |||
| 908 | (defconst gdb-var-list-children-regexp | ||
| 909 | "child={.*?name=\"\\(.*?\\)\".*?,exp=\"\\(.*?\\)\".*?,\ | ||
| 910 | numchild=\"\\(.*?\\)\"\\(}\\|.*?,\\(type=\"\\(.*?\\)\"\\)?.*?}\\)") | ||
| 911 | |||
| 912 | (defun gdb-var-list-children-handler (varnum) | ||
| 913 | (goto-char (point-min)) | ||
| 914 | (let ((var-list nil)) | ||
| 915 | (catch 'child-already-watched | ||
| 916 | (dolist (var gdb-var-list) | ||
| 917 | (if (string-equal varnum (car var)) | ||
| 918 | (progn | ||
| 919 | (push var var-list) | ||
| 920 | (while (re-search-forward gdb-var-list-children-regexp nil t) | ||
| 921 | (let ((varchild (list (match-string 1) | ||
| 922 | (match-string 2) | ||
| 923 | (match-string 3) | ||
| 924 | (match-string 6) | ||
| 925 | nil nil))) | ||
| 926 | (if (assoc (car varchild) gdb-var-list) | ||
| 927 | (throw 'child-already-watched nil)) | ||
| 928 | (push varchild var-list) | ||
| 929 | (gdb-enqueue-input | ||
| 930 | (list | ||
| 931 | (concat | ||
| 932 | "server interpreter mi \"0-var-evaluate-expression " | ||
| 933 | (car varchild) "\"\n") | ||
| 934 | `(lambda () (gdb-var-evaluate-expression-handler | ||
| 935 | ,(car varchild) nil))))))) | ||
| 936 | (push var var-list))) | ||
| 937 | (setq gdb-var-list (nreverse var-list))))) | ||
| 938 | |||
| 939 | (defun gdb-var-update () | ||
| 940 | (when (not (member 'gdb-var-update gdb-pending-triggers)) | ||
| 941 | (gdb-enqueue-input | ||
| 942 | (list "server interpreter mi \"-var-update *\"\n" | ||
| 943 | 'gdb-var-update-handler)) | ||
| 944 | (push 'gdb-var-update gdb-pending-triggers))) | ||
| 945 | |||
| 946 | (defconst gdb-var-update-regexp | ||
| 947 | "{.*?name=\"\\(.*?\\)\".*?,in_scope=\"\\(.*?\\)\".*?,\ | ||
| 948 | type_changed=\".*?\".*?}") | ||
| 949 | |||
| 950 | (defun gdb-var-update-handler () | ||
| 951 | (dolist (var gdb-var-list) | ||
| 952 | (setcar (nthcdr 5 var) nil)) | ||
| 953 | (goto-char (point-min)) | ||
| 954 | (let ((n 0)) | ||
| 955 | (while (re-search-forward gdb-var-update-regexp nil t) | ||
| 956 | (let ((varnum (match-string 1))) | ||
| 957 | (if (string-equal (match-string 2) "false") | ||
| 958 | (let ((var (assoc varnum gdb-var-list))) | ||
| 959 | (if var (setcar (nthcdr 5 var) 'out-of-scope))) | ||
| 960 | (setq n (1+ n)) | ||
| 961 | (push n gdb-pending-triggers) | ||
| 962 | (gdb-enqueue-input | ||
| 963 | (list | ||
| 964 | (concat "server interpreter mi \"" (number-to-string n) | ||
| 965 | "-var-evaluate-expression " varnum "\"\n") | ||
| 966 | `(lambda () (gdb-var-evaluate-expression-handler ,varnum t)))))))) | ||
| 967 | (setq gdb-pending-triggers | ||
| 968 | (delq 'gdb-var-update gdb-pending-triggers))) | ||
| 969 | |||
| 970 | (defun gdb-var-set-format (format) | ||
| 971 | "Set the output format for a variable displayed in the speedbar." | ||
| 972 | (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) | ||
| 973 | (varnum (car var))) | ||
| 974 | (gdb-enqueue-input | ||
| 975 | (list | ||
| 976 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 977 | (concat "server interpreter mi \"-var-set-format " | ||
| 978 | varnum " " format "\"\n") | ||
| 979 | (concat "-var-set-format " varnum " " format "\n")) | ||
| 980 | `(lambda () (gdb-var-set-format-handler ,varnum)))))) | ||
| 981 | |||
| 982 | (defconst gdb-var-set-format-regexp | ||
| 983 | "format=\"\\(.*?\\)\",.*value=\"\\(.*?\\)\"") | ||
| 984 | |||
| 985 | (defun gdb-var-set-format-handler (varnum) | ||
| 986 | (goto-char (point-min)) | ||
| 987 | (if (re-search-forward gdb-var-set-format-regexp nil t) | ||
| 988 | (let ((var (assoc varnum gdb-var-list))) | ||
| 989 | (setcar (nthcdr 4 var) (match-string 2)) | ||
| 990 | (gdb-var-update-1)))) | ||
| 991 | |||
| 992 | (defun gdb-var-delete-1 (var varnum) | ||
| 993 | (gdb-enqueue-input | ||
| 994 | (list | ||
| 995 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 996 | (concat "server interpreter mi \"-var-delete " varnum "\"\n") | ||
| 997 | (concat "-var-delete " varnum "\n")) | ||
| 998 | 'ignore)) | ||
| 999 | (setq gdb-var-list (delq var gdb-var-list)) | ||
| 1000 | (dolist (varchild gdb-var-list) | ||
| 1001 | (if (string-match (concat (car var) "\\.") (car varchild)) | ||
| 1002 | (setq gdb-var-list (delq varchild gdb-var-list))))) | ||
| 1003 | |||
| 1004 | (defun gdb-var-delete () | ||
| 1005 | "Delete watch expression at point from the speedbar." | ||
| 1006 | (interactive) | ||
| 1007 | (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | ||
| 1008 | '(gdbmi gdba)) | ||
| 1009 | (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) | ||
| 1010 | (varnum (car var))) | ||
| 1011 | (if (string-match "\\." (car var)) | ||
| 1012 | (message-box "Can only delete a root expression") | ||
| 1013 | (gdb-var-delete-1 var varnum))))) | ||
| 1014 | |||
| 1015 | (defun gdb-var-delete-children (varnum) | ||
| 1016 | "Delete children of variable object at point from the speedbar." | ||
| 1017 | (gdb-enqueue-input | ||
| 1018 | (list | ||
| 1019 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 1020 | (concat "server interpreter mi \"-var-delete -c " varnum "\"\n") | ||
| 1021 | (concat "-var-delete -c " varnum "\n")) 'ignore))) | ||
| 1022 | |||
| 1023 | (defun gdb-edit-value (text token indent) | ||
| 1024 | "Assign a value to a variable displayed in the speedbar." | ||
| 1025 | (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) | ||
| 1026 | (varnum (car var)) (value)) | ||
| 1027 | (setq value (read-string "New value: ")) | ||
| 1028 | (gdb-enqueue-input | ||
| 1029 | (list | ||
| 1030 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 1031 | (concat "server interpreter mi \"-var-assign " | ||
| 1032 | varnum " " value "\"\n") | ||
| 1033 | (concat "-var-assign " varnum " " value "\n")) | ||
| 1034 | `(lambda () (gdb-edit-value-handler ,value)))))) | ||
| 1035 | |||
| 1036 | (defun gdb-edit-value-handler (value) | ||
| 1037 | (goto-char (point-min)) | ||
| 1038 | (if (re-search-forward gdb-error-regexp nil t) | ||
| 1039 | (message-box "Invalid number or expression (%s)" value))) | ||
| 1040 | |||
| 1041 | (defcustom gdb-show-changed-values t | ||
| 1042 | "If non-nil change the face of out of scope variables and changed values. | ||
| 1043 | Out of scope variables are suppressed with `shadow' face. | ||
| 1044 | Changed values are highlighted with the face `font-lock-warning-face'." | ||
| 1045 | :type 'boolean | ||
| 1046 | :group 'gdb | ||
| 1047 | :version "22.1") | ||
| 1048 | |||
| 1049 | (defcustom gdb-max-children 40 | ||
| 1050 | "Maximum number of children before expansion requires confirmation." | ||
| 1051 | :type 'integer | ||
| 1052 | :group 'gdb | ||
| 1053 | :version "22.1") | ||
| 1054 | |||
| 1055 | (defcustom gdb-delete-out-of-scope t | ||
| 1056 | "If non-nil delete watch expressions automatically when they go out of scope." | ||
| 1057 | :type 'boolean | ||
| 1058 | :group 'gdb | ||
| 1059 | :version "22.2") | ||
| 1060 | |||
| 1061 | (defun gdb-speedbar-expand-node (text token indent) | ||
| 1062 | "Expand the node the user clicked on. | ||
| 1063 | TEXT is the text of the button we clicked on, a + or - item. | ||
| 1064 | TOKEN is data related to this node. | ||
| 1065 | INDENT is the current indentation depth." | ||
| 1066 | (if (and gud-comint-buffer (buffer-name gud-comint-buffer)) | ||
| 1067 | (progn | ||
| 1068 | (cond ((string-match "+" text) ;expand this node | ||
| 1069 | (let* ((var (assoc token gdb-var-list)) | ||
| 1070 | (expr (nth 1 var)) (children (nth 2 var))) | ||
| 1071 | (if (or (<= (string-to-number children) gdb-max-children) | ||
| 1072 | (y-or-n-p | ||
| 1073 | (format | ||
| 1074 | "%s has %s children. Continue? " expr children))) | ||
| 1075 | (if (and (eq (buffer-local-value | ||
| 1076 | 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 1077 | (string-equal gdb-version "pre-6.4")) | ||
| 1078 | (gdb-var-list-children token) | ||
| 1079 | (gdb-var-list-children-1 token))))) | ||
| 1080 | ((string-match "-" text) ;contract this node | ||
| 1081 | (dolist (var gdb-var-list) | ||
| 1082 | (if (string-match (concat token "\\.") (car var)) | ||
| 1083 | (setq gdb-var-list (delq var gdb-var-list)))) | ||
| 1084 | (gdb-var-delete-children token) | ||
| 1085 | (speedbar-change-expand-button-char ?+) | ||
| 1086 | (speedbar-delete-subblock indent)) | ||
| 1087 | (t (error "Ooops... not sure what to do"))) | ||
| 1088 | (speedbar-center-buffer-smartly)) | ||
| 1089 | (message-box "GUD session has been killed"))) | ||
| 1090 | |||
| 1091 | (defun gdb-get-target-string () | ||
| 1092 | (with-current-buffer gud-comint-buffer | ||
| 1093 | gud-target-name)) | ||
| 1094 | |||
| 1095 | |||
| 1096 | ;; | ||
| 1097 | ;; gdb buffers. | ||
| 1098 | ;; | ||
| 1099 | ;; Each buffer has a TYPE -- a symbol that identifies the function | ||
| 1100 | ;; of that particular buffer. | ||
| 1101 | ;; | ||
| 1102 | ;; The usual gdb interaction buffer is given the type `gdba' and | ||
| 1103 | ;; is constructed specially. | ||
| 1104 | ;; | ||
| 1105 | ;; Others are constructed by gdb-get-buffer-create and | ||
| 1106 | ;; named according to the rules set forth in the gdb-buffer-rules-assoc | ||
| 1107 | |||
| 1108 | (defvar gdb-buffer-rules-assoc '()) | ||
| 1109 | |||
| 1110 | (defun gdb-get-buffer (key) | ||
| 1111 | "Return the gdb buffer tagged with type KEY. | ||
| 1112 | The key should be one of the cars in `gdb-buffer-rules-assoc'." | ||
| 1113 | (save-excursion | ||
| 1114 | (gdb-look-for-tagged-buffer key (buffer-list)))) | ||
| 1115 | |||
| 1116 | (defun gdb-get-buffer-create (key) | ||
| 1117 | "Create a new gdb buffer of the type specified by KEY. | ||
| 1118 | The key should be one of the cars in `gdb-buffer-rules-assoc'." | ||
| 1119 | (or (gdb-get-buffer key) | ||
| 1120 | (let* ((rules (assoc key gdb-buffer-rules-assoc)) | ||
| 1121 | (name (funcall (gdb-rules-name-maker rules))) | ||
| 1122 | (new (get-buffer-create name))) | ||
| 1123 | (with-current-buffer new | ||
| 1124 | (let ((trigger)) | ||
| 1125 | (if (cdr (cdr rules)) | ||
| 1126 | (setq trigger (funcall (car (cdr (cdr rules)))))) | ||
| 1127 | (setq gdb-buffer-type key) | ||
| 1128 | (set (make-local-variable 'gud-minor-mode) | ||
| 1129 | (buffer-local-value 'gud-minor-mode gud-comint-buffer)) | ||
| 1130 | (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) | ||
| 1131 | (if trigger (funcall trigger))) | ||
| 1132 | new)))) | ||
| 1133 | |||
| 1134 | (defun gdb-rules-name-maker (rules) (car (cdr rules))) | ||
| 1135 | |||
| 1136 | (defun gdb-look-for-tagged-buffer (key bufs) | ||
| 1137 | (let ((retval nil)) | ||
| 1138 | (while (and (not retval) bufs) | ||
| 1139 | (set-buffer (car bufs)) | ||
| 1140 | (if (eq gdb-buffer-type key) | ||
| 1141 | (setq retval (car bufs))) | ||
| 1142 | (setq bufs (cdr bufs))) | ||
| 1143 | retval)) | ||
| 1144 | |||
| 1145 | ;; | ||
| 1146 | ;; This assoc maps buffer type symbols to rules. Each rule is a list of | ||
| 1147 | ;; at least one and possible more functions. The functions have these | ||
| 1148 | ;; roles in defining a buffer type: | ||
| 1149 | ;; | ||
| 1150 | ;; NAME - Return a name for this buffer type. | ||
| 1151 | ;; | ||
| 1152 | ;; The remaining function(s) are optional: | ||
| 1153 | ;; | ||
| 1154 | ;; MODE - called in a new buffer with no arguments, should establish | ||
| 1155 | ;; the proper mode for the buffer. | ||
| 1156 | ;; | ||
| 1157 | |||
| 1158 | (defun gdb-set-buffer-rules (buffer-type &rest rules) | ||
| 1159 | (let ((binding (assoc buffer-type gdb-buffer-rules-assoc))) | ||
| 1160 | (if binding | ||
| 1161 | (setcdr binding rules) | ||
| 1162 | (push (cons buffer-type rules) | ||
| 1163 | gdb-buffer-rules-assoc)))) | ||
| 1164 | |||
| 1165 | ;; GUD buffers are an exception to the rules | ||
| 1166 | (gdb-set-buffer-rules 'gdba 'error) | ||
| 1167 | |||
| 1168 | ;; Partial-output buffer : This accumulates output from a command executed on | ||
| 1169 | ;; behalf of emacs (rather than the user). | ||
| 1170 | ;; | ||
| 1171 | (gdb-set-buffer-rules 'gdb-partial-output-buffer | ||
| 1172 | 'gdb-partial-output-name) | ||
| 1173 | |||
| 1174 | (defun gdb-partial-output-name () | ||
| 1175 | (concat " *partial-output-" | ||
| 1176 | (gdb-get-target-string) | ||
| 1177 | "*")) | ||
| 1178 | |||
| 1179 | |||
| 1180 | (gdb-set-buffer-rules 'gdb-inferior-io | ||
| 1181 | 'gdb-inferior-io-name | ||
| 1182 | 'gdb-inferior-io-mode) | ||
| 1183 | |||
| 1184 | (defun gdb-inferior-io-name () | ||
| 1185 | (concat "*input/output of " | ||
| 1186 | (gdb-get-target-string) | ||
| 1187 | "*")) | ||
| 1188 | |||
| 1189 | (defun gdb-display-separate-io-buffer () | ||
| 1190 | "Display IO of debugged program in a separate window." | ||
| 1191 | (interactive) | ||
| 1192 | (if gdb-use-separate-io-buffer | ||
| 1193 | (gdb-display-buffer | ||
| 1194 | (gdb-get-buffer-create 'gdb-inferior-io) t))) | ||
| 1195 | |||
| 1196 | (defconst gdb-frame-parameters | ||
| 1197 | '((height . 14) (width . 80) | ||
| 1198 | (unsplittable . t) | ||
| 1199 | (tool-bar-lines . nil) | ||
| 1200 | (menu-bar-lines . nil) | ||
| 1201 | (minibuffer . nil))) | ||
| 1202 | |||
| 1203 | (defun gdb-frame-separate-io-buffer () | ||
| 1204 | "Display IO of debugged program in a new frame." | ||
| 1205 | (interactive) | ||
| 1206 | (if gdb-use-separate-io-buffer | ||
| 1207 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 1208 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 1209 | (display-buffer (gdb-get-buffer-create 'gdb-inferior-io))))) | ||
| 1210 | |||
| 1211 | (defvar gdb-inferior-io-mode-map | ||
| 1212 | (let ((map (make-sparse-keymap))) | ||
| 1213 | (define-key map "\C-c\C-c" 'gdb-separate-io-interrupt) | ||
| 1214 | (define-key map "\C-c\C-z" 'gdb-separate-io-stop) | ||
| 1215 | (define-key map "\C-c\C-\\" 'gdb-separate-io-quit) | ||
| 1216 | (define-key map "\C-c\C-d" 'gdb-separate-io-eof) | ||
| 1217 | (define-key map "\C-d" 'gdb-separate-io-eof) | ||
| 1218 | map)) | ||
| 1219 | |||
| 1220 | (define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O" | ||
| 1221 | "Major mode for gdb inferior-io." | ||
| 1222 | :syntax-table nil :abbrev-table nil | ||
| 1223 | ;; We want to use comint because it has various nifty and familiar | ||
| 1224 | ;; features. We don't need a process, but comint wants one, so create | ||
| 1225 | ;; a dummy one. | ||
| 1226 | (make-comint-in-buffer | ||
| 1227 | (substring (buffer-name) 1 (- (length (buffer-name)) 1)) | ||
| 1228 | (current-buffer) "hexl") | ||
| 1229 | (setq comint-input-sender 'gdb-inferior-io-sender)) | ||
| 1230 | |||
| 1231 | (defun gdb-inferior-io-sender (proc string) | ||
| 1232 | ;; PROC is the pseudo-process created to satisfy comint. | ||
| 1233 | (with-current-buffer (process-buffer proc) | ||
| 1234 | (setq proc (get-buffer-process gud-comint-buffer)) | ||
| 1235 | (process-send-string proc string) | ||
| 1236 | (process-send-string proc "\n"))) | ||
| 1237 | |||
| 1238 | (defun gdb-separate-io-interrupt () | ||
| 1239 | "Interrupt the program being debugged." | ||
| 1240 | (interactive) | ||
| 1241 | (interrupt-process | ||
| 1242 | (get-buffer-process gud-comint-buffer) comint-ptyp)) | ||
| 1243 | |||
| 1244 | (defun gdb-separate-io-quit () | ||
| 1245 | "Send quit signal to the program being debugged." | ||
| 1246 | (interactive) | ||
| 1247 | (quit-process | ||
| 1248 | (get-buffer-process gud-comint-buffer) comint-ptyp)) | ||
| 1249 | |||
| 1250 | (defun gdb-separate-io-stop () | ||
| 1251 | "Stop the program being debugged." | ||
| 1252 | (interactive) | ||
| 1253 | (stop-process | ||
| 1254 | (get-buffer-process gud-comint-buffer) comint-ptyp)) | ||
| 1255 | |||
| 1256 | (defun gdb-separate-io-eof () | ||
| 1257 | "Send end-of-file to the program being debugged." | ||
| 1258 | (interactive) | ||
| 1259 | (process-send-eof | ||
| 1260 | (get-buffer-process gud-comint-buffer))) | ||
| 1261 | |||
| 1262 | |||
| 1263 | ;; gdb communications | ||
| 1264 | ;; | ||
| 1265 | |||
| 1266 | ;; INPUT: things sent to gdb | ||
| 1267 | ;; | ||
| 1268 | ;; The queues are lists. Each element is either a string (indicating user or | ||
| 1269 | ;; user-like input) or a list of the form: | ||
| 1270 | ;; | ||
| 1271 | ;; (INPUT-STRING HANDLER-FN) | ||
| 1272 | ;; | ||
| 1273 | ;; The handler function will be called from the partial-output buffer when the | ||
| 1274 | ;; command completes. This is the way to write commands which invoke gdb | ||
| 1275 | ;; commands autonomously. | ||
| 1276 | ;; | ||
| 1277 | ;; These lists are consumed tail first. | ||
| 1278 | ;; | ||
| 1279 | |||
| 1280 | (defun gdb-send (proc string) | ||
| 1281 | "A comint send filter for gdb. | ||
| 1282 | This filter may simply queue input for a later time." | ||
| 1283 | (if gdb-ready | ||
| 1284 | (progn | ||
| 1285 | (with-current-buffer gud-comint-buffer | ||
| 1286 | (let ((inhibit-read-only t)) | ||
| 1287 | (remove-text-properties (point-min) (point-max) '(face)))) | ||
| 1288 | (if gud-running | ||
| 1289 | (progn | ||
| 1290 | (let ((item (concat string "\n"))) | ||
| 1291 | (if gdb-enable-debug (push (cons 'send item) gdb-debug-log)) | ||
| 1292 | (process-send-string proc item))) | ||
| 1293 | (if (string-match "\\\\\\'" string) | ||
| 1294 | (setq gdb-continuation (concat gdb-continuation string "\n")) | ||
| 1295 | (let ((item (concat | ||
| 1296 | gdb-continuation string | ||
| 1297 | (if (not comint-input-sender-no-newline) "\n")))) | ||
| 1298 | (gdb-enqueue-input item) | ||
| 1299 | (setq gdb-continuation nil))))) | ||
| 1300 | (push (concat string "\n") gdb-early-user-input))) | ||
| 1301 | |||
| 1302 | ;; Note: Stuff enqueued here will be sent to the next prompt, even if it | ||
| 1303 | ;; is a query, or other non-top-level prompt. | ||
| 1304 | |||
| 1305 | (defun gdb-enqueue-input (item) | ||
| 1306 | (if (not gud-running) | ||
| 1307 | (if gdb-prompting | ||
| 1308 | (progn | ||
| 1309 | (gdb-send-item item) | ||
| 1310 | (setq gdb-prompting nil)) | ||
| 1311 | (push item gdb-input-queue)))) | ||
| 1312 | |||
| 1313 | (defun gdb-dequeue-input () | ||
| 1314 | (let ((queue gdb-input-queue)) | ||
| 1315 | (if queue | ||
| 1316 | (let ((last (car (last queue)))) | ||
| 1317 | (unless (nbutlast queue) (setq gdb-input-queue '())) | ||
| 1318 | last) | ||
| 1319 | ;; This should be nil here anyway but set it just to make sure. | ||
| 1320 | (setq gdb-pending-triggers nil)))) | ||
| 1321 | |||
| 1322 | (defun gdb-send-item (item) | ||
| 1323 | (setq gdb-flush-pending-output nil) | ||
| 1324 | (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log)) | ||
| 1325 | (setq gdb-current-item item) | ||
| 1326 | (let ((process (get-buffer-process gud-comint-buffer))) | ||
| 1327 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 1328 | (if (stringp item) | ||
| 1329 | (progn | ||
| 1330 | (setq gdb-output-sink 'user) | ||
| 1331 | (process-send-string process item)) | ||
| 1332 | (progn | ||
| 1333 | (gdb-clear-partial-output) | ||
| 1334 | (setq gdb-output-sink 'pre-emacs) | ||
| 1335 | (process-send-string process | ||
| 1336 | (car item)))) | ||
| 1337 | ;; case: eq gud-minor-mode 'gdbmi | ||
| 1338 | (gdb-clear-partial-output) | ||
| 1339 | (setq gdb-output-sink 'emacs) | ||
| 1340 | (process-send-string process (car item))))) | ||
| 1341 | |||
| 1342 | ;; | ||
| 1343 | ;; output -- things gdb prints to emacs | ||
| 1344 | ;; | ||
| 1345 | ;; GDB output is a stream interrupted by annotations. | ||
| 1346 | ;; Annotations can be recognized by their beginning | ||
| 1347 | ;; with \C-j\C-z\C-z<tag><opt>\C-j | ||
| 1348 | ;; | ||
| 1349 | ;; The tag is a string obeying symbol syntax. | ||
| 1350 | ;; | ||
| 1351 | ;; The optional part `<opt>' can be either the empty string | ||
| 1352 | ;; or a space followed by more data relating to the annotation. | ||
| 1353 | ;; For example, the SOURCE annotation is followed by a filename, | ||
| 1354 | ;; line number and various useless goo. This data must not include | ||
| 1355 | ;; any newlines. | ||
| 1356 | ;; | ||
| 1357 | |||
| 1358 | (defcustom gud-gdb-command-name "gdb --annotate=3" | ||
| 1359 | "Default command to execute an executable under the GDB debugger. | ||
| 1360 | The option \"--annotate=3\" must be included in this value if you | ||
| 1361 | want the GDB Graphical Interface." | ||
| 1362 | :type 'string | ||
| 1363 | :group 'gud | ||
| 1364 | :version "22.1") | ||
| 1365 | |||
| 1366 | (defvar gdb-annotation-rules | ||
| 1367 | '(("pre-prompt" gdb-pre-prompt) | ||
| 1368 | ("prompt" gdb-prompt) | ||
| 1369 | ("commands" gdb-subprompt) | ||
| 1370 | ("overload-choice" gdb-subprompt) | ||
| 1371 | ("query" gdb-subprompt) | ||
| 1372 | ;; Need this prompt for GDB 6.1 | ||
| 1373 | ("nquery" gdb-subprompt) | ||
| 1374 | ("prompt-for-continue" gdb-subprompt) | ||
| 1375 | ("post-prompt" gdb-post-prompt) | ||
| 1376 | ("source" gdb-source) | ||
| 1377 | ("starting" gdb-starting) | ||
| 1378 | ("exited" gdb-exited) | ||
| 1379 | ("signalled" gdb-signalled) | ||
| 1380 | ("signal" gdb-signal) | ||
| 1381 | ("breakpoint" gdb-stopping) | ||
| 1382 | ("watchpoint" gdb-stopping) | ||
| 1383 | ("frame-begin" gdb-frame-begin) | ||
| 1384 | ("stopped" gdb-stopped) | ||
| 1385 | ("error-begin" gdb-error) | ||
| 1386 | ("error" gdb-error) | ||
| 1387 | ("new-thread" (lambda (ignored) | ||
| 1388 | (gdb-get-buffer-create 'gdb-threads-buffer))) | ||
| 1389 | ("thread-changed" gdb-thread-changed)) | ||
| 1390 | "An assoc mapping annotation tags to functions which process them.") | ||
| 1391 | |||
| 1392 | (defun gdb-resync() | ||
| 1393 | (setq gdb-flush-pending-output t) | ||
| 1394 | (setq gud-running nil) | ||
| 1395 | (gdb-force-mode-line-update | ||
| 1396 | (propertize "stopped" 'face font-lock-warning-face)) | ||
| 1397 | (setq gdb-output-sink 'user) | ||
| 1398 | (setq gdb-input-queue nil) | ||
| 1399 | (setq gdb-pending-triggers nil) | ||
| 1400 | (setq gdb-prompting t)) | ||
| 1401 | |||
| 1402 | (defconst gdb-source-spec-regexp | ||
| 1403 | "\\(.*\\):\\([0-9]*\\):[0-9]*:[a-z]*:0x0*\\([a-f0-9]*\\)") | ||
| 1404 | |||
| 1405 | ;; Do not use this except as an annotation handler. | ||
| 1406 | (defun gdb-source (args) | ||
| 1407 | (string-match gdb-source-spec-regexp args) | ||
| 1408 | ;; Extract the frame position from the marker. | ||
| 1409 | (setq gud-last-frame | ||
| 1410 | (cons | ||
| 1411 | (match-string 1 args) | ||
| 1412 | (string-to-number (match-string 2 args)))) | ||
| 1413 | (setq gdb-pc-address (match-string 3 args)) | ||
| 1414 | ;; cover for auto-display output which comes *before* | ||
| 1415 | ;; stopped annotation | ||
| 1416 | (if (eq gdb-output-sink 'inferior) (setq gdb-output-sink 'user))) | ||
| 1417 | |||
| 1418 | (defun gdb-pre-prompt (ignored) | ||
| 1419 | "An annotation handler for `pre-prompt'. | ||
| 1420 | This terminates the collection of output from a previous command if that | ||
| 1421 | happens to be in effect." | ||
| 1422 | (setq gdb-error nil) | ||
| 1423 | (let ((sink gdb-output-sink)) | ||
| 1424 | (cond | ||
| 1425 | ((eq sink 'user) t) | ||
| 1426 | ((eq sink 'emacs) | ||
| 1427 | (setq gdb-output-sink 'post-emacs)) | ||
| 1428 | (t | ||
| 1429 | (gdb-resync) | ||
| 1430 | (error "Phase error in gdb-pre-prompt (got %s)" sink))))) | ||
| 1431 | |||
| 1432 | (defun gdb-prompt (ignored) | ||
| 1433 | "An annotation handler for `prompt'. | ||
| 1434 | This sends the next command (if any) to gdb." | ||
| 1435 | (when gdb-first-prompt | ||
| 1436 | (gdb-force-mode-line-update | ||
| 1437 | (propertize "initializing..." 'face font-lock-variable-name-face)) | ||
| 1438 | (gdb-init-1) | ||
| 1439 | (setq gdb-first-prompt nil)) | ||
| 1440 | (let ((sink gdb-output-sink)) | ||
| 1441 | (cond | ||
| 1442 | ((eq sink 'user) t) | ||
| 1443 | ((eq sink 'post-emacs) | ||
| 1444 | (setq gdb-output-sink 'user) | ||
| 1445 | (let ((handler | ||
| 1446 | (car (cdr gdb-current-item)))) | ||
| 1447 | (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) | ||
| 1448 | (funcall handler)))) | ||
| 1449 | (t | ||
| 1450 | (gdb-resync) | ||
| 1451 | (error "Phase error in gdb-prompt (got %s)" sink)))) | ||
| 1452 | (let ((input (gdb-dequeue-input))) | ||
| 1453 | (if input | ||
| 1454 | (gdb-send-item input) | ||
| 1455 | (progn | ||
| 1456 | (setq gdb-prompting t) | ||
| 1457 | (gud-display-frame) | ||
| 1458 | (setq gdb-early-user-input (nreverse gdb-early-user-input)) | ||
| 1459 | (while gdb-early-user-input | ||
| 1460 | (gdb-enqueue-input (car gdb-early-user-input)) | ||
| 1461 | (setq gdb-early-user-input (cdr gdb-early-user-input))))))) | ||
| 1462 | |||
| 1463 | (defun gdb-subprompt (ignored) | ||
| 1464 | "An annotation handler for non-top-level prompts." | ||
| 1465 | (setq gdb-prompting t)) | ||
| 1466 | |||
| 1467 | (defun gdb-starting (ignored) | ||
| 1468 | "An annotation handler for `starting'. | ||
| 1469 | This says that I/O for the subprocess is now the program being debugged, | ||
| 1470 | not GDB." | ||
| 1471 | (setq gdb-active-process t) | ||
| 1472 | (setq gdb-printing t) | ||
| 1473 | (let ((sink gdb-output-sink)) | ||
| 1474 | (cond | ||
| 1475 | ((eq sink 'user) | ||
| 1476 | (progn | ||
| 1477 | (setq gud-running t) | ||
| 1478 | (setq gdb-stack-update t) | ||
| 1479 | ;; Temporarily set gud-running to nil to force "info stack" onto queue. | ||
| 1480 | (let ((gud-running nil)) | ||
| 1481 | (gdb-invalidate-frames) | ||
| 1482 | (unless (or gdb-register-names | ||
| 1483 | (string-equal gdb-version "pre-6.4")) | ||
| 1484 | (gdb-enqueue-input | ||
| 1485 | (list "server interpreter mi -data-list-register-names\n" | ||
| 1486 | 'gdb-get-register-names)))) | ||
| 1487 | (setq gdb-inferior-status "running") | ||
| 1488 | (setq gdb-signalled nil) | ||
| 1489 | (gdb-force-mode-line-update | ||
| 1490 | (propertize gdb-inferior-status 'face font-lock-type-face)) | ||
| 1491 | (gdb-remove-text-properties) | ||
| 1492 | (setq gud-old-arrow gud-overlay-arrow-position) | ||
| 1493 | (setq gud-overlay-arrow-position nil) | ||
| 1494 | (setq gdb-overlay-arrow-position nil) | ||
| 1495 | (setq gdb-stack-position nil) | ||
| 1496 | (if gdb-use-separate-io-buffer | ||
| 1497 | (setq gdb-output-sink 'inferior)))) | ||
| 1498 | (t | ||
| 1499 | (gdb-resync) | ||
| 1500 | (error "Unexpected `starting' annotation"))))) | ||
| 1501 | |||
| 1502 | (defun gdb-signal (ignored) | ||
| 1503 | (setq gdb-inferior-status "signal") | ||
| 1504 | (gdb-force-mode-line-update | ||
| 1505 | (propertize gdb-inferior-status 'face font-lock-warning-face)) | ||
| 1506 | (gdb-stopping ignored)) | ||
| 1507 | |||
| 1508 | (defun gdb-stopping (ignored) | ||
| 1509 | "An annotation handler for `breakpoint' and other annotations. | ||
| 1510 | They say that I/O for the subprocess is now GDB, not the program | ||
| 1511 | being debugged." | ||
| 1512 | (if gdb-use-separate-io-buffer | ||
| 1513 | (let ((sink gdb-output-sink)) | ||
| 1514 | (cond | ||
| 1515 | ((eq sink 'inferior) | ||
| 1516 | (setq gdb-output-sink 'user)) | ||
| 1517 | (t | ||
| 1518 | (gdb-resync) | ||
| 1519 | (error "Unexpected stopping annotation")))))) | ||
| 1520 | |||
| 1521 | (defun gdb-exited (ignored) | ||
| 1522 | "An annotation handler for `exited' and `signalled'. | ||
| 1523 | They say that I/O for the subprocess is now GDB, not the program | ||
| 1524 | being debugged and that the program is no longer running. This | ||
| 1525 | function is used to change the focus of GUD tooltips to #define | ||
| 1526 | directives." | ||
| 1527 | (setq gdb-active-process nil) | ||
| 1528 | (setq gud-overlay-arrow-position nil) | ||
| 1529 | (setq gdb-overlay-arrow-position nil) | ||
| 1530 | (setq gdb-stack-position nil) | ||
| 1531 | (setq gud-old-arrow nil) | ||
| 1532 | (setq gdb-inferior-status "exited") | ||
| 1533 | (gdb-force-mode-line-update | ||
| 1534 | (propertize gdb-inferior-status 'face font-lock-warning-face)) | ||
| 1535 | (gdb-stopping ignored)) | ||
| 1536 | |||
| 1537 | (defun gdb-signalled (ignored) | ||
| 1538 | (setq gdb-signalled t)) | ||
| 1539 | |||
| 1540 | (defun gdb-frame-begin (ignored) | ||
| 1541 | (setq gdb-frame-begin t) | ||
| 1542 | (setq gdb-printing nil) | ||
| 1543 | (let ((sink gdb-output-sink)) | ||
| 1544 | (cond | ||
| 1545 | ((eq sink 'inferior) | ||
| 1546 | (setq gdb-output-sink 'user)) | ||
| 1547 | ((eq sink 'user) t) | ||
| 1548 | ((eq sink 'emacs) t) | ||
| 1549 | (t | ||
| 1550 | (gdb-resync) | ||
| 1551 | (error "Unexpected frame-begin annotation (%S)" sink))))) | ||
| 1552 | |||
| 1553 | (defcustom gdb-same-frame (not focus-follows-mouse) | ||
| 1554 | "Non-nil means pop up GUD buffer in same frame." | ||
| 1555 | :group 'gdb | ||
| 1556 | :type 'boolean | ||
| 1557 | :version "22.1") | ||
| 1558 | |||
| 1559 | (defcustom gdb-find-source-frame nil | ||
| 1560 | "Non-nil means try to find a source frame further up stack e.g after signal." | ||
| 1561 | :group 'gdb | ||
| 1562 | :type 'boolean | ||
| 1563 | :version "22.1") | ||
| 1564 | |||
| 1565 | (defun gdb-find-source-frame (arg) | ||
| 1566 | "Toggle looking for a source frame further up call stack. | ||
| 1567 | The code associated with current (innermost) frame may not have | ||
| 1568 | been compiled with debug information, e.g., C library routine. | ||
| 1569 | With prefix argument ARG, look for a source frame further up | ||
| 1570 | stack to display in the source buffer if ARG is positive, | ||
| 1571 | otherwise don't look further up." | ||
| 1572 | (interactive "P") | ||
| 1573 | (setq gdb-find-source-frame | ||
| 1574 | (if (null arg) | ||
| 1575 | (not gdb-find-source-frame) | ||
| 1576 | (> (prefix-numeric-value arg) 0))) | ||
| 1577 | (message (format "Looking for source frame %sabled" | ||
| 1578 | (if gdb-find-source-frame "en" "dis")))) | ||
| 1579 | |||
| 1580 | (defun gdb-stopped (ignored) | ||
| 1581 | "An annotation handler for `stopped'. | ||
| 1582 | It is just like `gdb-stopping', except that if we already set the output | ||
| 1583 | sink to `user' in `gdb-stopping', that is fine." | ||
| 1584 | (setq gud-running nil) | ||
| 1585 | (unless (or gud-overlay-arrow-position gud-last-frame) | ||
| 1586 | (if (and gdb-frame-begin gdb-printing) | ||
| 1587 | (setq gud-overlay-arrow-position gud-old-arrow) | ||
| 1588 | ;;Pop up GUD buffer to display current frame when it doesn't have source | ||
| 1589 | ;;information i.e if not compiled with -g as with libc routines generally. | ||
| 1590 | (if gdb-same-frame | ||
| 1591 | (gdb-display-gdb-buffer) | ||
| 1592 | (gdb-frame-gdb-buffer)) | ||
| 1593 | (if gdb-find-source-frame | ||
| 1594 | ;;Try to find source further up stack e.g after signal. | ||
| 1595 | (setq gdb-look-up-stack | ||
| 1596 | (if (gdb-get-buffer 'gdb-stack-buffer) | ||
| 1597 | 'keep | ||
| 1598 | (progn | ||
| 1599 | (gdb-get-buffer-create 'gdb-stack-buffer) | ||
| 1600 | (gdb-invalidate-frames) | ||
| 1601 | 'delete)))))) | ||
| 1602 | (unless (member gdb-inferior-status '("exited" "signal")) | ||
| 1603 | (setq gdb-active-process t) ;Just for attaching case. | ||
| 1604 | (setq gdb-inferior-status "stopped") | ||
| 1605 | (gdb-force-mode-line-update | ||
| 1606 | (propertize gdb-inferior-status 'face font-lock-warning-face))) | ||
| 1607 | (let ((sink gdb-output-sink)) | ||
| 1608 | (cond | ||
| 1609 | ((eq sink 'inferior) | ||
| 1610 | (setq gdb-output-sink 'user)) | ||
| 1611 | ((eq sink 'user) t) | ||
| 1612 | (t | ||
| 1613 | (gdb-resync) | ||
| 1614 | (error "Unexpected stopped annotation")))) | ||
| 1615 | (if gdb-signalled (gdb-exited ignored))) | ||
| 1616 | |||
| 1617 | (defun gdb-error (ignored) | ||
| 1618 | (setq gdb-error (not gdb-error))) | ||
| 1619 | |||
| 1620 | (defun gdb-thread-changed (ignored) | ||
| 1621 | (gdb-frames-force-update)) | ||
| 1622 | |||
| 1623 | (defun gdb-post-prompt (ignored) | ||
| 1624 | "An annotation handler for `post-prompt'. | ||
| 1625 | This begins the collection of output from the current command if that | ||
| 1626 | happens to be appropriate." | ||
| 1627 | ;; Don't add to queue if there outstanding items or gdb-version is not known | ||
| 1628 | ;; yet. | ||
| 1629 | (unless (or gdb-pending-triggers gdb-first-post-prompt) | ||
| 1630 | (gdb-get-selected-frame) | ||
| 1631 | (gdb-invalidate-frames) | ||
| 1632 | ;; Regenerate breakpoints buffer in case it has been inadvertantly deleted. | ||
| 1633 | (gdb-get-buffer-create 'gdb-breakpoints-buffer) | ||
| 1634 | (gdb-invalidate-breakpoints) | ||
| 1635 | ;; Do this through gdb-get-selected-frame -> gdb-frame-handler | ||
| 1636 | ;; so gdb-pc-address is updated. | ||
| 1637 | ;; (gdb-invalidate-assembler) | ||
| 1638 | |||
| 1639 | (if (string-equal gdb-version "pre-6.4") | ||
| 1640 | (gdb-invalidate-registers) | ||
| 1641 | (gdb-get-changed-registers) | ||
| 1642 | (gdb-invalidate-registers-1)) | ||
| 1643 | |||
| 1644 | (gdb-invalidate-memory) | ||
| 1645 | (if (string-equal gdb-version "pre-6.4") | ||
| 1646 | (gdb-invalidate-locals) | ||
| 1647 | (gdb-invalidate-locals-1)) | ||
| 1648 | |||
| 1649 | (gdb-invalidate-threads) | ||
| 1650 | (unless (or (null gdb-var-list) | ||
| 1651 | (eq system-type 'darwin)) ;Breaks on Darwin's GDB-5.3. | ||
| 1652 | ;; FIXME: with GDB-6 on Darwin, this might very well work. | ||
| 1653 | ;; Only needed/used with speedbar/watch expressions. | ||
| 1654 | (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) | ||
| 1655 | (if (string-equal gdb-version "pre-6.4") | ||
| 1656 | (gdb-var-update) | ||
| 1657 | (gdb-var-update-1))))) | ||
| 1658 | (setq gdb-first-post-prompt nil) | ||
| 1659 | (let ((sink gdb-output-sink)) | ||
| 1660 | (cond | ||
| 1661 | ((eq sink 'user) t) | ||
| 1662 | ((eq sink 'pre-emacs) | ||
| 1663 | (setq gdb-output-sink 'emacs)) | ||
| 1664 | (t | ||
| 1665 | (gdb-resync) | ||
| 1666 | (error "Phase error in gdb-post-prompt (got %s)" sink))))) | ||
| 1667 | |||
| 1668 | (defconst gdb-buffer-list | ||
| 1669 | '(gdb-stack-buffer gdb-locals-buffer gdb-registers-buffer gdb-threads-buffer)) | ||
| 1670 | |||
| 1671 | (defun gdb-remove-text-properties () | ||
| 1672 | (dolist (buffertype gdb-buffer-list) | ||
| 1673 | (let ((buffer (gdb-get-buffer buffertype))) | ||
| 1674 | (if buffer | ||
| 1675 | (with-current-buffer buffer | ||
| 1676 | (let ((inhibit-read-only t)) | ||
| 1677 | (remove-text-properties | ||
| 1678 | (point-min) (point-max) '(mouse-face nil help-echo nil)))))))) | ||
| 1679 | |||
| 1680 | ;; GUD displays the selected GDB frame. This might might not be the current | ||
| 1681 | ;; GDB frame (after up, down etc). If no GDB frame is visible but the last | ||
| 1682 | ;; visited breakpoint is, use that window. | ||
| 1683 | (defun gdb-display-source-buffer (buffer) | ||
| 1684 | (let* ((last-window (if gud-last-last-frame | ||
| 1685 | (get-buffer-window | ||
| 1686 | (gud-find-file (car gud-last-last-frame))))) | ||
| 1687 | (source-window (or last-window | ||
| 1688 | (if (and gdb-source-window | ||
| 1689 | (window-live-p gdb-source-window)) | ||
| 1690 | gdb-source-window)))) | ||
| 1691 | (when source-window | ||
| 1692 | (setq gdb-source-window source-window) | ||
| 1693 | (set-window-buffer source-window buffer)) | ||
| 1694 | source-window)) | ||
| 1695 | |||
| 1696 | ;; Derived from gud-gdb-marker-regexp | ||
| 1697 | (defvar gdb-fullname-regexp | ||
| 1698 | (concat "\\(.:?[^" ":" "\n]*\\)" ":" "\\([0-9]*\\)" ":" ".*")) | ||
| 1699 | |||
| 1700 | (defun gud-gdba-marker-filter (string) | ||
| 1701 | "A gud marker filter for gdb. Handle a burst of output from GDB." | ||
| 1702 | (if gdb-flush-pending-output | ||
| 1703 | nil | ||
| 1704 | (when gdb-enable-debug | ||
| 1705 | (push (cons 'recv string) gdb-debug-log) | ||
| 1706 | (if (and gdb-debug-log-max | ||
| 1707 | (> (length gdb-debug-log) gdb-debug-log-max)) | ||
| 1708 | (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil))) | ||
| 1709 | ;; Recall the left over gud-marker-acc from last time. | ||
| 1710 | (setq gud-marker-acc (concat gud-marker-acc string)) | ||
| 1711 | ;; Start accumulating output for the GUD buffer. | ||
| 1712 | (let ((output "")) | ||
| 1713 | ;; | ||
| 1714 | ;; Process all the complete markers in this chunk. | ||
| 1715 | (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) | ||
| 1716 | (let ((annotation (match-string 1 gud-marker-acc)) | ||
| 1717 | (before (substring gud-marker-acc 0 (match-beginning 0))) | ||
| 1718 | (after (substring gud-marker-acc (match-end 0)))) | ||
| 1719 | ;; | ||
| 1720 | ;; Parse the tag from the annotation, and maybe its arguments. | ||
| 1721 | (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation) | ||
| 1722 | (let* ((annotation-type (match-string 1 annotation)) | ||
| 1723 | (annotation-arguments (match-string 2 annotation)) | ||
| 1724 | (annotation-rule (assoc annotation-type | ||
| 1725 | gdb-annotation-rules))) | ||
| 1726 | |||
| 1727 | ;; Stuff prior to the match is just ordinary output. | ||
| 1728 | ;; It is either concatenated to OUTPUT or directed | ||
| 1729 | ;; elsewhere. | ||
| 1730 | (setq output (gdb-concat-output output before)) | ||
| 1731 | |||
| 1732 | ;; Take that stuff off the gud-marker-acc. | ||
| 1733 | (setq gud-marker-acc after) | ||
| 1734 | |||
| 1735 | ;; Call the handler for this annotation. | ||
| 1736 | (if annotation-rule | ||
| 1737 | (funcall (car (cdr annotation-rule)) | ||
| 1738 | annotation-arguments)) | ||
| 1739 | |||
| 1740 | ;; Else the annotation is not recognized. Ignore it silently, | ||
| 1741 | ;; so that GDB can add new annotations without causing | ||
| 1742 | ;; us to blow up. | ||
| 1743 | ))) | ||
| 1744 | |||
| 1745 | ;; Does the remaining text end in a partial line? | ||
| 1746 | ;; If it does, then keep part of the gud-marker-acc until we get more. | ||
| 1747 | (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'" | ||
| 1748 | gud-marker-acc) | ||
| 1749 | (progn | ||
| 1750 | ;; Everything before the potential marker start can be output. | ||
| 1751 | (setq output | ||
| 1752 | (gdb-concat-output output | ||
| 1753 | (substring gud-marker-acc 0 | ||
| 1754 | (match-beginning 0)))) | ||
| 1755 | ;; | ||
| 1756 | ;; Everything after, we save, to combine with later input. | ||
| 1757 | (setq gud-marker-acc (substring gud-marker-acc | ||
| 1758 | (match-beginning 0)))) | ||
| 1759 | ;; | ||
| 1760 | ;; In case we know the gud-marker-acc contains no partial annotations: | ||
| 1761 | (progn | ||
| 1762 | (setq output (gdb-concat-output output gud-marker-acc)) | ||
| 1763 | (setq gud-marker-acc ""))) | ||
| 1764 | output))) | ||
| 1765 | |||
| 1766 | (defun gdb-concat-output (so-far new) | ||
| 1767 | (if gdb-error | ||
| 1768 | (put-text-property 0 (length new) 'face font-lock-warning-face new)) | ||
| 1769 | (let ((sink gdb-output-sink)) | ||
| 1770 | (cond | ||
| 1771 | ((eq sink 'user) (concat so-far new)) | ||
| 1772 | ((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far) | ||
| 1773 | ((eq sink 'emacs) | ||
| 1774 | (gdb-append-to-partial-output new) | ||
| 1775 | so-far) | ||
| 1776 | ((eq sink 'inferior) | ||
| 1777 | (gdb-append-to-inferior-io new) | ||
| 1778 | so-far) | ||
| 1779 | (t | ||
| 1780 | (gdb-resync) | ||
| 1781 | (error "Bogon output sink %S" sink))))) | ||
| 1782 | |||
| 1783 | (defun gdb-append-to-partial-output (string) | ||
| 1784 | (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) | ||
| 1785 | (goto-char (point-max)) | ||
| 1786 | (insert string))) | ||
| 1787 | |||
| 1788 | (defun gdb-clear-partial-output () | ||
| 1789 | (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) | ||
| 1790 | (erase-buffer))) | ||
| 1791 | |||
| 1792 | (defun gdb-append-to-inferior-io (string) | ||
| 1793 | (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) | ||
| 1794 | (goto-char (point-max)) | ||
| 1795 | (insert-before-markers string)) | ||
| 1796 | (if (not (string-equal string "")) | ||
| 1797 | (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t))) | ||
| 1798 | |||
| 1799 | (defun gdb-clear-inferior-io () | ||
| 1800 | (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) | ||
| 1801 | (erase-buffer))) | ||
| 1802 | |||
| 1803 | (defun gdb-jsonify-buffer (&optional fix-key fix-list) | ||
| 1804 | "Prepare GDB/MI output in current buffer for parsing with `json-read'. | ||
| 1805 | |||
| 1806 | Field names are wrapped in double quotes and equal signs are | ||
| 1807 | replaced with semicolons. | ||
| 1808 | |||
| 1809 | If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurences from | ||
| 1810 | partial output. This is used to get rid of useless keys in lists | ||
| 1811 | in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and | ||
| 1812 | -break-info are examples of MI commands which issue such | ||
| 1813 | responses. | ||
| 1814 | |||
| 1815 | If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with | ||
| 1816 | \"FIX-LIST=[..]\" prior to parsing. This is used to fix broken | ||
| 1817 | -break-info output when it contains breakpoint script field | ||
| 1818 | incompatible with GDB/MI output syntax." | ||
| 1819 | (save-excursion | ||
| 1820 | (goto-char (point-min)) | ||
| 1821 | ;; Sometimes missing symbol information precedes "^done" record. | ||
| 1822 | (re-search-forward "[[:ascii:]]*?\\^done," nil t) | ||
| 1823 | (replace-match "") | ||
| 1824 | (re-search-forward "(gdb) \n" nil t) | ||
| 1825 | (replace-match "") | ||
| 1826 | (goto-char (point-min)) | ||
| 1827 | (when fix-key | ||
| 1828 | (save-excursion | ||
| 1829 | (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t) | ||
| 1830 | (replace-match "" nil nil nil 1)))) | ||
| 1831 | (when fix-list | ||
| 1832 | (save-excursion | ||
| 1833 | ;; Find positions of braces which enclose broken list | ||
| 1834 | (while (re-search-forward (concat fix-list "={\"") nil t) | ||
| 1835 | (let ((p1 (goto-char (- (point) 2))) | ||
| 1836 | (p2 (progn (forward-sexp) | ||
| 1837 | (1- (point))))) | ||
| 1838 | ;; Replace braces with brackets | ||
| 1839 | (save-excursion | ||
| 1840 | (goto-char p1) | ||
| 1841 | (delete-char 1) | ||
| 1842 | (insert "[") | ||
| 1843 | (goto-char p2) | ||
| 1844 | (delete-char 1) | ||
| 1845 | (insert "]")))))) | ||
| 1846 | (goto-char (point-min)) | ||
| 1847 | (insert "{") | ||
| 1848 | (while (re-search-forward | ||
| 1849 | "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t) | ||
| 1850 | (replace-match "\"\\1\":\\2" nil nil)) | ||
| 1851 | (goto-char (point-max)) | ||
| 1852 | (insert "}"))) | ||
| 1853 | |||
| 1854 | (defun gdb-json-read-buffer (&optional fix-key fix-list) | ||
| 1855 | "Prepare and parse GDB/MI output in current buffer with `json-read'. | ||
| 1856 | |||
| 1857 | FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." | ||
| 1858 | (gdb-jsonify-buffer fix-key fix-list) | ||
| 1859 | (save-excursion | ||
| 1860 | (goto-char (point-min)) | ||
| 1861 | (let ((json-array-type 'list)) | ||
| 1862 | (json-read)))) | ||
| 1863 | |||
| 1864 | (defun gdb-json-partial-output (&optional fix-key fix-list) | ||
| 1865 | "Prepare and parse gdb-partial-output-buffer with `json-read'. | ||
| 1866 | |||
| 1867 | FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'." | ||
| 1868 | (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) | ||
| 1869 | (gdb-json-read-buffer fix-key fix-list))) | ||
| 1870 | |||
| 1871 | |||
| 1872 | ;; One trick is to have a command who's output is always available in a buffer | ||
| 1873 | ;; of it's own, and is always up to date. We build several buffers of this | ||
| 1874 | ;; type. | ||
| 1875 | ;; | ||
| 1876 | ;; There are two aspects to this: gdb has to tell us when the output for that | ||
| 1877 | ;; command might have changed, and we have to be able to run the command | ||
| 1878 | ;; behind the user's back. | ||
| 1879 | ;; | ||
| 1880 | ;; The output phasing associated with the variable gdb-output-sink | ||
| 1881 | ;; help us to run commands behind the user's back. | ||
| 1882 | ;; | ||
| 1883 | ;; Below is the code for specificly managing buffers of output from one | ||
| 1884 | ;; command. | ||
| 1885 | ;; | ||
| 1886 | |||
| 1887 | ;; The trigger function is suitable for use in the assoc GDB-ANNOTATION-RULES | ||
| 1888 | ;; It adds an input for the command we are tracking. It should be the | ||
| 1889 | ;; annotation rule binding of whatever gdb sends to tell us this command | ||
| 1890 | ;; might have changed it's output. | ||
| 1891 | ;; | ||
| 1892 | ;; NAME is the function name. DEMAND-PREDICATE tests if output is really needed. | ||
| 1893 | ;; GDB-COMMAND is a string of such. OUTPUT-HANDLER is the function bound to the | ||
| 1894 | ;; input in the input queue (see comment about ``gdb communications'' above). | ||
| 1895 | |||
| 1896 | (defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command | ||
| 1897 | output-handler) | ||
| 1898 | `(defun ,name (&optional ignored) | ||
| 1899 | (if (and ,demand-predicate | ||
| 1900 | (not (member ',name | ||
| 1901 | gdb-pending-triggers))) | ||
| 1902 | (progn | ||
| 1903 | (gdb-enqueue-input | ||
| 1904 | (list ,gdb-command ',output-handler)) | ||
| 1905 | (push ',name gdb-pending-triggers))))) | ||
| 1906 | |||
| 1907 | (defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun) | ||
| 1908 | `(defun ,name () | ||
| 1909 | (setq gdb-pending-triggers | ||
| 1910 | (delq ',trigger | ||
| 1911 | gdb-pending-triggers)) | ||
| 1912 | (let ((buf (gdb-get-buffer ',buf-key))) | ||
| 1913 | (and buf | ||
| 1914 | (with-current-buffer buf | ||
| 1915 | (let* ((window (get-buffer-window buf 0)) | ||
| 1916 | (start (window-start window)) | ||
| 1917 | (p (if window (window-point window) (point))) | ||
| 1918 | (buffer-read-only nil)) | ||
| 1919 | (erase-buffer) | ||
| 1920 | (insert-buffer-substring (gdb-get-buffer-create | ||
| 1921 | 'gdb-partial-output-buffer)) | ||
| 1922 | (if window | ||
| 1923 | (progn | ||
| 1924 | (set-window-start window start) | ||
| 1925 | (set-window-point window p)) | ||
| 1926 | (goto-char p)))))) | ||
| 1927 | ;; put customisation here | ||
| 1928 | (,custom-defun))) | ||
| 1929 | |||
| 1930 | (defmacro def-gdb-auto-updated-buffer (buffer-key | ||
| 1931 | trigger-name gdb-command | ||
| 1932 | output-handler-name custom-defun) | ||
| 1933 | `(progn | ||
| 1934 | (def-gdb-auto-update-trigger ,trigger-name | ||
| 1935 | ;; The demand predicate: | ||
| 1936 | (gdb-get-buffer ',buffer-key) | ||
| 1937 | ,gdb-command | ||
| 1938 | ,output-handler-name) | ||
| 1939 | (def-gdb-auto-update-handler ,output-handler-name | ||
| 1940 | ,trigger-name ,buffer-key ,custom-defun))) | ||
| 1941 | |||
| 1942 | |||
| 1943 | ;; | ||
| 1944 | ;; Breakpoint buffer : This displays the output of `info breakpoints'. | ||
| 1945 | ;; | ||
| 1946 | (gdb-set-buffer-rules 'gdb-breakpoints-buffer | ||
| 1947 | 'gdb-breakpoints-buffer-name | ||
| 1948 | 'gdb-breakpoints-mode) | ||
| 1949 | |||
| 1950 | (def-gdb-auto-updated-buffer gdb-breakpoints-buffer | ||
| 1951 | ;; This defines the auto update rule for buffers of type | ||
| 1952 | ;; `gdb-breakpoints-buffer'. | ||
| 1953 | ;; | ||
| 1954 | ;; It defines a function to serve as the annotation handler that | ||
| 1955 | ;; handles the `foo-invalidated' message. That function is called: | ||
| 1956 | gdb-invalidate-breakpoints | ||
| 1957 | ;; | ||
| 1958 | ;; To update the buffer, this command is sent to gdb. | ||
| 1959 | "server info breakpoints\n" | ||
| 1960 | ;; | ||
| 1961 | ;; This also defines a function to be the handler for the output | ||
| 1962 | ;; from the command above. That function will copy the output into | ||
| 1963 | ;; the appropriately typed buffer. That function will be called: | ||
| 1964 | gdb-info-breakpoints-handler | ||
| 1965 | ;; buffer specific functions | ||
| 1966 | gdb-info-breakpoints-custom) | ||
| 1967 | |||
| 1968 | (defconst breakpoint-xpm-data | ||
| 1969 | "/* XPM */ | ||
| 1970 | static char *magick[] = { | ||
| 1971 | /* columns rows colors chars-per-pixel */ | ||
| 1972 | \"10 10 2 1\", | ||
| 1973 | \" c red\", | ||
| 1974 | \"+ c None\", | ||
| 1975 | /* pixels */ | ||
| 1976 | \"+++ +++\", | ||
| 1977 | \"++ ++\", | ||
| 1978 | \"+ +\", | ||
| 1979 | \" \", | ||
| 1980 | \" \", | ||
| 1981 | \" \", | ||
| 1982 | \" \", | ||
| 1983 | \"+ +\", | ||
| 1984 | \"++ ++\", | ||
| 1985 | \"+++ +++\", | ||
| 1986 | };" | ||
| 1987 | "XPM data used for breakpoint icon.") | ||
| 1988 | |||
| 1989 | (defconst breakpoint-enabled-pbm-data | ||
| 1990 | "P1 | ||
| 1991 | 10 10\", | ||
| 1992 | 0 0 0 0 1 1 1 1 0 0 0 0 | ||
| 1993 | 0 0 0 1 1 1 1 1 1 0 0 0 | ||
| 1994 | 0 0 1 1 1 1 1 1 1 1 0 0 | ||
| 1995 | 0 1 1 1 1 1 1 1 1 1 1 0 | ||
| 1996 | 0 1 1 1 1 1 1 1 1 1 1 0 | ||
| 1997 | 0 1 1 1 1 1 1 1 1 1 1 0 | ||
| 1998 | 0 1 1 1 1 1 1 1 1 1 1 0 | ||
| 1999 | 0 0 1 1 1 1 1 1 1 1 0 0 | ||
| 2000 | 0 0 0 1 1 1 1 1 1 0 0 0 | ||
| 2001 | 0 0 0 0 1 1 1 1 0 0 0 0" | ||
| 2002 | "PBM data used for enabled breakpoint icon.") | ||
| 2003 | |||
| 2004 | (defconst breakpoint-disabled-pbm-data | ||
| 2005 | "P1 | ||
| 2006 | 10 10\", | ||
| 2007 | 0 0 1 0 1 0 1 0 0 0 | ||
| 2008 | 0 1 0 1 0 1 0 1 0 0 | ||
| 2009 | 1 0 1 0 1 0 1 0 1 0 | ||
| 2010 | 0 1 0 1 0 1 0 1 0 1 | ||
| 2011 | 1 0 1 0 1 0 1 0 1 0 | ||
| 2012 | 0 1 0 1 0 1 0 1 0 1 | ||
| 2013 | 1 0 1 0 1 0 1 0 1 0 | ||
| 2014 | 0 1 0 1 0 1 0 1 0 1 | ||
| 2015 | 0 0 1 0 1 0 1 0 1 0 | ||
| 2016 | 0 0 0 1 0 1 0 1 0 0" | ||
| 2017 | "PBM data used for disabled breakpoint icon.") | ||
| 2018 | |||
| 2019 | (defvar breakpoint-enabled-icon nil | ||
| 2020 | "Icon for enabled breakpoint in display margin.") | ||
| 2021 | |||
| 2022 | (defvar breakpoint-disabled-icon nil | ||
| 2023 | "Icon for disabled breakpoint in display margin.") | ||
| 2024 | |||
| 2025 | (declare-function define-fringe-bitmap "fringe.c" | ||
| 2026 | (bitmap bits &optional height width align)) | ||
| 2027 | |||
| 2028 | (and (display-images-p) | ||
| 2029 | ;; Bitmap for breakpoint in fringe | ||
| 2030 | (define-fringe-bitmap 'breakpoint | ||
| 2031 | "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") | ||
| 2032 | ;; Bitmap for gud-overlay-arrow in fringe | ||
| 2033 | (define-fringe-bitmap 'hollow-right-triangle | ||
| 2034 | "\xe0\x90\x88\x84\x84\x88\x90\xe0")) | ||
| 2035 | |||
| 2036 | (defface breakpoint-enabled | ||
| 2037 | '((t | ||
| 2038 | :foreground "red1" | ||
| 2039 | :weight bold)) | ||
| 2040 | "Face for enabled breakpoint icon in fringe." | ||
| 2041 | :group 'gdb) | ||
| 2042 | |||
| 2043 | (defface breakpoint-disabled | ||
| 2044 | '((((class color) (min-colors 88)) :foreground "grey70") | ||
| 2045 | ;; Ensure that on low-color displays that we end up something visible. | ||
| 2046 | (((class color) (min-colors 8) (background light)) | ||
| 2047 | :foreground "black") | ||
| 2048 | (((class color) (min-colors 8) (background dark)) | ||
| 2049 | :foreground "white") | ||
| 2050 | (((type tty) (class mono)) | ||
| 2051 | :inverse-video t) | ||
| 2052 | (t :background "gray")) | ||
| 2053 | "Face for disabled breakpoint icon in fringe." | ||
| 2054 | :group 'gdb) | ||
| 2055 | |||
| 2056 | (defconst gdb-breakpoint-regexp | ||
| 2057 | "\\(?:\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\|\\([0-9]+\\.[0-9]+\\)\\)\\s-+\\(.\\)\\s-+") | ||
| 2058 | |||
| 2059 | ;; Put breakpoint icons in relevant margins (even those set in the GUD buffer). | ||
| 2060 | (defun gdb-info-breakpoints-custom () | ||
| 2061 | (let ((flag) (bptno)) | ||
| 2062 | ;; Remove all breakpoint-icons in source buffers but not assembler buffer. | ||
| 2063 | (dolist (buffer (buffer-list)) | ||
| 2064 | (with-current-buffer buffer | ||
| 2065 | (if (and (memq gud-minor-mode '(gdba gdbmi)) | ||
| 2066 | (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name)))) | ||
| 2067 | (gdb-remove-breakpoint-icons (point-min) (point-max))))) | ||
| 2068 | (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer) | ||
| 2069 | (save-excursion | ||
| 2070 | (let ((buffer-read-only nil)) | ||
| 2071 | (goto-char (point-min)) | ||
| 2072 | (while (< (point) (- (point-max) 1)) | ||
| 2073 | (forward-line 1) | ||
| 2074 | (if (looking-at gdb-breakpoint-regexp) | ||
| 2075 | (progn | ||
| 2076 | (setq bptno (or (match-string 1) (match-string 2))) | ||
| 2077 | (setq flag (char-after (match-beginning 3))) | ||
| 2078 | (if (match-string 1) | ||
| 2079 | (setq gdb-parent-bptno-enabled (eq flag ?y))) | ||
| 2080 | (add-text-properties | ||
| 2081 | (match-beginning 3) (match-end 3) | ||
| 2082 | (if (eq flag ?y) | ||
| 2083 | '(face font-lock-warning-face) | ||
| 2084 | '(face font-lock-type-face))) | ||
| 2085 | (let ((bl (point)) | ||
| 2086 | (el (line-end-position))) | ||
| 2087 | (when (re-search-forward " in \\(.*\\) at" el t) | ||
| 2088 | (add-text-properties | ||
| 2089 | (match-beginning 1) (match-end 1) | ||
| 2090 | '(face font-lock-function-name-face))) | ||
| 2091 | (if (re-search-forward | ||
| 2092 | ".*\\s-+\\(\\S-+\\):\\([0-9]+\\)$" el t) | ||
| 2093 | (let ((line (match-string 2)) | ||
| 2094 | (file (match-string 1))) | ||
| 2095 | (add-text-properties bl el | ||
| 2096 | '(mouse-face highlight | ||
| 2097 | help-echo "mouse-2, RET: visit breakpoint")) | ||
| 2098 | (unless (file-exists-p file) | ||
| 2099 | (setq file (cdr (assoc bptno gdb-location-alist)))) | ||
| 2100 | (if (and file | ||
| 2101 | (not (string-equal file "File not found"))) | ||
| 2102 | (with-current-buffer | ||
| 2103 | (find-file-noselect file 'nowarn) | ||
| 2104 | (gdb-init-buffer) | ||
| 2105 | ;; Only want one breakpoint icon at each | ||
| 2106 | ;; location. | ||
| 2107 | (save-excursion | ||
| 2108 | (goto-char (point-min)) | ||
| 2109 | (forward-line (1- (string-to-number line))) | ||
| 2110 | (gdb-put-breakpoint-icon (eq flag ?y) bptno))) | ||
| 2111 | (gdb-enqueue-input | ||
| 2112 | (list | ||
| 2113 | (concat gdb-server-prefix "list " | ||
| 2114 | (match-string-no-properties 1) ":1\n") | ||
| 2115 | 'ignore)) | ||
| 2116 | (gdb-enqueue-input | ||
| 2117 | (list (concat gdb-server-prefix "info source\n") | ||
| 2118 | `(lambda () (gdb-get-location | ||
| 2119 | ,bptno ,line ,flag)))))) | ||
| 2120 | (if (re-search-forward | ||
| 2121 | "<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" | ||
| 2122 | el t) | ||
| 2123 | (add-text-properties | ||
| 2124 | (match-beginning 1) (match-end 1) | ||
| 2125 | '(face font-lock-function-name-face)) | ||
| 2126 | (end-of-line) | ||
| 2127 | (re-search-backward "\\s-\\(\\S-*\\)" | ||
| 2128 | bl t) | ||
| 2129 | (add-text-properties | ||
| 2130 | (match-beginning 1) (match-end 1) | ||
| 2131 | '(face font-lock-variable-name-face))))))) | ||
| 2132 | (end-of-line)))))) | ||
| 2133 | (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)) | ||
| 2134 | |||
| 2135 | ;; Breakpoints buffer is always present. Hack to just update | ||
| 2136 | ;; current frame if there's been no execution. | ||
| 2137 | (if gdb-stack-update | ||
| 2138 | (setq gdb-stack-update nil) | ||
| 2139 | (if (gdb-get-buffer 'gdb-stack-buffer) (gdb-info-stack-custom)))) | ||
| 2140 | |||
| 2141 | (declare-function gud-remove "gdb-ui" t t) ; gud-def | ||
| 2142 | (declare-function gud-break "gdb-ui" t t) ; gud-def | ||
| 2143 | (declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window)) | ||
| 2144 | |||
| 2145 | (defun gdb-mouse-set-clear-breakpoint (event) | ||
| 2146 | "Set/clear breakpoint in left fringe/margin at mouse click. | ||
| 2147 | If not in a source or disassembly buffer just set point." | ||
| 2148 | (interactive "e") | ||
| 2149 | (mouse-minibuffer-check event) | ||
| 2150 | (let ((posn (event-end event))) | ||
| 2151 | (with-selected-window (posn-window posn) | ||
| 2152 | (if (or (buffer-file-name) (eq major-mode 'gdb-assembler-mode)) | ||
| 2153 | (if (numberp (posn-point posn)) | ||
| 2154 | (save-excursion | ||
| 2155 | (goto-char (posn-point posn)) | ||
| 2156 | (if (or (posn-object posn) | ||
| 2157 | (eq (car (fringe-bitmaps-at-pos (posn-point posn))) | ||
| 2158 | 'breakpoint)) | ||
| 2159 | (gud-remove nil) | ||
| 2160 | (gud-break nil))))) | ||
| 2161 | (posn-set-point posn)))) | ||
| 2162 | |||
| 2163 | (defun gdb-mouse-toggle-breakpoint-margin (event) | ||
| 2164 | "Enable/disable breakpoint in left margin with mouse click." | ||
| 2165 | (interactive "e") | ||
| 2166 | (mouse-minibuffer-check event) | ||
| 2167 | (let ((posn (event-end event))) | ||
| 2168 | (if (numberp (posn-point posn)) | ||
| 2169 | (with-selected-window (posn-window posn) | ||
| 2170 | (save-excursion | ||
| 2171 | (goto-char (posn-point posn)) | ||
| 2172 | (if (posn-object posn) | ||
| 2173 | (let* ((bptno (get-text-property | ||
| 2174 | 0 'gdb-bptno (car (posn-string posn))))) | ||
| 2175 | (string-match "\\([0-9+]\\)*" bptno) | ||
| 2176 | (gdb-enqueue-input | ||
| 2177 | (list | ||
| 2178 | (concat gdb-server-prefix | ||
| 2179 | (if (get-text-property | ||
| 2180 | 0 'gdb-enabled (car (posn-string posn))) | ||
| 2181 | "disable " | ||
| 2182 | "enable ") | ||
| 2183 | (match-string 1 bptno) "\n") | ||
| 2184 | 'ignore))))))))) | ||
| 2185 | |||
| 2186 | (defun gdb-mouse-toggle-breakpoint-fringe (event) | ||
| 2187 | "Enable/disable breakpoint in left fringe with mouse click." | ||
| 2188 | (interactive "e") | ||
| 2189 | (mouse-minibuffer-check event) | ||
| 2190 | (let* ((posn (event-end event)) | ||
| 2191 | (pos (posn-point posn)) | ||
| 2192 | obj) | ||
| 2193 | (when (numberp pos) | ||
| 2194 | (with-selected-window (posn-window posn) | ||
| 2195 | (with-current-buffer (window-buffer (selected-window)) | ||
| 2196 | (goto-char pos) | ||
| 2197 | (dolist (overlay (overlays-in pos pos)) | ||
| 2198 | (when (overlay-get overlay 'put-break) | ||
| 2199 | (setq obj (overlay-get overlay 'before-string)))) | ||
| 2200 | (when (stringp obj) | ||
| 2201 | (let* ((bptno (get-text-property 0 'gdb-bptno obj))) | ||
| 2202 | (string-match "\\([0-9+]\\)*" bptno) | ||
| 2203 | (gdb-enqueue-input | ||
| 2204 | (list | ||
| 2205 | (concat gdb-server-prefix | ||
| 2206 | (if (get-text-property 0 'gdb-enabled obj) | ||
| 2207 | "disable " | ||
| 2208 | "enable ") | ||
| 2209 | (match-string 1 bptno) "\n") | ||
| 2210 | 'ignore))))))))) | ||
| 2211 | |||
| 2212 | (defun gdb-breakpoints-buffer-name () | ||
| 2213 | (with-current-buffer gud-comint-buffer | ||
| 2214 | (concat "*breakpoints of " (gdb-get-target-string) "*"))) | ||
| 2215 | |||
| 2216 | (defun gdb-display-breakpoints-buffer () | ||
| 2217 | "Display status of user-settable breakpoints." | ||
| 2218 | (interactive) | ||
| 2219 | (gdb-display-buffer | ||
| 2220 | (gdb-get-buffer-create 'gdb-breakpoints-buffer) t)) | ||
| 2221 | |||
| 2222 | (defun gdb-frame-breakpoints-buffer () | ||
| 2223 | "Display status of user-settable breakpoints in a new frame." | ||
| 2224 | (interactive) | ||
| 2225 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 2226 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 2227 | (display-buffer (gdb-get-buffer-create 'gdb-breakpoints-buffer)))) | ||
| 2228 | |||
| 2229 | (defvar gdb-breakpoints-mode-map | ||
| 2230 | (let ((map (make-sparse-keymap)) | ||
| 2231 | (menu (make-sparse-keymap "Breakpoints"))) | ||
| 2232 | (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window)) | ||
| 2233 | (define-key menu [goto] '("Goto" . gdb-goto-breakpoint)) | ||
| 2234 | (define-key menu [delete] '("Delete" . gdb-delete-breakpoint)) | ||
| 2235 | (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint)) | ||
| 2236 | (suppress-keymap map) | ||
| 2237 | (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu)) | ||
| 2238 | (define-key map " " 'gdb-toggle-breakpoint) | ||
| 2239 | (define-key map "D" 'gdb-delete-breakpoint) | ||
| 2240 | ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons. | ||
| 2241 | (define-key map "q" 'gdb-delete-frame-or-window) | ||
| 2242 | (define-key map "\r" 'gdb-goto-breakpoint) | ||
| 2243 | (define-key map [mouse-2] 'gdb-goto-breakpoint) | ||
| 2244 | (define-key map [follow-link] 'mouse-face) | ||
| 2245 | map)) | ||
| 2246 | |||
| 2247 | (defun gdb-delete-frame-or-window () | ||
| 2248 | "Delete frame if there is only one window. Otherwise delete the window." | ||
| 2249 | (interactive) | ||
| 2250 | (if (one-window-p) (delete-frame) | ||
| 2251 | (delete-window))) | ||
| 2252 | |||
| 2253 | ;;from make-mode-line-mouse-map | ||
| 2254 | (defun gdb-make-header-line-mouse-map (mouse function) "\ | ||
| 2255 | Return a keymap with single entry for mouse key MOUSE on the header line. | ||
| 2256 | MOUSE is defined to run function FUNCTION with no args in the buffer | ||
| 2257 | corresponding to the mode line clicked." | ||
| 2258 | (let ((map (make-sparse-keymap))) | ||
| 2259 | (define-key map (vector 'header-line mouse) function) | ||
| 2260 | (define-key map (vector 'header-line 'down-mouse-1) 'ignore) | ||
| 2261 | map)) | ||
| 2262 | |||
| 2263 | (defmacro gdb-propertize-header (name buffer help-echo mouse-face face) | ||
| 2264 | `(propertize ,name | ||
| 2265 | 'help-echo ,help-echo | ||
| 2266 | 'mouse-face ',mouse-face | ||
| 2267 | 'face ',face | ||
| 2268 | 'local-map | ||
| 2269 | (gdb-make-header-line-mouse-map | ||
| 2270 | 'mouse-1 | ||
| 2271 | (lambda (event) (interactive "e") | ||
| 2272 | (save-selected-window | ||
| 2273 | (select-window (posn-window (event-start event))) | ||
| 2274 | (set-window-dedicated-p (selected-window) nil) | ||
| 2275 | (switch-to-buffer | ||
| 2276 | (gdb-get-buffer-create ',buffer)) | ||
| 2277 | (setq header-line-format(gdb-set-header ',buffer)) | ||
| 2278 | (set-window-dedicated-p (selected-window) t)))))) | ||
| 2279 | |||
| 2280 | (defun gdb-set-header (buffer) | ||
| 2281 | (cond ((eq buffer 'gdb-locals-buffer) | ||
| 2282 | (list | ||
| 2283 | (gdb-propertize-header "Locals" gdb-locals-buffer | ||
| 2284 | nil nil mode-line) | ||
| 2285 | " " | ||
| 2286 | (gdb-propertize-header "Registers" gdb-registers-buffer | ||
| 2287 | "mouse-1: select" mode-line-highlight mode-line-inactive))) | ||
| 2288 | ((eq buffer 'gdb-registers-buffer) | ||
| 2289 | (list | ||
| 2290 | (gdb-propertize-header "Locals" gdb-locals-buffer | ||
| 2291 | "mouse-1: select" mode-line-highlight mode-line-inactive) | ||
| 2292 | " " | ||
| 2293 | (gdb-propertize-header "Registers" gdb-registers-buffer | ||
| 2294 | nil nil mode-line))) | ||
| 2295 | ((eq buffer 'gdb-breakpoints-buffer) | ||
| 2296 | (list | ||
| 2297 | (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer | ||
| 2298 | nil nil mode-line) | ||
| 2299 | " " | ||
| 2300 | (gdb-propertize-header "Threads" gdb-threads-buffer | ||
| 2301 | "mouse-1: select" mode-line-highlight mode-line-inactive))) | ||
| 2302 | ((eq buffer 'gdb-threads-buffer) | ||
| 2303 | (list | ||
| 2304 | (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer | ||
| 2305 | "mouse-1: select" mode-line-highlight mode-line-inactive) | ||
| 2306 | " " | ||
| 2307 | (gdb-propertize-header "Threads" gdb-threads-buffer | ||
| 2308 | nil nil mode-line))))) | ||
| 2309 | |||
| 2310 | (defvar gdb-breakpoints-header | ||
| 2311 | (list | ||
| 2312 | (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer | ||
| 2313 | nil nil mode-line) | ||
| 2314 | " " | ||
| 2315 | (gdb-propertize-header "Threads" gdb-threads-buffer | ||
| 2316 | "mouse-1: select" mode-line-highlight mode-line-inactive))) | ||
| 2317 | |||
| 2318 | (defun gdb-breakpoints-mode () | ||
| 2319 | "Major mode for gdb breakpoints. | ||
| 2320 | |||
| 2321 | \\{gdb-breakpoints-mode-map}" | ||
| 2322 | (kill-all-local-variables) | ||
| 2323 | (setq major-mode 'gdb-breakpoints-mode) | ||
| 2324 | (setq mode-name "Breakpoints") | ||
| 2325 | (use-local-map gdb-breakpoints-mode-map) | ||
| 2326 | (setq buffer-read-only t) | ||
| 2327 | (buffer-disable-undo) | ||
| 2328 | (setq header-line-format gdb-breakpoints-header) | ||
| 2329 | (run-mode-hooks 'gdb-breakpoints-mode-hook) | ||
| 2330 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 2331 | 'gdb-invalidate-breakpoints | ||
| 2332 | 'gdbmi-invalidate-breakpoints)) | ||
| 2333 | |||
| 2334 | (defun gdb-toggle-breakpoint () | ||
| 2335 | "Enable/disable breakpoint at current line." | ||
| 2336 | (interactive) | ||
| 2337 | (save-excursion | ||
| 2338 | (beginning-of-line 1) | ||
| 2339 | (if (looking-at gdb-breakpoint-regexp) | ||
| 2340 | (gdb-enqueue-input | ||
| 2341 | (list | ||
| 2342 | (concat gdb-server-prefix | ||
| 2343 | (if (eq ?y (char-after (match-beginning 3))) | ||
| 2344 | "disable " | ||
| 2345 | "enable ") | ||
| 2346 | (or (match-string 1) (match-string 2)) "\n") 'ignore)) | ||
| 2347 | (error "Not recognized as break/watchpoint line")))) | ||
| 2348 | |||
| 2349 | (defun gdb-delete-breakpoint () | ||
| 2350 | "Delete the breakpoint at current line." | ||
| 2351 | (interactive) | ||
| 2352 | (save-excursion | ||
| 2353 | (beginning-of-line 1) | ||
| 2354 | (if (looking-at gdb-breakpoint-regexp) | ||
| 2355 | (if (match-string 1) | ||
| 2356 | (gdb-enqueue-input | ||
| 2357 | (list | ||
| 2358 | (concat gdb-server-prefix "delete " (match-string 1) "\n") | ||
| 2359 | 'ignore)) | ||
| 2360 | (message-box "This breakpoint cannot be deleted on its own.")) | ||
| 2361 | (error "Not recognized as break/watchpoint line")))) | ||
| 2362 | |||
| 2363 | (defun gdb-goto-breakpoint (&optional event) | ||
| 2364 | "Display the breakpoint location specified at current line." | ||
| 2365 | (interactive (list last-input-event)) | ||
| 2366 | (if event (posn-set-point (event-end event))) | ||
| 2367 | (save-excursion | ||
| 2368 | (beginning-of-line 1) | ||
| 2369 | (if (looking-at "\\([0-9]+\\.?[0-9]*\\) .*\\s-+\\(\\S-+\\):\\([0-9]+\\)$") | ||
| 2370 | (let ((bptno (match-string 1)) | ||
| 2371 | (file (match-string 2)) | ||
| 2372 | (line (match-string 3))) | ||
| 2373 | (save-selected-window | ||
| 2374 | (let* ((buffer (find-file-noselect | ||
| 2375 | (if (file-exists-p file) file | ||
| 2376 | (cdr (assoc bptno gdb-location-alist))))) | ||
| 2377 | (window (or (gdb-display-source-buffer buffer) | ||
| 2378 | (display-buffer buffer)))) | ||
| 2379 | (setq gdb-source-window window) | ||
| 2380 | (with-current-buffer buffer | ||
| 2381 | (goto-char (point-min)) | ||
| 2382 | (forward-line (1- (string-to-number line))) | ||
| 2383 | (set-window-point window (point)))))) | ||
| 2384 | (error "No location specified.")))) | ||
| 2385 | |||
| 2386 | |||
| 2387 | ;; Frames buffer. This displays a perpetually correct backtrace | ||
| 2388 | ;; (from the command `where'). | ||
| 2389 | ;; | ||
| 2390 | ;; Alas, if your stack is deep, it is costly. | ||
| 2391 | ;; | ||
| 2392 | (defcustom gdb-max-frames 40 | ||
| 2393 | "Maximum number of frames displayed in call stack." | ||
| 2394 | :type 'integer | ||
| 2395 | :group 'gdb | ||
| 2396 | :version "22.1") | ||
| 2397 | |||
| 2398 | (gdb-set-buffer-rules 'gdb-stack-buffer | ||
| 2399 | 'gdb-stack-buffer-name | ||
| 2400 | 'gdb-frames-mode) | ||
| 2401 | |||
| 2402 | (def-gdb-auto-updated-buffer gdb-stack-buffer | ||
| 2403 | gdb-invalidate-frames | ||
| 2404 | (concat "server info stack " (number-to-string gdb-max-frames) "\n") | ||
| 2405 | gdb-info-stack-handler | ||
| 2406 | gdb-info-stack-custom) | ||
| 2407 | |||
| 2408 | ;; This may be more important for embedded targets where unwinding the | ||
| 2409 | ;; stack may take a long time. | ||
| 2410 | (defadvice gdb-invalidate-frames (around gdb-invalidate-frames-advice | ||
| 2411 | (&optional ignored) activate compile) | ||
| 2412 | "Only queue \"info stack\" if execution has occurred." | ||
| 2413 | (if gdb-stack-update ad-do-it)) | ||
| 2414 | |||
| 2415 | (defun gdb-info-stack-custom () | ||
| 2416 | (with-current-buffer (gdb-get-buffer 'gdb-stack-buffer) | ||
| 2417 | (let (move-to) | ||
| 2418 | (save-excursion | ||
| 2419 | (unless (eq gdb-look-up-stack 'delete) | ||
| 2420 | (let ((buffer-read-only nil) | ||
| 2421 | bl el) | ||
| 2422 | (goto-char (point-min)) | ||
| 2423 | (while (< (point) (point-max)) | ||
| 2424 | (setq bl (line-beginning-position) | ||
| 2425 | el (line-end-position)) | ||
| 2426 | (when (looking-at "#") | ||
| 2427 | (add-text-properties bl el | ||
| 2428 | '(mouse-face highlight | ||
| 2429 | help-echo "mouse-2, RET: Select frame"))) | ||
| 2430 | (goto-char bl) | ||
| 2431 | (when (looking-at "^#\\([0-9]+\\)") | ||
| 2432 | (when (string-equal (match-string 1) gdb-frame-number) | ||
| 2433 | (if (gud-tool-bar-item-visible-no-fringe) | ||
| 2434 | (progn | ||
| 2435 | (put-text-property bl (+ bl 4) | ||
| 2436 | 'face '(:inverse-video t)) | ||
| 2437 | (setq move-to bl)) | ||
| 2438 | (or gdb-stack-position | ||
| 2439 | (setq gdb-stack-position (make-marker))) | ||
| 2440 | (set-marker gdb-stack-position (point)) | ||
| 2441 | (setq move-to gdb-stack-position))) | ||
| 2442 | (when (re-search-forward "\\([^ ]+\\) (" el t) | ||
| 2443 | (put-text-property (match-beginning 1) (match-end 1) | ||
| 2444 | 'face font-lock-function-name-face) | ||
| 2445 | (setq bl (match-end 0)) | ||
| 2446 | (while (re-search-forward "<\\([^>]+\\)>" el t) | ||
| 2447 | (put-text-property (match-beginning 1) (match-end 1) | ||
| 2448 | 'face font-lock-function-name-face)) | ||
| 2449 | (goto-char bl) | ||
| 2450 | (while (re-search-forward "\\(\\(\\sw\\|[_.]\\)+\\)=" el t) | ||
| 2451 | (put-text-property (match-beginning 1) (match-end 1) | ||
| 2452 | 'face font-lock-variable-name-face)))) | ||
| 2453 | (forward-line 1)) | ||
| 2454 | (forward-line -1) | ||
| 2455 | (when (looking-at "(More stack frames follow...)") | ||
| 2456 | (add-text-properties | ||
| 2457 | (match-beginning 0) (match-end 0) | ||
| 2458 | '(mouse-face highlight | ||
| 2459 | gdb-max-frames t | ||
| 2460 | help-echo | ||
| 2461 | "mouse-2, RET: customize gdb-max-frames to see more frames" | ||
| 2462 | ))))) | ||
| 2463 | (when gdb-look-up-stack | ||
| 2464 | (goto-char (point-min)) | ||
| 2465 | (when (re-search-forward "\\(\\S-+?\\):\\([0-9]+\\)" nil t) | ||
| 2466 | (let ((start (line-beginning-position)) | ||
| 2467 | (file (match-string 1)) | ||
| 2468 | (line (match-string 2))) | ||
| 2469 | (re-search-backward "^#*\\([0-9]+\\)" start t) | ||
| 2470 | (gdb-enqueue-input | ||
| 2471 | (list (concat gdb-server-prefix "frame " | ||
| 2472 | (match-string 1) "\n") 'gdb-set-hollow)) | ||
| 2473 | (gdb-enqueue-input | ||
| 2474 | (list (concat gdb-server-prefix "frame 0\n") 'ignore)))))) | ||
| 2475 | (when move-to | ||
| 2476 | (let ((window (get-buffer-window (current-buffer) 0))) | ||
| 2477 | (when window | ||
| 2478 | (with-selected-window window | ||
| 2479 | (goto-char move-to) | ||
| 2480 | (unless (pos-visible-in-window-p) | ||
| 2481 | (recenter '(center))))))))) | ||
| 2482 | (if (eq gdb-look-up-stack 'delete) | ||
| 2483 | (kill-buffer (gdb-get-buffer 'gdb-stack-buffer))) | ||
| 2484 | (setq gdb-look-up-stack nil)) | ||
| 2485 | |||
| 2486 | (defun gdb-set-hollow () | ||
| 2487 | (if gud-last-last-frame | ||
| 2488 | (with-current-buffer (gud-find-file (car gud-last-last-frame)) | ||
| 2489 | (setq fringe-indicator-alist | ||
| 2490 | '((overlay-arrow . hollow-right-triangle)))))) | ||
| 2491 | |||
| 2492 | (defun gdb-stack-buffer-name () | ||
| 2493 | (with-current-buffer gud-comint-buffer | ||
| 2494 | (concat "*stack frames of " (gdb-get-target-string) "*"))) | ||
| 2495 | |||
| 2496 | (defun gdb-display-stack-buffer () | ||
| 2497 | "Display backtrace of current stack." | ||
| 2498 | (interactive) | ||
| 2499 | (gdb-display-buffer | ||
| 2500 | (gdb-get-buffer-create 'gdb-stack-buffer) t)) | ||
| 2501 | |||
| 2502 | (defun gdb-frame-stack-buffer () | ||
| 2503 | "Display backtrace of current stack in a new frame." | ||
| 2504 | (interactive) | ||
| 2505 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 2506 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 2507 | (display-buffer (gdb-get-buffer-create 'gdb-stack-buffer)))) | ||
| 2508 | |||
| 2509 | (defvar gdb-frames-mode-map | ||
| 2510 | (let ((map (make-sparse-keymap))) | ||
| 2511 | (suppress-keymap map) | ||
| 2512 | (define-key map "q" 'kill-this-buffer) | ||
| 2513 | (define-key map "\r" 'gdb-frames-select) | ||
| 2514 | (define-key map "F" 'gdb-frames-force-update) | ||
| 2515 | (define-key map [mouse-2] 'gdb-frames-select) | ||
| 2516 | (define-key map [follow-link] 'mouse-face) | ||
| 2517 | map)) | ||
| 2518 | |||
| 2519 | (declare-function gdbmi-invalidate-frames "ext:gdb-mi" nil t) | ||
| 2520 | |||
| 2521 | (defun gdb-frames-force-update () | ||
| 2522 | "Force update of call stack. | ||
| 2523 | Use when the displayed call stack gets out of sync with the | ||
| 2524 | actual one, e.g after using the Gdb command \"return\" or setting | ||
| 2525 | $pc directly from the GUD buffer. This command isn't normally needed." | ||
| 2526 | (interactive) | ||
| 2527 | (setq gdb-stack-update t) | ||
| 2528 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 2529 | (gdb-invalidate-frames) | ||
| 2530 | (gdbmi-invalidate-frames))) | ||
| 2531 | |||
| 2532 | (defun gdb-frames-mode () | ||
| 2533 | "Major mode for gdb call stack. | ||
| 2534 | |||
| 2535 | \\{gdb-frames-mode-map}" | ||
| 2536 | (kill-all-local-variables) | ||
| 2537 | (setq major-mode 'gdb-frames-mode) | ||
| 2538 | (setq mode-name "Frames") | ||
| 2539 | (setq gdb-stack-position nil) | ||
| 2540 | (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position) | ||
| 2541 | (setq truncate-lines t) ;; Make it easier to see overlay arrow. | ||
| 2542 | (setq buffer-read-only t) | ||
| 2543 | (buffer-disable-undo) | ||
| 2544 | (gdb-thread-identification) | ||
| 2545 | (use-local-map gdb-frames-mode-map) | ||
| 2546 | (run-mode-hooks 'gdb-frames-mode-hook) | ||
| 2547 | (setq gdb-stack-update t) | ||
| 2548 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 2549 | 'gdb-invalidate-frames | ||
| 2550 | 'gdbmi-invalidate-frames)) | ||
| 2551 | |||
| 2552 | (defun gdb-get-frame-number () | ||
| 2553 | (save-excursion | ||
| 2554 | (end-of-line) | ||
| 2555 | (let* ((start (line-beginning-position)) | ||
| 2556 | (pos (re-search-backward "^#*\\([0-9]+\\)" start t)) | ||
| 2557 | (n (or (and pos (match-string 1)) "0"))) | ||
| 2558 | n))) | ||
| 2559 | |||
| 2560 | (defun gdb-frames-select (&optional event) | ||
| 2561 | "Select the frame and display the relevant source." | ||
| 2562 | (interactive (list last-input-event)) | ||
| 2563 | (if event (posn-set-point (event-end event))) | ||
| 2564 | (if (get-text-property (point) 'gdb-max-frames) | ||
| 2565 | (progn | ||
| 2566 | (message-box "After setting gdb-max-frames, you need to enter\n\ | ||
| 2567 | another GDB command e.g pwd, to see new frames") | ||
| 2568 | (customize-variable-other-window 'gdb-max-frames)) | ||
| 2569 | (gdb-enqueue-input | ||
| 2570 | (list (concat gdb-server-prefix "frame " | ||
| 2571 | (gdb-get-frame-number) "\n") 'ignore)))) | ||
| 2572 | |||
| 2573 | |||
| 2574 | ;; Threads buffer. This displays a selectable thread list. | ||
| 2575 | ;; | ||
| 2576 | (gdb-set-buffer-rules 'gdb-threads-buffer | ||
| 2577 | 'gdb-threads-buffer-name | ||
| 2578 | 'gdb-threads-mode) | ||
| 2579 | |||
| 2580 | (def-gdb-auto-updated-buffer gdb-threads-buffer | ||
| 2581 | gdb-invalidate-threads | ||
| 2582 | (concat gdb-server-prefix "info threads\n") | ||
| 2583 | gdb-info-threads-handler | ||
| 2584 | gdb-info-threads-custom) | ||
| 2585 | |||
| 2586 | (defun gdb-info-threads-custom () | ||
| 2587 | (with-current-buffer (gdb-get-buffer 'gdb-threads-buffer) | ||
| 2588 | (let ((buffer-read-only nil)) | ||
| 2589 | (save-excursion | ||
| 2590 | (goto-char (point-min)) | ||
| 2591 | (if (re-search-forward "\\* \\([0-9]+\\)" nil t) | ||
| 2592 | (setq gdb-thread-indicator | ||
| 2593 | (propertize (concat " [" (match-string 1) "]") | ||
| 2594 | ; FIXME: this help-echo doesn't work | ||
| 2595 | 'help-echo "thread id"))) | ||
| 2596 | (goto-char (point-min)) | ||
| 2597 | (while (< (point) (point-max)) | ||
| 2598 | (unless (looking-at "No ") | ||
| 2599 | (add-text-properties (line-beginning-position) (line-end-position) | ||
| 2600 | '(mouse-face highlight | ||
| 2601 | help-echo "mouse-2, RET: select thread"))) | ||
| 2602 | (forward-line 1)))))) | ||
| 2603 | |||
| 2604 | (defun gdb-threads-buffer-name () | ||
| 2605 | (with-current-buffer gud-comint-buffer | ||
| 2606 | (concat "*threads of " (gdb-get-target-string) "*"))) | ||
| 2607 | |||
| 2608 | (defun gdb-display-threads-buffer () | ||
| 2609 | "Display IDs of currently known threads." | ||
| 2610 | (interactive) | ||
| 2611 | (gdb-display-buffer | ||
| 2612 | (gdb-get-buffer-create 'gdb-threads-buffer) t)) | ||
| 2613 | |||
| 2614 | (defun gdb-frame-threads-buffer () | ||
| 2615 | "Display IDs of currently known threads in a new frame." | ||
| 2616 | (interactive) | ||
| 2617 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 2618 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 2619 | (display-buffer (gdb-get-buffer-create 'gdb-threads-buffer)))) | ||
| 2620 | |||
| 2621 | (defvar gdb-threads-mode-map | ||
| 2622 | (let ((map (make-sparse-keymap))) | ||
| 2623 | (suppress-keymap map) | ||
| 2624 | (define-key map "q" 'kill-this-buffer) | ||
| 2625 | (define-key map "\r" 'gdb-threads-select) | ||
| 2626 | (define-key map [mouse-2] 'gdb-threads-select) | ||
| 2627 | (define-key map [follow-link] 'mouse-face) | ||
| 2628 | map)) | ||
| 2629 | |||
| 2630 | (defvar gdb-threads-font-lock-keywords | ||
| 2631 | '((") +\\([^ ]+\\) (" (1 font-lock-function-name-face)) | ||
| 2632 | ("in \\([^ ]+\\) (" (1 font-lock-function-name-face)) | ||
| 2633 | ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face))) | ||
| 2634 | "Font lock keywords used in `gdb-threads-mode'.") | ||
| 2635 | |||
| 2636 | (defun gdb-threads-mode () | ||
| 2637 | "Major mode for gdb threads. | ||
| 2638 | |||
| 2639 | \\{gdb-threads-mode-map}" | ||
| 2640 | (kill-all-local-variables) | ||
| 2641 | (setq major-mode 'gdb-threads-mode) | ||
| 2642 | (setq mode-name "Threads") | ||
| 2643 | (setq buffer-read-only t) | ||
| 2644 | (buffer-disable-undo) | ||
| 2645 | (setq header-line-format gdb-breakpoints-header) | ||
| 2646 | (use-local-map gdb-threads-mode-map) | ||
| 2647 | (set (make-local-variable 'font-lock-defaults) | ||
| 2648 | '(gdb-threads-font-lock-keywords)) | ||
| 2649 | (run-mode-hooks 'gdb-threads-mode-hook) | ||
| 2650 | ;; Force "info threads" onto queue. | ||
| 2651 | (lambda () (let ((gud-running nil)) (gdb-invalidate-threads)))) | ||
| 2652 | |||
| 2653 | (defun gdb-get-thread-number () | ||
| 2654 | (save-excursion | ||
| 2655 | (re-search-backward "^\\s-*\\([0-9]*\\)" nil t) | ||
| 2656 | (match-string-no-properties 1))) | ||
| 2657 | |||
| 2658 | (defun gdb-threads-select (&optional event) | ||
| 2659 | "Select the thread and display the relevant source." | ||
| 2660 | (interactive (list last-input-event)) | ||
| 2661 | (if event (posn-set-point (event-end event))) | ||
| 2662 | (setq gdb-stack-update t) | ||
| 2663 | (gdb-enqueue-input | ||
| 2664 | (list (concat gdb-server-prefix "thread " | ||
| 2665 | (gdb-get-thread-number) "\n") 'ignore)) | ||
| 2666 | (gud-display-frame)) | ||
| 2667 | |||
| 2668 | (defun gdb-thread-identification () | ||
| 2669 | (setq mode-line-buffer-identification | ||
| 2670 | (list (car mode-line-buffer-identification) | ||
| 2671 | '(gdb-thread-indicator gdb-thread-indicator)))) | ||
| 2672 | |||
| 2673 | ;; Registers buffer. | ||
| 2674 | ;; | ||
| 2675 | (defcustom gdb-all-registers nil | ||
| 2676 | "Non-nil means include floating-point registers." | ||
| 2677 | :type 'boolean | ||
| 2678 | :group 'gdb | ||
| 2679 | :version "22.1") | ||
| 2680 | |||
| 2681 | (gdb-set-buffer-rules 'gdb-registers-buffer | ||
| 2682 | 'gdb-registers-buffer-name | ||
| 2683 | 'gdb-registers-mode) | ||
| 2684 | |||
| 2685 | (def-gdb-auto-updated-buffer gdb-registers-buffer | ||
| 2686 | gdb-invalidate-registers | ||
| 2687 | (concat | ||
| 2688 | gdb-server-prefix "info " (if gdb-all-registers "all-") "registers\n") | ||
| 2689 | gdb-info-registers-handler | ||
| 2690 | gdb-info-registers-custom) | ||
| 2691 | |||
| 2692 | (defun gdb-info-registers-custom () | ||
| 2693 | (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) | ||
| 2694 | (save-excursion | ||
| 2695 | (let ((buffer-read-only nil) | ||
| 2696 | start end) | ||
| 2697 | (goto-char (point-min)) | ||
| 2698 | (while (< (point) (point-max)) | ||
| 2699 | (setq start (line-beginning-position)) | ||
| 2700 | (setq end (line-end-position)) | ||
| 2701 | (when (looking-at "^[^ ]+") | ||
| 2702 | (unless (string-equal (match-string 0) "The") | ||
| 2703 | (put-text-property start (match-end 0) | ||
| 2704 | 'face font-lock-variable-name-face) | ||
| 2705 | (add-text-properties start end | ||
| 2706 | '(help-echo "mouse-2: edit value" | ||
| 2707 | mouse-face highlight)))) | ||
| 2708 | (forward-line 1)))))) | ||
| 2709 | |||
| 2710 | (defun gdb-edit-register-value (&optional event) | ||
| 2711 | (interactive (list last-input-event)) | ||
| 2712 | (save-excursion | ||
| 2713 | (if event (posn-set-point (event-end event))) | ||
| 2714 | (beginning-of-line) | ||
| 2715 | (let* ((register (current-word)) | ||
| 2716 | (value (read-string (format "New value (%s): " register)))) | ||
| 2717 | (gdb-enqueue-input | ||
| 2718 | (list (concat gdb-server-prefix "set $" register "=" value "\n") | ||
| 2719 | 'ignore))))) | ||
| 2720 | |||
| 2721 | (defvar gdb-registers-mode-map | ||
| 2722 | (let ((map (make-sparse-keymap))) | ||
| 2723 | (suppress-keymap map) | ||
| 2724 | (define-key map "\r" 'gdb-edit-register-value) | ||
| 2725 | (define-key map [mouse-2] 'gdb-edit-register-value) | ||
| 2726 | (define-key map " " 'gdb-all-registers) | ||
| 2727 | (define-key map "q" 'kill-this-buffer) | ||
| 2728 | map)) | ||
| 2729 | |||
| 2730 | (defvar gdb-locals-header | ||
| 2731 | (list | ||
| 2732 | (gdb-propertize-header "Locals" gdb-locals-buffer | ||
| 2733 | nil nil mode-line) | ||
| 2734 | " " | ||
| 2735 | (gdb-propertize-header "Registers" gdb-registers-buffer | ||
| 2736 | "mouse-1: select" mode-line-highlight mode-line-inactive))) | ||
| 2737 | |||
| 2738 | |||
| 2739 | (defun gdb-registers-mode () | ||
| 2740 | "Major mode for gdb registers. | ||
| 2741 | |||
| 2742 | \\{gdb-registers-mode-map}" | ||
| 2743 | (kill-all-local-variables) | ||
| 2744 | (setq major-mode 'gdb-registers-mode) | ||
| 2745 | (setq mode-name "Registers") | ||
| 2746 | (setq header-line-format gdb-locals-header) | ||
| 2747 | (setq buffer-read-only t) | ||
| 2748 | (buffer-disable-undo) | ||
| 2749 | (gdb-thread-identification) | ||
| 2750 | (use-local-map gdb-registers-mode-map) | ||
| 2751 | (run-mode-hooks 'gdb-registers-mode-hook) | ||
| 2752 | (if (string-equal gdb-version "pre-6.4") | ||
| 2753 | (progn | ||
| 2754 | (if gdb-all-registers (setq mode-name "Registers:All")) | ||
| 2755 | 'gdb-invalidate-registers) | ||
| 2756 | 'gdb-invalidate-registers-1)) | ||
| 2757 | |||
| 2758 | (defun gdb-registers-buffer-name () | ||
| 2759 | (with-current-buffer gud-comint-buffer | ||
| 2760 | (concat "*registers of " (gdb-get-target-string) "*"))) | ||
| 2761 | |||
| 2762 | (defun gdb-display-registers-buffer () | ||
| 2763 | "Display integer register contents." | ||
| 2764 | (interactive) | ||
| 2765 | (gdb-display-buffer | ||
| 2766 | (gdb-get-buffer-create 'gdb-registers-buffer) t)) | ||
| 2767 | |||
| 2768 | (defun gdb-frame-registers-buffer () | ||
| 2769 | "Display integer register contents in a new frame." | ||
| 2770 | (interactive) | ||
| 2771 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 2772 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 2773 | (display-buffer (gdb-get-buffer-create 'gdb-registers-buffer)))) | ||
| 2774 | |||
| 2775 | (defun gdb-all-registers () | ||
| 2776 | "Toggle the display of floating-point registers (pre GDB 6.4 only)." | ||
| 2777 | (interactive) | ||
| 2778 | (when (string-equal gdb-version "pre-6.4") | ||
| 2779 | (if gdb-all-registers | ||
| 2780 | (progn | ||
| 2781 | (setq gdb-all-registers nil) | ||
| 2782 | (with-current-buffer (gdb-get-buffer-create 'gdb-registers-buffer) | ||
| 2783 | (setq mode-name "Registers"))) | ||
| 2784 | (setq gdb-all-registers t) | ||
| 2785 | (with-current-buffer (gdb-get-buffer-create 'gdb-registers-buffer) | ||
| 2786 | (setq mode-name "Registers:All"))) | ||
| 2787 | (message (format "Display of floating-point registers %sabled" | ||
| 2788 | (if gdb-all-registers "en" "dis"))) | ||
| 2789 | (gdb-invalidate-registers))) | ||
| 2790 | |||
| 2791 | |||
| 2792 | ;; Memory buffer. | ||
| 2793 | ;; | ||
| 2794 | (defcustom gdb-memory-repeat-count 32 | ||
| 2795 | "Number of data items in memory window." | ||
| 2796 | :type 'integer | ||
| 2797 | :group 'gdb | ||
| 2798 | :version "22.1") | ||
| 2799 | |||
| 2800 | (defcustom gdb-memory-format "x" | ||
| 2801 | "Display format of data items in memory window." | ||
| 2802 | :type '(choice (const :tag "Hexadecimal" "x") | ||
| 2803 | (const :tag "Signed decimal" "d") | ||
| 2804 | (const :tag "Unsigned decimal" "u") | ||
| 2805 | (const :tag "Octal" "o") | ||
| 2806 | (const :tag "Binary" "t")) | ||
| 2807 | :group 'gdb | ||
| 2808 | :version "22.1") | ||
| 2809 | |||
| 2810 | (defcustom gdb-memory-unit "w" | ||
| 2811 | "Unit size of data items in memory window." | ||
| 2812 | :type '(choice (const :tag "Byte" "b") | ||
| 2813 | (const :tag "Halfword" "h") | ||
| 2814 | (const :tag "Word" "w") | ||
| 2815 | (const :tag "Giant word" "g")) | ||
| 2816 | :group 'gdb | ||
| 2817 | :version "22.1") | ||
| 2818 | |||
| 2819 | (gdb-set-buffer-rules 'gdb-memory-buffer | ||
| 2820 | 'gdb-memory-buffer-name | ||
| 2821 | 'gdb-memory-mode) | ||
| 2822 | |||
| 2823 | (def-gdb-auto-updated-buffer gdb-memory-buffer | ||
| 2824 | gdb-invalidate-memory | ||
| 2825 | (concat gdb-server-prefix "x/" (number-to-string gdb-memory-repeat-count) | ||
| 2826 | gdb-memory-format gdb-memory-unit " " gdb-memory-address "\n") | ||
| 2827 | gdb-read-memory-handler | ||
| 2828 | gdb-read-memory-custom) | ||
| 2829 | |||
| 2830 | (defun gdb-read-memory-custom () | ||
| 2831 | (save-excursion | ||
| 2832 | (goto-char (point-min)) | ||
| 2833 | (if (looking-at "0x[[:xdigit:]]+") | ||
| 2834 | (setq gdb-memory-address (match-string 0))))) | ||
| 2835 | |||
| 2836 | (defvar gdb-memory-mode-map | ||
| 2837 | (let ((map (make-sparse-keymap))) | ||
| 2838 | (suppress-keymap map) | ||
| 2839 | (define-key map "S" 'gdb-memory-set-address) | ||
| 2840 | (define-key map "N" 'gdb-memory-set-repeat-count) | ||
| 2841 | (define-key map "q" 'kill-this-buffer) | ||
| 2842 | map)) | ||
| 2843 | |||
| 2844 | (defun gdb-memory-set-address (&optional event) | ||
| 2845 | "Set the start memory address." | ||
| 2846 | (interactive) | ||
| 2847 | (let ((arg (read-from-minibuffer "Start address: "))) | ||
| 2848 | (setq gdb-memory-address arg)) | ||
| 2849 | (gdb-invalidate-memory)) | ||
| 2850 | |||
| 2851 | (defun gdb-memory-set-repeat-count (&optional event) | ||
| 2852 | "Set the number of data items in memory window." | ||
| 2853 | (interactive) | ||
| 2854 | (let* ((arg (read-from-minibuffer "Repeat count: ")) | ||
| 2855 | (count (string-to-number arg))) | ||
| 2856 | (if (<= count 0) | ||
| 2857 | (error "Positive numbers only") | ||
| 2858 | (customize-set-variable 'gdb-memory-repeat-count count) | ||
| 2859 | (gdb-invalidate-memory)))) | ||
| 2860 | |||
| 2861 | (defun gdb-memory-format-binary () | ||
| 2862 | "Set the display format to binary." | ||
| 2863 | (interactive) | ||
| 2864 | (customize-set-variable 'gdb-memory-format "t") | ||
| 2865 | (gdb-invalidate-memory)) | ||
| 2866 | |||
| 2867 | (defun gdb-memory-format-octal () | ||
| 2868 | "Set the display format to octal." | ||
| 2869 | (interactive) | ||
| 2870 | (customize-set-variable 'gdb-memory-format "o") | ||
| 2871 | (gdb-invalidate-memory)) | ||
| 2872 | |||
| 2873 | (defun gdb-memory-format-unsigned () | ||
| 2874 | "Set the display format to unsigned decimal." | ||
| 2875 | (interactive) | ||
| 2876 | (customize-set-variable 'gdb-memory-format "u") | ||
| 2877 | (gdb-invalidate-memory)) | ||
| 2878 | |||
| 2879 | (defun gdb-memory-format-signed () | ||
| 2880 | "Set the display format to decimal." | ||
| 2881 | (interactive) | ||
| 2882 | (customize-set-variable 'gdb-memory-format "d") | ||
| 2883 | (gdb-invalidate-memory)) | ||
| 2884 | |||
| 2885 | (defun gdb-memory-format-hexadecimal () | ||
| 2886 | "Set the display format to hexadecimal." | ||
| 2887 | (interactive) | ||
| 2888 | (customize-set-variable 'gdb-memory-format "x") | ||
| 2889 | (gdb-invalidate-memory)) | ||
| 2890 | |||
| 2891 | (defvar gdb-memory-format-map | ||
| 2892 | (let ((map (make-sparse-keymap))) | ||
| 2893 | (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1) | ||
| 2894 | map) | ||
| 2895 | "Keymap to select format in the header line.") | ||
| 2896 | |||
| 2897 | (defvar gdb-memory-format-menu (make-sparse-keymap "Format") | ||
| 2898 | "Menu of display formats in the header line.") | ||
| 2899 | |||
| 2900 | (define-key gdb-memory-format-menu [binary] | ||
| 2901 | '(menu-item "Binary" gdb-memory-format-binary | ||
| 2902 | :button (:radio . (equal gdb-memory-format "t")))) | ||
| 2903 | (define-key gdb-memory-format-menu [octal] | ||
| 2904 | '(menu-item "Octal" gdb-memory-format-octal | ||
| 2905 | :button (:radio . (equal gdb-memory-format "o")))) | ||
| 2906 | (define-key gdb-memory-format-menu [unsigned] | ||
| 2907 | '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned | ||
| 2908 | :button (:radio . (equal gdb-memory-format "u")))) | ||
| 2909 | (define-key gdb-memory-format-menu [signed] | ||
| 2910 | '(menu-item "Signed Decimal" gdb-memory-format-signed | ||
| 2911 | :button (:radio . (equal gdb-memory-format "d")))) | ||
| 2912 | (define-key gdb-memory-format-menu [hexadecimal] | ||
| 2913 | '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal | ||
| 2914 | :button (:radio . (equal gdb-memory-format "x")))) | ||
| 2915 | |||
| 2916 | (defun gdb-memory-format-menu (event) | ||
| 2917 | (interactive "@e") | ||
| 2918 | (x-popup-menu event gdb-memory-format-menu)) | ||
| 2919 | |||
| 2920 | (defun gdb-memory-format-menu-1 (event) | ||
| 2921 | (interactive "e") | ||
| 2922 | (save-selected-window | ||
| 2923 | (select-window (posn-window (event-start event))) | ||
| 2924 | (let* ((selection (gdb-memory-format-menu event)) | ||
| 2925 | (binding (and selection (lookup-key gdb-memory-format-menu | ||
| 2926 | (vector (car selection)))))) | ||
| 2927 | (if binding (call-interactively binding))))) | ||
| 2928 | |||
| 2929 | (defun gdb-memory-unit-giant () | ||
| 2930 | "Set the unit size to giant words (eight bytes)." | ||
| 2931 | (interactive) | ||
| 2932 | (customize-set-variable 'gdb-memory-unit "g") | ||
| 2933 | (gdb-invalidate-memory)) | ||
| 2934 | |||
| 2935 | (defun gdb-memory-unit-word () | ||
| 2936 | "Set the unit size to words (four bytes)." | ||
| 2937 | (interactive) | ||
| 2938 | (customize-set-variable 'gdb-memory-unit "w") | ||
| 2939 | (gdb-invalidate-memory)) | ||
| 2940 | |||
| 2941 | (defun gdb-memory-unit-halfword () | ||
| 2942 | "Set the unit size to halfwords (two bytes)." | ||
| 2943 | (interactive) | ||
| 2944 | (customize-set-variable 'gdb-memory-unit "h") | ||
| 2945 | (gdb-invalidate-memory)) | ||
| 2946 | |||
| 2947 | (defun gdb-memory-unit-byte () | ||
| 2948 | "Set the unit size to bytes." | ||
| 2949 | (interactive) | ||
| 2950 | (customize-set-variable 'gdb-memory-unit "b") | ||
| 2951 | (gdb-invalidate-memory)) | ||
| 2952 | |||
| 2953 | (defvar gdb-memory-unit-map | ||
| 2954 | (let ((map (make-sparse-keymap))) | ||
| 2955 | (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1) | ||
| 2956 | map) | ||
| 2957 | "Keymap to select units in the header line.") | ||
| 2958 | |||
| 2959 | (defvar gdb-memory-unit-menu (make-sparse-keymap "Unit") | ||
| 2960 | "Menu of units in the header line.") | ||
| 2961 | |||
| 2962 | (define-key gdb-memory-unit-menu [giantwords] | ||
| 2963 | '(menu-item "Giant words" gdb-memory-unit-giant | ||
| 2964 | :button (:radio . (equal gdb-memory-unit "g")))) | ||
| 2965 | (define-key gdb-memory-unit-menu [words] | ||
| 2966 | '(menu-item "Words" gdb-memory-unit-word | ||
| 2967 | :button (:radio . (equal gdb-memory-unit "w")))) | ||
| 2968 | (define-key gdb-memory-unit-menu [halfwords] | ||
| 2969 | '(menu-item "Halfwords" gdb-memory-unit-halfword | ||
| 2970 | :button (:radio . (equal gdb-memory-unit "h")))) | ||
| 2971 | (define-key gdb-memory-unit-menu [bytes] | ||
| 2972 | '(menu-item "Bytes" gdb-memory-unit-byte | ||
| 2973 | :button (:radio . (equal gdb-memory-unit "b")))) | ||
| 2974 | |||
| 2975 | (defun gdb-memory-unit-menu (event) | ||
| 2976 | (interactive "@e") | ||
| 2977 | (x-popup-menu event gdb-memory-unit-menu)) | ||
| 2978 | |||
| 2979 | (defun gdb-memory-unit-menu-1 (event) | ||
| 2980 | (interactive "e") | ||
| 2981 | (save-selected-window | ||
| 2982 | (select-window (posn-window (event-start event))) | ||
| 2983 | (let* ((selection (gdb-memory-unit-menu event)) | ||
| 2984 | (binding (and selection (lookup-key gdb-memory-unit-menu | ||
| 2985 | (vector (car selection)))))) | ||
| 2986 | (if binding (call-interactively binding))))) | ||
| 2987 | |||
| 2988 | (defvar gdb-memory-font-lock-keywords | ||
| 2989 | '(;; <__function.name+n> | ||
| 2990 | ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face)) | ||
| 2991 | ) | ||
| 2992 | "Font lock keywords used in `gdb-memory-mode'.") | ||
| 2993 | |||
| 2994 | (defun gdb-memory-mode () | ||
| 2995 | "Major mode for examining memory. | ||
| 2996 | |||
| 2997 | \\{gdb-memory-mode-map}" | ||
| 2998 | (kill-all-local-variables) | ||
| 2999 | (setq major-mode 'gdb-memory-mode) | ||
| 3000 | (setq mode-name "Memory") | ||
| 3001 | (setq buffer-read-only t) | ||
| 3002 | (buffer-disable-undo) | ||
| 3003 | (use-local-map gdb-memory-mode-map) | ||
| 3004 | (setq header-line-format | ||
| 3005 | '(:eval | ||
| 3006 | (concat | ||
| 3007 | "Start address[" | ||
| 3008 | (propertize | ||
| 3009 | "-" | ||
| 3010 | 'face font-lock-warning-face | ||
| 3011 | 'help-echo "mouse-1: decrement address" | ||
| 3012 | 'mouse-face 'mode-line-highlight | ||
| 3013 | 'local-map | ||
| 3014 | (gdb-make-header-line-mouse-map | ||
| 3015 | 'mouse-1 | ||
| 3016 | (lambda () (interactive) | ||
| 3017 | (let ((gdb-memory-address | ||
| 3018 | ;; Let GDB do the arithmetic. | ||
| 3019 | (concat | ||
| 3020 | gdb-memory-address " - " | ||
| 3021 | (number-to-string | ||
| 3022 | (* gdb-memory-repeat-count | ||
| 3023 | (cond ((string= gdb-memory-unit "b") 1) | ||
| 3024 | ((string= gdb-memory-unit "h") 2) | ||
| 3025 | ((string= gdb-memory-unit "w") 4) | ||
| 3026 | ((string= gdb-memory-unit "g") 8))))))) | ||
| 3027 | (gdb-invalidate-memory))))) | ||
| 3028 | "|" | ||
| 3029 | (propertize "+" | ||
| 3030 | 'face font-lock-warning-face | ||
| 3031 | 'help-echo "mouse-1: increment address" | ||
| 3032 | 'mouse-face 'mode-line-highlight | ||
| 3033 | 'local-map (gdb-make-header-line-mouse-map | ||
| 3034 | 'mouse-1 | ||
| 3035 | (lambda () (interactive) | ||
| 3036 | (let ((gdb-memory-address nil)) | ||
| 3037 | (gdb-invalidate-memory))))) | ||
| 3038 | "]: " | ||
| 3039 | (propertize gdb-memory-address | ||
| 3040 | 'face font-lock-warning-face | ||
| 3041 | 'help-echo "mouse-1: set start address" | ||
| 3042 | 'mouse-face 'mode-line-highlight | ||
| 3043 | 'local-map (gdb-make-header-line-mouse-map | ||
| 3044 | 'mouse-1 | ||
| 3045 | #'gdb-memory-set-address)) | ||
| 3046 | " Repeat Count: " | ||
| 3047 | (propertize (number-to-string gdb-memory-repeat-count) | ||
| 3048 | 'face font-lock-warning-face | ||
| 3049 | 'help-echo "mouse-1: set repeat count" | ||
| 3050 | 'mouse-face 'mode-line-highlight | ||
| 3051 | 'local-map (gdb-make-header-line-mouse-map | ||
| 3052 | 'mouse-1 | ||
| 3053 | #'gdb-memory-set-repeat-count)) | ||
| 3054 | " Display Format: " | ||
| 3055 | (propertize gdb-memory-format | ||
| 3056 | 'face font-lock-warning-face | ||
| 3057 | 'help-echo "mouse-3: select display format" | ||
| 3058 | 'mouse-face 'mode-line-highlight | ||
| 3059 | 'local-map gdb-memory-format-map) | ||
| 3060 | " Unit Size: " | ||
| 3061 | (propertize gdb-memory-unit | ||
| 3062 | 'face font-lock-warning-face | ||
| 3063 | 'help-echo "mouse-3: select unit size" | ||
| 3064 | 'mouse-face 'mode-line-highlight | ||
| 3065 | 'local-map gdb-memory-unit-map)))) | ||
| 3066 | (set (make-local-variable 'font-lock-defaults) | ||
| 3067 | '(gdb-memory-font-lock-keywords)) | ||
| 3068 | (run-mode-hooks 'gdb-memory-mode-hook) | ||
| 3069 | 'gdb-invalidate-memory) | ||
| 3070 | |||
| 3071 | (defun gdb-memory-buffer-name () | ||
| 3072 | (with-current-buffer gud-comint-buffer | ||
| 3073 | (concat "*memory of " (gdb-get-target-string) "*"))) | ||
| 3074 | |||
| 3075 | (defun gdb-display-memory-buffer () | ||
| 3076 | "Display memory contents." | ||
| 3077 | (interactive) | ||
| 3078 | (gdb-display-buffer | ||
| 3079 | (gdb-get-buffer-create 'gdb-memory-buffer) t)) | ||
| 3080 | |||
| 3081 | (defun gdb-frame-memory-buffer () | ||
| 3082 | "Display memory contents in a new frame." | ||
| 3083 | (interactive) | ||
| 3084 | (let* ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 3085 | (special-display-frame-alist | ||
| 3086 | (cons '(left-fringe . 0) | ||
| 3087 | (cons '(right-fringe . 0) | ||
| 3088 | (cons '(width . 83) gdb-frame-parameters))))) | ||
| 3089 | (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer)))) | ||
| 3090 | |||
| 3091 | |||
| 3092 | ;; Locals buffer. | ||
| 3093 | ;; | ||
| 3094 | (gdb-set-buffer-rules 'gdb-locals-buffer | ||
| 3095 | 'gdb-locals-buffer-name | ||
| 3096 | 'gdb-locals-mode) | ||
| 3097 | |||
| 3098 | (def-gdb-auto-update-trigger gdb-invalidate-locals | ||
| 3099 | (gdb-get-buffer 'gdb-locals-buffer) | ||
| 3100 | "server info locals\n" | ||
| 3101 | gdb-info-locals-handler) | ||
| 3102 | |||
| 3103 | (defvar gdb-locals-watch-map | ||
| 3104 | (let ((map (make-sparse-keymap))) | ||
| 3105 | (suppress-keymap map) | ||
| 3106 | (define-key map "\r" (lambda () (interactive) | ||
| 3107 | (beginning-of-line) | ||
| 3108 | (gud-watch))) | ||
| 3109 | (define-key map [mouse-2] (lambda (event) (interactive "e") | ||
| 3110 | (mouse-set-point event) | ||
| 3111 | (beginning-of-line) | ||
| 3112 | (gud-watch))) | ||
| 3113 | map) | ||
| 3114 | "Keymap to create watch expression of a complex data type local variable.") | ||
| 3115 | |||
| 3116 | (defconst gdb-struct-string | ||
| 3117 | (concat (propertize "[struct/union]" | ||
| 3118 | 'mouse-face 'highlight | ||
| 3119 | 'help-echo "mouse-2: create watch expression" | ||
| 3120 | 'local-map gdb-locals-watch-map) "\n")) | ||
| 3121 | |||
| 3122 | (defconst gdb-array-string | ||
| 3123 | (concat " " (propertize "[array]" | ||
| 3124 | 'mouse-face 'highlight | ||
| 3125 | 'help-echo "mouse-2: create watch expression" | ||
| 3126 | 'local-map gdb-locals-watch-map) "\n")) | ||
| 3127 | |||
| 3128 | ;; Abbreviate for arrays and structures. | ||
| 3129 | ;; These can be expanded using gud-display. | ||
| 3130 | (defun gdb-info-locals-handler () | ||
| 3131 | (setq gdb-pending-triggers (delq 'gdb-invalidate-locals | ||
| 3132 | gdb-pending-triggers)) | ||
| 3133 | (let ((buf (gdb-get-buffer 'gdb-partial-output-buffer))) | ||
| 3134 | (with-current-buffer buf | ||
| 3135 | (goto-char (point-min)) | ||
| 3136 | ;; Need this in case "set print pretty" is on. | ||
| 3137 | (while (re-search-forward "^[ }].*\n" nil t) | ||
| 3138 | (replace-match "" nil nil)) | ||
| 3139 | (goto-char (point-min)) | ||
| 3140 | (while (re-search-forward "{\\(.*=.*\n\\|\n\\)" nil t) | ||
| 3141 | (replace-match gdb-struct-string nil nil)) | ||
| 3142 | (goto-char (point-min)) | ||
| 3143 | (while (re-search-forward "\\s-*{[^.].*\n" nil t) | ||
| 3144 | (replace-match gdb-array-string nil nil)))) | ||
| 3145 | (let ((buf (gdb-get-buffer 'gdb-locals-buffer))) | ||
| 3146 | (and buf | ||
| 3147 | (with-current-buffer buf | ||
| 3148 | (let* ((window (get-buffer-window buf 0)) | ||
| 3149 | (start (window-start window)) | ||
| 3150 | (p (window-point window)) | ||
| 3151 | (buffer-read-only nil)) | ||
| 3152 | (erase-buffer) | ||
| 3153 | (insert-buffer-substring (gdb-get-buffer-create | ||
| 3154 | 'gdb-partial-output-buffer)) | ||
| 3155 | (set-window-start window start) | ||
| 3156 | (set-window-point window p))))) | ||
| 3157 | (run-hooks 'gdb-info-locals-hook)) | ||
| 3158 | |||
| 3159 | (defvar gdb-locals-mode-map | ||
| 3160 | (let ((map (make-sparse-keymap))) | ||
| 3161 | (suppress-keymap map) | ||
| 3162 | (define-key map "q" 'kill-this-buffer) | ||
| 3163 | map)) | ||
| 3164 | |||
| 3165 | (defun gdb-locals-mode () | ||
| 3166 | "Major mode for gdb locals. | ||
| 3167 | |||
| 3168 | \\{gdb-locals-mode-map}" | ||
| 3169 | (kill-all-local-variables) | ||
| 3170 | (setq major-mode 'gdb-locals-mode) | ||
| 3171 | (setq mode-name (concat "Locals:" gdb-selected-frame)) | ||
| 3172 | (use-local-map gdb-locals-mode-map) | ||
| 3173 | (setq buffer-read-only t) | ||
| 3174 | (buffer-disable-undo) | ||
| 3175 | (setq header-line-format gdb-locals-header) | ||
| 3176 | (gdb-thread-identification) | ||
| 3177 | (set (make-local-variable 'font-lock-defaults) | ||
| 3178 | '(gdb-locals-font-lock-keywords)) | ||
| 3179 | (run-mode-hooks 'gdb-locals-mode-hook) | ||
| 3180 | (if (and (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 3181 | (string-equal gdb-version "pre-6.4")) | ||
| 3182 | 'gdb-invalidate-locals | ||
| 3183 | 'gdb-invalidate-locals-1)) | ||
| 3184 | |||
| 3185 | (defun gdb-locals-buffer-name () | ||
| 3186 | (with-current-buffer gud-comint-buffer | ||
| 3187 | (concat "*locals of " (gdb-get-target-string) "*"))) | ||
| 3188 | |||
| 3189 | (defun gdb-display-locals-buffer () | ||
| 3190 | "Display local variables of current stack and their values." | ||
| 3191 | (interactive) | ||
| 3192 | (gdb-display-buffer | ||
| 3193 | (gdb-get-buffer-create 'gdb-locals-buffer) t)) | ||
| 3194 | |||
| 3195 | (defun gdb-frame-locals-buffer () | ||
| 3196 | "Display local variables of current stack and their values in a new frame." | ||
| 3197 | (interactive) | ||
| 3198 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 3199 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 3200 | (display-buffer (gdb-get-buffer-create 'gdb-locals-buffer)))) | ||
| 3201 | |||
| 3202 | |||
| 3203 | ;;;; Window management | ||
| 3204 | (defun gdb-display-buffer (buf dedicated &optional frame) | ||
| 3205 | (let ((answer (get-buffer-window buf (or frame 0)))) | ||
| 3206 | (if answer | ||
| 3207 | (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary. | ||
| 3208 | (let ((window (get-lru-window))) | ||
| 3209 | (if (memq (buffer-local-value 'gud-minor-mode (window-buffer window)) | ||
| 3210 | '(gdba gdbmi)) | ||
| 3211 | (let* ((largest (get-largest-window)) | ||
| 3212 | (cur-size (window-height largest))) | ||
| 3213 | (setq answer (split-window largest)) | ||
| 3214 | (set-window-buffer answer buf) | ||
| 3215 | (set-window-dedicated-p answer dedicated) | ||
| 3216 | answer) | ||
| 3217 | (set-window-buffer window buf) | ||
| 3218 | window))))) | ||
| 3219 | |||
| 3220 | |||
| 3221 | ;;; Shared keymap initialization: | ||
| 3222 | |||
| 3223 | (let ((menu (make-sparse-keymap "GDB-Windows"))) | ||
| 3224 | (define-key gud-menu-map [displays] | ||
| 3225 | `(menu-item "GDB-Windows" ,menu | ||
| 3226 | :help "Open a GDB-UI buffer in a new window." | ||
| 3227 | :visible (memq gud-minor-mode '(gdbmi gdba)))) | ||
| 3228 | (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer)) | ||
| 3229 | (define-key menu [threads] '("Threads" . gdb-display-threads-buffer)) | ||
| 3230 | (define-key menu [inferior] | ||
| 3231 | '(menu-item "Separate IO" gdb-display-separate-io-buffer | ||
| 3232 | :enable gdb-use-separate-io-buffer)) | ||
| 3233 | (define-key menu [memory] '("Memory" . gdb-display-memory-buffer)) | ||
| 3234 | (define-key menu [registers] '("Registers" . gdb-display-registers-buffer)) | ||
| 3235 | (define-key menu [disassembly] | ||
| 3236 | '("Disassembly" . gdb-display-assembler-buffer)) | ||
| 3237 | (define-key menu [breakpoints] | ||
| 3238 | '("Breakpoints" . gdb-display-breakpoints-buffer)) | ||
| 3239 | (define-key menu [locals] '("Locals" . gdb-display-locals-buffer)) | ||
| 3240 | (define-key menu [frames] '("Stack" . gdb-display-stack-buffer))) | ||
| 3241 | |||
| 3242 | (let ((menu (make-sparse-keymap "GDB-Frames"))) | ||
| 3243 | (define-key gud-menu-map [frames] | ||
| 3244 | `(menu-item "GDB-Frames" ,menu | ||
| 3245 | :help "Open a GDB-UI buffer in a new frame." | ||
| 3246 | :visible (memq gud-minor-mode '(gdbmi gdba)))) | ||
| 3247 | (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer)) | ||
| 3248 | (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer)) | ||
| 3249 | (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer)) | ||
| 3250 | (define-key menu [inferior] | ||
| 3251 | '(menu-item "Separate IO" gdb-frame-separate-io-buffer | ||
| 3252 | :enable gdb-use-separate-io-buffer)) | ||
| 3253 | (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer)) | ||
| 3254 | (define-key menu [disassembly] '("Disassembly" . gdb-frame-assembler-buffer)) | ||
| 3255 | (define-key menu [breakpoints] | ||
| 3256 | '("Breakpoints" . gdb-frame-breakpoints-buffer)) | ||
| 3257 | (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer)) | ||
| 3258 | (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))) | ||
| 3259 | |||
| 3260 | (let ((menu (make-sparse-keymap "GDB-UI/MI"))) | ||
| 3261 | (define-key gud-menu-map [ui] | ||
| 3262 | `(menu-item (if (eq gud-minor-mode 'gdba) "GDB-UI" "GDB-MI") | ||
| 3263 | ,menu :visible (memq gud-minor-mode '(gdbmi gdba)))) | ||
| 3264 | (define-key menu [gdb-customize] | ||
| 3265 | '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb)) | ||
| 3266 | :help "Customize Gdb Graphical Mode options.")) | ||
| 3267 | (define-key menu [gdb-find-source-frame] | ||
| 3268 | '(menu-item "Look For Source Frame" gdb-find-source-frame | ||
| 3269 | :visible (eq gud-minor-mode 'gdba) | ||
| 3270 | :help "Toggle looking for source frame further up call stack." | ||
| 3271 | :button (:toggle . gdb-find-source-frame))) | ||
| 3272 | (define-key menu [gdb-use-separate-io] | ||
| 3273 | '(menu-item "Separate IO" gdb-use-separate-io-buffer | ||
| 3274 | :visible (eq gud-minor-mode 'gdba) | ||
| 3275 | :help "Toggle separate IO for debugged program." | ||
| 3276 | :button (:toggle . gdb-use-separate-io-buffer))) | ||
| 3277 | (define-key menu [gdb-many-windows] | ||
| 3278 | '(menu-item "Display Other Windows" gdb-many-windows | ||
| 3279 | :help "Toggle display of locals, stack and breakpoint information" | ||
| 3280 | :button (:toggle . gdb-many-windows))) | ||
| 3281 | (define-key menu [gdb-restore-windows] | ||
| 3282 | '(menu-item "Restore Window Layout" gdb-restore-windows | ||
| 3283 | :help "Restore standard layout for debug session."))) | ||
| 3284 | |||
| 3285 | (defun gdb-frame-gdb-buffer () | ||
| 3286 | "Display GUD buffer in a new frame." | ||
| 3287 | (interactive) | ||
| 3288 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 3289 | (special-display-frame-alist | ||
| 3290 | (remove '(menu-bar-lines) (remove '(tool-bar-lines) | ||
| 3291 | gdb-frame-parameters))) | ||
| 3292 | (same-window-regexps nil)) | ||
| 3293 | (display-buffer gud-comint-buffer))) | ||
| 3294 | |||
| 3295 | (defun gdb-display-gdb-buffer () | ||
| 3296 | "Display GUD buffer." | ||
| 3297 | (interactive) | ||
| 3298 | (let ((same-window-regexps nil)) | ||
| 3299 | (select-window (display-buffer gud-comint-buffer nil 0)))) | ||
| 3300 | |||
| 3301 | (defun gdb-set-window-buffer (name) | ||
| 3302 | (set-window-buffer (selected-window) (get-buffer name)) | ||
| 3303 | (set-window-dedicated-p (selected-window) t)) | ||
| 3304 | |||
| 3305 | (defun gdb-setup-windows () | ||
| 3306 | "Layout the window pattern for `gdb-many-windows'." | ||
| 3307 | (gdb-display-locals-buffer) | ||
| 3308 | (gdb-display-stack-buffer) | ||
| 3309 | (delete-other-windows) | ||
| 3310 | (gdb-display-breakpoints-buffer) | ||
| 3311 | (delete-other-windows) | ||
| 3312 | ; Don't dedicate. | ||
| 3313 | (pop-to-buffer gud-comint-buffer) | ||
| 3314 | (split-window nil ( / ( * (window-height) 3) 4)) | ||
| 3315 | (split-window nil ( / (window-height) 3)) | ||
| 3316 | (split-window-horizontally) | ||
| 3317 | (other-window 1) | ||
| 3318 | (gdb-set-window-buffer (gdb-locals-buffer-name)) | ||
| 3319 | (other-window 1) | ||
| 3320 | (switch-to-buffer | ||
| 3321 | (if gud-last-last-frame | ||
| 3322 | (gud-find-file (car gud-last-last-frame)) | ||
| 3323 | (if gdb-main-file | ||
| 3324 | (gud-find-file gdb-main-file) | ||
| 3325 | ;; Put buffer list in window if we | ||
| 3326 | ;; can't find a source file. | ||
| 3327 | (list-buffers-noselect)))) | ||
| 3328 | (setq gdb-source-window (selected-window)) | ||
| 3329 | (when gdb-use-separate-io-buffer | ||
| 3330 | (split-window-horizontally) | ||
| 3331 | (other-window 1) | ||
| 3332 | (gdb-set-window-buffer | ||
| 3333 | (gdb-get-buffer-create 'gdb-inferior-io))) | ||
| 3334 | (other-window 1) | ||
| 3335 | (gdb-set-window-buffer (gdb-stack-buffer-name)) | ||
| 3336 | (split-window-horizontally) | ||
| 3337 | (other-window 1) | ||
| 3338 | (gdb-set-window-buffer (gdb-breakpoints-buffer-name)) | ||
| 3339 | (other-window 1)) | ||
| 3340 | |||
| 3341 | (defun gdb-restore-windows () | ||
| 3342 | "Restore the basic arrangement of windows used by gdba. | ||
| 3343 | This arrangement depends on the value of `gdb-many-windows'." | ||
| 3344 | (interactive) | ||
| 3345 | (pop-to-buffer gud-comint-buffer) ;Select the right window and frame. | ||
| 3346 | (delete-other-windows) | ||
| 3347 | (if gdb-many-windows | ||
| 3348 | (gdb-setup-windows) | ||
| 3349 | (when (or gud-last-last-frame gdb-show-main) | ||
| 3350 | (split-window) | ||
| 3351 | (other-window 1) | ||
| 3352 | (switch-to-buffer | ||
| 3353 | (if gud-last-last-frame | ||
| 3354 | (gud-find-file (car gud-last-last-frame)) | ||
| 3355 | (gud-find-file gdb-main-file))) | ||
| 3356 | (setq gdb-source-window (selected-window)) | ||
| 3357 | (other-window 1)))) | ||
| 3358 | |||
| 3359 | (defun gdb-reset () | ||
| 3360 | "Exit a debugging session cleanly. | ||
| 3361 | Kills the gdb buffers, and resets variables and the source buffers." | ||
| 3362 | (dolist (buffer (buffer-list)) | ||
| 3363 | (unless (eq buffer gud-comint-buffer) | ||
| 3364 | (with-current-buffer buffer | ||
| 3365 | (if (memq gud-minor-mode '(gdbmi gdba)) | ||
| 3366 | (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name)) | ||
| 3367 | (kill-buffer nil) | ||
| 3368 | (gdb-remove-breakpoint-icons (point-min) (point-max) t) | ||
| 3369 | (setq gud-minor-mode nil) | ||
| 3370 | (kill-local-variable 'tool-bar-map) | ||
| 3371 | (kill-local-variable 'gdb-define-alist)))))) | ||
| 3372 | (setq gdb-overlay-arrow-position nil) | ||
| 3373 | (setq overlay-arrow-variable-list | ||
| 3374 | (delq 'gdb-overlay-arrow-position overlay-arrow-variable-list)) | ||
| 3375 | (setq fringe-indicator-alist '((overlay-arrow . right-triangle))) | ||
| 3376 | (setq gdb-stack-position nil) | ||
| 3377 | (setq overlay-arrow-variable-list | ||
| 3378 | (delq 'gdb-stack-position overlay-arrow-variable-list)) | ||
| 3379 | (if (boundp 'speedbar-frame) (speedbar-timer-fn)) | ||
| 3380 | (setq gud-running nil) | ||
| 3381 | (setq gdb-active-process nil) | ||
| 3382 | (setq gdb-var-list nil) | ||
| 3383 | (remove-hook 'after-save-hook 'gdb-create-define-alist t)) | ||
| 3384 | |||
| 3385 | (defun gdb-source-info () | ||
| 3386 | "Find the source file where the program starts and display it with related | ||
| 3387 | buffers." | ||
| 3388 | (goto-char (point-min)) | ||
| 3389 | (if (and (search-forward "Located in " nil t) | ||
| 3390 | (looking-at "\\S-+")) | ||
| 3391 | (setq gdb-main-file (match-string 0))) | ||
| 3392 | (goto-char (point-min)) | ||
| 3393 | (if (search-forward "Includes preprocessor macro info." nil t) | ||
| 3394 | (setq gdb-macro-info t)) | ||
| 3395 | (if gdb-many-windows | ||
| 3396 | (gdb-setup-windows) | ||
| 3397 | (gdb-get-buffer-create 'gdb-breakpoints-buffer) | ||
| 3398 | (if (and gdb-show-main gdb-main-file) | ||
| 3399 | (let ((pop-up-windows t)) | ||
| 3400 | (display-buffer (gud-find-file gdb-main-file))))) | ||
| 3401 | (setq gdb-ready t)) | ||
| 3402 | |||
| 3403 | (defun gdb-get-location (bptno line flag) | ||
| 3404 | "Find the directory containing the relevant source file. | ||
| 3405 | Put in buffer and place breakpoint icon." | ||
| 3406 | (goto-char (point-min)) | ||
| 3407 | (catch 'file-not-found | ||
| 3408 | (if (search-forward "Located in " nil t) | ||
| 3409 | (when (looking-at "\\S-+") | ||
| 3410 | (delete (cons bptno "File not found") gdb-location-alist) | ||
| 3411 | (push (cons bptno (match-string 0)) gdb-location-alist)) | ||
| 3412 | (gdb-resync) | ||
| 3413 | (unless (assoc bptno gdb-location-alist) | ||
| 3414 | (push (cons bptno "File not found") gdb-location-alist) | ||
| 3415 | (message-box "Cannot find source file for breakpoint location.\n\ | ||
| 3416 | Add directory to search path for source files using the GDB command, dir.")) | ||
| 3417 | (throw 'file-not-found nil)) | ||
| 3418 | (with-current-buffer | ||
| 3419 | (find-file-noselect (match-string 0)) | ||
| 3420 | (gdb-init-buffer) | ||
| 3421 | ;; only want one breakpoint icon at each location | ||
| 3422 | (save-excursion | ||
| 3423 | (goto-char (point-min)) | ||
| 3424 | (forward-line (1- (string-to-number line))) | ||
| 3425 | (gdb-put-breakpoint-icon (eq flag ?y) bptno))))) | ||
| 3426 | |||
| 3427 | (add-hook 'find-file-hook 'gdb-find-file-hook) | ||
| 3428 | |||
| 3429 | (defun gdb-find-file-hook () | ||
| 3430 | "Set up buffer for debugging if file is part of the source code | ||
| 3431 | of the current session." | ||
| 3432 | (if (and (buffer-name gud-comint-buffer) | ||
| 3433 | ;; in case gud or gdb-ui is just loaded | ||
| 3434 | gud-comint-buffer | ||
| 3435 | (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | ||
| 3436 | '(gdba gdbmi))) | ||
| 3437 | ;;Pre GDB 6.3 "info sources" doesn't give absolute file name. | ||
| 3438 | (if (member (if (string-equal gdb-version "pre-6.4") | ||
| 3439 | (file-name-nondirectory buffer-file-name) | ||
| 3440 | buffer-file-name) | ||
| 3441 | gdb-source-file-list) | ||
| 3442 | (with-current-buffer (find-buffer-visiting buffer-file-name) | ||
| 3443 | (gdb-init-buffer))))) | ||
| 3444 | |||
| 3445 | ;;from put-image | ||
| 3446 | (defun gdb-put-string (putstring pos &optional dprop &rest sprops) | ||
| 3447 | "Put string PUTSTRING in front of POS in the current buffer. | ||
| 3448 | PUTSTRING is displayed by putting an overlay into the current buffer with a | ||
| 3449 | `before-string' string that has a `display' property whose value is | ||
| 3450 | PUTSTRING." | ||
| 3451 | (let ((string (make-string 1 ?x)) | ||
| 3452 | (buffer (current-buffer))) | ||
| 3453 | (setq putstring (copy-sequence putstring)) | ||
| 3454 | (let ((overlay (make-overlay pos pos buffer)) | ||
| 3455 | (prop (or dprop | ||
| 3456 | (list (list 'margin 'left-margin) putstring)))) | ||
| 3457 | (put-text-property 0 1 'display prop string) | ||
| 3458 | (if sprops | ||
| 3459 | (add-text-properties 0 1 sprops string)) | ||
| 3460 | (overlay-put overlay 'put-break t) | ||
| 3461 | (overlay-put overlay 'before-string string)))) | ||
| 3462 | |||
| 3463 | ;;from remove-images | ||
| 3464 | (defun gdb-remove-strings (start end &optional buffer) | ||
| 3465 | "Remove strings between START and END in BUFFER. | ||
| 3466 | Remove only strings that were put in BUFFER with calls to `gdb-put-string'. | ||
| 3467 | BUFFER nil or omitted means use the current buffer." | ||
| 3468 | (unless buffer | ||
| 3469 | (setq buffer (current-buffer))) | ||
| 3470 | (dolist (overlay (overlays-in start end)) | ||
| 3471 | (when (overlay-get overlay 'put-break) | ||
| 3472 | (delete-overlay overlay)))) | ||
| 3473 | |||
| 3474 | (defun gdb-put-breakpoint-icon (enabled bptno) | ||
| 3475 | (if (string-match "[0-9+]+\\." bptno) | ||
| 3476 | (setq enabled gdb-parent-bptno-enabled)) | ||
| 3477 | (let ((start (- (line-beginning-position) 1)) | ||
| 3478 | (end (+ (line-end-position) 1)) | ||
| 3479 | (putstring (if enabled "B" "b")) | ||
| 3480 | (source-window (get-buffer-window (current-buffer) 0))) | ||
| 3481 | (add-text-properties | ||
| 3482 | 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt") | ||
| 3483 | putstring) | ||
| 3484 | (if enabled | ||
| 3485 | (add-text-properties | ||
| 3486 | 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring) | ||
| 3487 | (add-text-properties | ||
| 3488 | 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring)) | ||
| 3489 | (gdb-remove-breakpoint-icons start end) | ||
| 3490 | (if (display-images-p) | ||
| 3491 | (if (>= (or left-fringe-width | ||
| 3492 | (if source-window (car (window-fringes source-window))) | ||
| 3493 | gdb-buffer-fringe-width) 8) | ||
| 3494 | (gdb-put-string | ||
| 3495 | nil (1+ start) | ||
| 3496 | `(left-fringe breakpoint | ||
| 3497 | ,(if enabled | ||
| 3498 | 'breakpoint-enabled | ||
| 3499 | 'breakpoint-disabled)) | ||
| 3500 | 'gdb-bptno bptno | ||
| 3501 | 'gdb-enabled enabled) | ||
| 3502 | (when (< left-margin-width 2) | ||
| 3503 | (save-current-buffer | ||
| 3504 | (setq left-margin-width 2) | ||
| 3505 | (if source-window | ||
| 3506 | (set-window-margins | ||
| 3507 | source-window | ||
| 3508 | left-margin-width right-margin-width)))) | ||
| 3509 | (put-image | ||
| 3510 | (if enabled | ||
| 3511 | (or breakpoint-enabled-icon | ||
| 3512 | (setq breakpoint-enabled-icon | ||
| 3513 | (find-image `((:type xpm :data | ||
| 3514 | ,breakpoint-xpm-data | ||
| 3515 | :ascent 100 :pointer hand) | ||
| 3516 | (:type pbm :data | ||
| 3517 | ,breakpoint-enabled-pbm-data | ||
| 3518 | :ascent 100 :pointer hand))))) | ||
| 3519 | (or breakpoint-disabled-icon | ||
| 3520 | (setq breakpoint-disabled-icon | ||
| 3521 | (find-image `((:type xpm :data | ||
| 3522 | ,breakpoint-xpm-data | ||
| 3523 | :conversion disabled | ||
| 3524 | :ascent 100 :pointer hand) | ||
| 3525 | (:type pbm :data | ||
| 3526 | ,breakpoint-disabled-pbm-data | ||
| 3527 | :ascent 100 :pointer hand)))))) | ||
| 3528 | (+ start 1) | ||
| 3529 | putstring | ||
| 3530 | 'left-margin)) | ||
| 3531 | (when (< left-margin-width 2) | ||
| 3532 | (save-current-buffer | ||
| 3533 | (setq left-margin-width 2) | ||
| 3534 | (let ((window (get-buffer-window (current-buffer) 0))) | ||
| 3535 | (if window | ||
| 3536 | (set-window-margins | ||
| 3537 | window left-margin-width right-margin-width))))) | ||
| 3538 | (gdb-put-string | ||
| 3539 | (propertize putstring | ||
| 3540 | 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled)) | ||
| 3541 | (1+ start))))) | ||
| 3542 | |||
| 3543 | (defun gdb-remove-breakpoint-icons (start end &optional remove-margin) | ||
| 3544 | (gdb-remove-strings start end) | ||
| 3545 | (if (display-images-p) | ||
| 3546 | (remove-images start end)) | ||
| 3547 | (when remove-margin | ||
| 3548 | (setq left-margin-width 0) | ||
| 3549 | (let ((window (get-buffer-window (current-buffer) 0))) | ||
| 3550 | (if window | ||
| 3551 | (set-window-margins | ||
| 3552 | window left-margin-width right-margin-width))))) | ||
| 3553 | |||
| 3554 | |||
| 3555 | ;; | ||
| 3556 | ;; Assembler buffer. | ||
| 3557 | ;; | ||
| 3558 | (gdb-set-buffer-rules 'gdb-assembler-buffer | ||
| 3559 | 'gdb-assembler-buffer-name | ||
| 3560 | 'gdb-assembler-mode) | ||
| 3561 | |||
| 3562 | ;; We can't use def-gdb-auto-update-handler because we don't want to use | ||
| 3563 | ;; window-start but keep the overlay arrow/current line visible. | ||
| 3564 | (defun gdb-assembler-handler () | ||
| 3565 | (setq gdb-pending-triggers | ||
| 3566 | (delq 'gdb-invalidate-assembler | ||
| 3567 | gdb-pending-triggers)) | ||
| 3568 | (let ((buf (gdb-get-buffer 'gdb-assembler-buffer))) | ||
| 3569 | (and buf | ||
| 3570 | (with-current-buffer buf | ||
| 3571 | (let* ((window (get-buffer-window buf 0)) | ||
| 3572 | (p (window-point window)) | ||
| 3573 | (buffer-read-only nil)) | ||
| 3574 | (erase-buffer) | ||
| 3575 | (insert-buffer-substring (gdb-get-buffer-create | ||
| 3576 | 'gdb-partial-output-buffer)) | ||
| 3577 | (set-window-point window p))))) | ||
| 3578 | ;; put customisation here | ||
| 3579 | (gdb-assembler-custom)) | ||
| 3580 | |||
| 3581 | (defun gdb-assembler-custom () | ||
| 3582 | (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer)) | ||
| 3583 | (pos 1) (address) (flag) (bptno)) | ||
| 3584 | (with-current-buffer buffer | ||
| 3585 | (save-excursion | ||
| 3586 | (if (not (equal gdb-pc-address "main")) | ||
| 3587 | (progn | ||
| 3588 | (goto-char (point-min)) | ||
| 3589 | (if (and gdb-pc-address | ||
| 3590 | (search-forward gdb-pc-address nil t)) | ||
| 3591 | (progn | ||
| 3592 | (setq pos (point)) | ||
| 3593 | (beginning-of-line) | ||
| 3594 | (setq fringe-indicator-alist | ||
| 3595 | (if (string-equal gdb-frame-number "0") | ||
| 3596 | nil | ||
| 3597 | '((overlay-arrow . hollow-right-triangle)))) | ||
| 3598 | (or gdb-overlay-arrow-position | ||
| 3599 | (setq gdb-overlay-arrow-position (make-marker))) | ||
| 3600 | (set-marker gdb-overlay-arrow-position (point)))))) | ||
| 3601 | ;; remove all breakpoint-icons in assembler buffer before updating. | ||
| 3602 | (gdb-remove-breakpoint-icons (point-min) (point-max)))) | ||
| 3603 | (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer) | ||
| 3604 | (goto-char (point-min)) | ||
| 3605 | (while (< (point) (- (point-max) 1)) | ||
| 3606 | (forward-line 1) | ||
| 3607 | (when (looking-at | ||
| 3608 | "\\([0-9]+\\.?[0-9]*\\).*?\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)") | ||
| 3609 | (setq bptno (match-string 1)) | ||
| 3610 | (setq flag (char-after (match-beginning 2))) | ||
| 3611 | (setq address (match-string 3)) | ||
| 3612 | (with-current-buffer buffer | ||
| 3613 | (save-excursion | ||
| 3614 | (goto-char (point-min)) | ||
| 3615 | (if (re-search-forward (concat "^0x0*" address) nil t) | ||
| 3616 | (gdb-put-breakpoint-icon (eq flag ?y) bptno))))))) | ||
| 3617 | (if (not (equal gdb-pc-address "main")) | ||
| 3618 | (with-current-buffer buffer | ||
| 3619 | (set-window-point (get-buffer-window buffer 0) pos))))) | ||
| 3620 | |||
| 3621 | (defvar gdb-assembler-mode-map | ||
| 3622 | (let ((map (make-sparse-keymap))) | ||
| 3623 | (suppress-keymap map) | ||
| 3624 | (define-key map "q" 'kill-this-buffer) | ||
| 3625 | map)) | ||
| 3626 | |||
| 3627 | (defvar gdb-assembler-font-lock-keywords | ||
| 3628 | '(;; <__function.name+n> | ||
| 3629 | ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" | ||
| 3630 | (1 font-lock-function-name-face)) | ||
| 3631 | ;; 0xNNNNNNNN <__function.name+n>: opcode | ||
| 3632 | ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)" | ||
| 3633 | (4 font-lock-keyword-face)) | ||
| 3634 | ;; %register(at least i386) | ||
| 3635 | ("%\\sw+" . font-lock-variable-name-face) | ||
| 3636 | ("^\\(Dump of assembler code for function\\) \\(.+\\):" | ||
| 3637 | (1 font-lock-comment-face) | ||
| 3638 | (2 font-lock-function-name-face)) | ||
| 3639 | ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face)) | ||
| 3640 | "Font lock keywords used in `gdb-assembler-mode'.") | ||
| 3641 | |||
| 3642 | (defun gdb-assembler-mode () | ||
| 3643 | "Major mode for viewing code assembler. | ||
| 3644 | |||
| 3645 | \\{gdb-assembler-mode-map}" | ||
| 3646 | (kill-all-local-variables) | ||
| 3647 | (setq major-mode 'gdb-assembler-mode) | ||
| 3648 | (setq mode-name (concat "Machine:" gdb-selected-frame)) | ||
| 3649 | (setq gdb-overlay-arrow-position nil) | ||
| 3650 | (add-to-list 'overlay-arrow-variable-list 'gdb-overlay-arrow-position) | ||
| 3651 | (setq fringes-outside-margins t) | ||
| 3652 | (setq buffer-read-only t) | ||
| 3653 | (buffer-disable-undo) | ||
| 3654 | (gdb-thread-identification) | ||
| 3655 | (use-local-map gdb-assembler-mode-map) | ||
| 3656 | (gdb-invalidate-assembler) | ||
| 3657 | (set (make-local-variable 'font-lock-defaults) | ||
| 3658 | '(gdb-assembler-font-lock-keywords)) | ||
| 3659 | (run-mode-hooks 'gdb-assembler-mode-hook) | ||
| 3660 | 'gdb-invalidate-assembler) | ||
| 3661 | |||
| 3662 | (defun gdb-assembler-buffer-name () | ||
| 3663 | (with-current-buffer gud-comint-buffer | ||
| 3664 | (concat "*disassembly of " (gdb-get-target-string) "*"))) | ||
| 3665 | |||
| 3666 | (defun gdb-display-assembler-buffer () | ||
| 3667 | "Display disassembly view." | ||
| 3668 | (interactive) | ||
| 3669 | (setq gdb-previous-frame nil) | ||
| 3670 | (gdb-display-buffer | ||
| 3671 | (gdb-get-buffer-create 'gdb-assembler-buffer) t)) | ||
| 3672 | |||
| 3673 | (defun gdb-frame-assembler-buffer () | ||
| 3674 | "Display disassembly view in a new frame." | ||
| 3675 | (interactive) | ||
| 3676 | (setq gdb-previous-frame nil) | ||
| 3677 | (let ((special-display-regexps (append special-display-regexps '(".*"))) | ||
| 3678 | (special-display-frame-alist gdb-frame-parameters)) | ||
| 3679 | (display-buffer (gdb-get-buffer-create 'gdb-assembler-buffer)))) | ||
| 3680 | |||
| 3681 | ;; modified because if gdb-pc-address has changed value a new command | ||
| 3682 | ;; must be enqueued to update the buffer with the new output | ||
| 3683 | (defun gdb-invalidate-assembler (&optional ignored) | ||
| 3684 | (if (gdb-get-buffer 'gdb-assembler-buffer) | ||
| 3685 | (progn | ||
| 3686 | (unless (and gdb-selected-frame | ||
| 3687 | (string-equal gdb-selected-frame gdb-previous-frame)) | ||
| 3688 | (if (or (not (member 'gdb-invalidate-assembler | ||
| 3689 | gdb-pending-triggers)) | ||
| 3690 | (not (equal (string-to-number gdb-pc-address) | ||
| 3691 | (string-to-number | ||
| 3692 | gdb-previous-frame-pc-address)))) | ||
| 3693 | (progn | ||
| 3694 | ;; take previous disassemble command, if any, off the queue | ||
| 3695 | (with-current-buffer gud-comint-buffer | ||
| 3696 | (let ((queue gdb-input-queue)) | ||
| 3697 | (dolist (item queue) | ||
| 3698 | (if (equal (cdr item) '(gdb-assembler-handler)) | ||
| 3699 | (setq gdb-input-queue | ||
| 3700 | (delete item gdb-input-queue)))))) | ||
| 3701 | (gdb-enqueue-input | ||
| 3702 | (list | ||
| 3703 | (concat gdb-server-prefix "disassemble " gdb-pc-address "\n") | ||
| 3704 | 'gdb-assembler-handler)) | ||
| 3705 | (push 'gdb-invalidate-assembler gdb-pending-triggers) | ||
| 3706 | (setq gdb-previous-frame-pc-address gdb-pc-address) | ||
| 3707 | (setq gdb-previous-frame gdb-selected-frame))))))) | ||
| 3708 | |||
| 3709 | (defun gdb-get-selected-frame () | ||
| 3710 | (if (not (member 'gdb-get-selected-frame gdb-pending-triggers)) | ||
| 3711 | (progn | ||
| 3712 | (if (string-equal gdb-version "pre-6.4") | ||
| 3713 | (gdb-enqueue-input | ||
| 3714 | (list (concat gdb-server-prefix "info frame\n") | ||
| 3715 | 'gdb-frame-handler)) | ||
| 3716 | (gdb-enqueue-input | ||
| 3717 | (list "server interpreter mi -stack-info-frame\n" | ||
| 3718 | 'gdb-frame-handler-1))) | ||
| 3719 | (push 'gdb-get-selected-frame gdb-pending-triggers)))) | ||
| 3720 | |||
| 3721 | (defun gdb-frame-handler () | ||
| 3722 | (setq gdb-pending-triggers | ||
| 3723 | (delq 'gdb-get-selected-frame gdb-pending-triggers)) | ||
| 3724 | (goto-char (point-min)) | ||
| 3725 | (when (re-search-forward | ||
| 3726 | "Stack level \\([0-9]+\\), frame at \\(0x[[:xdigit:]]+\\)" nil t) | ||
| 3727 | (setq gdb-frame-number (match-string 1)) | ||
| 3728 | (setq gdb-frame-address (match-string 2))) | ||
| 3729 | (goto-char (point-min)) | ||
| 3730 | (when (re-search-forward ".*=\\s-+\\(\\S-*\\)\\s-+in\\s-+\\(.*?\\)\ | ||
| 3731 | \\(?: (\\(\\S-+?\\):[0-9]+?)\\)*; " | ||
| 3732 | nil t) | ||
| 3733 | (setq gdb-selected-frame (match-string 2)) | ||
| 3734 | (if (gdb-get-buffer 'gdb-locals-buffer) | ||
| 3735 | (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) | ||
| 3736 | (setq mode-name (concat "Locals:" gdb-selected-frame)))) | ||
| 3737 | (if (gdb-get-buffer 'gdb-assembler-buffer) | ||
| 3738 | (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer) | ||
| 3739 | (setq mode-name (concat "Machine:" gdb-selected-frame)))) | ||
| 3740 | (setq gdb-pc-address (match-string 1)) | ||
| 3741 | (if (and (match-string 3) gud-overlay-arrow-position) | ||
| 3742 | (let ((buffer (marker-buffer gud-overlay-arrow-position)) | ||
| 3743 | (position (marker-position gud-overlay-arrow-position))) | ||
| 3744 | (when (and buffer | ||
| 3745 | (string-equal (file-name-nondirectory | ||
| 3746 | (buffer-file-name buffer)) | ||
| 3747 | (file-name-nondirectory (match-string 3)))) | ||
| 3748 | (with-current-buffer buffer | ||
| 3749 | (setq fringe-indicator-alist | ||
| 3750 | (if (string-equal gdb-frame-number "0") | ||
| 3751 | nil | ||
| 3752 | '((overlay-arrow . hollow-right-triangle)))) | ||
| 3753 | (set-marker gud-overlay-arrow-position position)))))) | ||
| 3754 | (goto-char (point-min)) | ||
| 3755 | (if (re-search-forward " source language \\(\\S-+\\)\." nil t) | ||
| 3756 | (setq gdb-current-language (match-string 1))) | ||
| 3757 | (gdb-invalidate-assembler)) | ||
| 3758 | |||
| 3759 | |||
| 3760 | ;; Code specific to GDB 6.4 | ||
| 3761 | (defconst gdb-source-file-regexp-1 "fullname=\"\\(.*?\\)\"") | ||
| 3762 | |||
| 3763 | (defun gdb-set-gud-minor-mode-existing-buffers-1 () | ||
| 3764 | "Create list of source files for current GDB session. | ||
| 3765 | If buffers already exist for any of these files, `gud-minor-mode' | ||
| 3766 | is set in them." | ||
| 3767 | (goto-char (point-min)) | ||
| 3768 | (while (re-search-forward gdb-source-file-regexp-1 nil t) | ||
| 3769 | (push (match-string 1) gdb-source-file-list)) | ||
| 3770 | (dolist (buffer (buffer-list)) | ||
| 3771 | (with-current-buffer buffer | ||
| 3772 | (when (member buffer-file-name gdb-source-file-list) | ||
| 3773 | (gdb-init-buffer)))) | ||
| 3774 | (gdb-force-mode-line-update | ||
| 3775 | (propertize "ready" 'face font-lock-variable-name-face))) | ||
| 3776 | |||
| 3777 | ;; Used for -stack-info-frame but could be used for -stack-list-frames too. | ||
| 3778 | (defconst gdb-stack-list-frames-regexp | ||
| 3779 | ".*?level=\"\\(.*?\\)\".*?,addr=\"\\(.*?\\)\".*?,func=\"\\(.*?\\)\",\ | ||
| 3780 | \\(?:.*?file=\".*?\".*?,fullname=\"\\(.*?\\)\".*?,line=\"\\(.*?\\)\".*?}\\|\ | ||
| 3781 | from=\"\\(.*?\\)\"\\)") | ||
| 3782 | |||
| 3783 | (defun gdb-frame-handler-1 () | ||
| 3784 | (setq gdb-pending-triggers | ||
| 3785 | (delq 'gdb-get-selected-frame gdb-pending-triggers)) | ||
| 3786 | (goto-char (point-min)) | ||
| 3787 | (when (re-search-forward gdb-stack-list-frames-regexp nil t) | ||
| 3788 | (setq gdb-frame-number (match-string 1)) | ||
| 3789 | (setq gdb-pc-address (match-string 2)) | ||
| 3790 | (setq gdb-selected-frame (match-string 3)) | ||
| 3791 | (if (gdb-get-buffer 'gdb-locals-buffer) | ||
| 3792 | (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) | ||
| 3793 | (setq mode-name (concat "Locals:" gdb-selected-frame)))) | ||
| 3794 | (if (gdb-get-buffer 'gdb-assembler-buffer) | ||
| 3795 | (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer) | ||
| 3796 | (setq mode-name (concat "Machine:" gdb-selected-frame))))) | ||
| 3797 | (if (and (match-string 4) (match-string 5) gud-overlay-arrow-position) | ||
| 3798 | (let ((buffer (marker-buffer gud-overlay-arrow-position)) | ||
| 3799 | (position (marker-position gud-overlay-arrow-position))) | ||
| 3800 | (when (and buffer | ||
| 3801 | (string-equal (file-name-nondirectory | ||
| 3802 | (buffer-file-name buffer)) | ||
| 3803 | (file-name-nondirectory (match-string 4)))) | ||
| 3804 | (with-current-buffer buffer | ||
| 3805 | (setq fringe-indicator-alist | ||
| 3806 | (if (string-equal gdb-frame-number "0") | ||
| 3807 | nil | ||
| 3808 | '((overlay-arrow . hollow-right-triangle)))) | ||
| 3809 | (set-marker gud-overlay-arrow-position position))))) | ||
| 3810 | (gdb-invalidate-assembler)) | ||
| 3811 | |||
| 3812 | ; Uses "-var-list-children --all-values". Needs GDB 6.4 onwards. | ||
| 3813 | (defun gdb-var-list-children-1 (varnum) | ||
| 3814 | (gdb-enqueue-input | ||
| 3815 | (list | ||
| 3816 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 3817 | (concat "server interpreter mi \"-var-list-children --all-values \\\"" | ||
| 3818 | varnum "\\\"\"\n") | ||
| 3819 | (concat "-var-list-children --all-values \"" varnum "\"\n")) | ||
| 3820 | `(lambda () (gdb-var-list-children-handler-1 ,varnum))))) | ||
| 3821 | |||
| 3822 | (defun gdb-var-list-children-handler-1 (varnum) | ||
| 3823 | (let* ((var-list nil) | ||
| 3824 | (output (bindat-get-field (gdb-json-partial-output "child"))) | ||
| 3825 | (children (bindat-get-field output 'children))) | ||
| 3826 | (catch 'child-already-watched | ||
| 3827 | (dolist (var gdb-var-list) | ||
| 3828 | (if (string-equal varnum (car var)) | ||
| 3829 | (progn | ||
| 3830 | ;; With dynamic varobjs numchild may have increased. | ||
| 3831 | (setcar (nthcdr 2 var) (bindat-get-field output 'numchild)) | ||
| 3832 | (push var var-list) | ||
| 3833 | (dolist (child children) | ||
| 3834 | (let ((varchild (list (bindat-get-field child 'name) | ||
| 3835 | (bindat-get-field child 'exp) | ||
| 3836 | (bindat-get-field child 'numchild) | ||
| 3837 | (bindat-get-field child 'type) | ||
| 3838 | (bindat-get-field child 'value) | ||
| 3839 | nil | ||
| 3840 | (bindat-get-field child 'has_more)))) | ||
| 3841 | (if (assoc (car varchild) gdb-var-list) | ||
| 3842 | (throw 'child-already-watched nil)) | ||
| 3843 | (push varchild var-list)))) | ||
| 3844 | (push var var-list))) | ||
| 3845 | (setq gdb-var-list (nreverse var-list)))) | ||
| 3846 | (gdb-speedbar-update)) | ||
| 3847 | |||
| 3848 | ; Uses "-var-update --all-values". Needs GDB 6.4 onwards. | ||
| 3849 | (defun gdb-var-update-1 () | ||
| 3850 | (if (not (member 'gdb-var-update gdb-pending-triggers)) | ||
| 3851 | (progn | ||
| 3852 | (gdb-enqueue-input | ||
| 3853 | (list | ||
| 3854 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 3855 | "server interpreter mi \"-var-update --all-values *\"\n" | ||
| 3856 | "-var-update --all-values *\n") | ||
| 3857 | 'gdb-var-update-handler-1)) | ||
| 3858 | (push 'gdb-var-update gdb-pending-triggers)))) | ||
| 3859 | |||
| 3860 | (defun gdb-var-update-handler-1 () | ||
| 3861 | (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist))) | ||
| 3862 | (dolist (var gdb-var-list) | ||
| 3863 | (setcar (nthcdr 5 var) nil)) | ||
| 3864 | (let ((temp-var-list gdb-var-list)) | ||
| 3865 | (dolist (change changelist) | ||
| 3866 | (let* ((varnum (bindat-get-field change 'name)) | ||
| 3867 | (var (assoc varnum gdb-var-list)) | ||
| 3868 | (new-num (bindat-get-field change 'new_num_children))) | ||
| 3869 | (when var | ||
| 3870 | (let ((scope (bindat-get-field change 'in_scope)) | ||
| 3871 | (has-more (bindat-get-field change 'has_more))) | ||
| 3872 | (cond ((string-equal scope "false") | ||
| 3873 | (if gdb-delete-out-of-scope | ||
| 3874 | (gdb-var-delete-1 var varnum) | ||
| 3875 | (setcar (nthcdr 5 var) 'out-of-scope))) | ||
| 3876 | ((string-equal scope "true") | ||
| 3877 | (setcar (nthcdr 6 var) has-more) | ||
| 3878 | (when (and (or (not has-more) | ||
| 3879 | (string-equal has-more "0")) | ||
| 3880 | (not new-num) | ||
| 3881 | (string-equal (nth 2 var) "0")) | ||
| 3882 | (setcar (nthcdr 4 var) | ||
| 3883 | (bindat-get-field change 'value)) | ||
| 3884 | (setcar (nthcdr 5 var) 'changed))) | ||
| 3885 | ((string-equal scope "invalid") | ||
| 3886 | (gdb-var-delete-1 var varnum))))) | ||
| 3887 | (let ((var-list nil) var1 | ||
| 3888 | (children (bindat-get-field change 'new_children))) | ||
| 3889 | (if new-num | ||
| 3890 | (progn | ||
| 3891 | (setq var1 (pop temp-var-list)) | ||
| 3892 | (while var1 | ||
| 3893 | (if (string-equal varnum (car var1)) | ||
| 3894 | (let ((new (string-to-number new-num)) | ||
| 3895 | (previous (string-to-number (nth 2 var1)))) | ||
| 3896 | (setcar (nthcdr 2 var1) new-num) | ||
| 3897 | (push var1 var-list) | ||
| 3898 | (cond ((> new previous) | ||
| 3899 | ;; Add new children to list. | ||
| 3900 | (dotimes (dummy previous) | ||
| 3901 | (push (pop temp-var-list) var-list)) | ||
| 3902 | (dolist (child children) | ||
| 3903 | (let ((varchild | ||
| 3904 | (list (bindat-get-field child 'name) | ||
| 3905 | (bindat-get-field child 'exp) | ||
| 3906 | (bindat-get-field child 'numchild) | ||
| 3907 | (bindat-get-field child 'type) | ||
| 3908 | (bindat-get-field child 'value) | ||
| 3909 | 'changed | ||
| 3910 | (bindat-get-field child 'has_more)))) | ||
| 3911 | (push varchild var-list)))) | ||
| 3912 | ;; Remove deleted children from list. | ||
| 3913 | ((< new previous) | ||
| 3914 | (dotimes (dummy new) | ||
| 3915 | (push (pop temp-var-list) var-list)) | ||
| 3916 | (dotimes (dummy (- previous new)) | ||
| 3917 | (pop temp-var-list))))) | ||
| 3918 | (push var1 var-list)) | ||
| 3919 | (setq var1 (pop temp-var-list))) | ||
| 3920 | (setq gdb-var-list (nreverse var-list))))))))) | ||
| 3921 | (setq gdb-pending-triggers | ||
| 3922 | (delq 'gdb-var-update gdb-pending-triggers)) | ||
| 3923 | (gdb-speedbar-update)) | ||
| 3924 | |||
| 3925 | ;; Registers buffer. | ||
| 3926 | ;; | ||
| 3927 | (gdb-set-buffer-rules 'gdb-registers-buffer | ||
| 3928 | 'gdb-registers-buffer-name | ||
| 3929 | 'gdb-registers-mode) | ||
| 3930 | |||
| 3931 | (def-gdb-auto-update-trigger gdb-invalidate-registers-1 | ||
| 3932 | (gdb-get-buffer 'gdb-registers-buffer) | ||
| 3933 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 3934 | "server interpreter mi \"-data-list-register-values x\"\n" | ||
| 3935 | "-data-list-register-values x\n") | ||
| 3936 | gdb-data-list-register-values-handler) | ||
| 3937 | |||
| 3938 | (defconst gdb-data-list-register-values-regexp | ||
| 3939 | "{.*?number=\"\\(.*?\\)\".*?,value=\"\\(.*?\\)\".*?}") | ||
| 3940 | |||
| 3941 | (defun gdb-data-list-register-values-handler () | ||
| 3942 | (setq gdb-pending-triggers (delq 'gdb-invalidate-registers-1 | ||
| 3943 | gdb-pending-triggers)) | ||
| 3944 | (goto-char (point-min)) | ||
| 3945 | (if (re-search-forward gdb-error-regexp nil t) | ||
| 3946 | (let ((err (match-string 1))) | ||
| 3947 | (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) | ||
| 3948 | (let ((buffer-read-only nil)) | ||
| 3949 | (erase-buffer) | ||
| 3950 | (put-text-property 0 (length err) 'face font-lock-warning-face err) | ||
| 3951 | (insert err) | ||
| 3952 | (goto-char (point-min))))) | ||
| 3953 | (let ((register-list (reverse gdb-register-names)) | ||
| 3954 | (register nil) (register-string nil) (register-values nil)) | ||
| 3955 | (goto-char (point-min)) | ||
| 3956 | (while (re-search-forward gdb-data-list-register-values-regexp nil t) | ||
| 3957 | (setq register (pop register-list)) | ||
| 3958 | (setq register-string (concat register "\t" (match-string 2) "\n")) | ||
| 3959 | (if (member (match-string 1) gdb-changed-registers) | ||
| 3960 | (put-text-property 0 (length register-string) | ||
| 3961 | 'face 'font-lock-warning-face | ||
| 3962 | register-string)) | ||
| 3963 | (setq register-values | ||
| 3964 | (concat register-values register-string))) | ||
| 3965 | (let ((buf (gdb-get-buffer 'gdb-registers-buffer))) | ||
| 3966 | (with-current-buffer buf | ||
| 3967 | (let* ((window (get-buffer-window buf 0)) | ||
| 3968 | (start (window-start window)) | ||
| 3969 | (p (if window (window-point window) (point))) | ||
| 3970 | (buffer-read-only nil)) | ||
| 3971 | (erase-buffer) | ||
| 3972 | (insert register-values) | ||
| 3973 | (if window | ||
| 3974 | (progn | ||
| 3975 | (set-window-start window start) | ||
| 3976 | (set-window-point window p)) | ||
| 3977 | (goto-char p))))))) | ||
| 3978 | (gdb-data-list-register-values-custom)) | ||
| 3979 | |||
| 3980 | (defun gdb-data-list-register-values-custom () | ||
| 3981 | (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) | ||
| 3982 | (save-excursion | ||
| 3983 | (let ((buffer-read-only nil) | ||
| 3984 | start end) | ||
| 3985 | (goto-char (point-min)) | ||
| 3986 | (while (< (point) (point-max)) | ||
| 3987 | (setq start (line-beginning-position)) | ||
| 3988 | (setq end (line-end-position)) | ||
| 3989 | (when (looking-at "^[^\t]+") | ||
| 3990 | (unless (string-equal (match-string 0) "No registers.") | ||
| 3991 | (put-text-property start (match-end 0) | ||
| 3992 | 'face font-lock-variable-name-face) | ||
| 3993 | (add-text-properties start end | ||
| 3994 | '(help-echo "mouse-2: edit value" | ||
| 3995 | mouse-face highlight)))) | ||
| 3996 | (forward-line 1)))))) | ||
| 3997 | |||
| 3998 | ;; Needs GDB 6.4 onwards (used to fail with no stack). | ||
| 3999 | (defun gdb-get-changed-registers () | ||
| 4000 | (if (and (gdb-get-buffer 'gdb-registers-buffer) | ||
| 4001 | (not (member 'gdb-get-changed-registers gdb-pending-triggers))) | ||
| 4002 | (progn | ||
| 4003 | (gdb-enqueue-input | ||
| 4004 | (list | ||
| 4005 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 4006 | "server interpreter mi -data-list-changed-registers\n" | ||
| 4007 | "-data-list-changed-registers\n") | ||
| 4008 | 'gdb-get-changed-registers-handler)) | ||
| 4009 | (push 'gdb-get-changed-registers gdb-pending-triggers)))) | ||
| 4010 | |||
| 4011 | (defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"") | ||
| 4012 | |||
| 4013 | (defun gdb-get-changed-registers-handler () | ||
| 4014 | (setq gdb-pending-triggers | ||
| 4015 | (delq 'gdb-get-changed-registers gdb-pending-triggers)) | ||
| 4016 | (setq gdb-changed-registers nil) | ||
| 4017 | (goto-char (point-min)) | ||
| 4018 | (while (re-search-forward gdb-data-list-register-names-regexp nil t) | ||
| 4019 | (push (match-string 1) gdb-changed-registers))) | ||
| 4020 | |||
| 4021 | |||
| 4022 | ;; Locals buffer. | ||
| 4023 | ;; | ||
| 4024 | ;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards. | ||
| 4025 | (gdb-set-buffer-rules 'gdb-locals-buffer | ||
| 4026 | 'gdb-locals-buffer-name | ||
| 4027 | 'gdb-locals-mode) | ||
| 4028 | |||
| 4029 | (def-gdb-auto-update-trigger gdb-invalidate-locals-1 | ||
| 4030 | (gdb-get-buffer 'gdb-locals-buffer) | ||
| 4031 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) | ||
| 4032 | "server interpreter mi -\"stack-list-locals --simple-values\"\n" | ||
| 4033 | "-stack-list-locals --simple-values\n") | ||
| 4034 | gdb-stack-list-locals-handler) | ||
| 4035 | |||
| 4036 | (defconst gdb-stack-list-locals-regexp | ||
| 4037 | "{.*?name=\"\\(.*?\\)\".*?,type=\"\\(.*?\\)\"") | ||
| 4038 | |||
| 4039 | (defvar gdb-locals-watch-map-1 | ||
| 4040 | (let ((map (make-sparse-keymap))) | ||
| 4041 | (suppress-keymap map) | ||
| 4042 | (define-key map "\r" 'gud-watch) | ||
| 4043 | (define-key map [mouse-2] 'gud-watch) | ||
| 4044 | map) | ||
| 4045 | "Keymap to create watch expression of a complex data type local variable.") | ||
| 4046 | |||
| 4047 | (defvar gdb-edit-locals-map-1 | ||
| 4048 | (let ((map (make-sparse-keymap))) | ||
| 4049 | (suppress-keymap map) | ||
| 4050 | (define-key map "\r" 'gdb-edit-locals-value) | ||
| 4051 | (define-key map [mouse-2] 'gdb-edit-locals-value) | ||
| 4052 | map) | ||
| 4053 | "Keymap to edit value of a simple data type local variable.") | ||
| 4054 | |||
| 4055 | (defun gdb-edit-locals-value (&optional event) | ||
| 4056 | "Assign a value to a variable displayed in the locals buffer." | ||
| 4057 | (interactive (list last-input-event)) | ||
| 4058 | (save-excursion | ||
| 4059 | (if event (posn-set-point (event-end event))) | ||
| 4060 | (beginning-of-line) | ||
| 4061 | (let* ((var (current-word)) | ||
| 4062 | (value (read-string (format "New value (%s): " var)))) | ||
| 4063 | (gdb-enqueue-input | ||
| 4064 | (list (concat gdb-server-prefix "set variable " var " = " value "\n") | ||
| 4065 | 'ignore))))) | ||
| 4066 | |||
| 4067 | ;; Dont display values of arrays or structures. | ||
| 4068 | ;; These can be expanded using gud-watch. | ||
| 4069 | (defun gdb-stack-list-locals-handler () | ||
| 4070 | (setq gdb-pending-triggers (delq 'gdb-invalidate-locals-1 | ||
| 4071 | gdb-pending-triggers)) | ||
| 4072 | (goto-char (point-min)) | ||
| 4073 | (if (re-search-forward gdb-error-regexp nil t) | ||
| 4074 | (let ((err (match-string 1))) | ||
| 4075 | (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) | ||
| 4076 | (let ((buffer-read-only nil)) | ||
| 4077 | (erase-buffer) | ||
| 4078 | (insert err) | ||
| 4079 | (goto-char (point-min))))) | ||
| 4080 | (let (local locals-list) | ||
| 4081 | (goto-char (point-min)) | ||
| 4082 | (while (re-search-forward gdb-stack-list-locals-regexp nil t) | ||
| 4083 | (let ((local (list (match-string 1) | ||
| 4084 | (match-string 2) | ||
| 4085 | nil))) | ||
| 4086 | (if (looking-at ",value=\\(\".*\"\\).*?}") | ||
| 4087 | (setcar (nthcdr 2 local) (read (match-string 1)))) | ||
| 4088 | (push local locals-list))) | ||
| 4089 | (let ((buf (gdb-get-buffer 'gdb-locals-buffer))) | ||
| 4090 | (and buf (with-current-buffer buf | ||
| 4091 | (let* ((window (get-buffer-window buf 0)) | ||
| 4092 | (start (window-start window)) | ||
| 4093 | (p (if window (window-point window) (point))) | ||
| 4094 | (buffer-read-only nil) (name) (value)) | ||
| 4095 | (erase-buffer) | ||
| 4096 | (dolist (local locals-list) | ||
| 4097 | (setq name (car local)) | ||
| 4098 | (setq value (nth 2 local)) | ||
| 4099 | (if (or (not value) | ||
| 4100 | (string-match "^\\0x" value)) | ||
| 4101 | (add-text-properties 0 (length name) | ||
| 4102 | `(mouse-face highlight | ||
| 4103 | help-echo "mouse-2: create watch expression" | ||
| 4104 | local-map ,gdb-locals-watch-map-1) | ||
| 4105 | name) | ||
| 4106 | (add-text-properties 0 (length value) | ||
| 4107 | `(mouse-face highlight | ||
| 4108 | help-echo "mouse-2: edit value" | ||
| 4109 | local-map ,gdb-edit-locals-map-1) | ||
| 4110 | value)) | ||
| 4111 | (insert | ||
| 4112 | (concat name "\t" (nth 1 local) | ||
| 4113 | "\t" value "\n"))) | ||
| 4114 | (if window | ||
| 4115 | (progn | ||
| 4116 | (set-window-start window start) | ||
| 4117 | (set-window-point window p)) | ||
| 4118 | (goto-char p))))))))) | ||
| 4119 | |||
| 4120 | (defun gdb-get-register-names () | ||
| 4121 | "Create a list of register names." | ||
| 4122 | (goto-char (point-min)) | ||
| 4123 | (while (re-search-forward gdb-data-list-register-names-regexp nil t) | ||
| 4124 | (push (match-string 1) gdb-register-names))) | ||
| 4125 | |||
| 4126 | (provide 'gdb-ui) | ||
| 4127 | |||
| 4128 | ;; arch-tag: e9fb00c5-74ef-469f-a088-37384caae352 | ||
| 4129 | ;;; gdb-ui.el ends here | ||
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 9b8947a616a..5741e4e187a 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el | |||
| @@ -43,8 +43,10 @@ | |||
| 43 | (require 'comint) | 43 | (require 'comint) |
| 44 | 44 | ||
| 45 | (defvar gdb-active-process) | 45 | (defvar gdb-active-process) |
| 46 | (defvar gdb-recording) | ||
| 46 | (defvar gdb-define-alist) | 47 | (defvar gdb-define-alist) |
| 47 | (defvar gdb-macro-info) | 48 | (defvar gdb-macro-info) |
| 49 | (defvar gdb-server-prefix) | ||
| 48 | (defvar gdb-show-changed-values) | 50 | (defvar gdb-show-changed-values) |
| 49 | (defvar gdb-source-window) | 51 | (defvar gdb-source-window) |
| 50 | (defvar gdb-var-list) | 52 | (defvar gdb-var-list) |
| @@ -124,51 +126,77 @@ Used to grey out relevant toolbar icons.") | |||
| 124 | (throw 'info-found nil)))) | 126 | (throw 'info-found nil)))) |
| 125 | nil 0) | 127 | nil 0) |
| 126 | (select-frame (make-frame))) | 128 | (select-frame (make-frame))) |
| 127 | (if (eq gud-minor-mode 'gdbmi) | 129 | (if (memq gud-minor-mode '(gdbmi gdba)) |
| 128 | (info "(emacs)GDB Graphical Interface") | 130 | (info "(emacs)GDB Graphical Interface") |
| 129 | (info "(emacs)Debuggers")))) | 131 | (info "(emacs)Debuggers")))) |
| 130 | 132 | ||
| 131 | (defun gud-tool-bar-item-visible-no-fringe () | 133 | (defun gud-tool-bar-item-visible-no-fringe () |
| 132 | (not (or (eq (buffer-local-value 'major-mode (window-buffer)) 'speedbar-mode) | 134 | (not (or (eq (buffer-local-value 'major-mode (window-buffer)) 'speedbar-mode) |
| 133 | (and (eq gud-minor-mode 'gdbmi) | 135 | (and (memq gud-minor-mode '(gdbmi gdba)) |
| 134 | (> (car (window-fringes)) 0))))) | 136 | (> (car (window-fringes)) 0))))) |
| 135 | 137 | ||
| 136 | (declare-function gdb-gud-context-command "gdb-mi.el") | ||
| 137 | |||
| 138 | (defun gud-stop-subjob () | 138 | (defun gud-stop-subjob () |
| 139 | (interactive) | 139 | (interactive) |
| 140 | (with-current-buffer gud-comint-buffer | 140 | (with-current-buffer gud-comint-buffer |
| 141 | (cond ((string-equal gud-target-name "emacs") | 141 | (if (string-equal gud-target-name "emacs") |
| 142 | (comint-stop-subjob)) | 142 | (comint-stop-subjob) |
| 143 | ((eq gud-minor-mode 'jdb) | 143 | (if (eq gud-minor-mode 'jdb) |
| 144 | (gud-call "suspend")) | 144 | (gud-call "suspend") |
| 145 | ((eq gud-minor-mode 'gdbmi) | 145 | (comint-interrupt-subjob))))) |
| 146 | (gud-call (gdb-gud-context-command "-exec-interrupt"))) | ||
| 147 | (t | ||
| 148 | (comint-interrupt-subjob))))) | ||
| 149 | 146 | ||
| 150 | (easy-mmode-defmap gud-menu-map | 147 | (easy-mmode-defmap gud-menu-map |
| 151 | '(([help] "Info (debugger)" . gud-goto-info) | 148 | '(([help] "Info (debugger)" . gud-goto-info) |
| 149 | ([rfinish] menu-item "Reverse Finish Function" gud-rfinish | ||
| 150 | :enable (not gud-running) | ||
| 151 | :visible (and gdb-recording | ||
| 152 | (eq gud-minor-mode 'gdba))) | ||
| 153 | ([rstepi] menu-item "Reverse Step Instruction" gud-rstepi | ||
| 154 | :enable (not gud-running) | ||
| 155 | :visible (and gdb-recording | ||
| 156 | (eq gud-minor-mode 'gdba))) | ||
| 157 | ([rnexti] menu-item "Reverse Next Instruction" gud-rnexti | ||
| 158 | :enable (not gud-running) | ||
| 159 | :visible (and gdb-recording | ||
| 160 | (eq gud-minor-mode 'gdba))) | ||
| 161 | ([rstep] menu-item "Reverse Step Line" gud-rstep | ||
| 162 | :enable (not gud-running) | ||
| 163 | :visible (and gdb-recording | ||
| 164 | (eq gud-minor-mode 'gdba))) | ||
| 165 | ([rnext] menu-item "Reverse Next Line" gud-rnext | ||
| 166 | :enable (not gud-running) | ||
| 167 | :visible (and gdb-recording | ||
| 168 | (eq gud-minor-mode 'gdba))) | ||
| 169 | ([rcont] menu-item "Reverse Continue" gud-rcont | ||
| 170 | :enable (not gud-running) | ||
| 171 | :visible (and gdb-recording | ||
| 172 | (eq gud-minor-mode 'gdba))) | ||
| 173 | ([recstart] menu-item "Start Recording" gdb-toggle-recording-1 | ||
| 174 | :visible (and (not gdb-recording) | ||
| 175 | (eq gud-minor-mode 'gdba))) | ||
| 176 | ([recstop] menu-item "Stop Recording" gdb-toggle-recording | ||
| 177 | :visible (and gdb-recording | ||
| 178 | (eq gud-minor-mode 'gdba))) | ||
| 152 | ([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode | 179 | ([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode |
| 153 | :enable (and (not emacs-basic-display) | 180 | :enable (and (not emacs-basic-display) |
| 154 | (display-graphic-p) | 181 | (display-graphic-p) |
| 155 | (fboundp 'x-show-tip)) | 182 | (fboundp 'x-show-tip)) |
| 156 | :visible (memq gud-minor-mode | 183 | :visible (memq gud-minor-mode |
| 157 | '(gdbmi dbx sdb xdb pdb)) | 184 | '(gdbmi gdba dbx sdb xdb pdb)) |
| 158 | :button (:toggle . gud-tooltip-mode)) | 185 | :button (:toggle . gud-tooltip-mode)) |
| 159 | ([refresh] "Refresh" . gud-refresh) | 186 | ([refresh] "Refresh" . gud-refresh) |
| 160 | ([run] menu-item "Run" gud-run | 187 | ([run] menu-item "Run" gud-run |
| 161 | :enable (not gud-running) | 188 | :enable (not gud-running) |
| 162 | :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) | 189 | :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) |
| 163 | ([go] menu-item (if gdb-active-process "Continue" "Run") gud-go | 190 | ([go] menu-item (if gdb-active-process "Continue" "Run") gud-go |
| 164 | :visible (and (eq gud-minor-mode 'gdbmi) | 191 | :visible (and (not gud-running) |
| 165 | (gdb-show-run-p))) | 192 | (eq gud-minor-mode 'gdba))) |
| 166 | ([stop] menu-item "Stop" gud-stop-subjob | 193 | ([stop] menu-item "Stop" gud-stop-subjob |
| 167 | :visible (or (not (memq gud-minor-mode '(gdbmi pdb))) | 194 | :visible (or (not (memq gud-minor-mode '(gdba pdb))) |
| 168 | (gdb-show-stop-p))) | 195 | (and gud-running |
| 196 | (eq gud-minor-mode 'gdba)))) | ||
| 169 | ([until] menu-item "Continue to selection" gud-until | 197 | ([until] menu-item "Continue to selection" gud-until |
| 170 | :enable (not gud-running) | 198 | :enable (not gud-running) |
| 171 | :visible (and (memq gud-minor-mode '(gdbmi gdb perldb)) | 199 | :visible (and (memq gud-minor-mode '(gdbmi gdba gdb perldb)) |
| 172 | (gud-tool-bar-item-visible-no-fringe))) | 200 | (gud-tool-bar-item-visible-no-fringe))) |
| 173 | ([remove] menu-item "Remove Breakpoint" gud-remove | 201 | ([remove] menu-item "Remove Breakpoint" gud-remove |
| 174 | :enable (not gud-running) | 202 | :enable (not gud-running) |
| @@ -176,52 +204,50 @@ Used to grey out relevant toolbar icons.") | |||
| 176 | ([tbreak] menu-item "Temporary Breakpoint" gud-tbreak | 204 | ([tbreak] menu-item "Temporary Breakpoint" gud-tbreak |
| 177 | :enable (not gud-running) | 205 | :enable (not gud-running) |
| 178 | :visible (memq gud-minor-mode | 206 | :visible (memq gud-minor-mode |
| 179 | '(gdbmi gdb sdb xdb))) | 207 | '(gdbmi gdba gdb sdb xdb))) |
| 180 | ([break] menu-item "Set Breakpoint" gud-break | 208 | ([break] menu-item "Set Breakpoint" gud-break |
| 181 | :enable (not gud-running) | 209 | :enable (not gud-running) |
| 182 | :visible (gud-tool-bar-item-visible-no-fringe)) | 210 | :visible (gud-tool-bar-item-visible-no-fringe)) |
| 183 | ([up] menu-item "Up Stack" gud-up | 211 | ([up] menu-item "Up Stack" gud-up |
| 184 | :enable (not gud-running) | 212 | :enable (not gud-running) |
| 185 | :visible (memq gud-minor-mode | 213 | :visible (memq gud-minor-mode |
| 186 | '(gdbmi gdb dbx xdb jdb pdb))) | 214 | '(gdbmi gdba gdb dbx xdb jdb pdb))) |
| 187 | ([down] menu-item "Down Stack" gud-down | 215 | ([down] menu-item "Down Stack" gud-down |
| 188 | :enable (not gud-running) | 216 | :enable (not gud-running) |
| 189 | :visible (memq gud-minor-mode | 217 | :visible (memq gud-minor-mode |
| 190 | '(gdbmi gdb dbx xdb jdb pdb))) | 218 | '(gdbmi gdba gdb dbx xdb jdb pdb))) |
| 191 | ([pp] menu-item "Print S-expression" gud-pp | 219 | ([pp] menu-item "Print S-expression" gud-pp |
| 192 | :enable (and (not gud-running) | 220 | :enable (and (not gud-running) |
| 193 | gdb-active-process) | 221 | gdb-active-process) |
| 194 | :visible (and (string-equal | 222 | :visible (and (string-equal |
| 195 | (buffer-local-value | 223 | (buffer-local-value |
| 196 | 'gud-target-name gud-comint-buffer) "emacs") | 224 | 'gud-target-name gud-comint-buffer) "emacs") |
| 197 | (eq gud-minor-mode 'gdbmi))) | 225 | (eq gud-minor-mode 'gdba))) |
| 198 | ([print*] menu-item (if (eq gud-minor-mode 'jdb) | 226 | ([print*] menu-item "Print Dereference" gud-pstar |
| 199 | "Dump object" | ||
| 200 | "Print Dereference") gud-pstar | ||
| 201 | :enable (not gud-running) | 227 | :enable (not gud-running) |
| 202 | :visible (memq gud-minor-mode '(gdbmi gdb jdb))) | 228 | :visible (memq gud-minor-mode '(gdbmi gdba gdb))) |
| 203 | ([print] menu-item "Print Expression" gud-print | 229 | ([print] menu-item "Print Expression" gud-print |
| 204 | :enable (not gud-running)) | 230 | :enable (not gud-running)) |
| 205 | ([watch] menu-item "Watch Expression" gud-watch | 231 | ([watch] menu-item "Watch Expression" gud-watch |
| 206 | :enable (not gud-running) | 232 | :enable (not gud-running) |
| 207 | :visible (eq gud-minor-mode 'gdbmi)) | 233 | :visible (memq gud-minor-mode '(gdbmi gdba))) |
| 208 | ([finish] menu-item "Finish Function" gud-finish | 234 | ([finish] menu-item "Finish Function" gud-finish |
| 209 | :enable (not gud-running) | 235 | :enable (not gud-running) |
| 210 | :visible (memq gud-minor-mode | 236 | :visible (memq gud-minor-mode |
| 211 | '(gdbmi gdb xdb jdb pdb))) | 237 | '(gdbmi gdba gdb xdb jdb pdb))) |
| 212 | ([stepi] menu-item "Step Instruction" gud-stepi | 238 | ([stepi] menu-item "Step Instruction" gud-stepi |
| 213 | :enable (not gud-running) | 239 | :enable (not gud-running) |
| 214 | :visible (memq gud-minor-mode '(gdbmi gdb dbx))) | 240 | :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) |
| 215 | ([nexti] menu-item "Next Instruction" gud-nexti | 241 | ([nexti] menu-item "Next Instruction" gud-nexti |
| 216 | :enable (not gud-running) | 242 | :enable (not gud-running) |
| 217 | :visible (memq gud-minor-mode '(gdbmi gdb dbx))) | 243 | :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) |
| 218 | ([step] menu-item "Step Line" gud-step | 244 | ([step] menu-item "Step Line" gud-step |
| 219 | :enable (not gud-running)) | 245 | :enable (not gud-running)) |
| 220 | ([next] menu-item "Next Line" gud-next | 246 | ([next] menu-item "Next Line" gud-next |
| 221 | :enable (not gud-running)) | 247 | :enable (not gud-running)) |
| 222 | ([cont] menu-item "Continue" gud-cont | 248 | ([cont] menu-item "Continue" gud-cont |
| 223 | :enable (not gud-running) | 249 | :enable (not gud-running) |
| 224 | :visible (not (eq gud-minor-mode 'gdbmi)))) | 250 | :visible (not (eq gud-minor-mode 'gdba)))) |
| 225 | "Menu for `gud-mode'." | 251 | "Menu for `gud-mode'." |
| 226 | :name "Gud") | 252 | :name "Gud") |
| 227 | 253 | ||
| @@ -243,22 +269,21 @@ Used to grey out relevant toolbar icons.") | |||
| 243 | . (,(propertize "next" 'face 'font-lock-doc-face) . gud-next)) | 269 | . (,(propertize "next" 'face 'font-lock-doc-face) . gud-next)) |
| 244 | ([menu-bar until] menu-item | 270 | ([menu-bar until] menu-item |
| 245 | ,(propertize "until" 'face 'font-lock-doc-face) gud-until | 271 | ,(propertize "until" 'face 'font-lock-doc-face) gud-until |
| 246 | :visible (memq gud-minor-mode '(gdbmi gdb perldb))) | 272 | :visible (memq gud-minor-mode '(gdbmi gdba gdb perldb))) |
| 247 | ([menu-bar cont] menu-item | 273 | ([menu-bar cont] menu-item |
| 248 | ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont | 274 | ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont |
| 249 | :visible (not (eq gud-minor-mode 'gdbmi))) | 275 | :visible (not (eq gud-minor-mode 'gdba))) |
| 250 | ([menu-bar run] menu-item | 276 | ([menu-bar run] menu-item |
| 251 | ,(propertize "run" 'face 'font-lock-doc-face) gud-run | 277 | ,(propertize "run" 'face 'font-lock-doc-face) gud-run |
| 252 | :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) | 278 | :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) |
| 253 | ([menu-bar go] menu-item | 279 | ([menu-bar go] menu-item |
| 254 | ,(propertize " go " 'face 'font-lock-doc-face) gud-go | 280 | ,(propertize " go " 'face 'font-lock-doc-face) gud-go |
| 255 | :visible (and (eq gud-minor-mode 'gdbmi) | 281 | :visible (and (not gud-running) |
| 256 | (gdb-show-run-p))) | 282 | (eq gud-minor-mode 'gdba))) |
| 257 | ([menu-bar stop] menu-item | 283 | ([menu-bar stop] menu-item |
| 258 | ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob | 284 | ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob |
| 259 | :visible (or (and (eq gud-minor-mode 'gdbmi) | 285 | :visible (and gud-running |
| 260 | (gdb-show-stop-p)) | 286 | (eq gud-minor-mode 'gdba))) |
| 261 | (not (eq gud-minor-mode 'gdbmi)))) | ||
| 262 | ([menu-bar print] | 287 | ([menu-bar print] |
| 263 | . (,(propertize "print" 'face 'font-lock-doc-face) . gud-print)) | 288 | . (,(propertize "print" 'face 'font-lock-doc-face) . gud-print)) |
| 264 | ([menu-bar tools] . undefined) | 289 | ([menu-bar tools] . undefined) |
| @@ -297,6 +322,14 @@ Used to grey out relevant toolbar icons.") | |||
| 297 | (gud-stepi . "gud/stepi") | 322 | (gud-stepi . "gud/stepi") |
| 298 | (gud-up . "gud/up") | 323 | (gud-up . "gud/up") |
| 299 | (gud-down . "gud/down") | 324 | (gud-down . "gud/down") |
| 325 | (gdb-toggle-recording-1 . "gud/recstart") | ||
| 326 | (gdb-toggle-recording . "gud/recstop") | ||
| 327 | (gud-rcont . "gud/rcont") | ||
| 328 | (gud-rnext . "gud/rnext") | ||
| 329 | (gud-rstep . "gud/rstep") | ||
| 330 | (gud-rfinish . "gud/rfinish") | ||
| 331 | (gud-rnexti . "gud/rnexti") | ||
| 332 | (gud-rstepi . "gud/rstepi") | ||
| 300 | (gud-goto-info . "info")) | 333 | (gud-goto-info . "info")) |
| 301 | map) | 334 | map) |
| 302 | (tool-bar-local-item-from-menu | 335 | (tool-bar-local-item-from-menu |
| @@ -321,7 +354,7 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files." | |||
| 321 | (setq directories (cdr directories))) | 354 | (setq directories (cdr directories))) |
| 322 | result))) | 355 | result))) |
| 323 | 356 | ||
| 324 | (declare-function gdb-create-define-alist "gdb-mi" ()) | 357 | (declare-function gdb-create-define-alist "gdb-ui" ()) |
| 325 | 358 | ||
| 326 | (defun gud-find-file (file) | 359 | (defun gud-find-file (file) |
| 327 | ;; Don't get confused by double slashes in the name that comes from GDB. | 360 | ;; Don't get confused by double slashes in the name that comes from GDB. |
| @@ -337,7 +370,7 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files." | |||
| 337 | (set (make-local-variable 'gud-minor-mode) minor-mode) | 370 | (set (make-local-variable 'gud-minor-mode) minor-mode) |
| 338 | (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) | 371 | (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) |
| 339 | (when (and gud-tooltip-mode | 372 | (when (and gud-tooltip-mode |
| 340 | (eq gud-minor-mode 'gdbmi)) | 373 | (memq gud-minor-mode '(gdbmi gdba))) |
| 341 | (make-local-variable 'gdb-define-alist) | 374 | (make-local-variable 'gdb-define-alist) |
| 342 | (unless gdb-define-alist (gdb-create-define-alist)) | 375 | (unless gdb-define-alist (gdb-create-define-alist)) |
| 343 | (add-hook 'after-save-hook 'gdb-create-define-alist nil t)) | 376 | (add-hook 'after-save-hook 'gdb-create-define-alist nil t)) |
| @@ -466,21 +499,21 @@ The value t means that there is no stack, and we are in display-file mode.") | |||
| 466 | 499 | ||
| 467 | (defvar gud-speedbar-menu-items | 500 | (defvar gud-speedbar-menu-items |
| 468 | '(["Jump to stack frame" speedbar-edit-line | 501 | '(["Jump to stack frame" speedbar-edit-line |
| 469 | :visible (not (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | 502 | :visible (not (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) |
| 470 | 'gdbmi))] | 503 | '(gdbmi gdba)))] |
| 471 | ["Edit value" speedbar-edit-line | 504 | ["Edit value" speedbar-edit-line |
| 472 | :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | 505 | :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) |
| 473 | 'gdbmi)] | 506 | '(gdbmi gdba))] |
| 474 | ["Delete expression" gdb-var-delete | 507 | ["Delete expression" gdb-var-delete |
| 475 | :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | 508 | :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) |
| 476 | 'gdbmi)] | 509 | '(gdbmi gdba))] |
| 477 | ["Auto raise frame" gdb-speedbar-auto-raise | 510 | ["Auto raise frame" gdb-speedbar-auto-raise |
| 478 | :style toggle :selected gdb-speedbar-auto-raise | 511 | :style toggle :selected gdb-speedbar-auto-raise |
| 479 | :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | 512 | :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) |
| 480 | 'gdbmi)] | 513 | '(gdbmi gdba))] |
| 481 | ("Output Format" | 514 | ("Output Format" |
| 482 | :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | 515 | :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) |
| 483 | 'gdbmi) | 516 | '(gdbmi gdba)) |
| 484 | ["Binary" (gdb-var-set-format "binary") t] | 517 | ["Binary" (gdb-var-set-format "binary") t] |
| 485 | ["Natural" (gdb-var-set-format "natural") t] | 518 | ["Natural" (gdb-var-set-format "natural") t] |
| 486 | ["Hexadecimal" (gdb-var-set-format "hexadecimal") t])) | 519 | ["Hexadecimal" (gdb-var-set-format "hexadecimal") t])) |
| @@ -509,7 +542,7 @@ required by the caller." | |||
| 509 | (start (window-start window)) | 542 | (start (window-start window)) |
| 510 | (p (window-point window))) | 543 | (p (window-point window))) |
| 511 | (cond | 544 | (cond |
| 512 | ((eq minor-mode 'gdbmi) | 545 | ((memq minor-mode '(gdbmi gdba)) |
| 513 | (erase-buffer) | 546 | (erase-buffer) |
| 514 | (insert "Watch Expressions:\n") | 547 | (insert "Watch Expressions:\n") |
| 515 | (let ((var-list gdb-var-list) parent) | 548 | (let ((var-list gdb-var-list) parent) |
| @@ -599,7 +632,7 @@ required by the caller." | |||
| 599 | (car frame) | 632 | (car frame) |
| 600 | 'speedbar-file-face | 633 | 'speedbar-file-face |
| 601 | 'speedbar-highlight-face | 634 | 'speedbar-highlight-face |
| 602 | (cond ((memq minor-mode '(gdbmi gdb)) | 635 | (cond ((memq minor-mode '(gdbmi gdba gdb)) |
| 603 | 'gud-gdb-goto-stackframe) | 636 | 'gud-gdb-goto-stackframe) |
| 604 | (t (error "Should never be here"))) | 637 | (t (error "Should never be here"))) |
| 605 | frame t)))) | 638 | frame t)))) |
| @@ -656,6 +689,8 @@ The option \"--fullname\" must be included in this value." | |||
| 656 | ;; Set the accumulator to the remaining text. | 689 | ;; Set the accumulator to the remaining text. |
| 657 | gud-marker-acc (substring gud-marker-acc (match-end 0)))) | 690 | gud-marker-acc (substring gud-marker-acc (match-end 0)))) |
| 658 | 691 | ||
| 692 | ;; Check for annotations and change gud-minor-mode to 'gdba if | ||
| 693 | ;; they are found. | ||
| 659 | (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) | 694 | (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) |
| 660 | (let ((match (match-string 1 gud-marker-acc))) | 695 | (let ((match (match-string 1 gud-marker-acc))) |
| 661 | 696 | ||
| @@ -719,10 +754,10 @@ The option \"--fullname\" must be included in this value." | |||
| 719 | (defvar gud-filter-pending-text nil | 754 | (defvar gud-filter-pending-text nil |
| 720 | "Non-nil means this is text that has been saved for later in `gud-filter'.") | 755 | "Non-nil means this is text that has been saved for later in `gud-filter'.") |
| 721 | 756 | ||
| 722 | ;; If in gdb mode, gdb-mi is loaded. | 757 | ;; If in gdba mode, gdb-ui is loaded. |
| 723 | (declare-function gdb-restore-windows "gdb-mi" ()) | 758 | (declare-function gdb-restore-windows "gdb-ui" ()) |
| 724 | 759 | ||
| 725 | ;; The old gdb command (text command mode). The new one is in gdb-mi.el. | 760 | ;; The old gdb command (text command mode). The new one is in gdb-ui.el. |
| 726 | ;;;###autoload | 761 | ;;;###autoload |
| 727 | (defun gud-gdb (command-line) | 762 | (defun gud-gdb (command-line) |
| 728 | "Run gdb on program FILE in buffer *gud-FILE*. | 763 | "Run gdb on program FILE in buffer *gud-FILE*. |
| @@ -733,10 +768,10 @@ directory and source-file directory for your debugger." | |||
| 733 | (when (and gud-comint-buffer | 768 | (when (and gud-comint-buffer |
| 734 | (buffer-name gud-comint-buffer) | 769 | (buffer-name gud-comint-buffer) |
| 735 | (get-buffer-process gud-comint-buffer) | 770 | (get-buffer-process gud-comint-buffer) |
| 736 | (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdbmi))) | 771 | (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) |
| 737 | (gdb-restore-windows) | 772 | (gdb-restore-windows) |
| 738 | (error | 773 | (error |
| 739 | "Multiple debugging requires restarting in text command mode")) | 774 | "Multiple debugging requires restarting in text command mode")) |
| 740 | 775 | ||
| 741 | (gud-common-init command-line nil 'gud-gdb-marker-filter) | 776 | (gud-common-init command-line nil 'gud-gdb-marker-filter) |
| 742 | (set (make-local-variable 'gud-minor-mode) 'gdb) | 777 | (set (make-local-variable 'gud-minor-mode) 'gdb) |
| @@ -2607,7 +2642,7 @@ It is saved for when this flag is not set.") | |||
| 2607 | (defvar gud-overlay-arrow-position nil) | 2642 | (defvar gud-overlay-arrow-position nil) |
| 2608 | (add-to-list 'overlay-arrow-variable-list 'gud-overlay-arrow-position) | 2643 | (add-to-list 'overlay-arrow-variable-list 'gud-overlay-arrow-position) |
| 2609 | 2644 | ||
| 2610 | (declare-function gdb-reset "gdb-mi" ()) | 2645 | (declare-function gdb-reset "gdb-ui" ()) |
| 2611 | 2646 | ||
| 2612 | (defun gud-sentinel (proc msg) | 2647 | (defun gud-sentinel (proc msg) |
| 2613 | (cond ((null (buffer-name (process-buffer proc))) | 2648 | (cond ((null (buffer-name (process-buffer proc))) |
| @@ -2619,14 +2654,14 @@ It is saved for when this flag is not set.") | |||
| 2619 | (string-equal speedbar-initial-expansion-list-name "GUD")) | 2654 | (string-equal speedbar-initial-expansion-list-name "GUD")) |
| 2620 | (speedbar-change-initial-expansion-list | 2655 | (speedbar-change-initial-expansion-list |
| 2621 | speedbar-previously-used-expansion-list-name)) | 2656 | speedbar-previously-used-expansion-list-name)) |
| 2622 | (if (eq gud-minor-mode-type 'gdbmi) | 2657 | (if (memq gud-minor-mode-type '(gdbmi gdba)) |
| 2623 | (gdb-reset) | 2658 | (gdb-reset) |
| 2624 | (gud-reset))) | 2659 | (gud-reset))) |
| 2625 | ((memq (process-status proc) '(signal exit)) | 2660 | ((memq (process-status proc) '(signal exit)) |
| 2626 | ;; Stop displaying an arrow in a source file. | 2661 | ;; Stop displaying an arrow in a source file. |
| 2627 | (setq gud-overlay-arrow-position nil) | 2662 | (setq gud-overlay-arrow-position nil) |
| 2628 | (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | 2663 | (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) |
| 2629 | 'gdbmi) | 2664 | '(gdba gdbmi)) |
| 2630 | (gdb-reset) | 2665 | (gdb-reset) |
| 2631 | (gud-reset)) | 2666 | (gud-reset)) |
| 2632 | (let* ((obuf (current-buffer))) | 2667 | (let* ((obuf (current-buffer))) |
| @@ -2657,9 +2692,7 @@ It is saved for when this flag is not set.") | |||
| 2657 | (defun gud-kill-buffer-hook () | 2692 | (defun gud-kill-buffer-hook () |
| 2658 | (setq gud-minor-mode-type gud-minor-mode) | 2693 | (setq gud-minor-mode-type gud-minor-mode) |
| 2659 | (condition-case nil | 2694 | (condition-case nil |
| 2660 | (progn | 2695 | (kill-process (get-buffer-process (current-buffer))) |
| 2661 | (kill-process (get-buffer-process (current-buffer))) | ||
| 2662 | (delete-process (get-process "gdb-inferior"))) | ||
| 2663 | (error nil))) | 2696 | (error nil))) |
| 2664 | 2697 | ||
| 2665 | (defun gud-reset () | 2698 | (defun gud-reset () |
| @@ -2682,8 +2715,8 @@ Obeying it means displaying in another window the specified file and line." | |||
| 2682 | 2715 | ||
| 2683 | (declare-function global-hl-line-highlight "hl-line" ()) | 2716 | (declare-function global-hl-line-highlight "hl-line" ()) |
| 2684 | (declare-function hl-line-highlight "hl-line" ()) | 2717 | (declare-function hl-line-highlight "hl-line" ()) |
| 2685 | (declare-function gdb-display-source-buffer "gdb-mi" (buffer)) | 2718 | (declare-function gdb-display-source-buffer "gdb-ui" (buffer)) |
| 2686 | (declare-function gdb-display-buffer "gdb-mi" (buf dedicated &optional size)) | 2719 | (declare-function gdb-display-buffer "gdb-ui" (buf dedicated &optional size)) |
| 2687 | 2720 | ||
| 2688 | ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen | 2721 | ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen |
| 2689 | ;; and that its line LINE is visible. | 2722 | ;; and that its line LINE is visible. |
| @@ -2699,7 +2732,7 @@ Obeying it means displaying in another window the specified file and line." | |||
| 2699 | (gud-find-file true-file))) | 2732 | (gud-find-file true-file))) |
| 2700 | (window (and buffer | 2733 | (window (and buffer |
| 2701 | (or (get-buffer-window buffer) | 2734 | (or (get-buffer-window buffer) |
| 2702 | (if (eq gud-minor-mode 'gdbmi) | 2735 | (if (memq gud-minor-mode '(gdbmi gdba)) |
| 2703 | (or (if (get-buffer-window buffer 'visible) | 2736 | (or (if (get-buffer-window buffer 'visible) |
| 2704 | (display-buffer buffer nil 'visible)) | 2737 | (display-buffer buffer nil 'visible)) |
| 2705 | (unless (gdb-display-source-buffer buffer) | 2738 | (unless (gdb-display-source-buffer buffer) |
| @@ -2736,7 +2769,7 @@ Obeying it means displaying in another window the specified file and line." | |||
| 2736 | (goto-char pos)))) | 2769 | (goto-char pos)))) |
| 2737 | (when window | 2770 | (when window |
| 2738 | (set-window-point window gud-overlay-arrow-position) | 2771 | (set-window-point window gud-overlay-arrow-position) |
| 2739 | (if (eq gud-minor-mode 'gdbmi) | 2772 | (if (memq gud-minor-mode '(gdbmi gdba)) |
| 2740 | (setq gdb-source-window window))))))) | 2773 | (setq gdb-source-window window))))))) |
| 2741 | 2774 | ||
| 2742 | ;; The gud-call function must do the right thing whether its invoking | 2775 | ;; The gud-call function must do the right thing whether its invoking |
| @@ -2842,7 +2875,7 @@ Obeying it means displaying in another window the specified file and line." | |||
| 2842 | (forward-line 0)) | 2875 | (forward-line 0)) |
| 2843 | (if (looking-at comint-prompt-regexp) | 2876 | (if (looking-at comint-prompt-regexp) |
| 2844 | (set-marker gud-delete-prompt-marker (point))) | 2877 | (set-marker gud-delete-prompt-marker (point))) |
| 2845 | (if (eq gud-minor-mode 'gdbmi) | 2878 | (if (memq gud-minor-mode '(gdbmi gdba)) |
| 2846 | (apply comint-input-sender (list proc command)) | 2879 | (apply comint-input-sender (list proc command)) |
| 2847 | (process-send-string proc (concat command "\n")))))))) | 2880 | (process-send-string proc (concat command "\n")))))))) |
| 2848 | 2881 | ||
| @@ -3268,14 +3301,14 @@ Treats actions as defuns." | |||
| 3268 | (gud-tooltip-activate-mouse-motions-if-enabled) | 3301 | (gud-tooltip-activate-mouse-motions-if-enabled) |
| 3269 | (if (and gud-comint-buffer | 3302 | (if (and gud-comint-buffer |
| 3270 | (buffer-name gud-comint-buffer); gud-comint-buffer might be killed | 3303 | (buffer-name gud-comint-buffer); gud-comint-buffer might be killed |
| 3271 | (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) | 3304 | (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) |
| 3272 | 'gdbmi)) | 3305 | '(gdbmi gdba))) |
| 3273 | (if gud-tooltip-mode | 3306 | (if gud-tooltip-mode |
| 3274 | (progn | 3307 | (progn |
| 3275 | (dolist (buffer (buffer-list)) | 3308 | (dolist (buffer (buffer-list)) |
| 3276 | (unless (eq buffer gud-comint-buffer) | 3309 | (unless (eq buffer gud-comint-buffer) |
| 3277 | (with-current-buffer buffer | 3310 | (with-current-buffer buffer |
| 3278 | (when (and (eq gud-minor-mode 'gdbmi) | 3311 | (when (and (memq gud-minor-mode '(gdbmi gdba)) |
| 3279 | (not (string-match "\\`\\*.+\\*\\'" | 3312 | (not (string-match "\\`\\*.+\\*\\'" |
| 3280 | (buffer-name)))) | 3313 | (buffer-name)))) |
| 3281 | (make-local-variable 'gdb-define-alist) | 3314 | (make-local-variable 'gdb-define-alist) |
| @@ -3400,8 +3433,8 @@ With arg, dereference expr if ARG is positive, otherwise do not derereference." | |||
| 3400 | ; Larger arrays (say 400 elements) are displayed in | 3433 | ; Larger arrays (say 400 elements) are displayed in |
| 3401 | ; the tooltip incompletely and spill over into the gud buffer. | 3434 | ; the tooltip incompletely and spill over into the gud buffer. |
| 3402 | ; Switching the process-filter creates timing problems and | 3435 | ; Switching the process-filter creates timing problems and |
| 3403 | ; it may be difficult to do better. Using GDB/MI as in | 3436 | ; it may be difficult to do better. Using annotations as in |
| 3404 | ; gdb-mi.el gets round this problem. | 3437 | ; gdb-ui.el gets round this problem. |
| 3405 | (defun gud-tooltip-process-output (process output) | 3438 | (defun gud-tooltip-process-output (process output) |
| 3406 | "Process debugger output and show it in a tooltip window." | 3439 | "Process debugger output and show it in a tooltip window." |
| 3407 | (set-process-filter process gud-tooltip-original-filter) | 3440 | (set-process-filter process gud-tooltip-original-filter) |
| @@ -3411,12 +3444,12 @@ With arg, dereference expr if ARG is positive, otherwise do not derereference." | |||
| 3411 | (defun gud-tooltip-print-command (expr) | 3444 | (defun gud-tooltip-print-command (expr) |
| 3412 | "Return a suitable command to print the expression EXPR." | 3445 | "Return a suitable command to print the expression EXPR." |
| 3413 | (case gud-minor-mode | 3446 | (case gud-minor-mode |
| 3414 | (gdbmi (concat "-data-evaluate-expression " expr)) | 3447 | (gdba (concat "server print " expr)) |
| 3415 | (dbx (concat "print " expr)) | 3448 | ((dbx gdbmi) (concat "print " expr)) |
| 3416 | ((xdb pdb) (concat "p " expr)) | 3449 | ((xdb pdb) (concat "p " expr)) |
| 3417 | (sdb (concat expr "/")))) | 3450 | (sdb (concat expr "/")))) |
| 3418 | 3451 | ||
| 3419 | (declare-function gdb-input "gdb-mi" (item)) | 3452 | (declare-function gdb-enqueue-input "gdb-ui" (item)) |
| 3420 | (declare-function tooltip-expr-to-print "tooltip" (event)) | 3453 | (declare-function tooltip-expr-to-print "tooltip" (event)) |
| 3421 | (declare-function tooltip-event-buffer "tooltip" (event)) | 3454 | (declare-function tooltip-event-buffer "tooltip" (event)) |
| 3422 | 3455 | ||
| @@ -3436,12 +3469,12 @@ This function must return nil if it doesn't handle EVENT." | |||
| 3436 | (buffer-name gud-comint-buffer); might be killed | 3469 | (buffer-name gud-comint-buffer); might be killed |
| 3437 | (setq process (get-buffer-process gud-comint-buffer)) | 3470 | (setq process (get-buffer-process gud-comint-buffer)) |
| 3438 | (posn-point (event-end event)) | 3471 | (posn-point (event-end event)) |
| 3439 | (or (and (eq gud-minor-mode 'gdbmi) (not gdb-active-process)) | 3472 | (or (and (eq gud-minor-mode 'gdba) (not gdb-active-process)) |
| 3440 | (progn (setq gud-tooltip-event event) | 3473 | (progn (setq gud-tooltip-event event) |
| 3441 | (eval (cons 'and gud-tooltip-display))))) | 3474 | (eval (cons 'and gud-tooltip-display))))) |
| 3442 | (let ((expr (tooltip-expr-to-print event))) | 3475 | (let ((expr (tooltip-expr-to-print event))) |
| 3443 | (when expr | 3476 | (when expr |
| 3444 | (if (and (eq gud-minor-mode 'gdbmi) | 3477 | (if (and (eq gud-minor-mode 'gdba) |
| 3445 | (not gdb-active-process)) | 3478 | (not gdb-active-process)) |
| 3446 | (progn | 3479 | (progn |
| 3447 | (with-current-buffer (tooltip-event-buffer event) | 3480 | (with-current-buffer (tooltip-event-buffer event) |
| @@ -3459,13 +3492,13 @@ This function must return nil if it doesn't handle EVENT." | |||
| 3459 | (message-box "Using GUD tooltips in this mode is unsafe\n\ | 3492 | (message-box "Using GUD tooltips in this mode is unsafe\n\ |
| 3460 | so they have been disabled.")) | 3493 | so they have been disabled.")) |
| 3461 | (unless (null cmd) ; CMD can be nil if unknown debugger | 3494 | (unless (null cmd) ; CMD can be nil if unknown debugger |
| 3462 | (if (eq gud-minor-mode 'gdbmi) | 3495 | (if (memq gud-minor-mode '(gdba gdbmi)) |
| 3463 | (if gdb-macro-info | 3496 | (if gdb-macro-info |
| 3464 | (gdb-input | 3497 | (gdb-enqueue-input |
| 3465 | (list (concat | 3498 | (list (concat |
| 3466 | "server macro expand " expr "\n") | 3499 | gdb-server-prefix "macro expand " expr "\n") |
| 3467 | `(lambda () (gdb-tooltip-print-1 ,expr)))) | 3500 | `(lambda () (gdb-tooltip-print-1 ,expr)))) |
| 3468 | (gdb-input | 3501 | (gdb-enqueue-input |
| 3469 | (list (concat cmd "\n") | 3502 | (list (concat cmd "\n") |
| 3470 | `(lambda () (gdb-tooltip-print ,expr))))) | 3503 | `(lambda () (gdb-tooltip-print ,expr))))) |
| 3471 | (setq gud-tooltip-original-filter (process-filter process)) | 3504 | (setq gud-tooltip-original-filter (process-filter process)) |