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

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