gdb/mi/gdb-mi.el

   1 ;;; gdb-mi.el
   2
   3 ;; Author: Nick Roberts <nickrob@gnu.org>
   4 ;; Maintainer: Nick Roberts <nickrob@gnu.org>
   5 ;; Keywords: unix, tools
   6
   7 ;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
   8
   9 ;; This file is part of GNU GDB.
  10
  11 ;; GNU GDB 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 ;; This program 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 ;;; Commentary:
  22
  23 ;; This mode acts as a graphical user interface to GDB and works with Emacs
  24 ;; 22.x and the version of GDB with which it is distributed.  You can interact
  25 ;; with GDB through the GUD buffer in the usual way, but there are also
  26 ;; buffers which control the execution and describe the state of your program.
  27 ;; It separates the input/output of your program from that of GDB and displays
  28 ;; expressions and their current values in their own buffers.  It also uses
  29 ;; features of Emacs 21 such as the fringe/display margin for breakpoints, and
  30 ;; the toolbar (see the GDB Graphical Interface section in the Emacs info
  31 ;; manual).
  32
  33 ;; Start the debugger with M-x gdbmi.
  34
  35 ;; This file uses GDB/MI as the primary interface to GDB. It is still under
  36 ;; development and is part of a process to migrate Emacs from annotations (as
  37 ;; used in gdb-ui.el) to GDB/MI.  It runs gdb with GDB/MI (-interp=mi) and
  38 ;; access CLI using "-interpreter-exec console cli-command".
  39 ;;
  40 ;; Known Bugs:
  41 ;;
  42 ;; 1) To handle program input, if required, and to avoid extra output in the
  43 ;; GUD buffer you must not use run, step, next or continue etc but their MI
  44 ;; counterparts through gud-run, gud-step etc, e.g clicking on the appropriate
  45 ;; icon in the toolbar.
  46 ;;
  47 ;; 2) Some commands send extra prompts to the GUD buffer.
  48 ;;
  49 ;; TODO:
  50 ;; 1) Prefix MI commands with a token instead of queueing commands.
  51 ;; 2) Use MI command -data-read-memory for memory window.
  52 ;; 3) Use MI command -data-disassemble for disassembly window.
  53 ;; 4) Allow separate buffers for Inferior IO and GDB IO.
  54 ;; 5) Watch windows to work with threads.
  55 ;;
  56 ;;; Code:
  57
  58 (require 'gud)
  59 (require 'gdb-ui)
  60
  61 (defvar gdb-register-names nil "List of register names.")
  62 (defvar gdb-changed-registers nil
  63   "List of changed register numbers (strings).")
  64 (defvar gdb-last-command nil)
  65 (defvar gdb-prompt-name nil)
  66
  67 ;;;###autoload
  68 (defun gdbmi (command-line)
  69   "Run gdb on program FILE in buffer *gud-FILE*.
  70 The directory containing FILE becomes the initial working directory
  71 and source-file directory for your debugger.
  72
  73 If `gdb-many-windows' is nil (the default value) then gdb just
  74 pops up the GUD buffer unless `gdb-show-main' is t. In this case
  75 it starts with two windows: one displaying the GUD buffer and the
  76 other with the source file with the main routine of the inferior.
  77
  78 If `gdb-many-windows' is t, regardless of the value of
  79 `gdb-show-main', the layout below will appear. Keybindings are
  80 given in relevant buffer.
  81
  82 Watch expressions appear in the speedbar/slowbar.
  83
  84 The following interactive lisp functions help control operation :
  85
  86 `gdb-many-windows'    - Toggle the number of windows gdb uses.
  87 `gdb-restore-windows' - To restore the window layout.
  88
  89 See Info node `(emacs)GDB Graphical Interface' for a more
  90 detailed description of this mode.
  91
  92
  93 ---------------------------------------------------------------------
  94                                GDB Toolbar
  95 ---------------------------------------------------------------------
  96 GUD buffer (I/O of GDB)           | Locals buffer
  97                                   |
  98                                   |
  99                                   |
 100 ---------------------------------------------------------------------
 101  Source buffer                    | Input/Output (of inferior) buffer
 102                                   | (comint-mode)
 103                                   |
 104                                   |
 105                                   |
 106                                   |
 107                                   |
 108                                   |
 109 ---------------------------------------------------------------------
 110  Stack buffer                     | Breakpoints buffer
 111  RET      gdb-frames-select       | SPC    gdb-toggle-breakpoint
 112                                   | RET    gdb-goto-breakpoint
 113                                   |   d    gdb-delete-breakpoint
 114 ---------------------------------------------------------------------
 115 "
 116   ;;
 117   (interactive (list (gud-query-cmdline 'gdbmi)))
 118   ;;
 119   ;; Let's start with a basic gud-gdb buffer and then modify it a bit.
 120   (gdb command-line)
 121   ;;
 122   (setq gdb-debug-log nil)
 123   (set (make-local-variable 'gud-minor-mode) 'gdbmi)
 124   (set (make-local-variable 'gud-marker-filter) 'gud-gdbmi-marker-filter)
 125   ;;
 126   (gud-def gud-step   "-exec-step %p"              "\C-s"
 127            "Step one source line with display.")
 128   (gud-def gud-stepi  "-exec-step-instruction %p"  "\C-i"
 129            "Step one instruction with display.")
 130   (gud-def gud-next   "-exec-next %p"              "\C-n"
 131            "Step one line (skip functions).")
 132   (gud-def gud-cont   "-exec-continue"             "\C-r"
 133            "Continue with display.")
 134   (gud-def gud-finish "-exec-finish"               "\C-f"
 135            "Finish executing current function.")
 136   (gud-def gud-run    "-exec-run"            nil    "Run the program.")
 137   (gud-def gud-break (if (not (string-equal mode-name "Machine"))
 138                          (gud-call "break %f:%l" arg)
 139                        (save-excursion
 140                          (beginning-of-line)
 141                          (forward-char 2)
 142                          (gud-call "break *%a" arg)))
 143            "\C-b" "Set breakpoint at current line or address.")
 144   ;;
 145   (gud-def gud-remove (if (not (string-equal mode-name "Machine"))
 146                           (gud-call "clear %f:%l" arg)
 147                         (save-excursion
 148                           (beginning-of-line)
 149                           (forward-char 2)
 150                           (gud-call "clear *%a" arg)))
 151            "\C-d" "Remove breakpoint at current line or address.")
 152   ;;
 153   (gud-def gud-until  (if (not (string-equal mode-name "Machine"))
 154                           (gud-call "-exec-until %f:%l" arg)
 155                         (save-excursion
 156                           (beginning-of-line)
 157                           (forward-char 2)
 158                           (gud-call "-exec-until *%a" arg)))
 159            "\C-u" "Continue to current line or address.")
 160
 161   (define-key gud-minor-mode-map [left-margin mouse-1]
 162     'gdb-mouse-set-clear-breakpoint)
 163   (define-key gud-minor-mode-map [left-fringe mouse-1]
 164     'gdb-mouse-set-clear-breakpoint)
 165   (define-key gud-minor-mode-map [left-margin mouse-3]
 166     'gdb-mouse-toggle-breakpoint)
 167
 168   (setq comint-input-sender 'gdbmi-send)
 169   ;;
 170   ;; (re-)initialise
 171   (setq gdb-frame-address (if gdb-show-main "main" nil)
 172         gdb-previous-frame-address nil
 173         gdb-memory-address "main"
 174         gdb-previous-frame nil
 175         gdb-selected-frame nil
 176         gdb-frame-number nil
 177         gdb-var-list nil
 178         gdb-var-changed nil
 179         gdb-prompting nil
 180         gdb-input-queue nil
 181         gdb-current-item nil
 182         gdb-pending-triggers nil
 183         gdb-output-sink 'user
 184         gdb-server-prefix nil
 185         gdb-flush-pending-output nil
 186         gdb-location-alist nil
 187         gdb-find-file-unhook nil
 188         gdb-source-file-list nil
 189         gdb-last-command nil
 190         gdb-prompt-name nil)
 191   ;;
 192   (setq gdb-buffer-type 'gdbmi)
 193   ;;
 194   ;; FIXME: use tty command to separate io.
 195   ;;(gdb-clear-inferior-io)
 196   ;;
 197   (if (eq window-system 'w32)
 198       (gdb-enqueue-input (list "-gdb-set new-console off\n" 'ignore)))
 199   (gdb-enqueue-input (list "-gdb-set height 0\n" 'ignore))
 200   ;; find source file and compilation directory here
 201   (gdb-enqueue-input
 202    ; Needs GDB 6.2 onwards.
 203    (list "-file-list-exec-source-files\n" 'gdb-get-source-file-list))
 204   (gdb-enqueue-input
 205    ; Needs GDB 6.0 onwards.
 206    (list "-file-list-exec-source-file\n" 'gdb-get-source-file))
 207   (gdb-enqueue-input
 208    (list "-data-list-register-names\n" 'gdb-get-register-names))
 209   (gdb-enqueue-input
 210    (list "-gdb-show prompt\n" 'gdb-get-prompt))
 211   ;;
 212   (run-hooks 'gdbmi-mode-hook))
 213
 214 ; Force nil till fixed.
 215 (defconst gdbmi-use-inferior-io-buffer nil)
 216
 217 ; Uses "-var-list-children --all-values".  Needs GDB 6.1 onwards.
 218 (defun gdbmi-var-list-children (varnum)
 219   (gdb-enqueue-input
 220    (list (concat "-var-list-children --all-values "
 221                  varnum "\n")
 222              `(lambda () (gdbmi-var-list-children-handler ,varnum)))))
 223
 224 (defconst gdbmi-var-list-children-regexp
 225 "name=\"\\(.*?\\)\",exp=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",\
 226 value=\"\\(.*?\\)\"")
 227
 228 (defun gdbmi-var-list-children-handler (varnum)
 229   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 230     (goto-char (point-min))
 231     (let ((var-list nil))
 232      (catch 'child-already-watched
 233        (dolist (var gdb-var-list)
 234          (if (string-equal varnum (cadr var))
 235              (progn
 236                (push var var-list)
 237                (while (re-search-forward gdbmi-var-list-children-regexp nil t)
 238                  (let ((varchild (list (match-string 2)
 239                                        (match-string 1)
 240                                        (match-string 3)
 241                                        nil
 242                                        (match-string 4)
 243                                        nil)))
 244                    (if (looking-at ",type=\"\\(.*?\\)\"")
 245                        (setcar (nthcdr 3 varchild) (match-string 1)))
 246                    (dolist (var1 gdb-var-list)
 247                      (if (string-equal (cadr var1) (cadr varchild))
 248                          (throw 'child-already-watched nil)))
 249                    (push varchild var-list))))
 250            (push var var-list)))
 251        (setq gdb-var-changed t)
 252        (setq gdb-var-list (nreverse var-list))))))
 253
 254 ; Uses "-var-update --all-values".  Needs CVS GDB (6.4+).
 255 (defun gdbmi-var-update ()
 256   (gdb-enqueue-input
 257    (list "-var-update --all-values *\n" 'gdbmi-var-update-handler)))
 258
 259 (defconst gdbmi-var-update-regexp "name=\"\\(.*?\\)\",value=\"\\(.*?\\)\"")
 260
 261 (defun gdbmi-var-update-handler ()
 262   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 263     (goto-char (point-min))
 264     (while (re-search-forward gdbmi-var-update-regexp nil t)
 265         (let ((varnum (match-string 1)))
 266           (catch 'var-found1
 267             (let ((num 0))
 268               (dolist (var gdb-var-list)
 269                 (if (string-equal varnum (cadr var))
 270                     (progn
 271                       (setcar (nthcdr 5 var) t)
 272                       (setcar (nthcdr 4 var) (match-string 2))
 273                       (setcar (nthcdr num gdb-var-list) var)
 274                       (throw 'var-found1 nil)))
 275                 (setq num (+ num 1))))))
 276         (setq gdb-var-changed t))))
 277 \f
 278 (defun gdbmi-send (proc string)
 279   "A comint send filter for gdb."
 280   (if gud-running
 281       (process-send-string proc (concat string "\n"))
 282     (with-current-buffer gud-comint-buffer
 283       (remove-text-properties (point-min) (point-max) '(face)))
 284     (setq gdb-output-sink 'user)
 285     (setq gdb-prompting nil)
 286     ;; mimic <RET> key to repeat previous command in GDB
 287     (if (string-match "\\S+" string)
 288         (setq gdb-last-command string)
 289       (if gdb-last-command (setq string gdb-last-command)))
 290     (if gdb-enable-debug-log
 291         (push (cons 'mi-send (concat string "\n")) gdb-debug-log))
 292     (process-send-string
 293      proc
 294      (if (string-match "^-" string)
 295          ;; MI command
 296          (concat string "\n")
 297        ;; CLI command
 298        (concat "-interpreter-exec console \"" string "\"\n")))))
 299
 300 (defcustom gud-gdbmi-command-name "gdb -interp=mi"
 301   "Default command to execute an executable under the GDB-UI debugger."
 302   :type 'string
 303   :group 'gud)
 304
 305 (defconst gdb-gdb-regexp "(gdb) \n")
 306
 307 (defconst gdb-running-regexp (concat "\\^running\n" gdb-gdb-regexp))
 308
 309 ;; fullname added GDB 6.4+.
 310 ;; Probably not needed. -stack-info-frame computes filename and line.
 311 (defconst gdb-stopped-regexp
 312   "\\*stopped,reason=.*?,file=\".*?\"\
 313 ,fullname=\"\\(.*?\\)\",line=\"\\(.*?\\)\"}\n")
 314
 315 (defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)\n")
 316
 317 (defconst gdb-done-regexp "\\^done,*\n*")
 318
 319 (defconst gdb-console-regexp "~\\(\".*?[^\\]\"\\)\n")
 320
 321 (defconst gdb-internals-regexp "&\\(\".*?\\n\"\\)\n")
 322
 323 (defun gdbmi-prompt1 ()
 324   "Queue any GDB commands that the user interface needs."
 325   (unless gdb-pending-triggers
 326     (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
 327       (setq gdb-var-changed t)   ; force update
 328       (dolist (var gdb-var-list)
 329         (setcar (nthcdr 5 var) nil))
 330       (gdbmi-var-update))
 331     (gdbmi-get-selected-frame)
 332     (gdbmi-invalidate-frames)
 333     (gdbmi-invalidate-breakpoints)
 334     (gdb-get-changed-registers)
 335     (gdbmi-invalidate-registers)
 336     (gdbmi-invalidate-locals)))
 337
 338 (defun gdbmi-prompt2 ()
 339   "Handle any output and send next GDB command."
 340   (let ((sink gdb-output-sink))
 341     (when (eq sink 'emacs)
 342       (let ((handler
 343              (car (cdr gdb-current-item))))
 344         (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 345           (funcall handler)))))
 346   (let ((input (gdb-dequeue-input)))
 347     (if input
 348         (gdb-send-item input)
 349       (progn
 350         (setq gud-running nil)
 351         (setq gdb-prompting t)
 352         (gud-display-frame)))))
 353
 354 (defun gud-gdbmi-marker-filter (string)
 355   "Filter GDB/MI output."
 356   (if gdb-flush-pending-output
 357       nil
 358     (if gdb-enable-debug-log (push (cons 'recv (list string gdb-output-sink))
 359                                          gdb-debug-log))
 360     ;; Recall the left over gud-marker-acc from last time
 361     (setq gud-marker-acc (concat gud-marker-acc string))
 362     ;; Start accumulating output for the GUD buffer
 363     (let ((output ""))
 364
 365       (if (string-match gdb-running-regexp gud-marker-acc)
 366           (setq
 367            gud-marker-acc
 368            (concat (substring gud-marker-acc 0 (match-beginning 0))
 369                    (substring gud-marker-acc (match-end 0)))
 370                 gud-running t))
 371
 372       (if (string-match gdb-stopped-regexp gud-marker-acc)
 373           (setq
 374
 375            ;; Extract the frame position from the marker.
 376            gud-last-frame (cons (match-string 1 gud-marker-acc)
 377                                 (string-to-number
 378                                  (match-string 2 gud-marker-acc)))
 379
 380            gud-marker-acc
 381            (concat (substring gud-marker-acc 0 (match-beginning 0))
 382                    (substring gud-marker-acc (match-end 0)))))
 383
 384       ;; Filter error messages going to GUD buffer and
 385       ;; display in minibuffer.
 386       (if (eq gdb-output-sink 'user)
 387           (while (string-match gdb-error-regexp gud-marker-acc)
 388             (message (read (match-string 1 gud-marker-acc)))
 389             (setq
 390              gud-marker-acc
 391              (concat (substring gud-marker-acc 0 (match-beginning 0))
 392                      (substring gud-marker-acc (match-end 0))))))
 393
 394       (if (string-match gdb-done-regexp gud-marker-acc)
 395           (setq
 396            gud-marker-acc
 397            (concat (substring gud-marker-acc 0 (match-beginning 0))
 398                    (substring gud-marker-acc (match-end 0)))))
 399
 400       (when (string-match gdb-gdb-regexp gud-marker-acc)
 401         (setq
 402          gud-marker-acc
 403          (concat (substring gud-marker-acc 0 (match-beginning 0))
 404                    (substring gud-marker-acc (match-end 0))))
 405
 406         ;; Remove the trimmings from the console stream.
 407         (while (string-match gdb-console-regexp gud-marker-acc)
 408           (setq
 409            gud-marker-acc (concat
 410                            (substring gud-marker-acc 0 (match-beginning 0))
 411                            (read (match-string 1 gud-marker-acc))
 412                            (substring gud-marker-acc (match-end 0)))))
 413
 414         ;; Remove the trimmings from log stream containing debugging messages
 415         ;; being produced by GDB's internals and use warning face.
 416         (while (string-match gdb-internals-regexp gud-marker-acc)
 417           (setq
 418            gud-marker-acc
 419            (concat (substring gud-marker-acc 0 (match-beginning 0))
 420                    (let ((error-message
 421                           (read (match-string 1 gud-marker-acc))))
 422                      (put-text-property
 423                       0 (length error-message)
 424                       'face font-lock-warning-face
 425                       error-message)
 426                      error-message)
 427                    (substring gud-marker-acc (match-end 0)))))
 428
 429         (setq output (gdbmi-concat-output output gud-marker-acc))
 430         (setq gud-marker-acc "")
 431         (gdbmi-prompt1)
 432         (unless gdb-input-queue
 433           (setq output (concat output gdb-prompt-name)))
 434         (gdbmi-prompt2))
 435
 436       (when gud-running
 437         (setq output (gdbmi-concat-output output gud-marker-acc))
 438         (setq gud-marker-acc ""))
 439
 440        output)))
 441
 442 (defun gdbmi-concat-output (so-far new)
 443   (let ((sink gdb-output-sink))
 444     (cond
 445      ((eq sink 'user) (concat so-far new))
 446      ((eq sink 'emacs)
 447       (gdb-append-to-partial-output new)
 448       so-far)
 449      ((eq sink 'inferior)
 450       (gdb-append-to-inferior-io new)
 451       so-far))))
 452 \f
 453
 454 ;; Breakpoint buffer : This displays the output of `-break-list'.
 455 ;;
 456 (def-gdb-auto-updated-buffer gdb-breakpoints-buffer
 457   ;; This defines the auto update rule for buffers of type
 458   ;; `gdb-breakpoints-buffer'.
 459   ;;
 460   ;; It defines a function that queues the command below.  That function is
 461   ;; called:
 462   gdbmi-invalidate-breakpoints
 463   ;;
 464   ;; To update the buffer, this command is sent to gdb.
 465   "-break-list\n"
 466   ;;
 467   ;; This also defines a function to be the handler for the output
 468   ;; from the command above.  That function will copy the output into
 469   ;; the appropriately typed buffer.  That function will be called:
 470   gdb-break-list-handler
 471   ;; buffer specific functions
 472   gdb-break-list-custom)
 473
 474 (defconst gdb-break-list-regexp
 475 "number=\"\\(.*?\\)\",type=\"\\(.*?\\)\",disp=\"\\(.*?\\)\",enabled=\"\\(.\\)\",\
 476 addr=\"\\(.*?\\)\",func=\"\\(.*?\\)\",file=\"\\(.*?\\)\",line=\"\\(.*?\\)\"")
 477
 478 (defun gdb-break-list-handler ()
 479   (setq gdb-pending-triggers (delq 'gdbmi-invalidate-breakpoints
 480                                   gdb-pending-triggers))
 481   (let ((breakpoint) (breakpoints-list))
 482     (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 483       (goto-char (point-min))
 484       (while (re-search-forward gdb-break-list-regexp nil t)
 485         (let ((breakpoint (list (match-string 1)
 486                                 (match-string 2)
 487                                 (match-string 3)
 488                                 (match-string 4)
 489                                 (match-string 5)
 490                                 (match-string 6)
 491                                 (match-string 7)
 492                                 (match-string 8))))
 493           (push breakpoint breakpoints-list))))
 494     (let ((buf (gdb-get-buffer 'gdb-breakpoints-buffer)))
 495       (and buf (with-current-buffer buf
 496                  (let ((p (point))
 497                        (buffer-read-only nil))
 498                    (erase-buffer)
 499                    (insert "Num Type        Disp Enb Func\tFile:Line\tAddr\n")
 500                    (dolist (breakpoint breakpoints-list)
 501                      (insert (concat
 502                               (nth 0 breakpoint) "   "
 503                               (nth 1 breakpoint) "  "
 504                               (nth 2 breakpoint) "   "
 505                               (nth 3 breakpoint) " "
 506                               (nth 5 breakpoint) "\t"
 507                               (nth 6 breakpoint) ":" (nth 7 breakpoint) "\t"
 508                               (nth 4 breakpoint) "\n")))
 509                    (goto-char p))))))
 510   (gdb-break-list-custom))
 511
 512 ;;-put breakpoint icons in relevant margins (even those set in the GUD buffer)
 513 (defun gdb-break-list-custom ()
 514   (let ((flag) (bptno))
 515     ;;
 516     ;; remove all breakpoint-icons in source buffers but not assembler buffer
 517     (dolist (buffer (buffer-list))
 518       (with-current-buffer buffer
 519         (if (and (eq gud-minor-mode 'gdbmi)
 520                  (not (string-match "\\`\\*.+\\*\\'" (buffer-name))))
 521             (gdb-remove-breakpoint-icons (point-min) (point-max)))))
 522     (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
 523       (save-excursion
 524         (goto-char (point-min))
 525         (while (< (point) (- (point-max) 1))
 526           (forward-line 1)
 527           (if (looking-at
 528                "\\([0-9]+\\)\\s-+\\S-+\\s-+\\S-+\\s-+\\(.\\)\\s-+\\S-+\\s-+\
 529 \\(\\S-+\\):\\([0-9]+\\)")
 530               (progn
 531                 (setq bptno (match-string 1))
 532                 (setq flag (char-after (match-beginning 2)))
 533                 (let ((line (match-string 4)) (buffer-read-only nil)
 534                       (file (match-string 3)))
 535                   (add-text-properties (point-at-bol) (point-at-eol)
 536                    '(mouse-face highlight
 537                      help-echo "mouse-2, RET: visit breakpoint"))
 538                         (unless (file-exists-p file)
 539                            (setq file (cdr (assoc bptno gdb-location-alist))))
 540                         (if (and file
 541                                  (not (string-equal file "File not found")))
 542                             (with-current-buffer (find-file-noselect file)
 543                               (set (make-local-variable 'gud-minor-mode)
 544                                    'gdbmi)
 545                               (set (make-local-variable 'tool-bar-map)
 546                                    gud-tool-bar-map)
 547                               ;; only want one breakpoint icon at each location
 548                               (save-excursion
 549                                 (goto-line (string-to-number line))
 550                                 (gdb-put-breakpoint-icon (eq flag ?y) bptno)))
 551                           (gdb-enqueue-input
 552                            (list (concat "list "
 553                                          (match-string-no-properties 3) ":1\n")
 554                                  'ignore))
 555                           (gdb-enqueue-input
 556                            (list "-file-list-exec-source-file\n"
 557                                  `(lambda () (gdbmi-get-location
 558                                               ,bptno ,line ,flag))))))))))
 559       (end-of-line)))
 560   (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)))
 561
 562 (defun gdbmi-get-location (bptno line flag)
 563   "Find the directory containing the relevant source file.
 564 Put in buffer and place breakpoint icon."
 565   (goto-char (point-min))
 566   (catch 'file-not-found
 567     (if (re-search-forward gdb-source-file-regexp nil t)
 568         (delete (cons bptno "File not found") gdb-location-alist)
 569         (push (cons bptno (match-string 1)) gdb-location-alist)
 570       (gdb-resync)
 571       (unless (assoc bptno gdb-location-alist)
 572         (push (cons bptno "File not found") gdb-location-alist)
 573         (message-box "Cannot find source file for breakpoint location.
 574 Add directory to search path for source files using the GDB command, dir."))
 575       (throw 'file-not-found nil))
 576     (with-current-buffer
 577         (find-file-noselect (match-string 1))
 578       (save-current-buffer
 579         (set (make-local-variable 'gud-minor-mode) 'gdbmi)
 580         (set (make-local-variable 'tool-bar-map) gud-tool-bar-map))
 581       ;; only want one breakpoint icon at each location
 582       (save-excursion
 583         (goto-line (string-to-number line))
 584         (gdb-put-breakpoint-icon (eq flag ?y) bptno)))))
 585
 586 ;; Frames buffer.  This displays a perpetually correct bactrack trace.
 587 ;;
 588 (def-gdb-auto-updated-buffer gdb-stack-buffer
 589   gdbmi-invalidate-frames
 590   "-stack-list-frames\n"
 591   gdb-stack-list-frames-handler
 592   gdb-stack-list-frames-custom)
 593
 594 (defconst gdb-stack-list-frames-regexp
 595 "level=\"\\(.*?\\)\",addr=\"\\(.*?\\)\",func=\"\\(.*?\\)\",\
 596 file=\".*?\",fullname=\"\\(.*?\\)\",line=\"\\(.*?\\)\"")
 597
 598 (defun gdb-stack-list-frames-handler ()
 599   (setq gdb-pending-triggers (delq 'gdbmi-invalidate-frames
 600                                   gdb-pending-triggers))
 601   (let ((frame nil)
 602         (call-stack nil))
 603     (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 604       (goto-char (point-min))
 605       (while (re-search-forward gdb-stack-list-frames-regexp nil t)
 606         (let ((frame (list (match-string 1)
 607                            (match-string 2)
 608                            (match-string 3)
 609                            (match-string 4)
 610                            (match-string 5))))
 611           (push frame call-stack))))
 612     (let ((buf (gdb-get-buffer 'gdb-stack-buffer)))
 613       (and buf (with-current-buffer buf
 614                  (let ((p (point))
 615                        (buffer-read-only nil))
 616                    (erase-buffer)
 617                    (insert "Level\tFunc\tFile:Line\tAddr\n")
 618                    (dolist (frame (nreverse call-stack))
 619                      (insert (concat
 620                               (nth 0 frame) "\t"
 621                               (nth 2 frame) "\t"
 622                               (nth 3 frame) ":" (nth 4 frame) "\t"
 623                               (nth 1 frame) "\n")))
 624                    (goto-char p))))))
 625   (gdb-stack-list-frames-custom))
 626
 627 (defun gdb-stack-list-frames-custom ()
 628   (with-current-buffer (gdb-get-buffer 'gdb-stack-buffer)
 629     (save-excursion
 630       (let ((buffer-read-only nil))
 631         (goto-char (point-min))
 632         (forward-line 1)
 633         (while (< (point) (point-max))
 634           (add-text-properties (point-at-bol) (point-at-eol)
 635                              '(mouse-face highlight
 636                                help-echo "mouse-2, RET: Select frame"))
 637           (beginning-of-line)
 638           (when (and (looking-at "^[0-9]+\\s-+\\(\\S-+\\)")
 639                      (equal (match-string 1) gdb-selected-frame))
 640             (put-text-property (point-at-bol) (point-at-eol)
 641                                'face '(:inverse-video t)))
 642           (forward-line 1))))))
 643
 644 ;; Locals buffer.
 645 ;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards.
 646 (def-gdb-auto-updated-buffer gdb-locals-buffer
 647   gdbmi-invalidate-locals
 648   "-stack-list-locals --simple-values\n"
 649   gdb-stack-list-locals-handler
 650   gdb-stack-list-locals-custom)
 651
 652 (defconst gdb-stack-list-locals-regexp
 653   (concat "name=\"\\(.*?\\)\",type=\"\\(.*?\\)\""))
 654
 655 ;; Dont display values of arrays or structures.
 656 ;; These can be expanded using gud-watch.
 657 (defun gdb-stack-list-locals-handler nil
 658   (setq gdb-pending-triggers (delq 'gdbmi-invalidate-locals
 659                                   gdb-pending-triggers))
 660   (let ((local nil)
 661         (locals-list nil))
 662     (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 663       (goto-char (point-min))
 664       (while (re-search-forward gdb-stack-list-locals-regexp nil t)
 665         (let ((local (list (match-string 1)
 666                            (match-string 2)
 667                            nil)))
 668           (if (looking-at ",value=\"\\(.*?\\)\"")
 669               (setcar (nthcdr 2 local) (match-string 1)))
 670         (push local locals-list))))
 671     (let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
 672       (and buf (with-current-buffer buf
 673                  (let ((p (window-point (get-buffer-window buf 0)))
 674                        (buffer-read-only nil))
 675                    (erase-buffer)
 676                    (dolist (local locals-list)
 677                      (insert
 678                       (concat (car local) "\t" (nth 1 local) "\t"
 679                               (or (nth 2 local)
 680                                   (if (string-match "struct" (nth 1 local))
 681                                       "(structure)"
 682                                     "(array)"))
 683                               "\n")))
 684                    (set-window-point (get-buffer-window buf 0) p)))))))
 685
 686 (defun gdb-stack-list-locals-custom ()
 687   nil)
 688
 689 \f
 690 ;; Registers buffer.
 691 ;;
 692 (def-gdb-auto-updated-buffer gdb-registers-buffer
 693   gdbmi-invalidate-registers
 694   "-data-list-register-values x\n"
 695   gdb-data-list-register-values-handler
 696   gdb-data-list-register-values-custom)
 697
 698 (defconst gdb-data-list-register-values-regexp
 699   "number=\"\\(.*?\\)\",value=\"\\(.*?\\)\"")
 700
 701 (defun gdb-data-list-register-values-handler ()
 702   (setq gdb-pending-triggers (delq 'gdbmi-invalidate-registers
 703                                    gdb-pending-triggers))
 704   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 705     (goto-char (point-min))
 706     (if (re-search-forward gdb-error-regexp nil t)
 707         (progn
 708           (let ((match nil))
 709             (setq match (match-string 1))
 710             (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
 711               (let ((buffer-read-only nil))
 712                 (erase-buffer)
 713                 (insert match)
 714                 (goto-char (point-min))))))
 715       (let ((register-list (reverse gdb-register-names))
 716             (register nil) (register-string nil) (register-values nil))
 717         (goto-char (point-min))
 718         (while (re-search-forward gdb-data-list-register-values-regexp nil t)
 719           (setq register (pop register-list))
 720           (setq register-string (concat register "\t" (match-string 2) "\n"))
 721           (if (member (match-string 1) gdb-changed-registers)
 722               (put-text-property 0 (length register-string)
 723                                  'face 'font-lock-warning-face
 724                                  register-string))
 725           (setq register-values
 726                 (concat register-values register-string)))
 727         (let ((buf (gdb-get-buffer 'gdb-registers-buffer)))
 728           (with-current-buffer buf
 729             (let ((p (window-point (get-buffer-window buf 0)))
 730                   (buffer-read-only nil))
 731               (erase-buffer)
 732               (insert register-values)
 733               (set-window-point (get-buffer-window buf 0) p))))))))
 734
 735 (defun gdb-data-list-register-values-custom ())
 736
 737 (defun gdb-get-changed-registers ()
 738   (if (and (gdb-get-buffer 'gdb-registers-buffer)
 739            (not (member 'gdb-get-changed-registers gdb-pending-triggers)))
 740       (progn
 741         (gdb-enqueue-input
 742          (list
 743           "-data-list-changed-registers\n"
 744           'gdb-get-changed-registers-handler))
 745         (push 'gdb-get-changed-registers gdb-pending-triggers))))
 746
 747 (defun gdb-get-changed-registers-handler ()
 748   (setq gdb-pending-triggers
 749         (delq 'gdb-get-changed-registers gdb-pending-triggers))
 750   (setq gdb-changed-registers nil)
 751   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 752     (goto-char (point-min))
 753     (while (re-search-forward gdb-data-list-register-names-regexp nil t)
 754       (push (match-string 1) gdb-changed-registers))))
 755
 756
 757 (defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"")
 758
 759 (defun gdb-get-register-names ()
 760   "Create a list of register names."
 761   (goto-char (point-min))
 762   (setq gdb-register-names nil)
 763   (while (re-search-forward gdb-data-list-register-names-regexp nil t)
 764     (push (match-string 1) gdb-register-names)))
 765 \f
 766 ;; these functions/variables may go into gdb-ui.el in the near future
 767 ;; (from gdb-nui.el)
 768
 769 (defvar gdb-source-file-list nil)
 770 (defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"")
 771
 772 (defun gdb-get-source-file ()
 773   "Find the source file where the program starts and display it with related
 774 buffers, if required."
 775   (goto-char (point-min))
 776   (if (re-search-forward gdb-source-file-regexp nil t)
 777       (setq gdb-main-file (match-string 1)))
 778  (if gdb-many-windows
 779       (gdb-setup-windows)
 780    (gdb-get-create-buffer 'gdb-breakpoints-buffer)
 781    (if gdb-show-main
 782        (let ((pop-up-windows t))
 783          (display-buffer (gud-find-file gdb-main-file))))))
 784
 785 (defun gdb-get-source-file-list ()
 786   "Create list of source files for current GDB session."
 787   (goto-char (point-min))
 788   (while (re-search-forward gdb-source-file-regexp nil t)
 789     (push (match-string 1) gdb-source-file-list)))
 790
 791 (defun gdbmi-get-selected-frame ()
 792   (if (not (member 'gdbmi-get-selected-frame gdb-pending-triggers))
 793       (progn
 794         (gdb-enqueue-input
 795          (list "-stack-info-frame\n" 'gdbmi-frame-handler))
 796         (push 'gdbmi-get-selected-frame
 797                gdb-pending-triggers))))
 798
 799 (defun gdbmi-frame-handler ()
 800   (setq gdb-pending-triggers
 801         (delq 'gdbmi-get-selected-frame gdb-pending-triggers))
 802   (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
 803     (goto-char (point-min))
 804     (when (re-search-forward gdb-stack-list-frames-regexp nil t)
 805       (setq gdb-frame-number (match-string 1))
 806       (setq gdb-frame-address (match-string 2))
 807       (setq gdb-selected-frame (match-string 3))
 808       (setq gud-last-frame
 809             (cons (match-string 4) (string-to-number (match-string 5))))
 810       (gud-display-frame)
 811       (if (gdb-get-buffer 'gdb-locals-buffer)
 812           (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer)
 813             (setq mode-name (concat "Locals:" gdb-selected-frame))))
 814       (if (gdb-get-buffer 'gdb-assembler-buffer)
 815           (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer)
 816             (setq mode-name (concat "Machine:" gdb-selected-frame)))))))
 817
 818 (defvar gdb-prompt-name-regexp "value=\"\\(.*?\\)\"")
 819
 820 (defun gdb-get-prompt ()
 821   "Find prompt for GDB session."
 822   (goto-char (point-min))
 823   (setq gdb-prompt-name nil)
 824   (re-search-forward gdb-prompt-name-regexp nil t)
 825   (setq gdb-prompt-name (match-string 1)))
 826
 827 (provide 'gdb-mi)
 828 ;;; gdbmi.el ends here