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