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