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

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