;;; gdb-mi.el --- User Interface for running GDB
-;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Nick Roberts <nickrob@gnu.org>
;; Maintainer: FSF
(require 'gud)
(require 'json)
(require 'bindat)
+(eval-when-compile (require 'cl))
(defvar tool-bar-map)
(defvar speedbar-initial-expansion-list-name)
(defvar speedbar-frame)
-(defvar gdb-pc-address nil "Initialization for Assembler buffer.
-Set to \"main\" at start if `gdb-show-main' is t.")
(defvar gdb-memory-address "main")
(defvar gdb-memory-last-address nil
"Last successfully accessed memory address.")
(defvar gdb-memory-prev-page nil
"Address of previous memory page for program memory buffer.")
-(defvar gdb-frame-number "0")
-(defvar gdb-thread-number "1"
+(defvar gdb-thread-number nil
"Main current thread.
Invalidation triggers use this variable to query GDB for
-information on the specified thread.
+information on the specified thread by wrapping GDB/MI commands
+in `gdb-current-context-command'.
-This variable may be updated implicitly by GDB via
-`gdb-thread-list-handler-custom' or explicitly by
-`gdb-select-thread'.")
+This variable may be updated implicitly by GDB via `gdb-stopped'
+or explicitly by `gdb-select-thread'.
+
+Only `gdb-setq-thread-number' should be used to change this
+value.")
+
+(defvar gdb-frame-number nil
+ "Selected frame level for main current thread.
+
+Updated according to the following rules:
+
+When a thread is selected or current thread stops, set to \"0\".
+
+When current thread goes running (and possibly exits eventually),
+set to nil.
+
+May be manually changed by user with `gdb-select-frame'.")
+
+(defvar gdb-frame-address nil "Identity of frame for watch expression.")
+
+;; Used to show overlay arrow in source buffer. All set in
+;; gdb-get-main-selected-frame. Disassembly buffer should not use
+;; these but rely on buffer-local thread information instead.
+(defvar gdb-selected-frame nil
+ "Name of selected function for main current thread.")
+(defvar gdb-selected-file nil
+ "Name of selected file for main current thread.")
+(defvar gdb-selected-line nil
+ "Number of selected line for main current thread.")
+
+(defvar gdb-threads-list nil
+ "Associative list of threads provided by \"-thread-info\" MI command.
+
+Keys are thread numbers (in strings) and values are structures as
+returned from -thread-info by `gdb-json-partial-output'. Updated in
+`gdb-thread-list-handler-custom'.")
+
+(defvar gdb-running-threads-count nil
+ "Number of currently running threads.
+
+If nil, no information is available.
+
+Updated in `gdb-thread-list-handler-custom'.")
+
+(defvar gdb-stopped-threads-count nil
+ "Number of currently stopped threads.
+
+See also `gdb-running-threads-count'.")
+
+(defvar gdb-breakpoints-list nil
+ "Associative list of breakpoints provided by \"-break-list\" MI command.
+
+Keys are breakpoint numbers (in string) and values are structures
+as returned from \"-break-list\" by `gdb-json-partial-output'
+\(\"body\" field is used). Updated in
+`gdb-breakpoints-list-handler-custom'.")
-(defvar gdb-selected-frame nil)
-(defvar gdb-selected-file nil)
-(defvar gdb-selected-line nil)
(defvar gdb-current-language nil)
(defvar gdb-var-list nil
"List of variables in watch window.
-Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS) where
-STATUS is nil (unchanged), `changed' or `out-of-scope'.")
+Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP)
+where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame
+address for root variables.")
(defvar gdb-main-file nil "Source file from which program execution begins.")
-(defvar gdb-overlay-arrow-position nil)
+
+;; Overlay arrow markers
(defvar gdb-stack-position nil)
-(defvar gdb-breakpoints-list nil
- "List of breakpoints.
+(defvar gdb-thread-position nil)
+(defvar gdb-disassembly-position nil)
-`gdb-get-field' is used to access breakpoints data stored in this
-variable. Each element contains the same fields as \"body\"
-member of \"-break-info\".")
(defvar gdb-location-alist nil
"Alist of breakpoint numbers and full filenames. Only used for files that
Emacs can't find.")
(defvar gdb-source-window nil)
(defvar gdb-inferior-status nil)
(defvar gdb-continuation nil)
+(defvar gdb-version nil)
(defvar gdb-filter-output nil
"Message to be shown in GUD console.
This variable is updated in `gdb-done-or-error' and returned by
`gud-gdbmi-marker-filter'.")
+(defvar gdb-non-stop nil
+ "Indicates whether current GDB session is using non-stop mode.
+
+It is initialized to `gdb-non-stop-setting' at the beginning of
+every GDB session.")
+
(defvar gdb-buffer-type nil
"One of the symbols bound in `gdb-buffer-rules'.")
(make-variable-buffer-local 'gdb-buffer-type)
disposition of output generated by commands that
gdb mode sends to gdb on its own behalf.")
+;; Pending triggers prevent congestion: Emacs won't send two similar
+;; consecutive requests.
+
(defvar gdb-pending-triggers '()
- "A list of trigger functions that have run later than their output handlers.")
+ "A list of trigger functions which have not yet been handled.
+
+Elements are either function names or pairs (buffer . function)")
+
+(defmacro gdb-add-pending (item)
+ `(push ,item gdb-pending-triggers))
+(defmacro gdb-pending-p (item)
+ `(member ,item gdb-pending-triggers))
+(defmacro gdb-delete-pending (item)
+ `(setq gdb-pending-triggers
+ (delete ,item gdb-pending-triggers)))
+
+(defmacro gdb-wait-for-pending (&rest body)
+ "Wait until `gdb-pending-triggers' is empty and evaluate FORM.
+
+This function checks `gdb-pending-triggers' value every
+`gdb-wait-for-pending' seconds."
+ (run-with-timer
+ 0.5 nil
+ `(lambda ()
+ (if (not gdb-pending-triggers)
+ (progn ,@body)
+ (gdb-wait-for-pending ,@body)))))
+
+;; Publish-subscribe
+
+(defmacro gdb-add-subscriber (publisher subscriber)
+ "Register new PUBLISHER's SUBSCRIBER.
+
+SUBSCRIBER must be a pair, where cdr is a function of one
+argument (see `gdb-emit-signal')."
+ `(add-to-list ',publisher ,subscriber t))
+
+(defmacro gdb-delete-subscriber (publisher subscriber)
+ "Unregister SUBSCRIBER from PUBLISHER."
+ `(setq ,publisher (delete ,subscriber
+ ,publisher)))
+
+(defun gdb-get-subscribers (publisher)
+ publisher)
+
+(defun gdb-emit-signal (publisher &optional signal)
+ "Call cdr for each subscriber of PUBLISHER with SIGNAL as argument."
+ (dolist (subscriber (gdb-get-subscribers publisher))
+ (funcall (cdr subscriber) signal)))
+
+(defvar gdb-buf-publisher '()
+ "Used to invalidate GDB buffers by emitting a signal in
+`gdb-update'.
+
+Must be a list of pairs with cars being buffers and cdr's being
+valid signal handlers.")
+
+(defgroup gdb nil
+ "GDB graphical interface"
+ :group 'tools
+ :link '(info-link "(emacs)GDB Graphical Interface")
+ :version "23.2")
+
+(defgroup gdb-non-stop nil
+ "GDB non-stop debugging settings"
+ :group 'gdb
+ :version "23.2")
+
+(defgroup gdb-buffers nil
+ "GDB buffers"
+ :group 'gdb
+ :version "23.2")
(defcustom gdb-debug-log-max 128
"Maximum size of `gdb-debug-log'. If nil, size is unlimited."
(const :tag "Unlimited" nil))
:version "22.1")
+(defcustom gdb-non-stop-setting t
+ "When in non-stop mode, stopped threads can be examined while
+other threads continue to execute.
+
+GDB session needs to be restarted for this setting to take
+effect."
+ :type 'boolean
+ :group 'gdb-non-stop
+ :version "23.2")
+
+;; TODO Some commands can't be called with --all (give a notice about
+;; it in setting doc)
+(defcustom gdb-gud-control-all-threads t
+ "When enabled, GUD execution commands affect all threads when
+in non-stop mode. Otherwise, only current thread is affected."
+ :type 'boolean
+ :group 'gdb-non-stop
+ :version "23.2")
+
+(defcustom gdb-switch-reasons t
+ "List of stop reasons which cause Emacs to switch to the thread
+which caused the stop. When t, switch to stopped thread no matter
+what the reason was. When nil, never switch to stopped thread
+automatically.
+
+This setting is used in non-stop mode only. In all-stop mode,
+Emacs always switches to the thread which caused the stop."
+ ;; exited, exited-normally and exited-signalled are not
+ ;; thread-specific stop reasons and therefore are not included in
+ ;; this list
+ :type '(choice
+ (const :tag "All reasons" t)
+ (set :tag "Selection of reasons..."
+ (const :tag "A breakpoint was reached." "breakpoint-hit")
+ (const :tag "A watchpoint was triggered." "watchpoint-trigger")
+ (const :tag "A read watchpoint was triggered." "read-watchpoint-trigger")
+ (const :tag "An access watchpoint was triggered." "access-watchpoint-trigger")
+ (const :tag "Function finished execution." "function-finished")
+ (const :tag "Location reached." "location-reached")
+ (const :tag "Watchpoint has gone out of scope" "watchpoint-scope")
+ (const :tag "End of stepping range reached." "end-stepping-range")
+ (const :tag "Signal received (like interruption)." "signal-received"))
+ (const :tag "None" nil))
+ :group 'gdb-non-stop
+ :version "23.2"
+ :link '(info-link "(gdb)GDB/MI Async Records"))
+
+(defcustom gdb-stopped-hooks nil
+ "This variable holds a list of functions to be called whenever
+GDB stops.
+
+Each function takes one argument, a parsed MI response, which
+contains fields of corresponding MI *stopped async record:
+
+ ((stopped-threads . \"all\")
+ (thread-id . \"1\")
+ (frame (line . \"38\")
+ (fullname . \"/home/sphinx/projects/gsoc/server.c\")
+ (file . \"server.c\")
+ (args ((value . \"0x804b038\")
+ (name . \"arg\")))
+ (func . \"hello\")
+ (addr . \"0x0804869e\"))
+ (reason . \"end-stepping-range\"))
+
+Note that \"reason\" is only present in non-stop debugging mode.
+
+`bindat-get-field' may be used to access the fields of response.
+
+Each function is called after the new current thread was selected
+and GDB buffers were updated in `gdb-stopped'."
+ :type '(repeat function)
+ :group 'gdb
+ :version "23.2"
+ :link '(info-link "(gdb)GDB/MI Async Records"))
+
+(defcustom gdb-switch-when-another-stopped t
+ "When nil, Emacs won't switch to stopped thread if some other
+stopped thread is already selected."
+ :type 'boolean
+ :group 'gdb-non-stop
+ :version "23.2")
+
+(defcustom gdb-stack-buffer-locations t
+ "Show file information or library names in stack buffers."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-stack-buffer-addresses nil
+ "Show frame addresses in stack buffers."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-thread-buffer-verbose-names t
+ "Show long thread names in threads buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-thread-buffer-arguments t
+ "Show function arguments in threads buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-thread-buffer-locations t
+ "Show file information or library names in threads buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-thread-buffer-addresses nil
+ "Show addresses for thread frames in threads buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-show-threads-by-default nil
+ "Show threads list buffer instead of breakpoints list by
+default."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
(defvar gdb-debug-log nil
"List of commands sent to and replies received from GDB.
Most recent commands are listed first. This list stores only the last
:group 'gdb
:version "22.1")
-; Note: This mode requires a separate buffer for inferior IO.
-(defconst gdb-use-separate-io-buffer t)
-
(defun gdb-force-mode-line-update (status)
(let ((buffer gud-comint-buffer))
(if (and buffer (buffer-name buffer))
(message (format "Logging of transaction %sabled"
(if gdb-enable-debug "en" "dis"))))
+;; These two are used for menu and toolbar
+(defun gdb-control-all-threads ()
+ "Switch to non-stop/A mode."
+ (interactive)
+ (setq gdb-gud-control-all-threads t)
+ ;; Actually forcing the tool-bar to update.
+ (force-mode-line-update)
+ (message "Now in non-stop/A mode."))
+
+(defun gdb-control-current-thread ()
+ "Switch to non-stop/T mode."
+ (interactive)
+ (setq gdb-gud-control-all-threads nil)
+ ;; Actually forcing the tool-bar to update.
+ (force-mode-line-update)
+ (message "Now in non-stop/T mode."))
+
(defun gdb-find-watch-expression ()
(let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list))
(varnum (car var)) expr array)
(setq varnumlet (concat varnumlet "." component)))
expr)))
-(defvar gdb-locals-font-lock-keywords
- '(
- ;; var = type value
- ( "\\(^\\(\\sw\\|[_.]\\)+\\)\t+\\(\\(\\sw\\|[_.]\\)+\\)"
- (1 font-lock-variable-name-face)
- (3 font-lock-type-face))
- )
- "Font lock keywords used in `gdb-local-mode'.")
+;; noall is used for commands which don't take --all, but only
+;; --thread.
+(defun gdb-gud-context-command (command &optional noall)
+ "When `gdb-non-stop' is t, add --thread option to COMMAND if
+`gdb-gud-control-all-threads' is nil and --all option otherwise.
+If NOALL is t, always add --thread option no matter what
+`gdb-gud-control-all-threads' value is.
+
+When `gdb-non-stop' is nil, return COMMAND unchanged."
+ (if gdb-non-stop
+ (if (and gdb-gud-control-all-threads
+ (not noall)
+ (string-equal gdb-version "7.0+"))
+ (concat command " --all ")
+ (gdb-current-context-command command))
+ command))
+
+(defmacro gdb-gud-context-call (cmd1 &optional cmd2 noall noarg)
+ "`gud-call' wrapper which adds --thread/--all options between
+CMD1 and CMD2. NOALL is the same as in `gdb-gud-context-command'.
+
+NOARG must be t when this macro is used outside `gud-def'"
+ `(gud-call
+ (concat (gdb-gud-context-command ,cmd1 ,noall) " " ,cmd2)
+ ,(when (not noarg) 'arg)))
;;;###autoload
(defun gdb (command-line)
| | |
+-----------------------------------+----------------------------------+
| Stack buffer | Breakpoints buffer |
-| RET gdb-frames-select | SPC gdb-toggle-breakpoint |
+| RET gdb-select-frame | SPC gdb-toggle-breakpoint |
| | RET gdb-goto-breakpoint |
| | D gdb-delete-breakpoint |
+-----------------------------------+----------------------------------+"
(gud-common-init command-line nil 'gud-gdbmi-marker-filter)
(set (make-local-variable 'gud-minor-mode) 'gdbmi)
(setq comint-input-sender 'gdb-send)
-
+ (when (ring-empty-p comint-input-ring) ; cf shell-mode
+ (let (hfile)
+ (when (catch 'done
+ (dolist (file '(".gdbinit" "~/.gdbinit"))
+ (if (file-readable-p (setq file (expand-file-name file)))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (and (re-search-forward
+ "^ *set history filename *\\(.*\\)" nil t)
+ (file-readable-p
+ (setq hfile (expand-file-name
+ (match-string 1)
+ (file-name-directory file))))
+ (throw 'done t))))))
+ (set (make-local-variable 'comint-input-ring-file-name) hfile)
+ (comint-read-input-ring t))))
(gud-def gud-tbreak "tbreak %f:%l" "\C-t"
"Set temporary breakpoint at current line.")
(gud-def gud-jump
(gud-def gud-pstar "print* %e" nil
"Evaluate C dereferenced pointer expression at point.")
- (gud-def gud-step "-exec-step %p" "\C-s"
+ (gud-def gud-step (gdb-gud-context-call "-exec-step" "%p" t)
+ "\C-s"
"Step one source line with display.")
- (gud-def gud-stepi "-exec-step-instruction %p" "\C-i"
+ (gud-def gud-stepi (gdb-gud-context-call "-exec-step-instruction" "%p" t)
+ "\C-i"
"Step one instruction with display.")
- (gud-def gud-next "-exec-next %p" "\C-n"
+ (gud-def gud-next (gdb-gud-context-call "-exec-next" "%p" t)
+ "\C-n"
"Step one line (skip functions).")
- (gud-def gud-nexti "nexti %p" nil
+ (gud-def gud-nexti (gdb-gud-context-call "-exec-next-instruction" "%p" t)
+ nil
"Step one instruction (skip functions).")
- (gud-def gud-cont "-exec-continue" "\C-r"
+ (gud-def gud-cont (gdb-gud-context-call "-exec-continue")
+ "\C-r"
"Continue with display.")
- (gud-def gud-finish "-exec-finish" "\C-f"
+ (gud-def gud-finish (gdb-gud-context-call "-exec-finish" nil t)
+ "\C-f"
"Finish executing current function.")
- (gud-def gud-run "-exec-run" nil "Runn the program.")
+ (gud-def gud-run "-exec-run"
+ nil
+ "Run the program.")
- (local-set-key "\C-i" 'gud-gdb-complete-command)
- (setq gdb-first-prompt t)
- (setq gud-running nil)
- (gdb-update)
- (run-hooks 'gdb-mode-hook))
-
-(defun gdb-init-1 ()
(gud-def gud-break (if (not (string-match "Disassembly" mode-name))
(gud-call "break %f:%l" arg)
(save-excursion
(forward-char 2)
(gud-call "break *%a" arg)))
"\C-b" "Set breakpoint at current line or address.")
- ;;
+
(gud-def gud-remove (if (not (string-match "Disassembly" mode-name))
(gud-call "clear %f:%l" arg)
(save-excursion
(forward-char 2)
(gud-call "clear *%a" arg)))
"\C-d" "Remove breakpoint at current line or address.")
- ;;
+
+ ;; -exec-until doesn't support --all yet
(gud-def gud-until (if (not (string-match "Disassembly" mode-name))
(gud-call "-exec-until %f:%l" arg)
(save-excursion
(forward-char 2)
(gud-call "-exec-until *%a" arg)))
"\C-u" "Continue to current line or address.")
- ;;
+ ;; TODO Why arg here?
(gud-def
- gud-go (gud-call (if gdb-active-process "-exec-continue" "-exec-run") arg)
+ gud-go (gud-call (if gdb-active-process
+ (gdb-gud-context-command "-exec-continue")
+ "-exec-run") arg)
nil "Start or continue execution.")
;; For debugging Emacs only.
'gdb-mouse-jump)
(define-key gud-minor-mode-map [left-margin C-mouse-3]
'gdb-mouse-jump)
- ;;
+
+ (local-set-key "\C-i" 'gud-gdb-complete-command)
+ (setq gdb-first-prompt t)
+ (setq gud-running nil)
+
+ (gdb-update)
+
+ (run-hooks 'gdb-mode-hook))
+
+(defun gdb-init-1 ()
;; (re-)initialise
- (setq gdb-pc-address (if gdb-show-main "main" nil))
(setq gdb-selected-frame nil
gdb-frame-number nil
+ gdb-thread-number nil
gdb-var-list nil
gdb-pending-triggers nil
gdb-output-sink 'user
gdb-debug-log nil
gdb-source-window nil
gdb-inferior-status nil
- gdb-continuation nil)
+ gdb-continuation nil
+ gdb-buf-publisher '()
+ gdb-threads-list '()
+ gdb-breakpoints-list '()
+ gdb-register-names '()
+ gdb-non-stop gdb-non-stop-setting)
;;
(setq gdb-buffer-type 'gdbmi)
;;
(gdb-force-mode-line-update
(propertize "initializing..." 'face font-lock-variable-name-face))
- (when gdb-use-separate-io-buffer
- (gdb-get-buffer-create 'gdb-inferior-io)
- (gdb-clear-inferior-io)
- (set-process-filter (get-process "gdb-inferior") 'gdb-inferior-filter)
- (gdb-input
- ;; Needs GDB 6.4 onwards
- (list (concat "-inferior-tty-set "
- (process-tty-name (get-process "gdb-inferior")))
- 'ignore)))
+ (gdb-get-buffer-create 'gdb-inferior-io)
+ (gdb-clear-inferior-io)
+ (set-process-filter (get-process "gdb-inferior") 'gdb-inferior-filter)
+ (gdb-input
+ ;; Needs GDB 6.4 onwards
+ (list (concat "-inferior-tty-set "
+ (or
+ ;; The process can run on a remote host.
+ (process-get (get-process "gdb-inferior") 'remote-tty)
+ (process-tty-name (get-process "gdb-inferior"))))
+ 'ignore))
(if (eq window-system 'w32)
(gdb-input (list "-gdb-set new-console off" 'ignore)))
(gdb-input (list "-gdb-set height 0" 'ignore))
+
+ (when gdb-non-stop
+ (gdb-input (list "-gdb-set non-stop 1" 'gdb-non-stop-handler)))
+
;; find source file and compilation directory here
(gdb-input
; Needs GDB 6.2 onwards.
(gdb-input
(list "-gdb-show prompt" 'gdb-get-prompt)))
+(defun gdb-non-stop-handler ()
+ (goto-char (point-min))
+ (if (re-search-forward "No symbol" nil t)
+ (progn
+ (message "This version of GDB doesn't support non-stop mode. Turning it off.")
+ (setq gdb-non-stop nil)
+ (setq gdb-version "pre-7.0"))
+ (setq gdb-version "7.0+")
+ (gdb-input (list "-gdb-set target-async 1" 'ignore))
+ (gdb-input (list "-enable-pretty-printing" 'ignore))))
+
(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.")
(defun gdb-create-define-alist ()
(defvar tooltip-use-echo-area)
(defun gdb-tooltip-print (expr)
- (tooltip-show
(with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
(goto-char (point-min))
- (let ((string
- (if (search-forward "=" nil t)
- (concat expr (buffer-substring (- (point) 2) (point-max)))
- (buffer-string))))
- ;; remove newline for gud-tooltip-echo-area
- (substring string 0 (- (length string) 1))))
- (or gud-tooltip-echo-area tooltip-use-echo-area
- (not (display-graphic-p)))))
-
+ (if (re-search-forward ".*value=\\(\".*\"\\)" nil t)
+ (tooltip-show
+ (concat expr " = " (read (match-string 1)))
+ (or gud-tooltip-echo-area tooltip-use-echo-area
+ (not (display-graphic-p)))))))
+
;; If expr is a macro for a function don't print because of possible dangerous
;; side-effects. Also printing a function within a tooltip generates an
;; unexpected starting annotation (phase error).
(if (search-forward "expands to: " nil t)
(unless (looking-at "\\S-+.*(.*).*")
(gdb-input
- (list (concat "print " expr)
+ (list (concat "-data-evaluate-expression " expr)
`(lambda () (gdb-tooltip-print ,expr))))))))
(defun gdb-init-buffer ()
(gdb-if-arrow gud-overlay-arrow-position
(setq line (line-number-at-pos (posn-point end)))
(gud-call (concat "until " (number-to-string line))))
- (gdb-if-arrow gdb-overlay-arrow-position
+ (gdb-if-arrow gdb-disassembly-position
(save-excursion
- (goto-line (line-number-at-pos (posn-point end)))
+ (goto-char (point-min))
+ (forward-line (1- (line-number-at-pos (posn-point end))))
(forward-char 2)
(gud-call (concat "until *%a"))))))
(progn
(gud-call (concat "tbreak " (number-to-string line)))
(gud-call (concat "jump " (number-to-string line)))))
- (gdb-if-arrow gdb-overlay-arrow-position
+ (gdb-if-arrow gdb-disassembly-position
(save-excursion
- (goto-line (line-number-at-pos (posn-point end)))
+ (goto-char (point-min))
+ (forward-line (1- (line-number-at-pos (posn-point end))))
(forward-char 2)
(progn
(gud-call (concat "tbreak *%a"))
'gud-gdb-complete-command)
(if (and transient-mark-mode mark-active)
(buffer-substring (region-beginning) (region-end))
- (concat (if (eq major-mode 'gdb-registers-mode) "$")
+ (concat (if (derived-mode-p 'gdb-registers-mode) "$")
(tooltip-identifier-from-point (point)))))))
(set-text-properties 0 (length expr) nil expr)
(gdb-input
`(lambda () (gdb-var-create-handler ,expr)))))))
(message "gud-watch is a no-op in this mode."))))
-(defconst gdb-var-create-regexp
- "name=\"\\(.*?\\)\",.*numchild=\"\\(.*?\\)\",\\(?:.*value=\\(\".*\"\\),\\)?.*type=\"\\(.*?\\)\"")
-
(defun gdb-var-create-handler (expr)
- (goto-char (point-min))
- (if (re-search-forward gdb-var-create-regexp nil t)
- (let ((var (list
- (match-string 1)
- (if (and (string-equal gdb-current-language "c")
- gdb-use-colon-colon-notation gdb-selected-frame)
- (setq expr (concat gdb-selected-frame "::" expr))
- expr)
- (match-string 2)
- (match-string 4)
- (if (match-string 3) (read (match-string 3)))
- nil)))
- (push var gdb-var-list)
- (speedbar 1)
- (unless (string-equal
- speedbar-initial-expansion-list-name "GUD")
- (speedbar-change-initial-expansion-list "GUD"))
- (gdb-input
- (list
- (concat "-var-evaluate-expression " (car var))
- `(lambda () (gdb-var-evaluate-expression-handler
- ,(car var) nil)))))
- (message-box "No symbol \"%s\" in current context." expr)))
+ (let* ((result (gdb-json-partial-output)))
+ (if (not (bindat-get-field result 'msg))
+ (let ((var
+ (list (bindat-get-field result 'name)
+ (if (and (string-equal gdb-current-language "c")
+ gdb-use-colon-colon-notation gdb-selected-frame)
+ (setq expr (concat gdb-selected-frame "::" expr))
+ expr)
+ (bindat-get-field result 'numchild)
+ (bindat-get-field result 'type)
+ (bindat-get-field result 'value)
+ nil
+ (bindat-get-field result 'has_more)
+ gdb-frame-address)))
+ (push var gdb-var-list)
+ (speedbar 1)
+ (unless (string-equal
+ speedbar-initial-expansion-list-name "GUD")
+ (speedbar-change-initial-expansion-list "GUD")))
+ (message-box "No symbol \"%s\" in current context." expr))))
(defun gdb-speedbar-update ()
(when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)
- (not (member 'gdb-speedbar-timer gdb-pending-triggers)))
+ (not (gdb-pending-p 'gdb-speedbar-timer)))
;; Dummy command to update speedbar even when idle.
(gdb-input (list "-environment-pwd" 'gdb-speedbar-timer-fn))
;; Keep gdb-pending-triggers non-nil till end.
- (push 'gdb-speedbar-timer gdb-pending-triggers)))
+ (gdb-add-pending 'gdb-speedbar-timer)))
(defun gdb-speedbar-timer-fn ()
(if gdb-speedbar-auto-raise
(raise-frame speedbar-frame))
- (setq gdb-pending-triggers
- (delq 'gdb-speedbar-timer gdb-pending-triggers))
+ (gdb-delete-pending 'gdb-speedbar-timer)
(speedbar-timer-fn))
(defun gdb-var-evaluate-expression-handler (varnum changed)
varnum)
`(lambda () (gdb-var-list-children-handler ,varnum)))))
-(defconst gdb-var-list-children-regexp
- "child={.*?name=\"\\(.+?\\)\".*?,exp=\"\\(.+?\\)\".*?,\
-numchild=\"\\(.+?\\)\".*?,value=\\(\".*?\"\\).*?,type=\"\\(.+?\\)\".*?}")
-
(defun gdb-var-list-children-handler (varnum)
- (goto-char (point-min))
- (let ((var-list nil))
- (catch 'child-already-watched
+ (let* ((var-list nil)
+ (output (bindat-get-field (gdb-json-partial-output "child")))
+ (children (bindat-get-field output 'children)))
+ (catch 'child-already-watched
(dolist (var gdb-var-list)
(if (string-equal varnum (car var))
(progn
+ ;; With dynamic varobjs numchild may have increased.
+ (setcar (nthcdr 2 var) (bindat-get-field output 'numchild))
(push var var-list)
- (while (re-search-forward gdb-var-list-children-regexp nil t)
- (let ((varchild (list (match-string 1)
- (match-string 2)
- (match-string 3)
- (match-string 5)
- (read (match-string 4))
- nil)))
+ (dolist (child children)
+ (let ((varchild (list (bindat-get-field child 'name)
+ (bindat-get-field child 'exp)
+ (bindat-get-field child 'numchild)
+ (bindat-get-field child 'type)
+ (bindat-get-field child 'value)
+ nil
+ (bindat-get-field child 'has_more))))
(if (assoc (car varchild) gdb-var-list)
(throw 'child-already-watched nil))
(push varchild var-list))))
(list (concat "-var-set-format " varnum " " format) 'ignore))
(gdb-var-update)))
-(defun gdb-var-delete-1 (varnum)
+(defun gdb-var-delete-1 (var varnum)
(gdb-input
(list (concat "-var-delete " varnum) 'ignore))
(setq gdb-var-list (delq var gdb-var-list))
(varnum (car var)))
(if (string-match "\\." (car var))
(message-box "Can only delete a root expression")
- (gdb-var-delete-1 varnum)))))
+ (gdb-var-delete-1 var varnum)))))
(defun gdb-var-delete-children (varnum)
"Delete children of variable object at point from the speedbar."
; Uses "-var-update --all-values". Needs GDB 6.4 onwards.
(defun gdb-var-update ()
- (if (not (member 'gdb-var-update gdb-pending-triggers))
+ (if (not (gdb-pending-p 'gdb-var-update))
(gdb-input
(list "-var-update --all-values *" 'gdb-var-update-handler)))
- (push 'gdb-var-update gdb-pending-triggers))
-
-(defconst gdb-var-update-regexp
- "{.*?name=\"\\(.*?\\)\".*?,\\(?:value=\\(\".*?\"\\),\\)?.*?\
-in_scope=\"\\(.*?\\)\".*?}")
+ (gdb-add-pending 'gdb-var-update))
(defun gdb-var-update-handler ()
- (dolist (var gdb-var-list)
- (setcar (nthcdr 5 var) nil))
- (goto-char (point-min))
- (while (re-search-forward gdb-var-update-regexp nil t)
- (let* ((varnum (match-string 1))
- (var (assoc varnum gdb-var-list)))
- (when var
- (let ((match (match-string 3)))
- (cond ((string-equal match "false")
- (if gdb-delete-out-of-scope
- (gdb-var-delete-1 varnum)
- (setcar (nthcdr 5 var) 'out-of-scope)))
- ((string-equal match "true")
- (setcar (nthcdr 5 var) 'changed)
- (setcar (nthcdr 4 var)
- (read (match-string 2))))
- ((string-equal match "invalid")
- (gdb-var-delete-1 varnum)))))))
+ (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist)))
+ (dolist (var gdb-var-list)
+ (setcar (nthcdr 5 var) nil))
+ (let ((temp-var-list gdb-var-list))
+ (dolist (change changelist)
+ (let* ((varnum (bindat-get-field change 'name))
+ (var (assoc varnum gdb-var-list))
+ (new-num (bindat-get-field change 'new_num_children)))
+ (when var
+ (let ((scope (bindat-get-field change 'in_scope))
+ (has-more (bindat-get-field change 'has_more)))
+ (cond ((string-equal scope "false")
+ (if gdb-delete-out-of-scope
+ (gdb-var-delete-1 var varnum)
+ (setcar (nthcdr 5 var) 'out-of-scope)))
+ ((string-equal scope "true")
+ (setcar (nthcdr 6 var) has-more)
+ (when (and (or (not has-more)
+ (string-equal has-more "0"))
+ (not new-num)
+ (string-equal (nth 2 var) "0"))
+ (setcar (nthcdr 4 var)
+ (bindat-get-field change 'value))
+ (setcar (nthcdr 5 var) 'changed)))
+ ((string-equal scope "invalid")
+ (gdb-var-delete-1 var varnum)))))
+ (let ((var-list nil) var1
+ (children (bindat-get-field change 'new_children)))
+ (if new-num
+ (progn
+ (setq var1 (pop temp-var-list))
+ (while var1
+ (if (string-equal varnum (car var1))
+ (let ((new (string-to-number new-num))
+ (previous (string-to-number (nth 2 var1))))
+ (setcar (nthcdr 2 var1) new-num)
+ (push var1 var-list)
+ (cond ((> new previous)
+ ;; Add new children to list.
+ (dotimes (dummy previous)
+ (push (pop temp-var-list) var-list))
+ (dolist (child children)
+ (let ((varchild
+ (list (bindat-get-field child 'name)
+ (bindat-get-field child 'exp)
+ (bindat-get-field child 'numchild)
+ (bindat-get-field child 'type)
+ (bindat-get-field child 'value)
+ 'changed
+ (bindat-get-field child 'has_more))))
+ (push varchild var-list))))
+ ;; Remove deleted children from list.
+ ((< new previous)
+ (dotimes (dummy new)
+ (push (pop temp-var-list) var-list))
+ (dotimes (dummy (- previous new))
+ (pop temp-var-list)))))
+ (push var1 var-list))
+ (setq var1 (pop temp-var-list)))
+ (setq gdb-var-list (nreverse var-list)))))))))
(setq gdb-pending-triggers
- (delq 'gdb-var-update gdb-pending-triggers))
+ (delq 'gdb-var-update gdb-pending-triggers))
(gdb-speedbar-update))
(defun gdb-speedbar-expand-node (text token indent)
;; is constructed specially.
;;
;; Others are constructed by gdb-get-buffer-create and
-;; named according to the rules set forth in the gdb-buffer-rules-assoc
-
-(defvar gdb-buffer-rules-assoc '())
-
-(defun gdb-get-buffer (key)
- "Return the gdb buffer tagged with type KEY.
-The key should be one of the cars in `gdb-buffer-rules-assoc'."
- (save-excursion
- (gdb-look-for-tagged-buffer key (buffer-list))))
-
-(defun gdb-get-buffer-create (key)
- "Create a new gdb buffer of the type specified by KEY.
-The key should be one of the cars in `gdb-buffer-rules-assoc'."
- (or (gdb-get-buffer key)
- (let* ((rules (assoc key gdb-buffer-rules-assoc))
- (name (funcall (gdb-rules-name-maker rules)))
- (new (get-buffer-create name)))
+;; named according to the rules set forth in the gdb-buffer-rules
+
+(defvar gdb-buffer-rules '())
+
+(defun gdb-rules-name-maker (rules-entry)
+ (cadr rules-entry))
+(defun gdb-rules-buffer-mode (rules-entry)
+ (nth 2 rules-entry))
+(defun gdb-rules-update-trigger (rules-entry)
+ (nth 3 rules-entry))
+
+(defun gdb-update-buffer-name ()
+ "Rename current buffer according to name-maker associated with
+it in `gdb-buffer-rules'."
+ (let ((f (gdb-rules-name-maker (assoc gdb-buffer-type
+ gdb-buffer-rules))))
+ (when f (rename-buffer (funcall f)))))
+
+(defun gdb-current-buffer-rules ()
+ "Get `gdb-buffer-rules' entry for current buffer type."
+ (assoc gdb-buffer-type gdb-buffer-rules))
+
+(defun gdb-current-buffer-thread ()
+ "Get thread object of current buffer from `gdb-threads-list'.
+
+When current buffer is not bound to any thread, return main
+thread."
+ (cdr (assoc gdb-thread-number gdb-threads-list)))
+
+(defun gdb-current-buffer-frame ()
+ "Get current stack frame object for thread of current buffer."
+ (bindat-get-field (gdb-current-buffer-thread) 'frame))
+
+(defun gdb-buffer-type (buffer)
+ "Get value of `gdb-buffer-type' for BUFFER."
+ (with-current-buffer buffer
+ gdb-buffer-type))
+
+(defun gdb-buffer-shows-main-thread-p ()
+ "Return t if current GDB buffer shows main selected thread and
+is not bound to it."
+ (current-buffer)
+ (not (local-variable-p 'gdb-thread-number)))
+
+(defun gdb-get-buffer (buffer-type &optional thread)
+ "Get a specific GDB buffer.
+
+In that buffer, `gdb-buffer-type' must be equal to BUFFER-TYPE
+and `gdb-thread-number' (if provided) must be equal to THREAD."
+ (catch 'found
+ (dolist (buffer (buffer-list) nil)
+ (with-current-buffer buffer
+ (when (and (eq gdb-buffer-type buffer-type)
+ (or (not thread)
+ (equal gdb-thread-number thread)))
+ (throw 'found buffer))))))
+
+(defun gdb-get-buffer-create (buffer-type &optional thread)
+ "Create a new GDB buffer of the type specified by BUFFER-TYPE.
+The buffer-type should be one of the cars in `gdb-buffer-rules'.
+
+If THREAD is non-nil, it is assigned to `gdb-thread-number'
+buffer-local variable of the new buffer.
+
+Buffer mode and name are selected according to buffer type.
+
+If buffer has trigger associated with it in `gdb-buffer-rules',
+this trigger is subscribed to `gdb-buf-publisher' and called with
+'update argument."
+ (or (gdb-get-buffer buffer-type thread)
+ (let ((rules (assoc buffer-type gdb-buffer-rules))
+ (new (generate-new-buffer "limbo")))
(with-current-buffer new
- (let ((trigger))
- (if (cdr (cdr rules))
- (setq trigger (funcall (car (cdr (cdr rules))))))
- (setq gdb-buffer-type key)
+ (let ((mode (gdb-rules-buffer-mode rules))
+ (trigger (gdb-rules-update-trigger rules)))
+ (when mode (funcall mode))
+ (setq gdb-buffer-type buffer-type)
+ (when thread
+ (set (make-local-variable 'gdb-thread-number) thread))
(set (make-local-variable 'gud-minor-mode)
(buffer-local-value 'gud-minor-mode gud-comint-buffer))
(set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
- (if trigger (funcall trigger)))
- new))))
-
-(defun gdb-rules-name-maker (rules) (car (cdr rules)))
-
-(defun gdb-look-for-tagged-buffer (key bufs)
- (let ((retval nil))
- (while (and (not retval) bufs)
- (set-buffer (car bufs))
- (if (eq gdb-buffer-type key)
- (setq retval (car bufs)))
- (setq bufs (cdr bufs)))
- retval))
+ (rename-buffer (funcall (gdb-rules-name-maker rules)))
+ (when trigger
+ (gdb-add-subscriber gdb-buf-publisher
+ (cons (current-buffer)
+ (gdb-bind-function-to-buffer trigger (current-buffer))))
+ (funcall trigger 'start))
+ (current-buffer))))))
+
+(defun gdb-bind-function-to-buffer (expr buffer)
+ "Return a function which will evaluate EXPR in BUFFER."
+ `(lambda (&rest args)
+ (with-current-buffer ,buffer
+ (apply ',expr args))))
;; Used to define all gdb-frame-*-buffer functions except
-;; `gdb-frame-separate-io-buffer'
+;; `gdb-frame-io-buffer'
(defmacro def-gdb-frame-for-buffer (name buffer &optional doc)
"Define a function NAME which shows gdb BUFFER in a separate frame.
DOC is an optional documentation string."
- `(defun ,name ()
+ `(defun ,name (&optional thread)
,(when doc doc)
(interactive)
(let ((special-display-regexps (append special-display-regexps '(".*")))
(special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create ,buffer)))))
+ (display-buffer (gdb-get-buffer-create ,buffer thread)))))
(defmacro def-gdb-display-buffer (name buffer &optional doc)
"Define a function NAME which shows gdb BUFFER.
DOC is an optional documentation string."
- `(defun ,name ()
+ `(defun ,name (&optional thread)
,(when doc doc)
(interactive)
(gdb-display-buffer
- (gdb-get-buffer-create ,buffer) t)))
+ (gdb-get-buffer-create ,buffer thread) t)))
+
+;; Used to display windows with thread-bound buffers
+(defmacro def-gdb-preempt-display-buffer (name buffer &optional doc
+ split-horizontal)
+ `(defun ,name (&optional thread)
+ ,(when doc doc)
+ (message thread)
+ (gdb-preempt-existing-or-display-buffer
+ (gdb-get-buffer-create ,buffer thread)
+ ,split-horizontal)))
-;;
;; This assoc maps buffer type symbols to rules. Each rule is a list of
;; at least one and possible more functions. The functions have these
;; roles in defining a buffer type:
;;
(defun gdb-set-buffer-rules (buffer-type &rest rules)
- (let ((binding (assoc buffer-type gdb-buffer-rules-assoc)))
+ (let ((binding (assoc buffer-type gdb-buffer-rules)))
(if binding
(setcdr binding rules)
(push (cons buffer-type rules)
- gdb-buffer-rules-assoc))))
+ gdb-buffer-rules))))
-;; GUD buffers are an exception to the rules
-(gdb-set-buffer-rules 'gdbmi 'error)
+(defun gdb-parent-mode ()
+ "Generic mode to derive all other GDB buffer modes from."
+ (kill-all-local-variables)
+ (setq buffer-read-only t)
+ (buffer-disable-undo)
+ ;; Delete buffer from gdb-buf-publisher when it's killed
+ ;; (if it has an associated update trigger)
+ (add-hook
+ 'kill-buffer-hook
+ (function
+ (lambda ()
+ (let ((trigger (gdb-rules-update-trigger
+ (gdb-current-buffer-rules))))
+ (when trigger
+ (gdb-delete-subscriber
+ gdb-buf-publisher
+ ;; This should match gdb-add-subscriber done in
+ ;; gdb-get-buffer-create
+ (cons (current-buffer)
+ (gdb-bind-function-to-buffer trigger (current-buffer))))))))
+ nil t))
;; Partial-output buffer : This accumulates output from a command executed on
;; behalf of emacs (rather than the user).
(gdb-get-target-string)
"*"))
-(defun gdb-display-separate-io-buffer ()
+(defun gdb-display-io-buffer ()
"Display IO of debugged program in a separate window."
(interactive)
- (if gdb-use-separate-io-buffer
- (gdb-display-buffer
- (gdb-get-buffer-create 'gdb-inferior-io) t)))
+ (gdb-display-buffer
+ (gdb-get-buffer-create 'gdb-inferior-io) t))
(defconst gdb-frame-parameters
'((height . 14) (width . 80)
(menu-bar-lines . nil)
(minibuffer . nil)))
-(defun gdb-frame-separate-io-buffer ()
+(defun gdb-frame-io-buffer ()
"Display IO of debugged program in a new frame."
(interactive)
- (if gdb-use-separate-io-buffer
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create 'gdb-inferior-io)))))
+ (let ((special-display-regexps (append special-display-regexps '(".*")))
+ (special-display-frame-alist gdb-frame-parameters))
+ (display-buffer (gdb-get-buffer-create 'gdb-inferior-io))))
(defvar gdb-inferior-io-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-c" 'gdb-separate-io-interrupt)
- (define-key map "\C-c\C-z" 'gdb-separate-io-stop)
- (define-key map "\C-c\C-\\" 'gdb-separate-io-quit)
- (define-key map "\C-c\C-d" 'gdb-separate-io-eof)
- (define-key map "\C-d" 'gdb-separate-io-eof)
+ (define-key map "\C-c\C-c" 'gdb-io-interrupt)
+ (define-key map "\C-c\C-z" 'gdb-io-stop)
+ (define-key map "\C-c\C-\\" 'gdb-io-quit)
+ (define-key map "\C-c\C-d" 'gdb-io-eof)
+ (define-key map "\C-d" 'gdb-io-eof)
map))
+;; We want to use comint because it has various nifty and familiar features.
(define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O"
"Major mode for gdb inferior-io."
:syntax-table nil :abbrev-table nil
- ;; We want to use comint because it has various nifty and familiar
- ;; features. We don't need a process, but comint wants one, so create
- ;; a dummy one.
- (make-comint-in-buffer
- "gdb-inferior" (current-buffer) "sleep" nil "1000000000"))
+ (make-comint-in-buffer "gdb-inferior" (current-buffer) nil))
(defun gdb-inferior-filter (proc string)
(unless (string-equal string "")
(gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t))
(with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io)
- (insert-before-markers string)))
+ (comint-output-filter proc string)))
-(defun gdb-separate-io-interrupt ()
+(defun gdb-io-interrupt ()
"Interrupt the program being debugged."
(interactive)
(interrupt-process
(get-buffer-process gud-comint-buffer) comint-ptyp))
-(defun gdb-separate-io-quit ()
+(defun gdb-io-quit ()
"Send quit signal to the program being debugged."
(interactive)
(quit-process
(get-buffer-process gud-comint-buffer) comint-ptyp))
-(defun gdb-separate-io-stop ()
+(defun gdb-io-stop ()
"Stop the program being debugged."
(interactive)
(stop-process
(get-buffer-process gud-comint-buffer) comint-ptyp))
-(defun gdb-separate-io-eof ()
+(defun gdb-io-eof ()
"Send end-of-file to the program being debugged."
(interactive)
(process-send-eof
(let ((inhibit-read-only t))
(remove-text-properties (point-min) (point-max) '(face))))
;; mimic <RET> key to repeat previous command in GDB
- (if (not (string-match "^\\s+$" string))
+ (if (not (string= "" string))
(setq gdb-last-command string)
(if gdb-last-command (setq string gdb-last-command)))
(if gdb-enable-debug
(process-send-string (get-buffer-process gud-comint-buffer)
(concat (car item) "\n")))
-(defmacro gdb-current-context-command (command)
- "Add --thread option to gdb COMMAND.
-
-Option value is taken from `gdb-thread-number'."
- (concat command " --thread " gdb-thread-number))
+;; NOFRAME is used for gud execution control commands
+(defun gdb-current-context-command (command)
+ "Add --thread to gdb COMMAND when needed."
+ (if (and gdb-thread-number
+ (string-equal gdb-version "7.0+"))
+ (concat command " --thread " gdb-thread-number)
+ command))
+
+(defun gdb-current-context-buffer-name (name)
+ "Add thread information and asterisks to string NAME.
+
+If `gdb-thread-number' is nil, just wrap NAME in asterisks."
+ (concat "*" name
+ (if (local-variable-p 'gdb-thread-number)
+ (format " (bound to thread %s)" gdb-thread-number)
+ "")
+ "*"))
+
+(defun gdb-current-context-mode-name (mode)
+ "Add thread information to MODE which is to be used as
+`mode-name'."
+ (concat mode
+ (if gdb-thread-number
+ (format " [thread %s]" gdb-thread-number)
+ "")))
\f
(defcustom gud-gdb-command-name "gdb -i=mi"
(propertize "initializing..." 'face font-lock-variable-name-face))
(gdb-init-1)
(setq gdb-first-prompt nil))
- ;; We may need to update gdb-thread-number, so we call threads buffer
+
+ (gdb-get-main-selected-frame)
+ ;; We may need to update gdb-threads-list so we can use
(gdb-get-buffer-create 'gdb-threads-buffer)
- (gdb-invalidate-threads)
- (gdb-get-selected-frame)
- (gdb-invalidate-frames)
- ;; Regenerate breakpoints buffer in case it has been inadvertantly deleted.
+ ;; gdb-break-list is maintained in breakpoints handler
(gdb-get-buffer-create 'gdb-breakpoints-buffer)
- (gdb-invalidate-breakpoints)
+
+ (gdb-emit-signal gdb-buf-publisher 'update)
+
(gdb-get-changed-registers)
- (gdb-invalidate-registers)
- (gdb-invalidate-locals)
- (gdb-invalidate-memory)
+
(when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
(dolist (var gdb-var-list)
(setcar (nthcdr 5 var) nil))
(gdb-var-update)))
+;; gdb-setq-thread-number and gdb-update-gud-running are decoupled
+;; because we may need to update current gud-running value without
+;; changing current thread (see gdb-running)
+(defun gdb-setq-thread-number (number)
+ "Only this function must be used to change `gdb-thread-number'
+value to NUMBER, because `gud-running' and `gdb-frame-number'
+need to be updated appropriately when current thread changes."
+ ;; GDB 6.8 and earlier always output thread-id="0" when stopping.
+ (unless (string-equal number "0") (setq gdb-thread-number number))
+ (setq gdb-frame-number "0")
+ (gdb-update-gud-running))
+
+(defun gdb-update-gud-running ()
+ "Set `gud-running' according to the state of current thread.
+
+`gdb-frame-number' is set to 0 if current thread is now stopped.
+
+Note that when `gdb-gud-control-all-threads' is t, `gud-running'
+cannot be reliably used to determine whether or not execution
+control buttons should be shown in menu or toolbar. Use
+`gdb-running-threads-count' and `gdb-stopped-threads-count'
+instead.
+
+For all-stop mode, thread information is unavailable while target
+is running."
+ (let ((old-value gud-running))
+ (setq gud-running
+ (string= (bindat-get-field (gdb-current-buffer-thread) 'state)
+ "running"))
+ ;; Set frame number to "0" when _current_ threads stops
+ (when (and (gdb-current-buffer-thread)
+ (not (eq gud-running old-value)))
+ (setq gdb-frame-number "0"))))
+
+(defun gdb-show-run-p ()
+ "Return t if \"Run/continue\" should be shown on the toolbar."
+ (or (not gdb-active-process)
+ (and (or
+ (not gdb-gud-control-all-threads)
+ (not gdb-non-stop))
+ (not gud-running))
+ (and gdb-gud-control-all-threads
+ (> gdb-stopped-threads-count 0))))
+
+(defun gdb-show-stop-p ()
+ "Return t if \"Stop\" should be shown on the toolbar."
+ (or (and (or
+ (not gdb-gud-control-all-threads)
+ (not gdb-non-stop))
+ gud-running)
+ (and gdb-gud-control-all-threads
+ (> gdb-running-threads-count 0))))
+
;; GUD displays the selected GDB frame. This might might not be the current
;; GDB frame (after up, down etc). If no GDB frame is visible but the last
;; visited breakpoint is, use that window.
(gdb-error . "\\([0-9]*\\)\\^error,\\(.*?\\)\n")
(gdb-console . "~\\(\".*?\"\\)\n")
(gdb-internals . "&\\(\".*?\"\\)\n")
- (gdb-stopped . "\\*stopped,?\\(.*?\n\\)")
+ (gdb-stopped . "\\*stopped,?\\(.*?\\)\n")
(gdb-running . "\\*running,\\(.*?\n\\)")
(gdb-thread-created . "=thread-created,\\(.*?\n\\)")
- (gdb-thread-exited . "=thread-exited,\\(.*?\n\\)")))
+ (gdb-thread-selected . "=thread-selected,\\(.*?\\)\n")
+ (gdb-thread-exited . "=thread-exited,\\(.*?\n\\)")
+ (gdb-ignored-notification . "=[-[:alpha:]]+,?\\(.*?\\)\n")
+ (gdb-shell . "\\(\\(?:^.+\n\\)+\\)")))
(defun gud-gdbmi-marker-filter (string)
"Filter GDB/MI output."
gdb-filter-output))
(defun gdb-gdb (output-field))
+
+(defun gdb-shell (output-field)
+ (let ((gdb-output-sink gdb-output-sink))
+ (setq gdb-filter-output
+ (concat output-field gdb-filter-output))))
+
+(defun gdb-ignored-notification (output-field))
+
+;; gdb-invalidate-threads is defined to accept 'update-threads signal
(defun gdb-thread-created (output-field))
-(defun gdb-thread-exited (output-field))
+(defun gdb-thread-exited (output-field)
+ "Handle =thread-exited async record: unset `gdb-thread-number'
+ if current thread exited and update threads list."
+ (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'id)))
+ (if (string= gdb-thread-number thread-id)
+ (gdb-setq-thread-number nil))
+ ;; When we continue current thread and it quickly exits,
+ ;; gdb-pending-triggers left after gdb-running disallow us to
+ ;; properly call -thread-info without --thread option. Thus we
+ ;; need to use gdb-wait-for-pending.
+ (gdb-wait-for-pending
+ (gdb-emit-signal gdb-buf-publisher 'update-threads))))
+
+(defun gdb-thread-selected (output-field)
+ "Handler for =thread-selected MI output record.
+
+Sets `gdb-thread-number' to new id."
+ (let* ((result (gdb-json-string output-field))
+ (thread-id (bindat-get-field result 'id)))
+ (gdb-setq-thread-number thread-id)
+ ;; Typing `thread N` in GUD buffer makes GDB emit `^done` followed
+ ;; by `=thread-selected` notification. `^done` causes `gdb-update`
+ ;; as usually. Things happen to fast and second call (from
+ ;; gdb-thread-selected handler) gets cut off by our beloved
+ ;; gdb-pending-triggers.
+ ;; Solution is `gdb-wait-for-pending` macro: it guarantees that its
+ ;; body will get executed when `gdb-pending-triggers` is empty.
+ (gdb-wait-for-pending
+ (gdb-update))))
(defun gdb-running (output-field)
+ (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'thread-id)))
+ ;; We reset gdb-frame-number to nil if current thread has gone
+ ;; running. This can't be done in gdb-thread-list-handler-custom
+ ;; because we need correct gdb-frame-number by the time
+ ;; -thread-info command is sent.
+ (when (or (string-equal thread-id "all")
+ (string-equal thread-id gdb-thread-number))
+ (setq gdb-frame-number nil)))
(setq gdb-inferior-status "running")
(gdb-force-mode-line-update
(propertize gdb-inferior-status 'face font-lock-type-face))
+ (when (not gdb-non-stop)
+ (setq gud-running t))
(setq gdb-active-process t)
- (setq gud-running t))
+ (gdb-emit-signal gdb-buf-publisher 'update-threads))
(defun gdb-starting (output-field)
;; CLI commands don't emit ^running at the moment so use gdb-running too.
- (gdb-input
- (list "-data-list-register-names" 'gdb-get-register-names))
(setq gdb-inferior-status "running")
(gdb-force-mode-line-update
(propertize gdb-inferior-status 'face font-lock-type-face))
(setq gdb-active-process t)
- (setq gud-running t))
+ (setq gud-running t)
+ ;; GDB doesn't seem to respond to -thread-info before first stop or
+ ;; thread exit (even in non-stop mode), so this is useless.
+ ;; Behaviour may change in the future.
+ (gdb-emit-signal gdb-buf-publisher 'update-threads))
;; -break-insert -t didn't give a reason before gdb 6.9
-(defconst gdb-stopped-regexp
- "\\(reason=\"\\(.*?\\)\"\\)?\\(\\(,exit-code=.*?\\)*\n\\|.*?,file=\".*?\".*?,fullname=\"\\(.*?\\)\".*?,line=\"\\(.*?\\)\".*?\n\\)")
(defun gdb-stopped (output-field)
- (setq gud-running nil)
- (string-match gdb-stopped-regexp output-field)
- (let ((reason (match-string 2 output-field))
- (file (match-string 5 output-field)))
+ "Given the contents of *stopped MI async record, select new
+current thread and update GDB buffers."
+ ;; Reason is available with target-async only
+ (let* ((result (gdb-json-string output-field))
+ (reason (bindat-get-field result 'reason))
+ (thread-id (bindat-get-field result 'thread-id)))
+
+ ;; -data-list-register-names needs to be issued for any stopped
+ ;; thread
+ (when (not gdb-register-names)
+ (gdb-input
+ (list (concat "-data-list-register-names"
+ (if (string-equal gdb-version "7.0+")
+ (concat" --thread " thread-id)))
+ 'gdb-register-names-handler)))
;;; Don't set gud-last-frame here as it's currently done in gdb-frame-handler
;;; because synchronous GDB doesn't give these fields with CLI.
;;; (string-to-number
;;; (match-string 6 gud-marker-acc)))))
- (setq gdb-inferior-status (if reason reason "unknown"))
+ (setq gdb-inferior-status (or reason "unknown"))
(gdb-force-mode-line-update
(propertize gdb-inferior-status 'face font-lock-warning-face))
(if (string-equal reason "exited-normally")
- (setq gdb-active-process nil)))
-
+ (setq gdb-active-process nil))
+
+ ;; Select new current thread.
+
+ ;; Don't switch if we have no reasons selected
+ (when gdb-switch-reasons
+ ;; Switch from another stopped thread only if we have
+ ;; gdb-switch-when-another-stopped:
+ (when (or gdb-switch-when-another-stopped
+ (not (string= "stopped"
+ (bindat-get-field (gdb-current-buffer-thread) 'state))))
+ ;; Switch if current reason has been selected or we have no
+ ;; reasons
+ (if (or (eq gdb-switch-reasons t)
+ (member reason gdb-switch-reasons))
+ (when (not (string-equal gdb-thread-number thread-id))
+ (message (concat "Switched to thread " thread-id))
+ (gdb-setq-thread-number thread-id))
+ (message (format "Thread %s stopped" thread-id)))))
+
+ ;; Print "(gdb)" to GUD console
(when gdb-first-done-or-error
- (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))
+ (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
+
+ ;; In non-stop, we update information as soon as another thread gets
+ ;; stopped
+ (when (or gdb-first-done-or-error
+ gdb-non-stop)
+ ;; In all-stop this updates gud-running properly as well.
(gdb-update)
- (setq gdb-first-done-or-error nil)))
+ (setq gdb-first-done-or-error nil))
+ (run-hook-with-args 'gdb-stopped-hooks result)))
;; Remove the trimmings from log stream containing debugging messages
;; being produced by GDB's internals, use warning face and send to GUD
(with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
(erase-buffer)))
-(defun json-partial-output (&optional fix-key fix-list)
- "Parse gdb-partial-output-buffer with `json-read'.
+(defun gdb-jsonify-buffer (&optional fix-key fix-list)
+ "Prepare GDB/MI output in current buffer for parsing with `json-read'.
-If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurences from
+Field names are wrapped in double quotes and equal signs are
+replaced with semicolons.
+
+If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurrences from
partial output. This is used to get rid of useless keys in lists
in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and
-break-info are examples of MI commands which issue such
If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with
\"FIX-LIST=[..]\" prior to parsing. This is used to fix broken
-break-info output when it contains breakpoint script field
-incompatible with GDB/MI output syntax.
-
-Note that GDB/MI output syntax is different from JSON both
-cosmetically and (in some cases) structurally, so correct results
-are not guaranteed."
- (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
+incompatible with GDB/MI output syntax."
+ (save-excursion
(goto-char (point-min))
(when fix-key
(save-excursion
(replace-match "" nil nil nil 1))))
(when fix-list
(save-excursion
- ;; Find positions of brackets which enclose broken list
+ ;; Find positions of braces which enclose broken list
(while (re-search-forward (concat fix-list "={\"") nil t)
(let ((p1 (goto-char (- (point) 2)))
(p2 (progn (forward-sexp)
(insert "]"))))))
(goto-char (point-min))
(insert "{")
- ;; Wrap field names in double quotes and replace equal sign with
- ;; semicolon.
- ;; TODO: This breaks badly with foo= inside constants
- (while (re-search-forward "\\([[:alpha:]-_]+\\)=" nil t)
- (replace-match "\"\\1\":" nil nil))
+ (while (re-search-forward
+ "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t)
+ (replace-match "\"\\1\":\\2" nil nil))
(goto-char (point-max))
- (insert "}")
+ (insert "}")))
+
+(defun gdb-json-read-buffer (&optional fix-key fix-list)
+ "Prepare and parse GDB/MI output in current buffer with `json-read'.
+
+FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'."
+ (gdb-jsonify-buffer fix-key fix-list)
+ (save-excursion
(goto-char (point-min))
(let ((json-array-type 'list))
(json-read))))
+(defun gdb-json-string (string &optional fix-key fix-list)
+ "Prepare and parse STRING containing GDB/MI output with `json-read'.
+
+FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'."
+ (with-temp-buffer
+ (insert string)
+ (gdb-json-read-buffer fix-key fix-list)))
+
+(defun gdb-json-partial-output (&optional fix-key fix-list)
+ "Prepare and parse gdb-partial-output-buffer with `json-read'.
+
+FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'."
+ (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
+ (gdb-json-read-buffer fix-key fix-list)))
+
+(defun gdb-line-posns (line)
+ "Return a pair of LINE beginning and end positions."
+ (let ((offset (1+ (- line (line-number-at-pos)))))
+ (cons
+ (line-beginning-position offset)
+ (line-end-position offset))))
+
+(defmacro gdb-mark-line (line variable)
+ "Set VARIABLE marker to point at beginning of LINE.
+
+If current window has no fringes, inverse colors on LINE.
+
+Return position where LINE begins."
+ `(save-excursion
+ (let* ((posns (gdb-line-posns ,line))
+ (start-posn (car posns))
+ (end-posn (cdr posns)))
+ (set-marker ,variable (copy-marker start-posn))
+ (when (not (> (car (window-fringes)) 0))
+ (put-text-property start-posn end-posn
+ 'font-lock-face '(:inverse-video t)))
+ start-posn)))
+
(defun gdb-pad-string (string padding)
(format (concat "%" (number-to-string padding) "s") string))
-(defalias 'gdb-get-field 'bindat-get-field)
-
+;; gdb-table struct is a way to programmatically construct simple
+;; tables. It help to reliably align columns of data in GDB buffers
+;; and provides
+(defstruct
+ gdb-table
+ (column-sizes nil)
+ (rows nil)
+ (row-properties nil)
+ (right-align nil))
+
+(defun gdb-mapcar* (function &rest seqs)
+ "Apply FUNCTION to each element of SEQS, and make a list of the results.
+If there are several SEQS, FUNCTION is called with that many
+arugments, and mapping stops as sson as the shortest list runs
+out."
+ (let ((shortest (apply #'min (mapcar #'length seqs))))
+ (mapcar (lambda (i)
+ (apply function
+ (mapcar
+ (lambda (seq)
+ (nth i seq))
+ seqs)))
+ (number-sequence 0 (1- shortest)))))
+
+(defun gdb-table-add-row (table row &optional properties)
+ "Add ROW of string to TABLE and recalculate column sizes.
+
+When non-nil, PROPERTIES will be added to the whole row when
+calling `gdb-table-string'."
+ (let ((rows (gdb-table-rows table))
+ (row-properties (gdb-table-row-properties table))
+ (column-sizes (gdb-table-column-sizes table))
+ (right-align (gdb-table-right-align table)))
+ (when (not column-sizes)
+ (setf (gdb-table-column-sizes table)
+ (make-list (length row) 0)))
+ (setf (gdb-table-rows table)
+ (append rows (list row)))
+ (setf (gdb-table-row-properties table)
+ (append row-properties (list properties)))
+ (setf (gdb-table-column-sizes table)
+ (gdb-mapcar* (lambda (x s)
+ (let ((new-x
+ (max (abs x) (string-width (or s "")))))
+ (if right-align new-x (- new-x))))
+ (gdb-table-column-sizes table)
+ row))
+ ;; Avoid trailing whitespace at eol
+ (if (not (gdb-table-right-align table))
+ (setcar (last (gdb-table-column-sizes table)) 0))))
+
+(defun gdb-table-string (table &optional sep)
+ "Return TABLE as a string with columns separated with SEP."
+ (let ((column-sizes (gdb-table-column-sizes table))
+ (res ""))
+ (mapconcat
+ 'identity
+ (gdb-mapcar*
+ (lambda (row properties)
+ (apply 'propertize
+ (mapconcat 'identity
+ (gdb-mapcar* (lambda (s x) (gdb-pad-string s x))
+ row column-sizes)
+ sep)
+ properties))
+ (gdb-table-rows table)
+ (gdb-table-row-properties table))
+ "\n")))
+
+;; bindat-get-field goes deep, gdb-get-many-fields goes wide
(defun gdb-get-many-fields (struct &rest fields)
"Return a list of FIELDS values from STRUCT."
(let ((values))
(dolist (field fields values)
- (setq values (append values (list (gdb-get-field struct field)))))))
-
-;; NAME is the function name. DEMAND-PREDICATE tests if output is really needed.
-;; GDB-COMMAND is a string of such. OUTPUT-HANDLER is the function bound to the
-;; current input.
-
-(defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command
- output-handler)
- `(defun ,name (&optional ignored)
- (if (and ,demand-predicate
- (not (member ',name
- gdb-pending-triggers)))
- (progn
- (gdb-input
- (list ,gdb-command ',output-handler))
- (push ',name gdb-pending-triggers)))))
-
-(defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun)
- "Define a handler NAME for TRIGGER acting in BUF-KEY with CUSTOM-DEFUN.
-
-Delete TRIGGER from `gdb-pending-triggers', switch to gdb BUF-KEY
-buffer using `gdb-get-buffer', erase it and evalueat
-CUSTOM-DEFUN."
- `(defun ,name ()
- (setq gdb-pending-triggers
- (delq ',trigger
- gdb-pending-triggers))
- (let ((buf (gdb-get-buffer ',buf-key)))
- (and buf
- (with-current-buffer buf
- (let*((buffer-read-only nil))
- (erase-buffer)
- (,custom-defun)))))))
-
-(defmacro def-gdb-auto-updated-buffer (buf-key
- trigger-name gdb-command
- output-handler-name custom-defun)
- "Define a trigger and its handler for buffers of type BUF-KEY.
-
-TRIGGER-NAME trigger is defined to send GDB-COMMAND if BUF-KEY
-exists.
-
-OUTPUT-HANDLER-NAME handler uses customization of CUSTOM-DEFUN."
+ (setq values (append values (list (bindat-get-field struct field)))))))
+
+(defmacro def-gdb-auto-update-trigger (trigger-name gdb-command
+ handler-name
+ &optional signal-list)
+ "Define a trigger TRIGGER-NAME which sends GDB-COMMAND and sets
+HANDLER-NAME as its handler. HANDLER-NAME is bound to current
+buffer with `gdb-bind-function-to-buffer'.
+
+If SIGNAL-LIST is non-nil, GDB-COMMAND is sent only when the
+defined trigger is called with an argument from SIGNAL-LIST. It's
+not recommended to define triggers with empty SIGNAL-LIST.
+Normally triggers should respond at least to 'update signal.
+
+Normally the trigger defined by this command must be called from
+the buffer where HANDLER-NAME must work. This should be done so
+that buffer-local thread number may be used in GDB-COMMAND (by
+calling `gdb-current-context-command').
+`gdb-bind-function-to-buffer' is used to achieve this, see
+`gdb-get-buffer-create'.
+
+Triggers defined by this command are meant to be used as a
+trigger argument when describing buffer types with
+`gdb-set-buffer-rules'."
+ `(defun ,trigger-name (&optional signal)
+ (when
+ (or (not ,signal-list)
+ (memq signal ,signal-list))
+ (when (not (gdb-pending-p
+ (cons (current-buffer) ',trigger-name)))
+ (gdb-input
+ (list ,gdb-command
+ (gdb-bind-function-to-buffer ',handler-name (current-buffer))))
+ (gdb-add-pending (cons (current-buffer) ',trigger-name))))))
+
+;; Used by disassembly buffer only, the rest use
+;; def-gdb-trigger-and-handler
+(defmacro def-gdb-auto-update-handler (handler-name trigger-name custom-defun
+ &optional nopreserve)
+ "Define a handler HANDLER-NAME for TRIGGER-NAME with CUSTOM-DEFUN.
+
+Handlers are normally called from the buffers they put output in.
+
+Delete ((current-buffer) . TRIGGER-NAME) from
+`gdb-pending-triggers', erase current buffer and evaluate
+CUSTOM-DEFUN. Then `gdb-update-buffer-name' is called.
+
+If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN."
+ `(defun ,handler-name ()
+ (gdb-delete-pending (cons (current-buffer) ',trigger-name))
+ (let* ((buffer-read-only nil)
+ (window (get-buffer-window (current-buffer) 0))
+ (start (window-start window))
+ (p (window-point window)))
+ (erase-buffer)
+ (,custom-defun)
+ (gdb-update-buffer-name)
+ ,(when (not nopreserve)
+ '(set-window-start window start)
+ '(set-window-point window p)))))
+
+(defmacro def-gdb-trigger-and-handler (trigger-name gdb-command
+ handler-name custom-defun
+ &optional signal-list)
+ "Define trigger and handler.
+
+TRIGGER-NAME trigger is defined to send GDB-COMMAND. See
+`def-gdb-auto-update-trigger'.
+
+HANDLER-NAME handler uses customization of CUSTOM-DEFUN. See
+`def-gdb-auto-update-handler'."
`(progn
(def-gdb-auto-update-trigger ,trigger-name
- ;; The demand predicate:
- (gdb-get-buffer ',buf-key)
,gdb-command
- ,output-handler-name)
- (def-gdb-auto-update-handler ,output-handler-name
- ,trigger-name ,buf-key ,custom-defun)))
+ ,handler-name ,signal-list)
+ (def-gdb-auto-update-handler ,handler-name
+ ,trigger-name ,custom-defun)))
\f
;; Breakpoint buffer : This displays the output of `-break-list'.
-;;
-(gdb-set-buffer-rules 'gdb-breakpoints-buffer
- 'gdb-breakpoints-buffer-name
- 'gdb-breakpoints-mode)
-
-(def-gdb-auto-updated-buffer gdb-breakpoints-buffer
+(def-gdb-trigger-and-handler
gdb-invalidate-breakpoints "-break-list"
- gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom)
+ gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom
+ '(start update))
+
+(gdb-set-buffer-rules
+ 'gdb-breakpoints-buffer
+ 'gdb-breakpoints-buffer-name
+ 'gdb-breakpoints-mode
+ 'gdb-invalidate-breakpoints)
(defun gdb-breakpoints-list-handler-custom ()
- (setq gdb-pending-triggers (delq 'gdb-invalidate-breakpoints
- gdb-pending-triggers))
- (let ((breakpoints-list (gdb-get-field
- (json-partial-output "bkpt" "script")
- 'BreakpointTable 'body)))
- (setq gdb-breakpoints-list breakpoints-list)
- (insert "Num\tType\t\tDisp\tEnb\tHits\tAddr What\n")
+ (let ((breakpoints-list (bindat-get-field
+ (gdb-json-partial-output "bkpt" "script")
+ 'BreakpointTable 'body))
+ (table (make-gdb-table)))
+ (setq gdb-breakpoints-list nil)
+ (gdb-table-add-row table '("Num" "Type" "Disp" "Enb" "Addr" "Hits" "What"))
(dolist (breakpoint breakpoints-list)
- (insert
- (concat
- (gdb-get-field breakpoint 'number) "\t"
- (gdb-get-field breakpoint 'type) "\t"
- (gdb-get-field breakpoint 'disp) "\t"
- (let ((flag (gdb-get-field breakpoint 'enabled)))
+ (add-to-list 'gdb-breakpoints-list
+ (cons (bindat-get-field breakpoint 'number)
+ breakpoint))
+ (let ((at (bindat-get-field breakpoint 'at))
+ (pending (bindat-get-field breakpoint 'pending))
+ (func (bindat-get-field breakpoint 'func))
+ (type (bindat-get-field breakpoint 'type)))
+ (gdb-table-add-row table
+ (list
+ (bindat-get-field breakpoint 'number)
+ type
+ (bindat-get-field breakpoint 'disp)
+ (let ((flag (bindat-get-field breakpoint 'enabled)))
(if (string-equal flag "y")
- (propertize "y" 'face font-lock-warning-face)
- (propertize "n" 'face font-lock-type-face))) "\t"
- (gdb-get-field breakpoint 'times) "\t"
- (gdb-get-field breakpoint 'addr)))
- (let ((at (gdb-get-field breakpoint 'at)))
- (cond ((not at)
- (progn
- (insert
- (concat " in "
- (propertize (gdb-get-field breakpoint 'func)
- 'face font-lock-function-name-face)))
- (gdb-insert-frame-location breakpoint)
- (add-text-properties (line-beginning-position)
- (line-end-position)
- '(mouse-face highlight
- help-echo "mouse-2, RET: visit breakpoint"))))
- (at (insert (concat " " at)))
- (t (insert (gdb-get-field breakpoint 'original-location)))))
- (add-text-properties (line-beginning-position)
- (line-end-position)
- `(gdb-breakpoint ,breakpoint))
- (newline))
+ (propertize "y" 'font-lock-face font-lock-warning-face)
+ (propertize "n" 'font-lock-face font-lock-comment-face)))
+ (bindat-get-field breakpoint 'addr)
+ (bindat-get-field breakpoint 'times)
+ (if (string-match ".*watchpoint" type)
+ (bindat-get-field breakpoint 'what)
+ (or pending at
+ (concat "in "
+ (propertize func 'font-lock-face font-lock-function-name-face)
+ (gdb-frame-location breakpoint)))))
+ ;; Add clickable properties only for breakpoints with file:line
+ ;; information
+ (append (list 'gdb-breakpoint breakpoint)
+ (when func '(help-echo "mouse-2, RET: visit breakpoint"
+ mouse-face highlight))))))
+ (insert (gdb-table-string table " "))
(gdb-place-breakpoints)))
;; Put breakpoint icons in relevant margins (even those set in the GUD buffer).
(not (string-match "\\` ?\\*.+\\*\\'" (buffer-name))))
(gdb-remove-breakpoint-icons (point-min) (point-max)))))
(dolist (breakpoint gdb-breakpoints-list)
- (let ((line (gdb-get-field breakpoint 'line)))
+ (let* ((breakpoint (cdr breakpoint)) ; gdb-breakpoints-list is
+ ; an associative list
+ (line (bindat-get-field breakpoint 'line)))
(when line
- (let ((file (gdb-get-field breakpoint 'fullname))
- (flag (gdb-get-field breakpoint 'enabled))
- (bptno (gdb-get-field breakpoint 'number)))
+ (let ((file (bindat-get-field breakpoint 'fullname))
+ (flag (bindat-get-field breakpoint 'enabled))
+ (bptno (bindat-get-field breakpoint 'number)))
(unless (file-exists-p file)
(setq file (cdr (assoc bptno gdb-location-alist))))
(if (and file
(find-file-noselect file 'nowarn)
(gdb-init-buffer)
;; Only want one breakpoint icon at each location.
- (save-excursion
- (goto-line (string-to-number line))
- (gdb-put-breakpoint-icon (string-equal flag "y") bptno)))
+ (gdb-put-breakpoint-icon (string-equal flag "y") bptno
+ (string-to-number line)))
(gdb-input
(list (concat "list " file ":1")
'ignore))
(with-current-buffer (find-file-noselect (match-string 1))
(gdb-init-buffer)
;; only want one breakpoint icon at each location
- (save-excursion
- (goto-line (string-to-number line))
- (gdb-put-breakpoint-icon (eq flag ?y) bptno)))))
+ (gdb-put-breakpoint-icon (eq flag ?y) bptno (string-to-number line)))))
(add-hook 'find-file-hook 'gdb-find-file-hook)
(mouse-minibuffer-check event)
(let ((posn (event-end event)))
(with-selected-window (posn-window posn)
- (if (or (buffer-file-name) (eq major-mode 'gdb-disassembly-mode))
+ (if (or (buffer-file-name) (derived-mode-p 'gdb-disassembly-mode))
(if (numberp (posn-point posn))
(save-excursion
(goto-char (posn-point posn))
obj)
(when (numberp pos)
(with-selected-window (posn-window posn)
- (save-excursion
- (set-buffer (window-buffer (selected-window)))
+ (with-current-buffer (window-buffer (selected-window))
(goto-char pos)
(dolist (overlay (overlays-in pos pos))
(when (overlay-get overlay 'put-break)
(get-text-property 0 'gdb-bptno obj)))))))))
(defun gdb-breakpoints-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*breakpoints of " (gdb-get-target-string) "*")))
+ (concat "*breakpoints of " (gdb-get-target-string) "*"))
(def-gdb-display-buffer
gdb-display-breakpoints-buffer
;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons.
(define-key map "q" 'gdb-delete-frame-or-window)
(define-key map "\r" 'gdb-goto-breakpoint)
+ (define-key map "\t" '(lambda ()
+ (interactive)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create 'gdb-threads-buffer) t)))
(define-key map [mouse-2] 'gdb-goto-breakpoint)
(define-key map [follow-link] 'mouse-face)
map))
(defmacro gdb-propertize-header (name buffer help-echo mouse-face face)
`(propertize ,name
- 'help-echo ,help-echo
+ 'help-echo ,help-echo
'mouse-face ',mouse-face
'face ',face
'local-map
(lambda (event) (interactive "e")
(save-selected-window
(select-window (posn-window (event-start event)))
- (set-window-dedicated-p (selected-window) nil)
- (switch-to-buffer
- (gdb-get-buffer-create ',buffer))
- (setq header-line-format(gdb-set-header ',buffer))
- (set-window-dedicated-p (selected-window) t))))))
-
-(defun gdb-set-header (buffer)
- (cond ((eq buffer 'gdb-locals-buffer)
- (list
- (gdb-propertize-header "Locals" gdb-locals-buffer
- nil nil mode-line)
- " "
- (gdb-propertize-header "Registers" gdb-registers-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)))
- ((eq buffer 'gdb-registers-buffer)
- (list
- (gdb-propertize-header "Locals" gdb-locals-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)
- " "
- (gdb-propertize-header "Registers" gdb-registers-buffer
- nil nil mode-line)))
- ((eq buffer 'gdb-breakpoints-buffer)
- (list
- (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
- nil nil mode-line)
- " "
- (gdb-propertize-header "Threads" gdb-threads-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)))
- ((eq buffer 'gdb-threads-buffer)
- (list
- (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)
- " "
- (gdb-propertize-header "Threads" gdb-threads-buffer
- nil nil mode-line)))))
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create ',buffer) t) )))))
\f
;; uses "-thread-info". Needs GDB 7.0 onwards.
;;; Threads view
-(defun gdb-jump-to (file line)
- (find-file-other-window file)
- (goto-line line))
-
-(define-button-type 'gdb-file-button
- 'help-echo "Push to jump to source code"
-; 'face 'bold
- 'action
- (lambda (b)
- (gdb-jump-to (button-get b 'file)
- (button-get b 'line))))
-
-(defun gdb-insert-file-location-button (file line)
- "Insert text button which allows jumping to FILE:LINE.
-
-FILE is a full path."
- (insert-text-button
- (format "%s:%d" (file-name-nondirectory file) line)
- :type 'gdb-file-button
- 'file file
- 'line line))
-
(defun gdb-threads-buffer-name ()
(concat "*threads of " (gdb-get-target-string) "*"))
'gdb-threads-buffer
"Display GDB threads in a new frame.")
-(gdb-set-buffer-rules 'gdb-threads-buffer
- 'gdb-threads-buffer-name
- 'gdb-threads-mode)
-
-(def-gdb-auto-updated-buffer gdb-threads-buffer
- gdb-invalidate-threads "-thread-info"
- gdb-thread-list-handler gdb-thread-list-handler-custom)
+(def-gdb-trigger-and-handler
+ gdb-invalidate-threads (gdb-current-context-command "-thread-info")
+ gdb-thread-list-handler gdb-thread-list-handler-custom
+ '(start update update-threads))
+(gdb-set-buffer-rules
+ 'gdb-threads-buffer
+ 'gdb-threads-buffer-name
+ 'gdb-threads-mode
+ 'gdb-invalidate-threads)
(defvar gdb-threads-font-lock-keywords
- '(("in \\([^ ]+\\) (" (1 font-lock-function-name-face))
- (" \\(stopped\\) in " (1 font-lock-warning-face))
+ '(("in \\([^ ]+\\)" (1 font-lock-function-name-face))
+ (" \\(stopped\\)" (1 font-lock-warning-face))
+ (" \\(running\\)" (1 font-lock-string-face))
("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face)))
"Font lock keywords used in `gdb-threads-mode'.")
(defvar gdb-threads-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map " " 'gdb-select-thread)
+ (define-key map "\r" 'gdb-select-thread)
+ (define-key map "f" 'gdb-display-stack-for-thread)
+ (define-key map "F" 'gdb-frame-stack-for-thread)
+ (define-key map "l" 'gdb-display-locals-for-thread)
+ (define-key map "L" 'gdb-frame-locals-for-thread)
+ (define-key map "r" 'gdb-display-registers-for-thread)
+ (define-key map "R" 'gdb-frame-registers-for-thread)
+ (define-key map "d" 'gdb-display-disassembly-for-thread)
+ (define-key map "D" 'gdb-frame-disassembly-for-thread)
+ (define-key map "i" 'gdb-interrupt-thread)
+ (define-key map "c" 'gdb-continue-thread)
+ (define-key map "s" 'gdb-step-thread)
+ (define-key map "\t" '(lambda ()
+ (interactive)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create 'gdb-breakpoints-buffer) t)))
+ (define-key map [mouse-2] 'gdb-select-thread)
+ (define-key map [follow-link] 'mouse-face)
map))
-(defvar gdb-breakpoints-header
+(defvar gdb-threads-header
(list
(gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
- nil nil mode-line)
+ "mouse-1: select" mode-line-highlight mode-line-inactive)
" "
(gdb-propertize-header "Threads" gdb-threads-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)))
-
-(defun gdb-threads-mode ()
- "Major mode for GDB threads.
+ nil nil mode-line)))
-\\{gdb-threads-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-threads-mode)
- (setq mode-name "Threads")
- (use-local-map gdb-threads-mode-map)
- (setq buffer-read-only t)
- (buffer-disable-undo)
+(define-derived-mode gdb-threads-mode gdb-parent-mode "Threads"
+ "Major mode for GDB threads."
(setq gdb-thread-position (make-marker))
(add-to-list 'overlay-arrow-variable-list 'gdb-thread-position)
- (setq header-line-format gdb-breakpoints-header)
+ (setq header-line-format gdb-threads-header)
(set (make-local-variable 'font-lock-defaults)
'(gdb-threads-font-lock-keywords))
- (run-mode-hooks 'gdb-threads-mode-hook)
'gdb-invalidate-threads)
(defun gdb-thread-list-handler-custom ()
- (let* ((res (json-partial-output))
- (threads-list (gdb-get-field res 'threads))
- (current-thread (gdb-get-field res 'current-thread-id)))
- (when (and current-thread
- (not (string-equal current-thread gdb-thread-number)))
- ;; Implicitly switch thread (in case previous one dies)
- (message (concat "GDB switched to another thread: " current-thread))
- (setq gdb-thread-number current-thread))
+ (let ((threads-list (bindat-get-field (gdb-json-partial-output) 'threads))
+ (table (make-gdb-table))
+ (marked-line nil))
+ (setq gdb-threads-list nil)
+ (setq gdb-running-threads-count 0)
+ (setq gdb-stopped-threads-count 0)
(set-marker gdb-thread-position nil)
- (dolist (thread threads-list)
- (insert (apply 'format `("%s (%s) %s in %s "
- ,@(gdb-get-many-fields thread 'id 'target-id 'state)
- ,(gdb-get-field thread 'frame 'func))))
- ;; Arguments
- (insert "(")
- (let ((args (gdb-get-field thread 'frame 'args)))
- (dolist (arg args)
- (insert (apply 'format `("%s=%s" ,@(gdb-get-many-fields arg 'name 'value)))))
- (when args (kill-backward-chars 1)))
- (insert ")")
- (gdb-insert-frame-location (gdb-get-field thread 'frame))
- (insert (format " at %s" (gdb-get-field thread 'frame 'addr)))
- (add-text-properties (line-beginning-position)
- (line-end-position)
- `(gdb-thread ,thread))
- (when (string-equal gdb-thread-number
- (gdb-get-field thread 'id))
- (set-marker gdb-thread-position (line-beginning-position)))
- (newline))))
-(defun gdb-select-thread ()
- "Select the thread at current line of threads buffer."
- (interactive)
- (save-excursion
- (beginning-of-line)
- (let ((thread (get-text-property (point) 'gdb-thread)))
- (if thread
- (if (string-equal (gdb-get-field thread 'state) "running")
- (error "Cannot select running thread")
- (let ((new-id (gdb-get-field thread 'id)))
- (setq gdb-thread-number new-id)
- (gud-basic-call (concat "-thread-select " new-id))))
- (error "Not recognized as thread line")))))
+ (dolist (thread (reverse threads-list))
+ (let ((running (string-equal (bindat-get-field thread 'state) "running")))
+ (add-to-list 'gdb-threads-list
+ (cons (bindat-get-field thread 'id)
+ thread))
+ (if running
+ (incf gdb-running-threads-count)
+ (incf gdb-stopped-threads-count))
+
+ (gdb-table-add-row table
+ (list
+ (bindat-get-field thread 'id)
+ (concat
+ (if gdb-thread-buffer-verbose-names
+ (concat (bindat-get-field thread 'target-id) " ") "")
+ (bindat-get-field thread 'state)
+ ;; Include frame information for stopped threads
+ (if (not running)
+ (concat
+ " in " (bindat-get-field thread 'frame 'func)
+ (if gdb-thread-buffer-arguments
+ (concat
+ " ("
+ (let ((args (bindat-get-field thread 'frame 'args)))
+ (mapconcat
+ (lambda (arg)
+ (apply 'format `("%s=%s" ,@(gdb-get-many-fields arg 'name 'value))))
+ args ","))
+ ")")
+ "")
+ (if gdb-thread-buffer-locations
+ (gdb-frame-location (bindat-get-field thread 'frame)) "")
+ (if gdb-thread-buffer-addresses
+ (concat " at " (bindat-get-field thread 'frame 'addr)) ""))
+ "")))
+ (list
+ 'gdb-thread thread
+ 'mouse-face 'highlight
+ 'help-echo "mouse-2, RET: select thread")))
+ (when (string-equal gdb-thread-number
+ (bindat-get-field thread 'id))
+ (setq marked-line (length gdb-threads-list))))
+ (insert (gdb-table-string table " "))
+ (when marked-line
+ (gdb-mark-line marked-line gdb-thread-position)))
+ ;; We update gud-running here because we need to make sure that
+ ;; gdb-threads-list is up-to-date
+ (gdb-update-gud-running)
+ (gdb-emit-signal gdb-buf-publisher 'update-disassembly))
+
+(defmacro def-gdb-thread-buffer-command (name custom-defun &optional doc)
+ "Define a NAME command which will act upon thread on the current line.
+
+CUSTOM-DEFUN may use locally bound `thread' variable, which will
+be the value of 'gdb-thread property of the current line. If
+'gdb-thread is nil, error is signaled."
+ `(defun ,name (&optional event)
+ ,(when doc doc)
+ (interactive (list last-input-event))
+ (if event (posn-set-point (event-end event)))
+ (save-excursion
+ (beginning-of-line)
+ (let ((thread (get-text-property (point) 'gdb-thread)))
+ (if thread
+ ,custom-defun
+ (error "Not recognized as thread line"))))))
+
+(defmacro def-gdb-thread-buffer-simple-command (name buffer-command &optional doc)
+ "Define a NAME which will call BUFFER-COMMAND with id of thread
+on the current line."
+ `(def-gdb-thread-buffer-command ,name
+ (,buffer-command (bindat-get-field thread 'id))
+ ,doc))
+
+(def-gdb-thread-buffer-command gdb-select-thread
+ (let ((new-id (bindat-get-field thread 'id)))
+ (gdb-setq-thread-number new-id)
+ (gdb-input (list (concat "-thread-select " new-id) 'ignore))
+ (gdb-update))
+ "Select the thread at current line of threads buffer.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-display-stack-for-thread
+ gdb-preemptively-display-stack-buffer
+ "Display stack buffer for the thread at current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-display-locals-for-thread
+ gdb-preemptively-display-locals-buffer
+ "Display locals buffer for the thread at current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-display-registers-for-thread
+ gdb-preemptively-display-registers-buffer
+ "Display registers buffer for the thread at current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-display-disassembly-for-thread
+ gdb-preemptively-display-disassembly-buffer
+ "Display disassembly buffer for the thread at current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-frame-stack-for-thread
+ gdb-frame-stack-buffer
+ "Display a new frame with stack buffer for the thread at
+current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-frame-locals-for-thread
+ gdb-frame-locals-buffer
+ "Display a new frame with locals buffer for the thread at
+current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-frame-registers-for-thread
+ gdb-frame-registers-buffer
+ "Display a new frame with registers buffer for the thread at
+current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-frame-disassembly-for-thread
+ gdb-frame-disassembly-buffer
+ "Display a new frame with disassembly buffer for the thread at
+current line.")
+
+(defmacro def-gdb-thread-buffer-gud-command (name gud-command &optional doc)
+ "Define a NAME which will execute GUD-COMMAND with
+`gdb-thread-number' locally bound to id of thread on the current
+line."
+ `(def-gdb-thread-buffer-command ,name
+ (if gdb-non-stop
+ (let ((gdb-thread-number (bindat-get-field thread 'id))
+ (gdb-gud-control-all-threads nil))
+ (call-interactively #',gud-command))
+ (error "Available in non-stop mode only, customize `gdb-non-stop-setting'"))
+ ,doc))
+
+(def-gdb-thread-buffer-gud-command
+ gdb-interrupt-thread
+ gud-stop-subjob
+ "Interrupt thread at current line.")
+
+(def-gdb-thread-buffer-gud-command
+ gdb-continue-thread
+ gud-cont
+ "Continue thread at current line.")
+
+(def-gdb-thread-buffer-gud-command
+ gdb-step-thread
+ gud-step
+ "Step thread at current line.")
\f
;;; Memory view
:group 'gud
:version "23.2")
-(gdb-set-buffer-rules 'gdb-memory-buffer
- 'gdb-memory-buffer-name
- 'gdb-memory-mode)
-
-(def-gdb-auto-updated-buffer gdb-memory-buffer
+(def-gdb-trigger-and-handler
gdb-invalidate-memory
- (format "-data-read-memory %s %s %d %d %d"
+ (format "-data-read-memory %s %s %d %d %d"
gdb-memory-address
gdb-memory-format
gdb-memory-unit
gdb-memory-rows
gdb-memory-columns)
gdb-read-memory-handler
- gdb-read-memory-custom)
+ gdb-read-memory-custom
+ '(start update))
+
+(gdb-set-buffer-rules
+ 'gdb-memory-buffer
+ 'gdb-memory-buffer-name
+ 'gdb-memory-mode
+ 'gdb-invalidate-memory)
(defun gdb-memory-column-width (size format)
"Return length of string with memory unit of SIZE in FORMAT.
(error "Unknown format"))))
(defun gdb-read-memory-custom ()
- (let* ((res (json-partial-output))
- (err-msg (gdb-get-field res 'msg)))
+ (let* ((res (gdb-json-partial-output))
+ (err-msg (bindat-get-field res 'msg)))
(if (not err-msg)
- (let ((memory (gdb-get-field res 'memory)))
- (setq gdb-memory-address (gdb-get-field res 'addr))
- (setq gdb-memory-next-page (gdb-get-field res 'next-page))
- (setq gdb-memory-prev-page (gdb-get-field res 'prev-page))
+ (let ((memory (bindat-get-field res 'memory)))
+ (setq gdb-memory-address (bindat-get-field res 'addr))
+ (setq gdb-memory-next-page (bindat-get-field res 'next-page))
+ (setq gdb-memory-prev-page (bindat-get-field res 'prev-page))
(setq gdb-memory-last-address gdb-memory-address)
(dolist (row memory)
- (insert (concat (gdb-get-field row 'addr) ":"))
- (dolist (column (gdb-get-field row 'data))
+ (insert (concat (bindat-get-field row 'addr) ":"))
+ (dolist (column (bindat-get-field row 'data))
(insert (gdb-pad-string column
(+ 2 (gdb-memory-column-width
gdb-memory-unit
;; Show last page instead of empty buffer when out of bounds
(progn
(let ((gdb-memory-address gdb-memory-last-address))
- (gdb-invalidate-memory)
+ (gdb-invalidate-memory 'update)
(error err-msg))))))
(defvar gdb-memory-mode-map
(interactive)
(let ((arg (read-from-minibuffer "Memory address: ")))
(setq gdb-memory-address arg))
- (gdb-invalidate-memory))
+ (gdb-invalidate-memory 'update))
(defmacro def-gdb-set-positive-number (name variable echo-string &optional doc)
"Define a function NAME which reads new VAR value from minibuffer."
(if (<= count 0)
(error "Positive number only")
(customize-set-variable ',variable count)
- (gdb-invalidate-memory))))))
+ (gdb-invalidate-memory 'update))))))
(def-gdb-set-positive-number
gdb-memory-set-rows
`(defun ,name () ,(when doc doc)
(interactive)
(customize-set-variable 'gdb-memory-format ,format)
- (gdb-invalidate-memory)))
+ (gdb-invalidate-memory 'update)))
(def-gdb-memory-format
gdb-memory-format-binary "t"
`(defun ,name () ,(when doc doc)
(interactive)
(customize-set-variable 'gdb-memory-unit ,unit-size)
- (gdb-invalidate-memory)))
+ (gdb-invalidate-memory 'update)))
(def-gdb-memory-unit gdb-memory-unit-giant 8
"Set the unit size to giant words (eight bytes).")
'local-map gdb-memory-unit-map)))
"Header line used in `gdb-memory-mode'.")
-(defun gdb-memory-mode ()
- "Major mode for examining memory.
-
-\\{gdb-memory-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-memory-mode)
- (setq mode-name "Memory")
- (use-local-map gdb-memory-mode-map)
- (setq buffer-read-only t)
+(define-derived-mode gdb-memory-mode gdb-parent-mode "Memory"
+ "Major mode for examining memory."
(setq header-line-format gdb-memory-header)
(set (make-local-variable 'font-lock-defaults)
'(gdb-memory-font-lock-keywords))
- (run-mode-hooks 'gdb-memory-mode-hook)
'gdb-invalidate-memory)
(defun gdb-memory-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*memory of " (gdb-get-target-string) "*")))
+ (concat "*memory of " (gdb-get-target-string) "*"))
(def-gdb-display-buffer
gdb-display-memory-buffer
(special-display-frame-alist
`((left-fringe . 0)
(right-fringe . 0)
- (width . 83)
+ (width . 83)
,@gdb-frame-parameters)))
(display-buffer (gdb-get-buffer-create 'gdb-memory-buffer))))
;;; Disassembly view
(defun gdb-disassembly-buffer-name ()
- (concat "*disassembly of " (gdb-get-target-string) "*"))
+ (gdb-current-context-buffer-name
+ (concat "disassembly of " (gdb-get-target-string))))
(def-gdb-display-buffer
gdb-display-disassembly-buffer
'gdb-disassembly-buffer
"Display disassembly for current stack frame.")
+(def-gdb-preempt-display-buffer
+ gdb-preemptively-display-disassembly-buffer
+ 'gdb-disassembly-buffer)
+
(def-gdb-frame-for-buffer
gdb-frame-disassembly-buffer
'gdb-disassembly-buffer
"Display disassembly in a new frame.")
-(gdb-set-buffer-rules 'gdb-disassembly-buffer
- 'gdb-disassembly-buffer-name
- 'gdb-disassembly-mode)
-
(def-gdb-auto-update-trigger gdb-invalidate-disassembly
- (gdb-get-buffer 'gdb-disassembly-buffer)
- (let ((file (or gdb-selected-file gdb-main-file))
- (line (or gdb-selected-line 1)))
- (if (not file) (error "Disassembly invalidated with no file selected.")
- (format "-data-disassemble -f %s -l %d -n -1 -- 0" file line)))
- gdb-disassembly-handler)
+ (let* ((frame (gdb-current-buffer-frame))
+ (file (bindat-get-field frame 'fullname))
+ (line (bindat-get-field frame 'line)))
+ (when file
+ (format "-data-disassemble -f %s -l %s -n -1 -- 0" file line)))
+ gdb-disassembly-handler
+ ;; We update disassembly only after we have actual frame information
+ ;; about all threads, so no there's `update' signal in this list
+ '(start update-disassembly))
(def-gdb-auto-update-handler
gdb-disassembly-handler
gdb-invalidate-disassembly
- gdb-disassembly-buffer
- gdb-disassembly-handler-custom)
+ gdb-disassembly-handler-custom
+ t)
+
+(gdb-set-buffer-rules
+ 'gdb-disassembly-buffer
+ 'gdb-disassembly-buffer-name
+ 'gdb-disassembly-mode
+ 'gdb-invalidate-disassembly)
(defvar gdb-disassembly-font-lock-keywords
'(;; <__function.name+n>
(define-key map "q" 'kill-this-buffer)
map))
-(defun gdb-disassembly-mode ()
- "Major mode for GDB disassembly information.
-
-\\{gdb-disassembly-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-disassembly-mode)
- (setq mode-name "Disassembly")
- (add-to-list 'overlay-arrow-variable-list 'gdb-overlay-arrow-position)
+(define-derived-mode gdb-disassembly-mode gdb-parent-mode "Disassembly"
+ "Major mode for GDB disassembly information."
+ ;; TODO Rename overlay variable for disassembly mode
+ (add-to-list 'overlay-arrow-variable-list 'gdb-disassembly-position)
(setq fringes-outside-margins t)
- (setq gdb-overlay-arrow-position (make-marker))
- (use-local-map gdb-disassembly-mode-map)
- (setq buffer-read-only t)
- (buffer-disable-undo)
+ (set (make-local-variable 'gdb-disassembly-position) (make-marker))
(set (make-local-variable 'font-lock-defaults)
'(gdb-disassembly-font-lock-keywords))
- (run-mode-hooks 'gdb-disassembly-mode-hook)
'gdb-invalidate-disassembly)
(defun gdb-disassembly-handler-custom ()
- (let* ((res (json-partial-output))
- (instructions (gdb-get-field res 'asm_insns))
- (pos 1))
- (let* ((last-instr (car (last instructions)))
- (column-padding (+ 2 (string-width
- (apply 'format
- `("<%s+%s>:"
- ,@(gdb-get-many-fields last-instr 'func-name 'offset)))))))
+ (let* ((instructions (bindat-get-field (gdb-json-partial-output) 'asm_insns))
+ (address (bindat-get-field (gdb-current-buffer-frame) 'addr))
+ (pos 1)
+ (table (make-gdb-table))
+ (marked-line nil))
(dolist (instr instructions)
- ;; Put overlay arrow
- (when (string-equal (gdb-get-field instr 'address)
- gdb-pc-address)
+ (gdb-table-add-row table
+ (list
+ (bindat-get-field instr 'address)
+ (apply 'format `("<%s+%s>:" ,@(gdb-get-many-fields instr 'func-name 'offset)))
+ (bindat-get-field instr 'inst)))
+ (when (string-equal (bindat-get-field instr 'address)
+ address)
(progn
- (setq pos (point))
+ (setq marked-line (length (gdb-table-rows table)))
(setq fringe-indicator-alist
(if (string-equal gdb-frame-number "0")
nil
- '((overlay-arrow . hollow-right-triangle))))
- (set-marker gdb-overlay-arrow-position (point))))
- (insert
- (concat
- (gdb-get-field instr 'address)
- " "
- (gdb-pad-string (apply 'format `("<%s+%s>:" ,@(gdb-get-many-fields instr 'func-name 'offset)))
- (- column-padding))
- (gdb-get-field instr 'inst)
- "\n")))
+ '((overlay-arrow . hollow-right-triangle)))))))
+ (insert (gdb-table-string table " "))
(gdb-disassembly-place-breakpoints)
- (let ((window (get-buffer-window (current-buffer) 0)))
- (set-window-point window pos)))))
+ ;; Mark current position with overlay arrow and scroll window to
+ ;; that point
+ (when marked-line
+ (let ((window (get-buffer-window (current-buffer) 0)))
+ (set-window-point window (gdb-mark-line marked-line gdb-disassembly-position))))
+ (setq mode-name
+ (gdb-current-context-mode-name
+ (concat "Disassembly: "
+ (bindat-get-field (gdb-current-buffer-frame) 'func))))))
(defun gdb-disassembly-place-breakpoints ()
(gdb-remove-breakpoint-icons (point-min) (point-max))
(dolist (breakpoint gdb-breakpoints-list)
- (let ((bptno (gdb-get-field breakpoint 'number))
- (flag (gdb-get-field breakpoint 'enabled))
- (address (gdb-get-field breakpoint 'addr)))
+ (let* ((breakpoint (cdr breakpoint))
+ (bptno (bindat-get-field breakpoint 'number))
+ (flag (bindat-get-field breakpoint 'enabled))
+ (address (bindat-get-field breakpoint 'addr)))
(save-excursion
(goto-char (point-min))
(if (re-search-forward (concat "^" address) nil t)
(gdb-put-breakpoint-icon (string-equal flag "y") bptno))))))
\f
-;;; Breakpoints view
-(defun gdb-breakpoints-mode ()
- "Major mode for gdb breakpoints.
+(defvar gdb-breakpoints-header
+ (list
+ (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
+ nil nil mode-line)
+ " "
+ (gdb-propertize-header "Threads" gdb-threads-buffer
+ "mouse-1: select" mode-line-highlight mode-line-inactive)))
-\\{gdb-breakpoints-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-breakpoints-mode)
- (setq mode-name "Breakpoints")
- (use-local-map gdb-breakpoints-mode-map)
- (setq buffer-read-only t)
- (buffer-disable-undo)
+;;; Breakpoints view
+(define-derived-mode gdb-breakpoints-mode gdb-parent-mode "Breakpoints"
+ "Major mode for gdb breakpoints."
(setq header-line-format gdb-breakpoints-header)
- (run-mode-hooks 'gdb-breakpoints-mode-hook)
'gdb-invalidate-breakpoints)
(defun gdb-toggle-breakpoint ()
(let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
(if breakpoint
(gud-basic-call
- (concat (if (string-equal "y" (gdb-get-field breakpoint 'enabled))
+ (concat (if (string-equal "y" (bindat-get-field breakpoint 'enabled))
"-break-disable "
"-break-enable ")
- (gdb-get-field breakpoint 'number)))
+ (bindat-get-field breakpoint 'number)))
(error "Not recognized as break/watchpoint line")))))
(defun gdb-delete-breakpoint ()
(beginning-of-line)
(let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
(if breakpoint
- (gud-basic-call (concat "-break-delete " (gdb-get-field breakpoint 'number)))
+ (gud-basic-call (concat "-break-delete " (bindat-get-field breakpoint 'number)))
(error "Not recognized as break/watchpoint line")))))
-
+
(defun gdb-goto-breakpoint (&optional event)
"Go to the location of breakpoint at current line of
breakpoints buffer."
(beginning-of-line)
(let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
(if breakpoint
- (let ((bptno (gdb-get-field breakpoint 'number))
- (file (gdb-get-field breakpoint 'fullname))
- (line (gdb-get-field breakpoint 'line)))
+ (let ((bptno (bindat-get-field breakpoint 'number))
+ (file (bindat-get-field breakpoint 'fullname))
+ (line (bindat-get-field breakpoint 'line)))
(save-selected-window
(let* ((buffer (find-file-noselect
(if (file-exists-p file) file
(display-buffer buffer))))
(setq gdb-source-window window)
(with-current-buffer buffer
- (goto-line (string-to-number line))
+ (goto-char (point-min))
+ (forward-line (1- (string-to-number line)))
(set-window-point window (point))))))
(error "Not recognized as break/watchpoint line")))))
\f
;; Frames buffer. This displays a perpetually correct bactrack trace.
;;
-(gdb-set-buffer-rules 'gdb-stack-buffer
- 'gdb-stack-buffer-name
- 'gdb-frames-mode)
+(def-gdb-trigger-and-handler
+ gdb-invalidate-frames (gdb-current-context-command "-stack-list-frames")
+ gdb-stack-list-frames-handler gdb-stack-list-frames-custom
+ '(start update))
-(def-gdb-auto-updated-buffer gdb-stack-buffer
- gdb-invalidate-frames
- (gdb-current-context-command "-stack-list-frames")
- gdb-stack-list-frames-handler
- gdb-stack-list-frames-custom)
+(gdb-set-buffer-rules
+ 'gdb-stack-buffer
+ 'gdb-stack-buffer-name
+ 'gdb-frames-mode
+ 'gdb-invalidate-frames)
-(defun gdb-insert-frame-location (frame)
- "Insert \"of file:line\" button or library name for structure FRAME.
+(defun gdb-frame-location (frame)
+ "Return \" of file:line\" or \" of library\" for structure FRAME.
FRAME must have either \"file\" and \"line\" members or \"from\"
member."
- (let ((file (gdb-get-field frame 'fullname))
- (line (gdb-get-field frame 'line))
- (from (gdb-get-field frame 'from)))
- (cond (file
- ;; Filename with line number
- (insert " of ")
- (gdb-insert-file-location-button
- file (string-to-number line)))
- ;; Library
- (from (insert (format " of %s" from))))))
+ (let ((file (bindat-get-field frame 'file))
+ (line (bindat-get-field frame 'line))
+ (from (bindat-get-field frame 'from)))
+ (let ((res (or (and file line (concat file ":" line))
+ from)))
+ (if res (concat " of " res) ""))))
(defun gdb-stack-list-frames-custom ()
- (let* ((res (json-partial-output "frame"))
- (stack (gdb-get-field res 'stack)))
- (dolist (frame (nreverse stack))
- (insert (apply 'format `("%s in %s" ,@(gdb-get-many-fields frame 'level 'func))))
- (gdb-insert-frame-location frame)
- (newline))
- (save-excursion
- (goto-char (point-min))
- (forward-line 1)
- (while (< (point) (point-max))
- (add-text-properties (point-at-bol) (1+ (point-at-bol))
- '(mouse-face highlight
- help-echo "mouse-2, RET: Select frame"))
- (beginning-of-line)
- (when (and (looking-at "^[0-9]+\\s-+\\S-+\\s-+\\(\\S-+\\)")
- (equal (match-string 1) gdb-selected-frame))
- (if (> (car (window-fringes)) 0)
- (progn
- (or gdb-stack-position
- (setq gdb-stack-position (make-marker)))
- (set-marker gdb-stack-position (point)))
- (let ((bl (point-at-bol)))
- (put-text-property bl (+ bl 4)
- 'face '(:inverse-video t)))))
- (forward-line 1)))))
+ (let ((stack (bindat-get-field (gdb-json-partial-output "frame") 'stack))
+ (table (make-gdb-table)))
+ (set-marker gdb-stack-position nil)
+ (dolist (frame stack)
+ (gdb-table-add-row table
+ (list
+ (bindat-get-field frame 'level)
+ "in"
+ (concat
+ (bindat-get-field frame 'func)
+ (if gdb-stack-buffer-locations
+ (gdb-frame-location frame) "")
+ (if gdb-stack-buffer-addresses
+ (concat " at " (bindat-get-field frame 'addr)) "")))
+ `(mouse-face highlight
+ help-echo "mouse-2, RET: Select frame"
+ gdb-frame ,frame)))
+ (insert (gdb-table-string table " ")))
+ (when (and gdb-frame-number
+ (gdb-buffer-shows-main-thread-p))
+ (gdb-mark-line (1+ (string-to-number gdb-frame-number))
+ gdb-stack-position))
+ (setq mode-name
+ (gdb-current-context-mode-name "Frames")))
(defun gdb-stack-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*stack frames of " (gdb-get-target-string) "*")))
+ (gdb-current-context-buffer-name
+ (concat "stack frames of " (gdb-get-target-string))))
(def-gdb-display-buffer
gdb-display-stack-buffer
'gdb-stack-buffer
"Display backtrace of current stack.")
+(def-gdb-preempt-display-buffer
+ gdb-preemptively-display-stack-buffer
+ 'gdb-stack-buffer nil t)
+
(def-gdb-frame-for-buffer
gdb-frame-stack-buffer
'gdb-stack-buffer
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "q" 'kill-this-buffer)
- (define-key map "\r" 'gdb-frames-select)
- (define-key map [mouse-2] 'gdb-frames-select)
+ (define-key map "\r" 'gdb-select-frame)
+ (define-key map [mouse-2] 'gdb-select-frame)
(define-key map [follow-link] 'mouse-face)
map))
(defvar gdb-frames-font-lock-keywords
- '(("in \\([^ ]+\\) of " (1 font-lock-function-name-face)))
+ '(("in \\([^ ]+\\)" (1 font-lock-function-name-face)))
"Font lock keywords used in `gdb-frames-mode'.")
-(defun gdb-frames-mode ()
- "Major mode for gdb call stack.
-
-\\{gdb-frames-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-frames-mode)
- (setq mode-name "Frames")
- (setq gdb-stack-position nil)
+(define-derived-mode gdb-frames-mode gdb-parent-mode "Frames"
+ "Major mode for gdb call stack."
+ (setq gdb-stack-position (make-marker))
(add-to-list 'overlay-arrow-variable-list 'gdb-stack-position)
(setq truncate-lines t) ;; Make it easier to see overlay arrow.
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (use-local-map gdb-frames-mode-map)
(set (make-local-variable 'font-lock-defaults)
'(gdb-frames-font-lock-keywords))
- (run-mode-hooks 'gdb-frames-mode-hook)
'gdb-invalidate-frames)
-(defun gdb-get-frame-number ()
- (save-excursion
- (end-of-line)
- (let* ((pos (re-search-backward "^\\([0-9]+\\)" nil t))
- (n (or (and pos (match-string-no-properties 1)) "0")))
- n)))
-
-(defun gdb-frames-select (&optional event)
+(defun gdb-select-frame (&optional event)
"Select the frame and display the relevant source."
(interactive (list last-input-event))
(if event (posn-set-point (event-end event)))
- (gud-basic-call (concat "-stack-select-frame " (gdb-get-frame-number))))
+ (let ((frame (get-text-property (point) 'gdb-frame)))
+ (if frame
+ (if (gdb-buffer-shows-main-thread-p)
+ (let ((new-level (bindat-get-field frame 'level)))
+ (setq gdb-frame-number new-level)
+ (gdb-input (list (concat "-stack-select-frame " new-level) 'ignore))
+ (gdb-update))
+ (error "Could not select frame for non-current thread"))
+ (error "Not recognized as frame line"))))
\f
;; Locals buffer.
;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards.
-(gdb-set-buffer-rules 'gdb-locals-buffer
- 'gdb-locals-buffer-name
- 'gdb-locals-mode)
-
-(def-gdb-auto-update-trigger gdb-invalidate-locals
- (gdb-get-buffer 'gdb-locals-buffer)
+(def-gdb-trigger-and-handler
+ gdb-invalidate-locals
(concat (gdb-current-context-command "-stack-list-locals") " --simple-values")
- gdb-stack-list-locals-handler)
+ gdb-locals-handler gdb-locals-handler-custom
+ '(start update))
-(defconst gdb-stack-list-locals-regexp
- (concat "name=\"\\(.*?\\)\",type=\"\\(.*?\\)\""))
+(gdb-set-buffer-rules
+ 'gdb-locals-buffer
+ 'gdb-locals-buffer-name
+ 'gdb-locals-mode
+ 'gdb-invalidate-locals)
(defvar gdb-locals-watch-map
(let ((map (make-sparse-keymap)))
(save-excursion
(if event (posn-set-point (event-end event)))
(beginning-of-line)
- (let* ((var (current-word))
+ (let* ((var (bindat-get-field
+ (get-text-property (point) 'gdb-local-variable) 'name))
(value (read-string (format "New value (%s): " var))))
(gud-basic-call
(concat "-gdb-set variable " var " = " value)))))
;; Dont display values of arrays or structures.
;; These can be expanded using gud-watch.
-(defun gdb-stack-list-locals-handler nil
- (setq gdb-pending-triggers (delq 'gdb-invalidate-locals
- gdb-pending-triggers))
- (let (local locals-list)
- (goto-char (point-min))
- (while (re-search-forward gdb-stack-list-locals-regexp nil t)
- (let ((local (list (match-string 1)
- (match-string 2)
- nil)))
- (if (looking-at ",value=\\(\".*\"\\)}")
- (setcar (nthcdr 2 local) (read (match-string 1))))
- (push local locals-list)))
- (let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
- (and buf (with-current-buffer buf
- (let* ((window (get-buffer-window buf 0))
- (start (window-start window))
- (p (window-point window))
- (buffer-read-only nil) (name) (value))
- (erase-buffer)
- (dolist (local locals-list)
- (setq name (car local))
- (setq value (nth 2 local))
- (if (or (not value)
- (string-match "\\0x" value))
- (add-text-properties 0 (length name)
+(defun gdb-locals-handler-custom ()
+ (let ((locals-list (bindat-get-field (gdb-json-partial-output) 'locals))
+ (table (make-gdb-table)))
+ (dolist (local locals-list)
+ (let ((name (bindat-get-field local 'name))
+ (value (bindat-get-field local 'value))
+ (type (bindat-get-field local 'type)))
+ (if (or (not value)
+ (string-match "\\0x" value))
+ (add-text-properties 0 (length name)
`(mouse-face highlight
help-echo "mouse-2: create watch expression"
local-map ,gdb-locals-watch-map)
name)
- (add-text-properties 0 (length value)
- `(mouse-face highlight
+ (add-text-properties 0 (length value)
+ `(mouse-face highlight
help-echo "mouse-2: edit value"
local-map ,gdb-edit-locals-map-1)
- value))
- (insert
- (concat name "\t" (nth 1 local)
- "\t" (nth 2 local) "\n")))
- (set-window-start window start)
- (set-window-point window p)))))))
+ value))
+ (gdb-table-add-row
+ table
+ (list
+ (propertize type 'font-lock-face font-lock-type-face)
+ (propertize name 'font-lock-face font-lock-variable-name-face)
+ value)
+ `(gdb-local-variable ,local))))
+ (insert (gdb-table-string table " "))
+ (setq mode-name
+ (gdb-current-context-mode-name
+ (concat "Locals: " (bindat-get-field (gdb-current-buffer-frame) 'func))))))
(defvar gdb-locals-header
(list
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "q" 'kill-this-buffer)
+ (define-key map "\t" '(lambda ()
+ (interactive)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create
+ 'gdb-registers-buffer
+ gdb-thread-number) t)))
map))
-(defun gdb-locals-mode ()
- "Major mode for gdb locals.
-
-\\{gdb-locals-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-locals-mode)
- (setq mode-name (concat "Locals:" gdb-selected-frame))
- (setq buffer-read-only t)
- (buffer-disable-undo)
+(define-derived-mode gdb-locals-mode gdb-parent-mode "Locals"
+ "Major mode for gdb locals."
(setq header-line-format gdb-locals-header)
- (use-local-map gdb-locals-mode-map)
- (set (make-local-variable 'font-lock-defaults)
- '(gdb-locals-font-lock-keywords))
- (run-mode-hooks 'gdb-locals-mode-hook)
'gdb-invalidate-locals)
(defun gdb-locals-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*locals of " (gdb-get-target-string) "*")))
+ (gdb-current-context-buffer-name
+ (concat "locals of " (gdb-get-target-string))))
(def-gdb-display-buffer
gdb-display-locals-buffer
'gdb-locals-buffer
"Display local variables of current stack and their values.")
+(def-gdb-preempt-display-buffer
+ gdb-preemptively-display-locals-buffer
+ 'gdb-locals-buffer nil t)
+
(def-gdb-frame-for-buffer
gdb-frame-locals-buffer
'gdb-locals-buffer
\f
;; Registers buffer.
-;;
-(gdb-set-buffer-rules 'gdb-registers-buffer
- 'gdb-registers-buffer-name
- 'gdb-registers-mode)
-(def-gdb-auto-update-trigger gdb-invalidate-registers
- (gdb-get-buffer 'gdb-registers-buffer)
+(def-gdb-trigger-and-handler
+ gdb-invalidate-registers
(concat (gdb-current-context-command "-data-list-register-values") " x")
- gdb-data-list-register-values-handler)
-
-(defconst gdb-data-list-register-values-regexp
- "number=\"\\(.*?\\)\",value=\"\\(.*?\\)\"")
+ gdb-registers-handler
+ gdb-registers-handler-custom
+ '(start update))
-(defun gdb-data-list-register-values-handler ()
- (setq gdb-pending-triggers (delq 'gdb-invalidate-registers
- gdb-pending-triggers))
- (goto-char (point-min))
- (if (re-search-forward gdb-error-regexp nil t)
- (progn
- (let ((match nil))
- (setq match (match-string 1))
- (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
- (let ((buffer-read-only nil))
- (erase-buffer)
- (insert match)
- (goto-char (point-min))))))
- (let ((register-list (reverse gdb-register-names))
- (register nil) (register-string nil) (register-values nil))
- (goto-char (point-min))
- (while (re-search-forward gdb-data-list-register-values-regexp nil t)
- (setq register (pop register-list))
- (setq register-string (concat register "\t" (match-string 2) "\n"))
- (if (member (match-string 1) gdb-changed-registers)
- (put-text-property 0 (length register-string)
- 'face 'font-lock-warning-face
- register-string))
- (setq register-values
- (concat register-values register-string)))
- (let ((buf (gdb-get-buffer 'gdb-registers-buffer)))
- (with-current-buffer buf
- (let ((p (window-point (get-buffer-window buf 0)))
- (buffer-read-only nil))
- (erase-buffer)
- (insert register-values)
- (set-window-point (get-buffer-window buf 0) p))))))
- (gdb-data-list-register-values-custom))
-
-(defun gdb-data-list-register-values-custom ()
- (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
- (save-excursion
- (let ((buffer-read-only nil)
- bl)
- (goto-char (point-min))
- (while (< (point) (point-max))
- (setq bl (line-beginning-position))
- (when (looking-at "^[^\t]+")
- (put-text-property bl (match-end 0)
- 'face font-lock-variable-name-face))
- (forward-line 1))))))
+(gdb-set-buffer-rules
+ 'gdb-registers-buffer
+ 'gdb-registers-buffer-name
+ 'gdb-registers-mode
+ 'gdb-invalidate-registers)
+
+(defun gdb-registers-handler-custom ()
+ (when gdb-register-names
+ (let ((register-values (bindat-get-field (gdb-json-partial-output) 'register-values))
+ (table (make-gdb-table)))
+ (dolist (register register-values)
+ (let* ((register-number (bindat-get-field register 'number))
+ (value (bindat-get-field register 'value))
+ (register-name (nth (string-to-number register-number)
+ gdb-register-names)))
+ (gdb-table-add-row
+ table
+ (list
+ (propertize register-name 'font-lock-face font-lock-variable-name-face)
+ (if (member register-number gdb-changed-registers)
+ (propertize value 'font-lock-face font-lock-warning-face)
+ value))
+ `(mouse-face highlight
+ help-echo "mouse-2: edit value"
+ gdb-register-name ,register-name))))
+ (insert (gdb-table-string table " ")))
+ (setq mode-name
+ (gdb-current-context-mode-name "Registers"))))
+
+(defun gdb-edit-register-value (&optional event)
+ "Assign a value to a register displayed in the registers buffer."
+ (interactive (list last-input-event))
+ (save-excursion
+ (if event (posn-set-point (event-end event)))
+ (beginning-of-line)
+ (let* ((var (bindat-get-field
+ (get-text-property (point) 'gdb-register-name)))
+ (value (read-string (format "New value (%s): " var))))
+ (gud-basic-call
+ (concat "-gdb-set variable $" var " = " value)))))
(defvar gdb-registers-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
+ (define-key map "\r" 'gdb-edit-register-value)
+ (define-key map [mouse-2] 'gdb-edit-register-value)
(define-key map "q" 'kill-this-buffer)
- map))
+ (define-key map "\t" '(lambda ()
+ (interactive)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create
+ 'gdb-locals-buffer
+ gdb-thread-number) t)))
+ map))
-(defun gdb-registers-mode ()
- "Major mode for gdb registers.
+(defvar gdb-registers-header
+ (list
+ (gdb-propertize-header "Locals" gdb-locals-buffer
+ "mouse-1: select" mode-line-highlight mode-line-inactive)
+ " "
+ (gdb-propertize-header "Registers" gdb-registers-buffer
+ nil nil mode-line)))
-\\{gdb-registers-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-registers-mode)
- (setq mode-name "Registers")
- (setq header-line-format gdb-locals-header)
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (use-local-map gdb-registers-mode-map)
- (run-mode-hooks 'gdb-registers-mode-hook)
+(define-derived-mode gdb-registers-mode gdb-parent-mode "Registers"
+ "Major mode for gdb registers."
+ (setq header-line-format gdb-registers-header)
'gdb-invalidate-registers)
(defun gdb-registers-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*registers of " (gdb-get-target-string) "*")))
+ (gdb-current-context-buffer-name
+ (concat "registers of " (gdb-get-target-string))))
(def-gdb-display-buffer
gdb-display-registers-buffer
'gdb-registers-buffer
"Display integer register contents.")
+(def-gdb-preempt-display-buffer
+ gdb-preemptively-display-registers-buffer
+ 'gdb-registers-buffer nil t)
+
(def-gdb-frame-for-buffer
gdb-frame-registers-buffer
'gdb-registers-buffer
;; Needs GDB 6.4 onwards (used to fail with no stack).
(defun gdb-get-changed-registers ()
(if (and (gdb-get-buffer 'gdb-registers-buffer)
- (not (member 'gdb-get-changed-registers gdb-pending-triggers)))
+ (not (gdb-pending-p 'gdb-get-changed-registers)))
(progn
(gdb-input
(list
"-data-list-changed-registers"
- 'gdb-get-changed-registers-handler))
- (push 'gdb-get-changed-registers gdb-pending-triggers))))
-
-(defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"")
+ 'gdb-changed-registers-handler))
+ (gdb-add-pending 'gdb-get-changed-registers))))
-(defun gdb-get-changed-registers-handler ()
- (setq gdb-pending-triggers
- (delq 'gdb-get-changed-registers gdb-pending-triggers))
+(defun gdb-changed-registers-handler ()
+ (gdb-delete-pending 'gdb-get-changed-registers)
(setq gdb-changed-registers nil)
- (goto-char (point-min))
- (while (re-search-forward gdb-data-list-register-names-regexp nil t)
- (push (match-string 1) gdb-changed-registers)))
+ (dolist (register-number (bindat-get-field (gdb-json-partial-output) 'changed-registers))
+ (push register-number gdb-changed-registers)))
-(defun gdb-get-register-names ()
- "Create a list of register names."
- (goto-char (point-min))
+(defun gdb-register-names-handler ()
+ ;; Don't use gdb-pending-triggers because this handler is called
+ ;; only once (in gdb-init-1)
(setq gdb-register-names nil)
- (while (re-search-forward gdb-data-list-register-names-regexp nil t)
- (push (match-string 1) gdb-register-names)))
+ (dolist (register-name (bindat-get-field (gdb-json-partial-output) 'register-names))
+ (push register-name gdb-register-names))
+ (setq gdb-register-names (reverse gdb-register-names)))
\f
(defun gdb-get-source-file-list ()
(gdb-force-mode-line-update
(propertize "ready" 'face font-lock-variable-name-face)))
-(defun gdb-get-selected-frame ()
- (if (not (member 'gdb-get-selected-frame gdb-pending-triggers))
+(defun gdb-get-main-selected-frame ()
+ "Trigger for `gdb-frame-handler' which uses main current
+thread. Called from `gdb-update'."
+ (if (not (gdb-pending-p 'gdb-get-main-selected-frame))
(progn
(gdb-input
(list (gdb-current-context-command "-stack-info-frame") 'gdb-frame-handler))
- (push 'gdb-get-selected-frame
- gdb-pending-triggers))))
+ (gdb-add-pending 'gdb-get-main-selected-frame))))
(defun gdb-frame-handler ()
- (setq gdb-pending-triggers
- (delq 'gdb-get-selected-frame gdb-pending-triggers))
- (let ((frame (gdb-get-field (json-partial-output) 'frame)))
+ "Sets `gdb-selected-frame' and `gdb-selected-file' to show
+overlay arrow in source buffer."
+ (gdb-delete-pending 'gdb-get-main-selected-frame)
+ (let ((frame (bindat-get-field (gdb-json-partial-output) 'frame)))
(when frame
- (setq gdb-frame-number (gdb-get-field frame 'level))
- (setq gdb-pc-address (gdb-get-field frame 'addr))
- (setq gdb-selected-frame (gdb-get-field frame 'func))
- (setq gdb-selected-file (gdb-get-field frame 'fullname))
- (let ((line (gdb-get-field frame 'line)))
- (setq gdb-selected-line (or (and line (string-to-number line))
- nil)) ; don't fail if line is nil
- (when line ; obey the current file only if we have line info
+ (setq gdb-selected-frame (bindat-get-field frame 'func))
+ (setq gdb-selected-file (bindat-get-field frame 'fullname))
+ (setq gdb-frame-number (bindat-get-field frame 'level))
+ (setq gdb-frame-address (bindat-get-field frame 'addr))
+ (let ((line (bindat-get-field frame 'line)))
+ (setq gdb-selected-line (and line (string-to-number line)))
+ (when (and gdb-selected-file gdb-selected-line)
(setq gud-last-frame (cons gdb-selected-file gdb-selected-line))
(gud-display-frame)))
- (if (gdb-get-buffer 'gdb-locals-buffer)
- (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer)
- (setq mode-name (concat "Locals:" gdb-selected-frame))))
- (if (gdb-get-buffer 'gdb-disassembly-buffer)
- (with-current-buffer (gdb-get-buffer 'gdb-disassembly-buffer)
- (setq mode-name (concat "Disassembly:" gdb-selected-frame))))
(if gud-overlay-arrow-position
(let ((buffer (marker-buffer gud-overlay-arrow-position))
(position (marker-position gud-overlay-arrow-position)))
nil
'((overlay-arrow . hollow-right-triangle))))
(setq gud-overlay-arrow-position (make-marker))
- (set-marker gud-overlay-arrow-position position)))))
- (when gdb-selected-line
- (gdb-invalidate-disassembly)))))
-
+ (set-marker gud-overlay-arrow-position position))))))))
+
(defvar gdb-prompt-name-regexp "value=\"\\(.*?\\)\"")
(defun gdb-get-prompt ()
;;;; Window management
(defun gdb-display-buffer (buf dedicated &optional frame)
+ "Show buffer BUF.
+
+If BUF is already displayed in some window, show it, deiconifying
+the frame if necessary. Otherwise, find least recently used
+window and show BUF there, if the window is not used for GDB
+already, in which case that window is splitted first."
(let ((answer (get-buffer-window buf (or frame 0))))
(if answer
(display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary.
(set-window-buffer window buf)
window)))))
+(defun gdb-preempt-existing-or-display-buffer (buf &optional split-horizontal)
+ "Find window displaying a buffer with the same
+`gdb-buffer-type' as BUF and show BUF there. If no such window
+exists, just call `gdb-display-buffer' for BUF. If the window
+found is already dedicated, split window according to
+SPLIT-HORIZONTAL and show BUF in the new window."
+ (if buf
+ (when (not (get-buffer-window buf))
+ (let* ((buf-type (gdb-buffer-type buf))
+ (existing-window
+ (get-window-with-predicate
+ #'(lambda (w)
+ (and (eq buf-type
+ (gdb-buffer-type (window-buffer w)))
+ (not (window-dedicated-p w)))))))
+ (if existing-window
+ (set-window-buffer existing-window buf)
+ (let ((dedicated-window
+ (get-window-with-predicate
+ #'(lambda (w)
+ (eq buf-type
+ (gdb-buffer-type (window-buffer w)))))))
+ (if dedicated-window
+ (set-window-buffer
+ (split-window dedicated-window nil split-horizontal) buf)
+ (gdb-display-buffer buf t))))))
+ (error "Null buffer")))
\f
;;; Shared keymap initialization:
'("Disassembly" . gdb-display-disassembly-buffer))
(define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
(define-key menu [inferior]
- '("Separate IO" . gdb-display-separate-io-buffer))
+ '("IO" . gdb-display-io-buffer))
(define-key menu [locals] '("Locals" . gdb-display-locals-buffer))
(define-key menu [frames] '("Stack" . gdb-display-stack-buffer))
(define-key menu [breakpoints]
(define-key menu [disassembly] '("Disassembly" . gdb-frame-disassembly-buffer))
(define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
(define-key menu [inferior]
- '("Separate IO" . gdb-frame-separate-io-buffer))
+ '("IO" . gdb-frame-io-buffer))
(define-key menu [locals] '("Locals" . gdb-frame-locals-buffer))
(define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))
(define-key menu [breakpoints]
'("Breakpoints" . gdb-frame-breakpoints-buffer)))
(let ((menu (make-sparse-keymap "GDB-MI")))
- (define-key gud-menu-map [mi]
- `(menu-item "GDB-MI" ,menu :visible (eq gud-minor-mode 'gdbmi)))
(define-key menu [gdb-customize]
'(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb))
:help "Customize Gdb Graphical Mode options."))
:button (:toggle . gdb-many-windows)))
(define-key menu [gdb-restore-windows]
'(menu-item "Restore Window Layout" gdb-restore-windows
- :help "Restore standard layout for debug session.")))
+ :help "Restore standard layout for debug session."))
+ (define-key menu [sep1]
+ '(menu-item "--"))
+ (define-key menu [all-threads]
+ '(menu-item "GUD controls all threads"
+ (lambda ()
+ (interactive)
+ (setq gdb-gud-control-all-threads t))
+ :help "GUD start/stop commands apply to all threads"
+ :button (:radio . gdb-gud-control-all-threads)))
+ (define-key menu [current-thread]
+ '(menu-item "GUD controls current thread"
+ (lambda ()
+ (interactive)
+ (setq gdb-gud-control-all-threads nil))
+ :help "GUD start/stop commands apply to current thread only"
+ :button (:radio . (not gdb-gud-control-all-threads))))
+ (define-key menu [sep2]
+ '(menu-item "--"))
+ (define-key menu [gdb-customize-reasons]
+ '(menu-item "Customize switching..."
+ (lambda ()
+ (interactive)
+ (customize-option 'gdb-switch-reasons))))
+ (define-key menu [gdb-switch-when-another-stopped]
+ (menu-bar-make-toggle gdb-toggle-switch-when-another-stopped gdb-switch-when-another-stopped
+ "Automatically switch to stopped thread"
+ "GDB thread switching %s"
+ "Switch to stopped thread"))
+ (define-key gud-menu-map [mi]
+ `(menu-item "GDB-MI" ,menu :visible (eq gud-minor-mode 'gdbmi))))
+
+;; TODO Fit these into tool-bar-local-item-from-menu call in gud.el.
+;; GDB-MI menu will need to be moved to gud.el. We can't use
+;; tool-bar-local-item-from-menu here because it appends new buttons
+;; to toolbar from right to left while we want our A/T throttle to
+;; show up right before Run button.
+(define-key-after gud-tool-bar-map [all-threads]
+ '(menu-item "Switch to non-stop/A mode" gdb-control-all-threads
+ :image (find-image '((:type xpm :file "gud/thread.xpm")))
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ gdb-non-stop
+ (not gdb-gud-control-all-threads)))
+ 'run)
+
+(define-key-after gud-tool-bar-map [current-thread]
+ '(menu-item "Switch to non-stop/T mode" gdb-control-current-thread
+ :image (find-image '((:type xpm :file "gud/all.xpm")))
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ gdb-non-stop
+ gdb-gud-control-all-threads))
+ 'all-threads)
(defun gdb-frame-gdb-buffer ()
"Display GUD buffer in a new frame."
(let ((same-window-regexps nil))
(select-window (display-buffer gud-comint-buffer nil 0))))
-(defun gdb-set-window-buffer (name)
+(defun gdb-set-window-buffer (name &optional ignore-dedicated)
+ "Set buffer of selected window to NAME and dedicate window.
+
+When IGNORE-DEDICATED is non-nil, buffer is set even if selected
+window is dedicated."
+ (when ignore-dedicated
+ (set-window-dedicated-p (selected-window) nil))
(set-window-buffer (selected-window) (get-buffer name))
(set-window-dedicated-p (selected-window) t))
;; can't find a source file.
(list-buffers-noselect))))
(setq gdb-source-window (selected-window))
- (when gdb-use-separate-io-buffer
- (split-window-horizontally)
- (other-window 1)
- (gdb-set-window-buffer
- (gdb-get-buffer-create 'gdb-inferior-io)))
+ (split-window-horizontally)
+ (other-window 1)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create 'gdb-inferior-io))
(other-window 1)
(gdb-set-window-buffer (gdb-stack-buffer-name))
(split-window-horizontally)
(other-window 1)
- (gdb-set-window-buffer (gdb-breakpoints-buffer-name))
+ (gdb-set-window-buffer (if gdb-show-threads-by-default
+ (gdb-threads-buffer-name)
+ (gdb-breakpoints-buffer-name)))
(other-window 1))
(defcustom gdb-many-windows nil
(setq gud-minor-mode nil)
(kill-local-variable 'tool-bar-map)
(kill-local-variable 'gdb-define-alist))))))
- (setq gdb-overlay-arrow-position nil)
+ (setq gdb-disassembly-position nil)
(setq overlay-arrow-variable-list
- (delq 'gdb-overlay-arrow-position overlay-arrow-variable-list))
+ (delq 'gdb-disassembly-position overlay-arrow-variable-list))
(setq fringe-indicator-alist '((overlay-arrow . right-triangle)))
(setq gdb-stack-position nil)
(setq overlay-arrow-variable-list
(delq 'gdb-stack-position overlay-arrow-variable-list))
+ (setq gdb-thread-position nil)
+ (setq overlay-arrow-variable-list
+ (delq 'gdb-thread-position overlay-arrow-variable-list))
(if (boundp 'speedbar-frame) (speedbar-timer-fn))
(setq gud-running nil)
(setq gdb-active-process nil)
(when (overlay-get overlay 'put-break)
(delete-overlay overlay))))
-(defun gdb-put-breakpoint-icon (enabled bptno)
- (let ((start (- (line-beginning-position) 1))
- (end (+ (line-end-position) 1))
- (putstring (if enabled "B" "b"))
- (source-window (get-buffer-window (current-buffer) 0)))
+(defun gdb-put-breakpoint-icon (enabled bptno &optional line)
+ (let* ((posns (gdb-line-posns (or line (line-number-at-pos))))
+ (start (- (car posns) 1))
+ (end (+ (cdr posns) 1))
+ (putstring (if enabled "B" "b"))
+ (source-window (get-buffer-window (current-buffer) 0)))
(add-text-properties
0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt")
putstring)
(provide 'gdb-mi)
-;; arch-tag: 1b41ea2b-f364-4cec-8f35-e02e4fe01912
;;; gdb-mi.el ends here