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