lisp/gdb-ui.el

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