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