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