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  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 is based on 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.
  43 ;;
  44 ;; Known Bugs:
  45 ;; Does not auto-display arrays of structures or structures containing arrays.
  46 ;; On MS Windows, Gdb 5.1.1 from MinGW 2.0 does not flush the output from the
  47 ;; inferior.
  48
  49 ;;; Code:
  50
  51 (require 'gud)
  52
  53 (defcustom gdb-window-height 20
  54   "Number of lines in a frame for a displayed expression in GDB-UI."
  55   :type 'integer
  56   :group 'gud)
  57
  58 (defcustom gdb-window-width 30
  59   "Width of a frame for a displayed expression in GDB-UI."
  60   :type 'integer
  61   :group 'gud)
  62
  63 (defvar gdb-current-address "main" "Initialisation for Assembler buffer.")
  64 (defvar gdb-previous-address nil)
  65 (defvar gdb-previous-frame nil)
  66 (defvar gdb-current-frame "main")
  67 (defvar gdb-display-in-progress nil)
  68 (defvar gdb-dive nil)
  69 (defvar gdb-view-source t "Non-nil means that source code can be viewed")
  70 (defvar gdb-selected-view 'source "Code type that user wishes to view")
  71 (defvar gdb-buffer-type nil)
  72 (defvar gdb-variables '()
  73   "A list of variables that are local to the GUD buffer.")
  74
  75
  76 ;;;###autoload
  77 (defun gdba (command-line)
  78   "Run gdb on program FILE in buffer *gud-FILE*.
  79 The directory containing FILE becomes the initial working directory
  80 and source-file directory for your debugger.
  81
  82 If `gdb-many-windows' is nil (the default value) then gdb starts with
  83 just two windows : the GUD and the source buffer. If it is t the
  84 following layout will appear (keybindings given in relevant buffer) :
  85
  86 ---------------------------------------------------------------------
  87                                GDB Toolbar
  88 ---------------------------------------------------------------------
  89 GUD buffer (I/O of GDB)           | Locals buffer
  90                                   |
  91                                   |
  92                                   |
  93 ---------------------------------------------------------------------
  94 Source buffer                     | Input/Output (of debuggee) buffer
  95                                   | (comint-mode)
  96                                   |
  97                                   |
  98                                   |
  99                                   |
 100                                   |
 101                                   |
 102 ---------------------------------------------------------------------
 103 Stack buffer                      | Breakpoints buffer
 104  RET      gdb-frames-select       | SPC    gdb-toggle-breakpoint
 105                                   | RET    gdb-goto-breakpoint
 106                                   |   d    gdb-delete-breakpoint
 107 ---------------------------------------------------------------------
 108
 109 All the buffers share the toolbar and source should always display in the same
 110 window e.g after typing g on a breakpoint in the breakpoints buffer. Breakpoint
 111 icons are displayed both by setting a break with gud-break and by typing break
 112 in the GUD buffer.
 113
 114 This works best (depending on the size of your monitor) using most of the
 115 screen.
 116
 117 Displayed expressions appear in separate frames. Arrays may be displayed
 118 as slices and visualised using the graph program from plotutils if installed.
 119 Pointers in structures may be followed in a tree-like fashion.
 120
 121 The following interactive lisp functions help control operation :
 122
 123 `gdb-many-windows'    - Toggle the number of windows gdb uses.
 124 `gdb-restore-windows' - To restore the window layout.
 125 `gdb-quit'            - To delete (most) of the buffers used by GDB-UI and
 126                         reset variables."
 127   ;;
 128   (interactive (list (gud-query-cmdline 'gdba)))
 129   ;;
 130   ;; Let's start with a basic gud-gdb buffer and then modify it a bit.
 131   (gdb command-line)
 132   ;;
 133   (set (make-local-variable 'gud-minor-mode) 'gdba)
 134   (set (make-local-variable 'gud-marker-filter) 'gud-gdba-marker-filter)
 135   ;;
 136   (gud-def gud-break (if (not (string-equal mode-name "Assembler"))
 137                          (gud-call "break %f:%l" arg)
 138                        (save-excursion
 139                          (beginning-of-line)
 140                          (forward-char 2)
 141                          (gud-call "break *%a" arg)))
 142            "\C-b" "Set breakpoint at current line or address.")
 143   ;;
 144   (gud-def gud-remove (if (not (string-equal mode-name "Assembler"))
 145                           (gud-call "clear %f:%l" arg)
 146                         (save-excursion
 147                           (beginning-of-line)
 148                           (forward-char 2)
 149                           (gud-call "clear *%a" arg)))
 150            "\C-d" "Remove breakpoint at current line or address.")
 151   ;;
 152   (gud-def gud-until  (if (not (string-equal mode-name "Assembler"))
 153                           (gud-call "until %f:%l" arg)
 154                         (save-excursion
 155                           (beginning-of-line)
 156                           (forward-char 2)
 157                           (gud-call "until *%a" arg)))
 158            "\C-u" "Continue to current line or address.")
 159
 160   (setq comint-input-sender 'gdb-send)
 161   ;;
 162   ;; (re-)initialise
 163   (setq gdb-current-address "main")
 164   (setq gdb-previous-address nil)
 165   (setq gdb-previous-frame nil)
 166   (setq gdb-current-frame "main")
 167   (setq gdb-display-in-progress nil)
 168   (setq gdb-dive nil)
 169   (setq gdb-view-source t)
 170   (setq gdb-selected-view 'source)
 171   ;;
 172   (mapc 'make-local-variable gdb-variables)
 173   (setq gdb-buffer-type 'gdba)
 174   ;;
 175   (gdb-clear-inferior-io)
 176   ;;
 177   (if (eq window-system 'w32)
 178       (gdb-enqueue-input (list "set new-console off\n" 'ignore)))
 179   (gdb-enqueue-input (list "set height 0\n" 'ignore))
 180   ;; find source file and compilation directory here
 181   (gdb-enqueue-input (list "server list main\n"   'ignore))   ; C program
 182   (gdb-enqueue-input (list "server list MAIN__\n" 'ignore))   ; Fortran program
 183   (gdb-enqueue-input (list "server info source\n" 'gdb-source-info))
 184   ;;
 185   (run-hooks 'gdba-mode-hook))
 186
 187 (defun gud-display ()
 188   "Auto-display (possibly dereferenced) C expression at point."
 189   (interactive)
 190   (save-excursion
 191     (let ((expr (gud-find-c-expr)))
 192       (gdb-enqueue-input
 193        (list (concat "server ptype " expr "\n")
 194              `(lambda () (gud-display1 ,expr)))))))
 195
 196 (defun gud-display1 (expr)
 197   (goto-char (point-min))
 198   (if (looking-at "No symbol")
 199       (progn
 200         (gdb-set-output-sink 'user)
 201         (gud-call (concat "server ptype " expr)))
 202     (goto-char (- (point-max) 1))
 203     (if (equal (char-before) (string-to-char "\*"))
 204         (gdb-enqueue-input
 205          (list (concat "display* " expr "\n") 'ignore))
 206       (gdb-enqueue-input
 207        (list (concat "display " expr "\n") 'ignore)))))
 208
 209 ; this would messy because these bindings don't work with M-x gdb
 210 ; (define-key global-map "\C-x\C-a\C-a" 'gud-display)
 211 ; (define-key gud-minor-mode-map "\C-c\C-a" 'gud-display)
 212
 213
 214 \f
 215 ;; ======================================================================
 216 ;;
 217 ;; In this world, there are gdb variables (of unspecified
 218 ;; representation) and buffers associated with those objects.
 219 ;; The list of  variables is built up by the expansions of
 220 ;; def-gdb-variable
 221
 222 (defmacro def-gdb-var (root-symbol &optional default doc)
 223   (let* ((root (symbol-name root-symbol))
 224          (accessor (intern (concat "gdb-get-" root)))
 225          (setter (intern (concat "gdb-set-" root)))
 226          (name (intern (concat "gdb-" root))))
 227     `(progn
 228        (defvar ,name ,default ,doc)
 229        (if (not (memq ',name gdb-variables))
 230            (push ',name gdb-variables))
 231        (defun ,accessor ()
 232          (buffer-local-value ',name gud-comint-buffer))
 233        (defun ,setter (val)
 234          (with-current-buffer gud-comint-buffer
 235            (setq ,name val))))))
 236
 237 (def-gdb-var buffer-type nil
 238   "One of the symbols bound in gdb-buffer-rules")
 239
 240 (def-gdb-var burst ""
 241   "A string of characters from gdb that have not yet been processed.")
 242
 243 (def-gdb-var input-queue ()
 244   "A list of high priority gdb command objects.")
 245
 246 (def-gdb-var idle-input-queue ()
 247   "A list of low priority gdb command objects.")
 248
 249 (def-gdb-var prompting nil
 250   "True when gdb is idle with no pending input.")
 251
 252 (def-gdb-var output-sink 'user
 253   "The disposition of the output of the current gdb command.
 254 Possible values are these symbols:
 255
 256     user -- gdb output should be copied to the GUD buffer
 257             for the user to see.
 258
 259     inferior -- gdb output should be copied to the inferior-io buffer
 260
 261     pre-emacs -- output should be ignored util the post-prompt
 262                  annotation is received.  Then the output-sink
 263                  becomes:...
 264     emacs -- output should be collected in the partial-output-buffer
 265              for subsequent processing by a command.  This is the
 266              disposition of output generated by commands that
 267              gdb mode sends to gdb on its own behalf.
 268     post-emacs -- ignore input until the prompt annotation is
 269                   received, then go to USER disposition.
 270 ")
 271
 272 (def-gdb-var current-item nil
 273   "The most recent command item sent to gdb.")
 274
 275 (def-gdb-var pending-triggers '()
 276   "A list of trigger functions that have run later than their output
 277 handlers.")
 278
 279 ;; end of gdb variables
 280
 281 (defun gdb-get-target-string ()
 282   (with-current-buffer gud-comint-buffer
 283     gud-target-name))
 284 \f
 285
 286 ;;
 287 ;; gdb buffers.
 288 ;;
 289 ;; Each buffer has a TYPE -- a symbol that identifies the function
 290 ;; of that particular buffer.
 291 ;;
 292 ;; The usual gdb interaction buffer is given the type `gdba' and
 293 ;; is constructed specially.
 294 ;;
 295 ;; Others are constructed by gdb-get-create-buffer and
 296 ;; named according to the rules set forth in the gdb-buffer-rules-assoc
 297
 298 (defvar gdb-buffer-rules-assoc '())
 299
 300 (defun gdb-get-buffer (key)
 301   "Return the gdb buffer tagged with type KEY.
 302 The key should be one of the cars in `gdb-buffer-rules-assoc'."
 303   (save-excursion
 304     (gdb-look-for-tagged-buffer key (buffer-list))))
 305
 306 (defun gdb-get-create-buffer (key)
 307   "Create a new gdb  buffer of the type specified by KEY.
 308 The key should be one of the cars in `gdb-buffer-rules-assoc'."
 309   (or (gdb-get-buffer key)
 310       (let* ((rules (assoc key gdb-buffer-rules-assoc))
 311              (name (funcall (gdb-rules-name-maker rules)))
 312              (new (get-buffer-create name)))
 313         (with-current-buffer new
 314           ;; FIXME: This should be set after calling the function, since the
 315           ;; function should run kill-all-local-variables.
 316           (set (make-local-variable 'gdb-buffer-type) key)
 317           (if (cdr (cdr rules))
 318               (funcall (car (cdr (cdr rules)))))
 319           (set (make-local-variable 'gud-comint-buffer) gud-comint-buffer)
 320           (set (make-local-variable 'gud-minor-mode) 'gdba)
 321           (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
 322           new))))
 323
 324 (defun gdb-rules-name-maker (rules) (car (cdr rules)))
 325
 326 (defun gdb-look-for-tagged-buffer (key bufs)
 327   (let ((retval nil))
 328     (while (and (not retval) bufs)
 329       (set-buffer (car bufs))
 330       (if (eq gdb-buffer-type key)
 331           (setq retval (car bufs)))
 332       (setq bufs (cdr bufs)))
 333     retval))
 334
 335 ;;
 336 ;; This assoc maps buffer type symbols to rules.  Each rule is a list of
 337 ;; at least one and possible more functions.  The functions have these
 338 ;; roles in defining a buffer type:
 339 ;;
 340 ;;     NAME - Return a name for this  buffer type.
 341 ;;
 342 ;; The remaining function(s) are optional:
 343 ;;
 344 ;;     MODE - called in a new buffer with no arguments, should establish
 345 ;;            the proper mode for the buffer.
 346 ;;
 347
 348 (defun gdb-set-buffer-rules (buffer-type &rest rules)
 349   (let ((binding (assoc buffer-type gdb-buffer-rules-assoc)))
 350     (if binding
 351         (setcdr binding rules)
 352       (push (cons buffer-type rules)
 353             gdb-buffer-rules-assoc))))
 354
 355 ;; GUD buffers are an exception to the rules
 356 (gdb-set-buffer-rules 'gdba 'error)
 357
 358 ;;
 359 ;; Partial-output buffer : This accumulates output from a command executed on
 360 ;; behalf of emacs (rather than the user).
 361 ;;
 362 (gdb-set-buffer-rules 'gdb-partial-output-buffer
 363                       'gdb-partial-output-name)
 364
 365 (defun gdb-partial-output-name ()
 366   (concat "*partial-output-"
 367           (gdb-get-target-string)
 368           "*"))
 369
 370 \f
 371 (gdb-set-buffer-rules 'gdb-inferior-io
 372                       'gdb-inferior-io-name
 373                       'gdb-inferior-io-mode)
 374
 375 (defun gdb-inferior-io-name ()
 376   (concat "*input/output of "
 377           (gdb-get-target-string)
 378           "*"))
 379
 380 (defvar gdb-inferior-io-mode-map
 381   (let ((map (make-sparse-keymap)))
 382     (define-key map "\C-c\C-c" 'gdb-inferior-io-interrupt)
 383     (define-key map "\C-c\C-z" 'gdb-inferior-io-stop)
 384     (define-key map "\C-c\C-\\" 'gdb-inferior-io-quit)
 385     (define-key map "\C-c\C-d" 'gdb-inferior-io-eof)
 386     map))
 387
 388 (define-derived-mode gdb-inferior-io-mode comint-mode "Debuggee I/O"
 389   "Major mode for gdb inferior-io."
 390   :syntax-table nil :abbrev-table nil
 391   ;; We want to use comint because it has various nifty and familiar
 392   ;; features.  We don't need a process, but comint wants one, so create
 393   ;; a dummy one.
 394   (make-comint-in-buffer
 395    (substring (buffer-name) 1 (- (length (buffer-name)) 1))
 396    (current-buffer) "hexl")
 397   (setq comint-input-sender 'gdb-inferior-io-sender))
 398
 399 (defun gdb-inferior-io-sender (proc string)
 400   ;; PROC is the pseudo-process created to satisfy comint.
 401   (with-current-buffer (process-buffer proc)
 402     (setq proc (get-buffer-process gud-comint-buffer))
 403     (process-send-string proc string)
 404     (process-send-string proc "\n")))
 405
 406 (defun gdb-inferior-io-interrupt ()
 407   "Interrupt the program being debugged."
 408   (interactive)
 409   (interrupt-process
 410    (get-buffer-process gud-comint-buffer) comint-ptyp))
 411
 412 (defun gdb-inferior-io-quit ()
 413   "Send quit signal to the program being debugged."
 414   (interactive)
 415   (quit-process
 416    (get-buffer-process gud-comint-buffer) comint-ptyp))
 417
 418 (defun gdb-inferior-io-stop ()
 419   "Stop the program being debugged."
 420   (interactive)
 421   (stop-process
 422    (get-buffer-process gud-comint-buffer) comint-ptyp))
 423
 424 (defun gdb-inferior-io-eof ()
 425   "Send end-of-file to the program being debugged."
 426   (interactive)
 427   (process-send-eof
 428    (get-buffer-process gud-comint-buffer)))
 429 \f
 430
 431 ;;
 432 ;; gdb communications
 433 ;;
 434
 435 ;; INPUT: things sent to gdb
 436 ;;
 437 ;; There is a high and low priority input queue.  Low priority input is sent
 438 ;; only when the high priority queue is idle.
 439 ;;
 440 ;; The queues are lists.  Each element is either a string (indicating user or
 441 ;; user-like input) or a list of the form:
 442 ;;
 443 ;;    (INPUT-STRING  HANDLER-FN)
 444 ;;
 445 ;; The handler function will be called from the partial-output buffer when the
 446 ;; command completes.  This is the way to write commands which invoke gdb
 447 ;; commands autonomously.
 448 ;;
 449 ;; These lists are consumed tail first.
 450 ;;
 451
 452 (defun gdb-send (proc string)
 453   "A comint send filter for gdb.
 454 This filter may simply queue output for a later time."
 455   (gdb-enqueue-input (concat string "\n")))
 456
 457 ;; Note: Stuff enqueued here will be sent to the next prompt, even if it
 458 ;; is a query, or other non-top-level prompt.  To guarantee stuff will get
 459 ;; sent to the top-level prompt, currently it must be put in the idle queue.
 460 ;;                               ^^^^^^^^^
 461 ;; [This should encourage gdb extensions that invoke gdb commands to let
 462 ;;  the user go first; it is not a bug.     -t]
 463 ;;
 464
 465 (defun gdb-enqueue-input (item)
 466   (if (gdb-get-prompting)
 467       (progn
 468         (gdb-send-item item)
 469         (gdb-set-prompting nil))
 470     (gdb-set-input-queue
 471      (cons item (gdb-get-input-queue)))))
 472
 473 (defun gdb-dequeue-input ()
 474   (let ((queue (gdb-get-input-queue)))
 475     (and queue
 476          (if (not (cdr queue))
 477              (let ((answer (car queue)))
 478                (gdb-set-input-queue '())
 479                answer)
 480            (gdb-take-last-elt queue)))))
 481
 482 (defun gdb-enqueue-idle-input (item)
 483   (if (and (gdb-get-prompting)
 484            (not (gdb-get-input-queue)))
 485       (progn
 486         (gdb-send-item item)
 487         (gdb-set-prompting nil))
 488     (gdb-set-idle-input-queue
 489      (cons item (gdb-get-idle-input-queue)))))
 490
 491 (defun gdb-dequeue-idle-input ()
 492   (let ((queue (gdb-get-idle-input-queue)))
 493     (and queue
 494          (if (not (cdr queue))
 495              (let ((answer (car queue)))
 496                (gdb-set-idle-input-queue '())
 497                answer)
 498            (gdb-take-last-elt queue)))))
 499
 500 ;; Don't use this in general.
 501 (defun gdb-take-last-elt (l)
 502   (if (cdr (cdr l))
 503       (gdb-take-last-elt (cdr l))
 504     (let ((answer (car (cdr l))))
 505       (setcdr l '())
 506       answer)))
 507
 508 \f
 509 ;;
 510 ;; output -- things gdb prints to emacs
 511 ;;
 512 ;; GDB output is a stream interrupted by annotations.
 513 ;; Annotations can be recognized by their beginning
 514 ;; with \C-j\C-z\C-z<tag><opt>\C-j
 515 ;;
 516 ;; The tag is a string obeying symbol syntax.
 517 ;;
 518 ;; The optional part `<opt>' can be either the empty string
 519 ;; or a space followed by more data relating to the annotation.
 520 ;; For example, the SOURCE annotation is followed by a filename,
 521 ;; line number and various useless goo.  This data must not include
 522 ;; any newlines.
 523 ;;
 524
 525 (defcustom gud-gdba-command-name "gdb -annotate=2 -noasync"
 526   "Default command to execute an executable under the GDB-UI debugger."
 527   :type 'string
 528   :group 'gud)
 529
 530 (defvar gdb-annotation-rules
 531   '(("pre-prompt" gdb-pre-prompt)
 532     ("prompt" gdb-prompt)
 533     ("commands" gdb-subprompt)
 534     ("overload-choice" gdb-subprompt)
 535     ("query" gdb-subprompt)
 536     ("prompt-for-continue" gdb-subprompt)
 537     ("post-prompt" gdb-post-prompt)
 538     ("source" gdb-source)
 539     ("starting" gdb-starting)
 540     ("exited" gdb-stopping)
 541     ("signalled" gdb-stopping)
 542     ("signal" gdb-stopping)
 543     ("breakpoint" gdb-stopping)
 544     ("watchpoint" gdb-stopping)
 545     ("frame-begin" gdb-frame-begin)
 546     ("stopped" gdb-stopped)
 547     ("display-begin" gdb-display-begin)
 548     ("display-end" gdb-display-end)
 549 ; GDB commands info stack, info locals and frame generate an error-begin
 550 ; annotation at start when there is no stack but this is a quirk/bug in
 551 ; annotations.
 552 ;    ("error-begin" gdb-error-begin)
 553     ("display-number-end" gdb-display-number-end)
 554     ("array-section-begin" gdb-array-section-begin)
 555     ("array-section-end" gdb-array-section-end)
 556     ;; ("elt" gdb-elt)
 557     ("field-begin" gdb-field-begin)
 558     ("field-end" gdb-field-end)
 559     ) "An assoc mapping annotation tags to functions which process them.")
 560
 561 (defconst gdb-source-spec-regexp
 562   "\\(.*\\):\\([0-9]*\\):[0-9]*:[a-z]*:\\(0x[a-f0-9]*\\)")
 563
 564 ;; Do not use this except as an annotation handler.
 565 (defun gdb-source (args)
 566   (string-match gdb-source-spec-regexp args)
 567   ;; Extract the frame position from the marker.
 568   (setq gud-last-frame
 569         (cons
 570          (match-string 1 args)
 571          (string-to-int (match-string 2 args))))
 572   (setq gdb-current-address (match-string 3 args))
 573   (setq gdb-view-source t)
 574   ;;update with new frame for machine code if necessary
 575   (gdb-invalidate-assembler))
 576
 577 (defun gdb-send-item (item)
 578   (gdb-set-current-item item)
 579   (if (stringp item)
 580       (progn
 581         (gdb-set-output-sink 'user)
 582         (process-send-string (get-buffer-process gud-comint-buffer) item))
 583     (progn
 584       (gdb-clear-partial-output)
 585       (gdb-set-output-sink 'pre-emacs)
 586       (process-send-string (get-buffer-process gud-comint-buffer)
 587                            (car item)))))
 588
 589 (defun gdb-pre-prompt (ignored)
 590   "An annotation handler for `pre-prompt'. This terminates the collection of
 591 output from a previous command if that happens to be in effect."
 592   (let ((sink (gdb-get-output-sink)))
 593     (cond
 594      ((eq sink 'user) t)
 595      ((eq sink 'emacs)
 596       (gdb-set-output-sink 'post-emacs)
 597       (let ((handler
 598              (car (cdr (gdb-get-current-item)))))
 599         (save-excursion
 600           (set-buffer (gdb-get-create-buffer
 601                        'gdb-partial-output-buffer))
 602           (funcall handler))))
 603      (t
 604       (gdb-set-output-sink 'user)
 605       (error "Phase error in gdb-pre-prompt (got %s)" sink)))))
 606
 607 (defun gdb-prompt (ignored)
 608   "An annotation handler for `prompt'.
 609 This sends the next command (if any) to gdb."
 610   (let ((sink (gdb-get-output-sink)))
 611     (cond
 612      ((eq sink 'user) t)
 613      ((eq sink 'post-emacs)
 614       (gdb-set-output-sink 'user))
 615      (t
 616       (gdb-set-output-sink 'user)
 617       (error "Phase error in gdb-prompt (got %s)" sink))))
 618   (let ((highest (gdb-dequeue-input)))
 619     (if highest
 620         (gdb-send-item highest)
 621       (let ((lowest (gdb-dequeue-idle-input)))
 622         (if lowest
 623             (gdb-send-item lowest)
 624           (progn
 625             (gdb-set-prompting t)
 626             (gud-display-frame)))))))
 627
 628 (defun gdb-subprompt (ignored)
 629   "An annotation handler for non-top-level prompts."
 630   (let ((highest (gdb-dequeue-input)))
 631     (if highest
 632         (gdb-send-item highest)
 633       (gdb-set-prompting t))))
 634
 635 (defun gdb-starting (ignored)
 636   "An annotation handler for `starting'.  This says that I/O for the
 637 subprocess is now the program being debugged, not GDB."
 638   (let ((sink (gdb-get-output-sink)))
 639     (cond
 640      ((eq sink 'user)
 641       (progn
 642         (setq gud-running t)
 643         (gdb-set-output-sink 'inferior)))
 644      (t (error "Unexpected `starting' annotation")))))
 645
 646 (defun gdb-stopping (ignored)
 647   "An annotation handler for `exited' and other annotations which say that I/O
 648 for the subprocess is now GDB, not the program being debugged."
 649   (let ((sink (gdb-get-output-sink)))
 650     (cond
 651      ((eq sink 'inferior)
 652       (gdb-set-output-sink 'user))
 653      (t (error "Unexpected stopping annotation")))))
 654
 655 (defun gdb-frame-begin (ignored)
 656   (let ((sink (gdb-get-output-sink)))
 657     (cond
 658      ((eq sink 'inferior)
 659       (gdb-set-output-sink 'user))
 660      ((eq sink 'user) t)
 661      ((eq sink 'emacs) t)
 662      (t (error "Unexpected frame-begin annotation (%S)" sink)))))
 663
 664 (defun gdb-stopped (ignored)
 665   "An annotation handler for `stopped'.  It is just like gdb-stopping, except
 666 that if we already set the output sink to 'user in gdb-stopping, that is fine."
 667   (setq gud-running nil)
 668   (let ((sink (gdb-get-output-sink)))
 669     (cond
 670      ((eq sink 'inferior)
 671       (gdb-set-output-sink 'user))
 672      ((eq sink 'user) t)
 673      (t (error "Unexpected stopped annotation")))))
 674
 675 (defun gdb-post-prompt (ignored)
 676   "An annotation handler for `post-prompt'. This begins the collection of
 677 output from the current command if that happens to be appropriate."
 678   (if (not (gdb-get-pending-triggers))
 679       (progn
 680         (gdb-get-current-frame)
 681         (gdb-invalidate-frames)
 682         (gdb-invalidate-breakpoints)
 683         (gdb-invalidate-assembler)
 684         (gdb-invalidate-registers)
 685         (gdb-invalidate-locals)
 686         (gdb-invalidate-display)
 687         (gdb-invalidate-threads)))
 688   (let ((sink (gdb-get-output-sink)))
 689     (cond
 690      ((eq sink 'user) t)
 691      ((eq sink 'pre-emacs)
 692       (gdb-set-output-sink 'emacs))
 693      (t
 694       (gdb-set-output-sink 'user)
 695       (error "Phase error in gdb-post-prompt (got %s)" sink)))))
 696
 697 ;; If we get an error whilst evaluating one of the expressions
 698 ;; we won't get the display-end annotation. Set the sink back to
 699 ;; user to make sure that the error message is seen.
 700 ;; NOT USED: see annotation-rules for reason.
 701 ;(defun gdb-error-begin (ignored)
 702 ;  (gdb-set-output-sink 'user))
 703
 704 (defun gdb-display-begin (ignored)
 705   (gdb-set-output-sink 'emacs)
 706   (gdb-clear-partial-output)
 707   (setq gdb-display-in-progress t))
 708
 709 (defvar gdb-expression-buffer-name nil)
 710 (defvar gdb-display-number nil)
 711 (defvar gdb-dive-display-number nil)
 712
 713 (defun gdb-display-number-end (ignored)
 714   (set-buffer (gdb-get-buffer 'gdb-partial-output-buffer))
 715   (setq gdb-display-number (buffer-string))
 716   (setq gdb-expression-buffer-name
 717         (concat "*display " gdb-display-number "*"))
 718   (save-excursion
 719     (if (progn
 720           (set-buffer (window-buffer))
 721           gdb-dive)
 722         (progn
 723           (let ((number gdb-display-number))
 724             (switch-to-buffer
 725              (set-buffer (get-buffer-create gdb-expression-buffer-name)))
 726             (gdb-expressions-mode)
 727             (setq gdb-dive-display-number number)))
 728       (set-buffer (get-buffer-create gdb-expression-buffer-name))
 729       (if (display-graphic-p)
 730           (catch 'frame-exists
 731             (dolist (frame (frame-list))
 732               (if (string-equal (frame-parameter frame 'name)
 733                                 gdb-expression-buffer-name)
 734                   (throw 'frame-exists nil)))
 735             (gdb-expressions-mode)
 736             (make-frame `((height . ,gdb-window-height)
 737                           (width . ,gdb-window-width)
 738                           (tool-bar-lines . nil)
 739                           (menu-bar-lines . nil)
 740                           (minibuffer . nil))))
 741         (gdb-expressions-mode)
 742         (gdb-display-buffer (get-buffer gdb-expression-buffer-name)))))
 743   (set-buffer (gdb-get-buffer 'gdb-partial-output-buffer))
 744   (setq gdb-dive nil))
 745
 746 (defvar gdb-nesting-level nil)
 747 (defvar gdb-expression nil)
 748 (defvar gdb-point nil)
 749 (defvar gdb-annotation-arg nil)
 750
 751 (defun gdb-delete-line ()
 752   "Delete the current line."
 753   (delete-region (line-beginning-position) (line-beginning-position 2)))
 754
 755 (defun gdb-display-end (ignored)
 756   (set-buffer (gdb-get-buffer 'gdb-partial-output-buffer))
 757   (goto-char (point-min))
 758   (search-forward ": ")
 759   (looking-at "\\(.*?\\) =")
 760   (let ((char "")
 761         (gdb-temp-value (match-string 1)))
 762     ;;move * to front of expression if necessary
 763     (if (looking-at ".*\\*")
 764         (progn
 765           (setq char "*")
 766           (setq gdb-temp-value (substring gdb-temp-value 1 nil))))
 767     (with-current-buffer gdb-expression-buffer-name
 768       (setq gdb-expression gdb-temp-value)
 769       (if (not (string-match "::" gdb-expression))
 770           (setq gdb-expression (concat char gdb-current-frame
 771                                        "::" gdb-expression))
 772         ;;else put * back on if necessary
 773         (setq gdb-expression (concat char gdb-expression)))
 774       (if (not header-line-format)
 775           (setq header-line-format (concat "-- " gdb-expression " %-")))))
 776   ;;
 777   ;;-if scalar/string
 778   (if (not (re-search-forward "##" nil t))
 779       (progn
 780         (with-current-buffer gdb-expression-buffer-name
 781           (let ((buffer-read-only nil))
 782             (delete-region (point-min) (point-max))
 783             (insert-buffer-substring
 784              (gdb-get-buffer 'gdb-partial-output-buffer)))))
 785     ;; display expression name...
 786     (goto-char (point-min))
 787     (let ((start (progn (point)))
 788           (end (progn (end-of-line) (point))))
 789       (with-current-buffer gdb-expression-buffer-name
 790         (let ((buffer-read-only nil))
 791           (delete-region (point-min) (point-max))
 792           (insert-buffer-substring (gdb-get-buffer
 793                                     'gdb-partial-output-buffer)
 794                                    start end)
 795           (insert "\n"))))
 796     (goto-char (point-min))
 797     (re-search-forward "##" nil t)
 798     (setq gdb-nesting-level 0)
 799     (if (looking-at "array-section-begin")
 800         (progn
 801           (gdb-delete-line)
 802           (setq gdb-point (point))
 803           (gdb-array-format)))
 804     (if (looking-at "field-begin \\(.\\)")
 805         (progn
 806           (setq gdb-annotation-arg (match-string 1))
 807           (gdb-field-format-begin))))
 808   (with-current-buffer gdb-expression-buffer-name
 809     (if gdb-dive-display-number
 810         (progn
 811           (let ((buffer-read-only nil))
 812             (goto-char (point-max))
 813             (insert "\n")
 814             (insert-text-button "[back]" 'type 'gdb-display-back)))))
 815   (gdb-clear-partial-output)
 816   (gdb-set-output-sink 'user)
 817   (setq gdb-display-in-progress nil))
 818
 819 (define-button-type 'gdb-display-back
 820   'help-echo (purecopy "mouse-2, RET: go back to previous display buffer")
 821   'action (lambda (button) (gdb-display-go-back)))
 822
 823 (defun gdb-display-go-back ()
 824   ;; delete display so they don't accumulate and delete buffer
 825   (let ((number gdb-display-number))
 826     (gdb-enqueue-input
 827      (list (concat "server delete display " number "\n") 'ignore))
 828     (switch-to-buffer (concat "*display " gdb-dive-display-number "*"))
 829     (kill-buffer (get-buffer (concat "*display " number "*")))))
 830
 831 ;; prefix annotations with ## and process whole output in one chunk
 832 ;; in gdb-partial-output-buffer (to allow recursion).
 833
 834 ;; array-section flags are just removed again but after counting. They
 835 ;; might also be useful for arrays of structures and structures with arrays.
 836 (defun gdb-array-section-begin (args)
 837   (if gdb-display-in-progress
 838       (progn
 839         (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
 840           (goto-char (point-max))
 841           (insert (concat "\n##array-section-begin " args "\n"))))))
 842
 843 (defun gdb-array-section-end (ignored)
 844   (if gdb-display-in-progress
 845       (progn
 846         (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
 847           (goto-char (point-max))
 848           (insert "\n##array-section-end\n")))))
 849
 850 (defun gdb-field-begin (args)
 851   (if gdb-display-in-progress
 852       (progn
 853         (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
 854           (goto-char (point-max))
 855           (insert (concat "\n##field-begin " args "\n"))))))
 856
 857 (defun gdb-field-end (ignored)
 858   (if gdb-display-in-progress
 859       (progn
 860         (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
 861           (goto-char (point-max))
 862           (insert "\n##field-end\n")))))
 863
 864 (defun gdb-elt (ignored)
 865   (if gdb-display-in-progress
 866       (progn
 867         (goto-char (point-max))
 868         (insert "\n##elt\n"))))
 869
 870 (defun gdb-field-format-begin ()
 871   ;; get rid of ##field-begin
 872   (gdb-delete-line)
 873   (gdb-insert-field)
 874   (setq gdb-nesting-level (+ gdb-nesting-level 1))
 875   (while (re-search-forward "##" nil t)
 876     ;; keep making recursive calls...
 877     (if (looking-at "field-begin \\(.\\)")
 878         (progn
 879           (setq gdb-annotation-arg (match-string 1))
 880           (gdb-field-format-begin)))
 881     ;; until field-end.
 882     (if (looking-at "field-end") (gdb-field-format-end))))
 883
 884 (defun gdb-field-format-end ()
 885   ;; get rid of ##field-end and `,' or `}'
 886   (gdb-delete-line)
 887   (gdb-delete-line)
 888   (setq gdb-nesting-level (- gdb-nesting-level 1)))
 889
 890 (defvar gdb-dive-map
 891   (let ((map (make-sparse-keymap)))
 892     (define-key map [mouse-2] 'gdb-dive)
 893     (define-key map [S-mouse-2] 'gdb-dive-new-frame)
 894     map))
 895
 896 (defun gdb-dive (event)
 897   "Dive into structure."
 898   (interactive "e")
 899   (setq gdb-dive t)
 900   (gdb-dive-new-frame event))
 901
 902 (defun gdb-dive-new-frame (event)
 903   "Dive into structure and display in a new frame."
 904   (interactive "e")
 905   (save-excursion
 906     (mouse-set-point event)
 907     (let ((point (point)) (gdb-full-expression gdb-expression)
 908           (end (progn (end-of-line) (point)))
 909           (gdb-part-expression "") (gdb-last-field nil) (gdb-display-char nil))
 910       (beginning-of-line)
 911       (if (looking-at "\*") (setq gdb-display-char "*"))
 912       (re-search-forward "\\(\\S-+\\) = " end t)
 913       (setq gdb-last-field (match-string-no-properties 1))
 914       (goto-char (match-beginning 1))
 915       (let ((last-column (current-column)))
 916         (while (re-search-backward "\\s-\\(\\S-+\\) = {" nil t)
 917           (goto-char (match-beginning 1))
 918           (if (and (< (current-column) last-column)
 919                    (> (count-lines 1 (point)) 1))
 920               (progn
 921                 (setq gdb-part-expression
 922                       (concat "." (match-string-no-properties 1)
 923                               gdb-part-expression))
 924                 (setq last-column (current-column))))))
 925       ;; * not needed for components of a pointer to a structure in gdb
 926       (if (string-equal "*" (substring gdb-full-expression 0 1))
 927           (setq gdb-full-expression (substring gdb-full-expression 1 nil)))
 928       (setq gdb-full-expression
 929             (concat gdb-full-expression gdb-part-expression "." gdb-last-field))
 930       (gdb-enqueue-input
 931        (list (concat "server display" gdb-display-char
 932                      " " gdb-full-expression "\n")
 933              'ignore)))))
 934
 935 (defun gdb-insert-field ()
 936   (let ((start (progn (point)))
 937         (end (progn (next-line) (point)))
 938         (num 0))
 939     (with-current-buffer gdb-expression-buffer-name
 940       (let ((buffer-read-only nil))
 941         (if (string-equal gdb-annotation-arg "\*") (insert "\*"))
 942         (while (<= num gdb-nesting-level)
 943           (insert "\t")
 944           (setq num (+ num 1)))
 945         (insert-buffer-substring (gdb-get-buffer
 946                                   'gdb-partial-output-buffer)
 947                                  start end)
 948         (put-text-property (- (point) (- end start)) (- (point) 1)
 949                            'mouse-face 'highlight)
 950         (put-text-property (- (point) (- end start)) (- (point) 1)
 951                            'local-map gdb-dive-map)))
 952     (delete-region start end)))
 953
 954 (defvar gdb-values nil)
 955
 956 (defun gdb-array-format ()
 957   (while (re-search-forward "##" nil t)
 958     ;; keep making recursive calls...
 959     (if (looking-at "array-section-begin")
 960         (progn
 961           ;;get rid of ##array-section-begin
 962           (gdb-delete-line)
 963           (setq gdb-nesting-level (+ gdb-nesting-level 1))
 964           (gdb-array-format)))
 965     ;;until *matching* array-section-end is found
 966     (if (looking-at "array-section-end")
 967         (if (eq gdb-nesting-level 0)
 968             (progn
 969               (let ((values (buffer-substring gdb-point (- (point) 2))))
 970                 (with-current-buffer gdb-expression-buffer-name
 971                   (setq gdb-values
 972                         (concat "{" (replace-regexp-in-string "\n" "" values)
 973                                 "}"))
 974                   (gdb-array-format1))))
 975           ;;else get rid of ##array-section-end etc
 976           (gdb-delete-line)
 977           (setq gdb-nesting-level (- gdb-nesting-level 1))
 978           (gdb-array-format)))))
 979
 980 (defvar gdb-array-start nil)
 981 (defvar gdb-array-stop nil)
 982
 983 (defvar gdb-array-slice-map
 984   (let ((map (make-sparse-keymap)))
 985     (define-key map "\r" 'gdb-array-slice)
 986     (define-key map [mouse-2] 'gdb-mouse-array-slice)
 987     map))
 988
 989 (defun gdb-mouse-array-slice (event)
 990   "Select an array slice to display."
 991   (interactive "e")
 992   (mouse-set-point event)
 993   (gdb-array-slice))
 994
 995 (defun gdb-array-slice ()
 996   (interactive)
 997   (save-excursion
 998     (let ((n -1) (stop 0) (start 0) (point (point)))
 999       (beginning-of-line)
1000       (while (search-forward "[" point t)
1001         (setq n (+ n 1)))
1002       (setq start (string-to-int (read-string "Start index: ")))
1003       (aset gdb-array-start n start)
1004       (setq stop (string-to-int (read-string "Stop index: ")))
1005       (aset gdb-array-stop n stop)))
1006   (gdb-array-format1))
1007
1008 (defvar gdb-display-string nil)
1009 (defvar gdb-array-size nil)
1010
1011 (defun gdb-array-format1 ()
1012   (setq gdb-display-string "")
1013   (let ((buffer-read-only nil))
1014     (delete-region (point-min) (point-max))
1015     (let ((gdb-value-list (split-string gdb-values  ", ")))
1016       (string-match "\\({+\\)" (car gdb-value-list))
1017       (let* ((depth (- (match-end 1) (match-beginning 1)))
1018              (indices  (make-vector depth '0))
1019              (index 0) (num 0) (array-start "")
1020              (array-stop "") (array-slice "") (array-range nil)
1021              (flag t) (indices-string ""))
1022         (dolist (gdb-value gdb-value-list)
1023           (string-match "{*\\([^}]*\\)\\(}*\\)" gdb-value)
1024           (setq num 0)
1025           (while (< num depth)
1026             (setq indices-string
1027                   (concat indices-string
1028                           "[" (int-to-string (aref indices num)) "]"))
1029             (if (not (= (aref gdb-array-start num) -1))
1030                 (if (or (< (aref indices num) (aref gdb-array-start num))
1031                         (> (aref indices num) (aref gdb-array-stop num)))
1032                     (setq flag nil))
1033               (aset gdb-array-size num (aref indices num)))
1034             (setq num (+ num 1)))
1035           (if flag
1036               (let ((gdb-display-value (match-string 1 gdb-value)))
1037                 (setq gdb-display-string (concat gdb-display-string " "
1038                                                  gdb-display-value))
1039                 (insert
1040                  (concat indices-string "\t" gdb-display-value "\n"))))
1041           (setq indices-string "")
1042           (setq flag t)
1043           ;; 0<= index < depth, start at right : (- depth 1)
1044           (setq index (- (- depth 1)
1045                          (- (match-end 2) (match-beginning 2))))
1046           ;;don't set for very last brackets
1047           (when (>= index 0)
1048             (aset indices index (+ 1 (aref indices index)))
1049             (setq num (+ 1 index))
1050             (while (< num depth)
1051               (aset indices num 0)
1052               (setq num (+ num 1)))))
1053         (setq num 0)
1054         (while (< num depth)
1055           (if (= (aref gdb-array-start num) -1)
1056               (progn
1057                 (aset gdb-array-start num 0)
1058                 (aset gdb-array-stop num (aref indices num))))
1059           (setq array-start (int-to-string (aref gdb-array-start num)))
1060           (setq array-stop (int-to-string (aref gdb-array-stop num)))
1061           (setq array-range (concat "[" array-start
1062                                     ":" array-stop "]"))
1063           (put-text-property 1 (+ (length array-start)
1064                                   (length array-stop) 2)
1065                              'mouse-face 'highlight array-range)
1066           (put-text-property 1 (+ (length array-start)
1067                                   (length array-stop) 2)
1068                              'local-map gdb-array-slice-map array-range)
1069           (goto-char (point-min))
1070           (setq array-slice (concat array-slice array-range))
1071           (setq num (+ num 1)))
1072         (goto-char (point-min))
1073         (insert "Array Size : ")
1074         (setq num 0)
1075         (while (< num depth)
1076           (insert
1077            (concat "["
1078                    (int-to-string (+ (aref gdb-array-size num) 1)) "]"))
1079           (setq num (+ num 1)))
1080         (insert
1081          (concat "\n     Slice : " array-slice "\n\nIndex\tValues\n\n"))))))
1082
1083 (defun gud-gdba-marker-filter (string)
1084   "A gud marker filter for gdb. Handle a burst of output from GDB."
1085   (let (
1086         ;; Recall the left over burst from last time
1087         (burst (concat (gdb-get-burst) string))
1088         ;; Start accumulating output for the GUD buffer
1089         (output ""))
1090     ;;
1091     ;; Process all the complete markers in this chunk.
1092     (while (string-match "\n\032\032\\(.*\\)\n" burst)
1093       (let ((annotation (match-string 1 burst)))
1094         ;;
1095         ;; Stuff prior to the match is just ordinary output.
1096         ;; It is either concatenated to OUTPUT or directed
1097         ;; elsewhere.
1098         (setq output
1099               (gdb-concat-output
1100                output
1101                (substring burst 0 (match-beginning 0))))
1102
1103         ;; Take that stuff off the burst.
1104         (setq burst (substring burst (match-end 0)))
1105
1106         ;; Parse the tag from the annotation, and maybe its arguments.
1107         (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation)
1108         (let* ((annotation-type (match-string 1 annotation))
1109                (annotation-arguments (match-string 2 annotation))
1110                (annotation-rule (assoc annotation-type
1111                                        gdb-annotation-rules)))
1112           ;; Call the handler for this annotation.
1113           (if annotation-rule
1114               (funcall (car (cdr annotation-rule))
1115                        annotation-arguments)
1116             ;; Else the annotation is not recognized.  Ignore it silently,
1117             ;; so that GDB can add new annotations without causing
1118             ;; us to blow up.
1119             ))))
1120     ;;
1121     ;; Does the remaining text end in a partial line?
1122     ;; If it does, then keep part of the burst until we get more.
1123     (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'"
1124                       burst)
1125         (progn
1126           ;; Everything before the potential marker start can be output.
1127           (setq output
1128                 (gdb-concat-output output
1129                                    (substring burst 0 (match-beginning 0))))
1130           ;;
1131           ;; Everything after, we save, to combine with later input.
1132           (setq burst (substring burst (match-beginning 0))))
1133       ;;
1134       ;; In case we know the burst contains no partial annotations:
1135       (progn
1136         (setq output (gdb-concat-output output burst))
1137         (setq burst "")))
1138     ;;
1139     ;; Save the remaining burst for the next call to this function.
1140     (gdb-set-burst burst)
1141     output))
1142
1143 (defun gdb-concat-output (so-far new)
1144   (let ((sink (gdb-get-output-sink )))
1145     (cond
1146      ((eq sink 'user) (concat so-far new))
1147      ((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far)
1148      ((eq sink 'emacs)
1149       (gdb-append-to-partial-output new)
1150       so-far)
1151      ((eq sink 'inferior)
1152       (gdb-append-to-inferior-io new)
1153       so-far)
1154      (t (error "Bogon output sink %S" sink)))))
1155
1156 (defun gdb-append-to-partial-output (string)
1157   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
1158     (goto-char (point-max))
1159     (insert string)))
1160
1161 (defun gdb-clear-partial-output ()
1162   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
1163     (delete-region (point-min) (point-max))))
1164
1165 (defun gdb-append-to-inferior-io (string)
1166   (with-current-buffer (gdb-get-create-buffer 'gdb-inferior-io)
1167     (goto-char (point-max))
1168     (insert-before-markers string))
1169   (if (not (string-equal string ""))
1170       (gdb-display-buffer (gdb-get-create-buffer 'gdb-inferior-io))))
1171
1172 (defun gdb-clear-inferior-io ()
1173   (with-current-buffer (gdb-get-create-buffer 'gdb-inferior-io)
1174     (delete-region (point-min) (point-max))))
1175 \f
1176
1177 ;; One trick is to have a command who's output is always available in a buffer
1178 ;; of it's own, and is always up to date.  We build several buffers of this
1179 ;; type.
1180 ;;
1181 ;; There are two aspects to this: gdb has to tell us when the output for that
1182 ;; command might have changed, and we have to be able to run the command
1183 ;; behind the user's back.
1184 ;;
1185 ;; The idle input queue and the output phasing associated with the variable
1186 ;; gdb-output-sink help us to run commands behind the user's back.
1187 ;;
1188 ;; Below is the code for specificly managing buffers of output from one
1189 ;; command.
1190 ;;
1191
1192 ;; The trigger function is suitable for use in the assoc GDB-ANNOTATION-RULES
1193 ;; It adds an idle input for the command we are tracking.  It should be the
1194 ;; annotation rule binding of whatever gdb sends to tell us this command
1195 ;; might have changed it's output.
1196 ;;
1197 ;; NAME is the function name.  DEMAND-PREDICATE tests if output is really needed.
1198 ;; GDB-COMMAND is a string of such.  OUTPUT-HANDLER is the function bound to the
1199 ;; input in the input queue (see comment about ``gdb communications'' above).
1200
1201 (defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command
1202                                             output-handler)
1203   `(defun ,name (&optional ignored)
1204      (if (and (,demand-predicate)
1205               (not (member ',name
1206                            (gdb-get-pending-triggers))))
1207          (progn
1208            (gdb-enqueue-idle-input
1209             (list ,gdb-command ',output-handler))
1210            (gdb-set-pending-triggers
1211             (cons ',name
1212                   (gdb-get-pending-triggers)))))))
1213
1214 (defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun)
1215   `(defun ,name ()
1216      (gdb-set-pending-triggers
1217       (delq ',trigger
1218             (gdb-get-pending-triggers)))
1219      (let ((buf (gdb-get-buffer ',buf-key)))
1220        (and buf
1221             (with-current-buffer buf
1222               (let ((p (point))
1223                     (buffer-read-only nil))
1224                 (delete-region (point-min) (point-max))
1225                 (insert-buffer-substring (gdb-get-create-buffer
1226                                           'gdb-partial-output-buffer))
1227                 (goto-char p)))))
1228      ;; put customisation here
1229      (,custom-defun)))
1230
1231 (defmacro def-gdb-auto-updated-buffer (buffer-key trigger-name gdb-command
1232                                                   output-handler-name custom-defun)
1233   `(progn
1234      (def-gdb-auto-update-trigger ,trigger-name
1235        ;; The demand predicate:
1236        (lambda () (gdb-get-buffer ',buffer-key))
1237        ,gdb-command
1238        ,output-handler-name)
1239      (def-gdb-auto-update-handler ,output-handler-name
1240        ,trigger-name ,buffer-key ,custom-defun)))
1241
1242 \f
1243 ;;
1244 ;; Breakpoint buffer : This displays the output of `info breakpoints'.
1245 ;;
1246 (gdb-set-buffer-rules 'gdb-breakpoints-buffer
1247                       'gdb-breakpoints-buffer-name
1248                       'gdb-breakpoints-mode)
1249
1250 (def-gdb-auto-updated-buffer gdb-breakpoints-buffer
1251   ;; This defines the auto update rule for buffers of type
1252   ;; `gdb-breakpoints-buffer'.
1253   ;;
1254   ;; It defines a function to serve as the annotation handler that
1255   ;; handles the `foo-invalidated' message.  That function is called:
1256   gdb-invalidate-breakpoints
1257   ;;
1258   ;; To update the buffer, this command is sent to gdb.
1259   "server info breakpoints\n"
1260   ;;
1261   ;; This also defines a function to be the handler for the output
1262   ;; from the command above.  That function will copy the output into
1263   ;; the appropriately typed buffer.  That function will be called:
1264   gdb-info-breakpoints-handler
1265   ;; buffer specific functions
1266   gdb-info-breakpoints-custom)
1267
1268 (defvar gdb-cdir nil "Compilation directory.")
1269
1270 (defconst breakpoint-xpm-data "/* XPM */
1271 static char *magick[] = {
1272 /* columns rows colors chars-per-pixel */
1273 \"12 12 2 1\",
1274 \"  c red\",
1275 \"+ c None\",
1276 /* pixels */
1277 \"++++++++++++\",
1278 \"+++      +++\",
1279 \"++        ++\",
1280 \"+          +\",
1281 \"+          +\",
1282 \"+          +\",
1283 \"+          +\",
1284 \"+          +\",
1285 \"+          +\",
1286 \"++        ++\",
1287 \"+++      +++\",
1288 \"++++++++++++\"
1289 };"
1290   "XPM data used for breakpoint icon.")
1291
1292 (defconst breakpoint-enabled-pbm-data
1293 "P1
1294 12 12\",
1295 0 0 0 0 0 0 0 0 0 0 0 0
1296 0 0 0 1 1 1 1 1 1 0 0 0
1297 0 0 1 1 1 1 1 1 1 1 0 0
1298 0 1 1 1 1 1 1 1 1 1 1 0
1299 0 1 1 1 1 1 1 1 1 1 1 0
1300 0 1 1 1 1 1 1 1 1 1 1 0
1301 0 1 1 1 1 1 1 1 1 1 1 0
1302 0 1 1 1 1 1 1 1 1 1 1 0
1303 0 1 1 1 1 1 1 1 1 1 1 0
1304 0 0 1 1 1 1 1 1 1 1 0 0
1305 0 0 0 1 1 1 1 1 1 0 0 0
1306 0 0 0 0 0 0 0 0 0 0 0 0"
1307   "PBM data used for enabled breakpoint icon.")
1308
1309 (defconst breakpoint-disabled-pbm-data
1310 "P1
1311 12 12\",
1312 0 0 0 0 0 0 0 0 0 0 0 0
1313 0 0 0 1 0 1 0 1 0 0 0 0
1314 0 0 1 0 1 0 1 0 1 0 0 0
1315 0 1 0 1 0 1 0 1 0 1 0 0
1316 0 0 1 0 1 0 1 0 1 0 1 0
1317 0 1 0 1 0 1 0 1 0 1 0 0
1318 0 0 1 0 1 0 1 0 1 0 1 0
1319 0 1 0 1 0 1 0 1 0 1 0 0
1320 0 0 1 0 1 0 1 0 1 0 1 0
1321 0 0 0 1 0 1 0 1 0 1 0 0
1322 0 0 0 0 1 0 1 0 1 0 0 0
1323 0 0 0 0 0 0 0 0 0 0 0 0"
1324   "PBM data used for disabled breakpoint icon.")
1325
1326 (defvar breakpoint-enabled-icon
1327   (find-image `((:type xpm :data ,breakpoint-xpm-data)
1328                 (:type pbm :data ,breakpoint-enabled-pbm-data)))
1329   "Icon for enabled breakpoint in display margin")
1330
1331 (defvar breakpoint-disabled-icon
1332   (find-image `((:type xpm :data ,breakpoint-xpm-data :conversion disabled)
1333                 (:type pbm :data ,breakpoint-disabled-pbm-data)))
1334   "Icon for disabled breakpoint in display margin")
1335
1336 ;;-put breakpoint icons in relevant margins (even those set in the GUD buffer)
1337 (defun gdb-info-breakpoints-custom ()
1338   (let ((flag)(address))
1339     ;;
1340     ;; remove all breakpoint-icons in source buffers but not assembler buffer
1341     (dolist (buffer (buffer-list))
1342       (with-current-buffer buffer
1343         (if (and (eq gud-minor-mode 'gdba)
1344                  (not (string-match "^\*" (buffer-name))))
1345             (if (eq window-system 'x)
1346                 (remove-images (point-min) (point-max))
1347               (gdb-remove-strings (point-min) (point-max))))))
1348     (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
1349       (save-excursion
1350         (goto-char (point-min))
1351         (while (< (point) (- (point-max) 1))
1352           (forward-line 1)
1353           (if (looking-at "[^\t].*breakpoint")
1354               (progn
1355                 (looking-at "[0-9]*\\s-*\\S-*\\s-*\\S-*\\s-*\\(.\\)")
1356                 (setq flag (char-after (match-beginning 1)))
1357                 (beginning-of-line)
1358                 (if (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+" nil t)
1359                     (progn
1360                       (looking-at "\\(\\S-*\\):\\([0-9]+\\)")
1361                       (let ((line (match-string 2)) (buffer-read-only nil)
1362                             (file (match-string 1)))
1363                         (put-text-property (progn (beginning-of-line) (point))
1364                                            (progn (end-of-line) (point))
1365                                            'mouse-face 'highlight)
1366                         (with-current-buffer
1367                             (find-file-noselect
1368                              (if (file-exists-p file) file
1369                                (expand-file-name file gdb-cdir)))
1370                           (save-current-buffer
1371                             (set (make-local-variable 'gud-minor-mode) 'gdba)
1372                             (set (make-local-variable 'tool-bar-map)
1373                                  gud-tool-bar-map)
1374                             (setq left-margin-width 2)
1375                             (if (get-buffer-window (current-buffer))
1376                                 (set-window-margins (get-buffer-window
1377                                                      (current-buffer))
1378                                                     left-margin-width
1379                                                     right-margin-width)))
1380                           ;; only want one breakpoint icon at each location
1381                           (save-excursion
1382                             (goto-line (string-to-number line))
1383                             (let ((start (progn (beginning-of-line)
1384                                                 (- (point) 1)))
1385                                   (end (progn (end-of-line) (+ (point) 1))))
1386                               (if (eq window-system 'x)
1387                                   (progn
1388                                     (remove-images start end)
1389                                     (if (eq ?y flag)
1390                                         (put-image breakpoint-enabled-icon
1391                                                    (+ start 1)
1392                                                    "breakpoint icon enabled"
1393                                                    'left-margin)
1394                                       (put-image breakpoint-disabled-icon
1395                                                  (+ start 1)
1396                                                  "breakpoint icon disabled"
1397                                                  'left-margin)))
1398                                 (gdb-remove-strings start end)
1399                                 (if (eq ?y flag)
1400                                     (gdb-put-string "B" (+ start 1))
1401                                   (gdb-put-string "b" (+ start 1))))))))))))
1402           (end-of-line))))))
1403
1404 (defun gdb-breakpoints-buffer-name ()
1405   (with-current-buffer gud-comint-buffer
1406     (concat "*breakpoints of " (gdb-get-target-string) "*")))
1407
1408 (defun gdb-display-breakpoints-buffer ()
1409   (interactive)
1410   (gdb-display-buffer
1411    (gdb-get-create-buffer 'gdb-breakpoints-buffer)))
1412
1413 (defun gdb-frame-breakpoints-buffer ()
1414   (interactive)
1415   (switch-to-buffer-other-frame
1416    (gdb-get-create-buffer 'gdb-breakpoints-buffer)))
1417
1418 (defvar gdb-breakpoints-mode-map
1419   (let ((map (make-sparse-keymap))
1420         (menu (make-sparse-keymap "Breakpoints")))
1421     (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint))
1422     (define-key menu [delete] '("Delete" . gdb-delete-breakpoint))
1423     (define-key menu [goto] '("Goto"   . gdb-goto-breakpoint))
1424
1425     (suppress-keymap map)
1426     (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu))
1427     (define-key map " " 'gdb-toggle-breakpoint)
1428     (define-key map "d" 'gdb-delete-breakpoint)
1429     (define-key map "\r" 'gdb-goto-breakpoint)
1430     (define-key map [mouse-2] 'gdb-mouse-goto-breakpoint)
1431     map))
1432
1433 (defun gdb-breakpoints-mode ()
1434   "Major mode for gdb breakpoints.
1435
1436 \\{gdb-breakpoints-mode-map}"
1437   (setq major-mode 'gdb-breakpoints-mode)
1438   (setq mode-name "Breakpoints")
1439   (use-local-map gdb-breakpoints-mode-map)
1440   (setq buffer-read-only t)
1441   (gdb-invalidate-breakpoints))
1442
1443 (defun gdb-toggle-breakpoint ()
1444   "Enable/disable the breakpoint at current line."
1445   (interactive)
1446   (save-excursion
1447     (beginning-of-line 1)
1448     (if (not (looking-at "\\([0-9]+\\).*point\\s-*\\S-*\\s-*\\(.\\)"))
1449         (error "Not recognized as break/watchpoint line")
1450       (gdb-enqueue-input
1451        (list
1452         (concat
1453          (if (eq ?y (char-after (match-beginning 2)))
1454              "server disable "
1455            "server enable ")
1456          (match-string 1) "\n")
1457         'ignore)))))
1458
1459 (defun gdb-delete-breakpoint ()
1460   "Delete the breakpoint at current line."
1461   (interactive)
1462   (beginning-of-line 1)
1463   (if (not (looking-at "\\([0-9]+\\).*point\\s-*\\S-*\\s-*\\(.\\)"))
1464       (error "Not recognized as break/watchpoint line")
1465     (gdb-enqueue-input
1466      (list (concat "server delete " (match-string 1) "\n") 'ignore))))
1467
1468 (defvar gdb-source-window nil)
1469
1470 (defun gdb-goto-breakpoint ()
1471   "Display the file in the source buffer at the breakpoint specified on the
1472 current line."
1473   (interactive)
1474   (save-excursion
1475     (beginning-of-line 1)
1476     (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+" nil t)
1477     (looking-at "\\(\\S-*\\):\\([0-9]+\\)"))
1478   (if (match-string 2)
1479       (let ((line (match-string 2))
1480             (file (match-string 1)))
1481         (save-selected-window
1482           (select-window gdb-source-window)
1483           (switch-to-buffer (find-file-noselect
1484                              (if (file-exists-p file)
1485                                  file
1486                                (expand-file-name file gdb-cdir))))
1487           (goto-line (string-to-number line))))))
1488 ;; I'll get this to work one day!
1489 ;; (defun gdb-goto-breakpoint ()
1490 ;;   "Display the file in the source buffer at the breakpoint specified on the
1491 ;; current line."
1492 ;;   (interactive)
1493 ;;   (save-excursion
1494 ;;     (let ((eol (progn (end-of-line) (point))))
1495 ;;       (beginning-of-line 1)
1496 ;;       (if (re-search-forward "\\(\\S-*\\):\\([0-9]+\\)" eol t)
1497 ;;        (let ((line (match-string 2))
1498 ;;              (file (match-string 1)))
1499 ;;          (save-selected-window
1500 ;;            (select-window gdb-source-window)
1501 ;;            (switch-to-buffer (find-file-noselect
1502 ;;                               (if (file-exists-p file)
1503 ;;                                   file
1504 ;;                                 (expand-file-name file gdb-cdir))))
1505 ;;            (goto-line (string-to-number line))))))
1506 ;;     (let ((eol (progn (end-of-line) (point))))
1507 ;;       (beginning-of-line 1)
1508 ;;       (if (re-search-forward "<\\(\\S-*?\\)\\(\\+*[0-9]*\\)>" eol t)
1509 ;;        (save-selected-window
1510 ;;          (select-window gdb-source-window)
1511 ;;          (gdb-get-create-buffer 'gdb-assembler-buffer)
1512 ;;          (gdb-enqueue-input
1513 ;;           (list (concat "server disassemble " (match-string 1) "\n")
1514 ;;                 'gdb-assembler-handler))
1515 ;;          (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer)
1516 ;;            (re-search-forward
1517 ;;             (concat (match-string 1) (match-string 2)))))))))
1518
1519 (defun gdb-mouse-goto-breakpoint (event)
1520   "Display the file in the source buffer at the selected breakpoint."
1521   (interactive "e")
1522   (mouse-set-point event)
1523   (gdb-goto-breakpoint))
1524 \f
1525 ;;
1526 ;; Frames buffer.  This displays a perpetually correct bactracktrace
1527 ;; (from the command `where').
1528 ;;
1529 ;; Alas, if your stack is deep, it is costly.
1530 ;;
1531 (gdb-set-buffer-rules 'gdb-stack-buffer
1532                       'gdb-stack-buffer-name
1533                       'gdb-frames-mode)
1534
1535 (def-gdb-auto-updated-buffer gdb-stack-buffer
1536   gdb-invalidate-frames
1537   "server where\n"
1538   gdb-info-frames-handler
1539   gdb-info-frames-custom)
1540
1541 (defun gdb-info-frames-custom ()
1542   (with-current-buffer (gdb-get-buffer 'gdb-stack-buffer)
1543     (save-excursion
1544       (let ((buffer-read-only nil))
1545         (goto-char (point-min))
1546         (while (< (point) (point-max))
1547           (put-text-property (progn (beginning-of-line) (point))
1548                              (progn (end-of-line) (point))
1549                              'mouse-face 'highlight)
1550           (beginning-of-line)
1551           (if (or (looking-at "^#[0-9]*\\s-*\\S-* in \\(\\S-*\\)")
1552                   (looking-at "^#[0-9]*\\s-*\\(\\S-*\\)"))
1553               (if (equal (match-string 1) gdb-current-frame)
1554                   (put-text-property (progn (beginning-of-line) (point))
1555                                      (progn (end-of-line) (point))
1556                                      'face
1557                                      `(:background ,(face-attribute 'default :foreground)
1558                                        :foreground ,(face-attribute 'default :background)))))
1559           (forward-line 1))))))
1560
1561 (defun gdb-stack-buffer-name ()
1562   (with-current-buffer gud-comint-buffer
1563     (concat "*stack frames of " (gdb-get-target-string) "*")))
1564
1565 (defun gdb-display-stack-buffer ()
1566   (interactive)
1567   (gdb-display-buffer
1568    (gdb-get-create-buffer 'gdb-stack-buffer)))
1569
1570 (defun gdb-frame-stack-buffer ()
1571   (interactive)
1572   (switch-to-buffer-other-frame
1573    (gdb-get-create-buffer 'gdb-stack-buffer)))
1574
1575 (defvar gdb-frames-mode-map
1576   (let ((map (make-sparse-keymap)))
1577     (suppress-keymap map)
1578     (define-key map "\r" 'gdb-frames-select)
1579     (define-key map [mouse-2] 'gdb-frames-mouse-select)
1580     map))
1581
1582 (defun gdb-frames-mode ()
1583   "Major mode for gdb frames.
1584
1585 \\{gdb-frames-mode-map}"
1586   (setq major-mode 'gdb-frames-mode)
1587   (setq mode-name "Frames")
1588   (setq buffer-read-only t)
1589   (use-local-map gdb-frames-mode-map)
1590   (font-lock-mode -1)
1591   (gdb-invalidate-frames))
1592
1593 (defun gdb-get-frame-number ()
1594   (save-excursion
1595     (let* ((pos (re-search-backward "^#\\([0-9]*\\)" nil t))
1596            (n (or (and pos (match-string-no-properties 1)) "0")))
1597       n)))
1598
1599 (defun gdb-frames-select ()
1600   "Make the frame on the current line become the current frame and display the
1601 source in the source buffer."
1602   (interactive)
1603   (gdb-enqueue-input
1604    (list (concat "server frame " (gdb-get-frame-number) "\n") 'ignore))
1605   (gud-display-frame))
1606
1607 (defun gdb-frames-mouse-select (event)
1608   "Make the selected frame become the current frame and display the source in
1609 the source buffer."
1610   (interactive "e")
1611   (mouse-set-point event)
1612   (gdb-frames-select))
1613 \f
1614 ;;
1615 ;; Threads buffer.  This displays a selectable thread list.
1616 ;;
1617 (gdb-set-buffer-rules 'gdb-threads-buffer
1618                       'gdb-threads-buffer-name
1619                       'gdb-threads-mode)
1620
1621 (def-gdb-auto-updated-buffer gdb-threads-buffer
1622   gdb-invalidate-threads
1623   "info threads\n"
1624   gdb-info-threads-handler
1625   gdb-info-threads-custom)
1626
1627 (defun gdb-info-threads-custom ()
1628   (with-current-buffer (gdb-get-buffer 'gdb-threads-buffer)
1629     (let ((buffer-read-only nil))
1630       (goto-char (point-min))
1631       (while (< (point) (point-max))
1632         (put-text-property (progn (beginning-of-line) (point))
1633                            (progn (end-of-line) (point))
1634                            'mouse-face 'highlight)
1635         (forward-line 1)))))
1636
1637 (defun gdb-threads-buffer-name ()
1638   (with-current-buffer gud-comint-buffer
1639     (concat "*threads of " (gdb-get-target-string) "*")))
1640
1641 (defun gdb-display-threads-buffer ()
1642   (interactive)
1643   (gdb-display-buffer
1644    (gdb-get-create-buffer 'gdb-threads-buffer)))
1645
1646 (defun gdb-frame-threads-buffer ()
1647   (interactive)
1648   (switch-to-buffer-other-frame
1649    (gdb-get-create-buffer 'gdb-threads-buffer)))
1650
1651 (defvar gdb-threads-mode-map
1652   (let ((map (make-sparse-keymap)))
1653     (suppress-keymap map)
1654     (define-key map "\r" 'gdb-threads-select)
1655     (define-key map [mouse-2] 'gdb-threads-mouse-select)
1656     map))
1657
1658 (defun gdb-threads-mode ()
1659   "Major mode for gdb frames.
1660
1661 \\{gdb-frames-mode-map}"
1662   (setq major-mode 'gdb-threads-mode)
1663   (setq mode-name "Threads")
1664   (setq buffer-read-only t)
1665   (use-local-map gdb-threads-mode-map)
1666   (gdb-invalidate-threads))
1667
1668 (defun gdb-get-thread-number ()
1669   (save-excursion
1670     (re-search-backward "^\\s-*\\([0-9]*\\)" nil t)
1671     (match-string-no-properties 1)))
1672
1673
1674 (defun gdb-threads-select ()
1675   "Make the thread on the current line become the current thread and display the
1676 source in the source buffer."
1677   (interactive)
1678   (gdb-enqueue-input
1679    (list (concat "thread " (gdb-get-thread-number) "\n") 'ignore))
1680   (gud-display-frame))
1681
1682 (defun gdb-threads-mouse-select (event)
1683   "Make the selected frame become the current frame and display the source in
1684 the source buffer."
1685   (interactive "e")
1686   (mouse-set-point event)
1687   (gdb-threads-select))
1688 \f
1689 ;;
1690 ;; Registers buffer.
1691 ;;
1692 (gdb-set-buffer-rules 'gdb-registers-buffer
1693                       'gdb-registers-buffer-name
1694                       'gdb-registers-mode)
1695
1696 (def-gdb-auto-updated-buffer gdb-registers-buffer
1697   gdb-invalidate-registers
1698   "server info registers\n"
1699   gdb-info-registers-handler
1700   gdb-info-registers-custom)
1701
1702 (defun gdb-info-registers-custom ())
1703
1704 (defvar gdb-registers-mode-map
1705   (let ((map (make-sparse-keymap)))
1706     (suppress-keymap map)
1707     map))
1708
1709 (defun gdb-registers-mode ()
1710   "Major mode for gdb registers.
1711
1712 \\{gdb-registers-mode-map}"
1713   (setq major-mode 'gdb-registers-mode)
1714   (setq mode-name "Registers")
1715   (setq buffer-read-only t)
1716   (use-local-map gdb-registers-mode-map)
1717   (gdb-invalidate-registers))
1718
1719 (defun gdb-registers-buffer-name ()
1720   (with-current-buffer gud-comint-buffer
1721     (concat "*registers of " (gdb-get-target-string) "*")))
1722
1723 (defun gdb-display-registers-buffer ()
1724   (interactive)
1725   (gdb-display-buffer
1726    (gdb-get-create-buffer 'gdb-registers-buffer)))
1727
1728 (defun gdb-frame-registers-buffer ()
1729   (interactive)
1730   (switch-to-buffer-other-frame
1731    (gdb-get-create-buffer 'gdb-registers-buffer)))
1732 \f
1733 ;;
1734 ;; Locals buffer.
1735 ;;
1736 (gdb-set-buffer-rules 'gdb-locals-buffer
1737                       'gdb-locals-buffer-name
1738                       'gdb-locals-mode)
1739
1740 (def-gdb-auto-updated-buffer gdb-locals-buffer
1741   gdb-invalidate-locals
1742   "server info locals\n"
1743   gdb-info-locals-handler
1744   gdb-info-locals-custom)
1745
1746 ;; Abbreviate for arrays and structures.
1747 ;; These can be expanded using gud-display.
1748 (defun gdb-info-locals-handler nil
1749   (gdb-set-pending-triggers (delq 'gdb-invalidate-locals
1750                                   (gdb-get-pending-triggers)))
1751   (let ((buf (gdb-get-buffer 'gdb-partial-output-buffer)))
1752     (with-current-buffer buf
1753       (goto-char (point-min))
1754       (while (re-search-forward "^ .*\n" nil t)
1755         (replace-match "" nil nil))
1756       (goto-char (point-min))
1757       (while (re-search-forward "{[-0-9, {}\]*\n" nil t)
1758         (replace-match "(array);\n" nil nil))
1759       (goto-char (point-min))
1760       (while (re-search-forward "{.*=.*\n" nil t)
1761         (replace-match "(structure);\n" nil nil))))
1762   (let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
1763     (and buf (with-current-buffer buf
1764                (let ((p (point))
1765                      (buffer-read-only nil))
1766                  (delete-region (point-min) (point-max))
1767                  (insert-buffer-substring (gdb-get-create-buffer
1768                                            'gdb-partial-output-buffer))
1769                  (goto-char p)))))
1770   (run-hooks 'gdb-info-locals-hook))
1771
1772 (defun gdb-info-locals-custom ()
1773   nil)
1774
1775 (defvar gdb-locals-mode-map
1776   (let ((map (make-sparse-keymap)))
1777     (suppress-keymap map)
1778     map))
1779
1780 (defun gdb-locals-mode ()
1781   "Major mode for gdb locals.
1782
1783 \\{gdb-locals-mode-map}"
1784   (setq major-mode 'gdb-locals-mode)
1785   (setq mode-name "Locals")
1786   (setq buffer-read-only t)
1787   (use-local-map gdb-locals-mode-map)
1788   (gdb-invalidate-locals))
1789
1790 (defun gdb-locals-buffer-name ()
1791   (with-current-buffer gud-comint-buffer
1792     (concat "*locals of " (gdb-get-target-string) "*")))
1793
1794 (defun gdb-display-locals-buffer ()
1795   (interactive)
1796   (gdb-display-buffer
1797    (gdb-get-create-buffer 'gdb-locals-buffer)))
1798
1799 (defun gdb-frame-locals-buffer ()
1800   (interactive)
1801   (switch-to-buffer-other-frame
1802    (gdb-get-create-buffer 'gdb-locals-buffer)))
1803 \f
1804 ;;
1805 ;; Display expression buffer.
1806 ;;
1807 (gdb-set-buffer-rules 'gdb-display-buffer
1808                       'gdb-display-buffer-name
1809                       'gdb-display-mode)
1810
1811 (def-gdb-auto-updated-buffer gdb-display-buffer
1812   ;; `gdb-display-buffer'.
1813   gdb-invalidate-display
1814   "server info display\n"
1815   gdb-info-display-handler
1816   gdb-info-display-custom)
1817
1818 (defun gdb-info-display-custom ()
1819   (let ((display-list nil))
1820     (with-current-buffer (gdb-get-buffer 'gdb-display-buffer)
1821       (goto-char (point-min))
1822       (while (< (point) (- (point-max) 1))
1823         (forward-line 1)
1824         (if (looking-at "\\([0-9]+\\):   \\([ny]\\)")
1825             (setq display-list
1826                   (cons (string-to-int (match-string 1)) display-list)))
1827         (end-of-line)))
1828     (if (not (display-graphic-p))
1829         (progn
1830           (dolist (buffer (buffer-list))
1831             (if (string-match "\\*display \\([0-9]+\\)\\*" (buffer-name buffer))
1832                 (progn
1833                   (let ((number
1834                          (match-string 1 (buffer-name buffer))))
1835                     (if (not (memq (string-to-int number) display-list))
1836                         (kill-buffer
1837                          (get-buffer (concat "*display " number "*")))))))))
1838       (gdb-delete-frames display-list))))
1839
1840 (defun gdb-delete-frames (display-list)
1841   (dolist (frame (frame-list))
1842     (let ((frame-name (frame-parameter frame 'name)))
1843       (if (string-match "\\*display \\([0-9]+\\)\\*" frame-name)
1844           (progn
1845             (let ((number (match-string 1 frame-name)))
1846               (if (not (memq (string-to-int number) display-list))
1847                   (progn (kill-buffer
1848                           (get-buffer (concat "*display " number "*")))
1849                          (delete-frame frame)))))))))
1850
1851 (defvar gdb-display-mode-map
1852   (let ((map (make-sparse-keymap))
1853         (menu (make-sparse-keymap "Display")))
1854     (define-key menu [toggle] '("Toggle" . gdb-toggle-display))
1855     (define-key menu [delete] '("Delete" . gdb-delete-display))
1856
1857     (suppress-keymap map)
1858     (define-key map [menu-bar display] (cons "Display" menu))
1859     (define-key map " " 'gdb-toggle-display)
1860     (define-key map "d" 'gdb-delete-display)
1861     map))
1862
1863 (defun gdb-display-mode ()
1864   "Major mode for gdb display.
1865
1866 \\{gdb-display-mode-map}"
1867   (setq major-mode 'gdb-display-mode)
1868   (setq mode-name "Display")
1869   (setq buffer-read-only t)
1870   (use-local-map gdb-display-mode-map)
1871   (gdb-invalidate-display))
1872
1873 (defun gdb-display-buffer-name ()
1874   (with-current-buffer gud-comint-buffer
1875     (concat "*Displayed expressions of " (gdb-get-target-string) "*")))
1876
1877 (defun gdb-display-display-buffer ()
1878   (interactive)
1879   (gdb-display-buffer
1880    (gdb-get-create-buffer 'gdb-display-buffer)))
1881
1882 (defun gdb-frame-display-buffer ()
1883   (interactive)
1884   (switch-to-buffer-other-frame
1885    (gdb-get-create-buffer 'gdb-display-buffer)))
1886
1887 (defun gdb-toggle-display ()
1888   "Enable/disable the displayed expression at current line."
1889   (interactive)
1890   (save-excursion
1891     (beginning-of-line 1)
1892     (if (not (looking-at "\\([0-9]+\\):   \\([ny]\\)"))
1893         (error "No expression on this line")
1894       (gdb-enqueue-input
1895        (list
1896         (concat
1897          (if (eq ?y (char-after (match-beginning 2)))
1898              "server disable display "
1899            "server enable display ")
1900          (match-string 1) "\n")
1901         'ignore)))))
1902
1903 (defun gdb-delete-display ()
1904   "Delete the displayed expression at current line."
1905   (interactive)
1906   (with-current-buffer (gdb-get-buffer 'gdb-display-buffer)
1907     (beginning-of-line 1)
1908     (if (not (looking-at "\\([0-9]+\\):   \\([ny]\\)"))
1909         (error "No expression on this line")
1910       (let ((number (match-string 1)))
1911         (gdb-enqueue-input
1912          (list (concat "server delete display " number "\n") 'ignore))))))
1913
1914 (defvar gdb-expressions-mode-map
1915   (let ((map (make-sparse-keymap)))
1916     (suppress-keymap map)
1917     (define-key map "v" 'gdb-array-visualise)
1918     (define-key map "q" 'gdb-delete-expression)
1919     (define-key map [mouse-3] 'gdb-expressions-popup-menu)
1920     map))
1921
1922 (defvar gdb-expressions-mode-menu
1923   '("GDB Expressions Commands"
1924     "----"
1925     ["Visualise" gdb-array-visualise t]
1926     ["Delete"    gdb-delete-expression  t])
1927   "Menu for `gdb-expressions-mode'.")
1928
1929 (defun gdb-expressions-popup-menu (event)
1930   "Explicit Popup menu as this buffer doesn't have a menubar."
1931   (interactive "@e")
1932   (mouse-set-point event)
1933   (popup-menu gdb-expressions-mode-menu))
1934
1935 (defun gdb-expressions-mode ()
1936   "Major mode for display expressions.
1937
1938 \\{gdb-expressions-mode-map}"
1939   (setq major-mode 'gdb-expressions-mode)
1940   (setq mode-name "Expressions")
1941   (use-local-map gdb-expressions-mode-map)
1942   (make-local-variable 'gdb-display-number)
1943   (make-local-variable 'gdb-values)
1944   (make-local-variable 'gdb-expression)
1945   (set (make-local-variable 'gdb-display-string) nil)
1946   (set (make-local-variable 'gdb-dive-display-number) nil)
1947   (set (make-local-variable 'gud-minor-mode) 'gdba)
1948   (set (make-local-variable 'gdb-array-start) (make-vector 16 '-1))
1949   (set (make-local-variable 'gdb-array-stop)  (make-vector 16 '-1))
1950   (set (make-local-variable 'gdb-array-size)  (make-vector 16 '-1))
1951   (setq buffer-read-only t))
1952 \f
1953
1954 ;;;; Window management
1955
1956 ;;; The way we abuse the dedicated-p flag is pretty gross, but seems
1957 ;;; to do the right thing.  Seeing as there is no way for Lisp code to
1958 ;;; get at the use_time field of a window, I'm not sure there exists a
1959 ;;; more elegant solution without writing C code.
1960
1961 (defun gdb-display-buffer (buf &optional size)
1962   (let ((must-split nil)
1963         (answer nil))
1964     (unwind-protect
1965         (progn
1966           (walk-windows
1967            '(lambda (win)
1968               (if (or (eq gud-comint-buffer (window-buffer win))
1969                       (eq gdb-source-window win))
1970                   (set-window-dedicated-p win t))))
1971           (setq answer (get-buffer-window buf))
1972           (if (not answer)
1973               (let ((window (get-lru-window)))
1974                 (if window
1975                     (progn
1976                       (set-window-buffer window buf)
1977                       (setq answer window))
1978                   (setq must-split t)))))
1979       (walk-windows
1980        '(lambda (win)
1981           (if (or (eq gud-comint-buffer (window-buffer win))
1982                   (eq gdb-source-window win))
1983               (set-window-dedicated-p win nil)))))
1984     (if must-split
1985         (let* ((largest (get-largest-window))
1986                (cur-size (window-height largest))
1987                (new-size (and size (< size cur-size) (- cur-size size))))
1988           (setq answer (split-window largest new-size))
1989           (set-window-buffer answer buf)))
1990     answer))
1991
1992 (defun gdb-display-source-buffer (buffer)
1993   (if (eq gdb-selected-view 'source)
1994       (set-window-buffer gdb-source-window buffer)
1995     (set-window-buffer gdb-source-window
1996                        (gdb-get-buffer 'gdb-assembler-buffer)))
1997   gdb-source-window)
1998
1999 \f
2000 ;;; Shared keymap initialization:
2001
2002 (let ((menu (make-sparse-keymap "GDB-Frames")))
2003   (define-key gud-menu-map [frames]
2004     `(menu-item "GDB-Frames" ,menu :visible (eq gud-minor-mode 'gdba)))
2005   (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer))
2006   (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer))
2007   (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
2008   (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))
2009   (define-key menu [breakpoints] '("Breakpoints" . gdb-frame-breakpoints-buffer))
2010   (define-key menu [display] '("Display" . gdb-frame-display-buffer))
2011   (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
2012 ;  (define-key menu [assembler] '("Assembler" . gdb-frame-assembler-buffer))
2013 )
2014
2015 (let ((menu (make-sparse-keymap "GDB-Windows")))
2016   (define-key gud-menu-map [displays]
2017     `(menu-item "GDB-Windows" ,menu :visible (eq gud-minor-mode 'gdba)))
2018   (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer))
2019   (define-key menu [locals] '("Locals" . gdb-display-locals-buffer))
2020   (define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
2021   (define-key menu [frames] '("Stack" . gdb-display-stack-buffer))
2022   (define-key menu [breakpoints] '("Breakpoints" . gdb-display-breakpoints-buffer))
2023   (define-key menu [display] '("Display" . gdb-display-display-buffer))
2024   (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
2025 ;  (define-key menu [assembler] '("Assembler" . gdb-display-assembler-buffer))
2026 )
2027
2028 (let ((menu (make-sparse-keymap "View")))
2029    (define-key gud-menu-map [view]
2030      `(menu-item "View" ,menu :visible (eq gud-minor-mode 'gdba)))
2031 ;  (define-key menu [both] '(menu-item "Both" gdb-view-both
2032 ;              :help "Display both source and assembler"
2033 ;              :button (:radio . (eq gdb-selected-view 'both))))
2034    (define-key menu [assembler] '(menu-item "Assembler" gdb-view-assembler
2035                :help "Display assembler only"
2036                :button (:radio . (eq gdb-selected-view 'assembler))))
2037    (define-key menu [source] '(menu-item "Source" gdb-view-source-function
2038                :help "Display source only"
2039                :button (:radio . (eq gdb-selected-view 'source)))))
2040
2041 (let ((menu (make-sparse-keymap "GDB-UI")))
2042   (define-key gud-menu-map [ui]
2043     `(menu-item "GDB-UI" ,menu :visible (eq gud-minor-mode 'gdba)))
2044   (define-key menu [gdb-restore-windows]
2045     '("Restore window layout" . gdb-restore-windows))
2046   (define-key menu [gdb-many-windows]
2047     (menu-bar-make-toggle gdb-many-windows gdb-many-windows
2048                           "Display other windows" "Many Windows %s"
2049                           "Display locals, stack and breakpoint information")))
2050
2051 (defun gdb-frame-gdb-buffer ()
2052   (interactive)
2053   (switch-to-buffer-other-frame
2054    (gdb-get-create-buffer 'gdba)))
2055
2056 (defun gdb-display-gdb-buffer ()
2057   (interactive)
2058   (gdb-display-buffer
2059    (gdb-get-create-buffer 'gdba)))
2060
2061 (defvar gdb-main-file nil "Source file from which program execution begins.")
2062
2063 (defun gdb-view-source-function ()
2064   (interactive)
2065   (if gdb-view-source
2066       (if gud-last-last-frame
2067           (set-window-buffer gdb-source-window
2068                              (gud-find-file (car gud-last-last-frame)))
2069         (set-window-buffer gdb-source-window (gud-find-file gdb-main-file))))
2070   (setq gdb-selected-view 'source))
2071
2072 (defun gdb-view-assembler()
2073   (interactive)
2074   (set-window-buffer gdb-source-window
2075                      (gdb-get-create-buffer 'gdb-assembler-buffer))
2076   (setq gdb-selected-view 'assembler))
2077
2078 ;(defun gdb-view-both()
2079 ;(interactive)
2080 ;(setq gdb-selected-view 'both))
2081
2082 ;; layout for all the windows
2083 (defun gdb-setup-windows ()
2084   (gdb-display-locals-buffer)
2085   (gdb-display-stack-buffer)
2086   (delete-other-windows)
2087   (gdb-display-breakpoints-buffer)
2088   (gdb-display-display-buffer)
2089   (delete-other-windows)
2090   (switch-to-buffer gud-comint-buffer)
2091   (split-window nil ( / ( * (window-height) 3) 4))
2092   (split-window nil ( / (window-height) 3))
2093   (split-window-horizontally)
2094   (other-window 1)
2095   (switch-to-buffer (gdb-locals-buffer-name))
2096   (other-window 1)
2097   (if (and gdb-view-source
2098            (eq gdb-selected-view 'source))
2099       (switch-to-buffer
2100        (if gud-last-last-frame
2101            (gud-find-file (car gud-last-last-frame))
2102          (gud-find-file gdb-main-file)))
2103     (switch-to-buffer (gdb-get-create-buffer 'gdb-assembler-buffer)))
2104   (setq gdb-source-window (get-buffer-window (current-buffer)))
2105   (split-window-horizontally)
2106   (other-window 1)
2107   (switch-to-buffer (gdb-inferior-io-name))
2108   (other-window 1)
2109   (switch-to-buffer (gdb-stack-buffer-name))
2110   (split-window-horizontally)
2111   (other-window 1)
2112   (switch-to-buffer (gdb-breakpoints-buffer-name))
2113   (other-window 1))
2114
2115 (defcustom gdb-many-windows nil
2116   "Nil means that gdb starts with just two windows : the GUD and
2117 the source buffer."
2118   :type 'boolean
2119   :group 'gud)
2120
2121 (defun gdb-many-windows (arg)
2122 "Toggle the number of windows in the basic arrangement."
2123   (interactive "P")
2124   (setq gdb-many-windows
2125         (if (null arg)
2126             (not gdb-many-windows)
2127           (> (prefix-numeric-value arg) 0)))
2128   (gdb-restore-windows))
2129
2130 (defun gdb-restore-windows ()
2131   "Restore the basic arrangement of windows used by gdba.
2132 This arrangement depends on the value of `gdb-many-windows'."
2133   (interactive)
2134   (if gdb-many-windows
2135       (progn
2136         (switch-to-buffer gud-comint-buffer)
2137         (delete-other-windows)
2138         (gdb-setup-windows))
2139     (switch-to-buffer gud-comint-buffer)
2140     (delete-other-windows)
2141     (split-window)
2142     (other-window 1)
2143     (if (and gdb-view-source
2144            (eq gdb-selected-view 'source))
2145         (switch-to-buffer
2146          (if gud-last-last-frame
2147              (gud-find-file (car gud-last-last-frame))
2148            (gud-find-file gdb-main-file)))
2149       (switch-to-buffer (gdb-get-create-buffer 'gdb-assembler-buffer)))
2150     (setq gdb-source-window (get-buffer-window (current-buffer)))
2151     (other-window 1)))
2152
2153 (defun gdb-reset ()
2154   "Exit a debugging session cleanly by killing the gdb buffers and resetting
2155  the source buffers."
2156   (gdb-delete-frames '())
2157   (dolist (buffer (buffer-list))
2158     (if (not (eq buffer gud-comint-buffer))
2159         (with-current-buffer buffer
2160           (if (eq gud-minor-mode 'gdba)
2161               (if (string-match "^\*.+*$" (buffer-name))
2162                   (kill-buffer nil)
2163                 (if (eq window-system 'x)
2164                     (remove-images (point-min) (point-max))
2165                   (gdb-remove-strings (point-min) (point-max)))
2166                 (setq left-margin-width 0)
2167                 (setq gud-minor-mode nil)
2168                 (kill-local-variable 'tool-bar-map)
2169                 (setq gud-running nil)
2170                 (if (get-buffer-window (current-buffer))
2171                     (set-window-margins (get-buffer-window
2172                                          (current-buffer))
2173                                         left-margin-width
2174                                         right-margin-width))))))))
2175
2176 (defun gdb-source-info ()
2177   "Find the source file where the program starts and displays it with related
2178 buffers."
2179   (goto-char (point-min))
2180   (if (search-forward "directory is " nil t)
2181       (progn
2182         (if (looking-at "\\S-*:\\(\\S-*\\)")
2183             (setq gdb-cdir (match-string 1))
2184           (looking-at "\\S-*")
2185           (setq gdb-cdir (match-string 0)))
2186         (search-forward "Located in ")
2187         (looking-at "\\S-*")
2188         (setq gdb-main-file (match-string 0)))
2189     (setq gdb-view-source nil))
2190   (delete-other-windows)
2191   (switch-to-buffer gud-comint-buffer)
2192   (if gdb-many-windows
2193       (gdb-setup-windows)
2194     (gdb-display-breakpoints-buffer)
2195     (gdb-display-display-buffer)
2196     (delete-other-windows)
2197     (split-window)
2198     (other-window 1)
2199     (if gdb-view-source
2200       (switch-to-buffer
2201        (if gud-last-last-frame
2202            (gud-find-file (car gud-last-last-frame))
2203          (gud-find-file gdb-main-file)))
2204       (switch-to-buffer (gdb-get-create-buffer 'gdb-assembler-buffer))
2205       (gdb-invalidate-assembler))
2206     (setq gdb-source-window (get-buffer-window (current-buffer)))
2207     (other-window 1)))
2208
2209 ;;from put-image
2210 (defun gdb-put-string (putstring pos)
2211   "Put string PUTSTRING in front of POS in the current buffer.
2212 PUTSTRING is displayed by putting an overlay into the current buffer with a
2213 `before-string' STRING that has a `display' property whose value is
2214 PUTSTRING."
2215   (setq string "x")
2216   (let ((buffer (current-buffer)))
2217     (setq string (copy-sequence string))
2218     (let ((overlay (make-overlay pos pos buffer))
2219           (prop (list (list 'margin 'left-margin) putstring)))
2220       (put-text-property 0 (length string) 'display prop string)
2221       (overlay-put overlay 'put-break t)
2222       (overlay-put overlay 'before-string string))))
2223
2224 ;;from remove-images
2225 (defun gdb-remove-strings (start end &optional buffer)
2226   "Remove strings between START and END in BUFFER.
2227 Remove only strings that were put in BUFFER with calls to `put-string'.
2228 BUFFER nil or omitted means use the current buffer."
2229   (unless buffer
2230     (setq buffer (current-buffer)))
2231   (let ((overlays (overlays-in start end)))
2232     (while overlays
2233       (let ((overlay (car overlays)))
2234         (when (overlay-get overlay 'put-break)
2235           (delete-overlay overlay)))
2236       (setq overlays (cdr overlays)))))
2237
2238 (defun gdb-put-arrow (putstring pos)
2239   "Put arrow string PUTSTRING in the left margin in front of POS
2240 in the current buffer.  PUTSTRING is displayed by putting an
2241 overlay into the current buffer with a `before-string'
2242 \"gdb-arrow\" that has a `display' property whose value is
2243 PUTSTRING. STRING is defaulted if you omit it.  POS may be an
2244 integer or marker."
2245   (setq string "gdb-arrow")
2246   (let ((buffer (current-buffer)))
2247     (setq string (copy-sequence string))
2248     (let ((overlay (make-overlay pos pos buffer))
2249           (prop (list (list 'margin 'left-margin) putstring)))
2250       (put-text-property 0 (length string) 'display prop string)
2251       (overlay-put overlay 'put-arrow t)
2252       (overlay-put overlay 'before-string string))))
2253
2254 (defun gdb-remove-arrow (&optional buffer)
2255   "Remove arrow in BUFFER.
2256 Remove only images that were put in BUFFER with calls to `put-arrow'.
2257 BUFFER nil or omitted means use the current buffer."
2258   (unless buffer
2259     (setq buffer (current-buffer)))
2260   (let ((overlays (overlays-in (point-min) (point-max))))
2261     (while overlays
2262       (let ((overlay (car overlays)))
2263         (when (overlay-get overlay 'put-arrow)
2264           (delete-overlay overlay)))
2265       (setq overlays (cdr overlays)))))
2266
2267 (defun gdb-array-visualise ()
2268   "Visualise arrays and slices using graph program from plotutils."
2269   (interactive)
2270   (when (and (display-graphic-p) gdb-display-string)
2271     (let ((n 0) m)
2272       (catch 'multi-dimensional
2273         (while (eq (aref gdb-array-start n) (aref gdb-array-stop n))
2274           (setq n (+ n 1)))
2275         (setq m (+ n 1))
2276         (while (< m (length gdb-array-start))
2277           (if (not (eq (aref gdb-array-start m) (aref gdb-array-stop m)))
2278               (progn
2279                 (x-popup-dialog
2280                  t `(,(concat "Only one dimensional data can be visualised.\n"
2281                               "Use an array slice to reduce the number of\n"
2282                               "dimensions") ("OK" t)))
2283                 (throw 'multi-dimensional nil))
2284             (setq m (+ m 1))))
2285         (shell-command (concat "echo" gdb-display-string " | graph -a 1 "
2286                                (int-to-string (aref gdb-array-start n))
2287                                " -x "
2288                                (int-to-string (aref gdb-array-start n))
2289                                " "
2290                                (int-to-string (aref gdb-array-stop  n))
2291                                " 1 -T X"))))))
2292
2293 (defun gdb-delete-expression ()
2294   "Delete displayed expression and its frame."
2295   (interactive)
2296   (gdb-enqueue-input
2297    (list (concat "server delete display " gdb-display-number "\n")
2298          'ignore)))
2299 \f
2300 ;;
2301 ;; Assembler buffer.
2302 ;;
2303 (gdb-set-buffer-rules 'gdb-assembler-buffer
2304                       'gdb-assembler-buffer-name
2305                       'gdb-assembler-mode)
2306
2307 (def-gdb-auto-updated-buffer gdb-assembler-buffer
2308   gdb-invalidate-assembler
2309   (concat "server disassemble " gdb-current-address "\n")
2310   gdb-assembler-handler
2311   gdb-assembler-custom)
2312
2313 (defun gdb-assembler-custom ()
2314   (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer))
2315         (gdb-arrow-position 1) (address) (flag))
2316     (with-current-buffer buffer
2317       (if (not (equal gdb-current-address "main"))
2318           (progn
2319             (gdb-remove-arrow)
2320             (goto-char (point-min))
2321             (if (re-search-forward gdb-current-address nil t)
2322                 (progn
2323                   (setq gdb-arrow-position (point))
2324                   (gdb-put-arrow "=>" (point))))))
2325       ;; remove all breakpoint-icons in assembler buffer before updating.
2326       (if (eq window-system 'x)
2327           (remove-images (point-min) (point-max))
2328         (gdb-remove-strings (point-min) (point-max))))
2329     (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
2330       (goto-char (point-min))
2331       (while (< (point) (- (point-max) 1))
2332         (forward-line 1)
2333         (if (looking-at "[^\t].*breakpoint")
2334             (progn
2335               (looking-at
2336                "[0-9]*\\s-*\\S-*\\s-*\\S-*\\s-*\\(.\\)\\s-*0x\\(\\S-*\\)")
2337               (setq flag (char-after (match-beginning 1)))
2338               (setq address (match-string 2))
2339               ;; remove leading 0s from output of info break.
2340               (if (string-match "^0+\\(.*\\)" address)
2341                   (setq address (match-string 1 address)))
2342               (with-current-buffer buffer
2343                   (goto-char (point-min))
2344                   (if (re-search-forward address nil t)
2345                       (let ((start (progn (beginning-of-line) (- (point) 1)))
2346                             (end (progn (end-of-line) (+ (point) 1))))
2347                         (if (eq window-system 'x)
2348                             (progn
2349                               (remove-images start end)
2350                               (if (eq ?y flag)
2351                                   (put-image breakpoint-enabled-icon
2352                                              (+ start 1)
2353                                              "breakpoint icon enabled"
2354                                              'left-margin)
2355                                 (put-image breakpoint-disabled-icon
2356                                            (+ start 1)
2357                                            "breakpoint icon disabled"
2358                                            'left-margin)))
2359                           (gdb-remove-strings start end)
2360                           (if (eq ?y flag)
2361                               (gdb-put-string "B" (+ start 1))
2362                             (gdb-put-string "b" (+ start 1)))))))))))
2363     (if (not (equal gdb-current-address "main"))
2364         (set-window-point (get-buffer-window buffer) gdb-arrow-position))))
2365
2366 (defvar gdb-assembler-mode-map
2367   (let ((map (make-sparse-keymap)))
2368     (suppress-keymap map)
2369     map))
2370
2371 (defun gdb-assembler-mode ()
2372   "Major mode for viewing code assembler.
2373
2374 \\{gdb-assembler-mode-map}"
2375   (setq major-mode 'gdb-assembler-mode)
2376   (setq mode-name "Assembler")
2377   (setq left-margin-width 2)
2378   (setq fringes-outside-margins t)
2379   (setq buffer-read-only t)
2380   (use-local-map gdb-assembler-mode-map)
2381   (gdb-invalidate-assembler)
2382   (gdb-invalidate-breakpoints))
2383
2384 (defun gdb-assembler-buffer-name ()
2385   (with-current-buffer gud-comint-buffer
2386     (concat "*Machine Code " (gdb-get-target-string) "*")))
2387
2388 (defun gdb-display-assembler-buffer ()
2389   (interactive)
2390   (gdb-display-buffer
2391    (gdb-get-create-buffer 'gdb-assembler-buffer)))
2392
2393 (defun gdb-frame-assembler-buffer ()
2394   (interactive)
2395   (switch-to-buffer-other-frame
2396    (gdb-get-create-buffer 'gdb-assembler-buffer)))
2397
2398 ;; modified because if gdb-current-address has changed value a new command
2399 ;; must be enqueued to update the buffer with the new output
2400 (defun gdb-invalidate-assembler (&optional ignored)
2401   (if (gdb-get-buffer 'gdb-assembler-buffer)
2402       (progn
2403         (if (string-equal gdb-current-frame gdb-previous-frame)
2404             (gdb-assembler-custom)
2405           (if (or (not (member 'gdb-invalidate-assembler
2406                                (gdb-get-pending-triggers)))
2407                   (not (string-equal gdb-current-address
2408                                      gdb-previous-address)))
2409           (progn
2410             ;; take previous disassemble command off the queue
2411             (with-current-buffer gud-comint-buffer
2412               (let ((queue (gdb-get-idle-input-queue)) (item))
2413                 (dolist (item queue)
2414                   (if (equal (cdr item) '(gdb-assembler-handler))
2415                       (gdb-set-idle-input-queue
2416                        (delete item (gdb-get-idle-input-queue)))))))
2417             (gdb-enqueue-idle-input
2418              (list (concat "server disassemble " gdb-current-address "\n")
2419                    'gdb-assembler-handler))
2420             (gdb-set-pending-triggers
2421              (cons 'gdb-invalidate-assembler
2422                    (gdb-get-pending-triggers)))
2423             (setq gdb-previous-address gdb-current-address)
2424             (setq gdb-previous-frame gdb-current-frame)))))))
2425
2426 (defun gdb-get-current-frame ()
2427   (if (not (member 'gdb-get-current-frame (gdb-get-pending-triggers)))
2428       (progn
2429         (gdb-enqueue-idle-input
2430          (list (concat "server info frame\n") 'gdb-frame-handler))
2431         (gdb-set-pending-triggers
2432          (cons 'gdb-get-current-frame
2433                (gdb-get-pending-triggers))))))
2434
2435 (defun gdb-frame-handler ()
2436   (gdb-set-pending-triggers
2437    (delq 'gdb-get-current-frame (gdb-get-pending-triggers)))
2438   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
2439     (goto-char (point-min))
2440     (forward-line)
2441     (if (looking-at ".*= 0x\\(\\S-*\\) in \\(\\S-*\\)")
2442         (progn
2443           (setq gdb-current-frame (match-string 2))
2444           (let ((address (match-string 1)))
2445             ;; remove leading 0s from output of info frame command.
2446             (if (string-match "^0+\\(.*\\)" address)
2447                 (setq gdb-current-address
2448                       (concat "0x" (match-string 1 address)))
2449               (setq gdb-current-address (concat "0x" address))))
2450           (if (or (if (not (looking-at ".*(\\S-*:[0-9]*)"))
2451                       (progn (setq gdb-view-source nil) t))
2452                   (eq gdb-selected-view 'assembler))
2453               (progn
2454                 (set-window-buffer
2455                  gdb-source-window
2456                  (gdb-get-create-buffer 'gdb-assembler-buffer))
2457                 (gdb-invalidate-assembler)))))))
2458
2459 (provide 'gdb-ui)
2460
2461 ;;; gdb-ui.el ends here