Merge from emacs-24; up to 2012-12-30T19:34:25Z!jan.h.d@swipnet.se
[bpt/emacs.git] / lisp / progmodes / gdb-mi.el
1 ;;; gdb-mi.el --- User Interface for running GDB -*- lexical-binding: t -*-
2
3 ;; Copyright (C) 2007-2013 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 Nick Roberts following the general design
29 ;; used in gdb-ui.el for Emacs 22.1 - 23.1. It was further 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 runs gdb with
47 ;; GDB/MI (-interp=mi) and access CLI using "-interpreter-exec console
48 ;; cli-command". This code replaces gdb-ui.el and uses MI tokens instead
49 ;; of queues. Eventually MI should be asynchronous.
50
51 ;; Windows Platforms:
52
53 ;; If you are using Emacs and GDB on Windows you will need to flush the buffer
54 ;; explicitly in your program if you want timely display of I/O in Emacs.
55 ;; Alternatively you can make the output stream unbuffered, for example, by
56 ;; using a macro:
57
58 ;; #ifdef UNBUFFERED
59 ;; setvbuf (stdout, (char *) NULL, _IONBF, 0);
60 ;; #endif
61
62 ;; and compiling with -DUNBUFFERED while debugging.
63
64 ;; If you are using Cygwin GDB and find that the source is not being displayed
65 ;; in Emacs when you step through it, possible solutions are to:
66
67 ;; 1) Use Cygwin X Windows and Cygwin Emacs.
68 ;; (Since 22.1 Emacs builds under Cygwin.)
69 ;; 2) Use MinGW GDB instead.
70 ;; 3) Use cygwin-mount.el
71
72 ;;; Mac OSX:
73
74 ;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made
75 ;; some changes to the version that they include as part of Mac OSX.
76 ;; This requires GDB version 7.0 or later (estimated release date Aug 2009)
77 ;; as earlier versions do not compile on Mac OSX.
78
79 ;;; Known Bugs:
80
81 ;; 1) Stack buffer doesn't parse MI output if you stop in a routine without
82 ;; line information, e.g., a routine in libc (just a TODO item).
83
84 ;; TODO:
85 ;; 2) Watch windows to work with threads.
86 ;; 3) Use treebuffer.el instead of the speedbar for watch-expressions?
87 ;; 4) Mark breakpoint locations on scroll-bar of source buffer?
88
89 ;;; Code:
90
91 (require 'gud)
92 (require 'json)
93 (require 'bindat)
94 (require 'cl-lib)
95
96 (declare-function speedbar-change-initial-expansion-list
97 "speedbar" (new-default))
98 (declare-function speedbar-timer-fn "speedbar" ())
99 (declare-function speedbar-line-text "speedbar" (&optional p))
100 (declare-function speedbar-change-expand-button-char "speedbar" (char))
101 (declare-function speedbar-delete-subblock "speedbar" (indent))
102 (declare-function speedbar-center-buffer-smartly "speedbar" ())
103
104 (defvar tool-bar-map)
105 (defvar speedbar-initial-expansion-list-name)
106 (defvar speedbar-frame)
107
108 (defvar gdb-memory-address "main")
109 (defvar gdb-memory-last-address nil
110 "Last successfully accessed memory address.")
111 (defvar gdb-memory-next-page nil
112 "Address of next memory page for program memory buffer.")
113 (defvar gdb-memory-prev-page nil
114 "Address of previous memory page for program memory buffer.")
115
116 (defvar gdb-thread-number nil
117 "Main current thread.
118
119 Invalidation triggers use this variable to query GDB for
120 information on the specified thread by wrapping GDB/MI commands
121 in `gdb-current-context-command'.
122
123 This variable may be updated implicitly by GDB via `gdb-stopped'
124 or explicitly by `gdb-select-thread'.
125
126 Only `gdb-setq-thread-number' should be used to change this
127 value.")
128
129 (defvar gdb-frame-number nil
130 "Selected frame level for main current thread.
131
132 Updated according to the following rules:
133
134 When a thread is selected or current thread stops, set to \"0\".
135
136 When current thread goes running (and possibly exits eventually),
137 set to nil.
138
139 May be manually changed by user with `gdb-select-frame'.")
140
141 (defvar gdb-frame-address nil "Identity of frame for watch expression.")
142
143 ;; Used to show overlay arrow in source buffer. All set in
144 ;; gdb-get-main-selected-frame. Disassembly buffer should not use
145 ;; these but rely on buffer-local thread information instead.
146 (defvar gdb-selected-frame nil
147 "Name of selected function for main current thread.")
148 (defvar gdb-selected-file nil
149 "Name of selected file for main current thread.")
150 (defvar gdb-selected-line nil
151 "Number of selected line for main current thread.")
152
153 (defvar gdb-threads-list nil
154 "Associative list of threads provided by \"-thread-info\" MI command.
155
156 Keys are thread numbers (in strings) and values are structures as
157 returned from -thread-info by `gdb-json-partial-output'. Updated in
158 `gdb-thread-list-handler-custom'.")
159
160 (defvar gdb-running-threads-count nil
161 "Number of currently running threads.
162
163 If nil, no information is available.
164
165 Updated in `gdb-thread-list-handler-custom'.")
166
167 (defvar gdb-stopped-threads-count nil
168 "Number of currently stopped threads.
169
170 See also `gdb-running-threads-count'.")
171
172 (defvar gdb-breakpoints-list nil
173 "Associative list of breakpoints provided by \"-break-list\" MI command.
174
175 Keys are breakpoint numbers (in string) and values are structures
176 as returned from \"-break-list\" by `gdb-json-partial-output'
177 \(\"body\" field is used). Updated in
178 `gdb-breakpoints-list-handler-custom'.")
179
180 (defvar gdb-current-language nil)
181 (defvar gdb-var-list nil
182 "List of variables in watch window.
183 Each element has the form
184 (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP)
185 where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame
186 address for root variables.")
187 (defvar gdb-main-file nil "Source file from which program execution begins.")
188
189 ;; Overlay arrow markers
190 (defvar gdb-stack-position nil)
191 (defvar gdb-thread-position nil)
192 (defvar gdb-disassembly-position nil)
193
194 (defvar gdb-location-alist nil
195 "Alist of breakpoint numbers and full filenames.
196 Only used for files that Emacs can't find.")
197 (defvar gdb-active-process nil
198 "GUD tooltips display variable values when t, and macro definitions otherwise.")
199 (defvar gdb-error "Non-nil when GDB is reporting an error.")
200 (defvar gdb-macro-info nil
201 "Non-nil if GDB knows that the inferior includes preprocessor macro info.")
202 (defvar gdb-register-names nil "List of register names.")
203 (defvar gdb-changed-registers nil
204 "List of changed register numbers (strings).")
205 (defvar gdb-buffer-fringe-width nil)
206 (defvar gdb-last-command nil)
207 (defvar gdb-prompt-name nil)
208 (defvar gdb-token-number 0)
209 (defvar gdb-handler-list '()
210 "List of gdb-handler keeping track of all pending GDB commands.")
211 (defvar gdb-source-file-list nil
212 "List of source files for the current executable.")
213 (defvar gdb-first-done-or-error t)
214 (defvar gdb-source-window nil)
215 (defvar gdb-inferior-status nil)
216 (defvar gdb-continuation nil)
217 (defvar gdb-supports-non-stop nil)
218 (defvar gdb-filter-output nil
219 "Message to be shown in GUD console.
220
221 This variable is updated in `gdb-done-or-error' and returned by
222 `gud-gdbmi-marker-filter'.")
223
224 (defvar gdb-non-stop nil
225 "Indicates whether current GDB session is using non-stop mode.
226
227 It is initialized to `gdb-non-stop-setting' at the beginning of
228 every GDB session.")
229
230 (defvar-local gdb-buffer-type nil
231 "One of the symbols bound in `gdb-buffer-rules'.")
232
233 (defvar gdb-output-sink 'nil
234 "The disposition of the output of the current gdb command.
235 Possible values are these symbols:
236
237 `user' -- gdb output should be copied to the GUD buffer
238 for the user to see.
239
240 `emacs' -- output should be collected in the partial-output-buffer
241 for subsequent processing by a command. This is the
242 disposition of output generated by commands that
243 gdb mode sends to gdb on its own behalf.")
244
245 (defcustom gdb-discard-unordered-replies t
246 "Non-nil means discard any out-of-order GDB replies.
247 This protects against lost GDB replies, assuming that GDB always
248 replies in the same order as Emacs sends commands. When receiving a
249 reply with a given token-number, assume any pending messages with a
250 lower token-number are out-of-order."
251 :type 'boolean
252 :group 'gud
253 :version "24.4")
254
255 (cl-defstruct gdb-handler
256 "Data required to handle the reply of a command sent to GDB."
257 ;; Prefix of the command sent to GDB. The GDB reply for this command
258 ;; will be prefixed with this same TOKEN-NUMBER
259 (token-number nil :read-only t)
260 ;; Callback to invoke when the reply is received from GDB
261 (function nil :read-only t)
262 ;; PENDING-TRIGGER is used to prevent congestion: Emacs won't send
263 ;; two requests with the same PENDING-TRIGGER until a reply is received
264 ;; for the first one."
265 (pending-trigger nil))
266
267 (defun gdb-add-handler (token-number handler-function &optional pending-trigger)
268 "Insert a new GDB command handler in `gdb-handler-list'.
269 Handlers are used to keep track of the commands sent to GDB
270 and to handle the replies received.
271 Upon reception of a reply prefixed with TOKEN-NUMBER,
272 invoke the callback HANDLER-FUNCTION.
273 If PENDING-TRIGGER is specified, no new GDB commands will be
274 sent with this same PENDING-TRIGGER until a reply is received
275 for this handler."
276
277 (push (make-gdb-handler :token-number token-number
278 :function handler-function
279 :pending-trigger pending-trigger)
280 gdb-handler-list))
281
282 (defun gdb-delete-handler (token-number)
283 "Remove the handler TOKEN-NUMBER from `gdb-handler-list'.
284 Additionally, if `gdb-discard-unordered-replies' is non-nil,
285 discard all handlers having a token number less than TOKEN-NUMBER."
286 (if gdb-discard-unordered-replies
287
288 (setq gdb-handler-list
289 (cl-delete-if
290 (lambda (handler)
291 "Discard any HANDLER with a token number `<=' than TOKEN-NUMBER."
292 (when (< (gdb-handler-token-number handler) token-number)
293 (message (format
294 "WARNING! Discarding GDB handler with token #%d\n"
295 (gdb-handler-token-number handler))))
296 (<= (gdb-handler-token-number handler) token-number))
297 gdb-handler-list))
298
299 (setq gdb-handler-list
300 (cl-delete-if
301 (lambda (handler)
302 "Discard any HANDLER with a token number `eq' to TOKEN-NUMBER."
303 (eq (gdb-handler-token-number handler) token-number))
304 gdb-handler-list))))
305
306 (defun gdb-get-handler-function (token-number)
307 "Return the function callback registered with the handler TOKEN-NUMBER."
308 (gdb-handler-function
309 (cl-find-if (lambda (handler) (eq (gdb-handler-token-number handler)
310 token-number))
311 gdb-handler-list)))
312
313
314 (defun gdb-pending-handler-p (pending-trigger)
315 "Return non-nil if a command handler is pending with trigger PENDING-TRIGGER."
316 (cl-find-if (lambda (handler) (eq (gdb-handler-pending-trigger handler)
317 pending-trigger))
318 gdb-handler-list))
319
320
321 (defun gdb-handle-reply (token-number)
322 "Handle the GDB reply TOKEN-NUMBER.
323 This invokes the handler registered with this token number
324 in `gdb-handler-list' and clears all pending handlers invalidated
325 by the reception of this reply."
326 (let ((handler-function (gdb-get-handler-function token-number)))
327 (when handler-function
328 (funcall handler-function)
329 (gdb-delete-handler token-number))))
330
331 (defun gdb-remove-all-pending-triggers ()
332 "Remove all pending triggers from gdb-handler-list.
333 The handlers are left in gdb-handler-list so that replies received
334 from GDB could still be handled. However, removing the pending triggers
335 allows Emacs to send new commands even if replies of previous commands
336 were not yet received."
337 (dolist (handler gdb-handler-list)
338 (setf (gdb-handler-pending-trigger handler) nil)))
339
340 (defmacro gdb-wait-for-pending (&rest body)
341 "Wait for all pending GDB commands to finish and evaluate BODY.
342
343 This function checks every 0.5 seconds if there are any pending
344 triggers in `gdb-handler-list'."
345 `(run-with-timer
346 0.5 nil
347 '(lambda ()
348 (if (not (cl-find-if (lambda (handler)
349 (gdb-handler-pending-trigger handler))
350 gdb-handler-list))
351 (progn ,@body)
352 (gdb-wait-for-pending ,@body)))))
353
354 ;; Publish-subscribe
355
356 (defmacro gdb-add-subscriber (publisher subscriber)
357 "Register new PUBLISHER's SUBSCRIBER.
358
359 SUBSCRIBER must be a pair, where cdr is a function of one
360 argument (see `gdb-emit-signal')."
361 `(add-to-list ',publisher ,subscriber t))
362
363 (defmacro gdb-delete-subscriber (publisher subscriber)
364 "Unregister SUBSCRIBER from PUBLISHER."
365 `(setq ,publisher (delete ,subscriber
366 ,publisher)))
367
368 (defun gdb-get-subscribers (publisher)
369 publisher)
370
371 (defun gdb-emit-signal (publisher &optional signal)
372 "Call cdr for each subscriber of PUBLISHER with SIGNAL as argument."
373 (dolist (subscriber (gdb-get-subscribers publisher))
374 (funcall (cdr subscriber) signal)))
375
376 (defvar gdb-buf-publisher '()
377 "Used to invalidate GDB buffers by emitting a signal in `gdb-update'.
378 Must be a list of pairs with cars being buffers and cdr's being
379 valid signal handlers.")
380
381 (defgroup gdb nil
382 "GDB graphical interface"
383 :group 'tools
384 :link '(info-link "(emacs)GDB Graphical Interface")
385 :version "23.2")
386
387 (defgroup gdb-non-stop nil
388 "GDB non-stop debugging settings"
389 :group 'gdb
390 :version "23.2")
391
392 (defgroup gdb-buffers nil
393 "GDB buffers"
394 :group 'gdb
395 :version "23.2")
396
397 (defcustom gdb-debug-log-max 128
398 "Maximum size of `gdb-debug-log'. If nil, size is unlimited."
399 :group 'gdb
400 :type '(choice (integer :tag "Number of elements")
401 (const :tag "Unlimited" nil))
402 :version "22.1")
403
404 (defcustom gdb-non-stop-setting t
405 "When in non-stop mode, stopped threads can be examined while
406 other threads continue to execute.
407
408 GDB session needs to be restarted for this setting to take effect."
409 :type 'boolean
410 :group 'gdb-non-stop
411 :version "23.2")
412
413 ;; TODO Some commands can't be called with --all (give a notice about
414 ;; it in setting doc)
415 (defcustom gdb-gud-control-all-threads t
416 "When non-nil, GUD execution commands affect all threads when
417 in non-stop mode. Otherwise, only current thread is affected."
418 :type 'boolean
419 :group 'gdb-non-stop
420 :version "23.2")
421
422 (defcustom gdb-switch-reasons t
423 "List of stop reasons for which Emacs should switch thread.
424 When t, switch to stopped thread no matter what the reason was.
425 When nil, never switch to stopped thread automatically.
426
427 This setting is used in non-stop mode only. In all-stop mode,
428 Emacs always switches to the thread which caused the stop."
429 ;; exited, exited-normally and exited-signaled are not
430 ;; thread-specific stop reasons and therefore are not included in
431 ;; this list
432 :type '(choice
433 (const :tag "All reasons" t)
434 (set :tag "Selection of reasons..."
435 (const :tag "A breakpoint was reached." "breakpoint-hit")
436 (const :tag "A watchpoint was triggered." "watchpoint-trigger")
437 (const :tag "A read watchpoint was triggered."
438 "read-watchpoint-trigger")
439 (const :tag "An access watchpoint was triggered."
440 "access-watchpoint-trigger")
441 (const :tag "Function finished execution." "function-finished")
442 (const :tag "Location reached." "location-reached")
443 (const :tag "Watchpoint has gone out of scope"
444 "watchpoint-scope")
445 (const :tag "End of stepping range reached."
446 "end-stepping-range")
447 (const :tag "Signal received (like interruption)."
448 "signal-received"))
449 (const :tag "None" nil))
450 :group 'gdb-non-stop
451 :version "23.2"
452 :link '(info-link "(gdb)GDB/MI Async Records"))
453
454 (defcustom gdb-stopped-functions nil
455 "List of functions called whenever GDB stops.
456
457 Each function takes one argument, a parsed MI response, which
458 contains fields of corresponding MI *stopped async record:
459
460 ((stopped-threads . \"all\")
461 (thread-id . \"1\")
462 (frame (line . \"38\")
463 (fullname . \"/home/sphinx/projects/gsoc/server.c\")
464 (file . \"server.c\")
465 (args ((value . \"0x804b038\")
466 (name . \"arg\")))
467 (func . \"hello\")
468 (addr . \"0x0804869e\"))
469 (reason . \"end-stepping-range\"))
470
471 Note that \"reason\" is only present in non-stop debugging mode.
472
473 `bindat-get-field' may be used to access the fields of response.
474
475 Each function is called after the new current thread was selected
476 and GDB buffers were updated in `gdb-stopped'."
477 :type '(repeat function)
478 :group 'gdb
479 :version "23.2"
480 :link '(info-link "(gdb)GDB/MI Async Records"))
481
482 (defcustom gdb-switch-when-another-stopped t
483 "When nil, don't switch to stopped thread if some other
484 stopped thread is already selected."
485 :type 'boolean
486 :group 'gdb-non-stop
487 :version "23.2")
488
489 (defcustom gdb-stack-buffer-locations t
490 "Show file information or library names in stack buffers."
491 :type 'boolean
492 :group 'gdb-buffers
493 :version "23.2")
494
495 (defcustom gdb-stack-buffer-addresses nil
496 "Show frame addresses in stack buffers."
497 :type 'boolean
498 :group 'gdb-buffers
499 :version "23.2")
500
501 (defcustom gdb-thread-buffer-verbose-names t
502 "Show long thread names in threads buffer."
503 :type 'boolean
504 :group 'gdb-buffers
505 :version "23.2")
506
507 (defcustom gdb-thread-buffer-arguments t
508 "Show function arguments in threads buffer."
509 :type 'boolean
510 :group 'gdb-buffers
511 :version "23.2")
512
513 (defcustom gdb-thread-buffer-locations t
514 "Show file information or library names in threads buffer."
515 :type 'boolean
516 :group 'gdb-buffers
517 :version "23.2")
518
519 (defcustom gdb-thread-buffer-addresses nil
520 "Show addresses for thread frames in threads buffer."
521 :type 'boolean
522 :group 'gdb-buffers
523 :version "23.2")
524
525 (defcustom gdb-show-threads-by-default nil
526 "Show threads list buffer instead of breakpoints list by default."
527 :type 'boolean
528 :group 'gdb-buffers
529 :version "23.2")
530
531 (defvar gdb-debug-log nil
532 "List of commands sent to and replies received from GDB.
533 Most recent commands are listed first. This list stores only the last
534 `gdb-debug-log-max' values. This variable is used to debug GDB-MI.")
535
536 ;;;###autoload
537 (define-minor-mode gdb-enable-debug
538 "Toggle logging of transaction between Emacs and Gdb.
539 The log is stored in `gdb-debug-log' as an alist with elements
540 whose cons is send, send-item or recv and whose cdr is the string
541 being transferred. This list may grow up to a size of
542 `gdb-debug-log-max' after which the oldest element (at the end of
543 the list) is deleted every time a new one is added (at the front)."
544 :global t
545 :group 'gdb
546 :version "22.1")
547
548 (defcustom gdb-cpp-define-alist-program "gcc -E -dM -"
549 "Shell command for generating a list of defined macros in a source file.
550 This list is used to display the #define directive associated
551 with an identifier as a tooltip. It works in a debug session with
552 GDB, when `gud-tooltip-mode' is t.
553
554 Set `gdb-cpp-define-alist-flags' for any include paths or
555 predefined macros."
556 :type 'string
557 :group 'gdb
558 :version "22.1")
559
560 (defcustom gdb-cpp-define-alist-flags ""
561 "Preprocessor flags for `gdb-cpp-define-alist-program'."
562 :type 'string
563 :group 'gdb
564 :version "22.1")
565
566 (defcustom gdb-create-source-file-list t
567 "Non-nil means create a list of files from which the executable was built.
568 Set this to nil if the GUD buffer displays \"initializing...\" in the mode
569 line for a long time when starting, possibly because your executable was
570 built from a large number of files. This allows quicker initialization
571 but means that these files are not automatically enabled for debugging,
572 e.g., you won't be able to click in the fringe to set a breakpoint until
573 execution has already stopped there."
574 :type 'boolean
575 :group 'gdb
576 :version "23.1")
577
578 (defcustom gdb-show-main nil
579 "Non-nil means display source file containing the main routine at startup.
580 Also display the main routine in the disassembly buffer if present."
581 :type 'boolean
582 :group 'gdb
583 :version "22.1")
584
585 (defvar gdbmi-debug-mode nil
586 "When non-nil, print the messages sent/received from GDB/MI in *Messages*.")
587
588 (defun gdb-force-mode-line-update (status)
589 (let ((buffer gud-comint-buffer))
590 (if (and buffer (buffer-name buffer))
591 (with-current-buffer buffer
592 (setq mode-line-process
593 (format ":%s [%s]"
594 (process-status (get-buffer-process buffer)) status))
595 ;; Force mode line redisplay soon.
596 (force-mode-line-update)))))
597
598 ;; These two are used for menu and toolbar
599 (defun gdb-control-all-threads ()
600 "Switch to non-stop/A mode."
601 (interactive)
602 (setq gdb-gud-control-all-threads t)
603 ;; Actually forcing the tool-bar to update.
604 (force-mode-line-update)
605 (message "Now in non-stop/A mode."))
606
607 (defun gdb-control-current-thread ()
608 "Switch to non-stop/T mode."
609 (interactive)
610 (setq gdb-gud-control-all-threads nil)
611 ;; Actually forcing the tool-bar to update.
612 (force-mode-line-update)
613 (message "Now in non-stop/T mode."))
614
615 (defun gdb-find-watch-expression ()
616 (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list))
617 (varnum (car var)) expr)
618 (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum)
619 (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet
620 (component-list (split-string (match-string 2 varnum) "\\." t)))
621 (setq expr (nth 1 var1))
622 (setq varnumlet (car var1))
623 (dolist (component component-list)
624 (setq var2 (assoc varnumlet gdb-var-list))
625 (setq expr (concat expr
626 (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2))
627 (concat "[" component "]")
628 (concat "." component))))
629 (setq varnumlet (concat varnumlet "." component)))
630 expr)))
631
632 ;; noall is used for commands which don't take --all, but only
633 ;; --thread.
634 (defun gdb-gud-context-command (command &optional noall)
635 "When `gdb-non-stop' is t, add --thread option to COMMAND if
636 `gdb-gud-control-all-threads' is nil and --all option otherwise.
637 If NOALL is t, always add --thread option no matter what
638 `gdb-gud-control-all-threads' value is.
639
640 When `gdb-non-stop' is nil, return COMMAND unchanged."
641 (if gdb-non-stop
642 (if (and gdb-gud-control-all-threads
643 (not noall)
644 gdb-supports-non-stop)
645 (concat command " --all ")
646 (gdb-current-context-command command))
647 command))
648
649 (defmacro gdb-gud-context-call (cmd1 &optional cmd2 noall noarg)
650 "`gud-call' wrapper which adds --thread/--all options between
651 CMD1 and CMD2. NOALL is the same as in `gdb-gud-context-command'.
652
653 NOARG must be t when this macro is used outside `gud-def'"
654 `(gud-call
655 (concat (gdb-gud-context-command ,cmd1 ,noall) " " ,cmd2)
656 ,(when (not noarg) 'arg)))
657
658 (defun gdb--check-interpreter (filter proc string)
659 (unless (zerop (length string))
660 (remove-function (process-filter proc) #'gdb--check-interpreter)
661 (unless (memq (aref string 0) '(?^ ?~ ?@ ?& ?* ?=))
662 ;; Apparently we're not running with -i=mi.
663 (let ((msg "Error: you did not specify -i=mi on GDB's command line!"))
664 (message msg)
665 (setq string (concat (propertize msg 'font-lock-face 'error)
666 "\n" string)))
667 ;; Use the old gud-gbd filter, not because it works, but because it
668 ;; will properly display GDB's answers rather than hanging waiting for
669 ;; answers that aren't coming.
670 (set (make-local-variable 'gud-marker-filter) #'gud-gdb-marker-filter))
671 (funcall filter proc string)))
672
673 (defvar gdb-control-level 0)
674
675 ;;;###autoload
676 (defun gdb (command-line)
677 "Run gdb on program FILE in buffer *gud-FILE*.
678 The directory containing FILE becomes the initial working directory
679 and source-file directory for your debugger.
680
681 COMMAND-LINE is the shell command for starting the gdb session.
682 It should be a string consisting of the name of the gdb
683 executable followed by command line options. The command line
684 options should include \"-i=mi\" to use gdb's MI text interface.
685 Note that the old \"--annotate\" option is no longer supported.
686
687 If option `gdb-many-windows' is nil (the default value) then gdb just
688 pops up the GUD buffer unless `gdb-show-main' is t. In this case
689 it starts with two windows: one displaying the GUD buffer and the
690 other with the source file with the main routine of the inferior.
691
692 If option `gdb-many-windows' is t, regardless of the value of
693 `gdb-show-main', the layout below will appear. Keybindings are
694 shown in some of the buffers.
695
696 Watch expressions appear in the speedbar/slowbar.
697
698 The following commands help control operation :
699
700 `gdb-many-windows' - Toggle the number of windows gdb uses.
701 `gdb-restore-windows' - To restore the window layout.
702
703 See Info node `(emacs)GDB Graphical Interface' for a more
704 detailed description of this mode.
705
706
707 +----------------------------------------------------------------------+
708 | GDB Toolbar |
709 +-----------------------------------+----------------------------------+
710 | GUD buffer (I/O of GDB) | Locals buffer |
711 | | |
712 | | |
713 | | |
714 +-----------------------------------+----------------------------------+
715 | Source buffer | I/O buffer (of debugged program) |
716 | | (comint-mode) |
717 | | |
718 | | |
719 | | |
720 | | |
721 | | |
722 | | |
723 +-----------------------------------+----------------------------------+
724 | Stack buffer | Breakpoints buffer |
725 | RET gdb-select-frame | SPC gdb-toggle-breakpoint |
726 | | RET gdb-goto-breakpoint |
727 | | D gdb-delete-breakpoint |
728 +-----------------------------------+----------------------------------+"
729 ;;
730 (interactive (list (gud-query-cmdline 'gdb)))
731
732 (when (and gud-comint-buffer
733 (buffer-name gud-comint-buffer)
734 (get-buffer-process gud-comint-buffer)
735 (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba)))
736 (gdb-restore-windows)
737 (error
738 "Multiple debugging requires restarting in text command mode"))
739 ;;
740 (gud-common-init command-line nil 'gud-gdbmi-marker-filter)
741
742 ;; Setup a temporary process filter to warn when GDB was not started
743 ;; with -i=mi.
744 (let ((proc (get-buffer-process gud-comint-buffer)))
745 (add-function :around (process-filter proc) #'gdb--check-interpreter))
746
747 (set (make-local-variable 'gud-minor-mode) 'gdbmi)
748 (set (make-local-variable 'gdb-control-level) 0)
749 (setq comint-input-sender 'gdb-send)
750 (when (ring-empty-p comint-input-ring) ; cf shell-mode
751 (let ((hfile (expand-file-name (or (getenv "GDBHISTFILE")
752 (if (eq system-type 'ms-dos)
753 "_gdb_history"
754 ".gdb_history"))))
755 ;; gdb defaults to 256, but we'll default to comint-input-ring-size.
756 (hsize (getenv "HISTSIZE")))
757 (dolist (file (append '("~/.gdbinit")
758 (unless (string-equal (expand-file-name ".")
759 (expand-file-name "~"))
760 '(".gdbinit"))))
761 (if (file-readable-p (setq file (expand-file-name file)))
762 (with-temp-buffer
763 (insert-file-contents file)
764 ;; TODO? check for "set history save\\( *on\\)?" and do
765 ;; not use history otherwise?
766 (while (re-search-forward
767 "^ *set history \\(filename\\|size\\) *\\(.*\\)" nil t)
768 (cond ((string-equal (match-string 1) "filename")
769 (setq hfile (expand-file-name
770 (match-string 2)
771 (file-name-directory file))))
772 ((string-equal (match-string 1) "size")
773 (setq hsize (match-string 2))))))))
774 (and (stringp hsize)
775 (integerp (setq hsize (string-to-number hsize)))
776 (> hsize 0)
777 (set (make-local-variable 'comint-input-ring-size) hsize))
778 (if (stringp hfile)
779 (set (make-local-variable 'comint-input-ring-file-name) hfile))
780 (comint-read-input-ring t)))
781 (gud-def gud-tbreak "tbreak %f:%l" "\C-t"
782 "Set temporary breakpoint at current line.")
783 (gud-def gud-jump
784 (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l"))
785 "\C-j" "Set execution address to current line.")
786
787 (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).")
788 (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).")
789 (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.")
790 (gud-def gud-pstar "print* %e" nil
791 "Evaluate C dereferenced pointer expression at point.")
792
793 (gud-def gud-step (gdb-gud-context-call "-exec-step" "%p" t)
794 "\C-s"
795 "Step one source line with display.")
796 (gud-def gud-stepi (gdb-gud-context-call "-exec-step-instruction" "%p" t)
797 "\C-i"
798 "Step one instruction with display.")
799 (gud-def gud-next (gdb-gud-context-call "-exec-next" "%p" t)
800 "\C-n"
801 "Step one line (skip functions).")
802 (gud-def gud-nexti (gdb-gud-context-call "-exec-next-instruction" "%p" t)
803 nil
804 "Step one instruction (skip functions).")
805 (gud-def gud-cont (gdb-gud-context-call "-exec-continue")
806 "\C-r"
807 "Continue with display.")
808 (gud-def gud-finish (gdb-gud-context-call "-exec-finish" nil t)
809 "\C-f"
810 "Finish executing current function.")
811 (gud-def gud-run "-exec-run"
812 nil
813 "Run the program.")
814
815 (gud-def gud-break (if (not (string-match "Disassembly" mode-name))
816 (gud-call "break %f:%l" arg)
817 (save-excursion
818 (beginning-of-line)
819 (forward-char 2)
820 (gud-call "break *%a" arg)))
821 "\C-b" "Set breakpoint at current line or address.")
822
823 (gud-def gud-remove (if (not (string-match "Disassembly" mode-name))
824 (gud-call "clear %f:%l" arg)
825 (save-excursion
826 (beginning-of-line)
827 (forward-char 2)
828 (gud-call "clear *%a" arg)))
829 "\C-d" "Remove breakpoint at current line or address.")
830
831 ;; -exec-until doesn't support --all yet
832 (gud-def gud-until (if (not (string-match "Disassembly" mode-name))
833 (gud-call "-exec-until %f:%l" arg)
834 (save-excursion
835 (beginning-of-line)
836 (forward-char 2)
837 (gud-call "-exec-until *%a" arg)))
838 "\C-u" "Continue to current line or address.")
839 ;; TODO Why arg here?
840 (gud-def
841 gud-go (gud-call (if gdb-active-process
842 (gdb-gud-context-command "-exec-continue")
843 "-exec-run") arg)
844 nil "Start or continue execution.")
845
846 ;; For debugging Emacs only.
847 (gud-def gud-pp
848 (gud-call
849 (concat
850 "pp " (if (eq (buffer-local-value
851 'major-mode (window-buffer)) 'speedbar-mode)
852 (gdb-find-watch-expression) "%e")) arg)
853 nil "Print the Emacs s-expression.")
854
855 (define-key gud-minor-mode-map [left-margin mouse-1]
856 'gdb-mouse-set-clear-breakpoint)
857 (define-key gud-minor-mode-map [left-fringe mouse-1]
858 'gdb-mouse-set-clear-breakpoint)
859 (define-key gud-minor-mode-map [left-margin C-mouse-1]
860 'gdb-mouse-toggle-breakpoint-margin)
861 (define-key gud-minor-mode-map [left-fringe C-mouse-1]
862 'gdb-mouse-toggle-breakpoint-fringe)
863
864 (define-key gud-minor-mode-map [left-margin drag-mouse-1]
865 'gdb-mouse-until)
866 (define-key gud-minor-mode-map [left-fringe drag-mouse-1]
867 'gdb-mouse-until)
868 (define-key gud-minor-mode-map [left-margin mouse-3]
869 'gdb-mouse-until)
870 (define-key gud-minor-mode-map [left-fringe mouse-3]
871 'gdb-mouse-until)
872
873 (define-key gud-minor-mode-map [left-margin C-drag-mouse-1]
874 'gdb-mouse-jump)
875 (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1]
876 'gdb-mouse-jump)
877 (define-key gud-minor-mode-map [left-fringe C-mouse-3]
878 'gdb-mouse-jump)
879 (define-key gud-minor-mode-map [left-margin C-mouse-3]
880 'gdb-mouse-jump)
881
882 (set (make-local-variable 'gud-gdb-completion-function)
883 'gud-gdbmi-completions)
884
885 (add-hook 'completion-at-point-functions #'gud-gdb-completion-at-point
886 nil 'local)
887 (local-set-key "\C-i" 'completion-at-point)
888
889 (local-set-key [remap comint-delchar-or-maybe-eof] 'gdb-delchar-or-quit)
890
891 (setq gdb-first-prompt t)
892 (setq gud-running nil)
893
894 (gdb-update)
895
896 (run-hooks 'gdb-mode-hook))
897
898 (defun gdb-init-1 ()
899 ;; (Re-)initialize.
900 (setq gdb-selected-frame nil
901 gdb-frame-number nil
902 gdb-thread-number nil
903 gdb-var-list nil
904 gdb-output-sink 'user
905 gdb-location-alist nil
906 gdb-source-file-list nil
907 gdb-last-command nil
908 gdb-token-number 0
909 gdb-handler-list '()
910 gdb-prompt-name nil
911 gdb-first-done-or-error t
912 gdb-buffer-fringe-width (car (window-fringes))
913 gdb-debug-log nil
914 gdb-source-window nil
915 gdb-inferior-status nil
916 gdb-continuation nil
917 gdb-buf-publisher '()
918 gdb-threads-list '()
919 gdb-breakpoints-list '()
920 gdb-register-names '()
921 gdb-non-stop gdb-non-stop-setting)
922 ;;
923 (gdbmi-bnf-init)
924 ;;
925 (setq gdb-buffer-type 'gdbmi)
926 ;;
927 (gdb-force-mode-line-update
928 (propertize "initializing..." 'face font-lock-variable-name-face))
929
930 (gdb-get-buffer-create 'gdb-inferior-io)
931 (gdb-clear-inferior-io)
932 (gdb-inferior-io--init-proc (get-process "gdb-inferior"))
933
934 (when (eq system-type 'windows-nt)
935 ;; Don't create a separate console window for the debuggee.
936 (gdb-input "-gdb-set new-console off" 'ignore)
937 ;; Force GDB to behave as if its input and output stream were
938 ;; connected to a TTY device (since on Windows we use pipes for
939 ;; communicating with GDB).
940 (gdb-input "-gdb-set interactive-mode on" 'ignore))
941 (gdb-input "-gdb-set height 0" 'ignore)
942
943 (when gdb-non-stop
944 (gdb-input "-gdb-set non-stop 1" 'gdb-non-stop-handler))
945
946 (gdb-input "-enable-pretty-printing" 'ignore)
947
948 ;; Find source file and compilation directory here.
949 (if gdb-create-source-file-list
950 ;; Needs GDB 6.2 onwards.
951 (gdb-input "-file-list-exec-source-files" 'gdb-get-source-file-list))
952 ;; Needs GDB 6.0 onwards.
953 (gdb-input "-file-list-exec-source-file" 'gdb-get-source-file)
954 (gdb-input "-gdb-show prompt" 'gdb-get-prompt))
955
956 (defun gdb-non-stop-handler ()
957 (goto-char (point-min))
958 (if (re-search-forward "No symbol" nil t)
959 (progn
960 (message
961 "This version of GDB doesn't support non-stop mode. Turning it off.")
962 (setq gdb-non-stop nil)
963 (setq gdb-supports-non-stop nil))
964 (setq gdb-supports-non-stop t)
965 (gdb-input "-gdb-set target-async 1" 'ignore)
966 (gdb-input "-list-target-features" 'gdb-check-target-async)))
967
968 (defun gdb-check-target-async ()
969 (goto-char (point-min))
970 (unless (re-search-forward "async" nil t)
971 (message
972 "Target doesn't support non-stop mode. Turning it off.")
973 (setq gdb-non-stop nil)
974 (gdb-input "-gdb-set non-stop 0" 'ignore)))
975
976 (defun gdb-delchar-or-quit (arg)
977 "Delete ARG characters or send a quit command to GDB.
978 Send a quit only if point is at the end of the buffer, there is
979 no input, and GDB is waiting for input."
980 (interactive "p")
981 (unless (and (eq (current-buffer) gud-comint-buffer)
982 (eq gud-minor-mode 'gdbmi))
983 (error "Not in a GDB-MI buffer"))
984 (let ((proc (get-buffer-process gud-comint-buffer)))
985 (if (and (eobp) proc (process-live-p proc)
986 (not gud-running)
987 (= (point) (marker-position (process-mark proc))))
988 ;; Sending an EOF does not work with GDB-MI; submit an
989 ;; explicit quit command.
990 (progn
991 (insert "quit")
992 (comint-send-input t t))
993 (delete-char arg))))
994
995 (defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.")
996
997 (defun gdb-create-define-alist ()
998 "Create an alist of #define directives for GUD tooltips."
999 (let* ((file (buffer-file-name))
1000 (output
1001 (with-output-to-string
1002 (with-current-buffer standard-output
1003 (and file
1004 (file-exists-p file)
1005 ;; call-process doesn't work with remote file names.
1006 (not (file-remote-p default-directory))
1007 (call-process shell-file-name file
1008 (list t nil) nil "-c"
1009 (concat gdb-cpp-define-alist-program " "
1010 gdb-cpp-define-alist-flags))))))
1011 (define-list (split-string output "\n" t))
1012 (name))
1013 (setq gdb-define-alist nil)
1014 (dolist (define define-list)
1015 (setq name (nth 1 (split-string define "[( ]")))
1016 (push (cons name define) gdb-define-alist))))
1017
1018 (declare-function tooltip-show "tooltip" (text &optional use-echo-area))
1019
1020 (defun gdb-tooltip-print (expr)
1021 (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
1022 (goto-char (point-min))
1023 (cond
1024 ((re-search-forward ".*value=\\(\".*\"\\)" nil t)
1025 (tooltip-show
1026 (concat expr " = " (read (match-string 1)))
1027 (or gud-tooltip-echo-area
1028 (not (display-graphic-p)))))
1029 ((re-search-forward "msg=\\(\".+\"\\)$" nil t)
1030 (tooltip-show (read (match-string 1))
1031 (or gud-tooltip-echo-area
1032 (not (display-graphic-p))))))))
1033
1034 ;; If expr is a macro for a function don't print because of possible dangerous
1035 ;; side-effects. Also printing a function within a tooltip generates an
1036 ;; unexpected starting annotation (phase error).
1037 (defun gdb-tooltip-print-1 (expr)
1038 (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
1039 (goto-char (point-min))
1040 (if (search-forward "expands to: " nil t)
1041 (unless (looking-at "\\S-+.*(.*).*")
1042 (gdb-input (concat "-data-evaluate-expression \"" expr "\"")
1043 `(lambda () (gdb-tooltip-print ,expr)))))))
1044
1045 (defun gdb-init-buffer ()
1046 (set (make-local-variable 'gud-minor-mode) 'gdbmi)
1047 (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
1048 (when gud-tooltip-mode
1049 (make-local-variable 'gdb-define-alist)
1050 (gdb-create-define-alist)
1051 (add-hook 'after-save-hook 'gdb-create-define-alist nil t)))
1052
1053 (defmacro gdb--if-arrow (arrow-position start-posn end-posn &rest body)
1054 (declare (indent 3))
1055 (let ((buffer (make-symbol "buffer")))
1056 `(if ,arrow-position
1057 (let ((,buffer (marker-buffer ,arrow-position)))
1058 (if (equal ,buffer (window-buffer (posn-window ,end-posn)))
1059 (with-current-buffer ,buffer
1060 (when (or (equal ,start-posn ,end-posn)
1061 (equal (posn-point ,start-posn)
1062 (marker-position ,arrow-position)))
1063 ,@body)))))))
1064
1065 (defun gdb-mouse-until (event)
1066 "Continue running until a source line past the current line.
1067 The destination source line can be selected either by clicking
1068 with mouse-3 on the fringe/margin or dragging the arrow
1069 with mouse-1 (default bindings)."
1070 (interactive "e")
1071 (let ((start (event-start event))
1072 (end (event-end event)))
1073 (gdb--if-arrow gud-overlay-arrow-position start end
1074 (let ((line (line-number-at-pos (posn-point end))))
1075 (gud-call (concat "until " (number-to-string line)))))
1076 (gdb--if-arrow gdb-disassembly-position start end
1077 (save-excursion
1078 (goto-char (point-min))
1079 (forward-line (1- (line-number-at-pos (posn-point end))))
1080 (forward-char 2)
1081 (gud-call (concat "until *%a"))))))
1082
1083 (defun gdb-mouse-jump (event)
1084 "Set execution address/line.
1085 The destination source line can be selected either by clicking with C-mouse-3
1086 on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings).
1087 Unlike `gdb-mouse-until' the destination address can be before the current
1088 line, and no execution takes place."
1089 (interactive "e")
1090 (let ((start (event-start event))
1091 (end (event-end event)))
1092 (gdb--if-arrow gud-overlay-arrow-position start end
1093 (let ((line (line-number-at-pos (posn-point end))))
1094 (gud-call (concat "tbreak " (number-to-string line)))
1095 (gud-call (concat "jump " (number-to-string line)))))
1096 (gdb--if-arrow gdb-disassembly-position start end
1097 (save-excursion
1098 (goto-char (point-min))
1099 (forward-line (1- (line-number-at-pos (posn-point end))))
1100 (forward-char 2)
1101 (gud-call (concat "tbreak *%a"))
1102 (gud-call (concat "jump *%a"))))))
1103
1104 (defcustom gdb-show-changed-values t
1105 "If non-nil change the face of out of scope variables and changed values.
1106 Out of scope variables are suppressed with `shadow' face.
1107 Changed values are highlighted with the face `font-lock-warning-face'."
1108 :type 'boolean
1109 :group 'gdb
1110 :version "22.1")
1111
1112 (defcustom gdb-max-children 40
1113 "Maximum number of children before expansion requires confirmation."
1114 :type 'integer
1115 :group 'gdb
1116 :version "22.1")
1117
1118 (defcustom gdb-delete-out-of-scope t
1119 "If non-nil delete watch expressions automatically when they go out of scope."
1120 :type 'boolean
1121 :group 'gdb
1122 :version "22.2")
1123
1124 (define-minor-mode gdb-speedbar-auto-raise
1125 "Minor mode to automatically raise the speedbar for watch expressions.
1126 With prefix argument ARG, automatically raise speedbar if ARG is
1127 positive, otherwise don't automatically raise it."
1128 :global t
1129 :group 'gdb
1130 :version "22.1")
1131
1132 (defcustom gdb-use-colon-colon-notation nil
1133 "If non-nil use FUN::VAR format to display variables in the speedbar."
1134 :type 'boolean
1135 :group 'gdb
1136 :version "22.1")
1137
1138 (define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch)
1139 (define-key global-map (vconcat gud-key-prefix "\C-w") 'gud-watch)
1140
1141 (declare-function tooltip-identifier-from-point "tooltip" (point))
1142
1143 (defun gud-watch (&optional arg event)
1144 "Watch expression at point.
1145 With arg, enter name of variable to be watched in the minibuffer."
1146 (interactive (list current-prefix-arg last-input-event))
1147 (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer)))
1148 (if (eq minor-mode 'gdbmi)
1149 (progn
1150 (if event (posn-set-point (event-end event)))
1151 (require 'tooltip)
1152 (save-selected-window
1153 (let ((expr
1154 (if arg
1155 (completing-read "Name of variable: "
1156 'gud-gdb-complete-command)
1157 (if (and transient-mark-mode mark-active)
1158 (buffer-substring (region-beginning) (region-end))
1159 (concat (if (derived-mode-p 'gdb-registers-mode) "$")
1160 (tooltip-identifier-from-point (point)))))))
1161 (set-text-properties 0 (length expr) nil expr)
1162 (gdb-input (concat "-var-create - * " expr "")
1163 `(lambda () (gdb-var-create-handler ,expr))))))
1164 (message "gud-watch is a no-op in this mode."))))
1165
1166 (defun gdb-var-create-handler (expr)
1167 (let* ((result (gdb-json-partial-output)))
1168 (if (not (bindat-get-field result 'msg))
1169 (let ((var
1170 (list (bindat-get-field result 'name)
1171 (if (and (string-equal gdb-current-language "c")
1172 gdb-use-colon-colon-notation gdb-selected-frame)
1173 (setq expr (concat gdb-selected-frame "::" expr))
1174 expr)
1175 (bindat-get-field result 'numchild)
1176 (bindat-get-field result 'type)
1177 (bindat-get-field result 'value)
1178 nil
1179 (bindat-get-field result 'has_more)
1180 gdb-frame-address)))
1181 (push var gdb-var-list)
1182 (speedbar 1)
1183 (unless (string-equal
1184 speedbar-initial-expansion-list-name "GUD")
1185 (speedbar-change-initial-expansion-list "GUD")))
1186 (message-box "No symbol \"%s\" in current context." expr))))
1187
1188 (defun gdb-speedbar-update ()
1189 (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
1190 ;; Dummy command to update speedbar even when idle.
1191 (gdb-input "-environment-pwd"
1192 'gdb-speedbar-timer-fn
1193 'gdb-speedbar-update)))
1194
1195 (defun gdb-speedbar-timer-fn ()
1196 (if gdb-speedbar-auto-raise
1197 (raise-frame speedbar-frame))
1198 (speedbar-timer-fn))
1199
1200 (defun gdb-var-evaluate-expression-handler (varnum changed)
1201 (goto-char (point-min))
1202 (re-search-forward ".*value=\\(\".*\"\\)" nil t)
1203 (let ((var (assoc varnum gdb-var-list)))
1204 (when var
1205 (if changed (setcar (nthcdr 5 var) 'changed))
1206 (setcar (nthcdr 4 var) (read (match-string 1)))))
1207 (gdb-speedbar-update))
1208
1209 ; Uses "-var-list-children --all-values". Needs GDB 6.1 onwards.
1210 (defun gdb-var-list-children (varnum)
1211 (gdb-input (concat "-var-update " varnum) 'ignore)
1212 (gdb-input (concat "-var-list-children --all-values " varnum)
1213 `(lambda () (gdb-var-list-children-handler ,varnum))))
1214
1215 (defun gdb-var-list-children-handler (varnum)
1216 (let* ((var-list nil)
1217 (output (bindat-get-field (gdb-json-partial-output "child")))
1218 (children (bindat-get-field output 'children)))
1219 (catch 'child-already-watched
1220 (dolist (var gdb-var-list)
1221 (if (string-equal varnum (car var))
1222 (progn
1223 ;; With dynamic varobjs numchild may have increased.
1224 (setcar (nthcdr 2 var) (bindat-get-field output 'numchild))
1225 (push var var-list)
1226 (dolist (child children)
1227 (let ((varchild (list (bindat-get-field child 'name)
1228 (bindat-get-field child 'exp)
1229 (bindat-get-field child 'numchild)
1230 (bindat-get-field child 'type)
1231 (bindat-get-field child 'value)
1232 nil
1233 (bindat-get-field child 'has_more))))
1234 (if (assoc (car varchild) gdb-var-list)
1235 (throw 'child-already-watched nil))
1236 (push varchild var-list))))
1237 (push var var-list)))
1238 (setq gdb-var-list (nreverse var-list))))
1239 (gdb-speedbar-update))
1240
1241 (defun gdb-var-set-format (format)
1242 "Set the output format for a variable displayed in the speedbar."
1243 (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
1244 (varnum (car var)))
1245 (gdb-input (concat "-var-set-format " varnum " " format) 'ignore)
1246 (gdb-var-update)))
1247
1248 (defun gdb-var-delete-1 (var varnum)
1249 (gdb-input (concat "-var-delete " varnum) 'ignore)
1250 (setq gdb-var-list (delq var gdb-var-list))
1251 (dolist (varchild gdb-var-list)
1252 (if (string-match (concat (car var) "\\.") (car varchild))
1253 (setq gdb-var-list (delq varchild gdb-var-list)))))
1254
1255 (defun gdb-var-delete ()
1256 "Delete watch expression at point from the speedbar."
1257 (interactive)
1258 (let ((text (speedbar-line-text)))
1259 (string-match "\\(\\S-+\\)" text)
1260 (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
1261 (varnum (car var)))
1262 (if (string-match "\\." (car var))
1263 (message-box "Can only delete a root expression")
1264 (gdb-var-delete-1 var varnum)))))
1265
1266 (defun gdb-var-delete-children (varnum)
1267 "Delete children of variable object at point from the speedbar."
1268 (gdb-input (concat "-var-delete -c " varnum) 'ignore))
1269
1270 (defun gdb-edit-value (_text _token _indent)
1271 "Assign a value to a variable displayed in the speedbar."
1272 (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
1273 (varnum (car var))
1274 (value (read-string "New value: ")))
1275 (gdb-input (concat "-var-assign " varnum " " value)
1276 `(lambda () (gdb-edit-value-handler ,value)))))
1277
1278 (defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)")
1279
1280 (defun gdb-edit-value-handler (value)
1281 (goto-char (point-min))
1282 (if (re-search-forward gdb-error-regexp nil t)
1283 (message-box "Invalid number or expression (%s)" value)))
1284
1285 ; Uses "-var-update --all-values". Needs GDB 6.4 onwards.
1286 (defun gdb-var-update ()
1287 (gdb-input "-var-update --all-values *"
1288 'gdb-var-update-handler
1289 'gdb-var-update))
1290
1291 (defun gdb-var-update-handler ()
1292 (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist)))
1293 (dolist (var gdb-var-list)
1294 (setcar (nthcdr 5 var) nil))
1295 (let ((temp-var-list gdb-var-list))
1296 (dolist (change changelist)
1297 (let* ((varnum (bindat-get-field change 'name))
1298 (var (assoc varnum gdb-var-list))
1299 (new-num (bindat-get-field change 'new_num_children)))
1300 (when var
1301 (let ((scope (bindat-get-field change 'in_scope))
1302 (has-more (bindat-get-field change 'has_more)))
1303 (cond ((string-equal scope "false")
1304 (if gdb-delete-out-of-scope
1305 (gdb-var-delete-1 var varnum)
1306 (setcar (nthcdr 5 var) 'out-of-scope)))
1307 ((string-equal scope "true")
1308 (setcar (nthcdr 6 var) has-more)
1309 (when (and (or (not has-more)
1310 (string-equal has-more "0"))
1311 (not new-num)
1312 (string-equal (nth 2 var) "0"))
1313 (setcar (nthcdr 4 var)
1314 (bindat-get-field change 'value))
1315 (setcar (nthcdr 5 var) 'changed)))
1316 ((string-equal scope "invalid")
1317 (gdb-var-delete-1 var varnum)))))
1318 (let ((var-list nil) var1
1319 (children (bindat-get-field change 'new_children)))
1320 (when new-num
1321 (setq var1 (pop temp-var-list))
1322 (while var1
1323 (if (string-equal varnum (car var1))
1324 (let ((new (string-to-number new-num))
1325 (previous (string-to-number (nth 2 var1))))
1326 (setcar (nthcdr 2 var1) new-num)
1327 (push var1 var-list)
1328 (cond
1329 ((> new previous)
1330 ;; Add new children to list.
1331 (dotimes (_ previous)
1332 (push (pop temp-var-list) var-list))
1333 (dolist (child children)
1334 (let ((varchild
1335 (list (bindat-get-field child 'name)
1336 (bindat-get-field child 'exp)
1337 (bindat-get-field child 'numchild)
1338 (bindat-get-field child 'type)
1339 (bindat-get-field child 'value)
1340 'changed
1341 (bindat-get-field child 'has_more))))
1342 (push varchild var-list))))
1343 ;; Remove deleted children from list.
1344 ((< new previous)
1345 (dotimes (_ new)
1346 (push (pop temp-var-list) var-list))
1347 (dotimes (_ (- previous new))
1348 (pop temp-var-list)))))
1349 (push var1 var-list))
1350 (setq var1 (pop temp-var-list)))
1351 (setq gdb-var-list (nreverse var-list))))))))
1352 (gdb-speedbar-update))
1353
1354 (defun gdb-speedbar-expand-node (text token indent)
1355 "Expand the node the user clicked on.
1356 TEXT is the text of the button we clicked on, a + or - item.
1357 TOKEN is data related to this node.
1358 INDENT is the current indentation depth."
1359 (cond ((string-match "+" text) ;expand this node
1360 (let* ((var (assoc token gdb-var-list))
1361 (expr (nth 1 var)) (children (nth 2 var)))
1362 (if (or (<= (string-to-number children) gdb-max-children)
1363 (y-or-n-p
1364 (format "%s has %s children. Continue? " expr children)))
1365 (gdb-var-list-children token))))
1366 ((string-match "-" text) ;contract this node
1367 (dolist (var gdb-var-list)
1368 (if (string-match (concat token "\\.") (car var))
1369 (setq gdb-var-list (delq var gdb-var-list))))
1370 (gdb-var-delete-children token)
1371 (speedbar-change-expand-button-char ?+)
1372 (speedbar-delete-subblock indent))
1373 (t (error "Ooops... not sure what to do")))
1374 (speedbar-center-buffer-smartly))
1375
1376 (defun gdb-get-target-string ()
1377 (with-current-buffer gud-comint-buffer
1378 gud-target-name))
1379 \f
1380
1381 ;;
1382 ;; gdb buffers.
1383 ;;
1384 ;; Each buffer has a TYPE -- a symbol that identifies the function
1385 ;; of that particular buffer.
1386 ;;
1387 ;; The usual gdb interaction buffer is given the type `gdbmi' and
1388 ;; is constructed specially.
1389 ;;
1390 ;; Others are constructed by gdb-get-buffer-create and
1391 ;; named according to the rules set forth in the gdb-buffer-rules
1392
1393 (defvar gdb-buffer-rules '())
1394
1395 (defun gdb-rules-name-maker (rules-entry)
1396 (cadr rules-entry))
1397 (defun gdb-rules-buffer-mode (rules-entry)
1398 (nth 2 rules-entry))
1399 (defun gdb-rules-update-trigger (rules-entry)
1400 (nth 3 rules-entry))
1401
1402 (defun gdb-update-buffer-name ()
1403 "Rename current buffer according to name-maker associated with
1404 it in `gdb-buffer-rules'."
1405 (let ((f (gdb-rules-name-maker (assoc gdb-buffer-type
1406 gdb-buffer-rules))))
1407 (when f (rename-buffer (funcall f)))))
1408
1409 (defun gdb-current-buffer-rules ()
1410 "Get `gdb-buffer-rules' entry for current buffer type."
1411 (assoc gdb-buffer-type gdb-buffer-rules))
1412
1413 (defun gdb-current-buffer-thread ()
1414 "Get thread object of current buffer from `gdb-threads-list'.
1415
1416 When current buffer is not bound to any thread, return main
1417 thread."
1418 (cdr (assoc gdb-thread-number gdb-threads-list)))
1419
1420 (defun gdb-current-buffer-frame ()
1421 "Get current stack frame object for thread of current buffer."
1422 (bindat-get-field (gdb-current-buffer-thread) 'frame))
1423
1424 (defun gdb-buffer-type (buffer)
1425 "Get value of `gdb-buffer-type' for BUFFER."
1426 (with-current-buffer buffer
1427 gdb-buffer-type))
1428
1429 (defun gdb-buffer-shows-main-thread-p ()
1430 "Return t if current GDB buffer shows main selected thread and
1431 is not bound to it."
1432 (current-buffer)
1433 (not (local-variable-p 'gdb-thread-number)))
1434
1435 (defun gdb-get-buffer (buffer-type &optional thread)
1436 "Get a specific GDB buffer.
1437
1438 In that buffer, `gdb-buffer-type' must be equal to BUFFER-TYPE
1439 and `gdb-thread-number' (if provided) must be equal to THREAD."
1440 (catch 'found
1441 (dolist (buffer (buffer-list) nil)
1442 (with-current-buffer buffer
1443 (when (and (eq gdb-buffer-type buffer-type)
1444 (or (not thread)
1445 (equal gdb-thread-number thread)))
1446 (throw 'found buffer))))))
1447
1448 (defun gdb-get-buffer-create (buffer-type &optional thread)
1449 "Create a new GDB buffer of the type specified by BUFFER-TYPE.
1450 The buffer-type should be one of the cars in `gdb-buffer-rules'.
1451
1452 If THREAD is non-nil, it is assigned to `gdb-thread-number'
1453 buffer-local variable of the new buffer.
1454
1455 Buffer mode and name are selected according to buffer type.
1456
1457 If buffer has trigger associated with it in `gdb-buffer-rules',
1458 this trigger is subscribed to `gdb-buf-publisher' and called with
1459 'update argument."
1460 (or (gdb-get-buffer buffer-type thread)
1461 (let ((rules (assoc buffer-type gdb-buffer-rules))
1462 (new (generate-new-buffer "limbo")))
1463 (with-current-buffer new
1464 (let ((mode (gdb-rules-buffer-mode rules))
1465 (trigger (gdb-rules-update-trigger rules)))
1466 (when mode (funcall mode))
1467 (setq gdb-buffer-type buffer-type)
1468 (when thread
1469 (set (make-local-variable 'gdb-thread-number) thread))
1470 (set (make-local-variable 'gud-minor-mode)
1471 (buffer-local-value 'gud-minor-mode gud-comint-buffer))
1472 (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
1473 (rename-buffer (funcall (gdb-rules-name-maker rules)))
1474 (when trigger
1475 (gdb-add-subscriber gdb-buf-publisher
1476 (cons (current-buffer)
1477 (gdb-bind-function-to-buffer
1478 trigger (current-buffer))))
1479 (funcall trigger 'start))
1480 (current-buffer))))))
1481
1482 (defun gdb-bind-function-to-buffer (expr buffer)
1483 "Return a function which will evaluate EXPR in BUFFER."
1484 `(lambda (&rest args)
1485 (with-current-buffer ,buffer
1486 (apply ',expr args))))
1487
1488 ;; Used to display windows with thread-bound buffers
1489 (defmacro def-gdb-preempt-display-buffer (name buffer &optional doc
1490 split-horizontal)
1491 `(defun ,name (&optional thread)
1492 ,(when doc doc)
1493 (message thread)
1494 (gdb-preempt-existing-or-display-buffer
1495 (gdb-get-buffer-create ,buffer thread)
1496 ,split-horizontal)))
1497
1498 ;; This assoc maps buffer type symbols to rules. Each rule is a list of
1499 ;; at least one and possible more functions. The functions have these
1500 ;; roles in defining a buffer type:
1501 ;;
1502 ;; NAME - Return a name for this buffer type.
1503 ;;
1504 ;; The remaining function(s) are optional:
1505 ;;
1506 ;; MODE - called in a new buffer with no arguments, should establish
1507 ;; the proper mode for the buffer.
1508 ;;
1509
1510 (defun gdb-set-buffer-rules (buffer-type &rest rules)
1511 (let ((binding (assoc buffer-type gdb-buffer-rules)))
1512 (if binding
1513 (setcdr binding rules)
1514 (push (cons buffer-type rules)
1515 gdb-buffer-rules))))
1516
1517 (defun gdb-parent-mode ()
1518 "Generic mode to derive all other GDB buffer modes from."
1519 (kill-all-local-variables)
1520 (setq buffer-read-only t)
1521 (buffer-disable-undo)
1522 ;; Delete buffer from gdb-buf-publisher when it's killed
1523 ;; (if it has an associated update trigger)
1524 (add-hook
1525 'kill-buffer-hook
1526 (function
1527 (lambda ()
1528 (let ((trigger (gdb-rules-update-trigger
1529 (gdb-current-buffer-rules))))
1530 (when trigger
1531 (gdb-delete-subscriber
1532 gdb-buf-publisher
1533 ;; This should match gdb-add-subscriber done in
1534 ;; gdb-get-buffer-create
1535 (cons (current-buffer)
1536 (gdb-bind-function-to-buffer trigger (current-buffer))))))))
1537 nil t))
1538
1539 ;; Partial-output buffer : This accumulates output from a command executed on
1540 ;; behalf of emacs (rather than the user).
1541 ;;
1542 (gdb-set-buffer-rules 'gdb-partial-output-buffer
1543 'gdb-partial-output-name)
1544
1545 (defun gdb-partial-output-name ()
1546 (concat " *partial-output-"
1547 (gdb-get-target-string)
1548 "*"))
1549
1550 \f
1551 (gdb-set-buffer-rules 'gdb-inferior-io
1552 'gdb-inferior-io-name
1553 'gdb-inferior-io-mode)
1554
1555 (defun gdb-inferior-io-name ()
1556 (concat "*input/output of "
1557 (gdb-get-target-string)
1558 "*"))
1559
1560 (defun gdb-display-io-buffer ()
1561 "Display IO of debugged program in a separate window."
1562 (interactive)
1563 (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io)))
1564
1565 (defun gdb-inferior-io--init-proc (proc)
1566 ;; Set up inferior I/O. Needs GDB 6.4 onwards.
1567 (set-process-filter proc 'gdb-inferior-filter)
1568 (set-process-sentinel proc 'gdb-inferior-io-sentinel)
1569 ;; The process can run on a remote host.
1570 (let ((tty (or (process-get proc 'remote-tty)
1571 (process-tty-name proc))))
1572 (unless (or (null tty)
1573 (string= tty ""))
1574 (gdb-input
1575 (concat "-inferior-tty-set " tty) 'ignore))))
1576
1577 (defun gdb-inferior-io-sentinel (proc _str)
1578 (when (eq (process-status proc) 'failed)
1579 ;; When the debugged process exits, Emacs gets an EIO error on
1580 ;; read from the pty, and stops listening to it. If the gdb
1581 ;; process is still running, remove the pty, make a new one, and
1582 ;; pass it to gdb.
1583 (let ((gdb-proc (get-buffer-process gud-comint-buffer))
1584 (io-buffer (process-buffer proc)))
1585 (when (and gdb-proc (process-live-p gdb-proc)
1586 (buffer-live-p io-buffer))
1587 ;; `comint-exec' deletes the original process as a side effect.
1588 (comint-exec io-buffer "gdb-inferior" nil nil nil)
1589 (gdb-inferior-io--init-proc (get-buffer-process io-buffer))))))
1590
1591 (defcustom gdb-display-buffer-other-frame-action
1592 '((display-buffer-reuse-window display-buffer-pop-up-frame)
1593 (reusable-frames . visible)
1594 (inhibit-same-window . t)
1595 (pop-up-frame-parameters (height . 14)
1596 (width . 80)
1597 (unsplittable . t)
1598 (tool-bar-lines . nil)
1599 (menu-bar-lines . nil)
1600 (minibuffer . nil)))
1601 "`display-buffer' action for displaying GDB utility frames."
1602 :group 'gdb
1603 :type display-buffer--action-custom-type
1604 :risky t
1605 :version "24.3")
1606
1607 (defun gdb-frame-io-buffer ()
1608 "Display IO of debugged program in another frame."
1609 (interactive)
1610 (display-buffer (gdb-get-buffer-create 'gdb-inferior-io)
1611 gdb-display-buffer-other-frame-action))
1612
1613 (defvar gdb-inferior-io-mode-map
1614 (let ((map (make-sparse-keymap)))
1615 (define-key map "\C-c\C-c" 'gdb-io-interrupt)
1616 (define-key map "\C-c\C-z" 'gdb-io-stop)
1617 (define-key map "\C-c\C-\\" 'gdb-io-quit)
1618 (define-key map "\C-c\C-d" 'gdb-io-eof)
1619 (define-key map "\C-d" 'gdb-io-eof)
1620 map))
1621
1622 ;; We want to use comint because it has various nifty and familiar features.
1623 (define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O"
1624 "Major mode for gdb inferior-io."
1625 :syntax-table nil :abbrev-table nil
1626 (make-comint-in-buffer "gdb-inferior" (current-buffer) nil))
1627
1628 (defun gdb-inferior-filter (proc string)
1629 (unless (string-equal string "")
1630 (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io)))
1631 (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io)
1632 (comint-output-filter proc string)))
1633
1634 (defun gdb-io-interrupt ()
1635 "Interrupt the program being debugged."
1636 (interactive)
1637 (interrupt-process
1638 (get-buffer-process gud-comint-buffer) comint-ptyp))
1639
1640 (defun gdb-io-quit ()
1641 "Send quit signal to the program being debugged."
1642 (interactive)
1643 (quit-process
1644 (get-buffer-process gud-comint-buffer) comint-ptyp))
1645
1646 (defun gdb-io-stop ()
1647 "Stop the program being debugged."
1648 (interactive)
1649 (stop-process
1650 (get-buffer-process gud-comint-buffer) comint-ptyp))
1651
1652 (defun gdb-io-eof ()
1653 "Send end-of-file to the program being debugged."
1654 (interactive)
1655 (process-send-eof
1656 (get-buffer-process gud-comint-buffer)))
1657
1658 (defun gdb-clear-inferior-io ()
1659 (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io)
1660 (erase-buffer)))
1661 \f
1662
1663 (defconst breakpoint-xpm-data
1664 "/* XPM */
1665 static char *magick[] = {
1666 /* columns rows colors chars-per-pixel */
1667 \"10 10 2 1\",
1668 \" c red\",
1669 \"+ c None\",
1670 /* pixels */
1671 \"+++ +++\",
1672 \"++ ++\",
1673 \"+ +\",
1674 \" \",
1675 \" \",
1676 \" \",
1677 \" \",
1678 \"+ +\",
1679 \"++ ++\",
1680 \"+++ +++\",
1681 };"
1682 "XPM data used for breakpoint icon.")
1683
1684 (defconst breakpoint-enabled-pbm-data
1685 "P1
1686 10 10\",
1687 0 0 0 0 1 1 1 1 0 0 0 0
1688 0 0 0 1 1 1 1 1 1 0 0 0
1689 0 0 1 1 1 1 1 1 1 1 0 0
1690 0 1 1 1 1 1 1 1 1 1 1 0
1691 0 1 1 1 1 1 1 1 1 1 1 0
1692 0 1 1 1 1 1 1 1 1 1 1 0
1693 0 1 1 1 1 1 1 1 1 1 1 0
1694 0 0 1 1 1 1 1 1 1 1 0 0
1695 0 0 0 1 1 1 1 1 1 0 0 0
1696 0 0 0 0 1 1 1 1 0 0 0 0"
1697 "PBM data used for enabled breakpoint icon.")
1698
1699 (defconst breakpoint-disabled-pbm-data
1700 "P1
1701 10 10\",
1702 0 0 1 0 1 0 1 0 0 0
1703 0 1 0 1 0 1 0 1 0 0
1704 1 0 1 0 1 0 1 0 1 0
1705 0 1 0 1 0 1 0 1 0 1
1706 1 0 1 0 1 0 1 0 1 0
1707 0 1 0 1 0 1 0 1 0 1
1708 1 0 1 0 1 0 1 0 1 0
1709 0 1 0 1 0 1 0 1 0 1
1710 0 0 1 0 1 0 1 0 1 0
1711 0 0 0 1 0 1 0 1 0 0"
1712 "PBM data used for disabled breakpoint icon.")
1713
1714 (defvar breakpoint-enabled-icon nil
1715 "Icon for enabled breakpoint in display margin.")
1716
1717 (defvar breakpoint-disabled-icon nil
1718 "Icon for disabled breakpoint in display margin.")
1719
1720 (declare-function define-fringe-bitmap "fringe.c"
1721 (bitmap bits &optional height width align))
1722
1723 (and (display-images-p)
1724 ;; Bitmap for breakpoint in fringe
1725 (define-fringe-bitmap 'breakpoint
1726 "\x3c\x7e\xff\xff\xff\xff\x7e\x3c")
1727 ;; Bitmap for gud-overlay-arrow in fringe
1728 (define-fringe-bitmap 'hollow-right-triangle
1729 "\xe0\x90\x88\x84\x84\x88\x90\xe0"))
1730
1731 (defface breakpoint-enabled
1732 '((t
1733 :foreground "red1"
1734 :weight bold))
1735 "Face for enabled breakpoint icon in fringe."
1736 :group 'gdb)
1737
1738 (defface breakpoint-disabled
1739 '((((class color) (min-colors 88)) :foreground "grey70")
1740 ;; Ensure that on low-color displays that we end up something visible.
1741 (((class color) (min-colors 8) (background light))
1742 :foreground "black")
1743 (((class color) (min-colors 8) (background dark))
1744 :foreground "white")
1745 (((type tty) (class mono))
1746 :inverse-video t)
1747 (t :background "gray"))
1748 "Face for disabled breakpoint icon in fringe."
1749 :group 'gdb)
1750
1751 \f
1752 (defvar gdb-control-commands-regexp
1753 (concat
1754 "^\\("
1755 "commands\\|if\\|while\\|define\\|document\\|python\\|"
1756 "while-stepping\\|stepping\\|ws\\|actions"
1757 "\\)\\([[:blank:]]+.*\\)?$")
1758 "Regexp matching GDB commands that enter a recursive reading loop.
1759 As long as GDB is in the recursive reading loop, it does not expect
1760 commands to be prefixed by \"-interpreter-exec console\".")
1761
1762 (defun gdb-send (proc string)
1763 "A comint send filter for gdb."
1764 (with-current-buffer gud-comint-buffer
1765 (let ((inhibit-read-only t))
1766 (remove-text-properties (point-min) (point-max) '(face))))
1767 ;; mimic <RET> key to repeat previous command in GDB
1768 (if (not (string= "" string))
1769 (setq gdb-last-command string)
1770 (if gdb-last-command (setq string gdb-last-command)))
1771 (if (or (string-match "^-" string)
1772 (> gdb-control-level 0))
1773 ;; Either MI command or we are feeding GDB's recursive reading loop.
1774 (progn
1775 (setq gdb-first-done-or-error t)
1776 (process-send-string proc (concat string "\n"))
1777 (if (and (string-match "^end$" string)
1778 (> gdb-control-level 0))
1779 (setq gdb-control-level (1- gdb-control-level))))
1780 ;; CLI command
1781 (if (string-match "\\\\$" string)
1782 (setq gdb-continuation (concat gdb-continuation string "\n"))
1783 (setq gdb-first-done-or-error t)
1784 (let ((to-send (concat "-interpreter-exec console "
1785 (gdb-mi-quote string)
1786 "\n")))
1787 (if gdb-enable-debug
1788 (push (cons 'mi-send to-send) gdb-debug-log))
1789 (process-send-string proc to-send))
1790 (if (and (string-match "^end$" string)
1791 (> gdb-control-level 0))
1792 (setq gdb-control-level (1- gdb-control-level)))
1793 (setq gdb-continuation nil)))
1794 (if (string-match gdb-control-commands-regexp string)
1795 (setq gdb-control-level (1+ gdb-control-level))))
1796
1797 (defun gdb-mi-quote (string)
1798 "Return STRING quoted properly as an MI argument.
1799 The string is enclosed in double quotes.
1800 All embedded quotes, newlines, and backslashes are preceded with a backslash."
1801 (setq string (replace-regexp-in-string "\\([\"\\]\\)" "\\\\\\&" string))
1802 (setq string (replace-regexp-in-string "\n" "\\n" string t t))
1803 (concat "\"" string "\""))
1804
1805 (defun gdb-input (command handler-function &optional trigger-name)
1806 "Send COMMAND to GDB via the MI interface.
1807 Run the function HANDLER-FUNCTION, with no arguments, once the command is
1808 complete. Do not send COMMAND to GDB if TRIGGER-NAME is non-nil and
1809 Emacs is still waiting for a reply from another command previously
1810 sent with the same TRIGGER-NAME."
1811 (when (or (not trigger-name)
1812 (not (gdb-pending-handler-p trigger-name)))
1813 (setq gdb-token-number (1+ gdb-token-number))
1814 (setq command (concat (number-to-string gdb-token-number) command))
1815
1816 (if gdb-enable-debug (push (list 'send-item command handler-function)
1817 gdb-debug-log))
1818
1819 (gdb-add-handler gdb-token-number handler-function trigger-name)
1820
1821 (if gdbmi-debug-mode (message "gdb-input: %s" command))
1822 (process-send-string (get-buffer-process gud-comint-buffer)
1823 (concat command "\n"))))
1824
1825 ;; NOFRAME is used for gud execution control commands
1826 (defun gdb-current-context-command (command)
1827 "Add --thread to gdb COMMAND when needed."
1828 (if (and gdb-thread-number
1829 gdb-supports-non-stop)
1830 (concat command " --thread " gdb-thread-number)
1831 command))
1832
1833 (defun gdb-current-context-buffer-name (name)
1834 "Add thread information and asterisks to string NAME.
1835
1836 If `gdb-thread-number' is nil, just wrap NAME in asterisks."
1837 (concat "*" name
1838 (if (local-variable-p 'gdb-thread-number)
1839 (format " (bound to thread %s)" gdb-thread-number)
1840 "")
1841 "*"))
1842
1843 (defun gdb-current-context-mode-name (mode)
1844 "Add thread information to MODE which is to be used as `mode-name'."
1845 (concat mode
1846 (if gdb-thread-number
1847 (format " [thread %s]" gdb-thread-number)
1848 "")))
1849 \f
1850
1851 (defcustom gud-gdb-command-name "gdb -i=mi"
1852 "Default command to execute an executable under the GDB debugger."
1853 :type 'string
1854 :group 'gdb)
1855
1856 (defun gdb-resync()
1857 (setq gud-running nil)
1858 (setq gdb-output-sink 'user)
1859 (gdb-remove-all-pending-triggers))
1860
1861 (defun gdb-update (&optional no-proc)
1862 "Update buffers showing status of debug session.
1863 If NO-PROC is non-nil, do not try to contact the GDB process."
1864 (when gdb-first-prompt
1865 (gdb-force-mode-line-update
1866 (propertize "initializing..." 'face font-lock-variable-name-face))
1867 (gdb-init-1)
1868 (setq gdb-first-prompt nil))
1869
1870 (unless no-proc
1871 (gdb-get-main-selected-frame))
1872
1873 ;; We may need to update gdb-threads-list so we can use
1874 (gdb-get-buffer-create 'gdb-threads-buffer)
1875 ;; gdb-break-list is maintained in breakpoints handler
1876 (gdb-get-buffer-create 'gdb-breakpoints-buffer)
1877
1878 (unless no-proc
1879 (gdb-emit-signal gdb-buf-publisher 'update))
1880
1881 (gdb-get-changed-registers)
1882 (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
1883 (dolist (var gdb-var-list)
1884 (setcar (nthcdr 5 var) nil))
1885 (gdb-var-update)))
1886
1887 ;; gdb-setq-thread-number and gdb-update-gud-running are decoupled
1888 ;; because we may need to update current gud-running value without
1889 ;; changing current thread (see gdb-running)
1890 (defun gdb-setq-thread-number (number)
1891 "Set `gdb-thread-number' to NUMBER.
1892 Only this function must be used to change `gdb-thread-number'
1893 value to NUMBER, because `gud-running' and `gdb-frame-number'
1894 need to be updated appropriately when current thread changes."
1895 ;; GDB 6.8 and earlier always output thread-id="0" when stopping.
1896 (unless (string-equal number "0") (setq gdb-thread-number number))
1897 (setq gdb-frame-number "0")
1898 (gdb-update-gud-running))
1899
1900 (defun gdb-update-gud-running ()
1901 "Set `gud-running' according to the state of current thread.
1902
1903 `gdb-frame-number' is set to 0 if current thread is now stopped.
1904
1905 Note that when `gdb-gud-control-all-threads' is t, `gud-running'
1906 cannot be reliably used to determine whether or not execution
1907 control buttons should be shown in menu or toolbar. Use
1908 `gdb-running-threads-count' and `gdb-stopped-threads-count'
1909 instead.
1910
1911 For all-stop mode, thread information is unavailable while target
1912 is running."
1913 (let ((old-value gud-running))
1914 (setq gud-running
1915 (string= (bindat-get-field (gdb-current-buffer-thread) 'state)
1916 "running"))
1917 ;; Set frame number to "0" when _current_ threads stops.
1918 (when (and (gdb-current-buffer-thread)
1919 (not (eq gud-running old-value)))
1920 (setq gdb-frame-number "0"))))
1921
1922 (defun gdb-show-run-p ()
1923 "Return t if \"Run/continue\" should be shown on the toolbar."
1924 (or (not gdb-active-process)
1925 (and (or
1926 (not gdb-gud-control-all-threads)
1927 (not gdb-non-stop))
1928 (not gud-running))
1929 (and gdb-gud-control-all-threads
1930 (> gdb-stopped-threads-count 0))))
1931
1932 (defun gdb-show-stop-p ()
1933 "Return t if \"Stop\" should be shown on the toolbar."
1934 (or (and (or
1935 (not gdb-gud-control-all-threads)
1936 (not gdb-non-stop))
1937 gud-running)
1938 (and gdb-gud-control-all-threads
1939 (> gdb-running-threads-count 0))))
1940
1941 ;; GUD displays the selected GDB frame. This might might not be the current
1942 ;; GDB frame (after up, down etc). If no GDB frame is visible but the last
1943 ;; visited breakpoint is, use that window.
1944 (defun gdb-display-source-buffer (buffer)
1945 (let* ((last-window (if gud-last-last-frame
1946 (get-buffer-window
1947 (gud-find-file (car gud-last-last-frame)))))
1948 (source-window (or last-window
1949 (if (and gdb-source-window
1950 (window-live-p gdb-source-window))
1951 gdb-source-window))))
1952 (when source-window
1953 (setq gdb-source-window source-window)
1954 (set-window-buffer source-window buffer))
1955 source-window))
1956
1957
1958 (defun gdbmi-start-with (str offset match)
1959 "Return non-nil if string STR starts with MATCH, else returns nil.
1960 OFFSET is the position in STR at which the comparison takes place."
1961 (let ((match-length (length match))
1962 (str-length (- (length str) offset)))
1963 (when (>= str-length match-length)
1964 (string-equal match (substring str offset (+ offset match-length))))))
1965
1966 (defun gdbmi-same-start (str offset match)
1967 "Return non-nil iff STR and MATCH are equal up to the end of either strings.
1968 OFFSET is the position in STR at which the comparison takes place."
1969 (let* ((str-length (- (length str) offset))
1970 (match-length (length match))
1971 (compare-length (min str-length match-length)))
1972 (when (> compare-length 0)
1973 (string-equal (substring str offset (+ offset compare-length))
1974 (substring match 0 compare-length)))))
1975
1976 (defun gdbmi-is-number (character)
1977 "Return non-nil iff CHARACTER is a numerical character between 0 and 9."
1978 (and (>= character ?0)
1979 (<= character ?9)))
1980
1981
1982 (defvar-local gdbmi-bnf-state 'gdbmi-bnf-output
1983 "Current GDB/MI output parser state.
1984 The parser is placed in a different state when an incomplete data steam is
1985 received from GDB.
1986 This variable will preserve the state required to resume the parsing
1987 when more data arrives.")
1988
1989 (defvar-local gdbmi-bnf-offset 0
1990 "Offset in `gud-marker-acc' at which the parser is reading.
1991 This offset is used to be able to parse the GDB/MI message
1992 in-place, without the need of copying the string in a temporary buffer
1993 or discarding parsed tokens by substringing the message.")
1994
1995 (defun gdbmi-bnf-init ()
1996 "Initialize the GDB/MI message parser."
1997 (setq gdbmi-bnf-state 'gdbmi-bnf-output)
1998 (setq gdbmi-bnf-offset 0)
1999 (setq gud-marker-acc ""))
2000
2001
2002 (defun gdbmi-bnf-output ()
2003 "Implementation of the following GDB/MI output grammar rule:
2004
2005 output ==>
2006 ( out-of-band-record )* [ result-record ] gdb-prompt"
2007
2008 (gdbmi-bnf-skip-unrecognized)
2009 (while (gdbmi-bnf-out-of-band-record))
2010 (gdbmi-bnf-result-record)
2011 (gdbmi-bnf-gdb-prompt))
2012
2013
2014 (defun gdbmi-bnf-skip-unrecognized ()
2015 "Skip characters until is encounters the beginning of a valid record.
2016 Used as a protection mechanism in case something goes wrong when parsing
2017 a GDB/MI reply message."
2018 (let ((acc-length (length gud-marker-acc))
2019 (prefix-offset gdbmi-bnf-offset)
2020 (prompt "(gdb) \n"))
2021
2022 (while (and (< prefix-offset acc-length)
2023 (gdbmi-is-number (aref gud-marker-acc prefix-offset)))
2024 (setq prefix-offset (1+ prefix-offset)))
2025
2026 (if (and (< prefix-offset acc-length)
2027 (not (memq (aref gud-marker-acc prefix-offset)
2028 '(?^ ?* ?+ ?= ?~ ?@ ?&)))
2029 (not (gdbmi-same-start gud-marker-acc gdbmi-bnf-offset prompt))
2030 (string-match "\\([^^*+=~@&]+\\)" gud-marker-acc
2031 gdbmi-bnf-offset))
2032 (let ((unrecognized-str (match-string 0 gud-marker-acc)))
2033 (setq gdbmi-bnf-offset (match-end 0))
2034 (if gdbmi-debug-mode
2035 (message "gdbmi-bnf-skip-unrecognized: %s" unrecognized-str))
2036 (gdb-shell unrecognized-str)
2037 t))))
2038
2039
2040 (defun gdbmi-bnf-gdb-prompt ()
2041 "Implementation of the following GDB/MI output grammar rule:
2042 gdb-prompt ==>
2043 '(gdb)' nl
2044
2045 nl ==>
2046 CR | CR-LF"
2047
2048 (let ((prompt "(gdb) \n"))
2049 (when (gdbmi-start-with gud-marker-acc gdbmi-bnf-offset prompt)
2050 (if gdbmi-debug-mode (message "gdbmi-bnf-gdb-prompt: %s" prompt))
2051 (gdb-gdb prompt)
2052 (setq gdbmi-bnf-offset (+ gdbmi-bnf-offset (length prompt)))
2053
2054 ;; Returns non-nil to tell gud-gdbmi-marker-filter we've reached
2055 ;; the end of a GDB reply message.
2056 t)))
2057
2058
2059 (defun gdbmi-bnf-result-record ()
2060 "Implementation of the following GDB/MI output grammar rule:
2061
2062 result-record ==>
2063 [ token ] '^' result-class ( ',' result )* nl
2064
2065 token ==>
2066 any sequence of digits."
2067
2068 (gdbmi-bnf-result-and-async-record-impl))
2069
2070
2071 (defun gdbmi-bnf-out-of-band-record ()
2072 "Implementation of the following GDB/MI output grammar rule:
2073
2074 out-of-band-record ==>
2075 async-record | stream-record"
2076
2077 (or (gdbmi-bnf-async-record)
2078 (gdbmi-bnf-stream-record)))
2079
2080
2081 (defun gdbmi-bnf-async-record ()
2082 "Implementation of the following GDB/MI output grammar rules:
2083
2084 async-record ==>
2085 exec-async-output | status-async-output | notify-async-output
2086
2087 exec-async-output ==>
2088 [ token ] '*' async-output
2089
2090 status-async-output ==>
2091 [ token ] '+' async-output
2092
2093 notify-async-output ==>
2094 [ token ] '=' async-output
2095
2096 async-output ==>
2097 async-class ( ',' result )* nl"
2098
2099 (gdbmi-bnf-result-and-async-record-impl))
2100
2101
2102 (defun gdbmi-bnf-stream-record ()
2103 "Implement the following GDB/MI output grammar rule:
2104 stream-record ==>
2105 console-stream-output | target-stream-output | log-stream-output
2106
2107 console-stream-output ==>
2108 '~' c-string
2109
2110 target-stream-output ==>
2111 '@' c-string
2112
2113 log-stream-output ==>
2114 '&' c-string"
2115 (when (< gdbmi-bnf-offset (length gud-marker-acc))
2116 (if (and (member (aref gud-marker-acc gdbmi-bnf-offset) '(?~ ?@ ?&))
2117 (string-match "\\([~@&]\\)\\(\".*?\"\\)\n" gud-marker-acc
2118 gdbmi-bnf-offset))
2119 (let ((prefix (match-string 1 gud-marker-acc))
2120 (c-string (match-string 2 gud-marker-acc)))
2121
2122 (setq gdbmi-bnf-offset (match-end 0))
2123 (if gdbmi-debug-mode (message "gdbmi-bnf-stream-record: %s"
2124 (match-string 0 gud-marker-acc)))
2125
2126 (cond ((string-equal prefix "~")
2127 (gdbmi-bnf-console-stream-output c-string))
2128 ((string-equal prefix "@")
2129 (gdbmi-bnf-target-stream-output c-string))
2130 ((string-equal prefix "&")
2131 (gdbmi-bnf-log-stream-output c-string)))
2132 t))))
2133
2134 (defun gdbmi-bnf-console-stream-output (c-string)
2135 "Handler for the console-stream-output GDB/MI output grammar rule."
2136 (gdb-console c-string))
2137
2138 (defun gdbmi-bnf-target-stream-output (_c-string)
2139 "Handler for the target-stream-output GDB/MI output grammar rule."
2140 ;; Not currently used.
2141 )
2142
2143 (defun gdbmi-bnf-log-stream-output (c-string)
2144 "Handler for the log-stream-output GDB/MI output grammar rule."
2145 ;; Suppress "No registers." GDB 6.8 and earlier
2146 ;; duplicates MI error message on internal stream.
2147 ;; Don't print to GUD buffer.
2148 (if (not (string-equal (read c-string) "No registers.\n"))
2149 (gdb-internals c-string)))
2150
2151
2152 (defconst gdbmi-bnf-result-state-configs
2153 '(("^" . (("done" . (gdb-done . progressive))
2154 ("error" . (gdb-error . progressive))
2155 ("running" . (gdb-starting . atomic))))
2156 ("*" . (("stopped" . (gdb-stopped . atomic))
2157 ("running" . (gdb-running . atomic))))
2158 ("+" . ())
2159 ("=" . (("thread-created" . (gdb-thread-created . atomic))
2160 ("thread-selected" . (gdb-thread-selected . atomic))
2161 ("thread-existed" . (gdb-ignored-notification . atomic))
2162 ('default . (gdb-ignored-notification . atomic)))))
2163 "Alist of alists, mapping the type and class of message to a handler function.
2164 Handler functions are all flagged as either `progressive' or `atomic'.
2165 `progressive' handlers are capable of parsing incomplete messages.
2166 They can be called several time with new data chunk as they arrive from GDB.
2167 `progressive' handlers must have an extra argument that is set to a non-nil
2168 value when the message is complete.
2169
2170 Implement the following GDB/MI output grammar rule:
2171 result-class ==>
2172 'done' | 'running' | 'connected' | 'error' | 'exit'
2173
2174 async-class ==>
2175 'stopped' | others (where others will be added depending on the needs
2176 --this is still in development).")
2177
2178 (defun gdbmi-bnf-result-and-async-record-impl ()
2179 "Common implementation of the result-record and async-record rule.
2180 Both rules share the same syntax. Those records may be very large in size.
2181 For that reason, the \"result\" part of the record is parsed by
2182 `gdbmi-bnf-incomplete-record-result', which will keep
2183 receiving characters as they arrive from GDB until the record is complete."
2184 (let ((acc-length (length gud-marker-acc))
2185 (prefix-offset gdbmi-bnf-offset))
2186
2187 (while (and (< prefix-offset acc-length)
2188 (gdbmi-is-number (aref gud-marker-acc prefix-offset)))
2189 (setq prefix-offset (1+ prefix-offset)))
2190
2191 (if (and (< prefix-offset acc-length)
2192 (member (aref gud-marker-acc prefix-offset) '(?* ?+ ?= ?^))
2193 (string-match "\\([0-9]*\\)\\([*+=^]\\)\\(.+?\\)\\([,\n]\\)"
2194 gud-marker-acc gdbmi-bnf-offset))
2195
2196 (let ((token (match-string 1 gud-marker-acc))
2197 (prefix (match-string 2 gud-marker-acc))
2198 (class (match-string 3 gud-marker-acc))
2199 (complete (string-equal (match-string 4 gud-marker-acc) "\n"))
2200 class-alist
2201 class-command)
2202
2203 (setq gdbmi-bnf-offset (match-end 0))
2204 (if gdbmi-debug-mode (message "gdbmi-bnf-result-record: %s"
2205 (match-string 0 gud-marker-acc)))
2206
2207 (setq class-alist
2208 (cdr (assoc prefix gdbmi-bnf-result-state-configs)))
2209 (setq class-command (cdr (assoc class class-alist)))
2210 (if (null class-command)
2211 (setq class-command (cdr (assoc 'default class-alist))))
2212
2213 (if complete
2214 (if class-command
2215 (if (equal (cdr class-command) 'progressive)
2216 (funcall (car class-command) token "" complete)
2217 (funcall (car class-command) token "")))
2218 (setq gdbmi-bnf-state
2219 (lambda ()
2220 (gdbmi-bnf-incomplete-record-result token class-command)))
2221 (funcall gdbmi-bnf-state))
2222 t))))
2223
2224 (defun gdbmi-bnf-incomplete-record-result (token class-command)
2225 "State of the parser used to progressively parse a result-record or async-record
2226 rule from an incomplete data stream. The parser will stay in this state until
2227 the end of the current result or async record is reached."
2228 (when (< gdbmi-bnf-offset (length gud-marker-acc))
2229 ;; Search the data stream for the end of the current record:
2230 (let* ((newline-pos (string-match "\n" gud-marker-acc gdbmi-bnf-offset))
2231 (is-progressive (equal (cdr class-command) 'progressive))
2232 (is-complete (not (null newline-pos)))
2233 result-str)
2234
2235 (when gdbmi-debug-mode
2236 (message "gdbmi-bnf-incomplete-record-result: %s"
2237 (substring gud-marker-acc gdbmi-bnf-offset newline-pos)))
2238
2239 ;; Update the gdbmi-bnf-offset only if the current chunk of data can
2240 ;; be processed by the class-command handler:
2241 (when (or is-complete is-progressive)
2242 (setq result-str
2243 (substring gud-marker-acc gdbmi-bnf-offset newline-pos))
2244
2245 ;; Move gdbmi-bnf-offset past the end of the chunk.
2246 (setq gdbmi-bnf-offset (+ gdbmi-bnf-offset (length result-str)))
2247 (when newline-pos
2248 (setq gdbmi-bnf-offset (1+ gdbmi-bnf-offset))))
2249
2250 ;; Update the parsing state before invoking the handler in class-command
2251 ;; to make sure it's not left in an invalid state if the handler was
2252 ;; to generate an error.
2253 (if is-complete
2254 (setq gdbmi-bnf-state 'gdbmi-bnf-output))
2255
2256 (if class-command
2257 (if is-progressive
2258 (funcall (car class-command) token result-str is-complete)
2259 (if is-complete
2260 (funcall (car class-command) token result-str))))
2261
2262 (unless is-complete
2263 ;; Incomplete gdb response: abort parsing until we receive more data.
2264 (if gdbmi-debug-mode (message "gdbmi-bnf-incomplete-record-result, aborting: incomplete stream"))
2265 (throw 'gdbmi-incomplete-stream nil))
2266
2267 is-complete)))
2268
2269
2270 ; The following grammar rules are not yet implemented by this GDBMI-BNF parser.
2271 ; The handling of those rules is currently done by the handlers registered
2272 ; in gdbmi-bnf-result-state-configs
2273 ;
2274 ; result ==>
2275 ; variable "=" value
2276 ;
2277 ; variable ==>
2278 ; string
2279 ;
2280 ; value ==>
2281 ; const | tuple | list
2282 ;
2283 ; const ==>
2284 ; c-string
2285 ;
2286 ; tuple ==>
2287 ; "{}" | "{" result ( "," result )* "}"
2288 ;
2289 ; list ==>
2290 ; "[]" | "[" value ( "," value )* "]" | "[" result ( "," result )* "]"
2291
2292
2293 (defun gud-gdbmi-marker-filter (string)
2294 "Filter GDB/MI output."
2295
2296 ;; Record transactions if logging is enabled.
2297 (when gdb-enable-debug
2298 (push (cons 'recv string) gdb-debug-log)
2299 (if (and gdb-debug-log-max
2300 (> (length gdb-debug-log) gdb-debug-log-max))
2301 (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil)))
2302
2303 ;; Recall the left over gud-marker-acc from last time.
2304 (setq gud-marker-acc (concat gud-marker-acc string))
2305
2306 ;; Start accumulating output for the GUD buffer.
2307 (setq gdb-filter-output "")
2308
2309 (let ((acc-length (length gud-marker-acc)))
2310 (catch 'gdbmi-incomplete-stream
2311 (while (and (< gdbmi-bnf-offset acc-length)
2312 (funcall gdbmi-bnf-state)))))
2313
2314 (when (/= gdbmi-bnf-offset 0)
2315 (setq gud-marker-acc (substring gud-marker-acc gdbmi-bnf-offset))
2316 (setq gdbmi-bnf-offset 0))
2317
2318 (when (and gdbmi-debug-mode (> (length gud-marker-acc) 0))
2319 (message "gud-gdbmi-marker-filter, unparsed string: %s" gud-marker-acc))
2320
2321 gdb-filter-output)
2322
2323 (defun gdb-gdb (_output-field))
2324
2325 (defun gdb-shell (output-field)
2326 (setq gdb-filter-output
2327 (concat output-field gdb-filter-output)))
2328
2329 (defun gdb-ignored-notification (_token _output-field))
2330
2331 ;; gdb-invalidate-threads is defined to accept 'update-threads signal
2332 (defun gdb-thread-created (_token _output-field))
2333 (defun gdb-thread-exited (_token output-field)
2334 "Handle =thread-exited async record.
2335 Unset `gdb-thread-number' if current thread exited and update threads list."
2336 (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'id)))
2337 (if (string= gdb-thread-number thread-id)
2338 (gdb-setq-thread-number nil))
2339 ;; When we continue current thread and it quickly exits,
2340 ;; the pending triggers in gdb-handler-list left after gdb-running
2341 ;; disallow us to properly call -thread-info without --thread option.
2342 ;; Thus we need to use gdb-wait-for-pending.
2343 (gdb-wait-for-pending
2344 (gdb-emit-signal gdb-buf-publisher 'update-threads))))
2345
2346 (defun gdb-thread-selected (_token output-field)
2347 "Handler for =thread-selected MI output record.
2348
2349 Sets `gdb-thread-number' to new id."
2350 (let* ((result (gdb-json-string output-field))
2351 (thread-id (bindat-get-field result 'id)))
2352 (gdb-setq-thread-number thread-id)
2353 ;; Typing `thread N` in GUD buffer makes GDB emit `^done` followed
2354 ;; by `=thread-selected` notification. `^done` causes `gdb-update`
2355 ;; as usually. Things happen to fast and second call (from
2356 ;; gdb-thread-selected handler) gets cut off by our beloved
2357 ;; pending triggers.
2358 ;; Solution is `gdb-wait-for-pending' macro: it guarantees that its
2359 ;; body will get executed when `gdb-handler-list' if free of
2360 ;; pending triggers.
2361 (gdb-wait-for-pending
2362 (gdb-update))))
2363
2364 (defun gdb-running (_token output-field)
2365 (let* ((thread-id
2366 (bindat-get-field (gdb-json-string output-field) 'thread-id)))
2367 ;; We reset gdb-frame-number to nil if current thread has gone
2368 ;; running. This can't be done in gdb-thread-list-handler-custom
2369 ;; because we need correct gdb-frame-number by the time
2370 ;; -thread-info command is sent.
2371 (when (or (string-equal thread-id "all")
2372 (string-equal thread-id gdb-thread-number))
2373 (setq gdb-frame-number nil)))
2374 (setq gdb-inferior-status "running")
2375 (gdb-force-mode-line-update
2376 (propertize gdb-inferior-status 'face font-lock-type-face))
2377 (when (not gdb-non-stop)
2378 (setq gud-running t))
2379 (setq gdb-active-process t))
2380
2381 (defun gdb-starting (_output-field _result)
2382 ;; CLI commands don't emit ^running at the moment so use gdb-running too.
2383 (setq gdb-inferior-status "running")
2384 (gdb-force-mode-line-update
2385 (propertize gdb-inferior-status 'face font-lock-type-face))
2386 (setq gdb-active-process t)
2387 (setq gud-running t))
2388
2389 ;; -break-insert -t didn't give a reason before gdb 6.9
2390
2391 (defun gdb-stopped (_token output-field)
2392 "Given the contents of *stopped MI async record, select new
2393 current thread and update GDB buffers."
2394 ;; Reason is available with target-async only
2395 (let* ((result (gdb-json-string output-field))
2396 (reason (bindat-get-field result 'reason))
2397 (thread-id (bindat-get-field result 'thread-id)))
2398
2399 ;; -data-list-register-names needs to be issued for any stopped
2400 ;; thread
2401 (when (not gdb-register-names)
2402 (gdb-input (concat "-data-list-register-names"
2403 (if gdb-supports-non-stop
2404 (concat " --thread " thread-id)))
2405 'gdb-register-names-handler))
2406
2407 ;; Don't set gud-last-frame here as it's currently done in
2408 ;; gdb-frame-handler because synchronous GDB doesn't give these fields
2409 ;; with CLI.
2410 ;;(when file
2411 ;; (setq
2412 ;; ;; Extract the frame position from the marker.
2413 ;; gud-last-frame (cons file
2414 ;; (string-to-number
2415 ;; (match-string 6 gud-marker-acc)))))
2416
2417 (setq gdb-inferior-status (or reason "unknown"))
2418 (gdb-force-mode-line-update
2419 (propertize gdb-inferior-status 'face font-lock-warning-face))
2420 (if (string-equal reason "exited-normally")
2421 (setq gdb-active-process nil))
2422
2423 ;; Select new current thread.
2424
2425 ;; Don't switch if we have no reasons selected
2426 (when gdb-switch-reasons
2427 ;; Switch from another stopped thread only if we have
2428 ;; gdb-switch-when-another-stopped:
2429 (when (or gdb-switch-when-another-stopped
2430 (not (string= "stopped"
2431 (bindat-get-field (gdb-current-buffer-thread) 'state))))
2432 ;; Switch if current reason has been selected or we have no
2433 ;; reasons
2434 (if (or (eq gdb-switch-reasons t)
2435 (member reason gdb-switch-reasons))
2436 (when (not (string-equal gdb-thread-number thread-id))
2437 (message (concat "Switched to thread " thread-id))
2438 (gdb-setq-thread-number thread-id))
2439 (message (format "Thread %s stopped" thread-id)))))
2440
2441 ;; Print "(gdb)" to GUD console
2442 (when gdb-first-done-or-error
2443 (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
2444
2445 ;; In non-stop, we update information as soon as another thread gets
2446 ;; stopped
2447 (when (or gdb-first-done-or-error
2448 gdb-non-stop)
2449 ;; In all-stop this updates gud-running properly as well.
2450 (gdb-update)
2451 (setq gdb-first-done-or-error nil))
2452 (run-hook-with-args 'gdb-stopped-functions result)))
2453
2454 ;; Remove the trimmings from log stream containing debugging messages
2455 ;; being produced by GDB's internals, use warning face and send to GUD
2456 ;; buffer.
2457 (defun gdb-internals (output-field)
2458 (setq gdb-filter-output
2459 (gdb-concat-output
2460 gdb-filter-output
2461 (if (string= output-field "\"\\n\"")
2462 ""
2463 (let ((error-message
2464 (read output-field)))
2465 (put-text-property
2466 0 (length error-message)
2467 'face font-lock-warning-face
2468 error-message)
2469 error-message)))))
2470
2471 ;; Remove the trimmings from the console stream and send to GUD buffer
2472 ;; (frontend MI commands should not print to this stream)
2473 (defun gdb-console (output-field)
2474 (setq gdb-filter-output
2475 (gdb-concat-output gdb-filter-output (read output-field))))
2476
2477 (defun gdb-done (token-number output-field is-complete)
2478 (gdb-done-or-error token-number 'done output-field is-complete))
2479
2480 (defun gdb-error (token-number output-field is-complete)
2481 (gdb-done-or-error token-number 'error output-field is-complete))
2482
2483 (defun gdb-done-or-error (token-number type output-field is-complete)
2484 (if (string-equal token-number "")
2485 ;; Output from command entered by user
2486 (progn
2487 (setq gdb-output-sink 'user)
2488 (setq token-number nil)
2489 ;; MI error - send to minibuffer
2490 (when (eq type 'error)
2491 ;; Skip "msg=" from `output-field'
2492 (message (read (substring output-field 4)))
2493 ;; Don't send to the console twice. (If it is a console error
2494 ;; it is also in the console stream.)
2495 (setq output-field nil)))
2496 ;; Output from command from frontend.
2497 (setq gdb-output-sink 'emacs))
2498
2499 ;; The process may already be dead (e.g. C-d at the gdb prompt).
2500 (let* ((proc (get-buffer-process gud-comint-buffer))
2501 (no-proc (or (null proc)
2502 (memq (process-status proc) '(exit signal)))))
2503
2504 (when (and is-complete gdb-first-done-or-error)
2505 (unless (or token-number gud-running no-proc)
2506 (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
2507 (gdb-update no-proc)
2508 (setq gdb-first-done-or-error nil))
2509
2510 (setq gdb-filter-output
2511 (gdb-concat-output gdb-filter-output output-field))
2512
2513 ;; We are done concatenating to the output sink. Restore it to user sink:
2514 (setq gdb-output-sink 'user)
2515
2516 (when (and token-number is-complete)
2517 (with-current-buffer
2518 (gdb-get-buffer-create 'gdb-partial-output-buffer)
2519 (gdb-handle-reply (string-to-number token-number))))
2520
2521 (when is-complete
2522 (gdb-clear-partial-output))))
2523
2524 (defun gdb-concat-output (so-far new)
2525 (cond
2526 ((eq gdb-output-sink 'user) (concat so-far new))
2527 ((eq gdb-output-sink 'emacs)
2528 (gdb-append-to-partial-output new)
2529 so-far)))
2530
2531 (defun gdb-append-to-partial-output (string)
2532 (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
2533 (goto-char (point-max))
2534 (insert string)))
2535
2536 (defun gdb-clear-partial-output ()
2537 (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
2538 (erase-buffer)))
2539
2540 (defun gdb-jsonify-buffer (&optional fix-key fix-list)
2541 "Prepare GDB/MI output in current buffer for parsing with `json-read'.
2542
2543 Field names are wrapped in double quotes and equal signs are
2544 replaced with semicolons.
2545
2546 If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurrences from
2547 partial output. This is used to get rid of useless keys in lists
2548 in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and
2549 -break-info are examples of MI commands which issue such
2550 responses.
2551
2552 If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with
2553 \"FIX-LIST=[..]\" prior to parsing. This is used to fix broken
2554 -break-info output when it contains breakpoint script field
2555 incompatible with GDB/MI output syntax."
2556 (save-excursion
2557 (goto-char (point-min))
2558 (when fix-key
2559 (save-excursion
2560 (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t)
2561 (replace-match "" nil nil nil 1))))
2562 (when fix-list
2563 (save-excursion
2564 ;; Find positions of braces which enclose broken list
2565 (while (re-search-forward (concat fix-list "={\"") nil t)
2566 (let ((p1 (goto-char (- (point) 2)))
2567 (p2 (progn (forward-sexp)
2568 (1- (point)))))
2569 ;; Replace braces with brackets
2570 (save-excursion
2571 (goto-char p1)
2572 (delete-char 1)
2573 (insert "[")
2574 (goto-char p2)
2575 (delete-char 1)
2576 (insert "]"))))))
2577 (goto-char (point-min))
2578 (insert "{")
2579 (while (re-search-forward
2580 "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t)
2581 (replace-match "\"\\1\":\\2" nil nil))
2582 (goto-char (point-max))
2583 (insert "}")))
2584
2585 (defun gdb-json-read-buffer (&optional fix-key fix-list)
2586 "Prepare and parse GDB/MI output in current buffer with `json-read'.
2587
2588 FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'."
2589 (gdb-jsonify-buffer fix-key fix-list)
2590 (save-excursion
2591 (goto-char (point-min))
2592 (let ((json-array-type 'list))
2593 (json-read))))
2594
2595 (defun gdb-json-string (string &optional fix-key fix-list)
2596 "Prepare and parse STRING containing GDB/MI output with `json-read'.
2597
2598 FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'."
2599 (with-temp-buffer
2600 (insert string)
2601 (gdb-json-read-buffer fix-key fix-list)))
2602
2603 (defun gdb-json-partial-output (&optional fix-key fix-list)
2604 "Prepare and parse gdb-partial-output-buffer with `json-read'.
2605
2606 FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'."
2607 (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
2608 (gdb-json-read-buffer fix-key fix-list)))
2609
2610 (defun gdb-line-posns (line)
2611 "Return a pair of LINE beginning and end positions."
2612 (let ((offset (1+ (- line (line-number-at-pos)))))
2613 (cons
2614 (line-beginning-position offset)
2615 (line-end-position offset))))
2616
2617 (defmacro gdb-mark-line (line variable)
2618 "Set VARIABLE marker to point at beginning of LINE.
2619
2620 If current window has no fringes, inverse colors on LINE.
2621
2622 Return position where LINE begins."
2623 `(save-excursion
2624 (let* ((posns (gdb-line-posns ,line))
2625 (start-posn (car posns))
2626 (end-posn (cdr posns)))
2627 (set-marker ,variable (copy-marker start-posn))
2628 (when (not (> (car (window-fringes)) 0))
2629 (put-text-property start-posn end-posn
2630 'font-lock-face '(:inverse-video t)))
2631 start-posn)))
2632
2633 (defun gdb-pad-string (string padding)
2634 (format (concat "%" (number-to-string padding) "s") string))
2635
2636 ;; gdb-table struct is a way to programmatically construct simple
2637 ;; tables. It help to reliably align columns of data in GDB buffers
2638 ;; and provides
2639 (cl-defstruct gdb-table
2640 (column-sizes nil)
2641 (rows nil)
2642 (row-properties nil)
2643 (right-align nil))
2644
2645 (defun gdb-table-add-row (table row &optional properties)
2646 "Add ROW of string to TABLE and recalculate column sizes.
2647
2648 When non-nil, PROPERTIES will be added to the whole row when
2649 calling `gdb-table-string'."
2650 (let ((rows (gdb-table-rows table))
2651 (row-properties (gdb-table-row-properties table))
2652 (column-sizes (gdb-table-column-sizes table))
2653 (right-align (gdb-table-right-align table)))
2654 (when (not column-sizes)
2655 (setf (gdb-table-column-sizes table)
2656 (make-list (length row) 0)))
2657 (setf (gdb-table-rows table)
2658 (append rows (list row)))
2659 (setf (gdb-table-row-properties table)
2660 (append row-properties (list properties)))
2661 (setf (gdb-table-column-sizes table)
2662 (cl-mapcar (lambda (x s)
2663 (let ((new-x
2664 (max (abs x) (string-width (or s "")))))
2665 (if right-align new-x (- new-x))))
2666 (gdb-table-column-sizes table)
2667 row))
2668 ;; Avoid trailing whitespace at eol
2669 (if (not (gdb-table-right-align table))
2670 (setcar (last (gdb-table-column-sizes table)) 0))))
2671
2672 (defun gdb-table-string (table &optional sep)
2673 "Return TABLE as a string with columns separated with SEP."
2674 (let ((column-sizes (gdb-table-column-sizes table)))
2675 (mapconcat
2676 'identity
2677 (cl-mapcar
2678 (lambda (row properties)
2679 (apply 'propertize
2680 (mapconcat 'identity
2681 (cl-mapcar (lambda (s x) (gdb-pad-string s x))
2682 row column-sizes)
2683 sep)
2684 properties))
2685 (gdb-table-rows table)
2686 (gdb-table-row-properties table))
2687 "\n")))
2688
2689 ;; bindat-get-field goes deep, gdb-get-many-fields goes wide
2690 (defun gdb-get-many-fields (struct &rest fields)
2691 "Return a list of FIELDS values from STRUCT."
2692 (let ((values))
2693 (dolist (field fields)
2694 (push (bindat-get-field struct field) values))
2695 (nreverse values)))
2696
2697 (defmacro def-gdb-auto-update-trigger (trigger-name gdb-command
2698 handler-name
2699 &optional signal-list)
2700 "Define a trigger TRIGGER-NAME which sends GDB-COMMAND and sets
2701 HANDLER-NAME as its handler. HANDLER-NAME is bound to current
2702 buffer with `gdb-bind-function-to-buffer'.
2703
2704 If SIGNAL-LIST is non-nil, GDB-COMMAND is sent only when the
2705 defined trigger is called with an argument from SIGNAL-LIST. It's
2706 not recommended to define triggers with empty SIGNAL-LIST.
2707 Normally triggers should respond at least to 'update signal.
2708
2709 Normally the trigger defined by this command must be called from
2710 the buffer where HANDLER-NAME must work. This should be done so
2711 that buffer-local thread number may be used in GDB-COMMAND (by
2712 calling `gdb-current-context-command').
2713 `gdb-bind-function-to-buffer' is used to achieve this, see
2714 `gdb-get-buffer-create'.
2715
2716 Triggers defined by this command are meant to be used as a
2717 trigger argument when describing buffer types with
2718 `gdb-set-buffer-rules'."
2719 `(defun ,trigger-name (&optional signal)
2720 (when
2721 (or (not ,signal-list)
2722 (memq signal ,signal-list))
2723 (gdb-input ,gdb-command
2724 (gdb-bind-function-to-buffer ',handler-name (current-buffer))
2725 (cons (current-buffer) ',trigger-name)))))
2726
2727 ;; Used by disassembly buffer only, the rest use
2728 ;; def-gdb-trigger-and-handler
2729 (defmacro def-gdb-auto-update-handler (handler-name custom-defun
2730 &optional nopreserve)
2731 "Define a handler HANDLER-NAME calling CUSTOM-DEFUN.
2732
2733 Handlers are normally called from the buffers they put output in.
2734
2735 Erase current buffer and evaluate CUSTOM-DEFUN.
2736 Then call `gdb-update-buffer-name'.
2737
2738 If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN."
2739 `(defun ,handler-name ()
2740 (let* ((inhibit-read-only t)
2741 ,@(unless nopreserve
2742 '((window (get-buffer-window (current-buffer) 0))
2743 (start (window-start window))
2744 (p (window-point window)))))
2745 (erase-buffer)
2746 (,custom-defun)
2747 (gdb-update-buffer-name)
2748 ,@(when (not nopreserve)
2749 '((set-window-start window start)
2750 (set-window-point window p))))))
2751
2752 (defmacro def-gdb-trigger-and-handler (trigger-name gdb-command
2753 handler-name custom-defun
2754 &optional signal-list)
2755 "Define trigger and handler.
2756
2757 TRIGGER-NAME trigger is defined to send GDB-COMMAND.
2758 See `def-gdb-auto-update-trigger'.
2759
2760 HANDLER-NAME handler uses customization of CUSTOM-DEFUN.
2761 See `def-gdb-auto-update-handler'."
2762 `(progn
2763 (def-gdb-auto-update-trigger ,trigger-name
2764 ,gdb-command
2765 ,handler-name ,signal-list)
2766 (def-gdb-auto-update-handler ,handler-name
2767 ,custom-defun)))
2768
2769 \f
2770
2771 ;; Breakpoint buffer : This displays the output of `-break-list'.
2772 (def-gdb-trigger-and-handler
2773 gdb-invalidate-breakpoints "-break-list"
2774 gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom
2775 '(start update))
2776
2777 (gdb-set-buffer-rules
2778 'gdb-breakpoints-buffer
2779 'gdb-breakpoints-buffer-name
2780 'gdb-breakpoints-mode
2781 'gdb-invalidate-breakpoints)
2782
2783 (defun gdb-breakpoints-list-handler-custom ()
2784 (let ((breakpoints-list (bindat-get-field
2785 (gdb-json-partial-output "bkpt" "script")
2786 'BreakpointTable 'body))
2787 (table (make-gdb-table)))
2788 (setq gdb-breakpoints-list nil)
2789 (gdb-table-add-row table '("Num" "Type" "Disp" "Enb" "Addr" "Hits" "What"))
2790 (dolist (breakpoint breakpoints-list)
2791 (add-to-list 'gdb-breakpoints-list
2792 (cons (bindat-get-field breakpoint 'number)
2793 breakpoint))
2794 (let ((at (bindat-get-field breakpoint 'at))
2795 (pending (bindat-get-field breakpoint 'pending))
2796 (func (bindat-get-field breakpoint 'func))
2797 (type (bindat-get-field breakpoint 'type)))
2798 (gdb-table-add-row table
2799 (list
2800 (bindat-get-field breakpoint 'number)
2801 (or type "")
2802 (or (bindat-get-field breakpoint 'disp) "")
2803 (let ((flag (bindat-get-field breakpoint 'enabled)))
2804 (if (string-equal flag "y")
2805 (propertize "y" 'font-lock-face font-lock-warning-face)
2806 (propertize "n" 'font-lock-face font-lock-comment-face)))
2807 (bindat-get-field breakpoint 'addr)
2808 (or (bindat-get-field breakpoint 'times) "")
2809 (if (and type (string-match ".*watchpoint" type))
2810 (bindat-get-field breakpoint 'what)
2811 (or pending at
2812 (concat "in "
2813 (propertize (or func "unknown")
2814 'font-lock-face font-lock-function-name-face)
2815 (gdb-frame-location breakpoint)))))
2816 ;; Add clickable properties only for breakpoints with file:line
2817 ;; information
2818 (append (list 'gdb-breakpoint breakpoint)
2819 (when func '(help-echo "mouse-2, RET: visit breakpoint"
2820 mouse-face highlight))))))
2821 (insert (gdb-table-string table " "))
2822 (gdb-place-breakpoints)))
2823
2824 ;; Put breakpoint icons in relevant margins (even those set in the GUD buffer).
2825 (defun gdb-place-breakpoints ()
2826 ;; Remove all breakpoint-icons in source buffers but not assembler buffer.
2827 (dolist (buffer (buffer-list))
2828 (with-current-buffer buffer
2829 (if (and (eq gud-minor-mode 'gdbmi)
2830 (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name))))
2831 (gdb-remove-breakpoint-icons (point-min) (point-max)))))
2832 (dolist (breakpoint gdb-breakpoints-list)
2833 (let* ((breakpoint (cdr breakpoint)) ; gdb-breakpoints-list is
2834 ; an associative list
2835 (line (bindat-get-field breakpoint 'line)))
2836 (when line
2837 (let ((file (bindat-get-field breakpoint 'fullname))
2838 (flag (bindat-get-field breakpoint 'enabled))
2839 (bptno (bindat-get-field breakpoint 'number)))
2840 (unless (and file (file-exists-p file))
2841 (setq file (cdr (assoc bptno gdb-location-alist))))
2842 (if (or (null file)
2843 (string-equal file "File not found"))
2844 ;; If the full filename is not recorded in the
2845 ;; breakpoint structure or in `gdb-location-alist', use
2846 ;; -file-list-exec-source-file to extract it.
2847 (when (setq file (bindat-get-field breakpoint 'file))
2848 (gdb-input (concat "list " file ":1") 'ignore)
2849 (gdb-input "-file-list-exec-source-file"
2850 `(lambda () (gdb-get-location
2851 ,bptno ,line ,flag))))
2852 (with-current-buffer (find-file-noselect file 'nowarn)
2853 (gdb-init-buffer)
2854 ;; Only want one breakpoint icon at each location.
2855 (gdb-put-breakpoint-icon (string-equal flag "y") bptno
2856 (string-to-number line)))))))))
2857
2858 (defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"")
2859
2860 (defun gdb-get-location (bptno line flag)
2861 "Find the directory containing the relevant source file.
2862 Put in buffer and place breakpoint icon."
2863 (goto-char (point-min))
2864 (catch 'file-not-found
2865 (if (re-search-forward gdb-source-file-regexp nil t)
2866 (delete (cons bptno "File not found") gdb-location-alist)
2867 (push (cons bptno (match-string 1)) gdb-location-alist)
2868 (gdb-resync)
2869 (unless (assoc bptno gdb-location-alist)
2870 (push (cons bptno "File not found") gdb-location-alist)
2871 (message-box "Cannot find source file for breakpoint location.
2872 Add directory to search path for source files using the GDB command, dir."))
2873 (throw 'file-not-found nil))
2874 (with-current-buffer (find-file-noselect (match-string 1))
2875 (gdb-init-buffer)
2876 ;; only want one breakpoint icon at each location
2877 (gdb-put-breakpoint-icon (eq flag ?y) bptno (string-to-number line)))))
2878
2879 (add-hook 'find-file-hook 'gdb-find-file-hook)
2880
2881 (defun gdb-find-file-hook ()
2882 "Set up buffer for debugging if file is part of the source code
2883 of the current session."
2884 (if (and (buffer-name gud-comint-buffer)
2885 ;; in case gud or gdb-ui is just loaded
2886 gud-comint-buffer
2887 (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
2888 'gdbmi))
2889 (if (member buffer-file-name gdb-source-file-list)
2890 (with-current-buffer (find-buffer-visiting buffer-file-name)
2891 (gdb-init-buffer)))))
2892
2893 (declare-function gud-remove "gdb-mi" t t) ; gud-def
2894 (declare-function gud-break "gdb-mi" t t) ; gud-def
2895 (declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window))
2896
2897 (defun gdb-mouse-set-clear-breakpoint (event)
2898 "Set/clear breakpoint in left fringe/margin at mouse click.
2899 If not in a source or disassembly buffer just set point."
2900 (interactive "e")
2901 (mouse-minibuffer-check event)
2902 (let ((posn (event-end event)))
2903 (with-selected-window (posn-window posn)
2904 (if (or (buffer-file-name) (derived-mode-p 'gdb-disassembly-mode))
2905 (if (numberp (posn-point posn))
2906 (save-excursion
2907 (goto-char (posn-point posn))
2908 (if (or (posn-object posn)
2909 (eq (car (fringe-bitmaps-at-pos (posn-point posn)))
2910 'breakpoint))
2911 (gud-remove nil)
2912 (gud-break nil)))))
2913 (posn-set-point posn))))
2914
2915 (defun gdb-mouse-toggle-breakpoint-margin (event)
2916 "Enable/disable breakpoint in left margin with mouse click."
2917 (interactive "e")
2918 (mouse-minibuffer-check event)
2919 (let ((posn (event-end event)))
2920 (if (numberp (posn-point posn))
2921 (with-selected-window (posn-window posn)
2922 (save-excursion
2923 (goto-char (posn-point posn))
2924 (if (posn-object posn)
2925 (gud-basic-call
2926 (let ((bptno (get-text-property
2927 0 'gdb-bptno (car (posn-string posn)))))
2928 (concat
2929 (if (get-text-property
2930 0 'gdb-enabled (car (posn-string posn)))
2931 "-break-disable "
2932 "-break-enable ")
2933 bptno)))))))))
2934
2935 (defun gdb-mouse-toggle-breakpoint-fringe (event)
2936 "Enable/disable breakpoint in left fringe with mouse click."
2937 (interactive "e")
2938 (mouse-minibuffer-check event)
2939 (let* ((posn (event-end event))
2940 (pos (posn-point posn))
2941 obj)
2942 (when (numberp pos)
2943 (with-selected-window (posn-window posn)
2944 (with-current-buffer (window-buffer (selected-window))
2945 (goto-char pos)
2946 (dolist (overlay (overlays-in pos pos))
2947 (when (overlay-get overlay 'put-break)
2948 (setq obj (overlay-get overlay 'before-string))))
2949 (when (stringp obj)
2950 (gud-basic-call
2951 (concat
2952 (if (get-text-property 0 'gdb-enabled obj)
2953 "-break-disable "
2954 "-break-enable ")
2955 (get-text-property 0 'gdb-bptno obj)))))))))
2956
2957 (defun gdb-breakpoints-buffer-name ()
2958 (concat "*breakpoints of " (gdb-get-target-string) "*"))
2959
2960 (defun gdb-display-breakpoints-buffer (&optional thread)
2961 "Display GDB breakpoints."
2962 (interactive)
2963 (gdb-display-buffer (gdb-get-buffer-create 'gdb-breakpoints-buffer thread)))
2964
2965 (defun gdb-frame-breakpoints-buffer (&optional thread)
2966 "Display GDB breakpoints in another frame."
2967 (interactive)
2968 (display-buffer (gdb-get-buffer-create 'gdb-breakpoints-buffer thread)
2969 gdb-display-buffer-other-frame-action))
2970
2971 (defvar gdb-breakpoints-mode-map
2972 (let ((map (make-sparse-keymap))
2973 (menu (make-sparse-keymap "Breakpoints")))
2974 (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window))
2975 (define-key menu [goto] '("Goto" . gdb-goto-breakpoint))
2976 (define-key menu [delete] '("Delete" . gdb-delete-breakpoint))
2977 (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint))
2978 (suppress-keymap map)
2979 (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu))
2980 (define-key map " " 'gdb-toggle-breakpoint)
2981 (define-key map "D" 'gdb-delete-breakpoint)
2982 ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons.
2983 (define-key map "q" 'gdb-delete-frame-or-window)
2984 (define-key map "\r" 'gdb-goto-breakpoint)
2985 (define-key map "\t" (lambda ()
2986 (interactive)
2987 (gdb-set-window-buffer
2988 (gdb-get-buffer-create 'gdb-threads-buffer) t)))
2989 (define-key map [mouse-2] 'gdb-goto-breakpoint)
2990 (define-key map [follow-link] 'mouse-face)
2991 map))
2992
2993 (defun gdb-delete-frame-or-window ()
2994 "Delete frame if there is only one window. Otherwise delete the window."
2995 (interactive)
2996 (if (one-window-p) (delete-frame)
2997 (delete-window)))
2998
2999 ;;from make-mode-line-mouse-map
3000 (defun gdb-make-header-line-mouse-map (mouse function) "\
3001 Return a keymap with single entry for mouse key MOUSE on the header line.
3002 MOUSE is defined to run function FUNCTION with no args in the buffer
3003 corresponding to the mode line clicked."
3004 (let ((map (make-sparse-keymap)))
3005 (define-key map (vector 'header-line mouse) function)
3006 (define-key map (vector 'header-line 'down-mouse-1) 'ignore)
3007 map))
3008
3009 (defmacro gdb-propertize-header (name buffer help-echo mouse-face face)
3010 `(propertize ,name
3011 'help-echo ,help-echo
3012 'mouse-face ',mouse-face
3013 'face ',face
3014 'local-map
3015 (gdb-make-header-line-mouse-map
3016 'mouse-1
3017 (lambda (event) (interactive "e")
3018 (save-selected-window
3019 (select-window (posn-window (event-start event)))
3020 (gdb-set-window-buffer
3021 (gdb-get-buffer-create ',buffer) t) )))))
3022
3023 \f
3024 ;; uses "-thread-info". Needs GDB 7.0 onwards.
3025 ;;; Threads view
3026
3027 (defun gdb-threads-buffer-name ()
3028 (concat "*threads of " (gdb-get-target-string) "*"))
3029
3030 (defun gdb-display-threads-buffer (&optional thread)
3031 "Display GDB threads."
3032 (interactive)
3033 (gdb-display-buffer (gdb-get-buffer-create 'gdb-threads-buffer thread)))
3034
3035 (defun gdb-frame-threads-buffer (&optional thread)
3036 "Display GDB threads in another frame."
3037 (interactive)
3038 (display-buffer (gdb-get-buffer-create 'gdb-threads-buffer thread)
3039 gdb-display-buffer-other-frame-action))
3040
3041 (def-gdb-trigger-and-handler
3042 gdb-invalidate-threads (gdb-current-context-command "-thread-info")
3043 gdb-thread-list-handler gdb-thread-list-handler-custom
3044 '(start update update-threads))
3045
3046 (gdb-set-buffer-rules
3047 'gdb-threads-buffer
3048 'gdb-threads-buffer-name
3049 'gdb-threads-mode
3050 'gdb-invalidate-threads)
3051
3052 (defvar gdb-threads-font-lock-keywords
3053 '(("in \\([^ ]+\\)" (1 font-lock-function-name-face))
3054 (" \\(stopped\\)" (1 font-lock-warning-face))
3055 (" \\(running\\)" (1 font-lock-string-face))
3056 ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face)))
3057 "Font lock keywords used in `gdb-threads-mode'.")
3058
3059 (defvar gdb-threads-mode-map
3060 (let ((map (make-sparse-keymap)))
3061 (define-key map "\r" 'gdb-select-thread)
3062 (define-key map "f" 'gdb-display-stack-for-thread)
3063 (define-key map "F" 'gdb-frame-stack-for-thread)
3064 (define-key map "l" 'gdb-display-locals-for-thread)
3065 (define-key map "L" 'gdb-frame-locals-for-thread)
3066 (define-key map "r" 'gdb-display-registers-for-thread)
3067 (define-key map "R" 'gdb-frame-registers-for-thread)
3068 (define-key map "d" 'gdb-display-disassembly-for-thread)
3069 (define-key map "D" 'gdb-frame-disassembly-for-thread)
3070 (define-key map "i" 'gdb-interrupt-thread)
3071 (define-key map "c" 'gdb-continue-thread)
3072 (define-key map "s" 'gdb-step-thread)
3073 (define-key map "\t"
3074 (lambda ()
3075 (interactive)
3076 (gdb-set-window-buffer
3077 (gdb-get-buffer-create 'gdb-breakpoints-buffer) t)))
3078 (define-key map [mouse-2] 'gdb-select-thread)
3079 (define-key map [follow-link] 'mouse-face)
3080 map))
3081
3082 (defvar gdb-threads-header
3083 (list
3084 (gdb-propertize-header
3085 "Breakpoints" gdb-breakpoints-buffer
3086 "mouse-1: select" mode-line-highlight mode-line-inactive)
3087 " "
3088 (gdb-propertize-header "Threads" gdb-threads-buffer
3089 nil nil mode-line)))
3090
3091 (define-derived-mode gdb-threads-mode gdb-parent-mode "Threads"
3092 "Major mode for GDB threads."
3093 (setq gdb-thread-position (make-marker))
3094 (add-to-list 'overlay-arrow-variable-list 'gdb-thread-position)
3095 (setq header-line-format gdb-threads-header)
3096 (set (make-local-variable 'font-lock-defaults)
3097 '(gdb-threads-font-lock-keywords))
3098 'gdb-invalidate-threads)
3099
3100 (defun gdb-thread-list-handler-custom ()
3101 (let ((threads-list (bindat-get-field (gdb-json-partial-output) 'threads))
3102 (table (make-gdb-table))
3103 (marked-line nil))
3104 (setq gdb-threads-list nil)
3105 (setq gdb-running-threads-count 0)
3106 (setq gdb-stopped-threads-count 0)
3107 (set-marker gdb-thread-position nil)
3108
3109 (dolist (thread (reverse threads-list))
3110 (let ((running (equal (bindat-get-field thread 'state) "running")))
3111 (add-to-list 'gdb-threads-list
3112 (cons (bindat-get-field thread 'id)
3113 thread))
3114 (cl-incf (if running
3115 gdb-running-threads-count
3116 gdb-stopped-threads-count))
3117
3118 (gdb-table-add-row
3119 table
3120 (list
3121 (bindat-get-field thread 'id)
3122 (concat
3123 (if gdb-thread-buffer-verbose-names
3124 (concat (bindat-get-field thread 'target-id) " ") "")
3125 (bindat-get-field thread 'state)
3126 ;; Include frame information for stopped threads
3127 (if (not running)
3128 (concat
3129 " in " (bindat-get-field thread 'frame 'func)
3130 (if gdb-thread-buffer-arguments
3131 (concat
3132 " ("
3133 (let ((args (bindat-get-field thread 'frame 'args)))
3134 (mapconcat
3135 (lambda (arg)
3136 (apply #'format "%s=%s"
3137 (gdb-get-many-fields arg 'name 'value)))
3138 args ","))
3139 ")")
3140 "")
3141 (if gdb-thread-buffer-locations
3142 (gdb-frame-location (bindat-get-field thread 'frame)) "")
3143 (if gdb-thread-buffer-addresses
3144 (concat " at " (bindat-get-field thread 'frame 'addr)) ""))
3145 "")))
3146 (list
3147 'gdb-thread thread
3148 'mouse-face 'highlight
3149 'help-echo "mouse-2, RET: select thread")))
3150 (when (string-equal gdb-thread-number
3151 (bindat-get-field thread 'id))
3152 (setq marked-line (length gdb-threads-list))))
3153 (insert (gdb-table-string table " "))
3154 (when marked-line
3155 (gdb-mark-line marked-line gdb-thread-position)))
3156 ;; We update gud-running here because we need to make sure that
3157 ;; gdb-threads-list is up-to-date
3158 (gdb-update-gud-running)
3159 (gdb-emit-signal gdb-buf-publisher 'update-disassembly))
3160
3161 (defmacro def-gdb-thread-buffer-command (name custom-defun &optional doc)
3162 "Define a NAME command which will act upon thread on the current line.
3163
3164 CUSTOM-DEFUN may use locally bound `thread' variable, which will
3165 be the value of 'gdb-thread property of the current line.
3166 If `gdb-thread' is nil, error is signaled."
3167 `(defun ,name (&optional event)
3168 ,(when doc doc)
3169 (interactive (list last-input-event))
3170 (if event (posn-set-point (event-end event)))
3171 (save-excursion
3172 (beginning-of-line)
3173 (let ((thread (get-text-property (point) 'gdb-thread)))
3174 (if thread
3175 ,custom-defun
3176 (error "Not recognized as thread line"))))))
3177
3178 (defmacro def-gdb-thread-buffer-simple-command (name buffer-command
3179 &optional doc)
3180 "Define a NAME which will call BUFFER-COMMAND with id of thread
3181 on the current line."
3182 `(def-gdb-thread-buffer-command ,name
3183 (,buffer-command (bindat-get-field thread 'id))
3184 ,doc))
3185
3186 (def-gdb-thread-buffer-command gdb-select-thread
3187 (let ((new-id (bindat-get-field thread 'id)))
3188 (gdb-setq-thread-number new-id)
3189 (gdb-input (concat "-thread-select " new-id) 'ignore)
3190 (gdb-update))
3191 "Select the thread at current line of threads buffer.")
3192
3193 (def-gdb-thread-buffer-simple-command
3194 gdb-display-stack-for-thread
3195 gdb-preemptively-display-stack-buffer
3196 "Display stack buffer for the thread at current line.")
3197
3198 (def-gdb-thread-buffer-simple-command
3199 gdb-display-locals-for-thread
3200 gdb-preemptively-display-locals-buffer
3201 "Display locals buffer for the thread at current line.")
3202
3203 (def-gdb-thread-buffer-simple-command
3204 gdb-display-registers-for-thread
3205 gdb-preemptively-display-registers-buffer
3206 "Display registers buffer for the thread at current line.")
3207
3208 (def-gdb-thread-buffer-simple-command
3209 gdb-display-disassembly-for-thread
3210 gdb-preemptively-display-disassembly-buffer
3211 "Display disassembly buffer for the thread at current line.")
3212
3213 (def-gdb-thread-buffer-simple-command
3214 gdb-frame-stack-for-thread
3215 gdb-frame-stack-buffer
3216 "Display another frame with stack buffer for thread at current line.")
3217
3218 (def-gdb-thread-buffer-simple-command
3219 gdb-frame-locals-for-thread
3220 gdb-frame-locals-buffer
3221 "Display another frame with locals buffer for thread at current line.")
3222
3223 (def-gdb-thread-buffer-simple-command
3224 gdb-frame-registers-for-thread
3225 gdb-frame-registers-buffer
3226 "Display another frame with registers buffer for the thread at current line.")
3227
3228 (def-gdb-thread-buffer-simple-command
3229 gdb-frame-disassembly-for-thread
3230 gdb-frame-disassembly-buffer
3231 "Display another frame with disassembly buffer for the thread at current line.")
3232
3233 (defmacro def-gdb-thread-buffer-gud-command (name gud-command &optional doc)
3234 "Define a NAME which will execute GUD-COMMAND with
3235 `gdb-thread-number' locally bound to id of thread on the current
3236 line."
3237 `(def-gdb-thread-buffer-command ,name
3238 (if gdb-non-stop
3239 (let ((gdb-thread-number (bindat-get-field thread 'id))
3240 (gdb-gud-control-all-threads nil))
3241 (call-interactively #',gud-command))
3242 (error "Available in non-stop mode only, customize `gdb-non-stop-setting'"))
3243 ,doc))
3244
3245 (def-gdb-thread-buffer-gud-command
3246 gdb-interrupt-thread
3247 gud-stop-subjob
3248 "Interrupt thread at current line.")
3249
3250 (def-gdb-thread-buffer-gud-command
3251 gdb-continue-thread
3252 gud-cont
3253 "Continue thread at current line.")
3254
3255 (def-gdb-thread-buffer-gud-command
3256 gdb-step-thread
3257 gud-step
3258 "Step thread at current line.")
3259
3260 \f
3261 ;;; Memory view
3262
3263 (defcustom gdb-memory-rows 8
3264 "Number of data rows in memory window."
3265 :type 'integer
3266 :group 'gud
3267 :version "23.2")
3268
3269 (defcustom gdb-memory-columns 4
3270 "Number of data columns in memory window."
3271 :type 'integer
3272 :group 'gud
3273 :version "23.2")
3274
3275 (defcustom gdb-memory-format "x"
3276 "Display format of data items in memory window."
3277 :type '(choice (const :tag "Hexadecimal" "x")
3278 (const :tag "Signed decimal" "d")
3279 (const :tag "Unsigned decimal" "u")
3280 (const :tag "Octal" "o")
3281 (const :tag "Binary" "t"))
3282 :group 'gud
3283 :version "22.1")
3284
3285 (defcustom gdb-memory-unit 4
3286 "Unit size of data items in memory window."
3287 :type '(choice (const :tag "Byte" 1)
3288 (const :tag "Halfword" 2)
3289 (const :tag "Word" 4)
3290 (const :tag "Giant word" 8))
3291 :group 'gud
3292 :version "23.2")
3293
3294 (def-gdb-trigger-and-handler
3295 gdb-invalidate-memory
3296 (format "-data-read-memory %s %s %d %d %d"
3297 gdb-memory-address
3298 gdb-memory-format
3299 gdb-memory-unit
3300 gdb-memory-rows
3301 gdb-memory-columns)
3302 gdb-read-memory-handler
3303 gdb-read-memory-custom
3304 '(start update))
3305
3306 (gdb-set-buffer-rules
3307 'gdb-memory-buffer
3308 'gdb-memory-buffer-name
3309 'gdb-memory-mode
3310 'gdb-invalidate-memory)
3311
3312 (defun gdb-memory-column-width (size format)
3313 "Return length of string with memory unit of SIZE in FORMAT.
3314
3315 SIZE is in bytes, as in `gdb-memory-unit'. FORMAT is a string as
3316 in `gdb-memory-format'."
3317 (let ((format-base (cdr (assoc format
3318 '(("x" . 16)
3319 ("d" . 10) ("u" . 10)
3320 ("o" . 8)
3321 ("t" . 2))))))
3322 (if format-base
3323 (let ((res (ceiling (log (expt 2.0 (* size 8)) format-base))))
3324 (cond ((string-equal format "x")
3325 (+ 2 res)) ; hexadecimal numbers have 0x in front
3326 ((or (string-equal format "d")
3327 (string-equal format "o"))
3328 (1+ res))
3329 (t res)))
3330 (error "Unknown format"))))
3331
3332 (defun gdb-read-memory-custom ()
3333 (let* ((res (gdb-json-partial-output))
3334 (err-msg (bindat-get-field res 'msg)))
3335 (if (not err-msg)
3336 (let ((memory (bindat-get-field res 'memory)))
3337 (setq gdb-memory-address (bindat-get-field res 'addr))
3338 (setq gdb-memory-next-page (bindat-get-field res 'next-page))
3339 (setq gdb-memory-prev-page (bindat-get-field res 'prev-page))
3340 (setq gdb-memory-last-address gdb-memory-address)
3341 (dolist (row memory)
3342 (insert (concat (bindat-get-field row 'addr) ":"))
3343 (dolist (column (bindat-get-field row 'data))
3344 (insert (gdb-pad-string column
3345 (+ 2 (gdb-memory-column-width
3346 gdb-memory-unit
3347 gdb-memory-format)))))
3348 (newline)))
3349 ;; Show last page instead of empty buffer when out of bounds
3350 (progn
3351 (let ((gdb-memory-address gdb-memory-last-address))
3352 (gdb-invalidate-memory 'update)
3353 (error err-msg))))))
3354
3355 (defvar gdb-memory-mode-map
3356 (let ((map (make-sparse-keymap)))
3357 (suppress-keymap map t)
3358 (define-key map "q" 'kill-this-buffer)
3359 (define-key map "n" 'gdb-memory-show-next-page)
3360 (define-key map "p" 'gdb-memory-show-previous-page)
3361 (define-key map "a" 'gdb-memory-set-address)
3362 (define-key map "t" 'gdb-memory-format-binary)
3363 (define-key map "o" 'gdb-memory-format-octal)
3364 (define-key map "u" 'gdb-memory-format-unsigned)
3365 (define-key map "d" 'gdb-memory-format-signed)
3366 (define-key map "x" 'gdb-memory-format-hexadecimal)
3367 (define-key map "b" 'gdb-memory-unit-byte)
3368 (define-key map "h" 'gdb-memory-unit-halfword)
3369 (define-key map "w" 'gdb-memory-unit-word)
3370 (define-key map "g" 'gdb-memory-unit-giant)
3371 (define-key map "R" 'gdb-memory-set-rows)
3372 (define-key map "C" 'gdb-memory-set-columns)
3373 map))
3374
3375 (defun gdb-memory-set-address-event (event)
3376 "Handle a click on address field in memory buffer header."
3377 (interactive "e")
3378 (save-selected-window
3379 (select-window (posn-window (event-start event)))
3380 (gdb-memory-set-address)))
3381
3382 ;; Non-event version for use within keymap
3383 (defun gdb-memory-set-address ()
3384 "Set the start memory address."
3385 (interactive)
3386 (let ((arg (read-from-minibuffer "Memory address: ")))
3387 (setq gdb-memory-address arg))
3388 (gdb-invalidate-memory 'update))
3389
3390 (defmacro def-gdb-set-positive-number (name variable echo-string &optional doc)
3391 "Define a function NAME which reads new VAR value from minibuffer."
3392 `(defun ,name (event)
3393 ,(when doc doc)
3394 (interactive "e")
3395 (save-selected-window
3396 (select-window (posn-window (event-start event)))
3397 (let* ((arg (read-from-minibuffer ,echo-string))
3398 (count (string-to-number arg)))
3399 (if (<= count 0)
3400 (error "Positive number only")
3401 (customize-set-variable ',variable count)
3402 (gdb-invalidate-memory 'update))))))
3403
3404 (def-gdb-set-positive-number
3405 gdb-memory-set-rows
3406 gdb-memory-rows
3407 "Rows: "
3408 "Set the number of data rows in memory window.")
3409
3410 (def-gdb-set-positive-number
3411 gdb-memory-set-columns
3412 gdb-memory-columns
3413 "Columns: "
3414 "Set the number of data columns in memory window.")
3415
3416 (defmacro def-gdb-memory-format (name format doc)
3417 "Define a function NAME to switch memory buffer to use FORMAT.
3418
3419 DOC is an optional documentation string."
3420 `(defun ,name () ,(when doc doc)
3421 (interactive)
3422 (customize-set-variable 'gdb-memory-format ,format)
3423 (gdb-invalidate-memory 'update)))
3424
3425 (def-gdb-memory-format
3426 gdb-memory-format-binary "t"
3427 "Set the display format to binary.")
3428
3429 (def-gdb-memory-format
3430 gdb-memory-format-octal "o"
3431 "Set the display format to octal.")
3432
3433 (def-gdb-memory-format
3434 gdb-memory-format-unsigned "u"
3435 "Set the display format to unsigned decimal.")
3436
3437 (def-gdb-memory-format
3438 gdb-memory-format-signed "d"
3439 "Set the display format to decimal.")
3440
3441 (def-gdb-memory-format
3442 gdb-memory-format-hexadecimal "x"
3443 "Set the display format to hexadecimal.")
3444
3445 (defvar gdb-memory-format-map
3446 (let ((map (make-sparse-keymap)))
3447 (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1)
3448 map)
3449 "Keymap to select format in the header line.")
3450
3451 (defvar gdb-memory-format-menu
3452 (let ((map (make-sparse-keymap "Format")))
3453
3454 (define-key map [binary]
3455 '(menu-item "Binary" gdb-memory-format-binary
3456 :button (:radio . (equal gdb-memory-format "t"))))
3457 (define-key map [octal]
3458 '(menu-item "Octal" gdb-memory-format-octal
3459 :button (:radio . (equal gdb-memory-format "o"))))
3460 (define-key map [unsigned]
3461 '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned
3462 :button (:radio . (equal gdb-memory-format "u"))))
3463 (define-key map [signed]
3464 '(menu-item "Signed Decimal" gdb-memory-format-signed
3465 :button (:radio . (equal gdb-memory-format "d"))))
3466 (define-key map [hexadecimal]
3467 '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal
3468 :button (:radio . (equal gdb-memory-format "x"))))
3469 map)
3470 "Menu of display formats in the header line.")
3471
3472 (defun gdb-memory-format-menu (event)
3473 (interactive "@e")
3474 (x-popup-menu event gdb-memory-format-menu))
3475
3476 (defun gdb-memory-format-menu-1 (event)
3477 (interactive "e")
3478 (save-selected-window
3479 (select-window (posn-window (event-start event)))
3480 (let* ((selection (gdb-memory-format-menu event))
3481 (binding (and selection (lookup-key gdb-memory-format-menu
3482 (vector (car selection))))))
3483 (if binding (call-interactively binding)))))
3484
3485 (defmacro def-gdb-memory-unit (name unit-size doc)
3486 "Define a function NAME to switch memory unit size to UNIT-SIZE.
3487
3488 DOC is an optional documentation string."
3489 `(defun ,name () ,(when doc doc)
3490 (interactive)
3491 (customize-set-variable 'gdb-memory-unit ,unit-size)
3492 (gdb-invalidate-memory 'update)))
3493
3494 (def-gdb-memory-unit gdb-memory-unit-giant 8
3495 "Set the unit size to giant words (eight bytes).")
3496
3497 (def-gdb-memory-unit gdb-memory-unit-word 4
3498 "Set the unit size to words (four bytes).")
3499
3500 (def-gdb-memory-unit gdb-memory-unit-halfword 2
3501 "Set the unit size to halfwords (two bytes).")
3502
3503 (def-gdb-memory-unit gdb-memory-unit-byte 1
3504 "Set the unit size to bytes.")
3505
3506 (defmacro def-gdb-memory-show-page (name address-var &optional doc)
3507 "Define a function NAME which show new address in memory buffer.
3508
3509 The defined function switches Memory buffer to show address
3510 stored in ADDRESS-VAR variable.
3511
3512 DOC is an optional documentation string."
3513 `(defun ,name
3514 ,(when doc doc)
3515 (interactive)
3516 (let ((gdb-memory-address ,address-var))
3517 (gdb-invalidate-memory))))
3518
3519 (def-gdb-memory-show-page gdb-memory-show-previous-page
3520 gdb-memory-prev-page)
3521
3522 (def-gdb-memory-show-page gdb-memory-show-next-page
3523 gdb-memory-next-page)
3524
3525 (defvar gdb-memory-unit-map
3526 (let ((map (make-sparse-keymap)))
3527 (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1)
3528 map)
3529 "Keymap to select units in the header line.")
3530
3531 (defvar gdb-memory-unit-menu
3532 (let ((map (make-sparse-keymap "Unit")))
3533 (define-key map [giantwords]
3534 '(menu-item "Giant words" gdb-memory-unit-giant
3535 :button (:radio . (equal gdb-memory-unit 8))))
3536 (define-key map [words]
3537 '(menu-item "Words" gdb-memory-unit-word
3538 :button (:radio . (equal gdb-memory-unit 4))))
3539 (define-key map [halfwords]
3540 '(menu-item "Halfwords" gdb-memory-unit-halfword
3541 :button (:radio . (equal gdb-memory-unit 2))))
3542 (define-key map [bytes]
3543 '(menu-item "Bytes" gdb-memory-unit-byte
3544 :button (:radio . (equal gdb-memory-unit 1))))
3545 map)
3546 "Menu of units in the header line.")
3547
3548 (defun gdb-memory-unit-menu (event)
3549 (interactive "@e")
3550 (x-popup-menu event gdb-memory-unit-menu))
3551
3552 (defun gdb-memory-unit-menu-1 (event)
3553 (interactive "e")
3554 (save-selected-window
3555 (select-window (posn-window (event-start event)))
3556 (let* ((selection (gdb-memory-unit-menu event))
3557 (binding (and selection (lookup-key gdb-memory-unit-menu
3558 (vector (car selection))))))
3559 (if binding (call-interactively binding)))))
3560
3561 (defvar gdb-memory-font-lock-keywords
3562 '(;; <__function.name+n>
3563 ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>"
3564 (1 font-lock-function-name-face)))
3565 "Font lock keywords used in `gdb-memory-mode'.")
3566
3567 (defvar gdb-memory-header
3568 '(:eval
3569 (concat
3570 "Start address["
3571 (propertize "-"
3572 'face font-lock-warning-face
3573 'help-echo "mouse-1: decrement address"
3574 'mouse-face 'mode-line-highlight
3575 'local-map (gdb-make-header-line-mouse-map
3576 'mouse-1
3577 #'gdb-memory-show-previous-page))
3578 "|"
3579 (propertize "+"
3580 'face font-lock-warning-face
3581 'help-echo "mouse-1: increment address"
3582 'mouse-face 'mode-line-highlight
3583 'local-map (gdb-make-header-line-mouse-map
3584 'mouse-1
3585 #'gdb-memory-show-next-page))
3586 "]: "
3587 (propertize gdb-memory-address
3588 'face font-lock-warning-face
3589 'help-echo "mouse-1: set start address"
3590 'mouse-face 'mode-line-highlight
3591 'local-map (gdb-make-header-line-mouse-map
3592 'mouse-1
3593 #'gdb-memory-set-address-event))
3594 " Rows: "
3595 (propertize (number-to-string gdb-memory-rows)
3596 'face font-lock-warning-face
3597 'help-echo "mouse-1: set number of columns"
3598 'mouse-face 'mode-line-highlight
3599 'local-map (gdb-make-header-line-mouse-map
3600 'mouse-1
3601 #'gdb-memory-set-rows))
3602 " Columns: "
3603 (propertize (number-to-string gdb-memory-columns)
3604 'face font-lock-warning-face
3605 'help-echo "mouse-1: set number of columns"
3606 'mouse-face 'mode-line-highlight
3607 'local-map (gdb-make-header-line-mouse-map
3608 'mouse-1
3609 #'gdb-memory-set-columns))
3610 " Display Format: "
3611 (propertize gdb-memory-format
3612 'face font-lock-warning-face
3613 'help-echo "mouse-3: select display format"
3614 'mouse-face 'mode-line-highlight
3615 'local-map gdb-memory-format-map)
3616 " Unit Size: "
3617 (propertize (number-to-string gdb-memory-unit)
3618 'face font-lock-warning-face
3619 'help-echo "mouse-3: select unit size"
3620 'mouse-face 'mode-line-highlight
3621 'local-map gdb-memory-unit-map)))
3622 "Header line used in `gdb-memory-mode'.")
3623
3624 (define-derived-mode gdb-memory-mode gdb-parent-mode "Memory"
3625 "Major mode for examining memory."
3626 (setq header-line-format gdb-memory-header)
3627 (set (make-local-variable 'font-lock-defaults)
3628 '(gdb-memory-font-lock-keywords))
3629 'gdb-invalidate-memory)
3630
3631 (defun gdb-memory-buffer-name ()
3632 (concat "*memory of " (gdb-get-target-string) "*"))
3633
3634 (defun gdb-display-memory-buffer (&optional thread)
3635 "Display GDB memory contents."
3636 (interactive)
3637 (gdb-display-buffer (gdb-get-buffer-create 'gdb-memory-buffer thread)))
3638
3639 (defun gdb-frame-memory-buffer ()
3640 "Display memory contents in another frame."
3641 (interactive)
3642 (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer)
3643 gdb-display-buffer-other-frame-action))
3644
3645 \f
3646 ;;; Disassembly view
3647
3648 (defun gdb-disassembly-buffer-name ()
3649 (gdb-current-context-buffer-name
3650 (concat "disassembly of " (gdb-get-target-string))))
3651
3652 (defun gdb-display-disassembly-buffer (&optional thread)
3653 "Display GDB disassembly information."
3654 (interactive)
3655 (gdb-display-buffer (gdb-get-buffer-create 'gdb-disassembly-buffer thread)))
3656
3657 (def-gdb-preempt-display-buffer
3658 gdb-preemptively-display-disassembly-buffer
3659 'gdb-disassembly-buffer)
3660
3661 (defun gdb-frame-disassembly-buffer (&optional thread)
3662 "Display GDB disassembly information in another frame."
3663 (interactive)
3664 (display-buffer (gdb-get-buffer-create 'gdb-disassembly-buffer thread)
3665 gdb-display-buffer-other-frame-action))
3666
3667 (def-gdb-auto-update-trigger gdb-invalidate-disassembly
3668 (let* ((frame (gdb-current-buffer-frame))
3669 (file (bindat-get-field frame 'fullname))
3670 (line (bindat-get-field frame 'line)))
3671 (if file
3672 (format "-data-disassemble -f %s -l %s -n -1 -- 0" file line)
3673 ;; If we're unable to get a file name / line for $PC, simply
3674 ;; follow $PC, disassembling the next 10 (x ~15 (on IA) ==
3675 ;; 150 bytes) instructions.
3676 "-data-disassemble -s $pc -e \"$pc + 150\" -- 0"))
3677 gdb-disassembly-handler
3678 ;; We update disassembly only after we have actual frame information
3679 ;; about all threads, so no there's `update' signal in this list
3680 '(start update-disassembly))
3681
3682 (def-gdb-auto-update-handler
3683 gdb-disassembly-handler
3684 gdb-disassembly-handler-custom
3685 t)
3686
3687 (gdb-set-buffer-rules
3688 'gdb-disassembly-buffer
3689 'gdb-disassembly-buffer-name
3690 'gdb-disassembly-mode
3691 'gdb-invalidate-disassembly)
3692
3693 (defvar gdb-disassembly-font-lock-keywords
3694 '(;; <__function.name+n>
3695 ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>"
3696 (1 font-lock-function-name-face))
3697 ;; 0xNNNNNNNN <__function.name+n>: opcode
3698 ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)"
3699 (4 font-lock-keyword-face))
3700 ;; %register(at least i386)
3701 ("%\\sw+" . font-lock-variable-name-face)
3702 ("^\\(Dump of assembler code for function\\) \\(.+\\):"
3703 (1 font-lock-comment-face)
3704 (2 font-lock-function-name-face))
3705 ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face))
3706 "Font lock keywords used in `gdb-disassembly-mode'.")
3707
3708 (defvar gdb-disassembly-mode-map
3709 ;; TODO
3710 (let ((map (make-sparse-keymap)))
3711 (suppress-keymap map)
3712 (define-key map "q" 'kill-this-buffer)
3713 map))
3714
3715 (define-derived-mode gdb-disassembly-mode gdb-parent-mode "Disassembly"
3716 "Major mode for GDB disassembly information."
3717 ;; TODO Rename overlay variable for disassembly mode
3718 (add-to-list 'overlay-arrow-variable-list 'gdb-disassembly-position)
3719 (setq fringes-outside-margins t)
3720 (set (make-local-variable 'gdb-disassembly-position) (make-marker))
3721 (set (make-local-variable 'font-lock-defaults)
3722 '(gdb-disassembly-font-lock-keywords))
3723 'gdb-invalidate-disassembly)
3724
3725 (defun gdb-disassembly-handler-custom ()
3726 (let* ((instructions (bindat-get-field (gdb-json-partial-output) 'asm_insns))
3727 (address (bindat-get-field (gdb-current-buffer-frame) 'addr))
3728 (table (make-gdb-table))
3729 (marked-line nil))
3730 (dolist (instr instructions)
3731 (gdb-table-add-row table
3732 (list
3733 (bindat-get-field instr 'address)
3734 (let
3735 ((func-name (bindat-get-field instr 'func-name))
3736 (offset (bindat-get-field instr 'offset)))
3737 (if func-name
3738 (format "<%s+%s>:" func-name offset)
3739 ""))
3740 (bindat-get-field instr 'inst)))
3741 (when (string-equal (bindat-get-field instr 'address)
3742 address)
3743 (progn
3744 (setq marked-line (length (gdb-table-rows table)))
3745 (setq fringe-indicator-alist
3746 (if (string-equal gdb-frame-number "0")
3747 nil
3748 '((overlay-arrow . hollow-right-triangle)))))))
3749 (insert (gdb-table-string table " "))
3750 (gdb-disassembly-place-breakpoints)
3751 ;; Mark current position with overlay arrow and scroll window to
3752 ;; that point
3753 (when marked-line
3754 (let ((window (get-buffer-window (current-buffer) 0)))
3755 (set-window-point window (gdb-mark-line marked-line
3756 gdb-disassembly-position))))
3757 (setq mode-name
3758 (gdb-current-context-mode-name
3759 (concat "Disassembly: "
3760 (bindat-get-field (gdb-current-buffer-frame) 'func))))))
3761
3762 (defun gdb-disassembly-place-breakpoints ()
3763 (gdb-remove-breakpoint-icons (point-min) (point-max))
3764 (dolist (breakpoint gdb-breakpoints-list)
3765 (let* ((breakpoint (cdr breakpoint))
3766 (bptno (bindat-get-field breakpoint 'number))
3767 (flag (bindat-get-field breakpoint 'enabled))
3768 (address (bindat-get-field breakpoint 'addr)))
3769 (save-excursion
3770 (goto-char (point-min))
3771 (if (re-search-forward (concat "^" address) nil t)
3772 (gdb-put-breakpoint-icon (string-equal flag "y") bptno))))))
3773
3774 \f
3775 (defvar gdb-breakpoints-header
3776 (list
3777 (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
3778 nil nil mode-line)
3779 " "
3780 (gdb-propertize-header "Threads" gdb-threads-buffer
3781 "mouse-1: select" mode-line-highlight
3782 mode-line-inactive)))
3783
3784 ;;; Breakpoints view
3785 (define-derived-mode gdb-breakpoints-mode gdb-parent-mode "Breakpoints"
3786 "Major mode for gdb breakpoints."
3787 (setq header-line-format gdb-breakpoints-header)
3788 'gdb-invalidate-breakpoints)
3789
3790 (defun gdb-toggle-breakpoint ()
3791 "Enable/disable breakpoint at current line of breakpoints buffer."
3792 (interactive)
3793 (save-excursion
3794 (beginning-of-line)
3795 (let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
3796 (if breakpoint
3797 (gud-basic-call
3798 (concat (if (equal "y" (bindat-get-field breakpoint 'enabled))
3799 "-break-disable "
3800 "-break-enable ")
3801 (bindat-get-field breakpoint 'number)))
3802 (error "Not recognized as break/watchpoint line")))))
3803
3804 (defun gdb-delete-breakpoint ()
3805 "Delete the breakpoint at current line of breakpoints buffer."
3806 (interactive)
3807 (save-excursion
3808 (beginning-of-line)
3809 (let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
3810 (if breakpoint
3811 (gud-basic-call (concat "-break-delete "
3812 (bindat-get-field breakpoint 'number)))
3813 (error "Not recognized as break/watchpoint line")))))
3814
3815 (defun gdb-goto-breakpoint (&optional event)
3816 "Go to the location of breakpoint at current line of breakpoints buffer."
3817 (interactive (list last-input-event))
3818 (if event (posn-set-point (event-end event)))
3819 ;; Hack to stop gdb-goto-breakpoint displaying in GUD buffer.
3820 (let ((window (get-buffer-window gud-comint-buffer)))
3821 (if window (save-selected-window (select-window window))))
3822 (save-excursion
3823 (beginning-of-line)
3824 (let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
3825 (if breakpoint
3826 (let ((bptno (bindat-get-field breakpoint 'number))
3827 (file (bindat-get-field breakpoint 'fullname))
3828 (line (bindat-get-field breakpoint 'line)))
3829 (save-selected-window
3830 (let* ((buffer (find-file-noselect
3831 (if (file-exists-p file) file
3832 (cdr (assoc bptno gdb-location-alist)))))
3833 (window (or (gdb-display-source-buffer buffer)
3834 (display-buffer buffer))))
3835 (setq gdb-source-window window)
3836 (with-current-buffer buffer
3837 (goto-char (point-min))
3838 (forward-line (1- (string-to-number line)))
3839 (set-window-point window (point))))))
3840 (error "Not recognized as break/watchpoint line")))))
3841
3842 \f
3843 ;; Frames buffer. This displays a perpetually correct backtrack trace.
3844 ;;
3845 (def-gdb-trigger-and-handler
3846 gdb-invalidate-frames (gdb-current-context-command "-stack-list-frames")
3847 gdb-stack-list-frames-handler gdb-stack-list-frames-custom
3848 '(start update))
3849
3850 (gdb-set-buffer-rules
3851 'gdb-stack-buffer
3852 'gdb-stack-buffer-name
3853 'gdb-frames-mode
3854 'gdb-invalidate-frames)
3855
3856 (defun gdb-frame-location (frame)
3857 "Return \" of file:line\" or \" of library\" for structure FRAME.
3858
3859 FRAME must have either \"file\" and \"line\" members or \"from\"
3860 member."
3861 (let ((file (bindat-get-field frame 'file))
3862 (line (bindat-get-field frame 'line))
3863 (from (bindat-get-field frame 'from)))
3864 (let ((res (or (and file line (concat file ":" line))
3865 from)))
3866 (if res (concat " of " res) ""))))
3867
3868 (defun gdb-stack-list-frames-custom ()
3869 (let ((stack (bindat-get-field (gdb-json-partial-output "frame") 'stack))
3870 (table (make-gdb-table)))
3871 (set-marker gdb-stack-position nil)
3872 (dolist (frame stack)
3873 (gdb-table-add-row table
3874 (list
3875 (bindat-get-field frame 'level)
3876 "in"
3877 (concat
3878 (bindat-get-field frame 'func)
3879 (if gdb-stack-buffer-locations
3880 (gdb-frame-location frame) "")
3881 (if gdb-stack-buffer-addresses
3882 (concat " at " (bindat-get-field frame 'addr)) "")))
3883 `(mouse-face highlight
3884 help-echo "mouse-2, RET: Select frame"
3885 gdb-frame ,frame)))
3886 (insert (gdb-table-string table " ")))
3887 (when (and gdb-frame-number
3888 (gdb-buffer-shows-main-thread-p))
3889 (gdb-mark-line (1+ (string-to-number gdb-frame-number))
3890 gdb-stack-position))
3891 (setq mode-name
3892 (gdb-current-context-mode-name "Frames")))
3893
3894 (defun gdb-stack-buffer-name ()
3895 (gdb-current-context-buffer-name
3896 (concat "stack frames of " (gdb-get-target-string))))
3897
3898 (defun gdb-display-stack-buffer (&optional thread)
3899 "Display GDB backtrace for current stack."
3900 (interactive)
3901 (gdb-display-buffer (gdb-get-buffer-create 'gdb-stack-buffer thread)))
3902
3903 (def-gdb-preempt-display-buffer
3904 gdb-preemptively-display-stack-buffer
3905 'gdb-stack-buffer nil t)
3906
3907 (defun gdb-frame-stack-buffer (&optional thread)
3908 "Display GDB backtrace for current stack in another frame."
3909 (interactive)
3910 (display-buffer (gdb-get-buffer-create 'gdb-stack-buffer thread)
3911 gdb-display-buffer-other-frame-action))
3912
3913 (defvar gdb-frames-mode-map
3914 (let ((map (make-sparse-keymap)))
3915 (suppress-keymap map)
3916 (define-key map "q" 'kill-this-buffer)
3917 (define-key map "\r" 'gdb-select-frame)
3918 (define-key map [mouse-2] 'gdb-select-frame)
3919 (define-key map [follow-link] 'mouse-face)
3920 map))
3921
3922 (defvar gdb-frames-font-lock-keywords
3923 '(("in \\([^ ]+\\)" (1 font-lock-function-name-face)))
3924 "Font lock keywords used in `gdb-frames-mode'.")
3925
3926 (define-derived-mode gdb-frames-mode gdb-parent-mode "Frames"
3927 "Major mode for gdb call stack."
3928 (setq gdb-stack-position (make-marker))
3929 (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position)
3930 (setq truncate-lines t) ;; Make it easier to see overlay arrow.
3931 (set (make-local-variable 'font-lock-defaults)
3932 '(gdb-frames-font-lock-keywords))
3933 'gdb-invalidate-frames)
3934
3935 (defun gdb-select-frame (&optional event)
3936 "Select the frame and display the relevant source."
3937 (interactive (list last-input-event))
3938 (if event (posn-set-point (event-end event)))
3939 (let ((frame (get-text-property (point) 'gdb-frame)))
3940 (if frame
3941 (if (gdb-buffer-shows-main-thread-p)
3942 (let ((new-level (bindat-get-field frame 'level)))
3943 (setq gdb-frame-number new-level)
3944 (gdb-input (concat "-stack-select-frame " new-level)
3945 'ignore)
3946 (gdb-update))
3947 (error "Could not select frame for non-current thread"))
3948 (error "Not recognized as frame line"))))
3949
3950 \f
3951 ;; Locals buffer.
3952 ;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards.
3953 (def-gdb-trigger-and-handler
3954 gdb-invalidate-locals
3955 (concat (gdb-current-context-command "-stack-list-locals")
3956 " --simple-values")
3957 gdb-locals-handler gdb-locals-handler-custom
3958 '(start update))
3959
3960 (gdb-set-buffer-rules
3961 'gdb-locals-buffer
3962 'gdb-locals-buffer-name
3963 'gdb-locals-mode
3964 'gdb-invalidate-locals)
3965
3966 (defvar gdb-locals-watch-map
3967 (let ((map (make-sparse-keymap)))
3968 (suppress-keymap map)
3969 (define-key map "\r" 'gud-watch)
3970 (define-key map [mouse-2] 'gud-watch)
3971 map)
3972 "Keymap to create watch expression of a complex data type local variable.")
3973
3974 (defvar gdb-edit-locals-map-1
3975 (let ((map (make-sparse-keymap)))
3976 (suppress-keymap map)
3977 (define-key map "\r" 'gdb-edit-locals-value)
3978 (define-key map [mouse-2] 'gdb-edit-locals-value)
3979 map)
3980 "Keymap to edit value of a simple data type local variable.")
3981
3982 (defun gdb-edit-locals-value (&optional event)
3983 "Assign a value to a variable displayed in the locals buffer."
3984 (interactive (list last-input-event))
3985 (save-excursion
3986 (if event (posn-set-point (event-end event)))
3987 (beginning-of-line)
3988 (let* ((var (bindat-get-field
3989 (get-text-property (point) 'gdb-local-variable) 'name))
3990 (value (read-string (format "New value (%s): " var))))
3991 (gud-basic-call
3992 (concat "-gdb-set variable " var " = " value)))))
3993
3994 ;; Don't display values of arrays or structures.
3995 ;; These can be expanded using gud-watch.
3996 (defun gdb-locals-handler-custom ()
3997 (let ((locals-list (bindat-get-field (gdb-json-partial-output) 'locals))
3998 (table (make-gdb-table)))
3999 (dolist (local locals-list)
4000 (let ((name (bindat-get-field local 'name))
4001 (value (bindat-get-field local 'value))
4002 (type (bindat-get-field local 'type)))
4003 (if (or (not value)
4004 (string-match "\\0x" value))
4005 (add-text-properties 0 (length name)
4006 `(mouse-face highlight
4007 help-echo "mouse-2: create watch expression"
4008 local-map ,gdb-locals-watch-map)
4009 name)
4010 (add-text-properties 0 (length value)
4011 `(mouse-face highlight
4012 help-echo "mouse-2: edit value"
4013 local-map ,gdb-edit-locals-map-1)
4014 value))
4015 (gdb-table-add-row
4016 table
4017 (list
4018 (propertize type 'font-lock-face font-lock-type-face)
4019 (propertize name 'font-lock-face font-lock-variable-name-face)
4020 value)
4021 `(gdb-local-variable ,local))))
4022 (insert (gdb-table-string table " "))
4023 (setq mode-name
4024 (gdb-current-context-mode-name
4025 (concat "Locals: "
4026 (bindat-get-field (gdb-current-buffer-frame) 'func))))))
4027
4028 (defvar gdb-locals-header
4029 (list
4030 (gdb-propertize-header "Locals" gdb-locals-buffer
4031 nil nil mode-line)
4032 " "
4033 (gdb-propertize-header "Registers" gdb-registers-buffer
4034 "mouse-1: select" mode-line-highlight
4035 mode-line-inactive)))
4036
4037 (defvar gdb-locals-mode-map
4038 (let ((map (make-sparse-keymap)))
4039 (suppress-keymap map)
4040 (define-key map "q" 'kill-this-buffer)
4041 (define-key map "\t" (lambda ()
4042 (interactive)
4043 (gdb-set-window-buffer
4044 (gdb-get-buffer-create
4045 'gdb-registers-buffer
4046 gdb-thread-number) t)))
4047 map))
4048
4049 (define-derived-mode gdb-locals-mode gdb-parent-mode "Locals"
4050 "Major mode for gdb locals."
4051 (setq header-line-format gdb-locals-header)
4052 'gdb-invalidate-locals)
4053
4054 (defun gdb-locals-buffer-name ()
4055 (gdb-current-context-buffer-name
4056 (concat "locals of " (gdb-get-target-string))))
4057
4058 (defun gdb-display-locals-buffer (&optional thread)
4059 "Display the local variables of current GDB stack."
4060 (interactive)
4061 (gdb-display-buffer (gdb-get-buffer-create 'gdb-locals-buffer thread)))
4062
4063 (def-gdb-preempt-display-buffer
4064 gdb-preemptively-display-locals-buffer
4065 'gdb-locals-buffer nil t)
4066
4067 (defun gdb-frame-locals-buffer (&optional thread)
4068 "Display the local variables of the current GDB stack in another frame."
4069 (interactive)
4070 (display-buffer (gdb-get-buffer-create 'gdb-locals-buffer thread)
4071 gdb-display-buffer-other-frame-action))
4072
4073 \f
4074 ;; Registers buffer.
4075
4076 (def-gdb-trigger-and-handler
4077 gdb-invalidate-registers
4078 (concat (gdb-current-context-command "-data-list-register-values") " x")
4079 gdb-registers-handler
4080 gdb-registers-handler-custom
4081 '(start update))
4082
4083 (gdb-set-buffer-rules
4084 'gdb-registers-buffer
4085 'gdb-registers-buffer-name
4086 'gdb-registers-mode
4087 'gdb-invalidate-registers)
4088
4089 (defun gdb-registers-handler-custom ()
4090 (when gdb-register-names
4091 (let ((register-values
4092 (bindat-get-field (gdb-json-partial-output) 'register-values))
4093 (table (make-gdb-table)))
4094 (dolist (register register-values)
4095 (let* ((register-number (bindat-get-field register 'number))
4096 (value (bindat-get-field register 'value))
4097 (register-name (nth (string-to-number register-number)
4098 gdb-register-names)))
4099 (gdb-table-add-row
4100 table
4101 (list
4102 (propertize register-name
4103 'font-lock-face font-lock-variable-name-face)
4104 (if (member register-number gdb-changed-registers)
4105 (propertize value 'font-lock-face font-lock-warning-face)
4106 value))
4107 `(mouse-face highlight
4108 help-echo "mouse-2: edit value"
4109 gdb-register-name ,register-name))))
4110 (insert (gdb-table-string table " ")))
4111 (setq mode-name
4112 (gdb-current-context-mode-name "Registers"))))
4113
4114 (defun gdb-edit-register-value (&optional event)
4115 "Assign a value to a register displayed in the registers buffer."
4116 (interactive (list last-input-event))
4117 (save-excursion
4118 (if event (posn-set-point (event-end event)))
4119 (beginning-of-line)
4120 (let* ((var (bindat-get-field
4121 (get-text-property (point) 'gdb-register-name)))
4122 (value (read-string (format "New value (%s): " var))))
4123 (gud-basic-call
4124 (concat "-gdb-set variable $" var " = " value)))))
4125
4126 (defvar gdb-registers-mode-map
4127 (let ((map (make-sparse-keymap)))
4128 (suppress-keymap map)
4129 (define-key map "\r" 'gdb-edit-register-value)
4130 (define-key map [mouse-2] 'gdb-edit-register-value)
4131 (define-key map "q" 'kill-this-buffer)
4132 (define-key map "\t" (lambda ()
4133 (interactive)
4134 (gdb-set-window-buffer
4135 (gdb-get-buffer-create
4136 'gdb-locals-buffer
4137 gdb-thread-number) t)))
4138 map))
4139
4140 (defvar gdb-registers-header
4141 (list
4142 (gdb-propertize-header "Locals" gdb-locals-buffer
4143 "mouse-1: select" mode-line-highlight
4144 mode-line-inactive)
4145 " "
4146 (gdb-propertize-header "Registers" gdb-registers-buffer
4147 nil nil mode-line)))
4148
4149 (define-derived-mode gdb-registers-mode gdb-parent-mode "Registers"
4150 "Major mode for gdb registers."
4151 (setq header-line-format gdb-registers-header)
4152 'gdb-invalidate-registers)
4153
4154 (defun gdb-registers-buffer-name ()
4155 (gdb-current-context-buffer-name
4156 (concat "registers of " (gdb-get-target-string))))
4157
4158 (defun gdb-display-registers-buffer (&optional thread)
4159 "Display GDB register contents."
4160 (interactive)
4161 (gdb-display-buffer (gdb-get-buffer-create 'gdb-registers-buffer thread)))
4162
4163 (def-gdb-preempt-display-buffer
4164 gdb-preemptively-display-registers-buffer
4165 'gdb-registers-buffer nil t)
4166
4167 (defun gdb-frame-registers-buffer (&optional thread)
4168 "Display GDB register contents in another frame."
4169 (interactive)
4170 (display-buffer (gdb-get-buffer-create 'gdb-registers-buffer thread)
4171 gdb-display-buffer-other-frame-action))
4172
4173 ;; Needs GDB 6.4 onwards (used to fail with no stack).
4174 (defun gdb-get-changed-registers ()
4175 (when (gdb-get-buffer 'gdb-registers-buffer)
4176 (gdb-input "-data-list-changed-registers"
4177 'gdb-changed-registers-handler
4178 'gdb-get-changed-registers)))
4179
4180 (defun gdb-changed-registers-handler ()
4181 (setq gdb-changed-registers nil)
4182 (dolist (register-number
4183 (bindat-get-field (gdb-json-partial-output) 'changed-registers))
4184 (push register-number gdb-changed-registers)))
4185
4186 (defun gdb-register-names-handler ()
4187 ;; Don't use pending triggers because this handler is called
4188 ;; only once (in gdb-init-1)
4189 (setq gdb-register-names nil)
4190 (dolist (register-name
4191 (bindat-get-field (gdb-json-partial-output) 'register-names))
4192 (push register-name gdb-register-names))
4193 (setq gdb-register-names (reverse gdb-register-names)))
4194 \f
4195
4196 (defun gdb-get-source-file-list ()
4197 "Create list of source files for current GDB session.
4198 If buffers already exist for any of these files, `gud-minor-mode'
4199 is set in them."
4200 (goto-char (point-min))
4201 (while (re-search-forward gdb-source-file-regexp nil t)
4202 (push (match-string 1) gdb-source-file-list))
4203 (dolist (buffer (buffer-list))
4204 (with-current-buffer buffer
4205 (when (member buffer-file-name gdb-source-file-list)
4206 (gdb-init-buffer)))))
4207
4208 (defun gdb-get-main-selected-frame ()
4209 "Trigger for `gdb-frame-handler' which uses main current thread.
4210 Called from `gdb-update'."
4211 (gdb-input (gdb-current-context-command "-stack-info-frame")
4212 'gdb-frame-handler
4213 'gdb-get-main-selected-frame))
4214
4215 (defun gdb-frame-handler ()
4216 "Set `gdb-selected-frame' and `gdb-selected-file' to show
4217 overlay arrow in source buffer."
4218 (let ((frame (bindat-get-field (gdb-json-partial-output) 'frame)))
4219 (when frame
4220 (setq gdb-selected-frame (bindat-get-field frame 'func))
4221 (setq gdb-selected-file (bindat-get-field frame 'fullname))
4222 (setq gdb-frame-number (bindat-get-field frame 'level))
4223 (setq gdb-frame-address (bindat-get-field frame 'addr))
4224 (let ((line (bindat-get-field frame 'line)))
4225 (setq gdb-selected-line (and line (string-to-number line)))
4226 (when (and gdb-selected-file gdb-selected-line)
4227 (setq gud-last-frame (cons gdb-selected-file gdb-selected-line))
4228 (gud-display-frame)))
4229 (if gud-overlay-arrow-position
4230 (let ((buffer (marker-buffer gud-overlay-arrow-position))
4231 (position (marker-position gud-overlay-arrow-position)))
4232 (when buffer
4233 (with-current-buffer buffer
4234 (setq fringe-indicator-alist
4235 (if (string-equal gdb-frame-number "0")
4236 nil
4237 '((overlay-arrow . hollow-right-triangle))))
4238 (setq gud-overlay-arrow-position (make-marker))
4239 (set-marker gud-overlay-arrow-position position))))))))
4240
4241 (defvar gdb-prompt-name-regexp "value=\"\\(.*?\\)\"")
4242
4243 (defun gdb-get-prompt ()
4244 "Find prompt for GDB session."
4245 (goto-char (point-min))
4246 (setq gdb-prompt-name nil)
4247 (re-search-forward gdb-prompt-name-regexp nil t)
4248 (setq gdb-prompt-name (match-string 1))
4249 ;; Insert first prompt.
4250 (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
4251
4252 ;;;; Window management
4253 (defun gdb-display-buffer (buf)
4254 "Show buffer BUF, and make that window dedicated."
4255 (let ((window (display-buffer buf)))
4256 (set-window-dedicated-p window t)
4257 window))
4258
4259 ;; (let ((answer (get-buffer-window buf 0)))
4260 ;; (if answer
4261 ;; (display-buffer buf nil 0) ;Deiconify frame if necessary.
4262 ;; (let ((window (get-lru-window)))
4263 ;; (if (eq (buffer-local-value 'gud-minor-mode (window-buffer window))
4264 ;; 'gdbmi)
4265 ;; (let ((largest (get-largest-window)))
4266 ;; (setq answer (split-window largest))
4267 ;; (set-window-buffer answer buf)
4268 ;; (set-window-dedicated-p answer t)
4269 ;; answer)
4270 ;; (set-window-buffer window buf)
4271 ;; window)))))
4272
4273
4274 (defun gdb-preempt-existing-or-display-buffer (buf &optional split-horizontal)
4275 "Find window displaying a buffer with the same
4276 `gdb-buffer-type' as BUF and show BUF there. If no such window
4277 exists, just call `gdb-display-buffer' for BUF. If the window
4278 found is already dedicated, split window according to
4279 SPLIT-HORIZONTAL and show BUF in the new window."
4280 (if buf
4281 (when (not (get-buffer-window buf))
4282 (let* ((buf-type (gdb-buffer-type buf))
4283 (existing-window
4284 (get-window-with-predicate
4285 #'(lambda (w)
4286 (and (eq buf-type
4287 (gdb-buffer-type (window-buffer w)))
4288 (not (window-dedicated-p w)))))))
4289 (if existing-window
4290 (set-window-buffer existing-window buf)
4291 (let ((dedicated-window
4292 (get-window-with-predicate
4293 #'(lambda (w)
4294 (eq buf-type
4295 (gdb-buffer-type (window-buffer w)))))))
4296 (if dedicated-window
4297 (set-window-buffer
4298 (split-window dedicated-window nil split-horizontal) buf)
4299 (gdb-display-buffer buf))))))
4300 (error "Null buffer")))
4301 \f
4302 ;;; Shared keymap initialization:
4303
4304 (let ((menu (make-sparse-keymap "GDB-Windows")))
4305 (define-key gud-menu-map [displays]
4306 `(menu-item "GDB-Windows" ,menu
4307 :visible (eq gud-minor-mode 'gdbmi)))
4308 (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer))
4309 (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
4310 (define-key menu [memory] '("Memory" . gdb-display-memory-buffer))
4311 (define-key menu [disassembly]
4312 '("Disassembly" . gdb-display-disassembly-buffer))
4313 (define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
4314 (define-key menu [inferior]
4315 '("IO" . gdb-display-io-buffer))
4316 (define-key menu [locals] '("Locals" . gdb-display-locals-buffer))
4317 (define-key menu [frames] '("Stack" . gdb-display-stack-buffer))
4318 (define-key menu [breakpoints]
4319 '("Breakpoints" . gdb-display-breakpoints-buffer)))
4320
4321 (let ((menu (make-sparse-keymap "GDB-Frames")))
4322 (define-key gud-menu-map [frames]
4323 `(menu-item "GDB-Frames" ,menu
4324 :visible (eq gud-minor-mode 'gdbmi)))
4325 (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer))
4326 (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
4327 (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer))
4328 (define-key menu [disassembly]
4329 '("Disassembly" . gdb-frame-disassembly-buffer))
4330 (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
4331 (define-key menu [inferior]
4332 '("IO" . gdb-frame-io-buffer))
4333 (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer))
4334 (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))
4335 (define-key menu [breakpoints]
4336 '("Breakpoints" . gdb-frame-breakpoints-buffer)))
4337
4338 (let ((menu (make-sparse-keymap "GDB-MI")))
4339 (define-key menu [gdb-customize]
4340 '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb))
4341 :help "Customize Gdb Graphical Mode options."))
4342 (define-key menu [gdb-many-windows]
4343 '(menu-item "Display Other Windows" gdb-many-windows
4344 :help "Toggle display of locals, stack and breakpoint information"
4345 :button (:toggle . gdb-many-windows)))
4346 (define-key menu [gdb-restore-windows]
4347 '(menu-item "Restore Window Layout" gdb-restore-windows
4348 :help "Restore standard layout for debug session."))
4349 (define-key menu [sep1]
4350 '(menu-item "--"))
4351 (define-key menu [all-threads]
4352 '(menu-item "GUD controls all threads"
4353 (lambda ()
4354 (interactive)
4355 (setq gdb-gud-control-all-threads t))
4356 :help "GUD start/stop commands apply to all threads"
4357 :button (:radio . gdb-gud-control-all-threads)))
4358 (define-key menu [current-thread]
4359 '(menu-item "GUD controls current thread"
4360 (lambda ()
4361 (interactive)
4362 (setq gdb-gud-control-all-threads nil))
4363 :help "GUD start/stop commands apply to current thread only"
4364 :button (:radio . (not gdb-gud-control-all-threads))))
4365 (define-key menu [sep2]
4366 '(menu-item "--"))
4367 (define-key menu [gdb-customize-reasons]
4368 '(menu-item "Customize switching..."
4369 (lambda ()
4370 (interactive)
4371 (customize-option 'gdb-switch-reasons))))
4372 (define-key menu [gdb-switch-when-another-stopped]
4373 (menu-bar-make-toggle gdb-toggle-switch-when-another-stopped
4374 gdb-switch-when-another-stopped
4375 "Automatically switch to stopped thread"
4376 "GDB thread switching %s"
4377 "Switch to stopped thread"))
4378 (define-key gud-menu-map [mi]
4379 `(menu-item "GDB-MI" ,menu :visible (eq gud-minor-mode 'gdbmi))))
4380
4381 ;; TODO Fit these into tool-bar-local-item-from-menu call in gud.el.
4382 ;; GDB-MI menu will need to be moved to gud.el. We can't use
4383 ;; tool-bar-local-item-from-menu here because it appends new buttons
4384 ;; to toolbar from right to left while we want our A/T throttle to
4385 ;; show up right before Run button.
4386 (define-key-after gud-tool-bar-map [all-threads]
4387 '(menu-item "Switch to non-stop/A mode" gdb-control-all-threads
4388 :image (find-image '((:type xpm :file "gud/thread.xpm")))
4389 :visible (and (eq gud-minor-mode 'gdbmi)
4390 gdb-non-stop
4391 (not gdb-gud-control-all-threads)))
4392 'run)
4393
4394 (define-key-after gud-tool-bar-map [current-thread]
4395 '(menu-item "Switch to non-stop/T mode" gdb-control-current-thread
4396 :image (find-image '((:type xpm :file "gud/all.xpm")))
4397 :visible (and (eq gud-minor-mode 'gdbmi)
4398 gdb-non-stop
4399 gdb-gud-control-all-threads))
4400 'all-threads)
4401
4402 (defun gdb-frame-gdb-buffer ()
4403 "Display GUD buffer in another frame."
4404 (interactive)
4405 (display-buffer-other-frame gud-comint-buffer))
4406
4407 (defun gdb-display-gdb-buffer ()
4408 "Display GUD buffer."
4409 (interactive)
4410 (pop-to-buffer gud-comint-buffer nil 0))
4411
4412 (defun gdb-set-window-buffer (name &optional ignore-dedicated window)
4413 "Set buffer of selected window to NAME and dedicate window.
4414
4415 When IGNORE-DEDICATED is non-nil, buffer is set even if selected
4416 window is dedicated."
4417 (unless window (setq window (selected-window)))
4418 (when ignore-dedicated
4419 (set-window-dedicated-p window nil))
4420 (set-window-buffer window (get-buffer name))
4421 (set-window-dedicated-p window t))
4422
4423 (defun gdb-setup-windows ()
4424 "Layout the window pattern for option `gdb-many-windows'."
4425 (gdb-get-buffer-create 'gdb-locals-buffer)
4426 (gdb-get-buffer-create 'gdb-stack-buffer)
4427 (gdb-get-buffer-create 'gdb-breakpoints-buffer)
4428 (set-window-dedicated-p (selected-window) nil)
4429 (switch-to-buffer gud-comint-buffer)
4430 (delete-other-windows)
4431 (let ((win0 (selected-window))
4432 (win1 (split-window nil ( / ( * (window-height) 3) 4)))
4433 (win2 (split-window nil ( / (window-height) 3)))
4434 (win3 (split-window-right)))
4435 (gdb-set-window-buffer (gdb-locals-buffer-name) nil win3)
4436 (select-window win2)
4437 (set-window-buffer
4438 win2
4439 (if gud-last-last-frame
4440 (gud-find-file (car gud-last-last-frame))
4441 (if gdb-main-file
4442 (gud-find-file gdb-main-file)
4443 ;; Put buffer list in window if we
4444 ;; can't find a source file.
4445 (list-buffers-noselect))))
4446 (setq gdb-source-window (selected-window))
4447 (let ((win4 (split-window-right)))
4448 (gdb-set-window-buffer
4449 (gdb-get-buffer-create 'gdb-inferior-io) nil win4))
4450 (select-window win1)
4451 (gdb-set-window-buffer (gdb-stack-buffer-name))
4452 (let ((win5 (split-window-right)))
4453 (gdb-set-window-buffer (if gdb-show-threads-by-default
4454 (gdb-threads-buffer-name)
4455 (gdb-breakpoints-buffer-name))
4456 nil win5))
4457 (select-window win0)))
4458
4459 (define-minor-mode gdb-many-windows
4460 "If nil just pop up the GUD buffer unless `gdb-show-main' is t.
4461 In this case it starts with two windows: one displaying the GUD
4462 buffer and the other with the source file with the main routine
4463 of the debugged program. Non-nil means display the layout shown for
4464 `gdb'."
4465 :global t
4466 :group 'gdb
4467 :version "22.1"
4468 (if (and gud-comint-buffer
4469 (buffer-name gud-comint-buffer))
4470 (ignore-errors
4471 (gdb-restore-windows))))
4472
4473 (defun gdb-restore-windows ()
4474 "Restore the basic arrangement of windows used by gdb.
4475 This arrangement depends on the value of option `gdb-many-windows'."
4476 (interactive)
4477 (switch-to-buffer gud-comint-buffer) ;Select the right window and frame.
4478 (delete-other-windows)
4479 (if gdb-many-windows
4480 (gdb-setup-windows)
4481 (when (or gud-last-last-frame gdb-show-main)
4482 (let ((win (split-window)))
4483 (set-window-buffer
4484 win
4485 (if gud-last-last-frame
4486 (gud-find-file (car gud-last-last-frame))
4487 (gud-find-file gdb-main-file)))
4488 (setq gdb-source-window win)))))
4489
4490 ;; Called from `gud-sentinel' in gud.el:
4491 (defun gdb-reset ()
4492 "Exit a debugging session cleanly.
4493 Kills the gdb buffers, and resets variables and the source buffers."
4494 ;; The gdb-inferior buffer has a pty hooked up to the main gdb
4495 ;; process. This pty must be deleted explicitly.
4496 (let ((pty (get-process "gdb-inferior")))
4497 (if pty (delete-process pty)))
4498 ;; Find gdb-mi buffers and kill them.
4499 (dolist (buffer (buffer-list))
4500 (unless (eq buffer gud-comint-buffer)
4501 (with-current-buffer buffer
4502 (if (eq gud-minor-mode 'gdbmi)
4503 (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name))
4504 (kill-buffer nil)
4505 (gdb-remove-breakpoint-icons (point-min) (point-max) t)
4506 (setq gud-minor-mode nil)
4507 (kill-local-variable 'tool-bar-map)
4508 (kill-local-variable 'gdb-define-alist))))))
4509 (setq gdb-disassembly-position nil)
4510 (setq overlay-arrow-variable-list
4511 (delq 'gdb-disassembly-position overlay-arrow-variable-list))
4512 (setq fringe-indicator-alist '((overlay-arrow . right-triangle)))
4513 (setq gdb-stack-position nil)
4514 (setq overlay-arrow-variable-list
4515 (delq 'gdb-stack-position overlay-arrow-variable-list))
4516 (setq gdb-thread-position nil)
4517 (setq overlay-arrow-variable-list
4518 (delq 'gdb-thread-position overlay-arrow-variable-list))
4519 (if (boundp 'speedbar-frame) (speedbar-timer-fn))
4520 (setq gud-running nil)
4521 (setq gdb-active-process nil)
4522 (remove-hook 'after-save-hook 'gdb-create-define-alist t))
4523
4524 (defun gdb-get-source-file ()
4525 "Find the source file where the program starts and display it with related
4526 buffers, if required."
4527 (goto-char (point-min))
4528 (if (re-search-forward gdb-source-file-regexp nil t)
4529 (setq gdb-main-file (match-string 1)))
4530 (if gdb-many-windows
4531 (gdb-setup-windows)
4532 (gdb-get-buffer-create 'gdb-breakpoints-buffer)
4533 (and gdb-show-main
4534 gdb-main-file
4535 (display-buffer (gud-find-file gdb-main-file))))
4536 (gdb-force-mode-line-update
4537 (propertize "ready" 'face font-lock-variable-name-face)))
4538
4539 ;;from put-image
4540 (defun gdb-put-string (putstring pos &optional dprop &rest sprops)
4541 "Put string PUTSTRING in front of POS in the current buffer.
4542 PUTSTRING is displayed by putting an overlay into the current buffer with a
4543 `before-string' string that has a `display' property whose value is
4544 PUTSTRING."
4545 (let ((string (make-string 1 ?x))
4546 (buffer (current-buffer)))
4547 (setq putstring (copy-sequence putstring))
4548 (let ((overlay (make-overlay pos pos buffer))
4549 (prop (or dprop
4550 (list (list 'margin 'left-margin) putstring))))
4551 (put-text-property 0 1 'display prop string)
4552 (if sprops
4553 (add-text-properties 0 1 sprops string))
4554 (overlay-put overlay 'put-break t)
4555 (overlay-put overlay 'before-string string))))
4556
4557 ;;from remove-images
4558 (defun gdb-remove-strings (start end &optional buffer)
4559 "Remove strings between START and END in BUFFER.
4560 Remove only strings that were put in BUFFER with calls to `gdb-put-string'.
4561 BUFFER nil or omitted means use the current buffer."
4562 (unless buffer
4563 (setq buffer (current-buffer)))
4564 (dolist (overlay (overlays-in start end))
4565 (when (overlay-get overlay 'put-break)
4566 (delete-overlay overlay))))
4567
4568 (defun gdb-put-breakpoint-icon (enabled bptno &optional line)
4569 (let* ((posns (gdb-line-posns (or line (line-number-at-pos))))
4570 (start (- (car posns) 1))
4571 (end (+ (cdr posns) 1))
4572 (putstring (if enabled "B" "b"))
4573 (source-window (get-buffer-window (current-buffer) 0)))
4574 (add-text-properties
4575 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt")
4576 putstring)
4577 (if enabled
4578 (add-text-properties
4579 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring)
4580 (add-text-properties
4581 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring))
4582 (gdb-remove-breakpoint-icons start end)
4583 (if (display-images-p)
4584 (if (>= (or left-fringe-width
4585 (if source-window (car (window-fringes source-window)))
4586 gdb-buffer-fringe-width) 8)
4587 (gdb-put-string
4588 nil (1+ start)
4589 `(left-fringe breakpoint
4590 ,(if enabled
4591 'breakpoint-enabled
4592 'breakpoint-disabled))
4593 'gdb-bptno bptno
4594 'gdb-enabled enabled)
4595 (when (< left-margin-width 2)
4596 (save-current-buffer
4597 (setq left-margin-width 2)
4598 (if source-window
4599 (set-window-margins
4600 source-window
4601 left-margin-width right-margin-width))))
4602 (put-image
4603 (if enabled
4604 (or breakpoint-enabled-icon
4605 (setq breakpoint-enabled-icon
4606 (find-image `((:type xpm :data
4607 ,breakpoint-xpm-data
4608 :ascent 100 :pointer hand)
4609 (:type pbm :data
4610 ,breakpoint-enabled-pbm-data
4611 :ascent 100 :pointer hand)))))
4612 (or breakpoint-disabled-icon
4613 (setq breakpoint-disabled-icon
4614 (find-image `((:type xpm :data
4615 ,breakpoint-xpm-data
4616 :conversion disabled
4617 :ascent 100 :pointer hand)
4618 (:type pbm :data
4619 ,breakpoint-disabled-pbm-data
4620 :ascent 100 :pointer hand))))))
4621 (+ start 1)
4622 putstring
4623 'left-margin))
4624 (when (< left-margin-width 2)
4625 (save-current-buffer
4626 (setq left-margin-width 2)
4627 (let ((window (get-buffer-window (current-buffer) 0)))
4628 (if window
4629 (set-window-margins
4630 window left-margin-width right-margin-width)))))
4631 (gdb-put-string
4632 (propertize putstring
4633 'face (if enabled
4634 'breakpoint-enabled 'breakpoint-disabled))
4635 (1+ start)))))
4636
4637 (defun gdb-remove-breakpoint-icons (start end &optional remove-margin)
4638 (gdb-remove-strings start end)
4639 (if (display-images-p)
4640 (remove-images start end))
4641 (when remove-margin
4642 (setq left-margin-width 0)
4643 (let ((window (get-buffer-window (current-buffer) 0)))
4644 (if window
4645 (set-window-margins
4646 window left-margin-width right-margin-width)))))
4647
4648 \f
4649 ;;; Functions for inline completion.
4650
4651 (defvar gud-gdb-fetch-lines-in-progress)
4652 (defvar gud-gdb-fetch-lines-string)
4653 (defvar gud-gdb-fetch-lines-break)
4654 (defvar gud-gdb-fetched-lines)
4655
4656 (defun gud-gdbmi-completions (context command)
4657 "Completion table for GDB/MI commands.
4658 COMMAND is the prefix for which we seek completion.
4659 CONTEXT is the text before COMMAND on the line."
4660 (let ((gud-gdb-fetch-lines-in-progress t)
4661 (gud-gdb-fetch-lines-string nil)
4662 (gud-gdb-fetch-lines-break (length context))
4663 (gud-gdb-fetched-lines nil)
4664 ;; This filter dumps output lines to `gud-gdb-fetched-lines'.
4665 (gud-marker-filter #'gud-gdbmi-fetch-lines-filter))
4666 (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
4667 (gdb-input (concat "complete " context command)
4668 (lambda () (setq gud-gdb-fetch-lines-in-progress nil)))
4669 (while gud-gdb-fetch-lines-in-progress
4670 (accept-process-output (get-buffer-process gud-comint-buffer))))
4671 (gud-gdb-completions-1 gud-gdb-fetched-lines)))
4672
4673 (defun gud-gdbmi-fetch-lines-filter (string)
4674 "Custom filter function for `gud-gdbmi-completions'."
4675 (setq string (concat gud-gdb-fetch-lines-string
4676 (gud-gdbmi-marker-filter string)))
4677 (while (string-match "\n" string)
4678 (push (substring string gud-gdb-fetch-lines-break (match-beginning 0))
4679 gud-gdb-fetched-lines)
4680 (setq string (substring string (match-end 0))))
4681 "")
4682
4683 (provide 'gdb-mi)
4684
4685 ;;; gdb-mi.el ends here