lisp/progmodes/gdb-mi.el

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