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

   1 ;;; gdb-ui.el --- User Interface for running GDB
   2
   3 ;; Author: Nick Roberts <nickrob@gnu.org>
   4 ;; Maintainer: FSF
   5 ;; Keywords: unix, tools
   6
   7 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006
   8 ;; Free Software Foundation, Inc.
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; This mode acts as a graphical user interface to GDB.  You can interact with
  30 ;; GDB through the GUD buffer in the usual way, but there are also further
  31 ;; buffers which control the execution and describe the state of your program.
  32 ;; It separates the input/output of your program from that of GDB, if
  33 ;; required, and watches expressions in the speedbar.  It also uses features of
  34 ;; Emacs 21 such as the fringe/display margin for breakpoints, and the toolbar
  35 ;; (see the GDB Graphical Interface section in the Emacs info manual).
  36
  37 ;; By default, M-x gdb will start the debugger. However, if you have customised
  38 ;; gud-gdb-command-name, then start it with M-x gdba.
  39
  40 ;; This file has evolved from gdba.el that was included with GDB 5.0 and
  41 ;; written by Tom Lord and Jim Kingdon.  It uses GDB's annotation interface.
  42 ;; You don't need to know about annotations to use this mode as a debugger,
  43 ;; but if you are interested developing the mode itself, then see the
  44 ;; Annotations section in the GDB info manual.
  45
  46 ;; GDB developers plan to make the annotation interface obsolete.  A new
  47 ;; interface called GDB/MI (machine interface) has been designed to replace
  48 ;; it.  Some GDB/MI commands are used in this file through the CLI command
  49 ;; 'interpreter mi <mi-command>'.  A file called gdb-mi.el is included with
  50 ;; GDB (6.2 onwards) that uses GDB/MI as the primary interface to GDB.  It is
  51 ;; still under development and is part of a process to migrate Emacs from
  52 ;; annotations to GDB/MI.
  53
  54 ;; This mode SHOULD WORK WITH GDB 5.0 onwards but you will NEED GDB 6.0
  55 ;; onwards to use watch expressions.  It works best with GDB 6.4 where
  56 ;; watch expressions will update more quickly.
  57
  58 ;;; Windows Platforms:
  59
  60 ;; If you are using Emacs and GDB on Windows you will need to flush the buffer
  61 ;; explicitly in your program if you want timely display of I/O in Emacs.
  62 ;; Alternatively you can make the output stream unbuffered, for example, by
  63 ;; using a macro:
  64
  65 ;;           #ifdef UNBUFFERED
  66 ;;           setvbuf (stdout, (char *) NULL, _IONBF, 0);
  67 ;;           #endif
  68
  69 ;; and compiling with -DUNBUFFERED while debugging.
  70
  71 ;;; Known Bugs:
  72
  73 ;; 1) Strings that are watched don't update in the speedbar when their
  74 ;; contents change.
  75 ;; 2) Cannot handle multiple debug sessions.
  76
  77 ;;; Problems with watch expressions:
  78
  79 ;; 1) They go out of scope when the inferior is re-run.
  80 ;; 2) -var-update reports that an out of scope variable has changed:
  81 ;;    changelist=[{name="var1",in_scope="false"}], but the value can't be accessed.
  82 ;;    (-var-list-children, in contrast allows you to create variable objects of
  83 ;;      the children when they are out of scope and get their values).
  84 ;; 3) VARNUM increments even when vaiable object is not created (maybe trivial).
  85
  86 ;;; TODO:
  87
  88 ;; 1) Use MI command -data-read-memory for memory window.
  89 ;; 2) Use tree-widget.el instead of the speedbar for watch-expressions?
  90 ;; 3) Mark breakpoint locations on scroll-bar of source buffer?
  91 ;; 4) With gud-print and gud-pstar, print the variable name in the GUD
  92 ;;    buffer instead of the value's history number.
  93
  94 ;;; Code:
  95
  96 (require 'gud)
  97
  98 (defvar tool-bar-map)
  99 (defvar speedbar-initial-expansion-list-name)
 100
 101 (defvar gdb-frame-address "main" "Initialization for Assembler buffer.")
 102 (defvar gdb-previous-frame-address nil)
 103 (defvar gdb-memory-address "main")
 104 (defvar gdb-previous-frame nil)
 105 (defvar gdb-selected-frame nil)
 106 (defvar gdb-frame-number nil)
 107 (defvar gdb-current-language nil)
 108 (defvar gdb-var-list nil
 109  "List of variables in watch window.
 110 Each element has the form (EXPRESSION VARNUM NUMCHILD TYPE VALUE STATUS) where
 111 STATUS is nil (unchanged), `changed' or `out-of-scope'.")
 112 (defvar gdb-force-update t
 113  "Non-nil means that view of watch expressions will be updated in the speedbar.")
 114 (defvar gdb-main-file nil "Source file from which program execution begins.")
 115 (defvar gdb-overlay-arrow-position nil)
 116 (defvar gdb-server-prefix nil)
 117 (defvar gdb-flush-pending-output nil)
 118 (defvar gdb-location-alist nil
 119   "Alist of breakpoint numbers and full filenames.")
 120 (defvar gdb-active-process nil "GUD tooltips display variable values when t, \
 121 and #define directives otherwise.")
 122 (defvar gdb-error "Non-nil when GDB is reporting an error.")
 123 (defvar gdb-macro-info nil
 124   "Non-nil if GDB knows that the inferior includes preprocessor macro info.")
 125 (defvar gdb-buffer-fringe-width nil)
 126
 127 (defvar gdb-buffer-type nil
 128   "One of the symbols bound in `gdb-buffer-rules'.")
 129 (make-variable-buffer-local 'gdb-buffer-type)
 130
 131 (defvar gdb-input-queue ()
 132   "A list of gdb command objects.")
 133
 134 (defvar gdb-prompting nil
 135   "True when gdb is idle with no pending input.")
 136
 137 (defvar gdb-output-sink 'user
 138   "The disposition of the output of the current gdb command.
 139 Possible values are these symbols:
 140
 141     `user' -- gdb output should be copied to the GUD buffer
 142               for the user to see.
 143
 144     `inferior' -- gdb output should be copied to the inferior-io buffer.
 145
 146     `pre-emacs' -- output should be ignored util the post-prompt
 147                    annotation is received.  Then the output-sink
 148                    becomes:...
 149     `emacs' -- output should be collected in the partial-output-buffer
 150                for subsequent processing by a command.  This is the
 151                disposition of output generated by commands that
 152                gdb mode sends to gdb on its own behalf.
 153     `post-emacs' -- ignore output until the prompt annotation is
 154                     received, then go to USER disposition.
 155
 156 gdba (gdb-ui.el) uses all five values, gdbmi (gdb-mi.el) only two
 157 \(`user' and `emacs').")
 158
 159 (defvar gdb-current-item nil
 160   "The most recent command item sent to gdb.")
 161
 162 (defvar gdb-pending-triggers '()
 163   "A list of trigger functions that have run later than their output
 164 handlers.")
 165
 166 (defvar gdb-first-post-prompt nil)
 167 (defvar gdb-version nil)
 168 (defvar gdb-locals-font-lock-keywords nil)
 169 (defvar gdb-source-file-list nil
 170   "List of source files for the current executable")
 171 (defconst gdb-error-regexp "\\^error,msg=\"\\(.+\\)\"")
 172
 173 (defvar gdb-locals-font-lock-keywords-1
 174   '(
 175     ;; var = (struct struct_tag) value
 176     ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(struct\\) \\(\\(\\sw\\|[_.]\\)+\\)"
 177       (1 font-lock-variable-name-face)
 178       (3 font-lock-keyword-face)
 179       (4 font-lock-type-face))
 180     ;; var = (type) value
 181     ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(\\(\\sw\\|[_.]\\)+\\)"
 182       (1 font-lock-variable-name-face)
 183       (3 font-lock-type-face))
 184     ;; var = val
 185     ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +[^(]"
 186       (1 font-lock-variable-name-face))
 187     )
 188   "Font lock keywords used in `gdb-local-mode'.")
 189
 190 (defvar gdb-locals-font-lock-keywords-2
 191   '(
 192     ;; var = type value
 193     ( "\\(^\\(\\sw\\|[_.]\\)+\\)\t+\\(\\(\\sw\\|[_.]\\)+\\)"
 194       (1 font-lock-variable-name-face)
 195       (3 font-lock-type-face))
 196     )
 197   "Font lock keywords used in `gdb-local-mode'.")
 198
 199 ;; Variables for GDB 6.4+
 200 (defvar gdb-register-names nil "List of register names.")
 201 (defvar gdb-changed-registers nil
 202   "List of changed register numbers (strings).")
 203
 204 ;;;###autoload
 205 (defun gdba (command-line)
 206   "Run gdb on program FILE in buffer *gud-FILE*.
 207 The directory containing FILE becomes the initial working directory
 208 and source-file directory for your debugger.
 209
 210 If `gdb-many-windows' is nil (the default value) then gdb just
 211 pops up the GUD buffer unless `gdb-show-main' is t.  In this case
 212 it starts with two windows: one displaying the GUD buffer and the
 213 other with the source file with the main routine of the inferior.
 214
 215 If `gdb-many-windows' is t, regardless of the value of
 216 `gdb-show-main', the layout below will appear unless
 217 `gdb-use-separate-io-buffer' is nil when the source buffer
 218 occupies the full width of the frame.  Keybindings are shown in
 219 some of the buffers.
 220
 221 Watch expressions appear in the speedbar/slowbar.
 222
 223 The following commands help control operation :
 224
 225 `gdb-many-windows'    - Toggle the number of windows gdb uses.
 226 `gdb-restore-windows' - To restore the window layout.
 227
 228 See Info node `(emacs)GDB Graphical Interface' for a more
 229 detailed description of this mode.
 230
 231
 232 +----------------------------------------------------------------------+
 233 |                               GDB Toolbar                            |
 234 +-----------------------------------+----------------------------------+
 235 | GUD buffer (I/O of GDB)           | Locals buffer                    |
 236 |                                   |                                  |
 237 |                                   |                                  |
 238 |                                   |                                  |
 239 +-----------------------------------+----------------------------------+
 240 | Source buffer                     | I/O buffer (of debugged program) |
 241 |                                   | (comint-mode)                    |
 242 |                                   |                                  |
 243 |                                   |                                  |
 244 |                                   |                                  |
 245 |                                   |                                  |
 246 |                                   |                                  |
 247 |                                   |                                  |
 248 +-----------------------------------+----------------------------------+
 249 | Stack buffer                      | Breakpoints buffer               |
 250 | RET      gdb-frames-select        | SPC    gdb-toggle-breakpoint     |
 251 |                                   | RET    gdb-goto-breakpoint       |
 252 |                                   | D      gdb-delete-breakpoint     |
 253 +-----------------------------------+----------------------------------+"
 254   ;;
 255   (interactive (list (gud-query-cmdline 'gdba)))
 256   ;;
 257   ;; Let's start with a basic gud-gdb buffer and then modify it a bit.
 258   (gdb command-line)
 259   (gdb-init-1))
 260
 261 (defvar gdb-debug-log nil)
 262
 263 ;;;###autoload
 264 (defcustom gdb-enable-debug-log nil
 265   "Non-nil means record the process input and output in `gdb-debug-log'."
 266   :type 'boolean
 267   :group 'gud
 268   :version "22.1")
 269
 270 (defcustom gdb-cpp-define-alist-program "gcc -E -dM -"
 271   "Shell command for generating a list of defined macros in a source file.
 272 This list is used to display the #define directive associated
 273 with an identifier as a tooltip.  It works in a debug session with
 274 GDB, when gud-tooltip-mode is t.
 275
 276 Set `gdb-cpp-define-alist-flags' for any include paths or
 277 predefined macros."
 278   :type 'string
 279   :group 'gud
 280   :version "22.1")
 281
 282 (defcustom gdb-cpp-define-alist-flags ""
 283   "Preprocessor flags for `gdb-cpp-define-alist-program'."
 284   :type 'string
 285   :group 'gud
 286   :version "22.1")
 287
 288 (defcustom gdb-show-main nil
 289   "Non-nil means display source file containing the main routine at startup.
 290 Also display the main routine in the disassembly buffer if present."
 291   :type 'boolean
 292   :group 'gud
 293   :version "22.1")
 294
 295 (defcustom gdb-use-separate-io-buffer nil
 296   "Non-nil means display output from the inferior in a separate buffer."
 297   :type 'boolean
 298   :group 'gud
 299   :version "22.1")
 300
 301 (defun gdb-use-separate-io-buffer (arg)
 302   "Toggle separate IO for inferior.
 303 With arg, use separate IO iff arg is positive."
 304   (interactive "P")
 305   (setq gdb-use-separate-io-buffer
 306         (if (null arg)
 307             (not gdb-use-separate-io-buffer)
 308           (> (prefix-numeric-value arg) 0)))
 309   (message (format "Separate inferior IO %sabled"
 310                    (if gdb-use-separate-io-buffer "en" "dis")))
 311   (if (and gud-comint-buffer
 312            (buffer-name gud-comint-buffer))
 313       (condition-case nil
 314           (if gdb-use-separate-io-buffer
 315               (gdb-restore-windows)
 316             (kill-buffer (gdb-inferior-io-name)))
 317         (error nil))))
 318
 319 (defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.")
 320
 321 (defun gdb-create-define-alist ()
 322   "Create an alist of #define directives for GUD tooltips."
 323   (let* ((file (buffer-file-name))
 324          (output
 325           (with-output-to-string
 326             (with-current-buffer standard-output
 327               (call-process shell-file-name
 328                             (if (file-exists-p file) file nil)
 329                             (list t nil) nil "-c"
 330                             (concat gdb-cpp-define-alist-program " "
 331                                     gdb-cpp-define-alist-flags)))))
 332         (define-list (split-string output "\n" t))
 333         (name))
 334     (setq gdb-define-alist nil)
 335     (dolist (define define-list)
 336       (setq name (nth 1 (split-string define "[( ]")))
 337       (push (cons name define) gdb-define-alist))))
 338
 339 (defun gdb-tooltip-print (expr)
 340   (tooltip-show
 341    (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
 342      (goto-char (point-min))
 343      (let ((string
 344             (if (search-forward "=" nil t)
 345                 (concat expr (buffer-substring (- (point) 2) (point-max)))
 346               (buffer-string))))
 347        ;; remove newline for gud-tooltip-echo-area
 348        (substring string 0 (- (length string) 1))))
 349    (or gud-tooltip-echo-area tooltip-use-echo-area)))
 350
 351 ;; If expr is a macro for a function don't print because of possible dangerous
 352 ;; side-effects. Also printing a function within a tooltip generates an
 353 ;; unexpected starting annotation (phase error).
 354 (defun gdb-tooltip-print-1 (expr)
 355   (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
 356     (goto-char (point-min))
 357     (if (search-forward "expands to: " nil t)
 358         (unless (looking-at "\\S-+.*(.*).*")
 359           (gdb-enqueue-input
 360            (list  (concat gdb-server-prefix "print " expr "\n")
 361                   `(lambda () (gdb-tooltip-print ,expr))))))))
 362
 363 (defconst gdb-source-file-regexp "\\(.+?\\), \\|\\([^, \n].*$\\)")
 364
 365 (defun gdb-set-gud-minor-mode-existing-buffers ()
 366   "Create list of source files for current GDB session."
 367   (goto-char (point-min))
 368   (when (search-forward "read in on demand:" nil t)
 369     (while (re-search-forward gdb-source-file-regexp nil t)
 370       (push (or (match-string 1) (match-string 2)) gdb-source-file-list))
 371     (dolist (buffer (buffer-list))
 372       (with-current-buffer buffer
 373         (when (and buffer-file-name
 374                    (member (file-name-nondirectory buffer-file-name)
 375                            gdb-source-file-list))
 376           (set (make-local-variable 'gud-minor-mode) 'gdba)
 377           (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
 378           (when gud-tooltip-mode
 379             (make-local-variable 'gdb-define-alist)
 380             (gdb-create-define-alist)
 381             (add-hook 'after-save-hook 'gdb-create-define-alist nil t)))))))
 382
 383 (defun gdb-find-watch-expression ()
 384   (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list))
 385          (varno (nth 1 var)) (expr))
 386     (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varno)
 387     (dolist (var1 gdb-var-list)
 388       (if (string-equal (nth 1 var1) (match-string 1 varno))
 389           (setq expr (concat (car var1) "." (match-string 2 varno)))))
 390     expr))
 391
 392 (defun gdb-init-1 ()
 393   (setq gdb-debug-log nil)
 394   (set (make-local-variable 'gud-minor-mode) 'gdba)
 395   (set (make-local-variable 'gud-marker-filter) 'gud-gdba-marker-filter)
 396   ;;
 397   (gud-def gud-break (if (not (string-match "Machine" mode-name))
 398                          (gud-call "break %f:%l" arg)
 399                        (save-excursion
 400                          (beginning-of-line)
 401                          (forward-char 2)
 402                          (gud-call "break *%a" arg)))
 403            "\C-b" "Set breakpoint at current line or address.")
 404   ;;
 405   (gud-def gud-remove (if (not (string-match "Machine" mode-name))
 406                           (gud-call "clear %f:%l" arg)
 407                         (save-excursion
 408                           (beginning-of-line)
 409                           (forward-char 2)
 410                           (gud-call "clear *%a" arg)))
 411            "\C-d" "Remove breakpoint at current line or address.")
 412   ;;
 413   (gud-def gud-until (if (not (string-match "Machine" mode-name))
 414                          (gud-call "until %f:%l" arg)
 415                        (save-excursion
 416                          (beginning-of-line)
 417                          (forward-char 2)
 418                          (gud-call "until *%a" arg)))
 419            "\C-u" "Continue to current line or address.")
 420   ;;
 421   (gud-def gud-go (gud-call (if gdb-active-process "continue" "run") arg)
 422            nil "Start or continue execution.")
 423
 424   ;; For debugging Emacs only.
 425   (gud-def gud-pp
 426            (gud-call
 427             (concat
 428              "pp1 " (if (eq (buffer-local-value
 429                              'major-mode (window-buffer)) 'speedbar-mode)
 430                         (gdb-find-watch-expression) "%e")) arg)
 431            nil   "Print the emacs s-expression.")
 432
 433   (define-key gud-minor-mode-map [left-margin mouse-1]
 434     'gdb-mouse-set-clear-breakpoint)
 435   (define-key gud-minor-mode-map [left-fringe mouse-1]
 436     'gdb-mouse-set-clear-breakpoint)
 437   (define-key gud-minor-mode-map [left-fringe mouse-2]
 438     'gdb-mouse-until)
 439   (define-key gud-minor-mode-map [left-fringe drag-mouse-1]
 440     'gdb-mouse-until)
 441   (define-key gud-minor-mode-map [left-margin mouse-2]
 442     'gdb-mouse-until)
 443   (define-key gud-minor-mode-map [left-margin mouse-3]
 444     'gdb-mouse-toggle-breakpoint-margin)
 445   (define-key gud-minor-mode-map [left-fringe mouse-3]
 446     'gdb-mouse-toggle-breakpoint-fringe)
 447
 448   (setq comint-input-sender 'gdb-send)
 449
 450   ;; (re-)initialize
 451   (setq gdb-frame-address (if gdb-show-main "main" nil))
 452   (setq gdb-previous-frame-address nil
 453         gdb-memory-address "main"
 454         gdb-previous-frame nil
 455         gdb-selected-frame nil
 456         gdb-current-language nil
 457         gdb-frame-number nil
 458         gdb-var-list nil
 459         gdb-force-update t
 460         gdb-first-post-prompt t
 461         gdb-prompting nil
 462         gdb-input-queue nil
 463         gdb-current-item nil
 464         gdb-pending-triggers nil
 465         gdb-output-sink 'user
 466         gdb-server-prefix "server "
 467         gdb-flush-pending-output nil
 468         gdb-location-alist nil
 469         gdb-source-file-list nil
 470         gdb-error nil
 471         gdb-macro-info nil
 472         gdb-buffer-fringe-width (car (window-fringes)))
 473
 474   (setq gdb-buffer-type 'gdba)
 475
 476   (if gdb-use-separate-io-buffer (gdb-clear-inferior-io))
 477
 478   ;; Hack to see test for GDB 6.4+ (-stack-info-frame was implemented in 6.4)
 479   (setq gdb-version nil)
 480   (gdb-enqueue-input (list "server interpreter mi -stack-info-frame\n"
 481                            'gdb-get-version)))
 482
 483 (defun gdb-init-2 ()
 484   (if (eq window-system 'w32)
 485       (gdb-enqueue-input (list "set new-console off\n" 'ignore)))
 486   (gdb-enqueue-input (list "set height 0\n" 'ignore))
 487   (gdb-enqueue-input (list "set width 0\n" 'ignore))
 488
 489   (if (string-equal gdb-version "pre-6.4")
 490       (progn
 491         (gdb-enqueue-input (list (concat gdb-server-prefix "info sources\n")
 492                                  'gdb-set-gud-minor-mode-existing-buffers))
 493         (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-1))
 494     (gdb-enqueue-input
 495      (list "server interpreter mi -data-list-register-names\n"
 496          'gdb-get-register-names))
 497     ; Needs GDB 6.2 onwards.
 498     (gdb-enqueue-input
 499      (list "server interpreter mi \"-file-list-exec-source-files\"\n"
 500            'gdb-set-gud-minor-mode-existing-buffers-1))
 501     (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-2))
 502
 503   ;; find source file and compilation directory here
 504   (gdb-enqueue-input (list "server list main\n"   'ignore))   ; C program
 505   (gdb-enqueue-input (list "server list MAIN__\n" 'ignore))   ; Fortran program
 506   (gdb-enqueue-input (list "server info source\n" 'gdb-source-info))
 507
 508   (run-hooks 'gdba-mode-hook))
 509
 510 (defun gdb-get-version ()
 511   (goto-char (point-min))
 512   (if (and (re-search-forward gdb-error-regexp nil t)
 513            (string-match ".*(missing implementation)" (match-string 1)))
 514       (setq gdb-version "pre-6.4")
 515     (setq gdb-version "6.4+"))
 516   (gdb-init-2))
 517
 518 (defun gdb-mouse-until (event)
 519   "Execute source lines by dragging the overlay arrow (fringe) with the mouse."
 520   (interactive "e")
 521   (if gud-overlay-arrow-position
 522       (let ((start (event-start event))
 523             (end  (event-end event))
 524             (buffer (marker-buffer gud-overlay-arrow-position)) (line))
 525         (if (not (string-match "Machine" mode-name))
 526             (if (equal buffer (window-buffer (posn-window end)))
 527                 (with-current-buffer buffer
 528                   (when (or (equal start end)
 529                             (equal (posn-point start)
 530                                    (marker-position
 531                                     gud-overlay-arrow-position)))
 532                     (setq line (line-number-at-pos (posn-point end)))
 533                     (gud-call (concat "until " (number-to-string line))))))
 534           (if (equal (marker-buffer gdb-overlay-arrow-position)
 535                      (window-buffer (posn-window end)))
 536               (when (or (equal start end)
 537                         (equal (posn-point start)
 538                                (marker-position
 539                                 gdb-overlay-arrow-position)))
 540                 (save-excursion
 541                   (goto-line (line-number-at-pos (posn-point end)))
 542                   (forward-char 2)
 543                   (gud-call (concat "until *%a")))))))))
 544
 545 (defcustom gdb-speedbar-auto-raise t
 546   "If non-nil raise speedbar every time display of watch expressions is\
 547  updated."
 548   :type 'boolean
 549   :group 'gud
 550   :version "22.1")
 551
 552 (defun gdb-speedbar-auto-raise (arg)
 553   "Toggle automatic raising of the speedbar for watch expressions.
 554 With arg, automatically raise speedbar iff arg is positive."
 555   (interactive "P")
 556   (setq gdb-speedbar-auto-raise
 557         (if (null arg)
 558             (not gdb-speedbar-auto-raise)
 559           (> (prefix-numeric-value arg) 0)))
 560   (message (format "Auto raising %sabled"
 561                    (if gdb-speedbar-auto-raise "en" "dis"))))
 562
 563 (defcustom gdb-use-colon-colon-notation nil
 564   "If non-nil use FUN::VAR format to display variables in the speedbar."
 565   :type 'boolean
 566   :group 'gud
 567   :version "22.1")
 568
 569 (defun gud-watch (&optional event)
 570   "Watch expression at point."
 571   (interactive (list last-input-event))
 572   (if event (posn-set-point (event-end event)))
 573   (require 'tooltip)
 574   (save-selected-window
 575     (let ((expr (tooltip-identifier-from-point (point))))
 576       (if (and (string-equal gdb-current-language "c")
 577                gdb-use-colon-colon-notation gdb-selected-frame)
 578           (setq expr (concat gdb-selected-frame "::" expr)))
 579       (catch 'already-watched
 580         (dolist (var gdb-var-list)
 581           (if (string-equal expr (car var)) (throw 'already-watched nil)))
 582         (set-text-properties 0 (length expr) nil expr)
 583         (gdb-enqueue-input
 584          (list
 585           (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
 586               (concat "server interpreter mi \"-var-create - * "  expr "\"\n")
 587             (concat"-var-create - * "  expr "\n"))
 588           `(lambda () (gdb-var-create-handler ,expr))))))))
 589
 590 (defconst gdb-var-create-regexp
 591   "name=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
 592
 593 (defun gdb-var-create-handler (expr)
 594   (goto-char (point-min))
 595   (if (re-search-forward gdb-var-create-regexp nil t)
 596       (let ((var (list expr
 597                        (match-string 1)
 598                        (match-string 2)
 599                        (match-string 3)
 600                        nil nil)))
 601         (push var gdb-var-list)
 602         (speedbar 1)
 603         (unless (string-equal
 604                  speedbar-initial-expansion-list-name "GUD")
 605           (speedbar-change-initial-expansion-list "GUD"))
 606         (gdb-enqueue-input
 607          (list
 608           (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
 609               (concat "server interpreter mi \"-var-evaluate-expression "
 610                       (nth 1 var) "\"\n")
 611             (concat "-var-evaluate-expression " (nth 1 var) "\n"))
 612           `(lambda () (gdb-var-evaluate-expression-handler
 613                        ,(nth 1 var) nil)))))
 614     (if (search-forward "Undefined command" nil t)
 615         (message-box "Watching expressions requires gdb 6.0 onwards")
 616       (message "No symbol \"%s\" in current context." expr))))
 617
 618 (defun gdb-var-evaluate-expression-handler (varnum changed)
 619   (goto-char (point-min))
 620   (re-search-forward ".*value=\\(\".*\"\\)" nil t)
 621   (catch 'var-found
 622     (dolist (var gdb-var-list)
 623       (when (string-equal varnum (cadr var))
 624         (if changed (setcar (nthcdr 5 var) 'changed))
 625         (setcar (nthcdr 4 var) (read (match-string 1)))
 626         (throw 'var-found nil)))))
 627
 628 (defun gdb-var-list-children (varnum)
 629   (gdb-enqueue-input
 630    (list (concat "server interpreter mi \"-var-list-children " varnum "\"\n")
 631          `(lambda () (gdb-var-list-children-handler ,varnum)))))
 632
 633 (defconst gdb-var-list-children-regexp
 634  "name=\"\\(.*?\\)\",exp=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",\
 635 type=\"\\(.*?\\)\"")
 636
 637 (defun gdb-var-list-children-handler (varnum)
 638   (goto-char (point-min))
 639   (let ((var-list nil))
 640     (catch 'child-already-watched
 641       (dolist (var gdb-var-list)
 642         (if (string-equal varnum (cadr var))
 643             (progn
 644               (push var var-list)
 645               (while (re-search-forward gdb-var-list-children-regexp nil t)
 646                 (let ((varchild (list (match-string 2)
 647                                       (match-string 1)
 648                                       (match-string 3)
 649                                       (match-string 4)
 650                                       nil nil)))
 651                   (dolist (var1 gdb-var-list)
 652                     (if (string-equal (cadr var1) (cadr varchild))
 653                         (throw 'child-already-watched nil)))
 654                   (push varchild var-list)
 655                   (gdb-enqueue-input
 656                    (list
 657                     (concat
 658                      "server interpreter mi \"-var-evaluate-expression "
 659                      (nth 1 varchild) "\"\n")
 660                     `(lambda () (gdb-var-evaluate-expression-handler
 661                                  ,(nth 1 varchild) nil)))))))
 662           (push var var-list)))
 663       (setq gdb-var-list (nreverse var-list)))))
 664
 665 (defun gdb-var-update ()
 666   (when (not (member 'gdb-var-update gdb-pending-triggers))
 667     (gdb-enqueue-input
 668      (list "server interpreter mi \"-var-update *\"\n"
 669            'gdb-var-update-handler))
 670     (push 'gdb-var-update gdb-pending-triggers)))
 671
 672 (defconst gdb-var-update-regexp "name=\"\\(.*?\\)\",in_scope=\"\\(.*?\\)\"")
 673
 674 (defun gdb-var-update-handler ()
 675   (dolist (var gdb-var-list)
 676     (setcar (nthcdr 5 var) nil))
 677   (goto-char (point-min))
 678   (while (re-search-forward gdb-var-update-regexp nil t)
 679     (let ((varnum (match-string 1)))
 680       (if  (string-equal (match-string 2) "false")
 681           (catch 'var-found
 682             (dolist (var gdb-var-list)
 683               (when (string-equal varnum (cadr var))
 684                 (setcar (nthcdr 5 var) 'out-of-scope)
 685                 (throw 'var-found nil))))
 686         (gdb-enqueue-input
 687          (list
 688           (concat "server interpreter mi \"-var-evaluate-expression "
 689                   varnum "\"\n")
 690           `(lambda () (gdb-var-evaluate-expression-handler ,varnum t)))))))
 691   (setq gdb-pending-triggers
 692         (delq 'gdb-var-update gdb-pending-triggers))
 693   (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
 694     ;; Dummy command to update speedbar at right time.
 695     (gdb-enqueue-input (list "server pwd\n" 'gdb-speedbar-timer-fn))
 696     ;; Keep gdb-pending-triggers non-nil till end.
 697     (push 'gdb-speedbar-timer gdb-pending-triggers)))
 698
 699 (defun gdb-speedbar-timer-fn ()
 700   (setq gdb-pending-triggers
 701         (delq 'gdb-speedbar-timer gdb-pending-triggers))
 702   (with-current-buffer gud-comint-buffer
 703     (speedbar-timer-fn)))
 704
 705 (defun gdb-var-delete ()
 706   "Delete watch expression at point from the speedbar."
 707   (interactive)
 708   (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
 709             '(gdbmi gdba))
 710       (let ((text (speedbar-line-text)))
 711         (string-match "\\(\\S-+\\)" text)
 712         (let* ((expr (match-string 1 text))
 713                (var (assoc expr gdb-var-list))
 714                (varnum (cadr var)))
 715           (unless (string-match "\\." varnum)
 716             (gdb-enqueue-input
 717              (list
 718               (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
 719                       'gdba)
 720                   (concat "server interpreter mi \"-var-delete " varnum "\"\n")
 721                 (concat "-var-delete " varnum "\n"))
 722                    'ignore))
 723             (setq gdb-var-list (delq var gdb-var-list))
 724             (dolist (varchild gdb-var-list)
 725               (if (string-match (concat (nth 1 var) "\\.") (nth 1 varchild))
 726                   (setq gdb-var-list (delq varchild gdb-var-list)))))))))
 727
 728 (defun gdb-edit-value (text token indent)
 729   "Assign a value to a variable displayed in the speedbar."
 730   (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
 731          (varnum (cadr var)) (value))
 732     (setq value (read-string "New value: "))
 733     (gdb-enqueue-input
 734      (list
 735       (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
 736           (concat "server interpreter mi \"-var-assign "
 737                   varnum " " value "\"\n")
 738         (concat "-var-assign " varnum " " value "\n"))
 739            'ignore))))
 740
 741 (defcustom gdb-show-changed-values t
 742   "If non-nil change the face of out of scope variables and changed values.
 743 Out of scope variables are suppressed with `shadow' face.
 744 Changed values are highlighted with the face `font-lock-warning-face'."
 745   :type 'boolean
 746   :group 'gud
 747   :version "22.1")
 748
 749 (defun gdb-speedbar-expand-node (text token indent)
 750   "Expand the node the user clicked on.
 751 TEXT is the text of the button we clicked on, a + or - item.
 752 TOKEN is data related to this node.
 753 INDENT is the current indentation depth."
 754   (cond ((string-match "+" text)        ;expand this node
 755          (if (and
 756               (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
 757               (string-equal gdb-version "pre-6.4"))
 758              (gdb-var-list-children token)
 759            (gdb-var-list-children-1 token)))
 760         ((string-match "-" text)        ;contract this node
 761          (dolist (var gdb-var-list)
 762            (if (string-match (concat token "\\.") (nth 1 var))
 763                (setq gdb-var-list (delq var gdb-var-list))))
 764          (setq gdb-force-update t)
 765          (with-current-buffer gud-comint-buffer
 766            (speedbar-timer-fn)))))
 767
 768 (defun gdb-get-target-string ()
 769   (with-current-buffer gud-comint-buffer
 770     gud-target-name))
 771 \f
 772
 773 ;;
 774 ;; gdb buffers.
 775 ;;
 776 ;; Each buffer has a TYPE -- a symbol that identifies the function
 777 ;; of that particular buffer.
 778 ;;
 779 ;; The usual gdb interaction buffer is given the type `gdba' and
 780 ;; is constructed specially.
 781 ;;
 782 ;; Others are constructed by gdb-get-create-buffer and
 783 ;; named according to the rules set forth in the gdb-buffer-rules-assoc
 784
 785 (defvar gdb-buffer-rules-assoc '())
 786
 787 (defun gdb-get-buffer (key)
 788   "Return the gdb buffer tagged with type KEY.
 789 The key should be one of the cars in `gdb-buffer-rules-assoc'."
 790   (save-excursion
 791     (gdb-look-for-tagged-buffer key (buffer-list))))
 792
 793 (defun gdb-get-create-buffer (key)
 794   "Create a new gdb  buffer of the type specified by KEY.
 795 The key should be one of the cars in `gdb-buffer-rules-assoc'."
 796   (or (gdb-get-buffer key)
 797       (let* ((rules (assoc key gdb-buffer-rules-assoc))
 798              (name (funcall (gdb-rules-name-maker rules)))
 799              (new (get-buffer-create name)))
 800         (with-current-buffer new
 801           (let ((trigger))
 802             (if (cdr (cdr rules))
 803                 (setq trigger (funcall (car (cdr (cdr rules))))))
 804             (setq gdb-buffer-type key)
 805             (set (make-local-variable 'gud-minor-mode)
 806                  (buffer-local-value 'gud-minor-mode gud-comint-buffer))
 807             (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
 808             (if trigger (funcall trigger)))
 809           new))))
 810
 811 (defun gdb-rules-name-maker (rules) (car (cdr rules)))
 812
 813 (defun gdb-look-for-tagged-buffer (key bufs)
 814   (let ((retval nil))
 815     (while (and (not retval) bufs)
 816       (set-buffer (car bufs))
 817       (if (eq gdb-buffer-type key)
 818           (setq retval (car bufs)))
 819       (setq bufs (cdr bufs)))
 820     retval))
 821
 822 ;;
 823 ;; This assoc maps buffer type symbols to rules.  Each rule is a list of
 824 ;; at least one and possible more functions.  The functions have these
 825 ;; roles in defining a buffer type:
 826 ;;
 827 ;;     NAME - Return a name for this  buffer type.
 828 ;;
 829 ;; The remaining function(s) are optional:
 830 ;;
 831 ;;     MODE - called in a new buffer with no arguments, should establish
 832 ;;            the proper mode for the buffer.
 833 ;;
 834
 835 (defun gdb-set-buffer-rules (buffer-type &rest rules)
 836   (let ((binding (assoc buffer-type gdb-buffer-rules-assoc)))
 837     (if binding
 838         (setcdr binding rules)
 839       (push (cons buffer-type rules)
 840             gdb-buffer-rules-assoc))))
 841
 842 ;; GUD buffers are an exception to the rules
 843 (gdb-set-buffer-rules 'gdba 'error)
 844
 845 ;; Partial-output buffer : This accumulates output from a command executed on
 846 ;; behalf of emacs (rather than the user).
 847 ;;
 848 (gdb-set-buffer-rules 'gdb-partial-output-buffer
 849                       'gdb-partial-output-name)
 850
 851 (defun gdb-partial-output-name ()
 852   (concat "*partial-output-"
 853           (gdb-get-target-string)
 854           "*"))
 855
 856 \f
 857 (gdb-set-buffer-rules 'gdb-inferior-io
 858                       'gdb-inferior-io-name
 859                       'gdb-inferior-io-mode)
 860
 861 (defun gdb-inferior-io-name ()
 862   (concat "*input/output of "
 863           (gdb-get-target-string)
 864           "*"))
 865
 866 (defun gdb-display-separate-io-buffer ()
 867   "Display IO of inferior in a separate window."
 868   (interactive)
 869   (if gdb-use-separate-io-buffer
 870       (gdb-display-buffer
 871        (gdb-get-create-buffer 'gdb-inferior-io))))
 872
 873 (defconst gdb-frame-parameters
 874   '((height . 14) (width . 80)
 875     (unsplittable . t)
 876     (tool-bar-lines . nil)
 877     (menu-bar-lines . nil)
 878     (minibuffer . nil)))
 879
 880 (defun gdb-frame-separate-io-buffer ()
 881   "Display IO of inferior in a new frame."
 882   (interactive)
 883   (if gdb-use-separate-io-buffer
 884       (let ((special-display-regexps (append special-display-regexps '(".*")))
 885             (special-display-frame-alist gdb-frame-parameters))
 886         (display-buffer (gdb-get-create-buffer 'gdb-inferior-io)))))
 887
 888 (defvar gdb-inferior-io-mode-map
 889   (let ((map (make-sparse-keymap)))
 890     (define-key map "\C-c\C-c" 'gdb-separate-io-interrupt)
 891     (define-key map "\C-c\C-z" 'gdb-separate-io-stop)
 892     (define-key map "\C-c\C-\\" 'gdb-separate-io-quit)
 893     (define-key map "\C-c\C-d" 'gdb-separate-io-eof)
 894     (define-key map "\C-d" 'gdb-separate-io-eof)
 895     map))
 896
 897 (define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O"
 898   "Major mode for gdb inferior-io."
 899   :syntax-table nil :abbrev-table nil
 900   ;; We want to use comint because it has various nifty and familiar
 901   ;; features.  We don't need a process, but comint wants one, so create
 902   ;; a dummy one.
 903   (make-comint-in-buffer
 904    (substring (buffer-name) 1 (- (length (buffer-name)) 1))
 905    (current-buffer) "hexl")
 906   (setq comint-input-sender 'gdb-inferior-io-sender))
 907
 908 (defun gdb-inferior-io-sender (proc string)
 909   ;; PROC is the pseudo-process created to satisfy comint.
 910   (with-current-buffer (process-buffer proc)
 911     (setq proc (get-buffer-process gud-comint-buffer))
 912     (process-send-string proc string)
 913     (process-send-string proc "\n")))
 914
 915 (defun gdb-separate-io-interrupt ()
 916   "Interrupt the program being debugged."
 917   (interactive)
 918   (interrupt-process
 919    (get-buffer-process gud-comint-buffer) comint-ptyp))
 920
 921 (defun gdb-separate-io-quit ()
 922   "Send quit signal to the program being debugged."
 923   (interactive)
 924   (quit-process
 925    (get-buffer-process gud-comint-buffer) comint-ptyp))
 926
 927 (defun gdb-separate-io-stop ()
 928   "Stop the program being debugged."
 929   (interactive)
 930   (stop-process
 931    (get-buffer-process gud-comint-buffer) comint-ptyp))
 932
 933 (defun gdb-separate-io-eof ()
 934   "Send end-of-file to the program being debugged."
 935   (interactive)
 936   (process-send-eof
 937    (get-buffer-process gud-comint-buffer)))
 938 \f
 939
 940 ;; gdb communications
 941 ;;
 942
 943 ;; INPUT: things sent to gdb
 944 ;;
 945 ;; The queues are lists.  Each element is either a string (indicating user or
 946 ;; user-like input) or a list of the form:
 947 ;;
 948 ;;    (INPUT-STRING  HANDLER-FN)
 949 ;;
 950 ;; The handler function will be called from the partial-output buffer when the
 951 ;; command completes.  This is the way to write commands which invoke gdb
 952 ;; commands autonomously.
 953 ;;
 954 ;; These lists are consumed tail first.
 955 ;;
 956
 957 (defun gdb-send (proc string)
 958   "A comint send filter for gdb.
 959 This filter may simply queue input for a later time."
 960   (with-current-buffer gud-comint-buffer
 961     (let ((inhibit-read-only t))
 962       (remove-text-properties (point-min) (point-max) '(face))))
 963   (let ((item (concat string "\n")))
 964     (if gud-running
 965       (progn
 966         (if gdb-enable-debug-log (push (cons 'send item) gdb-debug-log))
 967         (process-send-string proc item))
 968       (gdb-enqueue-input item))))
 969
 970 ;; Note: Stuff enqueued here will be sent to the next prompt, even if it
 971 ;; is a query, or other non-top-level prompt.
 972
 973 (defun gdb-enqueue-input (item)
 974   (if gdb-prompting
 975       (progn
 976         (gdb-send-item item)
 977         (setq gdb-prompting nil))
 978     (push item gdb-input-queue)))
 979
 980 (defun gdb-dequeue-input ()
 981   (let ((queue gdb-input-queue))
 982     (and queue
 983          (let ((last (car (last queue))))
 984            (unless (nbutlast queue) (setq gdb-input-queue '()))
 985            last))))
 986
 987 (defun gdb-send-item (item)
 988   (setq gdb-flush-pending-output nil)
 989   (if gdb-enable-debug-log (push (cons 'send-item item) gdb-debug-log))
 990   (setq gdb-current-item item)
 991   (let ((process (get-buffer-process gud-comint-buffer)))
 992     (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
 993         (if (stringp item)
 994             (progn
 995               (setq gdb-output-sink 'user)
 996               (process-send-string process item))
 997           (progn
 998             (gdb-clear-partial-output)
 999             (setq gdb-output-sink 'pre-emacs)
1000             (process-send-string process
1001                                  (car item))))
1002       ;; case: eq gud-minor-mode 'gdbmi
1003       (gdb-clear-partial-output)
1004       (setq gdb-output-sink 'emacs)
1005       (process-send-string process (car item)))))
1006 \f
1007 ;;
1008 ;; output -- things gdb prints to emacs
1009 ;;
1010 ;; GDB output is a stream interrupted by annotations.
1011 ;; Annotations can be recognized by their beginning
1012 ;; with \C-j\C-z\C-z<tag><opt>\C-j
1013 ;;
1014 ;; The tag is a string obeying symbol syntax.
1015 ;;
1016 ;; The optional part `<opt>' can be either the empty string
1017 ;; or a space followed by more data relating to the annotation.
1018 ;; For example, the SOURCE annotation is followed by a filename,
1019 ;; line number and various useless goo.  This data must not include
1020 ;; any newlines.
1021 ;;
1022
1023 (defcustom gud-gdba-command-name "gdb -annotate=3"
1024   "Default command to execute an executable under the GDB-UI debugger."
1025   :type 'string
1026   :group 'gud
1027   :version "22.1")
1028
1029 (defvar gdb-annotation-rules
1030   '(("pre-prompt" gdb-pre-prompt)
1031     ("prompt" gdb-prompt)
1032     ("commands" gdb-subprompt)
1033     ("overload-choice" gdb-subprompt)
1034     ("query" gdb-subprompt)
1035     ;; Need this prompt for GDB 6.1
1036     ("nquery" gdb-subprompt)
1037     ("prompt-for-continue" gdb-subprompt)
1038     ("post-prompt" gdb-post-prompt)
1039     ("source" gdb-source)
1040     ("starting" gdb-starting)
1041     ("exited" gdb-exited)
1042     ("signalled" gdb-exited)
1043     ("signal" gdb-stopping)
1044     ("breakpoint" gdb-stopping)
1045     ("watchpoint" gdb-stopping)
1046     ("frame-begin" gdb-frame-begin)
1047     ("stopped" gdb-stopped)
1048     ("error-begin" gdb-error)
1049     ("error" gdb-error)
1050     ) "An assoc mapping annotation tags to functions which process them.")
1051
1052 (defun gdb-resync()
1053   (setq gdb-flush-pending-output t)
1054   (setq gud-running nil)
1055   (setq gdb-output-sink 'user)
1056   (setq gdb-input-queue nil)
1057   (setq gdb-pending-triggers nil)
1058   (setq gdb-prompting t))
1059
1060 (defconst gdb-source-spec-regexp
1061   "\\(.*\\):\\([0-9]*\\):[0-9]*:[a-z]*:0x0*\\([a-f0-9]*\\)")
1062
1063 ;; Do not use this except as an annotation handler.
1064 (defun gdb-source (args)
1065   (string-match gdb-source-spec-regexp args)
1066   ;; Extract the frame position from the marker.
1067   (setq gud-last-frame
1068         (cons
1069          (match-string 1 args)
1070          (string-to-number (match-string 2 args))))
1071   (setq gdb-frame-address (match-string 3 args))
1072   ;; cover for auto-display output which comes *before*
1073   ;; stopped annotation
1074   (if (eq gdb-output-sink 'inferior) (setq gdb-output-sink 'user)))
1075
1076 (defun gdb-pre-prompt (ignored)
1077   "An annotation handler for `pre-prompt'.
1078 This terminates the collection of output from a previous command if that
1079 happens to be in effect."
1080   (setq gdb-error nil)
1081   (let ((sink gdb-output-sink))
1082     (cond
1083      ((eq sink 'user) t)
1084      ((eq sink 'emacs)
1085       (setq gdb-output-sink 'post-emacs))
1086      (t
1087       (gdb-resync)
1088       (error "Phase error in gdb-pre-prompt (got %s)" sink)))))
1089
1090 (defun gdb-prompt (ignored)
1091   "An annotation handler for `prompt'.
1092 This sends the next command (if any) to gdb."
1093   (when gdb-first-prompt
1094     (gdb-init-1)
1095     (setq gdb-first-prompt nil))
1096   (let ((sink gdb-output-sink))
1097     (cond
1098      ((eq sink 'user) t)
1099      ((eq sink 'post-emacs)
1100       (setq gdb-output-sink 'user)
1101       (let ((handler
1102              (car (cdr gdb-current-item))))
1103         (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
1104           (funcall handler))))
1105      (t
1106       (gdb-resync)
1107       (error "Phase error in gdb-prompt (got %s)" sink))))
1108   (let ((input (gdb-dequeue-input)))
1109     (if input
1110         (gdb-send-item input)
1111       (progn
1112         (setq gdb-prompting t)
1113         (gud-display-frame)))))
1114
1115 (defun gdb-subprompt (ignored)
1116   "An annotation handler for non-top-level prompts."
1117   (setq gdb-prompting t))
1118
1119 (defun gdb-starting (ignored)
1120   "An annotation handler for `starting'.
1121 This says that I/O for the subprocess is now the program being debugged,
1122 not GDB."
1123   (setq gdb-active-process t)
1124   (let ((sink gdb-output-sink))
1125     (cond
1126      ((eq sink 'user)
1127       (progn
1128         (setq gud-running t)
1129         (if gdb-use-separate-io-buffer
1130             (setq gdb-output-sink 'inferior))))
1131      (t
1132       (gdb-resync)
1133       (error "Unexpected `starting' annotation")))))
1134
1135 (defun gdb-stopping (ignored)
1136   "An annotation handler for `breakpoint' and other annotations.
1137 They say that I/O for the subprocess is now GDB, not the program
1138 being debugged."
1139   (if gdb-use-separate-io-buffer
1140       (let ((sink gdb-output-sink))
1141         (cond
1142          ((eq sink 'inferior)
1143           (setq gdb-output-sink 'user))
1144          (t
1145           (gdb-resync)
1146           (error "Unexpected stopping annotation"))))))
1147
1148 (defun gdb-exited (ignored)
1149   "An annotation handler for `exited' and `signalled'.
1150 They say that I/O for the subprocess is now GDB, not the program
1151 being debugged and that the program is no longer running.  This
1152 function is used to change the focus of GUD tooltips to #define
1153 directives."
1154   (setq gdb-active-process nil)
1155   (setq gud-overlay-arrow-position nil)
1156   (setq gdb-overlay-arrow-position nil)
1157   (gdb-stopping ignored))
1158
1159 (defun gdb-frame-begin (ignored)
1160   (let ((sink gdb-output-sink))
1161     (cond
1162      ((eq sink 'inferior)
1163       (setq gdb-output-sink 'user))
1164      ((eq sink 'user) t)
1165      ((eq sink 'emacs) t)
1166      (t
1167       (gdb-resync)
1168       (error "Unexpected frame-begin annotation (%S)" sink)))))
1169
1170 (defun gdb-stopped (ignored)
1171   "An annotation handler for `stopped'.
1172 It is just like `gdb-stopping', except that if we already set the output
1173 sink to `user' in `gdb-stopping', that is fine."
1174   (setq gud-running nil)
1175   (setq gdb-active-process t)
1176   (let ((sink gdb-output-sink))
1177     (cond
1178      ((eq sink 'inferior)
1179       (setq gdb-output-sink 'user))
1180      ((eq sink 'user) t)
1181      (t
1182       (gdb-resync)
1183       (error "Unexpected stopped annotation")))))
1184
1185 (defun gdb-error (ignored)
1186   (setq gdb-error (not gdb-error)))
1187
1188 (defun gdb-post-prompt (ignored)
1189   "An annotation handler for `post-prompt'.
1190 This begins the collection of output from the current command if that
1191 happens to be appropriate."
1192   ;; Don't add to queue if there outstanding items or GDB is not known yet.
1193   (unless (or gdb-pending-triggers gdb-first-post-prompt)
1194     (gdb-get-selected-frame)
1195     (gdb-invalidate-frames)
1196     ;; Regenerate breakpoints buffer in case it has been inadvertantly deleted.
1197     (gdb-get-create-buffer 'gdb-breakpoints-buffer)
1198     (gdb-invalidate-breakpoints)
1199     ;; Do this through gdb-get-selected-frame -> gdb-frame-handler
1200     ;; so gdb-frame-address is updated.
1201     ;; (gdb-invalidate-assembler)
1202
1203     (if (string-equal gdb-version "pre-6.4")
1204         (gdb-invalidate-registers)
1205       (gdb-get-changed-registers)
1206       (gdb-invalidate-registers-1))
1207
1208     (gdb-invalidate-memory)
1209     (if (string-equal gdb-version "pre-6.4")
1210         (gdb-invalidate-locals)
1211       (gdb-invalidate-locals-1))
1212
1213     (gdb-invalidate-threads)
1214     (unless (eq system-type 'darwin) ;Breaks on Darwin's GDB-5.3.
1215       ;; FIXME: with GDB-6 on Darwin, this might very well work.
1216       ;; Only needed/used with speedbar/watch expressions.
1217       (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
1218         (setq gdb-force-update t)
1219         (if (string-equal gdb-version "pre-6.4")
1220             (gdb-var-update)
1221           (gdb-var-update-1)))))
1222   (setq gdb-first-post-prompt nil)
1223   (let ((sink gdb-output-sink))
1224     (cond
1225      ((eq sink 'user) t)
1226      ((eq sink 'pre-emacs)
1227       (setq gdb-output-sink 'emacs))
1228      (t
1229       (gdb-resync)
1230       (error "Phase error in gdb-post-prompt (got %s)" sink)))))
1231
1232 (defun gud-gdba-marker-filter (string)
1233   "A gud marker filter for gdb.  Handle a burst of output from GDB."
1234   (if gdb-flush-pending-output
1235       nil
1236     (if gdb-enable-debug-log (push (cons 'recv string) gdb-debug-log))
1237     ;; Recall the left over gud-marker-acc from last time.
1238     (setq gud-marker-acc (concat gud-marker-acc string))
1239     ;; Start accumulating output for the GUD buffer.
1240     (let ((output ""))
1241       ;;
1242       ;; Process all the complete markers in this chunk.
1243       (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc)
1244         (let ((annotation (match-string 1 gud-marker-acc)))
1245           ;;
1246           ;; Stuff prior to the match is just ordinary output.
1247           ;; It is either concatenated to OUTPUT or directed
1248           ;; elsewhere.
1249           (setq output
1250                 (gdb-concat-output
1251                  output
1252                  (substring gud-marker-acc 0 (match-beginning 0))))
1253           ;;
1254           ;; Take that stuff off the gud-marker-acc.
1255           (setq gud-marker-acc (substring gud-marker-acc (match-end 0)))
1256           ;;
1257           ;; Parse the tag from the annotation, and maybe its arguments.
1258           (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation)
1259           (let* ((annotation-type (match-string 1 annotation))
1260                  (annotation-arguments (match-string 2 annotation))
1261                  (annotation-rule (assoc annotation-type
1262                                          gdb-annotation-rules)))
1263             ;; Call the handler for this annotation.
1264             (if annotation-rule
1265                 (funcall (car (cdr annotation-rule))
1266                          annotation-arguments)
1267               ;; Else the annotation is not recognized.  Ignore it silently,
1268               ;; so that GDB can add new annotations without causing
1269               ;; us to blow up.
1270               ))))
1271       ;;
1272       ;; Does the remaining text end in a partial line?
1273       ;; If it does, then keep part of the gud-marker-acc until we get more.
1274       (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'"
1275                         gud-marker-acc)
1276           (progn
1277             ;; Everything before the potential marker start can be output.
1278             (setq output
1279                   (gdb-concat-output output
1280                                      (substring gud-marker-acc 0
1281                                                 (match-beginning 0))))
1282             ;;
1283             ;; Everything after, we save, to combine with later input.
1284             (setq gud-marker-acc (substring gud-marker-acc
1285                                             (match-beginning 0))))
1286         ;;
1287         ;; In case we know the gud-marker-acc contains no partial annotations:
1288         (progn
1289           (setq output (gdb-concat-output output gud-marker-acc))
1290           (setq gud-marker-acc "")))
1291       output)))
1292
1293 (defun gdb-concat-output (so-far new)
1294   (if gdb-error
1295       (put-text-property 0 (length new) 'face font-lock-warning-face new))
1296   (let ((sink gdb-output-sink))
1297     (cond
1298      ((eq sink 'user) (concat so-far new))
1299      ((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far)
1300      ((eq sink 'emacs)
1301       (gdb-append-to-partial-output new)
1302       so-far)
1303      ((eq sink 'inferior)
1304       (gdb-append-to-inferior-io new)
1305       so-far)
1306      (t
1307       (gdb-resync)
1308       (error "Bogon output sink %S" sink)))))
1309
1310 (defun gdb-append-to-partial-output (string)
1311   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
1312     (goto-char (point-max))
1313     (insert string)))
1314
1315 (defun gdb-clear-partial-output ()
1316   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
1317     (erase-buffer)))
1318
1319 (defun gdb-append-to-inferior-io (string)
1320   (with-current-buffer (gdb-get-create-buffer 'gdb-inferior-io)
1321     (goto-char (point-max))
1322     (insert-before-markers string))
1323   (if (not (string-equal string ""))
1324       (gdb-display-buffer (gdb-get-create-buffer 'gdb-inferior-io))))
1325
1326 (defun gdb-clear-inferior-io ()
1327   (with-current-buffer (gdb-get-create-buffer 'gdb-inferior-io)
1328     (erase-buffer)))
1329 \f
1330
1331 ;; One trick is to have a command who's output is always available in a buffer
1332 ;; of it's own, and is always up to date.  We build several buffers of this
1333 ;; type.
1334 ;;
1335 ;; There are two aspects to this: gdb has to tell us when the output for that
1336 ;; command might have changed, and we have to be able to run the command
1337 ;; behind the user's back.
1338 ;;
1339 ;; The output phasing associated with the variable gdb-output-sink
1340 ;; help us to run commands behind the user's back.
1341 ;;
1342 ;; Below is the code for specificly managing buffers of output from one
1343 ;; command.
1344 ;;
1345
1346 ;; The trigger function is suitable for use in the assoc GDB-ANNOTATION-RULES
1347 ;; It adds an input for the command we are tracking.  It should be the
1348 ;; annotation rule binding of whatever gdb sends to tell us this command
1349 ;; might have changed it's output.
1350 ;;
1351 ;; NAME is the function name. DEMAND-PREDICATE tests if output is really needed.
1352 ;; GDB-COMMAND is a string of such.  OUTPUT-HANDLER is the function bound to the
1353 ;; input in the input queue (see comment about ``gdb communications'' above).
1354
1355 (defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command
1356                                             output-handler)
1357   `(defun ,name (&optional ignored)
1358      (if (and ,demand-predicate
1359               (not (member ',name
1360                            gdb-pending-triggers)))
1361          (progn
1362            (gdb-enqueue-input
1363             (list ,gdb-command ',output-handler))
1364            (push ',name gdb-pending-triggers)))))
1365
1366 (defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun)
1367   `(defun ,name ()
1368      (setq gdb-pending-triggers
1369       (delq ',trigger
1370             gdb-pending-triggers))
1371      (let ((buf (gdb-get-buffer ',buf-key)))
1372        (and buf
1373             (with-current-buffer buf
1374               (let* ((window (get-buffer-window buf 0))
1375                      (p (window-point window))
1376                     (buffer-read-only nil))
1377                 (erase-buffer)
1378                 (insert-buffer-substring (gdb-get-create-buffer
1379                                           'gdb-partial-output-buffer))
1380                 (set-window-point window p)))))
1381      ;; put customisation here
1382      (,custom-defun)))
1383
1384 (defmacro def-gdb-auto-updated-buffer (buffer-key
1385                                        trigger-name gdb-command
1386                                        output-handler-name custom-defun)
1387   `(progn
1388      (def-gdb-auto-update-trigger ,trigger-name
1389        ;; The demand predicate:
1390        (gdb-get-buffer ',buffer-key)
1391        ,gdb-command
1392        ,output-handler-name)
1393      (def-gdb-auto-update-handler ,output-handler-name
1394        ,trigger-name ,buffer-key ,custom-defun)))
1395
1396 \f
1397 ;;
1398 ;; Breakpoint buffer : This displays the output of `info breakpoints'.
1399 ;;
1400 (gdb-set-buffer-rules 'gdb-breakpoints-buffer
1401                       'gdb-breakpoints-buffer-name
1402                       'gdb-breakpoints-mode)
1403
1404 (def-gdb-auto-updated-buffer gdb-breakpoints-buffer
1405   ;; This defines the auto update rule for buffers of type
1406   ;; `gdb-breakpoints-buffer'.
1407   ;;
1408   ;; It defines a function to serve as the annotation handler that
1409   ;; handles the `foo-invalidated' message.  That function is called:
1410   gdb-invalidate-breakpoints
1411   ;;
1412   ;; To update the buffer, this command is sent to gdb.
1413   "server info breakpoints\n"
1414   ;;
1415   ;; This also defines a function to be the handler for the output
1416   ;; from the command above.  That function will copy the output into
1417   ;; the appropriately typed buffer.  That function will be called:
1418   gdb-info-breakpoints-handler
1419   ;; buffer specific functions
1420   gdb-info-breakpoints-custom)
1421
1422 (defconst breakpoint-xpm-data
1423   "/* XPM */
1424 static char *magick[] = {
1425 /* columns rows colors chars-per-pixel */
1426 \"10 10 2 1\",
1427 \"  c red\",
1428 \"+ c None\",
1429 /* pixels */
1430 \"+++    +++\",
1431 \"++      ++\",
1432 \"+        +\",
1433 \"          \",
1434 \"          \",
1435 \"          \",
1436 \"          \",
1437 \"+        +\",
1438 \"++      ++\",
1439 \"+++    +++\",
1440 };"
1441   "XPM data used for breakpoint icon.")
1442
1443 (defconst breakpoint-enabled-pbm-data
1444   "P1
1445 10 10\",
1446 0 0 0 0 1 1 1 1 0 0 0 0
1447 0 0 0 1 1 1 1 1 1 0 0 0
1448 0 0 1 1 1 1 1 1 1 1 0 0
1449 0 1 1 1 1 1 1 1 1 1 1 0
1450 0 1 1 1 1 1 1 1 1 1 1 0
1451 0 1 1 1 1 1 1 1 1 1 1 0
1452 0 1 1 1 1 1 1 1 1 1 1 0
1453 0 0 1 1 1 1 1 1 1 1 0 0
1454 0 0 0 1 1 1 1 1 1 0 0 0
1455 0 0 0 0 1 1 1 1 0 0 0 0"
1456   "PBM data used for enabled breakpoint icon.")
1457
1458 (defconst breakpoint-disabled-pbm-data
1459   "P1
1460 10 10\",
1461 0 0 1 0 1 0 1 0 0 0
1462 0 1 0 1 0 1 0 1 0 0
1463 1 0 1 0 1 0 1 0 1 0
1464 0 1 0 1 0 1 0 1 0 1
1465 1 0 1 0 1 0 1 0 1 0
1466 0 1 0 1 0 1 0 1 0 1
1467 1 0 1 0 1 0 1 0 1 0
1468 0 1 0 1 0 1 0 1 0 1
1469 0 0 1 0 1 0 1 0 1 0
1470 0 0 0 1 0 1 0 1 0 0"
1471   "PBM data used for disabled breakpoint icon.")
1472
1473 (defvar breakpoint-enabled-icon nil
1474   "Icon for enabled breakpoint in display margin.")
1475
1476 (defvar breakpoint-disabled-icon nil
1477   "Icon for disabled breakpoint in display margin.")
1478
1479 ;; Bitmap for breakpoint in fringe
1480 (and (display-images-p)
1481      (define-fringe-bitmap 'breakpoint
1482        "\x3c\x7e\xff\xff\xff\xff\x7e\x3c"))
1483
1484 (defface breakpoint-enabled
1485   '((t
1486      :foreground "red"
1487      :weight bold))
1488   "Face for enabled breakpoint icon in fringe."
1489   :group 'gud)
1490
1491 (defface breakpoint-disabled
1492   ;; We use different values of grey for different background types,
1493   ;; so that on low-color displays it will end up as something visible
1494   ;; if it has to be approximated.
1495   '((((background dark))  :foreground "grey60")
1496     (((background light)) :foreground "grey40"))
1497   "Face for disabled breakpoint icon in fringe."
1498   :group 'gud)
1499
1500 ;; Put breakpoint icons in relevant margins (even those set in the GUD buffer).
1501 (defun gdb-info-breakpoints-custom ()
1502   (let ((flag) (bptno))
1503     ;; Remove all breakpoint-icons in source buffers but not assembler buffer.
1504     (dolist (buffer (buffer-list))
1505       (with-current-buffer buffer
1506         (if (and (memq gud-minor-mode '(gdba gdbmi))
1507                  (not (string-match "\\`\\*.+\\*\\'" (buffer-name))))
1508             (gdb-remove-breakpoint-icons (point-min) (point-max)))))
1509     (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
1510       (save-excursion
1511         (goto-char (point-min))
1512         (while (< (point) (- (point-max) 1))
1513           (forward-line 1)
1514           (if (looking-at "[^\t].*?breakpoint")
1515               (progn
1516                 (looking-at "\\([0-9]+\\)\\s-+\\S-+\\s-+\\S-+\\s-+\\(.\\)")
1517                 (setq bptno (match-string 1))
1518                 (setq flag (char-after (match-beginning 2)))
1519                 (beginning-of-line)
1520                 (if (re-search-forward " in \\(.*\\) at\\s-+" nil t)
1521                     (progn
1522                       (let ((buffer-read-only nil))
1523                         (add-text-properties (match-beginning 1) (match-end 1)
1524                                              '(face font-lock-function-name-face)))
1525                       (looking-at "\\(\\S-+\\):\\([0-9]+\\)")
1526                       (let ((line (match-string 2)) (buffer-read-only nil)
1527                             (file (match-string 1)))
1528                         (add-text-properties (line-beginning-position)
1529                                              (line-end-position)
1530                          '(mouse-face highlight
1531                            help-echo "mouse-2, RET: visit breakpoint"))
1532                         (unless (file-exists-p file)
1533                            (setq file (cdr (assoc bptno gdb-location-alist))))
1534                         (if (and file
1535                                  (not (string-equal file "File not found")))
1536                             (with-current-buffer
1537                                 (find-file-noselect file 'nowarn)
1538                               (set (make-local-variable 'gud-minor-mode)
1539                                    'gdba)
1540                               (set (make-local-variable 'tool-bar-map)
1541                                    gud-tool-bar-map)
1542                               ;; Only want one breakpoint icon at each
1543                               ;; location.
1544                               (save-excursion
1545                                 (goto-line (string-to-number line))
1546                                 (gdb-put-breakpoint-icon (eq flag ?y) bptno)))
1547                           (gdb-enqueue-input
1548                            (list
1549                             (concat gdb-server-prefix "list "
1550                                     (match-string-no-properties 1) ":1\n")
1551                             'ignore))
1552                           (gdb-enqueue-input
1553                            (list (concat gdb-server-prefix "info source\n")
1554                                  `(lambda () (gdb-get-location
1555                                               ,bptno ,line ,flag))))))))))
1556           (end-of-line)))))
1557   (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)))
1558
1559 (defun gdb-mouse-set-clear-breakpoint (event)
1560   "Set/clear breakpoint in left fringe/margin with mouse click."
1561   (interactive "e")
1562   (mouse-minibuffer-check event)
1563   (let ((posn (event-end event)))
1564     (if (numberp (posn-point posn))
1565         (with-selected-window (posn-window posn)
1566           (save-excursion
1567             (goto-char (posn-point posn))
1568             (if (or (posn-object posn)
1569                     (eq (car (fringe-bitmaps-at-pos (posn-point posn)))
1570                         'breakpoint))
1571                 (gud-remove nil)
1572               (gud-break nil)))))))
1573
1574 (defun gdb-mouse-toggle-breakpoint-margin (event)
1575   "Enable/disable breakpoint in left margin with mouse click."
1576   (interactive "e")
1577   (mouse-minibuffer-check event)
1578   (let ((posn (event-end event)))
1579     (if (numberp (posn-point posn))
1580         (with-selected-window (posn-window posn)
1581           (save-excursion
1582             (goto-char (posn-point posn))
1583             (if (posn-object posn)
1584                 (gdb-enqueue-input
1585                  (list
1586                   (let ((bptno (get-text-property
1587                                 0 'gdb-bptno (car (posn-string posn)))))
1588                     (concat gdb-server-prefix
1589                             (if (get-text-property
1590                                  0 'gdb-enabled (car (posn-string posn)))
1591                                 "disable "
1592                               "enable ")
1593                             bptno "\n"))
1594                   'ignore))))))))
1595
1596 (defun gdb-mouse-toggle-breakpoint-fringe (event)
1597   "Enable/disable breakpoint in left fringe with mouse click."
1598   (interactive "e")
1599   (mouse-minibuffer-check event)
1600   (let* ((posn (event-end event))
1601          (pos (posn-point posn))
1602          obj)
1603     (when (numberp pos)
1604       (with-selected-window (posn-window posn)
1605         (save-excursion
1606           (set-buffer (window-buffer (selected-window)))
1607           (goto-char pos)
1608           (dolist (overlay (overlays-in pos pos))
1609             (when (overlay-get overlay 'put-break)
1610               (setq obj (overlay-get overlay 'before-string))))
1611           (when (stringp obj)
1612             (gdb-enqueue-input
1613              (list
1614               (concat gdb-server-prefix
1615                (if (get-text-property 0 'gdb-enabled obj)
1616                    "disable "
1617                  "enable ")
1618                (get-text-property 0 'gdb-bptno obj) "\n")
1619               'ignore))))))))
1620
1621 (defun gdb-breakpoints-buffer-name ()
1622   (with-current-buffer gud-comint-buffer
1623     (concat "*breakpoints of " (gdb-get-target-string) "*")))
1624
1625 (defun gdb-display-breakpoints-buffer ()
1626   "Display status of user-settable breakpoints."
1627   (interactive)
1628   (gdb-display-buffer
1629    (gdb-get-create-buffer 'gdb-breakpoints-buffer)))
1630
1631 (defun gdb-frame-breakpoints-buffer ()
1632   "Display status of user-settable breakpoints in a new frame."
1633   (interactive)
1634   (let ((special-display-regexps (append special-display-regexps '(".*")))
1635         (special-display-frame-alist gdb-frame-parameters))
1636     (display-buffer (gdb-get-create-buffer 'gdb-breakpoints-buffer))))
1637
1638 (defvar gdb-breakpoints-mode-map
1639   (let ((map (make-sparse-keymap))
1640         (menu (make-sparse-keymap "Breakpoints")))
1641     (define-key menu [quit] '("Quit"   . gdb-delete-frame-or-window))
1642     (define-key menu [goto] '("Goto"   . gdb-goto-breakpoint))
1643     (define-key menu [delete] '("Delete" . gdb-delete-breakpoint))
1644     (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint))
1645     (suppress-keymap map)
1646     (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu))
1647     (define-key map " " 'gdb-toggle-breakpoint)
1648     (define-key map "D" 'gdb-delete-breakpoint)
1649     ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons.
1650     (define-key map "q" 'gdb-delete-frame-or-window)
1651     (define-key map "\r" 'gdb-goto-breakpoint)
1652     (define-key map [mouse-2] 'gdb-goto-breakpoint)
1653     (define-key map [follow-link] 'mouse-face)
1654     map))
1655
1656 (defun gdb-delete-frame-or-window ()
1657   "Delete frame if there is only one window.  Otherwise delete the window."
1658   (interactive)
1659   (if (one-window-p) (delete-frame)
1660     (delete-window)))
1661
1662 (defun gdb-breakpoints-mode ()
1663   "Major mode for gdb breakpoints.
1664
1665 \\{gdb-breakpoints-mode-map}"
1666   (kill-all-local-variables)
1667   (setq major-mode 'gdb-breakpoints-mode)
1668   (setq mode-name "Breakpoints")
1669   (use-local-map gdb-breakpoints-mode-map)
1670   (setq buffer-read-only t)
1671   (run-mode-hooks 'gdb-breakpoints-mode-hook)
1672   (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
1673       'gdb-invalidate-breakpoints
1674     'gdbmi-invalidate-breakpoints))
1675
1676 (defconst gdb-breakpoint-regexp
1677   "\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\s-+\\(.\\)\\s-+")
1678
1679 (defun gdb-toggle-breakpoint ()
1680   "Enable/disable breakpoint at current line."
1681   (interactive)
1682   (save-excursion
1683     (beginning-of-line 1)
1684     (if (looking-at gdb-breakpoint-regexp)
1685         (gdb-enqueue-input
1686          (list
1687           (concat gdb-server-prefix
1688                   (if (eq ?y (char-after (match-beginning 2)))
1689                       "disable "
1690                     "enable ")
1691                   (match-string 1) "\n") 'ignore))
1692       (error "Not recognized as break/watchpoint line"))))
1693
1694 (defun gdb-delete-breakpoint ()
1695   "Delete the breakpoint at current line."
1696   (interactive)
1697   (beginning-of-line 1)
1698   (if (looking-at gdb-breakpoint-regexp)
1699       (gdb-enqueue-input
1700        (list
1701         (concat gdb-server-prefix "delete " (match-string 1) "\n") 'ignore))
1702     (error "Not recognized as break/watchpoint line")))
1703
1704 (defun gdb-goto-breakpoint (&optional event)
1705   "Display the breakpoint location specified at current line."
1706   (interactive (list last-input-event))
1707   (if event (posn-set-point (event-end event)))
1708   ;; Hack to stop gdb-goto-breakpoint displaying in GUD buffer.
1709   (let ((window (get-buffer-window gud-comint-buffer)))
1710     (if window (save-selected-window  (select-window window))))
1711   (save-excursion
1712     (beginning-of-line 1)
1713     (if (looking-at "\\([0-9]+\\) .+ in .+ at\\s-+\\(\\S-+\\):\\([0-9]+\\)")
1714         (let ((bptno (match-string 1))
1715               (file  (match-string 2))
1716               (line  (match-string 3)))
1717           (save-selected-window
1718             (let* ((buf (find-file-noselect
1719                          (if (file-exists-p file) file
1720                            (cdr (assoc bptno gdb-location-alist)))))
1721                    (window (display-buffer buf)))
1722               (with-current-buffer buf
1723                 (goto-line (string-to-number line))
1724                 (set-window-point window (point))))))
1725       (error "No location specified."))))
1726 \f
1727
1728 ;; Frames buffer.  This displays a perpetually correct bactracktrace
1729 ;; (from the command `where').
1730 ;;
1731 ;; Alas, if your stack is deep, it is costly.
1732 ;;
1733 (gdb-set-buffer-rules 'gdb-stack-buffer
1734                       'gdb-stack-buffer-name
1735                       'gdb-frames-mode)
1736
1737 (def-gdb-auto-updated-buffer gdb-stack-buffer
1738   gdb-invalidate-frames
1739   "server where\n"
1740   gdb-info-frames-handler
1741   gdb-info-frames-custom)
1742
1743 (defun gdb-info-frames-custom ()
1744   (with-current-buffer (gdb-get-buffer 'gdb-stack-buffer)
1745     (save-excursion
1746       (let ((buffer-read-only nil)
1747             bl el)
1748         (goto-char (point-min))
1749         (while (< (point) (point-max))
1750           (setq bl (line-beginning-position)
1751                 el (line-end-position))
1752           (when (looking-at "#")
1753             (add-text-properties bl el
1754                                  '(mouse-face highlight
1755                                    help-echo "mouse-2, RET: Select frame")))
1756           (goto-char bl)
1757           (when (looking-at "^#\\([0-9]+\\)")
1758             (when (string-equal (match-string 1) gdb-frame-number)
1759                 (put-text-property bl (+ bl 4)
1760                                    'face '(:inverse-video t)))
1761             (when (re-search-forward
1762                    (concat
1763                     (if (string-equal (match-string 1) "0") "" " in ")
1764                     "\\([^ ]+\\) (") el t)
1765               (put-text-property (match-beginning 1) (match-end 1)
1766                                  'face font-lock-function-name-face)
1767               (setq bl (match-end 0))
1768               (while (re-search-forward "<\\([^>]+\\)>" el t)
1769                 (put-text-property (match-beginning 1) (match-end 1)
1770                                      'face font-lock-function-name-face))
1771               (goto-char bl)
1772               (while (re-search-forward "\\(\\(\\sw\\|[_.]\\)+\\)=" el t)
1773                 (put-text-property (match-beginning 1) (match-end 1)
1774                                    'face font-lock-variable-name-face))))
1775           (forward-line 1))))))
1776
1777 (defun gdb-stack-buffer-name ()
1778   (with-current-buffer gud-comint-buffer
1779     (concat "*stack frames of " (gdb-get-target-string) "*")))
1780
1781 (defun gdb-display-stack-buffer ()
1782   "Display backtrace of current stack."
1783   (interactive)
1784   (gdb-display-buffer
1785    (gdb-get-create-buffer 'gdb-stack-buffer)))
1786
1787 (defun gdb-frame-stack-buffer ()
1788   "Display backtrace of current stack in a new frame."
1789   (interactive)
1790   (let ((special-display-regexps (append special-display-regexps '(".*")))
1791         (special-display-frame-alist gdb-frame-parameters))
1792     (display-buffer (gdb-get-create-buffer 'gdb-stack-buffer))))
1793
1794 (defvar gdb-frames-mode-map
1795   (let ((map (make-sparse-keymap)))
1796     (suppress-keymap map)
1797     (define-key map "q" 'kill-this-buffer)
1798     (define-key map "\r" 'gdb-frames-select)
1799     (define-key map [mouse-2] 'gdb-frames-select)
1800     (define-key map [follow-link] 'mouse-face)
1801     map))
1802
1803 (defun gdb-frames-mode ()
1804   "Major mode for gdb frames.
1805
1806 \\{gdb-frames-mode-map}"
1807   (kill-all-local-variables)
1808   (setq major-mode 'gdb-frames-mode)
1809   (setq mode-name "Frames")
1810   (setq buffer-read-only t)
1811   (use-local-map gdb-frames-mode-map)
1812   (run-mode-hooks 'gdb-frames-mode-hook)
1813   (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
1814       'gdb-invalidate-frames
1815     'gdbmi-invalidate-frames))
1816
1817 (defun gdb-get-frame-number ()
1818   (save-excursion
1819     (end-of-line)
1820     (let* ((start (line-beginning-position))
1821            (pos (re-search-backward "^#*\\([0-9]+\\)" start t))
1822            (n (or (and pos (match-string-no-properties 1)) "0")))
1823       n)))
1824
1825 (defun gdb-frames-select (&optional event)
1826   "Select the frame and display the relevant source."
1827   (interactive (list last-input-event))
1828   (if event (posn-set-point (event-end event)))
1829   (gdb-enqueue-input
1830    (list (concat gdb-server-prefix "frame "
1831                  (gdb-get-frame-number) "\n") 'ignore))
1832   (gud-display-frame))
1833 \f
1834
1835 ;; Threads buffer.  This displays a selectable thread list.
1836 ;;
1837 (gdb-set-buffer-rules 'gdb-threads-buffer
1838                       'gdb-threads-buffer-name
1839                       'gdb-threads-mode)
1840
1841 (def-gdb-auto-updated-buffer gdb-threads-buffer
1842   gdb-invalidate-threads
1843   (concat gdb-server-prefix "info threads\n")
1844   gdb-info-threads-handler
1845   gdb-info-threads-custom)
1846
1847 (defun gdb-info-threads-custom ()
1848   (with-current-buffer (gdb-get-buffer 'gdb-threads-buffer)
1849     (let ((buffer-read-only nil))
1850       (goto-char (point-min))
1851       (while (< (point) (point-max))
1852         (unless (looking-at "No ")
1853           (add-text-properties (line-beginning-position) (line-end-position)
1854                                '(mouse-face highlight
1855                                  help-echo "mouse-2, RET: select thread")))
1856         (forward-line 1)))))
1857
1858 (defun gdb-threads-buffer-name ()
1859   (with-current-buffer gud-comint-buffer
1860     (concat "*threads of " (gdb-get-target-string) "*")))
1861
1862 (defun gdb-display-threads-buffer ()
1863   "Display IDs of currently known threads."
1864   (interactive)
1865   (gdb-display-buffer
1866    (gdb-get-create-buffer 'gdb-threads-buffer)))
1867
1868 (defun gdb-frame-threads-buffer ()
1869   "Display IDs of currently known threads in a new frame."
1870   (interactive)
1871   (let ((special-display-regexps (append special-display-regexps '(".*")))
1872         (special-display-frame-alist gdb-frame-parameters))
1873     (display-buffer (gdb-get-create-buffer 'gdb-threads-buffer))))
1874
1875 (defvar gdb-threads-mode-map
1876   (let ((map (make-sparse-keymap)))
1877     (suppress-keymap map)
1878     (define-key map "q" 'kill-this-buffer)
1879     (define-key map "\r" 'gdb-threads-select)
1880     (define-key map [mouse-2] 'gdb-threads-select)
1881     (define-key map [follow-link] 'mouse-face)
1882     map))
1883
1884 (defvar gdb-threads-font-lock-keywords
1885   '(
1886     (") +\\([^ ]+\\) ("  (1 font-lock-function-name-face))
1887     ("in \\([^ ]+\\) ("  (1 font-lock-function-name-face))
1888     ("\\(\\(\\sw\\|[_.]\\)+\\)="  (1 font-lock-variable-name-face))
1889     )
1890   "Font lock keywords used in `gdb-threads-mode'.")
1891
1892 (defun gdb-threads-mode ()
1893   "Major mode for gdb frames.
1894
1895 \\{gdb-threads-mode-map}"
1896   (kill-all-local-variables)
1897   (setq major-mode 'gdb-threads-mode)
1898   (setq mode-name "Threads")
1899   (setq buffer-read-only t)
1900   (use-local-map gdb-threads-mode-map)
1901   (set (make-local-variable 'font-lock-defaults)
1902        '(gdb-threads-font-lock-keywords))
1903   (run-mode-hooks 'gdb-threads-mode-hook)
1904   'gdb-invalidate-threads)
1905
1906 (defun gdb-get-thread-number ()
1907   (save-excursion
1908     (re-search-backward "^\\s-*\\([0-9]*\\)" nil t)
1909     (match-string-no-properties 1)))
1910
1911 (defun gdb-threads-select (&optional event)
1912   "Select the thread and display the relevant source."
1913   (interactive (list last-input-event))
1914   (if event (posn-set-point (event-end event)))
1915   (gdb-enqueue-input
1916    (list (concat gdb-server-prefix "thread "
1917                  (gdb-get-thread-number) "\n") 'ignore))
1918   (gud-display-frame))
1919 \f
1920
1921 ;; Registers buffer.
1922 ;;
1923 (defcustom gdb-all-registers nil
1924   "Non-nil means include floating-point registers."
1925   :type 'boolean
1926   :group 'gud
1927   :version "22.1")
1928
1929 (gdb-set-buffer-rules 'gdb-registers-buffer
1930                       'gdb-registers-buffer-name
1931                       'gdb-registers-mode)
1932
1933 (def-gdb-auto-updated-buffer gdb-registers-buffer
1934   gdb-invalidate-registers
1935   (concat
1936    gdb-server-prefix "info " (if gdb-all-registers "all-") "registers\n")
1937   gdb-info-registers-handler
1938   gdb-info-registers-custom)
1939
1940 (defun gdb-info-registers-custom ()
1941   (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
1942     (save-excursion
1943       (let ((buffer-read-only nil)
1944             start end)
1945         (goto-char (point-min))
1946         (while (< (point) (point-max))
1947           (setq start (line-beginning-position))
1948           (setq end (line-end-position))
1949           (when (looking-at "^[^ ]+")
1950             (unless (string-equal (match-string 0) "The")
1951               (put-text-property start (match-end 0)
1952                                  'face font-lock-variable-name-face)
1953               (add-text-properties start end
1954                                    '(help-echo "mouse-2: edit value"
1955                                      mouse-face highlight))))
1956           (forward-line 1))))))
1957
1958 (defun gdb-edit-register-value (&optional event)
1959   (interactive (list last-input-event))
1960   (save-excursion
1961     (if event (posn-set-point (event-end event)))
1962     (beginning-of-line)
1963     (let* ((register (current-word))
1964           (value (read-string (format "New value (%s): " register))))
1965       (gdb-enqueue-input
1966        (list (concat gdb-server-prefix "set $" register "=" value "\n")
1967              'ignore)))))
1968
1969 (defvar gdb-registers-mode-map
1970   (let ((map (make-sparse-keymap)))
1971     (suppress-keymap map)
1972     (define-key map "\r" 'gdb-edit-register-value)
1973     (define-key map [mouse-2] 'gdb-edit-register-value)
1974     (define-key map " " 'gdb-all-registers)
1975     (define-key map "q" 'kill-this-buffer)
1976      map))
1977
1978 (defun gdb-registers-mode ()
1979   "Major mode for gdb registers.
1980
1981 \\{gdb-registers-mode-map}"
1982   (kill-all-local-variables)
1983   (setq major-mode 'gdb-registers-mode)
1984   (setq mode-name "Registers")
1985   (setq buffer-read-only t)
1986   (use-local-map gdb-registers-mode-map)
1987   (run-mode-hooks 'gdb-registers-mode-hook)
1988   (if (string-equal gdb-version "pre-6.4")
1989       (progn
1990         (if gdb-all-registers (setq mode-name "Registers:All"))
1991         'gdb-invalidate-registers)
1992     'gdb-invalidate-registers-1))
1993
1994 (defun gdb-registers-buffer-name ()
1995   (with-current-buffer gud-comint-buffer
1996     (concat "*registers of " (gdb-get-target-string) "*")))
1997
1998 (defun gdb-display-registers-buffer ()
1999   "Display integer register contents."
2000   (interactive)
2001   (gdb-display-buffer
2002    (gdb-get-create-buffer 'gdb-registers-buffer)))
2003
2004 (defun gdb-frame-registers-buffer ()
2005   "Display integer register contents in a new frame."
2006   (interactive)
2007   (let ((special-display-regexps (append special-display-regexps '(".*")))
2008         (special-display-frame-alist gdb-frame-parameters))
2009     (display-buffer (gdb-get-create-buffer 'gdb-registers-buffer))))
2010
2011 (defun gdb-all-registers ()
2012   "Toggle the display of floating-point registers (pre GDB 6.4 only)."
2013   (interactive)
2014   (when (string-equal gdb-version "pre-6.4")
2015     (if gdb-all-registers
2016         (progn
2017           (setq gdb-all-registers nil)
2018           (with-current-buffer (gdb-get-create-buffer 'gdb-registers-buffer)
2019             (setq mode-name "Registers")))
2020       (setq gdb-all-registers t)
2021       (with-current-buffer (gdb-get-create-buffer 'gdb-registers-buffer)
2022         (setq mode-name "Registers:All")))
2023     (message (format "Display of floating-point registers %sabled"
2024                      (if gdb-all-registers "en" "dis")))
2025     (gdb-invalidate-registers)))
2026 \f
2027
2028 ;; Memory buffer.
2029 ;;
2030 (defcustom gdb-memory-repeat-count 32
2031   "Number of data items in memory window."
2032   :type 'integer
2033   :group 'gud
2034   :version "22.1")
2035
2036 (defcustom gdb-memory-format "x"
2037   "Display format of data items in memory window."
2038   :type '(choice (const :tag "Hexadecimal" "x")
2039                  (const :tag "Signed decimal" "d")
2040                  (const :tag "Unsigned decimal" "u")
2041                  (const :tag "Octal" "o")
2042                  (const :tag "Binary" "t"))
2043   :group 'gud
2044   :version "22.1")
2045
2046 (defcustom gdb-memory-unit "w"
2047   "Unit size of data items in memory window."
2048   :type '(choice (const :tag "Byte" "b")
2049                  (const :tag "Halfword" "h")
2050                  (const :tag "Word" "w")
2051                  (const :tag "Giant word" "g"))
2052   :group 'gud
2053   :version "22.1")
2054
2055 (gdb-set-buffer-rules 'gdb-memory-buffer
2056                       'gdb-memory-buffer-name
2057                       'gdb-memory-mode)
2058
2059 (def-gdb-auto-updated-buffer gdb-memory-buffer
2060   gdb-invalidate-memory
2061   (concat gdb-server-prefix "x/" (number-to-string gdb-memory-repeat-count)
2062           gdb-memory-format gdb-memory-unit " " gdb-memory-address "\n")
2063   gdb-read-memory-handler
2064   gdb-read-memory-custom)
2065
2066 (defun gdb-read-memory-custom ()
2067   (save-excursion
2068     (goto-char (point-min))
2069     (if (looking-at "0x[[:xdigit:]]+")
2070         (setq gdb-memory-address (match-string 0)))))
2071
2072 (defvar gdb-memory-mode-map
2073   (let ((map (make-sparse-keymap)))
2074     (suppress-keymap map)
2075     (define-key map "q" 'kill-this-buffer)
2076      map))
2077
2078 (defun gdb-memory-set-address (event)
2079   "Set the start memory address."
2080   (interactive "e")
2081   (save-selected-window
2082     (select-window (posn-window (event-start event)))
2083     (let ((arg (read-from-minibuffer "Memory address: ")))
2084       (setq gdb-memory-address arg))
2085     (gdb-invalidate-memory)))
2086
2087 (defun gdb-memory-set-repeat-count (event)
2088   "Set the number of data items in memory window."
2089   (interactive "e")
2090   (save-selected-window
2091     (select-window (posn-window (event-start event)))
2092     (let* ((arg (read-from-minibuffer "Repeat count: "))
2093           (count (string-to-number arg)))
2094       (if (<= count 0)
2095           (error "Positive numbers only")
2096         (customize-set-variable 'gdb-memory-repeat-count count)
2097         (gdb-invalidate-memory)))))
2098
2099 (defun gdb-memory-format-binary ()
2100   "Set the display format to binary."
2101   (interactive)
2102   (customize-set-variable 'gdb-memory-format "t")
2103   (gdb-invalidate-memory))
2104
2105 (defun gdb-memory-format-octal ()
2106   "Set the display format to octal."
2107   (interactive)
2108   (customize-set-variable 'gdb-memory-format "o")
2109   (gdb-invalidate-memory))
2110
2111 (defun gdb-memory-format-unsigned ()
2112   "Set the display format to unsigned decimal."
2113   (interactive)
2114   (customize-set-variable 'gdb-memory-format "u")
2115   (gdb-invalidate-memory))
2116
2117 (defun gdb-memory-format-signed ()
2118   "Set the display format to decimal."
2119   (interactive)
2120   (customize-set-variable 'gdb-memory-format "d")
2121   (gdb-invalidate-memory))
2122
2123 (defun gdb-memory-format-hexadecimal ()
2124   "Set the display format to hexadecimal."
2125   (interactive)
2126   (customize-set-variable 'gdb-memory-format "x")
2127   (gdb-invalidate-memory))
2128
2129 (defvar gdb-memory-format-map
2130   (let ((map (make-sparse-keymap)))
2131     (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1)
2132     map)
2133  "Keymap to select format in the header line.")
2134
2135 (defvar gdb-memory-format-menu (make-sparse-keymap "Format")
2136  "Menu of display formats in the header line.")
2137
2138 (define-key gdb-memory-format-menu [binary]
2139   '(menu-item "Binary" gdb-memory-format-binary
2140               :button (:radio . (equal gdb-memory-format "t"))))
2141 (define-key gdb-memory-format-menu [octal]
2142   '(menu-item "Octal" gdb-memory-format-octal
2143               :button (:radio . (equal gdb-memory-format "o"))))
2144 (define-key gdb-memory-format-menu [unsigned]
2145   '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned
2146               :button (:radio . (equal gdb-memory-format "u"))))
2147 (define-key gdb-memory-format-menu [signed]
2148   '(menu-item "Signed Decimal" gdb-memory-format-signed
2149               :button (:radio . (equal gdb-memory-format "d"))))
2150 (define-key gdb-memory-format-menu [hexadecimal]
2151   '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal
2152               :button (:radio . (equal gdb-memory-format "x"))))
2153
2154 (defun gdb-memory-format-menu (event)
2155   (interactive "@e")
2156   (x-popup-menu event gdb-memory-format-menu))
2157
2158 (defun gdb-memory-format-menu-1 (event)
2159   (interactive "e")
2160   (save-selected-window
2161     (select-window (posn-window (event-start event)))
2162     (let* ((selection (gdb-memory-format-menu event))
2163            (binding (and selection (lookup-key gdb-memory-format-menu
2164                                                (vector (car selection))))))
2165       (if binding (call-interactively binding)))))
2166
2167 (defun gdb-memory-unit-giant ()
2168   "Set the unit size to giant words (eight bytes)."
2169   (interactive)
2170   (customize-set-variable 'gdb-memory-unit "g")
2171   (gdb-invalidate-memory))
2172
2173 (defun gdb-memory-unit-word ()
2174   "Set the unit size to words (four bytes)."
2175   (interactive)
2176   (customize-set-variable 'gdb-memory-unit "w")
2177   (gdb-invalidate-memory))
2178
2179 (defun gdb-memory-unit-halfword ()
2180   "Set the unit size to halfwords (two bytes)."
2181   (interactive)
2182   (customize-set-variable 'gdb-memory-unit "h")
2183   (gdb-invalidate-memory))
2184
2185 (defun gdb-memory-unit-byte ()
2186   "Set the unit size to bytes."
2187   (interactive)
2188   (customize-set-variable 'gdb-memory-unit "b")
2189   (gdb-invalidate-memory))
2190
2191 (defvar gdb-memory-unit-map
2192   (let ((map (make-sparse-keymap)))
2193     (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1)
2194     map)
2195  "Keymap to select units in the header line.")
2196
2197 (defvar gdb-memory-unit-menu (make-sparse-keymap "Unit")
2198  "Menu of units in the header line.")
2199
2200 (define-key gdb-memory-unit-menu [giantwords]
2201   '(menu-item "Giant words" gdb-memory-unit-giant
2202               :button (:radio . (equal gdb-memory-unit "g"))))
2203 (define-key gdb-memory-unit-menu [words]
2204   '(menu-item "Words" gdb-memory-unit-word
2205               :button (:radio . (equal gdb-memory-unit "w"))))
2206 (define-key gdb-memory-unit-menu [halfwords]
2207   '(menu-item "Halfwords" gdb-memory-unit-halfword
2208               :button (:radio . (equal gdb-memory-unit "h"))))
2209 (define-key gdb-memory-unit-menu [bytes]
2210   '(menu-item "Bytes" gdb-memory-unit-byte
2211               :button (:radio . (equal gdb-memory-unit "b"))))
2212
2213 (defun gdb-memory-unit-menu (event)
2214   (interactive "@e")
2215   (x-popup-menu event gdb-memory-unit-menu))
2216
2217 (defun gdb-memory-unit-menu-1 (event)
2218   (interactive "e")
2219   (save-selected-window
2220     (select-window (posn-window (event-start event)))
2221     (let* ((selection (gdb-memory-unit-menu event))
2222            (binding (and selection (lookup-key gdb-memory-unit-menu
2223                                                (vector (car selection))))))
2224       (if binding (call-interactively binding)))))
2225
2226 ;;from make-mode-line-mouse-map
2227 (defun gdb-make-header-line-mouse-map (mouse function) "\
2228 Return a keymap with single entry for mouse key MOUSE on the header line.
2229 MOUSE is defined to run function FUNCTION with no args in the buffer
2230 corresponding to the mode line clicked."
2231   (let ((map (make-sparse-keymap)))
2232     (define-key map (vector 'header-line mouse) function)
2233     (define-key map (vector 'header-line 'down-mouse-1) 'ignore)
2234     map))
2235
2236 (defvar gdb-memory-font-lock-keywords
2237   '(;; <__function.name+n>
2238     ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face))
2239     )
2240   "Font lock keywords used in `gdb-memory-mode'.")
2241
2242 (defun gdb-memory-mode ()
2243   "Major mode for examining memory.
2244
2245 \\{gdb-memory-mode-map}"
2246   (kill-all-local-variables)
2247   (setq major-mode 'gdb-memory-mode)
2248   (setq mode-name "Memory")
2249   (setq buffer-read-only t)
2250   (use-local-map gdb-memory-mode-map)
2251   (setq header-line-format
2252         '(:eval
2253           (concat
2254            "Read address["
2255            (propertize
2256             "-"
2257             'face font-lock-warning-face
2258             'help-echo "mouse-1: Decrement address"
2259             'mouse-face 'mode-line-highlight
2260             'local-map
2261             (gdb-make-header-line-mouse-map
2262              'mouse-1
2263              #'(lambda () (interactive)
2264                  (let ((gdb-memory-address
2265                         ;; Let GDB do the arithmetic.
2266                         (concat
2267                          gdb-memory-address " - "
2268                          (number-to-string
2269                           (* gdb-memory-repeat-count
2270                              (cond ((string= gdb-memory-unit "b") 1)
2271                                    ((string= gdb-memory-unit "h") 2)
2272                                    ((string= gdb-memory-unit "w") 4)
2273                                    ((string= gdb-memory-unit "g") 8)))))))
2274                        (gdb-invalidate-memory)))))
2275            "|"
2276            (propertize "+"
2277                        'face font-lock-warning-face
2278                        'help-echo "mouse-1: Increment address"
2279                        'mouse-face 'mode-line-highlight
2280                        'local-map (gdb-make-header-line-mouse-map
2281                                    'mouse-1
2282                                    #'(lambda () (interactive)
2283                                        (let ((gdb-memory-address nil))
2284                                          (gdb-invalidate-memory)))))
2285            "]: "
2286            (propertize gdb-memory-address
2287                        'face font-lock-warning-face
2288                        'help-echo "mouse-1: Set memory address"
2289                        'mouse-face 'mode-line-highlight
2290                        'local-map (gdb-make-header-line-mouse-map
2291                                    'mouse-1
2292                                    #'gdb-memory-set-address))
2293            "  Repeat Count: "
2294            (propertize (number-to-string gdb-memory-repeat-count)
2295                        'face font-lock-warning-face
2296                        'help-echo "mouse-1: Set repeat count"
2297                        'mouse-face 'mode-line-highlight
2298                        'local-map (gdb-make-header-line-mouse-map
2299                                    'mouse-1
2300                                    #'gdb-memory-set-repeat-count))
2301            "  Display Format: "
2302            (propertize gdb-memory-format
2303                        'face font-lock-warning-face
2304                        'help-echo "mouse-3: Select display format"
2305                        'mouse-face 'mode-line-highlight
2306                        'local-map gdb-memory-format-map)
2307            "  Unit Size: "
2308            (propertize gdb-memory-unit
2309                        'face font-lock-warning-face
2310                        'help-echo "mouse-3: Select unit size"
2311                        'mouse-face 'mode-line-highlight
2312                        'local-map gdb-memory-unit-map))))
2313   (set (make-local-variable 'font-lock-defaults)
2314        '(gdb-memory-font-lock-keywords))
2315   (run-mode-hooks 'gdb-memory-mode-hook)
2316   'gdb-invalidate-memory)
2317
2318 (defun gdb-memory-buffer-name ()
2319   (with-current-buffer gud-comint-buffer
2320     (concat "*memory of " (gdb-get-target-string) "*")))
2321
2322 (defun gdb-display-memory-buffer ()
2323   "Display memory contents."
2324   (interactive)
2325   (gdb-display-buffer
2326    (gdb-get-create-buffer 'gdb-memory-buffer)))
2327
2328 (defun gdb-frame-memory-buffer ()
2329   "Display memory contents in a new frame."
2330   (interactive)
2331   (let ((special-display-regexps (append special-display-regexps '(".*")))
2332         (special-display-frame-alist gdb-frame-parameters))
2333     (display-buffer (gdb-get-create-buffer 'gdb-memory-buffer))))
2334 \f
2335
2336 ;; Locals buffer.
2337 ;;
2338 (gdb-set-buffer-rules 'gdb-locals-buffer
2339                       'gdb-locals-buffer-name
2340                       'gdb-locals-mode)
2341
2342 (def-gdb-auto-update-trigger gdb-invalidate-locals
2343   (gdb-get-buffer 'gdb-locals-buffer)
2344   "server info locals\n"
2345   gdb-info-locals-handler)
2346
2347 (defvar gdb-locals-watch-map
2348   (let ((map (make-sparse-keymap)))
2349     (define-key map "\r" '(lambda () (interactive)
2350                             (beginning-of-line)
2351                             (gud-watch)))
2352     (define-key map [mouse-2] '(lambda (event) (interactive "e")
2353                                  (mouse-set-point event)
2354                                  (beginning-of-line)
2355                                  (gud-watch)))
2356     map)
2357  "Keymap to create watch expression of a complex data type local variable.")
2358
2359 (defconst gdb-struct-string
2360   (concat (propertize "[struct/union]"
2361                       'mouse-face 'highlight
2362                       'help-echo "mouse-2: create watch expression"
2363                       'local-map gdb-locals-watch-map) "\n"))
2364
2365 (defconst gdb-array-string
2366   (concat " " (propertize "[array]"
2367                           'mouse-face 'highlight
2368                           'help-echo "mouse-2: create watch expression"
2369                           'local-map gdb-locals-watch-map) "\n"))
2370
2371 ;; Abbreviate for arrays and structures.
2372 ;; These can be expanded using gud-display.
2373 (defun gdb-info-locals-handler ()
2374   (setq gdb-pending-triggers (delq 'gdb-invalidate-locals
2375                                   gdb-pending-triggers))
2376   (let ((buf (gdb-get-buffer 'gdb-partial-output-buffer)))
2377     (with-current-buffer buf
2378       (goto-char (point-min))
2379       (while (re-search-forward "^[ }].*\n" nil t)
2380         (replace-match "" nil nil))
2381       (goto-char (point-min))
2382       (while (re-search-forward "{\\(.*=.*\n\\|\n\\)" nil t)
2383         (replace-match gdb-struct-string nil nil))
2384       (goto-char (point-min))
2385       (while (re-search-forward "\\s-*{.*\n" nil t)
2386         (replace-match gdb-array-string nil nil))))
2387   (let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
2388     (and buf
2389          (with-current-buffer buf
2390               (let* ((window (get-buffer-window buf 0))
2391                      (p (window-point window))
2392                      (buffer-read-only nil))
2393                  (erase-buffer)
2394                  (insert-buffer-substring (gdb-get-create-buffer
2395                                            'gdb-partial-output-buffer))
2396                 (set-window-point window p)))))
2397   (run-hooks 'gdb-info-locals-hook))
2398
2399 (defvar gdb-locals-mode-map
2400   (let ((map (make-sparse-keymap)))
2401     (suppress-keymap map)
2402     (define-key map "q" 'kill-this-buffer)
2403      map))
2404
2405 (defun gdb-locals-mode ()
2406   "Major mode for gdb locals.
2407
2408 \\{gdb-locals-mode-map}"
2409   (kill-all-local-variables)
2410   (setq major-mode 'gdb-locals-mode)
2411   (setq mode-name (concat "Locals:" gdb-selected-frame))
2412   (setq buffer-read-only t)
2413   (use-local-map gdb-locals-mode-map)
2414   (set (make-local-variable 'font-lock-defaults)
2415        '(gdb-locals-font-lock-keywords))
2416   (run-mode-hooks 'gdb-locals-mode-hook)
2417   (if (and (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
2418            (string-equal gdb-version "pre-6.4"))
2419       'gdb-invalidate-locals
2420     'gdb-invalidate-locals-1))
2421
2422 (defun gdb-locals-buffer-name ()
2423   (with-current-buffer gud-comint-buffer
2424     (concat "*locals of " (gdb-get-target-string) "*")))
2425
2426 (defun gdb-display-locals-buffer ()
2427   "Display local variables of current stack and their values."
2428   (interactive)
2429   (gdb-display-buffer
2430    (gdb-get-create-buffer 'gdb-locals-buffer)))
2431
2432 (defun gdb-frame-locals-buffer ()
2433   "Display local variables of current stack and their values in a new frame."
2434   (interactive)
2435   (let ((special-display-regexps (append special-display-regexps '(".*")))
2436         (special-display-frame-alist gdb-frame-parameters))
2437     (display-buffer (gdb-get-create-buffer 'gdb-locals-buffer))))
2438 \f
2439
2440 ;;;; Window management
2441 (defun gdb-display-buffer (buf &optional size)
2442   (let ((answer (get-buffer-window buf 0))
2443         (must-split nil))
2444     (if answer
2445         (display-buffer buf nil 0)      ;Raise the frame if necessary.
2446       ;; The buffer is not yet displayed.
2447       (pop-to-buffer gud-comint-buffer) ;Select the right frame.
2448       (let ((window (get-lru-window)))
2449         (if (and window
2450             (not (eq window (get-buffer-window gud-comint-buffer))))
2451             (progn
2452               (set-window-buffer window buf)
2453               (setq answer window))
2454           (setq must-split t)))
2455       (if must-split
2456           (let* ((largest (get-largest-window))
2457                  (cur-size (window-height largest))
2458                  (new-size (and size (< size cur-size) (- cur-size size))))
2459             (setq answer (split-window largest new-size))
2460             (set-window-buffer answer buf)
2461             (set-window-dedicated-p answer t)))
2462       answer)))
2463
2464 \f
2465 ;;; Shared keymap initialization:
2466
2467 (let ((menu (make-sparse-keymap "GDB-Windows")))
2468   (define-key gud-menu-map [displays]
2469     `(menu-item "GDB-Windows" ,menu
2470                 :visible (memq gud-minor-mode '(gdbmi gdba))))
2471   (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer))
2472   (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
2473   (define-key menu [inferior]
2474     '(menu-item "Inferior IO" gdb-display-separate-io-buffer
2475                 :enable gdb-use-separate-io-buffer))
2476   (define-key menu [memory] '("Memory" . gdb-display-memory-buffer))
2477   (define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
2478   (define-key menu [disassembly]
2479     '("Disassembly" . gdb-display-assembler-buffer))
2480   (define-key menu [breakpoints]
2481     '("Breakpoints" . gdb-display-breakpoints-buffer))
2482   (define-key menu [locals] '("Locals" . gdb-display-locals-buffer))
2483   (define-key menu [frames] '("Stack" . gdb-display-stack-buffer)))
2484
2485 (let ((menu (make-sparse-keymap "GDB-Frames")))
2486   (define-key gud-menu-map [frames]
2487     `(menu-item "GDB-Frames" ,menu
2488                 :visible (memq gud-minor-mode '(gdbmi gdba))))
2489   (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer))
2490   (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
2491   (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer))
2492   (define-key menu [inferior]
2493     '(menu-item "Inferior IO" gdb-frame-separate-io-buffer
2494                 :enable gdb-use-separate-io-buffer))
2495   (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
2496   (define-key menu [disassembly] '("Disassembiy" . gdb-frame-assembler-buffer))
2497   (define-key menu [breakpoints]
2498     '("Breakpoints" . gdb-frame-breakpoints-buffer))
2499   (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer))
2500   (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer)))
2501
2502 (let ((menu (make-sparse-keymap "GDB-UI/MI")))
2503   (define-key gud-menu-map [ui]
2504     `(menu-item (if (eq gud-minor-mode 'gdba) "GDB-UI" "GDB-MI")
2505                 ,menu :visible (memq gud-minor-mode '(gdbmi gdba))))
2506   (define-key menu [gdb-use-separate-io]
2507   '(menu-item "Separate inferior IO" gdb-use-separate-io-buffer
2508               :visible (eq gud-minor-mode 'gdba)
2509               :help "Toggle separate IO for inferior."
2510               :button (:toggle . gdb-use-separate-io-buffer)))
2511   (define-key menu [gdb-many-windows]
2512   '(menu-item "Display Other Windows" gdb-many-windows
2513               :help "Toggle display of locals, stack and breakpoint information"
2514               :button (:toggle . gdb-many-windows)))
2515   (define-key menu [gdb-restore-windows]
2516   '(menu-item "Restore Window Layout" gdb-restore-windows
2517               :help "Restore standard layout for debug session.")))
2518
2519 (defun gdb-frame-gdb-buffer ()
2520   "Display GUD buffer in a new frame."
2521   (interactive)
2522   (let ((special-display-regexps (append special-display-regexps '(".*")))
2523         (special-display-frame-alist gdb-frame-parameters)
2524         (same-window-regexps nil))
2525     (display-buffer gud-comint-buffer)))
2526
2527 (defun gdb-display-gdb-buffer ()
2528   "Display GUD buffer."
2529   (interactive)
2530   (let ((same-window-regexps nil))
2531     (pop-to-buffer gud-comint-buffer)))
2532
2533 (defun gdb-set-window-buffer (name)
2534   (set-window-buffer (selected-window) (get-buffer name))
2535   (set-window-dedicated-p (selected-window) t))
2536
2537 (defun gdb-setup-windows ()
2538   "Layout the window pattern for `gdb-many-windows'."
2539   (gdb-display-locals-buffer)
2540   (gdb-display-stack-buffer)
2541   (delete-other-windows)
2542   (gdb-display-breakpoints-buffer)
2543   (delete-other-windows)
2544   ; Don't dedicate.
2545   (pop-to-buffer gud-comint-buffer)
2546   (split-window nil ( / ( * (window-height) 3) 4))
2547   (split-window nil ( / (window-height) 3))
2548   (split-window-horizontally)
2549   (other-window 1)
2550   (gdb-set-window-buffer (gdb-locals-buffer-name))
2551   (other-window 1)
2552   (switch-to-buffer
2553        (if gud-last-last-frame
2554            (gud-find-file (car gud-last-last-frame))
2555          (gud-find-file gdb-main-file)))
2556   (when gdb-use-separate-io-buffer
2557     (split-window-horizontally)
2558     (other-window 1)
2559     (gdb-set-window-buffer
2560      (gdb-get-create-buffer 'gdb-inferior-io)))
2561   (other-window 1)
2562   (gdb-set-window-buffer (gdb-stack-buffer-name))
2563   (split-window-horizontally)
2564   (other-window 1)
2565   (gdb-set-window-buffer (gdb-breakpoints-buffer-name))
2566   (other-window 1))
2567
2568 (defcustom gdb-many-windows nil
2569   "Nil means just pop up the GUD buffer unless `gdb-show-main' is t.
2570 In this case it starts with two windows: one displaying the GUD
2571 buffer and the other with the source file with the main routine
2572 of the inferior.  Non-nil means display the layout shown for
2573 `gdba'."
2574   :type 'boolean
2575   :group 'gud
2576   :version "22.1")
2577
2578 (defun gdb-many-windows (arg)
2579   "Toggle the number of windows in the basic arrangement.
2580 With arg, display additional buffers iff arg is positive."
2581   (interactive "P")
2582   (setq gdb-many-windows
2583         (if (null arg)
2584             (not gdb-many-windows)
2585           (> (prefix-numeric-value arg) 0)))
2586   (message (format "Display of other windows %sabled"
2587                    (if gdb-many-windows "en" "dis")))
2588   (if (and gud-comint-buffer
2589            (buffer-name gud-comint-buffer))
2590       (condition-case nil
2591           (gdb-restore-windows)
2592         (error nil))))
2593
2594 (defun gdb-restore-windows ()
2595   "Restore the basic arrangement of windows used by gdba.
2596 This arrangement depends on the value of `gdb-many-windows'."
2597   (interactive)
2598   (pop-to-buffer gud-comint-buffer)     ;Select the right window and frame.
2599     (delete-other-windows)
2600   (if gdb-many-windows
2601       (gdb-setup-windows)
2602     (when (or gud-last-last-frame gdb-show-main)
2603       (split-window)
2604       (other-window 1)
2605       (switch-to-buffer
2606        (if gud-last-last-frame
2607            (gud-find-file (car gud-last-last-frame))
2608          (gud-find-file gdb-main-file)))
2609       (other-window 1))))
2610
2611 (defun gdb-reset ()
2612   "Exit a debugging session cleanly.
2613 Kills the gdb buffers and resets the source buffers."
2614   (dolist (buffer (buffer-list))
2615     (unless (eq buffer gud-comint-buffer)
2616       (with-current-buffer buffer
2617         (if (memq gud-minor-mode '(gdbmi gdba))
2618             (if (string-match "\\`\\*.+\\*\\'" (buffer-name))
2619                 (kill-buffer nil)
2620               (gdb-remove-breakpoint-icons (point-min) (point-max) t)
2621               (setq gud-minor-mode nil)
2622               (kill-local-variable 'tool-bar-map)
2623               (kill-local-variable 'gdb-define-alist))))))
2624   (when (markerp gdb-overlay-arrow-position)
2625     (move-marker gdb-overlay-arrow-position nil)
2626     (setq gdb-overlay-arrow-position nil))
2627   (setq overlay-arrow-variable-list
2628         (delq 'gdb-overlay-arrow-position overlay-arrow-variable-list))
2629   (if (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
2630       (speedbar-refresh))
2631   (setq gud-running nil)
2632   (setq gdb-active-process nil)
2633   (setq gdb-var-list nil)
2634   (remove-hook 'after-save-hook 'gdb-create-define-alist t))
2635
2636 (defun gdb-source-info ()
2637   "Find the source file where the program starts and displays it with related
2638 buffers."
2639   (goto-char (point-min))
2640   (if (and (search-forward "Located in " nil t)
2641            (looking-at "\\S-+"))
2642       (setq gdb-main-file (match-string 0)))
2643   (goto-char (point-min))
2644   (if (search-forward "Includes preprocessor macro info." nil t)
2645       (setq gdb-macro-info t))
2646  (if gdb-many-windows
2647       (gdb-setup-windows)
2648    (gdb-get-create-buffer 'gdb-breakpoints-buffer)
2649    (if gdb-show-main
2650        (let ((pop-up-windows t))
2651          (display-buffer (gud-find-file gdb-main-file))))))
2652
2653 (defun gdb-get-location (bptno line flag)
2654   "Find the directory containing the relevant source file.
2655 Put in buffer and place breakpoint icon."
2656   (goto-char (point-min))
2657   (catch 'file-not-found
2658     (if (search-forward "Located in " nil t)
2659         (when (looking-at "\\S-+")
2660           (delete (cons bptno "File not found") gdb-location-alist)
2661           (push (cons bptno (match-string 0)) gdb-location-alist))
2662       (gdb-resync)
2663       (unless (assoc bptno gdb-location-alist)
2664         (push (cons bptno "File not found") gdb-location-alist)
2665         (message-box "Cannot find source file for breakpoint location.\n\
2666 Add directory to search path for source files using the GDB command, dir."))
2667       (throw 'file-not-found nil))
2668     (with-current-buffer
2669         (find-file-noselect (match-string 0))
2670       (save-current-buffer
2671         (set (make-local-variable 'gud-minor-mode) 'gdba)
2672         (set (make-local-variable 'tool-bar-map) gud-tool-bar-map))
2673       ;; only want one breakpoint icon at each location
2674       (save-excursion
2675         (goto-line (string-to-number line))
2676         (gdb-put-breakpoint-icon (eq flag ?y) bptno)))))
2677
2678 (add-hook 'find-file-hook 'gdb-find-file-hook)
2679
2680 (defun gdb-find-file-hook ()
2681   "Set up buffer for debugging if file is part of the source code
2682 of the current session."
2683   (if (and (buffer-name gud-comint-buffer)
2684            ;; in case gud or gdb-ui is just loaded
2685            gud-comint-buffer
2686            (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
2687                '(gdba gdbmi)))
2688       (if (member buffer-file-name gdb-source-file-list)
2689           (with-current-buffer (find-buffer-visiting buffer-file-name)
2690             (set (make-local-variable 'gud-minor-mode)
2691                  (buffer-local-value 'gud-minor-mode gud-comint-buffer))
2692             (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)))))
2693
2694 ;;from put-image
2695 (defun gdb-put-string (putstring pos &optional dprop &rest sprops)
2696   "Put string PUTSTRING in front of POS in the current buffer.
2697 PUTSTRING is displayed by putting an overlay into the current buffer with a
2698 `before-string' string that has a `display' property whose value is
2699 PUTSTRING."
2700   (let ((string (make-string 1 ?x))
2701         (buffer (current-buffer)))
2702     (setq putstring (copy-sequence putstring))
2703     (let ((overlay (make-overlay pos pos buffer))
2704           (prop (or dprop
2705                     (list (list 'margin 'left-margin) putstring))))
2706       (put-text-property 0 1 'display prop string)
2707       (if sprops
2708           (add-text-properties 0 1 sprops string))
2709       (overlay-put overlay 'put-break t)
2710       (overlay-put overlay 'before-string string))))
2711
2712 ;;from remove-images
2713 (defun gdb-remove-strings (start end &optional buffer)
2714   "Remove strings between START and END in BUFFER.
2715 Remove only strings that were put in BUFFER with calls to `gdb-put-string'.
2716 BUFFER nil or omitted means use the current buffer."
2717   (unless buffer
2718     (setq buffer (current-buffer)))
2719   (dolist (overlay (overlays-in start end))
2720     (when (overlay-get overlay 'put-break)
2721           (delete-overlay overlay))))
2722
2723 (defun gdb-put-breakpoint-icon (enabled bptno)
2724   (let ((start (- (line-beginning-position) 1))
2725         (end (+ (line-end-position) 1))
2726         (putstring (if enabled "B" "b"))
2727         (source-window (get-buffer-window (current-buffer) 0)))
2728     (add-text-properties
2729      0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt")
2730      putstring)
2731     (if enabled
2732         (add-text-properties
2733          0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring)
2734       (add-text-properties
2735        0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring))
2736     (gdb-remove-breakpoint-icons start end)
2737     (if (display-images-p)
2738         (if (>= (or left-fringe-width
2739                     (if source-window (car (window-fringes source-window)))
2740                     gdb-buffer-fringe-width) 8)
2741             (gdb-put-string
2742              nil (1+ start)
2743              `(left-fringe breakpoint
2744                            ,(if enabled
2745                                 'breakpoint-enabled
2746                               'breakpoint-disabled))
2747              'gdb-bptno bptno
2748              'gdb-enabled enabled)
2749           (when (< left-margin-width 2)
2750             (save-current-buffer
2751               (setq left-margin-width 2)
2752               (if source-window
2753                   (set-window-margins
2754                    source-window
2755                    left-margin-width right-margin-width))))
2756           (put-image
2757            (if enabled
2758                (or breakpoint-enabled-icon
2759                    (setq breakpoint-enabled-icon
2760                          (find-image `((:type xpm :data
2761                                               ,breakpoint-xpm-data
2762                                               :ascent 100 :pointer hand)
2763                                        (:type pbm :data
2764                                               ,breakpoint-enabled-pbm-data
2765                                               :ascent 100 :pointer hand)))))
2766              (or breakpoint-disabled-icon
2767                  (setq breakpoint-disabled-icon
2768                        (find-image `((:type xpm :data
2769                                             ,breakpoint-xpm-data
2770                                             :conversion disabled
2771                                             :ascent 100 :pointer hand)
2772                                      (:type pbm :data
2773                                             ,breakpoint-disabled-pbm-data
2774                                             :ascent 100 :pointer hand))))))
2775            (+ start 1)
2776            putstring
2777            'left-margin))
2778       (when (< left-margin-width 2)
2779         (save-current-buffer
2780           (setq left-margin-width 2)
2781           (let ((window (get-buffer-window (current-buffer) 0)))
2782             (if window
2783               (set-window-margins
2784                window left-margin-width right-margin-width)))))
2785       (gdb-put-string
2786        (propertize putstring
2787                    'face (if enabled 'breakpoint-enabled 'breakpoint-disabled))
2788        (1+ start)))))
2789
2790 (defun gdb-remove-breakpoint-icons (start end &optional remove-margin)
2791   (gdb-remove-strings start end)
2792   (if (display-images-p)
2793       (remove-images start end))
2794   (when remove-margin
2795     (setq left-margin-width 0)
2796     (let ((window (get-buffer-window (current-buffer) 0)))
2797       (if window
2798           (set-window-margins
2799            window left-margin-width right-margin-width)))))
2800
2801 \f
2802 ;;
2803 ;; Assembler buffer.
2804 ;;
2805 (gdb-set-buffer-rules 'gdb-assembler-buffer
2806                       'gdb-assembler-buffer-name
2807                       'gdb-assembler-mode)
2808
2809 (def-gdb-auto-update-handler gdb-assembler-handler
2810   gdb-invalidate-assembler
2811   gdb-assembler-buffer
2812   gdb-assembler-custom)
2813
2814 (defun gdb-assembler-custom ()
2815   (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer))
2816         (pos 1) (address) (flag) (bptno))
2817     (with-current-buffer buffer
2818       (save-excursion
2819         (if (not (equal gdb-frame-address "main"))
2820             (progn
2821               (goto-char (point-min))
2822               (if (and gdb-frame-address
2823                        (search-forward gdb-frame-address nil t))
2824                   (progn
2825                     (setq pos (point))
2826                     (beginning-of-line)
2827                     (or gdb-overlay-arrow-position
2828                         (setq gdb-overlay-arrow-position (make-marker)))
2829                     (set-marker gdb-overlay-arrow-position
2830                                 (point) (current-buffer))))))
2831         ;; remove all breakpoint-icons in assembler buffer before updating.
2832         (gdb-remove-breakpoint-icons (point-min) (point-max))))
2833     (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
2834       (goto-char (point-min))
2835       (while (< (point) (- (point-max) 1))
2836         (forward-line 1)
2837         (if (looking-at "[^\t].*?breakpoint")
2838             (progn
2839               (looking-at
2840             "\\([0-9]+\\)\\s-+\\S-+\\s-+\\S-+\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)")
2841               (setq bptno (match-string 1))
2842               (setq flag (char-after (match-beginning 2)))
2843               (setq address (match-string 3))
2844               (with-current-buffer buffer
2845                 (save-excursion
2846                   (goto-char (point-min))
2847                   (if (search-forward address nil t)
2848                       (gdb-put-breakpoint-icon (eq flag ?y) bptno))))))))
2849     (if (not (equal gdb-frame-address "main"))
2850         (with-current-buffer buffer
2851           (set-window-point (get-buffer-window buffer 0) pos)))))
2852
2853 (defvar gdb-assembler-mode-map
2854   (let ((map (make-sparse-keymap)))
2855     (suppress-keymap map)
2856     (define-key map "q" 'kill-this-buffer)
2857      map))
2858
2859 (defvar gdb-assembler-font-lock-keywords
2860   '(;; <__function.name+n>
2861     ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>"
2862      (1 font-lock-function-name-face))
2863     ;; 0xNNNNNNNN <__function.name+n>: opcode
2864     ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)"
2865      (4 font-lock-keyword-face))
2866     ;; %register(at least i386)
2867     ("%\\sw+" . font-lock-variable-name-face)
2868     ("^\\(Dump of assembler code for function\\) \\(.+\\):"
2869      (1 font-lock-comment-face)
2870      (2 font-lock-function-name-face))
2871     ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face))
2872   "Font lock keywords used in `gdb-assembler-mode'.")
2873
2874 (defun gdb-assembler-mode ()
2875   "Major mode for viewing code assembler.
2876
2877 \\{gdb-assembler-mode-map}"
2878   (kill-all-local-variables)
2879   (setq major-mode 'gdb-assembler-mode)
2880   (setq mode-name (concat "Machine:" gdb-selected-frame))
2881   (setq gdb-overlay-arrow-position nil)
2882   (add-to-list 'overlay-arrow-variable-list 'gdb-overlay-arrow-position)
2883   (setq fringes-outside-margins t)
2884   (setq buffer-read-only t)
2885   (use-local-map gdb-assembler-mode-map)
2886   (gdb-invalidate-assembler)
2887   (set (make-local-variable 'font-lock-defaults)
2888        '(gdb-assembler-font-lock-keywords))
2889   (run-mode-hooks 'gdb-assembler-mode-hook)
2890   'gdb-invalidate-assembler)
2891
2892 (defun gdb-assembler-buffer-name ()
2893   (with-current-buffer gud-comint-buffer
2894     (concat "*disassembly of " (gdb-get-target-string) "*")))
2895
2896 (defun gdb-display-assembler-buffer ()
2897   "Display disassembly view."
2898   (interactive)
2899   (setq gdb-previous-frame nil)
2900   (gdb-display-buffer
2901    (gdb-get-create-buffer 'gdb-assembler-buffer)))
2902
2903 (defun gdb-frame-assembler-buffer ()
2904   "Display disassembly view in a new frame."
2905   (interactive)
2906   (setq gdb-previous-frame nil)
2907   (let ((special-display-regexps (append special-display-regexps '(".*")))
2908         (special-display-frame-alist gdb-frame-parameters))
2909     (display-buffer (gdb-get-create-buffer 'gdb-assembler-buffer))))
2910
2911 ;; modified because if gdb-frame-address has changed value a new command
2912 ;; must be enqueued to update the buffer with the new output
2913 (defun gdb-invalidate-assembler (&optional ignored)
2914   (if (gdb-get-buffer 'gdb-assembler-buffer)
2915       (progn
2916         (unless (and gdb-selected-frame
2917                      (string-equal gdb-selected-frame gdb-previous-frame))
2918           (if (or (not (member 'gdb-invalidate-assembler
2919                                gdb-pending-triggers))
2920                   (not (string-equal gdb-frame-address
2921                                      gdb-previous-frame-address)))
2922           (progn
2923             ;; take previous disassemble command, if any, off the queue
2924             (with-current-buffer gud-comint-buffer
2925               (let ((queue gdb-input-queue))
2926                 (dolist (item queue)
2927                   (if (equal (cdr item) '(gdb-assembler-handler))
2928                       (setq gdb-input-queue
2929                             (delete item gdb-input-queue))))))
2930             (gdb-enqueue-input
2931              (list
2932               (concat gdb-server-prefix "disassemble "
2933                       (if (member gdb-frame-address '(nil "main")) nil "0x")
2934                            gdb-frame-address "\n")
2935                    'gdb-assembler-handler))
2936             (push 'gdb-invalidate-assembler gdb-pending-triggers)
2937             (setq gdb-previous-frame-address gdb-frame-address)
2938             (setq gdb-previous-frame gdb-selected-frame)))))))
2939
2940 (defun gdb-get-selected-frame ()
2941   (if (not (member 'gdb-get-selected-frame gdb-pending-triggers))
2942       (progn
2943         (gdb-enqueue-input
2944          (list (concat gdb-server-prefix "info frame\n") 'gdb-frame-handler))
2945         (push 'gdb-get-selected-frame
2946                gdb-pending-triggers))))
2947
2948 (defun gdb-frame-handler ()
2949   (setq gdb-pending-triggers
2950         (delq 'gdb-get-selected-frame gdb-pending-triggers))
2951   (goto-char (point-min))
2952   (if (re-search-forward  "Stack level \\([0-9]+\\)" nil t)
2953       (setq gdb-frame-number (match-string 1)))
2954   (goto-char (point-min))
2955   (if (re-search-forward
2956        ".*=\\s-+0x0*\\(\\S-*\\)\\s-+in\\s-+\\(\\S-*?\\);? " nil t)
2957       (progn
2958         (setq gdb-selected-frame (match-string 2))
2959         (if (gdb-get-buffer 'gdb-locals-buffer)
2960             (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer)
2961               (setq mode-name (concat "Locals:" gdb-selected-frame))))
2962         (if (gdb-get-buffer 'gdb-assembler-buffer)
2963             (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer)
2964               (setq mode-name (concat "Machine:" gdb-selected-frame))))
2965         (setq gdb-frame-address (match-string 1))))
2966   (goto-char (point-min))
2967   (if (re-search-forward " source language \\(\\S-*\\)\." nil t)
2968       (setq gdb-current-language (match-string 1)))
2969   (gdb-invalidate-assembler))
2970
2971 \f
2972 ;; Code specific to GDB 6.4
2973 (defconst gdb-source-file-regexp-1 "fullname=\"\\(.*?\\)\"")
2974
2975 (defun gdb-set-gud-minor-mode-existing-buffers-1 ()
2976   "Create list of source files for current GDB session.
2977 If buffers already exist for any of these files, gud-minor-mode
2978 is set in them."
2979   (goto-char (point-min))
2980   (while (re-search-forward gdb-source-file-regexp-1 nil t)
2981     (push (match-string 1) gdb-source-file-list))
2982   (dolist (buffer (buffer-list))
2983     (with-current-buffer buffer
2984       (when (member buffer-file-name gdb-source-file-list)
2985         (set (make-local-variable 'gud-minor-mode)
2986              (buffer-local-value 'gud-minor-mode gud-comint-buffer))
2987         (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
2988         (when gud-tooltip-mode
2989           (make-local-variable 'gdb-define-alist)
2990           (gdb-create-define-alist)
2991           (add-hook 'after-save-hook 'gdb-create-define-alist nil t))))))
2992
2993 ; Uses "-var-list-children --all-values".  Needs GDB 6.1 onwards.
2994 (defun gdb-var-list-children-1 (varnum)
2995   (gdb-enqueue-input
2996    (list
2997     (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
2998         (concat "server interpreter mi \"-var-list-children --all-values "
2999                 varnum "\"\n")
3000       (concat "-var-list-children --all-values " varnum "\n"))
3001     `(lambda () (gdb-var-list-children-handler-1 ,varnum)))))
3002
3003 (defconst gdb-var-list-children-regexp-1
3004   "name=\"\\(.+?\\)\",exp=\"\\(.+?\\)\",numchild=\"\\(.+?\\)\",\
3005 value=\\(\".*?\"\\),type=\"\\(.+?\\)\"}")
3006
3007 (defun gdb-var-list-children-handler-1 (varnum)
3008   (goto-char (point-min))
3009   (let ((var-list nil))
3010     (catch 'child-already-watched
3011       (dolist (var gdb-var-list)
3012         (if (string-equal varnum (cadr var))
3013             (progn
3014               (push var var-list)
3015               (while (re-search-forward gdb-var-list-children-regexp-1 nil t)
3016                 (let ((varchild (list (match-string 2)
3017                                       (match-string 1)
3018                                       (match-string 3)
3019                                       (match-string 5)
3020                                       (read (match-string 4))
3021                                       nil)))
3022                   (dolist (var1 gdb-var-list)
3023                     (if (string-equal (cadr var1) (cadr varchild))
3024                         (throw 'child-already-watched nil)))
3025                   (push varchild var-list))))
3026           (push var var-list)))
3027       (setq gdb-var-list (nreverse var-list)))))
3028
3029 ; Uses "-var-update --all-values".  Needs GDB 6.4 onwards.
3030 (defun gdb-var-update-1 ()
3031   (if (not (member 'gdb-var-update gdb-pending-triggers))
3032       (progn
3033         (gdb-enqueue-input
3034          (list
3035           (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
3036               "server interpreter mi \"-var-update --all-values *\"\n"
3037             "-var-update --all-values *\n")
3038           'gdb-var-update-handler-1))
3039         (push 'gdb-var-update gdb-pending-triggers))))
3040
3041 (defconst gdb-var-update-regexp-1
3042   "name=\"\\(.*?\\)\",\\(?:value=\\(\".*?\"\\),\\)?in_scope=\"\\(.*?\\)\"")
3043
3044 (defun gdb-var-update-handler-1 ()
3045   (dolist (var gdb-var-list)
3046     (setcar (nthcdr 5 var) nil))
3047   (goto-char (point-min))
3048   (while (re-search-forward gdb-var-update-regexp-1 nil t)
3049     (let ((varnum (match-string 1)))
3050       (catch 'var-found
3051         (dolist (var gdb-var-list)
3052           (when (string-equal varnum (cadr var))
3053             (if (string-equal (match-string 3) "false")
3054                 (setcar (nthcdr 5 var) 'out-of-scope)
3055               (setcar (nthcdr 5 var) 'changed)
3056               (setcar (nthcdr 4 var)
3057                       (read (match-string 2))))
3058             (throw 'var-found nil))))))
3059   (setq gdb-pending-triggers
3060    (delq 'gdb-var-update gdb-pending-triggers))
3061   (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
3062     ;; dummy command to update speedbar at right time
3063     (gdb-enqueue-input (list "server pwd\n" 'gdb-speedbar-timer-fn))
3064     ;; keep gdb-pending-triggers non-nil till end
3065     (push 'gdb-speedbar-timer gdb-pending-triggers)))
3066
3067 ;; Registers buffer.
3068 ;;
3069 (gdb-set-buffer-rules 'gdb-registers-buffer
3070                       'gdb-registers-buffer-name
3071                       'gdb-registers-mode)
3072
3073 (def-gdb-auto-update-trigger gdb-invalidate-registers-1
3074   (gdb-get-buffer 'gdb-registers-buffer)
3075   (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
3076       "server interpreter mi \"-data-list-register-values x\"\n"
3077     "-data-list-register-values x\n")
3078     gdb-data-list-register-values-handler)
3079
3080 (defconst gdb-data-list-register-values-regexp
3081   "number=\"\\(.*?\\)\",value=\"\\(.*?\\)\"")
3082
3083 (defun gdb-data-list-register-values-handler ()
3084   (setq gdb-pending-triggers (delq 'gdb-invalidate-registers-1
3085                                    gdb-pending-triggers))
3086   (goto-char (point-min))
3087   (if (re-search-forward gdb-error-regexp nil t)
3088       (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
3089         (let ((buffer-read-only nil))
3090           (erase-buffer)
3091           (insert (match-string 1))
3092           (goto-char (point-min))))
3093     (let ((register-list (reverse gdb-register-names))
3094           (register nil) (register-string nil) (register-values nil))
3095       (goto-char (point-min))
3096       (while (re-search-forward gdb-data-list-register-values-regexp nil t)
3097         (setq register (pop register-list))
3098         (setq register-string (concat register "\t" (match-string 2) "\n"))
3099         (if (member (match-string 1) gdb-changed-registers)
3100             (put-text-property 0 (length register-string)
3101                                'face 'font-lock-warning-face
3102                                register-string))
3103         (setq register-values
3104               (concat register-values register-string)))
3105       (let ((buf (gdb-get-buffer 'gdb-registers-buffer)))
3106         (with-current-buffer buf
3107           (let ((p (window-point (get-buffer-window buf 0)))
3108                 (buffer-read-only nil))
3109             (erase-buffer)
3110             (insert register-values)
3111             (set-window-point (get-buffer-window buf 0) p))))))
3112   (gdb-data-list-register-values-custom))
3113
3114 (defun gdb-data-list-register-values-custom ()
3115   (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
3116     (save-excursion
3117       (let ((buffer-read-only nil)
3118             start end)
3119         (goto-char (point-min))
3120         (while (< (point) (point-max))
3121           (setq start (line-beginning-position))
3122           (setq end (line-end-position))
3123           (when (looking-at "^[^\t]+")
3124             (unless (string-equal (match-string 0) "No registers.")
3125               (put-text-property start (match-end 0)
3126                                  'face font-lock-variable-name-face)
3127               (add-text-properties start end
3128                                    '(help-echo "mouse-2: edit value"
3129                                      mouse-face highlight))))
3130           (forward-line 1))))))
3131
3132 ;; Needs GDB 6.4 onwards (used to fail with no stack).
3133 (defun gdb-get-changed-registers ()
3134   (if (and (gdb-get-buffer 'gdb-registers-buffer)
3135            (not (member 'gdb-get-changed-registers gdb-pending-triggers)))
3136       (progn
3137         (gdb-enqueue-input
3138          (list
3139           (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
3140               "server interpreter mi -data-list-changed-registers\n"
3141             "-data-list-changed-registers\n")
3142           'gdb-get-changed-registers-handler))
3143         (push 'gdb-get-changed-registers gdb-pending-triggers))))
3144
3145 (defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"")
3146
3147 (defun gdb-get-changed-registers-handler ()
3148   (setq gdb-pending-triggers
3149         (delq 'gdb-get-changed-registers gdb-pending-triggers))
3150   (setq gdb-changed-registers nil)
3151   (goto-char (point-min))
3152   (while (re-search-forward gdb-data-list-register-names-regexp nil t)
3153     (push (match-string 1) gdb-changed-registers)))
3154 \f
3155
3156 ;; Locals buffer.
3157 ;;
3158 ;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards.
3159 (gdb-set-buffer-rules 'gdb-locals-buffer
3160                       'gdb-locals-buffer-name
3161                       'gdb-locals-mode)
3162
3163 (def-gdb-auto-update-trigger gdb-invalidate-locals-1
3164   (gdb-get-buffer 'gdb-locals-buffer)
3165   (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
3166       "server interpreter mi -\"stack-list-locals --simple-values\"\n"
3167     "-stack-list-locals --simple-values\n")
3168   gdb-stack-list-locals-handler)
3169
3170 (defconst gdb-stack-list-locals-regexp
3171   "name=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
3172
3173 (defvar gdb-locals-watch-map-1
3174   (let ((map (make-sparse-keymap)))
3175     (define-key map [mouse-2] 'gud-watch)
3176     map)
3177  "Keymap to create watch expression of a complex data type local variable.")
3178
3179 ;; Dont display values of arrays or structures.
3180 ;; These can be expanded using gud-watch.
3181 (defun gdb-stack-list-locals-handler ()
3182   (setq gdb-pending-triggers (delq 'gdb-invalidate-locals-1
3183                                   gdb-pending-triggers))
3184   (let (local locals-list)
3185     (goto-char (point-min))
3186     (while (re-search-forward gdb-stack-list-locals-regexp nil t)
3187       (let ((local (list (match-string 1)
3188                          (match-string 2)
3189                          nil)))
3190         (if (looking-at ",value=\\(\".*\"\\)}")
3191             (setcar (nthcdr 2 local) (read (match-string 1))))
3192         (push local locals-list)))
3193     (let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
3194       (and buf (with-current-buffer buf
3195                  (let* ((window (get-buffer-window buf 0))
3196                         (p (window-point window))
3197                         (buffer-read-only nil))
3198                    (erase-buffer)
3199                    (dolist (local locals-list)
3200                      (setq name (car local))
3201                      (if (or (not (nth 2 local))
3202                              (string-match "\\*$" (nth 1 local)))
3203                        (add-text-properties 0 (length name)
3204                             `(mouse-face highlight
3205                               help-echo "mouse-2: create watch expression"
3206                               local-map ,gdb-locals-watch-map-1)
3207                             name))
3208                        (insert
3209                         (concat name "\t" (nth 1 local)
3210                                 "\t" (nth 2 local) "\n")))
3211                    (set-window-point window p)))))))
3212
3213 (defun gdb-get-register-names ()
3214   "Create a list of register names."
3215   (goto-char (point-min))
3216   (setq gdb-register-names nil)
3217   (while (re-search-forward gdb-data-list-register-names-regexp nil t)
3218     (push (match-string 1) gdb-register-names)))
3219
3220 (provide 'gdb-ui)
3221
3222 ;; arch-tag: e9fb00c5-74ef-469f-a088-37384caae352
3223 ;;; gdb-ui.el ends here