code.delx.au - gnu-emacs/blob - lisp/progmodes/gdb-mi.el

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