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

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