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