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