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

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