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