lisp/gdb-ui.el

   1 ;;; gdb-ui.el --- User Interface for running GDB
   2
   3 ;; Author: Nick Roberts <nick@nick.uklinux.net>
   4 ;; Maintainer: FSF
   5 ;; Keywords: unix, tools
   6
   7 ;; Copyright (C) 2002, 2003, 2004  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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, 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 and displays
  32 ;; expressions and their current values in their own buffers. It also uses
  33 ;; features of Emacs 21 such as the display margin for breakpoints, and the
  34 ;; toolbar (see the GDB Graphical Interface section in the Emacs info manual).
  35
  36 ;; Start the debugger with M-x gdba.
  37
  38 ;; This file has evolved from gdba.el from GDB 5.0 written by Tom Lord and Jim
  39 ;; Kingdon and uses GDB's annotation interface. You don't need to know about
  40 ;; annotations to use this mode as a debugger, but if you are interested
  41 ;; developing the mode itself, then see the Annotations section in the GDB
  42 ;; info manual. Some GDB/MI commands are also used through th CLI command
  43 ;; 'interpreter mi <mi-command>'.
  44 ;;
  45 ;; Known Bugs:
  46 ;;
  47
  48 ;;; Code:
  49
  50 (require 'gud)
  51
  52 (defvar gdb-current-address "main" "Initialisation for Assembler buffer.")
  53 (defvar gdb-previous-address nil)
  54 (defvar gdb-previous-frame nil)
  55 (defvar gdb-current-frame "main")
  56 (defvar gdb-current-language nil)
  57 (defvar gdb-view-source t "Non-nil means that source code can be viewed.")
  58 (defvar gdb-selected-view 'source "Code type that user wishes to view.")
  59 (defvar gdb-var-list nil "List of variables in watch window")
  60 (defvar gdb-var-changed nil "Non-nil means that gdb-var-list has changed.")
  61 (defvar gdb-buffer-type nil)
  62 (defvar gdb-variables '()
  63   "A list of variables that are local to the GUD buffer.")
  64
  65 ;;;###autoload
  66 (defun gdba (command-line)
  67   "Run gdb on program FILE in buffer *gud-FILE*.
  68 The directory containing FILE becomes the initial working directory
  69 and source-file directory for your debugger.
  70
  71 If `gdb-many-windows' is nil (the default value) then gdb starts with
  72 just two windows : the GUD and the source buffer. If it is t the
  73 following layout will appear (keybindings given in relevant buffer) :
  74
  75 ---------------------------------------------------------------------
  76                                GDB Toolbar
  77 ---------------------------------------------------------------------
  78 GUD buffer (I/O of GDB)           | Locals buffer
  79                                   |
  80                                   |
  81                                   |
  82 ---------------------------------------------------------------------
  83 Source buffer                     | Input/Output (of debuggee) buffer
  84                                   | (comint-mode)
  85                                   |
  86                                   |
  87                                   |
  88                                   |
  89                                   |
  90                                   |
  91 ---------------------------------------------------------------------
  92 Stack buffer                      | Breakpoints buffer
  93  RET      gdb-frames-select       | SPC    gdb-toggle-breakpoint
  94                                   | RET    gdb-goto-breakpoint
  95                                   |   d    gdb-delete-breakpoint
  96 ---------------------------------------------------------------------
  97
  98 All the buffers share the toolbar and source should always display in the same
  99 window e.g after typing g on a breakpoint in the breakpoints buffer. Breakpoint
 100 icons are displayed both by setting a break with gud-break and by typing break
 101 in the GUD buffer.
 102
 103 This works best (depending on the size of your monitor) using most of the
 104 screen.
 105
 106 Displayed expressions appear in separate frames. Arrays may be displayed
 107 as slices and visualised using the graph program from plotutils if installed.
 108 Pointers in structures may be followed in a tree-like fashion.
 109
 110 The following interactive lisp functions help control operation :
 111
 112 `gdb-many-windows'    - Toggle the number of windows gdb uses.
 113 `gdb-restore-windows' - To restore the window layout."
 114   ;;
 115   (interactive (list (gud-query-cmdline 'gdba)))
 116   ;;
 117   ;; Let's start with a basic gud-gdb buffer and then modify it a bit.
 118   (gdb command-line)
 119   (gdb-ann3))
 120
 121 (defun gdb-ann3 ()
 122   (set (make-local-variable 'gud-minor-mode) 'gdba)
 123   (set (make-local-variable 'gud-marker-filter) 'gud-gdba-marker-filter)
 124   ;;
 125   (gud-def gud-break (if (not (string-equal mode-name "Machine"))
 126                          (gud-call "break %f:%l" arg)
 127                        (save-excursion
 128                          (beginning-of-line)
 129                          (forward-char 2)
 130                          (gud-call "break *%a" arg)))
 131            "\C-b" "Set breakpoint at current line or address.")
 132   ;;
 133   (gud-def gud-remove (if (not (string-equal mode-name "Machine"))
 134                           (gud-call "clear %f:%l" arg)
 135                         (save-excursion
 136                           (beginning-of-line)
 137                           (forward-char 2)
 138                           (gud-call "clear *%a" arg)))
 139            "\C-d" "Remove breakpoint at current line or address.")
 140   ;;
 141   (gud-def gud-until  (if (not (string-equal mode-name "Machine"))
 142                           (gud-call "until %f:%l" arg)
 143                         (save-excursion
 144                           (beginning-of-line)
 145                           (forward-char 2)
 146                           (gud-call "until *%a" arg)))
 147            "\C-u" "Continue to current line or address.")
 148
 149   (define-key gud-minor-mode-map [left-margin mouse-1]
 150     'gdb-mouse-toggle-breakpoint)
 151   (define-key gud-minor-mode-map [left-fringe mouse-1]
 152     'gdb-mouse-toggle-breakpoint)
 153
 154   (setq comint-input-sender 'gdb-send)
 155   ;;
 156   ;; (re-)initialise
 157   (setq gdb-current-address "main")
 158   (setq gdb-previous-address nil)
 159   (setq gdb-previous-frame nil)
 160   (setq gdb-current-frame "main")
 161   (setq gdb-view-source t)
 162   (setq gdb-selected-view 'source)
 163   (setq gdb-var-list nil)
 164   (setq gdb-var-changed nil)
 165   (setq gdb-first-prompt nil)
 166   ;;
 167   (mapc 'make-local-variable gdb-variables)
 168   (setq gdb-buffer-type 'gdba)
 169   ;;
 170   (gdb-clear-inferior-io)
 171   ;;
 172   (if (eq window-system 'w32)
 173       (gdb-enqueue-input (list "set new-console off\n" 'ignore)))
 174   (gdb-enqueue-input (list "set height 0\n" 'ignore))
 175   ;; find source file and compilation directory here
 176   (gdb-enqueue-input (list "server list main\n"   'ignore))   ; C program
 177   (gdb-enqueue-input (list "server list MAIN__\n" 'ignore))   ; Fortran program
 178   (gdb-enqueue-input (list "server info source\n" 'gdb-source-info))
 179   ;;
 180   (run-hooks 'gdba-mode-hook))
 181
 182 (defcustom gdb-use-colon-colon-notation t
 183   "Non-nil means use FUNCTION::VARIABLE format to display variables in the
 184 speedbar."
 185   :type 'boolean
 186   :group 'gud)
 187
 188 (defun gud-watch ()
 189   "Watch expression at point."
 190   (interactive)
 191   (let ((expr (tooltip-identifier-from-point (point))))
 192     (if (and (string-equal gdb-current-language "c")
 193              gdb-use-colon-colon-notation)
 194         (setq expr (concat gdb-current-frame "::" expr)))
 195     (catch 'already-watched
 196       (dolist (var gdb-var-list)
 197         (if (string-equal expr (car var)) (throw 'already-watched nil)))
 198       (set-text-properties 0 (length expr) nil expr)
 199       (gdb-enqueue-input
 200        (list (concat "server interpreter mi \"-var-create - * "  expr "\"\n")
 201              `(lambda () (gdb-var-create-handler ,expr))))))
 202   (select-window (get-buffer-window gud-comint-buffer)))
 203
 204 (defconst gdb-var-create-regexp
 205 "name=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
 206
 207 (defun gdb-var-create-handler (expr)
 208   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 209     (goto-char (point-min))
 210     (if (re-search-forward gdb-var-create-regexp nil t)
 211         (let ((var (list expr
 212                          (match-string 1)
 213                          (match-string 2)
 214                          (match-string 3)
 215                          nil nil)))
 216           (push var gdb-var-list)
 217           (speedbar 1)
 218           (if (equal (nth 2 var) "0")
 219               (gdb-enqueue-input
 220                (list (concat "server interpreter mi \"-var-evaluate-expression "
 221                              (nth 1 var) "\"\n")
 222                      `(lambda () (gdb-var-evaluate-expression-handler
 223                                   ,(nth 1 var) nil))))
 224             (setq gdb-var-changed t)))
 225       (if (re-search-forward "Undefined command" nil t)
 226           (message "Watching expressions requires gdb 6.0 onwards")
 227         (message "No symbol %s in current context." expr)))))
 228
 229 (defun gdb-var-evaluate-expression-handler (varnum changed)
 230   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 231     (goto-char (point-min))
 232     (re-search-forward ".*value=\"\\(.*?\\)\"" nil t)
 233     (catch 'var-found
 234       (let ((var-list nil) (num 0))
 235         (dolist (var gdb-var-list)
 236           (if (string-equal varnum (cadr var))
 237               (progn
 238                 (if changed (setcar (nthcdr 5 var) t))
 239                 (setcar (nthcdr 4 var) (match-string 1))
 240                 (setcar (nthcdr num gdb-var-list) var)
 241                 (throw 'var-found nil)))
 242           (setq num (+ num 1))))))
 243   (setq gdb-var-changed t))
 244
 245 (defun gdb-var-list-children (varnum)
 246   (gdb-enqueue-input
 247    (list (concat "server interpreter mi \"-var-list-children "  varnum "\"\n")
 248              `(lambda () (gdb-var-list-children-handler ,varnum)))))
 249
 250 (defconst gdb-var-list-children-regexp
 251 "name=\"\\(.*?\\)\",exp=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
 252
 253 (defun gdb-var-list-children-handler (varnum)
 254   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 255     (goto-char (point-min))
 256     (let ((var-list nil))
 257      (catch 'child-already-watched
 258        (dolist (var gdb-var-list)
 259          (if (string-equal varnum (cadr var))
 260              (progn
 261                (push var var-list)
 262                (while (re-search-forward gdb-var-list-children-regexp nil t)
 263                  (let ((varchild (list (match-string 2)
 264                                        (match-string 1)
 265                                        (match-string 3)
 266                                        (match-string 5)
 267                                        (match-string 4)
 268                                        nil)))
 269                    (dolist (var1 gdb-var-list)
 270                      (if (string-equal (cadr var1) (cadr varchild))
 271                          (throw 'child-already-watched nil)))
 272                    (push varchild var-list)
 273                    (if (equal (nth 2 varchild) "0")
 274                        (gdb-enqueue-input
 275                         (list
 276                          (concat
 277                           "server interpreter mi \"-var-evaluate-expression "
 278                                  (nth 1 varchild) "\"\n")
 279                          `(lambda () (gdb-var-evaluate-expression-handler
 280                                       ,(nth 1 varchild) nil))))))))
 281            (push var var-list)))
 282        (setq gdb-var-list (nreverse var-list))))))
 283
 284 (defun gdb-var-update ()
 285   (if (not (member 'gdb-var-update (gdb-get-pending-triggers)))
 286       (progn
 287         (gdb-enqueue-input (list "server interpreter mi \"-var-update *\"\n"
 288                                  'gdb-var-update-handler))
 289         (gdb-set-pending-triggers (cons 'gdb-var-update
 290                                         (gdb-get-pending-triggers))))))
 291
 292 (defconst gdb-var-update-regexp "name=\"\\(.*?\\)\"")
 293
 294 (defun gdb-var-update-handler ()
 295   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 296     (goto-char (point-min))
 297     (while (re-search-forward gdb-var-update-regexp nil t)
 298         (let ((varnum (match-string 1)))
 299           (gdb-enqueue-input
 300            (list (concat "server interpreter mi \"-var-evaluate-expression "
 301                          varnum "\"\n")
 302                      `(lambda () (gdb-var-evaluate-expression-handler
 303                                   ,varnum t)))))))
 304   (gdb-set-pending-triggers
 305    (delq 'gdb-var-update (gdb-get-pending-triggers))))
 306
 307 (defun gdb-var-delete (text token indent)
 308   "Delete watched expression."
 309   (interactive)
 310   (when (eq indent 0)
 311     (string-match "\\(\\S-+\\)" text)
 312     (let* ((expr (match-string 1 text))
 313            (var (assoc expr gdb-var-list))
 314            (varnum (cadr var)))
 315       (gdb-enqueue-input
 316        (list (concat "server interpreter mi \"-var-delete " varnum "\"\n")
 317              'ignore))
 318       (setq gdb-var-list (delq var gdb-var-list))
 319       (dolist (varchild gdb-var-list)
 320         (if (string-match (concat (nth 1 var) "\\.") (nth 1 varchild))
 321             (setq gdb-var-list (delq varchild gdb-var-list)))))
 322     (setq gdb-var-changed t)))
 323
 324 (defun gdb-edit-value (text token indent)
 325   "Assign a value to a variable displayed in the speedbar"
 326   (interactive)
 327   (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
 328          (varnum (cadr var)) (value))
 329     (setq value (read-string "New value: "))
 330     (gdb-enqueue-input
 331      (list (concat "server interpreter mi \"-var-assign "
 332                    varnum " " value "\"\n")
 333            'ignore))))
 334
 335 (defcustom gdb-show-changed-values t
 336   "Non-nil means use font-lock-warning-face to display values that have
 337 recently changed in the speedbar."
 338   :type 'boolean
 339   :group 'gud)
 340
 341 (defun gdb-speedbar-expand-node (text token indent)
 342   "Expand the node the user clicked on.
 343 TEXT is the text of the button we clicked on, a + or - item.
 344 TOKEN is data related to this node.
 345 INDENT is the current indentation depth."
 346   (cond ((string-match "+" text)        ;expand this node
 347          (gdb-var-list-children token))
 348         ((string-match "-" text)        ;contract this node
 349          (dolist (var gdb-var-list)
 350            (if (string-match (concat token "\\.") (nth 1 var))
 351                (setq gdb-var-list (delq var gdb-var-list))))
 352          (setq gdb-var-changed t))))
 353
 354 \f
 355 ;; ======================================================================
 356 ;;
 357 ;; In this world, there are gdb variables (of unspecified
 358 ;; representation) and buffers associated with those objects.
 359 ;; The list of  variables is built up by the expansions of
 360 ;; def-gdb-variable
 361
 362 (defmacro def-gdb-var (root-symbol &optional default doc)
 363   (let* ((root (symbol-name root-symbol))
 364          (accessor (intern (concat "gdb-get-" root)))
 365          (setter (intern (concat "gdb-set-" root)))
 366          (name (intern (concat "gdb-" root))))
 367     `(progn
 368        (defvar ,name ,default ,doc)
 369        (if (not (memq ',name gdb-variables))
 370            (push ',name gdb-variables))
 371        (defun ,accessor ()
 372          (buffer-local-value ',name gud-comint-buffer))
 373        (defun ,setter (val)
 374          (with-current-buffer gud-comint-buffer
 375            (setq ,name val))))))
 376
 377 (def-gdb-var buffer-type nil
 378   "One of the symbols bound in gdb-buffer-rules")
 379
 380 (def-gdb-var burst ""
 381   "A string of characters from gdb that have not yet been processed.")
 382
 383 (def-gdb-var input-queue ()
 384   "A list of gdb command objects.")
 385
 386 (def-gdb-var prompting nil
 387   "True when gdb is idle with no pending input.")
 388
 389 (def-gdb-var output-sink 'user
 390   "The disposition of the output of the current gdb command.
 391 Possible values are these symbols:
 392
 393     user -- gdb output should be copied to the GUD buffer
 394             for the user to see.
 395
 396     inferior -- gdb output should be copied to the inferior-io buffer
 397
 398     pre-emacs -- output should be ignored util the post-prompt
 399                  annotation is received.  Then the output-sink
 400                  becomes:...
 401     emacs -- output should be collected in the partial-output-buffer
 402              for subsequent processing by a command.  This is the
 403              disposition of output generated by commands that
 404              gdb mode sends to gdb on its own behalf.
 405     post-emacs -- ignore input until the prompt annotation is
 406                   received, then go to USER disposition.
 407 ")
 408
 409 (def-gdb-var current-item nil
 410   "The most recent command item sent to gdb.")
 411
 412 (def-gdb-var pending-triggers '()
 413   "A list of trigger functions that have run later than their output
 414 handlers.")
 415
 416 ;; end of gdb variables
 417
 418 (defun gdb-get-target-string ()
 419   (with-current-buffer gud-comint-buffer
 420     gud-target-name))
 421 \f
 422
 423 ;;
 424 ;; gdb buffers.
 425 ;;
 426 ;; Each buffer has a TYPE -- a symbol that identifies the function
 427 ;; of that particular buffer.
 428 ;;
 429 ;; The usual gdb interaction buffer is given the type `gdba' and
 430 ;; is constructed specially.
 431 ;;
 432 ;; Others are constructed by gdb-get-create-buffer and
 433 ;; named according to the rules set forth in the gdb-buffer-rules-assoc
 434
 435 (defvar gdb-buffer-rules-assoc '())
 436
 437 (defun gdb-get-buffer (key)
 438   "Return the gdb buffer tagged with type KEY.
 439 The key should be one of the cars in `gdb-buffer-rules-assoc'."
 440   (save-excursion
 441     (gdb-look-for-tagged-buffer key (buffer-list))))
 442
 443 (defun gdb-get-create-buffer (key)
 444   "Create a new gdb  buffer of the type specified by KEY.
 445 The key should be one of the cars in `gdb-buffer-rules-assoc'."
 446   (or (gdb-get-buffer key)
 447       (let* ((rules (assoc key gdb-buffer-rules-assoc))
 448              (name (funcall (gdb-rules-name-maker rules)))
 449              (new (get-buffer-create name)))
 450         (with-current-buffer new
 451           ;; FIXME: This should be set after calling the function, since the
 452           ;; function should run kill-all-local-variables.
 453           (set (make-local-variable 'gdb-buffer-type) key)
 454           (if (cdr (cdr rules))
 455               (funcall (car (cdr (cdr rules)))))
 456           (set (make-local-variable 'gud-comint-buffer) gud-comint-buffer)
 457           (set (make-local-variable 'gud-minor-mode) 'gdba)
 458           (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
 459           new))))
 460
 461 (defun gdb-rules-name-maker (rules) (car (cdr rules)))
 462
 463 (defun gdb-look-for-tagged-buffer (key bufs)
 464   (let ((retval nil))
 465     (while (and (not retval) bufs)
 466       (set-buffer (car bufs))
 467       (if (eq gdb-buffer-type key)
 468           (setq retval (car bufs)))
 469       (setq bufs (cdr bufs)))
 470     retval))
 471
 472 ;;
 473 ;; This assoc maps buffer type symbols to rules.  Each rule is a list of
 474 ;; at least one and possible more functions.  The functions have these
 475 ;; roles in defining a buffer type:
 476 ;;
 477 ;;     NAME - Return a name for this  buffer type.
 478 ;;
 479 ;; The remaining function(s) are optional:
 480 ;;
 481 ;;     MODE - called in a new buffer with no arguments, should establish
 482 ;;            the proper mode for the buffer.
 483 ;;
 484
 485 (defun gdb-set-buffer-rules (buffer-type &rest rules)
 486   (let ((binding (assoc buffer-type gdb-buffer-rules-assoc)))
 487     (if binding
 488         (setcdr binding rules)
 489       (push (cons buffer-type rules)
 490             gdb-buffer-rules-assoc))))
 491
 492 ;; GUD buffers are an exception to the rules
 493 (gdb-set-buffer-rules 'gdba 'error)
 494
 495 ;;
 496 ;; Partial-output buffer : This accumulates output from a command executed on
 497 ;; behalf of emacs (rather than the user).
 498 ;;
 499 (gdb-set-buffer-rules 'gdb-partial-output-buffer
 500                       'gdb-partial-output-name)
 501
 502 (defun gdb-partial-output-name ()
 503   (concat "*partial-output-"
 504           (gdb-get-target-string)
 505           "*"))
 506
 507 \f
 508 (gdb-set-buffer-rules 'gdb-inferior-io
 509                       'gdb-inferior-io-name
 510                       'gdb-inferior-io-mode)
 511
 512 (defun gdb-inferior-io-name ()
 513   (concat "*input/output of "
 514           (gdb-get-target-string)
 515           "*"))
 516
 517 (defvar gdb-inferior-io-mode-map
 518   (let ((map (make-sparse-keymap)))
 519     (define-key map "\C-c\C-c" 'gdb-inferior-io-interrupt)
 520     (define-key map "\C-c\C-z" 'gdb-inferior-io-stop)
 521     (define-key map "\C-c\C-\\" 'gdb-inferior-io-quit)
 522     (define-key map "\C-c\C-d" 'gdb-inferior-io-eof)
 523     map))
 524
 525 (define-derived-mode gdb-inferior-io-mode comint-mode "Debuggee I/O"
 526   "Major mode for gdb inferior-io."
 527   :syntax-table nil :abbrev-table nil
 528   ;; We want to use comint because it has various nifty and familiar
 529   ;; features.  We don't need a process, but comint wants one, so create
 530   ;; a dummy one.
 531   (make-comint-in-buffer
 532    (substring (buffer-name) 1 (- (length (buffer-name)) 1))
 533    (current-buffer) "hexl")
 534   (setq comint-input-sender 'gdb-inferior-io-sender))
 535
 536 (defun gdb-inferior-io-sender (proc string)
 537   ;; PROC is the pseudo-process created to satisfy comint.
 538   (with-current-buffer (process-buffer proc)
 539     (setq proc (get-buffer-process gud-comint-buffer))
 540     (process-send-string proc string)
 541     (process-send-string proc "\n")))
 542
 543 (defun gdb-inferior-io-interrupt ()
 544   "Interrupt the program being debugged."
 545   (interactive)
 546   (interrupt-process
 547    (get-buffer-process gud-comint-buffer) comint-ptyp))
 548
 549 (defun gdb-inferior-io-quit ()
 550   "Send quit signal to the program being debugged."
 551   (interactive)
 552   (quit-process
 553    (get-buffer-process gud-comint-buffer) comint-ptyp))
 554
 555 (defun gdb-inferior-io-stop ()
 556   "Stop the program being debugged."
 557   (interactive)
 558   (stop-process
 559    (get-buffer-process gud-comint-buffer) comint-ptyp))
 560
 561 (defun gdb-inferior-io-eof ()
 562   "Send end-of-file to the program being debugged."
 563   (interactive)
 564   (process-send-eof
 565    (get-buffer-process gud-comint-buffer)))
 566 \f
 567
 568 ;;
 569 ;; gdb communications
 570 ;;
 571
 572 ;; INPUT: things sent to gdb
 573 ;;
 574 ;; The queues are lists.  Each element is either a string (indicating user or
 575 ;; user-like input) or a list of the form:
 576 ;;
 577 ;;    (INPUT-STRING  HANDLER-FN)
 578 ;;
 579 ;; The handler function will be called from the partial-output buffer when the
 580 ;; command completes.  This is the way to write commands which invoke gdb
 581 ;; commands autonomously.
 582 ;;
 583 ;; These lists are consumed tail first.
 584 ;;
 585
 586 (defun gdb-send (proc string)
 587   "A comint send filter for gdb.
 588 This filter may simply queue output for a later time."
 589   (gdb-enqueue-input (concat string "\n")))
 590
 591 ;; Note: Stuff enqueued here will be sent to the next prompt, even if it
 592 ;; is a query, or other non-top-level prompt.
 593
 594 (defun gdb-enqueue-input (item)
 595   (if (gdb-get-prompting)
 596       (progn
 597         (gdb-send-item item)
 598         (gdb-set-prompting nil))
 599     (gdb-set-input-queue
 600      (cons item (gdb-get-input-queue)))))
 601
 602 (defun gdb-dequeue-input ()
 603   (let ((queue (gdb-get-input-queue)))
 604     (and queue
 605          (let ((last (car (last queue))))
 606            (unless (nbutlast queue) (gdb-set-input-queue '()))
 607            last))))
 608
 609 \f
 610 ;;
 611 ;; output -- things gdb prints to emacs
 612 ;;
 613 ;; GDB output is a stream interrupted by annotations.
 614 ;; Annotations can be recognized by their beginning
 615 ;; with \C-j\C-z\C-z<tag><opt>\C-j
 616 ;;
 617 ;; The tag is a string obeying symbol syntax.
 618 ;;
 619 ;; The optional part `<opt>' can be either the empty string
 620 ;; or a space followed by more data relating to the annotation.
 621 ;; For example, the SOURCE annotation is followed by a filename,
 622 ;; line number and various useless goo.  This data must not include
 623 ;; any newlines.
 624 ;;
 625
 626 (defcustom gud-gdba-command-name "gdb -annotate=3"
 627   "Default command to execute an executable under the GDB-UI debugger."
 628   :type 'string
 629   :group 'gud)
 630
 631 (defvar gdb-annotation-rules
 632   '(("pre-prompt" gdb-pre-prompt)
 633     ("prompt" gdb-prompt)
 634     ("commands" gdb-subprompt)
 635     ("overload-choice" gdb-subprompt)
 636     ("query" gdb-subprompt)
 637     ("prompt-for-continue" gdb-subprompt)
 638     ("post-prompt" gdb-post-prompt)
 639     ("source" gdb-source)
 640     ("starting" gdb-starting)
 641     ("exited" gdb-stopping)
 642     ("signalled" gdb-stopping)
 643     ("signal" gdb-stopping)
 644     ("breakpoint" gdb-stopping)
 645     ("watchpoint" gdb-stopping)
 646     ("frame-begin" gdb-frame-begin)
 647     ("stopped" gdb-stopped)
 648     ) "An assoc mapping annotation tags to functions which process them.")
 649
 650 (defconst gdb-source-spec-regexp
 651   "\\(.*\\):\\([0-9]*\\):[0-9]*:[a-z]*:\\(0x[a-f0-9]*\\)")
 652
 653 ;; Do not use this except as an annotation handler.
 654 (defun gdb-source (args)
 655   (string-match gdb-source-spec-regexp args)
 656   ;; Extract the frame position from the marker.
 657   (setq gud-last-frame
 658         (cons
 659          (match-string 1 args)
 660          (string-to-int (match-string 2 args))))
 661   (setq gdb-current-address (match-string 3 args))
 662   (setq gdb-view-source t))
 663
 664 (defun gdb-send-item (item)
 665   (gdb-set-current-item item)
 666   (if (stringp item)
 667       (progn
 668         (gdb-set-output-sink 'user)
 669         (process-send-string (get-buffer-process gud-comint-buffer) item))
 670     (progn
 671       (gdb-clear-partial-output)
 672       (gdb-set-output-sink 'pre-emacs)
 673       (process-send-string (get-buffer-process gud-comint-buffer)
 674                            (car item)))))
 675
 676 (defun gdb-pre-prompt (ignored)
 677   "An annotation handler for `pre-prompt'. This terminates the collection of
 678 output from a previous command if that happens to be in effect."
 679   (let ((sink (gdb-get-output-sink)))
 680     (cond
 681      ((eq sink 'user) t)
 682      ((eq sink 'emacs)
 683       (gdb-set-output-sink 'post-emacs))
 684      (t
 685       (gdb-set-output-sink 'user)
 686       (error "Phase error in gdb-pre-prompt (got %s)" sink)))))
 687
 688 (defun gdb-prompt (ignored)
 689   "An annotation handler for `prompt'.
 690 This sends the next command (if any) to gdb."
 691   (when gdb-first-prompt (gdb-ann3))
 692   (let ((sink (gdb-get-output-sink)))
 693     (cond
 694      ((eq sink 'user) t)
 695      ((eq sink 'post-emacs)
 696       (gdb-set-output-sink 'user)
 697       (let ((handler
 698              (car (cdr (gdb-get-current-item)))))
 699         (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 700           (funcall handler))))
 701      (t
 702       (gdb-set-output-sink 'user)
 703       (error "Phase error in gdb-prompt (got %s)" sink))))
 704   (let ((input (gdb-dequeue-input)))
 705     (if input
 706         (gdb-send-item input)
 707       (progn
 708         (gdb-set-prompting t)
 709         (gud-display-frame)))))
 710
 711 (defun gdb-subprompt (ignored)
 712   "An annotation handler for non-top-level prompts."
 713   (gdb-set-prompting t))
 714
 715 (defun gdb-starting (ignored)
 716   "An annotation handler for `starting'.  This says that I/O for the
 717 subprocess is now the program being debugged, not GDB."
 718   (let ((sink (gdb-get-output-sink)))
 719     (cond
 720      ((eq sink 'user)
 721       (progn
 722         (setq gud-running t)
 723         (gdb-set-output-sink 'inferior)))
 724      (t (error "Unexpected `starting' annotation")))))
 725
 726 (defun gdb-stopping (ignored)
 727   "An annotation handler for `exited' and other annotations which say that I/O
 728 for the subprocess is now GDB, not the program being debugged."
 729   (let ((sink (gdb-get-output-sink)))
 730     (cond
 731      ((eq sink 'inferior)
 732       (gdb-set-output-sink 'user))
 733      (t (error "Unexpected stopping annotation")))))
 734
 735 (defun gdb-frame-begin (ignored)
 736   (let ((sink (gdb-get-output-sink)))
 737     (cond
 738      ((eq sink 'inferior)
 739       (gdb-set-output-sink 'user))
 740      ((eq sink 'user) t)
 741      ((eq sink 'emacs) t)
 742      (t (error "Unexpected frame-begin annotation (%S)" sink)))))
 743
 744 (defun gdb-stopped (ignored)
 745   "An annotation handler for `stopped'.  It is just like gdb-stopping, except
 746 that if we already set the output sink to 'user in gdb-stopping, that is fine."
 747   (setq gud-running nil)
 748   (let ((sink (gdb-get-output-sink)))
 749     (cond
 750      ((eq sink 'inferior)
 751       (gdb-set-output-sink 'user))
 752      ((eq sink 'user) t)
 753      (t (error "Unexpected stopped annotation")))))
 754
 755 (defun gdb-post-prompt (ignored)
 756   "An annotation handler for `post-prompt'. This begins the collection of
 757 output from the current command if that happens to be appropriate."
 758   (if (not (gdb-get-pending-triggers))
 759       (progn
 760         (gdb-get-current-frame)
 761         (gdb-invalidate-frames)
 762         (gdb-invalidate-breakpoints)
 763         (gdb-invalidate-assembler)
 764         (gdb-invalidate-registers)
 765         (gdb-invalidate-locals)
 766         (gdb-invalidate-threads)
 767         (dolist (frame (frame-list))
 768           (when (string-equal (frame-parameter frame 'name) "Speedbar")
 769             (setq gdb-var-changed t)    ; force update
 770             (dolist (var gdb-var-list)
 771               (setcar (nthcdr 5 var) nil))))
 772         (gdb-var-update)))
 773   (let ((sink (gdb-get-output-sink)))
 774     (cond
 775      ((eq sink 'user) t)
 776      ((eq sink 'pre-emacs)
 777       (gdb-set-output-sink 'emacs))
 778      (t
 779       (gdb-set-output-sink 'user)
 780       (error "Phase error in gdb-post-prompt (got %s)" sink)))))
 781
 782 (defun gud-gdba-marker-filter (string)
 783   "A gud marker filter for gdb. Handle a burst of output from GDB."
 784   ;; Recall the left over gud-marker-acc from last time
 785   (setq gud-marker-acc (concat gud-marker-acc string))
 786   ;; Start accumulating output for the GUD buffer
 787   (let ((output ""))
 788     ;;
 789     ;; Process all the complete markers in this chunk.
 790     (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc)
 791       (let ((annotation (match-string 1 gud-marker-acc)))
 792         ;;
 793         ;; Stuff prior to the match is just ordinary output.
 794         ;; It is either concatenated to OUTPUT or directed
 795         ;; elsewhere.
 796         (setq output
 797               (gdb-concat-output
 798                output
 799                (substring gud-marker-acc 0 (match-beginning 0))))
 800         ;;
 801         ;; Take that stuff off the gud-marker-acc.
 802         (setq gud-marker-acc (substring gud-marker-acc (match-end 0)))
 803         ;;
 804         ;; Parse the tag from the annotation, and maybe its arguments.
 805         (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation)
 806         (let* ((annotation-type (match-string 1 annotation))
 807                (annotation-arguments (match-string 2 annotation))
 808                (annotation-rule (assoc annotation-type
 809                                        gdb-annotation-rules)))
 810           ;; Call the handler for this annotation.
 811           (if annotation-rule
 812               (funcall (car (cdr annotation-rule))
 813                        annotation-arguments)
 814             ;; Else the annotation is not recognized.  Ignore it silently,
 815             ;; so that GDB can add new annotations without causing
 816             ;; us to blow up.
 817             ))))
 818     ;;
 819     ;; Does the remaining text end in a partial line?
 820     ;; If it does, then keep part of the gud-marker-acc until we get more.
 821     (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'"
 822                       gud-marker-acc)
 823         (progn
 824           ;; Everything before the potential marker start can be output.
 825           (setq output
 826                 (gdb-concat-output output
 827                                    (substring gud-marker-acc 0
 828                                               (match-beginning 0))))
 829           ;;
 830           ;; Everything after, we save, to combine with later input.
 831           (setq gud-marker-acc (substring gud-marker-acc (match-beginning 0))))
 832       ;;
 833       ;; In case we know the gud-marker-acc contains no partial annotations:
 834       (progn
 835         (setq output (gdb-concat-output output gud-marker-acc))
 836         (setq gud-marker-acc "")))
 837     output))
 838
 839 (defun gdb-concat-output (so-far new)
 840   (let ((sink (gdb-get-output-sink )))
 841     (cond
 842      ((eq sink 'user) (concat so-far new))
 843      ((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far)
 844      ((eq sink 'emacs)
 845       (gdb-append-to-partial-output new)
 846       so-far)
 847      ((eq sink 'inferior)
 848       (gdb-append-to-inferior-io new)
 849       so-far)
 850      (t (error "Bogon output sink %S" sink)))))
 851
 852 (defun gdb-append-to-partial-output (string)
 853   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 854     (goto-char (point-max))
 855     (insert string)))
 856
 857 (defun gdb-clear-partial-output ()
 858   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 859     (erase-buffer)))
 860
 861 (defun gdb-append-to-inferior-io (string)
 862   (with-current-buffer (gdb-get-create-buffer 'gdb-inferior-io)
 863     (goto-char (point-max))
 864     (insert-before-markers string))
 865   (if (not (string-equal string ""))
 866       (gdb-display-buffer (gdb-get-create-buffer 'gdb-inferior-io))))
 867
 868 (defun gdb-clear-inferior-io ()
 869   (with-current-buffer (gdb-get-create-buffer 'gdb-inferior-io)
 870     (erase-buffer)))
 871 \f
 872
 873 ;; One trick is to have a command who's output is always available in a buffer
 874 ;; of it's own, and is always up to date.  We build several buffers of this
 875 ;; type.
 876 ;;
 877 ;; There are two aspects to this: gdb has to tell us when the output for that
 878 ;; command might have changed, and we have to be able to run the command
 879 ;; behind the user's back.
 880 ;;
 881 ;; The output phasing associated with the variable gdb-output-sink
 882 ;; help us to run commands behind the user's back.
 883 ;;
 884 ;; Below is the code for specificly managing buffers of output from one
 885 ;; command.
 886 ;;
 887
 888 ;; The trigger function is suitable for use in the assoc GDB-ANNOTATION-RULES
 889 ;; It adds an input for the command we are tracking.  It should be the
 890 ;; annotation rule binding of whatever gdb sends to tell us this command
 891 ;; might have changed it's output.
 892 ;;
 893 ;; NAME is the function name.  DEMAND-PREDICATE tests if output is really needed.
 894 ;; GDB-COMMAND is a string of such.  OUTPUT-HANDLER is the function bound to the
 895 ;; input in the input queue (see comment about ``gdb communications'' above).
 896
 897 (defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command
 898                                             output-handler)
 899   `(defun ,name (&optional ignored)
 900      (if (and (,demand-predicate)
 901               (not (member ',name
 902                            (gdb-get-pending-triggers))))
 903          (progn
 904            (gdb-enqueue-input
 905             (list ,gdb-command ',output-handler))
 906            (gdb-set-pending-triggers
 907             (cons ',name
 908                   (gdb-get-pending-triggers)))))))
 909
 910 (defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun)
 911   `(defun ,name ()
 912      (gdb-set-pending-triggers
 913       (delq ',trigger
 914             (gdb-get-pending-triggers)))
 915      (let ((buf (gdb-get-buffer ',buf-key)))
 916        (and buf
 917             (with-current-buffer buf
 918               (let ((p (point))
 919                     (buffer-read-only nil))
 920                 (erase-buffer)
 921                 (insert-buffer-substring (gdb-get-create-buffer
 922                                           'gdb-partial-output-buffer))
 923                 (goto-char p)))))
 924      ;; put customisation here
 925      (,custom-defun)))
 926
 927 (defmacro def-gdb-auto-updated-buffer (buffer-key trigger-name gdb-command
 928                                                   output-handler-name custom-defun)
 929   `(progn
 930      (def-gdb-auto-update-trigger ,trigger-name
 931        ;; The demand predicate:
 932        (lambda () (gdb-get-buffer ',buffer-key))
 933        ,gdb-command
 934        ,output-handler-name)
 935      (def-gdb-auto-update-handler ,output-handler-name
 936        ,trigger-name ,buffer-key ,custom-defun)))
 937
 938 \f
 939 ;;
 940 ;; Breakpoint buffer : This displays the output of `info breakpoints'.
 941 ;;
 942 (gdb-set-buffer-rules 'gdb-breakpoints-buffer
 943                       'gdb-breakpoints-buffer-name
 944                       'gdb-breakpoints-mode)
 945
 946 (def-gdb-auto-updated-buffer gdb-breakpoints-buffer
 947   ;; This defines the auto update rule for buffers of type
 948   ;; `gdb-breakpoints-buffer'.
 949   ;;
 950   ;; It defines a function to serve as the annotation handler that
 951   ;; handles the `foo-invalidated' message.  That function is called:
 952   gdb-invalidate-breakpoints
 953   ;;
 954   ;; To update the buffer, this command is sent to gdb.
 955   "server info breakpoints\n"
 956   ;;
 957   ;; This also defines a function to be the handler for the output
 958   ;; from the command above.  That function will copy the output into
 959   ;; the appropriately typed buffer.  That function will be called:
 960   gdb-info-breakpoints-handler
 961   ;; buffer specific functions
 962   gdb-info-breakpoints-custom)
 963
 964 (defvar gdb-cdir nil "Compilation directory.")
 965
 966 (defconst breakpoint-xpm-data "/* XPM */
 967 static char *magick[] = {
 968 /* columns rows colors chars-per-pixel */
 969 \"10 10 2 1\",
 970 \"  c red\",
 971 \"+ c None\",
 972 /* pixels */
 973 \"+++    +++\",
 974 \"++      ++\",
 975 \"+        +\",
 976 \"          \",
 977 \"          \",
 978 \"          \",
 979 \"          \",
 980 \"+        +\",
 981 \"++      ++\",
 982 \"+++    +++\",
 983 };"
 984   "XPM data used for breakpoint icon.")
 985
 986 (defconst breakpoint-enabled-pbm-data
 987 "P1
 988 10 10\",
 989 0 0 0 0 1 1 1 1 0 0 0 0
 990 0 0 0 1 1 1 1 1 1 0 0 0
 991 0 0 1 1 1 1 1 1 1 1 0 0
 992 0 1 1 1 1 1 1 1 1 1 1 0
 993 0 1 1 1 1 1 1 1 1 1 1 0
 994 0 1 1 1 1 1 1 1 1 1 1 0
 995 0 1 1 1 1 1 1 1 1 1 1 0
 996 0 0 1 1 1 1 1 1 1 1 0 0
 997 0 0 0 1 1 1 1 1 1 0 0 0
 998 0 0 0 0 1 1 1 1 0 0 0 0"
 999   "PBM data used for enabled breakpoint icon.")
1000
1001 (defconst breakpoint-disabled-pbm-data
1002 "P1
1003 10 10\",
1004 0 0 1 0 1 0 1 0 0 0
1005 0 1 0 1 0 1 0 1 0 0
1006 1 0 1 0 1 0 1 0 1 0
1007 0 1 0 1 0 1 0 1 0 1
1008 1 0 1 0 1 0 1 0 1 0
1009 0 1 0 1 0 1 0 1 0 1
1010 1 0 1 0 1 0 1 0 1 0
1011 0 1 0 1 0 1 0 1 0 1
1012 0 0 1 0 1 0 1 0 1 0
1013 0 0 0 1 0 1 0 1 0 0"
1014   "PBM data used for disabled breakpoint icon.")
1015
1016 (defvar breakpoint-enabled-icon
1017   (find-image `((:type xpm :data ,breakpoint-xpm-data :ascent 100)
1018                 (:type pbm :data ,breakpoint-enabled-pbm-data :ascent 100)))
1019   "Icon for enabled breakpoint in display margin")
1020
1021 (defvar breakpoint-disabled-icon
1022   (find-image `((:type xpm :data ,breakpoint-xpm-data :conversion disabled :ascent 100)
1023                 (:type pbm :data ,breakpoint-disabled-pbm-data :ascent 100)))
1024   "Icon for disabled breakpoint in display margin")
1025
1026 ;;-put breakpoint icons in relevant margins (even those set in the GUD buffer)
1027 (defun gdb-info-breakpoints-custom ()
1028   (let ((flag)(address))
1029     ;;
1030     ;; remove all breakpoint-icons in source buffers but not assembler buffer
1031     (dolist (buffer (buffer-list))
1032       (with-current-buffer buffer
1033         (if (and (eq gud-minor-mode 'gdba)
1034                  (not (string-match "^\*" (buffer-name))))
1035             (if (display-images-p)
1036                 (remove-images (point-min) (point-max))
1037               (gdb-remove-strings (point-min) (point-max))))))
1038     (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
1039       (save-excursion
1040         (goto-char (point-min))
1041         (while (< (point) (- (point-max) 1))
1042           (forward-line 1)
1043           (if (looking-at "[^\t].*breakpoint")
1044               (progn
1045                 (looking-at "[0-9]*\\s-*\\S-*\\s-*\\S-*\\s-*\\(.\\)")
1046                 (setq flag (char-after (match-beginning 1)))
1047                 (beginning-of-line)
1048                 (if (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+" nil t)
1049                     (progn
1050                       (looking-at "\\(\\S-*\\):\\([0-9]+\\)")
1051                       (let ((line (match-string 2)) (buffer-read-only nil)
1052                             (file (match-string 1)))
1053                         (add-text-properties (point-at-bol) (point-at-eol)
1054                          '(mouse-face highlight
1055                            help-echo "mouse-2, RET: visit breakpoint"))
1056                         (with-current-buffer
1057                             (find-file-noselect
1058                              (if (file-exists-p file) file
1059                                (expand-file-name file gdb-cdir)))
1060                           (save-current-buffer
1061                             (set (make-local-variable 'gud-minor-mode) 'gdba)
1062                             (set (make-local-variable 'tool-bar-map)
1063                                  gud-tool-bar-map)
1064                             (setq left-margin-width 2)
1065                             (if (get-buffer-window (current-buffer))
1066                                 (set-window-margins (get-buffer-window
1067                                                      (current-buffer))
1068                                                     left-margin-width
1069                                                     right-margin-width)))
1070                           ;; only want one breakpoint icon at each location
1071                           (save-excursion
1072                             (goto-line (string-to-number line))
1073                             (let ((start (progn (beginning-of-line)
1074                                                 (- (point) 1)))
1075                                   (end (progn (end-of-line) (+ (point) 1))))
1076                               (if (display-images-p)
1077                                   (progn
1078                                     (remove-images start end)
1079                                     (if (eq ?y flag)
1080                                         (put-image breakpoint-enabled-icon
1081                                                    (+ start 1)
1082                                                    "breakpoint icon enabled"
1083                                                    'left-margin)
1084                                       (put-image breakpoint-disabled-icon
1085                                                  (+ start 1)
1086                                                  "breakpoint icon disabled"
1087                                                  'left-margin)))
1088                                 (gdb-remove-strings start end)
1089                                 (if (eq ?y flag)
1090                                     (gdb-put-string "B" (+ start 1))
1091                                   (gdb-put-string "b" (+ start 1))))))))))))
1092           (end-of-line)))))
1093   (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)))
1094
1095 (defun gdb-mouse-toggle-breakpoint (event)
1096   "Toggle breakpoint with mouse click in left margin."
1097   (interactive "e")
1098   (mouse-minibuffer-check event)
1099   (let ((posn (event-end event)))
1100     (message "pt=%S posn=%S" (posn-point posn) posn)
1101     (if (numberp (posn-point posn))
1102         (with-selected-window (posn-window posn)
1103           (save-excursion
1104             (goto-char (posn-point posn))
1105             (if (posn-object posn)
1106                 (gud-remove nil)
1107               (gud-break nil)))))))
1108
1109 (defun gdb-breakpoints-buffer-name ()
1110   (with-current-buffer gud-comint-buffer
1111     (concat "*breakpoints of " (gdb-get-target-string) "*")))
1112
1113 (defun gdb-display-breakpoints-buffer ()
1114   (interactive)
1115   (gdb-display-buffer
1116    (gdb-get-create-buffer 'gdb-breakpoints-buffer)))
1117
1118 (defun gdb-frame-breakpoints-buffer ()
1119   (interactive)
1120   (switch-to-buffer-other-frame
1121    (gdb-get-create-buffer 'gdb-breakpoints-buffer)))
1122
1123 (defvar gdb-breakpoints-mode-map
1124   (let ((map (make-sparse-keymap))
1125         (menu (make-sparse-keymap "Breakpoints")))
1126     (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint))
1127     (define-key menu [delete] '("Delete" . gdb-delete-breakpoint))
1128     (define-key menu [goto] '("Goto"   . gdb-goto-breakpoint))
1129
1130     (suppress-keymap map)
1131     (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu))
1132     (define-key map " " 'gdb-toggle-breakpoint)
1133     (define-key map "d" 'gdb-delete-breakpoint)
1134     (define-key map "\r" 'gdb-goto-breakpoint)
1135     (define-key map [mouse-2] 'gdb-mouse-goto-breakpoint)
1136     map))
1137
1138 (defun gdb-breakpoints-mode ()
1139   "Major mode for gdb breakpoints.
1140
1141 \\{gdb-breakpoints-mode-map}"
1142   (setq major-mode 'gdb-breakpoints-mode)
1143   (setq mode-name "Breakpoints")
1144   (use-local-map gdb-breakpoints-mode-map)
1145   (setq buffer-read-only t)
1146   (gdb-invalidate-breakpoints))
1147
1148 (defun gdb-toggle-breakpoint ()
1149   "Enable/disable the breakpoint at current line."
1150   (interactive)
1151   (save-excursion
1152     (beginning-of-line 1)
1153     (if (not (looking-at "\\([0-9]+\\).*point\\s-*\\S-*\\s-*\\(.\\)"))
1154         (error "Not recognized as break/watchpoint line")
1155       (gdb-enqueue-input
1156        (list
1157         (concat
1158          (if (eq ?y (char-after (match-beginning 2)))
1159              "server disable "
1160            "server enable ")
1161          (match-string 1) "\n")
1162         'ignore)))))
1163
1164 (defun gdb-delete-breakpoint ()
1165   "Delete the breakpoint at current line."
1166   (interactive)
1167   (beginning-of-line 1)
1168   (if (not (looking-at "\\([0-9]+\\).*point\\s-*\\S-*\\s-*\\(.\\)"))
1169       (error "Not recognized as break/watchpoint line")
1170     (gdb-enqueue-input
1171      (list (concat "server delete " (match-string 1) "\n") 'ignore))))
1172
1173 (defvar gdb-source-window nil)
1174
1175 (defun gdb-goto-breakpoint ()
1176   "Display the file in the source buffer at the breakpoint specified on the
1177 current line."
1178   (interactive)
1179   (save-excursion
1180     (beginning-of-line 1)
1181     (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+" nil t)
1182     (looking-at "\\(\\S-*\\):\\([0-9]+\\)"))
1183   (if (match-string 2)
1184       (let ((line (match-string 2))
1185             (file (match-string 1)))
1186         (save-selected-window
1187           (select-window gdb-source-window)
1188           (switch-to-buffer (find-file-noselect
1189                              (if (file-exists-p file)
1190                                  file
1191                                (expand-file-name file gdb-cdir))))
1192           (goto-line (string-to-number line))))))
1193
1194 (defun gdb-mouse-goto-breakpoint (event)
1195   "Display the file in the source buffer at the selected breakpoint."
1196   (interactive "e")
1197   (mouse-set-point event)
1198   (gdb-goto-breakpoint))
1199 \f
1200 ;;
1201 ;; Frames buffer.  This displays a perpetually correct bactracktrace
1202 ;; (from the command `where').
1203 ;;
1204 ;; Alas, if your stack is deep, it is costly.
1205 ;;
1206 (gdb-set-buffer-rules 'gdb-stack-buffer
1207                       'gdb-stack-buffer-name
1208                       'gdb-frames-mode)
1209
1210 (def-gdb-auto-updated-buffer gdb-stack-buffer
1211   gdb-invalidate-frames
1212   "server where\n"
1213   gdb-info-frames-handler
1214   gdb-info-frames-custom)
1215
1216 (defun gdb-info-frames-custom ()
1217   (with-current-buffer (gdb-get-buffer 'gdb-stack-buffer)
1218     (save-excursion
1219       (let ((buffer-read-only nil))
1220         (goto-char (point-min))
1221         (while (< (point) (point-max))
1222           (add-text-properties (point-at-bol) (point-at-eol)
1223                              '(mouse-face highlight
1224                                help-echo "mouse-2, RET: Select frame"))
1225           (beginning-of-line)
1226           (when (and (or (looking-at "^#[0-9]*\\s-*\\S-* in \\(\\S-*\\)")
1227                          (looking-at "^#[0-9]*\\s-*\\(\\S-*\\)"))
1228                      (equal (match-string 1) gdb-current-frame))
1229             (put-text-property (point-at-bol) (point-at-eol)
1230                                'face '(:inverse-video t)))
1231           (forward-line 1))))))
1232
1233 (defun gdb-stack-buffer-name ()
1234   (with-current-buffer gud-comint-buffer
1235     (concat "*stack frames of " (gdb-get-target-string) "*")))
1236
1237 (defun gdb-display-stack-buffer ()
1238   (interactive)
1239   (gdb-display-buffer
1240    (gdb-get-create-buffer 'gdb-stack-buffer)))
1241
1242 (defun gdb-frame-stack-buffer ()
1243   (interactive)
1244   (switch-to-buffer-other-frame
1245    (gdb-get-create-buffer 'gdb-stack-buffer)))
1246
1247 (defvar gdb-frames-mode-map
1248   (let ((map (make-sparse-keymap)))
1249     (suppress-keymap map)
1250     (define-key map "\r" 'gdb-frames-select)
1251     (define-key map [mouse-2] 'gdb-frames-mouse-select)
1252     map))
1253
1254 (defun gdb-frames-mode ()
1255   "Major mode for gdb frames.
1256
1257 \\{gdb-frames-mode-map}"
1258   (setq major-mode 'gdb-frames-mode)
1259   (setq mode-name "Frames")
1260   (setq buffer-read-only t)
1261   (use-local-map gdb-frames-mode-map)
1262   (font-lock-mode -1)
1263   (gdb-invalidate-frames))
1264
1265 (defun gdb-get-frame-number ()
1266   (save-excursion
1267     (let* ((pos (re-search-backward "^#\\([0-9]*\\)" nil t))
1268            (n (or (and pos (match-string-no-properties 1)) "0")))
1269       n)))
1270
1271 (defun gdb-frames-select ()
1272   "Make the frame on the current line become the current frame and display the
1273 source in the source buffer."
1274   (interactive)
1275   (gdb-enqueue-input
1276    (list (concat "server frame " (gdb-get-frame-number) "\n") 'ignore))
1277   (gud-display-frame))
1278
1279 (defun gdb-frames-mouse-select (event)
1280   "Make the selected frame become the current frame and display the source in
1281 the source buffer."
1282   (interactive "e")
1283   (mouse-set-point event)
1284   (gdb-frames-select))
1285 \f
1286 ;;
1287 ;; Threads buffer.  This displays a selectable thread list.
1288 ;;
1289 (gdb-set-buffer-rules 'gdb-threads-buffer
1290                       'gdb-threads-buffer-name
1291                       'gdb-threads-mode)
1292
1293 (def-gdb-auto-updated-buffer gdb-threads-buffer
1294   gdb-invalidate-threads
1295   "server info threads\n"
1296   gdb-info-threads-handler
1297   gdb-info-threads-custom)
1298
1299 (defun gdb-info-threads-custom ()
1300   (with-current-buffer (gdb-get-buffer 'gdb-threads-buffer)
1301     (let ((buffer-read-only nil))
1302       (goto-char (point-min))
1303       (while (< (point) (point-max))
1304         (add-text-properties (point-at-bol) (point-at-eol)
1305                              '(mouse-face highlight
1306                                help-echo "mouse-2, RET: select thread"))
1307         (forward-line 1)))))
1308
1309 (defun gdb-threads-buffer-name ()
1310   (with-current-buffer gud-comint-buffer
1311     (concat "*threads of " (gdb-get-target-string) "*")))
1312
1313 (defun gdb-display-threads-buffer ()
1314   (interactive)
1315   (gdb-display-buffer
1316    (gdb-get-create-buffer 'gdb-threads-buffer)))
1317
1318 (defun gdb-frame-threads-buffer ()
1319   (interactive)
1320   (switch-to-buffer-other-frame
1321    (gdb-get-create-buffer 'gdb-threads-buffer)))
1322
1323 (defvar gdb-threads-mode-map
1324   (let ((map (make-sparse-keymap)))
1325     (suppress-keymap map)
1326     (define-key map "\r" 'gdb-threads-select)
1327     (define-key map [mouse-2] 'gdb-threads-mouse-select)
1328     map))
1329
1330 (defun gdb-threads-mode ()
1331   "Major mode for gdb frames.
1332
1333 \\{gdb-frames-mode-map}"
1334   (setq major-mode 'gdb-threads-mode)
1335   (setq mode-name "Threads")
1336   (setq buffer-read-only t)
1337   (use-local-map gdb-threads-mode-map)
1338   (gdb-invalidate-threads))
1339
1340 (defun gdb-get-thread-number ()
1341   (save-excursion
1342     (re-search-backward "^\\s-*\\([0-9]*\\)" nil t)
1343     (match-string-no-properties 1)))
1344
1345 (defun gdb-threads-select ()
1346   "Make the thread on the current line become the current thread and display the
1347 source in the source buffer."
1348   (interactive)
1349   (gdb-enqueue-input
1350    (list (concat "thread " (gdb-get-thread-number) "\n") 'ignore))
1351   (gud-display-frame))
1352
1353 (defun gdb-threads-mouse-select (event)
1354   "Make the selected frame become the current frame and display the source in
1355 the source buffer."
1356   (interactive "e")
1357   (mouse-set-point event)
1358   (gdb-threads-select))
1359 \f
1360 ;;
1361 ;; Registers buffer.
1362 ;;
1363 (gdb-set-buffer-rules 'gdb-registers-buffer
1364                       'gdb-registers-buffer-name
1365                       'gdb-registers-mode)
1366
1367 (def-gdb-auto-updated-buffer gdb-registers-buffer
1368   gdb-invalidate-registers
1369   "server info registers\n"
1370   gdb-info-registers-handler
1371   gdb-info-registers-custom)
1372
1373 (defun gdb-info-registers-custom ())
1374
1375 (defvar gdb-registers-mode-map
1376   (let ((map (make-sparse-keymap)))
1377     (suppress-keymap map)
1378     map))
1379
1380 (defun gdb-registers-mode ()
1381   "Major mode for gdb registers.
1382
1383 \\{gdb-registers-mode-map}"
1384   (setq major-mode 'gdb-registers-mode)
1385   (setq mode-name "Registers")
1386   (setq buffer-read-only t)
1387   (use-local-map gdb-registers-mode-map)
1388   (gdb-invalidate-registers))
1389
1390 (defun gdb-registers-buffer-name ()
1391   (with-current-buffer gud-comint-buffer
1392     (concat "*registers of " (gdb-get-target-string) "*")))
1393
1394 (defun gdb-display-registers-buffer ()
1395   (interactive)
1396   (gdb-display-buffer
1397    (gdb-get-create-buffer 'gdb-registers-buffer)))
1398
1399 (defun gdb-frame-registers-buffer ()
1400   (interactive)
1401   (switch-to-buffer-other-frame
1402    (gdb-get-create-buffer 'gdb-registers-buffer)))
1403 \f
1404 ;;
1405 ;; Locals buffer.
1406 ;;
1407 (gdb-set-buffer-rules 'gdb-locals-buffer
1408                       'gdb-locals-buffer-name
1409                       'gdb-locals-mode)
1410
1411 (def-gdb-auto-updated-buffer gdb-locals-buffer
1412   gdb-invalidate-locals
1413   "server info locals\n"
1414   gdb-info-locals-handler
1415   gdb-info-locals-custom)
1416
1417 ;; Abbreviate for arrays and structures.
1418 ;; These can be expanded using gud-display.
1419 (defun gdb-info-locals-handler nil
1420   (gdb-set-pending-triggers (delq 'gdb-invalidate-locals
1421                                   (gdb-get-pending-triggers)))
1422   (let ((buf (gdb-get-buffer 'gdb-partial-output-buffer)))
1423     (with-current-buffer buf
1424       (goto-char (point-min))
1425       (while (re-search-forward "^ .*\n" nil t)
1426         (replace-match "" nil nil))
1427       (goto-char (point-min))
1428       (while (re-search-forward "{[-0-9, {}\]*\n" nil t)
1429         (replace-match "(array);\n" nil nil))
1430       (goto-char (point-min))
1431       (while (re-search-forward "{.*=.*\n" nil t)
1432         (replace-match "(structure);\n" nil nil))))
1433   (let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
1434     (and buf (with-current-buffer buf
1435                (let ((p (point))
1436                      (buffer-read-only nil))
1437                  (delete-region (point-min) (point-max))
1438                  (insert-buffer-substring (gdb-get-create-buffer
1439                                            'gdb-partial-output-buffer))
1440                  (goto-char p)))))
1441   (run-hooks 'gdb-info-locals-hook))
1442
1443 (defun gdb-info-locals-custom ()
1444   nil)
1445
1446 (defvar gdb-locals-mode-map
1447   (let ((map (make-sparse-keymap)))
1448     (suppress-keymap map)
1449     map))
1450
1451 (defun gdb-locals-mode ()
1452   "Major mode for gdb locals.
1453
1454 \\{gdb-locals-mode-map}"
1455   (setq major-mode 'gdb-locals-mode)
1456   (setq mode-name "Locals")
1457   (setq buffer-read-only t)
1458   (use-local-map gdb-locals-mode-map)
1459   (gdb-invalidate-locals))
1460
1461 (defun gdb-locals-buffer-name ()
1462   (with-current-buffer gud-comint-buffer
1463     (concat "*locals of " (gdb-get-target-string) "*")))
1464
1465 (defun gdb-display-locals-buffer ()
1466   (interactive)
1467   (gdb-display-buffer
1468    (gdb-get-create-buffer 'gdb-locals-buffer)))
1469
1470 (defun gdb-frame-locals-buffer ()
1471   (interactive)
1472   (switch-to-buffer-other-frame
1473    (gdb-get-create-buffer 'gdb-locals-buffer)))
1474 \f
1475
1476 ;;;; Window management
1477
1478 ;;; The way we abuse the dedicated-p flag is pretty gross, but seems
1479 ;;; to do the right thing.  Seeing as there is no way for Lisp code to
1480 ;;; get at the use_time field of a window, I'm not sure there exists a
1481 ;;; more elegant solution without writing C code.
1482
1483 (defun gdb-display-buffer (buf &optional size)
1484   (let ((must-split nil)
1485         (answer nil))
1486     (unwind-protect
1487         (progn
1488           (walk-windows
1489            #'(lambda (win)
1490               (if (or (eq gud-comint-buffer (window-buffer win))
1491                       (eq gdb-source-window win))
1492                   (set-window-dedicated-p win t))))
1493           (setq answer (get-buffer-window buf))
1494           (if (not answer)
1495               (let ((window (get-lru-window)))
1496                 (if window
1497                     (progn
1498                       (set-window-buffer window buf)
1499                       (setq answer window))
1500                   (setq must-split t)))))
1501       (walk-windows
1502        #'(lambda (win)
1503           (if (or (eq gud-comint-buffer (window-buffer win))
1504                   (eq gdb-source-window win))
1505               (set-window-dedicated-p win nil)))))
1506     (if must-split
1507         (let* ((largest (get-largest-window))
1508                (cur-size (window-height largest))
1509                (new-size (and size (< size cur-size) (- cur-size size))))
1510           (setq answer (split-window largest new-size))
1511           (set-window-buffer answer buf)))
1512     answer))
1513
1514 (defun gdb-display-source-buffer (buffer)
1515   (if (eq gdb-selected-view 'source)
1516       (progn
1517         (if (window-live-p gdb-source-window)
1518             (set-window-buffer gdb-source-window buffer)
1519           (gdb-display-buffer buffer)
1520           (setq gdb-source-window (get-buffer-window buffer)))
1521               gdb-source-window)
1522     (if (window-live-p gdb-source-window)
1523         (set-window-buffer gdb-source-window
1524                            (gdb-get-buffer 'gdb-assembler-buffer))
1525       (let ((buf (gdb-get-buffer 'gdb-assembler-buffer)))
1526         (gdb-display-buffer buf)
1527         (setq gdb-source-window (get-buffer-window buf))))
1528     nil))
1529
1530 \f
1531 ;;; Shared keymap initialization:
1532
1533 (let ((menu (make-sparse-keymap "GDB-Frames")))
1534   (define-key gud-menu-map [frames]
1535     `(menu-item "GDB-Frames" ,menu :visible (eq gud-minor-mode 'gdba)))
1536   (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer))
1537   (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer))
1538   (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
1539   (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))
1540   (define-key menu [breakpoints] '("Breakpoints" . gdb-frame-breakpoints-buffer))
1541   (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
1542 ;  (define-key menu [assembler] '("Machine" . gdb-frame-assembler-buffer))
1543 )
1544
1545 (let ((menu (make-sparse-keymap "GDB-Windows")))
1546   (define-key gud-menu-map [displays]
1547     `(menu-item "GDB-Windows" ,menu :visible (eq gud-minor-mode 'gdba)))
1548   (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer))
1549   (define-key menu [locals] '("Locals" . gdb-display-locals-buffer))
1550   (define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
1551   (define-key menu [frames] '("Stack" . gdb-display-stack-buffer))
1552   (define-key menu [breakpoints] '("Breakpoints" . gdb-display-breakpoints-buffer))
1553   (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
1554 ;  (define-key menu [assembler] '("Machine" . gdb-display-assembler-buffer))
1555 )
1556
1557 (let ((menu (make-sparse-keymap "View")))
1558    (define-key gud-menu-map [view]
1559      `(menu-item "View" ,menu :visible (eq gud-minor-mode 'gdba)))
1560 ;  (define-key menu [both] '(menu-item "Both" gdb-view-both
1561 ;              :help "Display both source and assembler"
1562 ;              :button (:radio . (eq gdb-selected-view 'both))))
1563    (define-key menu [assembler] '(menu-item "Machine" gdb-view-assembler
1564                :help "Display assembler only"
1565                :button (:radio . (eq gdb-selected-view 'assembler))))
1566    (define-key menu [source] '(menu-item "Source" gdb-view-source-function
1567                :help "Display source only"
1568                :button (:radio . (eq gdb-selected-view 'source)))))
1569
1570 (let ((menu (make-sparse-keymap "GDB-UI")))
1571   (define-key gud-menu-map [ui]
1572     `(menu-item "GDB-UI" ,menu :visible (eq gud-minor-mode 'gdba)))
1573   (define-key menu [gdb-restore-windows]
1574     '("Restore window layout" . gdb-restore-windows))
1575   (define-key menu [gdb-many-windows]
1576     (menu-bar-make-toggle gdb-many-windows gdb-many-windows
1577                           "Display other windows" "Many Windows %s"
1578                           "Display locals, stack and breakpoint information")))
1579
1580 (defun gdb-frame-gdb-buffer ()
1581   (interactive)
1582   (switch-to-buffer-other-frame
1583    (gdb-get-create-buffer 'gdba)))
1584
1585 (defun gdb-display-gdb-buffer ()
1586   (interactive)
1587   (gdb-display-buffer
1588    (gdb-get-create-buffer 'gdba)))
1589
1590 (defvar gdb-main-file nil "Source file from which program execution begins.")
1591
1592 (defun gdb-view-source-function ()
1593   (interactive)
1594   (if gdb-view-source
1595       (if gud-last-last-frame
1596           (set-window-buffer gdb-source-window
1597                              (gud-find-file (car gud-last-last-frame)))
1598         (set-window-buffer gdb-source-window (gud-find-file gdb-main-file))))
1599   (setq gdb-selected-view 'source))
1600
1601 (defun gdb-view-assembler()
1602   (interactive)
1603   (set-window-buffer gdb-source-window
1604                      (gdb-get-create-buffer 'gdb-assembler-buffer))
1605   (setq gdb-selected-view 'assembler))
1606
1607 ;(defun gdb-view-both()
1608 ;(interactive)
1609 ;(setq gdb-selected-view 'both))
1610
1611 ;; layout for all the windows
1612 (defun gdb-setup-windows ()
1613   (gdb-display-locals-buffer)
1614   (gdb-display-stack-buffer)
1615   (delete-other-windows)
1616   (gdb-display-breakpoints-buffer)
1617   (delete-other-windows)
1618   (switch-to-buffer gud-comint-buffer)
1619   (split-window nil ( / ( * (window-height) 3) 4))
1620   (split-window nil ( / (window-height) 3))
1621   (split-window-horizontally)
1622   (other-window 1)
1623   (switch-to-buffer (gdb-locals-buffer-name))
1624   (other-window 1)
1625   (if (and gdb-view-source
1626            (eq gdb-selected-view 'source))
1627       (switch-to-buffer
1628        (if gud-last-last-frame
1629            (gud-find-file (car gud-last-last-frame))
1630          (gud-find-file gdb-main-file)))
1631     (switch-to-buffer (gdb-get-create-buffer 'gdb-assembler-buffer)))
1632   (setq gdb-source-window (get-buffer-window (current-buffer)))
1633   (split-window-horizontally)
1634   (other-window 1)
1635   (switch-to-buffer (gdb-inferior-io-name))
1636   (other-window 1)
1637   (switch-to-buffer (gdb-stack-buffer-name))
1638   (split-window-horizontally)
1639   (other-window 1)
1640   (switch-to-buffer (gdb-breakpoints-buffer-name))
1641   (other-window 1))
1642
1643 (defcustom gdb-many-windows nil
1644   "Nil means that gdb starts with just two windows : the GUD and
1645 the source buffer."
1646   :type 'boolean
1647   :group 'gud)
1648
1649 (defun gdb-many-windows (arg)
1650 "Toggle the number of windows in the basic arrangement."
1651   (interactive "P")
1652   (setq gdb-many-windows
1653         (if (null arg)
1654             (not gdb-many-windows)
1655           (> (prefix-numeric-value arg) 0)))
1656   (gdb-restore-windows))
1657
1658 (defun gdb-restore-windows ()
1659   "Restore the basic arrangement of windows used by gdba.
1660 This arrangement depends on the value of `gdb-many-windows'."
1661   (interactive)
1662   (if gdb-many-windows
1663       (progn
1664         (switch-to-buffer gud-comint-buffer)
1665         (delete-other-windows)
1666         (gdb-setup-windows))
1667     (switch-to-buffer gud-comint-buffer)
1668     (delete-other-windows)
1669     (split-window)
1670     (other-window 1)
1671     (if (and gdb-view-source
1672            (eq gdb-selected-view 'source))
1673         (switch-to-buffer
1674          (if gud-last-last-frame
1675              (gud-find-file (car gud-last-last-frame))
1676            (gud-find-file gdb-main-file)))
1677       (switch-to-buffer (gdb-get-create-buffer 'gdb-assembler-buffer)))
1678     (setq gdb-source-window (get-buffer-window (current-buffer)))
1679     (other-window 1)))
1680
1681 (defun gdb-reset ()
1682   "Exit a debugging session cleanly by killing the gdb buffers and resetting
1683  the source buffers."
1684   (dolist (buffer (buffer-list))
1685     (if (not (eq buffer gud-comint-buffer))
1686         (with-current-buffer buffer
1687           (if (memq gud-minor-mode '(gdba pdb))
1688               (if (string-match "^\*.+*$" (buffer-name))
1689                   (kill-buffer nil)
1690                 (if (display-images-p)
1691                     (remove-images (point-min) (point-max))
1692                   (gdb-remove-strings (point-min) (point-max)))
1693                 (setq left-margin-width 0)
1694                 (setq gud-minor-mode nil)
1695                 (kill-local-variable 'tool-bar-map)
1696                 (setq gud-running nil)
1697                 (if (get-buffer-window (current-buffer))
1698                     (set-window-margins (get-buffer-window
1699                                          (current-buffer))
1700                                         left-margin-width
1701                                         right-margin-width))))))))
1702
1703 (defun gdb-source-info ()
1704   "Find the source file where the program starts and displays it with related
1705 buffers."
1706   (goto-char (point-min))
1707   (if (search-forward "directory is " nil t)
1708       (if (looking-at "\\S-*:\\(\\S-*\\)")
1709           (setq gdb-cdir (match-string 1))
1710         (looking-at "\\S-*")
1711         (setq gdb-cdir (match-string 0))))
1712   (if (search-forward "Located in " nil t)
1713       (if (looking-at "\\S-*")
1714           (setq gdb-main-file (match-string 0)))
1715     (setq gdb-view-source nil))
1716   (delete-other-windows)
1717   (switch-to-buffer gud-comint-buffer)
1718   (if gdb-many-windows
1719       (gdb-setup-windows)
1720     (gdb-display-breakpoints-buffer)
1721     (delete-other-windows)
1722     (split-window)
1723     (other-window 1)
1724     (if gdb-view-source
1725       (switch-to-buffer
1726        (if gud-last-last-frame
1727            (gud-find-file (car gud-last-last-frame))
1728          (gud-find-file gdb-main-file)))
1729       (switch-to-buffer (gdb-get-create-buffer 'gdb-assembler-buffer)))
1730     (setq gdb-source-window (get-buffer-window (current-buffer)))
1731     (other-window 1)))
1732
1733 ;;from put-image
1734 (defun gdb-put-string (putstring pos)
1735   "Put string PUTSTRING in front of POS in the current buffer.
1736 PUTSTRING is displayed by putting an overlay into the current buffer with a
1737 `before-string' STRING that has a `display' property whose value is
1738 PUTSTRING."
1739   (let ((gdb-string "x")
1740         (buffer (current-buffer)))
1741     (let ((overlay (make-overlay pos pos buffer))
1742           (prop (list (list 'margin 'left-margin) putstring)))
1743       (put-text-property 0 (length gdb-string) 'display prop gdb-string)
1744       (overlay-put overlay 'put-break t)
1745       (overlay-put overlay 'before-string gdb-string))))
1746
1747 ;;from remove-images
1748 (defun gdb-remove-strings (start end &optional buffer)
1749   "Remove strings between START and END in BUFFER.
1750 Remove only strings that were put in BUFFER with calls to `put-string'.
1751 BUFFER nil or omitted means use the current buffer."
1752   (unless buffer
1753     (setq buffer (current-buffer)))
1754   (let ((overlays (overlays-in start end)))
1755     (while overlays
1756       (let ((overlay (car overlays)))
1757         (when (overlay-get overlay 'put-break)
1758           (delete-overlay overlay)))
1759       (setq overlays (cdr overlays)))))
1760
1761 (defun gdb-put-arrow (putstring pos)
1762   "Put arrow string PUTSTRING in the left margin in front of POS
1763 in the current buffer.  PUTSTRING is displayed by putting an
1764 overlay into the current buffer with a `before-string'
1765 \"gdb-arrow\" that has a `display' property whose value is
1766 PUTSTRING. POS may be an integer or marker."
1767   (let ((gdb-string "gdb-arrow")
1768         (buffer (current-buffer)))
1769     (let ((overlay (make-overlay pos pos buffer))
1770           (prop (list (list 'margin 'left-margin) putstring)))
1771       (put-text-property 0 (length gdb-string) 'display prop gdb-string)
1772       (overlay-put overlay 'put-arrow t)
1773       (overlay-put overlay 'before-string gdb-string))))
1774
1775 (defun gdb-remove-arrow (&optional buffer)
1776   "Remove arrow in BUFFER.
1777 Remove only images that were put in BUFFER with calls to `put-arrow'.
1778 BUFFER nil or omitted means use the current buffer."
1779   (unless buffer
1780     (setq buffer (current-buffer)))
1781   (let ((overlays (overlays-in (point-min) (point-max))))
1782     (while overlays
1783       (let ((overlay (car overlays)))
1784         (when (overlay-get overlay 'put-arrow)
1785           (delete-overlay overlay)))
1786       (setq overlays (cdr overlays)))))
1787 \f
1788 ;;
1789 ;; Assembler buffer.
1790 ;;
1791 (gdb-set-buffer-rules 'gdb-assembler-buffer
1792                       'gdb-assembler-buffer-name
1793                       'gdb-assembler-mode)
1794
1795 (def-gdb-auto-updated-buffer gdb-assembler-buffer
1796   gdb-invalidate-assembler
1797   (concat "server disassemble " gdb-current-address "\n")
1798   gdb-assembler-handler
1799   gdb-assembler-custom)
1800
1801 (defun gdb-assembler-custom ()
1802   (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer))
1803         (gdb-arrow-position 1) (address) (flag))
1804     (with-current-buffer buffer
1805       (if (not (equal gdb-current-address "main"))
1806           (progn
1807             (gdb-remove-arrow)
1808             (goto-char (point-min))
1809             (if (re-search-forward gdb-current-address nil t)
1810                 (progn
1811                   (setq gdb-arrow-position (point))
1812                   (gdb-put-arrow "=>" (point))))))
1813       ;; remove all breakpoint-icons in assembler buffer before updating.
1814       (if (display-images-p)
1815           (remove-images (point-min) (point-max))
1816         (gdb-remove-strings (point-min) (point-max))))
1817     (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
1818       (goto-char (point-min))
1819       (while (< (point) (- (point-max) 1))
1820         (forward-line 1)
1821         (if (looking-at "[^\t].*breakpoint")
1822             (progn
1823               (looking-at
1824                "[0-9]*\\s-*\\S-*\\s-*\\S-*\\s-*\\(.\\)\\s-*0x\\(\\S-*\\)")
1825               (setq flag (char-after (match-beginning 1)))
1826               (setq address (match-string 2))
1827               ;; remove leading 0s from output of info break.
1828               (if (string-match "^0+\\(.*\\)" address)
1829                   (setq address (match-string 1 address)))
1830               (with-current-buffer buffer
1831                   (goto-char (point-min))
1832                   (if (re-search-forward address nil t)
1833                       (let ((start (progn (beginning-of-line) (- (point) 1)))
1834                             (end (progn (end-of-line) (+ (point) 1))))
1835                         (if (display-images-p)
1836                             (progn
1837                               (remove-images start end)
1838                               (if (eq ?y flag)
1839                                   (put-image breakpoint-enabled-icon
1840                                              (+ start 1)
1841                                              "breakpoint icon enabled"
1842                                              'left-margin)
1843                                 (put-image breakpoint-disabled-icon
1844                                            (+ start 1)
1845                                            "breakpoint icon disabled"
1846                                            'left-margin)))
1847                           (gdb-remove-strings start end)
1848                           (if (eq ?y flag)
1849                               (gdb-put-string "B" (+ start 1))
1850                             (gdb-put-string "b" (+ start 1)))))))))))
1851     (if (not (equal gdb-current-address "main"))
1852         (set-window-point (get-buffer-window buffer) gdb-arrow-position))))
1853
1854 (defvar gdb-assembler-mode-map
1855   (let ((map (make-sparse-keymap)))
1856     (suppress-keymap map)
1857     map))
1858
1859 (defun gdb-assembler-mode ()
1860   "Major mode for viewing code assembler.
1861
1862 \\{gdb-assembler-mode-map}"
1863   (setq major-mode 'gdb-assembler-mode)
1864   (setq mode-name "Machine")
1865   (setq left-margin-width 2)
1866   (setq fringes-outside-margins t)
1867   (setq buffer-read-only t)
1868   (use-local-map gdb-assembler-mode-map)
1869   (gdb-invalidate-assembler))
1870
1871 (defun gdb-assembler-buffer-name ()
1872   (with-current-buffer gud-comint-buffer
1873     (concat "*Machine Code " (gdb-get-target-string) "*")))
1874
1875 (defun gdb-display-assembler-buffer ()
1876   (interactive)
1877   (gdb-display-buffer
1878    (gdb-get-create-buffer 'gdb-assembler-buffer)))
1879
1880 (defun gdb-frame-assembler-buffer ()
1881   (interactive)
1882   (switch-to-buffer-other-frame
1883    (gdb-get-create-buffer 'gdb-assembler-buffer)))
1884
1885 ;; modified because if gdb-current-address has changed value a new command
1886 ;; must be enqueued to update the buffer with the new output
1887 (defun gdb-invalidate-assembler (&optional ignored)
1888   (if (gdb-get-buffer 'gdb-assembler-buffer)
1889       (progn
1890         (unless (string-equal gdb-current-frame gdb-previous-frame)
1891           (if (or (not (member 'gdb-invalidate-assembler
1892                                (gdb-get-pending-triggers)))
1893                   (not (string-equal gdb-current-address
1894                                      gdb-previous-address)))
1895           (progn
1896             ;; take previous disassemble command off the queue
1897             (with-current-buffer gud-comint-buffer
1898               (let ((queue (gdb-get-input-queue)) (item))
1899                 (dolist (item queue)
1900                   (if (equal (cdr item) '(gdb-assembler-handler))
1901                       (gdb-set-input-queue
1902                        (delete item (gdb-get-input-queue)))))))
1903             (gdb-enqueue-input
1904              (list (concat "server disassemble " gdb-current-address "\n")
1905                    'gdb-assembler-handler))
1906             (gdb-set-pending-triggers
1907              (cons 'gdb-invalidate-assembler
1908                    (gdb-get-pending-triggers)))
1909             (setq gdb-previous-address gdb-current-address)
1910             (setq gdb-previous-frame gdb-current-frame)))))))
1911
1912 (defun gdb-get-current-frame ()
1913   (if (not (member 'gdb-get-current-frame (gdb-get-pending-triggers)))
1914       (progn
1915         (gdb-enqueue-input
1916          (list (concat "server info frame\n") 'gdb-frame-handler))
1917         (gdb-set-pending-triggers
1918          (cons 'gdb-get-current-frame
1919                (gdb-get-pending-triggers))))))
1920
1921 (defun gdb-frame-handler ()
1922   (gdb-set-pending-triggers
1923    (delq 'gdb-get-current-frame (gdb-get-pending-triggers)))
1924   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
1925     (goto-char (point-min))
1926     (forward-line)
1927     (if (looking-at ".*=\\s-+0x\\(\\S-*\\)\\s-+in\\s-+\\(\\S-*\\)")
1928         (progn
1929           (setq gdb-current-frame (match-string 2))
1930           (let ((address (match-string 1)))
1931             ;; remove leading 0s from output of info frame command.
1932             (if (string-match "^0+\\(.*\\)" address)
1933                 (setq gdb-current-address
1934                       (concat "0x" (match-string 1 address)))
1935               (setq gdb-current-address (concat "0x" address))))
1936           (if (or (if (not (re-search-forward "(\\S-*:[0-9]*);" nil t))
1937                       (progn (setq gdb-view-source nil) t))
1938                   (eq gdb-selected-view 'assembler))
1939               (progn
1940                 (set-window-buffer
1941                  gdb-source-window
1942                  (gdb-get-create-buffer 'gdb-assembler-buffer))
1943                 ;;update with new frame for machine code if necessary
1944                 (gdb-invalidate-assembler))))))
1945     (if (re-search-forward " source language \\(\\S-*\\)\." nil t)
1946         (setq gdb-current-language (match-string 1))))
1947
1948 (provide 'gdb-ui)
1949
1950 ;;; arch-tag: e9fb00c5-74ef-469f-a088-37384caae352
1951 ;;; gdb-ui.el ends here