lisp/progmodes/gdb-mi.el

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