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