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