(eval-when-compile (require 'cl))
(require 'comint)
(defvar gdb-active-process)
(defvar gdb-define-alist)
(defvar gdb-macro-info)
(defvar gdb-server-prefix)
(defvar gdb-show-changed-values)
(defvar gdb-var-list)
(defvar gdb-speedbar-auto-raise)
(defvar tool-bar-map)
(defgroup gud nil
"Grand Unified Debugger mode for gdb and other debuggers under Emacs.
Supported debuggers include gdb, sdb, dbx, xdb, perldb, pdb (Python) and jdb."
:group 'unix
:group 'tools)
(defcustom gud-key-prefix "\C-x\C-a"
"Prefix of all GUD commands valid in C buffers."
:type 'string
:group 'gud)
(global-set-key (concat gud-key-prefix "\C-l") 'gud-refresh)
(define-key ctl-x-map " " 'gud-break)
(defvar gud-marker-filter nil)
(put 'gud-marker-filter 'permanent-local t)
(defvar gud-find-file nil)
(put 'gud-find-file 'permanent-local t)
(defun gud-marker-filter (&rest args)
(apply gud-marker-filter args))
(defvar gud-minor-mode nil)
(put 'gud-minor-mode 'permanent-local t)
(defvar gud-comint-buffer nil)
(defvar gud-keep-buffer nil)
(defun gud-symbol (sym &optional soft minor-mode)
"Return the symbol used for SYM in MINOR-MODE.
MINOR-MODE defaults to `gud-minor-mode'.
The symbol returned is `gud-<MINOR-MODE>-<SYM>'.
If SOFT is non-nil, returns nil if the symbol doesn't already exist."
(unless (or minor-mode gud-minor-mode) (error "Gud internal error"))
(funcall (if soft 'intern-soft 'intern)
(format "gud-%s-%s" (or minor-mode gud-minor-mode) sym)))
(defun gud-val (sym &optional minor-mode)
"Return the value of `gud-symbol' SYM. Default to nil."
(let ((sym (gud-symbol sym t minor-mode)))
(if (boundp sym) (symbol-value sym))))
(defvar gud-running nil
"Non-nil if debugged program is running.
Used to grey out relevant toolbar icons.")
(defvar gdb-ready nil)
(defun gud-goto-info ()
"Go to relevant Emacs info node."
(interactive)
(let ((same-window-regexps same-window-regexps)
(display-buffer-reuse-frames t))
(catch 'info-found
(walk-windows
'(lambda (window)
(if (eq (window-buffer window) (get-buffer "*info*"))
(progn
(setq same-window-regexps nil)
(throw 'info-found nil))))
nil 0)
(select-frame (make-frame)))
(if (memq gud-minor-mode '(gdbmi gdba))
(info "(emacs)GDB Graphical Interface")
(info "(emacs)Debuggers"))))
(defun gud-tool-bar-item-visible-no-fringe ()
(not (or (eq (buffer-local-value 'major-mode (window-buffer)) 'speedbar-mode)
(and (memq gud-minor-mode '(gdbmi gdba))
(> (car (window-fringes)) 0)))))
(defun gud-stop-subjob ()
(interactive)
(with-current-buffer gud-comint-buffer
(if (string-equal gud-target-name "emacs")
(comint-stop-subjob)
(comint-interrupt-subjob))))
(easy-mmode-defmap gud-menu-map
'(([help] "Info" . gud-goto-info)
([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode
:enable (and (not emacs-basic-display)
(display-graphic-p)
(fboundp 'x-show-tip))
:visible (memq gud-minor-mode
'(lldb gdbmi gdba dbx sdb xdb pdb))
:button (:toggle . gud-tooltip-mode))
([refresh] "Refresh" . gud-refresh)
([run] menu-item "Run" gud-run
:enable (not gud-running)
:visible (memq gud-minor-mode '(lldb gdbmi gdb dbx jdb)))
([go] menu-item (if gdb-active-process "Continue" "Run") gud-go
:visible (and (not gud-running)
(eq gud-minor-mode 'gdba)))
([stop] menu-item "Stop" gud-stop-subjob
:visible (or (not (memq gud-minor-mode '(gdba pdb)))
(and gud-running
(eq gud-minor-mode 'gdba))))
([until] menu-item "Continue to selection" gud-until
:enable (not gud-running)
:visible (and (memq gud-minor-mode '(gdbmi gdba gdb perldb))
(gud-tool-bar-item-visible-no-fringe)))
([remove] menu-item "Remove Breakpoint" gud-remove
:enable (not gud-running)
:visible (gud-tool-bar-item-visible-no-fringe))
([tbreak] menu-item "Temporary Breakpoint" gud-tbreak
:enable (not gud-running)
:visible (memq gud-minor-mode
'(lldb gdbmi gdba gdb sdb xdb)))
([break] menu-item "Set Breakpoint" gud-break
:enable (not gud-running)
:visible (gud-tool-bar-item-visible-no-fringe))
([up] menu-item "Up Stack" gud-up
:enable (not gud-running)
:visible (memq gud-minor-mode
'(lldb gdbmi gdba gdb dbx xdb jdb pdb)))
([down] menu-item "Down Stack" gud-down
:enable (not gud-running)
:visible (memq gud-minor-mode
'(lldb gdbmi gdba gdb dbx xdb jdb pdb)))
([pp] menu-item "Print S-expression" gud-pp
:enable (and (not gud-running)
gdb-active-process)
:visible (and (string-equal
(buffer-local-value
'gud-target-name gud-comint-buffer) "emacs")
(eq gud-minor-mode 'gdba)))
([print*] menu-item "Print Dereference" gud-pstar
:enable (not gud-running)
:visible (memq gud-minor-mode '(lldb gdbmi gdba gdb)))
([print] menu-item "Print Expression" gud-print
:enable (not gud-running))
([watch] menu-item "Watch Expression" gud-watch
:enable (not gud-running)
:visible (memq gud-minor-mode '(gdbmi gdba)))
([finish] menu-item "Finish Function" gud-finish
:enable (not gud-running)
:visible (memq gud-minor-mode
'(lldb gdbmi gdba gdb xdb jdb pdb)))
([stepi] menu-item "Step Instruction" gud-stepi
:enable (not gud-running)
:visible (memq gud-minor-mode '(lldb gdbmi gdba gdb dbx)))
([nexti] menu-item "Next Instruction" gud-nexti
:enable (not gud-running)
:visible (memq gud-minor-mode '(lldb gdbmi gdba gdb dbx)))
([step] menu-item "Step Line" gud-step
:enable (not gud-running))
([next] menu-item "Next Line" gud-next
:enable (not gud-running))
([cont] menu-item "Continue" gud-cont
:enable (not gud-running)
:visible (not (eq gud-minor-mode 'gdba))))
"Menu for `gud-mode'."
:name "Gud")
(easy-mmode-defmap gud-minor-mode-map
(append
`(([menu-bar debug] . ("Gud" . ,gud-menu-map)))
(unless window-system
`(([menu-bar down]
. (,(propertize "down" 'face 'font-lock-doc-face) . gud-down))
([menu-bar up]
. (,(propertize "up" 'face 'font-lock-doc-face) . gud-up))
([menu-bar finish]
. (,(propertize "finish" 'face 'font-lock-doc-face) . gud-finish))
([menu-bar step]
. (,(propertize "step" 'face 'font-lock-doc-face) . gud-step))
([menu-bar next]
. (,(propertize "next" 'face 'font-lock-doc-face) . gud-next))
([menu-bar until] menu-item
,(propertize "until" 'face 'font-lock-doc-face) gud-until
:visible (memq gud-minor-mode '(gdbmi gdba gdb perldb)))
([menu-bar cont] menu-item
,(propertize "cont" 'face 'font-lock-doc-face) gud-cont
:visible (not (eq gud-minor-mode 'gdba)))
([menu-bar run] menu-item
,(propertize "run" 'face 'font-lock-doc-face) gud-run
:visible (memq gud-minor-mode '(gdbmi gdb dbx jdb)))
([menu-bar go] menu-item
,(propertize " go " 'face 'font-lock-doc-face) gud-go
:visible (and (not gud-running)
(eq gud-minor-mode 'gdba)))
([menu-bar stop] menu-item
,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob
:visible (or gud-running
(not (eq gud-minor-mode 'gdba))))
([menu-bar print]
. (,(propertize "print" 'face 'font-lock-doc-face) . gud-print))
([menu-bar tools] . undefined)
([menu-bar buffer] . undefined)
([menu-bar options] . undefined)
([menu-bar edit] . undefined)
([menu-bar file] . undefined))))
"Map used in visited files.")
(let ((m (assq 'gud-minor-mode minor-mode-map-alist)))
(if m (setcdr m gud-minor-mode-map)
(push (cons 'gud-minor-mode gud-minor-mode-map) minor-mode-map-alist)))
(defvar gud-mode-map
(make-sparse-keymap)
"`gud-mode' keymap.")
(defvar gud-tool-bar-map
(if (display-graphic-p)
(let ((map (make-sparse-keymap)))
(dolist (x '((gud-break . "gud/break")
(gud-remove . "gud/remove")
(gud-print . "gud/print")
(gud-pstar . "gud/pstar")
(gud-pp . "gud/pp")
(gud-watch . "gud/watch")
(gud-run . "gud/run")
(gud-go . "gud/go")
(gud-stop-subjob . "gud/stop")
(gud-cont . "gud/cont")
(gud-until . "gud/until")
(gud-next . "gud/next")
(gud-step . "gud/step")
(gud-finish . "gud/finish")
(gud-nexti . "gud/nexti")
(gud-stepi . "gud/stepi")
(gud-up . "gud/up")
(gud-down . "gud/down")
(gud-goto-info . "info"))
map)
(tool-bar-local-item-from-menu
(car x) (cdr x) map gud-minor-mode-map)))))
(defun gud-file-name (f)
"Transform a relative file name to an absolute file name.
Uses `gud-<MINOR-MODE>-directories' to find the source files."
(if (file-exists-p f) (expand-file-name f)
(let ((directories (gud-val 'directories))
(result nil))
(while directories
(let ((path (expand-file-name f (car directories))))
(if (file-exists-p path)
(setq result path
directories nil)))
(setq directories (cdr directories)))
result)))
(defun gud-find-file (file)
(while (string-match "//+" file)
(setq file (replace-match "/" t t file)))
(let ((minor-mode gud-minor-mode)
(buf (funcall (or gud-find-file 'gud-file-name) file)))
(when (stringp buf)
(setq buf (and (file-readable-p buf) (find-file-noselect buf 'nowarn))))
(when buf
(with-current-buffer buf
(set (make-local-variable 'gud-minor-mode) minor-mode)
(set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
(when (and gud-tooltip-mode
(memq gud-minor-mode '(gdbmi gdba)))
(make-local-variable 'gdb-define-alist)
(unless gdb-define-alist (gdb-create-define-alist))
(add-hook 'after-save-hook 'gdb-create-define-alist nil t))
(make-local-variable 'gud-keep-buffer))
buf)))
(defmacro gud-def (func cmd key &optional doc)
"Define FUNC to be a command sending CMD and bound to KEY, with
optional doc string DOC. Certain %-escapes in the string arguments
are interpreted specially if present. These are:
%f -- Name (without directory) of current source file.
%F -- Name (without directory or extension) of current source file.
%d -- Directory of current source file.
%l -- Number of current source line.
%e -- Text of the C lvalue or function-call expression surrounding point.
%a -- Text of the hexadecimal address surrounding point.
%b -- Text of the most recently created breakpoint id.
%p -- Prefix argument to the command (if any) as a number.
%c -- Fully qualified class name derived from the expression
surrounding point (jdb only).
The `current' source file is the file of the current buffer (if
we're in a C file) or the source file current at the last break or
step (if we're in the GUD buffer).
The `current' line is that of the current buffer (if we're in a
source file) or the source line number at the last break or step (if
we're in the GUD buffer)."
`(progn
(defun ,func (arg)
,@(if doc (list doc))
(interactive "p")
(if (not gud-running)
,(if (stringp cmd)
`(gud-call ,cmd arg)
cmd)))
,(if key `(local-set-key ,(concat "\C-c" key) ',func))
,(if key `(global-set-key (vconcat gud-key-prefix ,key) ',func))))
(defvar gud-last-frame nil)
(defvar gud-last-last-frame nil)
(eval-when-compile (require 'speedbar))
(defvar gud-last-speedbar-stackframe nil
"Description of the currently displayed GUD stack.
The value t means that there is no stack, and we are in display-file mode.")
(defvar gud-speedbar-key-map nil
"Keymap used when in the buffers display mode.")
(defun gud-speedbar-item-info ()
"Display the data type of the watch expression element."
(let ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list)))
(if (nth 6 var)
(speedbar-message "%s: %s" (nth 6 var) (nth 3 var))
(speedbar-message "%s" (nth 3 var)))))
(defun gud-install-speedbar-variables ()
"Install those variables used by speedbar to enhance gud/gdb."
(if gud-speedbar-key-map
nil
(setq gud-speedbar-key-map (speedbar-make-specialized-keymap))
(define-key gud-speedbar-key-map "j" 'speedbar-edit-line)
(define-key gud-speedbar-key-map "e" 'speedbar-edit-line)
(define-key gud-speedbar-key-map "\C-m" 'speedbar-edit-line)
(define-key gud-speedbar-key-map " " 'speedbar-toggle-line-expansion)
(define-key gud-speedbar-key-map "D" 'gdb-var-delete)
(define-key gud-speedbar-key-map "p" 'gud-pp))
(speedbar-add-expansion-list '("GUD" gud-speedbar-menu-items
gud-speedbar-key-map
gud-expansion-speedbar-buttons))
(add-to-list
'speedbar-mode-functions-list
'("GUD" (speedbar-item-info . gud-speedbar-item-info)
(speedbar-line-directory . ignore))))
(defvar gud-speedbar-menu-items
'(["Jump to stack frame" speedbar-edit-line
:visible (not (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'(gdbmi gdba)))]
["Edit value" speedbar-edit-line
:visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'(gdbmi gdba))]
["Delete expression" gdb-var-delete
:visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'(gdbmi gdba))]
["Auto raise frame" gdb-speedbar-auto-raise
:style toggle :selected gdb-speedbar-auto-raise
:visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'(gdbmi gdba))]
("Output Format"
:visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'(gdbmi gdba))
["Binary" (gdb-var-set-format "binary") t]
["Natural" (gdb-var-set-format "natural") t]
["Hexadecimal" (gdb-var-set-format "hexadecimal") t]))
"Additional menu items to add to the speedbar frame.")
(if (featurep 'speedbar)
(gud-install-speedbar-variables)
(add-hook 'speedbar-load-hook 'gud-install-speedbar-variables))
(defun gud-expansion-speedbar-buttons (directory zero)
"Wrapper for call to `speedbar-add-expansion-list'.
DIRECTORY and ZERO are not used, but are required by the caller."
(gud-speedbar-buttons gud-comint-buffer))
(defun gud-speedbar-buttons (buffer)
"Create a speedbar display based on the current state of GUD.
If the GUD BUFFER is not running a supported debugger, then turn
off the specialized speedbar mode. BUFFER is not used, but is
required by the caller."
(when (and gud-comint-buffer
(buffer-name gud-comint-buffer))
(let* ((minor-mode (with-current-buffer buffer gud-minor-mode))
(window (get-buffer-window (current-buffer) 0))
(start (window-start window))
(p (window-point window)))
(cond
((memq minor-mode '(gdbmi gdba))
(erase-buffer)
(insert "Watch Expressions:\n")
(if gdb-speedbar-auto-raise
(raise-frame speedbar-frame))
(let ((var-list gdb-var-list) parent)
(while var-list
(let* (char (depth 0) (start 0) (var (car var-list))
(varnum (car var)) (expr (nth 1 var))
(type (if (nth 3 var) (nth 3 var) " "))
(value (nth 4 var)) (status (nth 5 var)))
(put-text-property
0 (length expr) 'face font-lock-variable-name-face expr)
(put-text-property
0 (length type) 'face font-lock-type-face type)
(while (string-match "\\." varnum start)
(setq depth (1+ depth)
start (1+ (match-beginning 0))))
(if (eq depth 0) (setq parent nil))
(if (or (equal (nth 2 var) "0")
(and (equal (nth 2 var) "1")
(string-match "char \\*$" type)))
(speedbar-make-tag-line
'bracket ?? nil nil
(concat expr "\t" value)
(if (or parent (eq status 'out-of-scope))
nil 'gdb-edit-value)
nil
(if gdb-show-changed-values
(or parent (case status
(changed 'font-lock-warning-face)
(out-of-scope 'shadow)
(t t)))
t)
depth)
(if (eq status 'out-of-scope) (setq parent 'shadow))
(if (and (nth 1 var-list)
(string-match (concat varnum "\\.")
(car (nth 1 var-list))))
(setq char ?-)
(setq char ?+))
(if (string-match "\\*$\\|\\*&$" type)
(speedbar-make-tag-line
'bracket char
'gdb-speedbar-expand-node varnum
(concat expr "\t" type "\t" value)
(if (or parent (eq status 'out-of-scope))
nil 'gdb-edit-value)
nil
(if gdb-show-changed-values
(or parent (case status
(changed 'font-lock-warning-face)
(out-of-scope 'shadow)
(t t)))
t)
depth)
(speedbar-make-tag-line
'bracket char
'gdb-speedbar-expand-node varnum
(concat expr "\t" type)
nil nil
(if (and (or parent status) gdb-show-changed-values)
'shadow t)
depth))))
(setq var-list (cdr var-list)))))
(t (unless (and (save-excursion
(goto-char (point-min))
(looking-at "Current Stack:"))
(equal gud-last-last-frame gud-last-speedbar-stackframe))
(let ((gud-frame-list
(cond ((eq minor-mode 'gdb)
(gud-gdb-get-stackframe buffer))
(t (speedbar-remove-localized-speedbar-support buffer)
nil))))
(erase-buffer)
(if (not gud-frame-list)
(insert "No Stack frames\n")
(insert "Current Stack:\n"))
(dolist (frame gud-frame-list)
(insert (nth 1 frame) ":\n")
(if (= (length frame) 2)
(progn
(speedbar-insert-button (car frame)
'speedbar-directory-face
nil nil nil t))
(speedbar-insert-button
(car frame)
'speedbar-file-face
'speedbar-highlight-face
(cond ((memq minor-mode '(gdbmi gdba gdb))
'gud-gdb-goto-stackframe)
(t (error "Should never be here")))
frame t))))
(setq gud-last-speedbar-stackframe gud-last-last-frame))))
(set-window-start window start)
(set-window-point window p))))
(defvar gud-gdb-history nil)
(defcustom gud-gud-gdb-command-name "gdb --fullname"
"Default command to run an executable under GDB in text command mode.
The option \"--fullname\" must be included in this value."
:type 'string
:group 'gud)
(defvar gud-gdb-marker-regexp
(concat "\032\032\\(.:?[^" ":" "\n]*\\)" ":"
"\\([0-9]*\\)" ":" ".*\n"))
(defvar gud-marker-acc "")
(make-variable-buffer-local 'gud-marker-acc)
(defun gud-gdb-marker-filter (string)
(setq gud-marker-acc (concat gud-marker-acc string))
(let ((output ""))
(while (string-match gud-gdb-marker-regexp gud-marker-acc)
(setq
gud-last-frame (cons (match-string 1 gud-marker-acc)
(string-to-number (match-string 2 gud-marker-acc)))
output (concat output
(substring gud-marker-acc 0 (match-beginning 0)))
gud-marker-acc (substring gud-marker-acc (match-end 0))))
(while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc)
(let ((match (match-string 1 gud-marker-acc)))
(setq
output (concat output
(substring gud-marker-acc 0 (match-beginning 0)))
gud-marker-acc (substring gud-marker-acc (match-end 0)))))
(if (string-match "\n\\(\032.*\\)?\\'" gud-marker-acc)
(progn
(setq output (concat output (substring gud-marker-acc
0 (match-beginning 0))))
(setq gud-marker-acc
(substring gud-marker-acc (match-beginning 0))))
(setq output (concat output gud-marker-acc)
gud-marker-acc ""))
output))
(easy-mmode-defmap gud-minibuffer-local-map
'(("\C-i" . comint-dynamic-complete-filename))
"Keymap for minibuffer prompting of gud startup command."
:inherit minibuffer-local-map)
(defun gud-query-cmdline (minor-mode &optional init)
(let* ((hist-sym (gud-symbol 'history nil minor-mode))
(cmd-name (gud-val 'command-name minor-mode)))
(unless (boundp hist-sym) (set hist-sym nil))
(read-from-minibuffer
(format "Run %s (like this): " minor-mode)
(or (car-safe (symbol-value hist-sym))
(concat (or cmd-name (symbol-name minor-mode))
" "
(or init
(let ((file nil))
(dolist (f (directory-files default-directory) file)
(if (and (file-executable-p f)
(not (file-directory-p f))
(or (not file)
(file-newer-than-file-p f file)))
(setq file f)))))))
gud-minibuffer-local-map nil
hist-sym)))
(defvar gdb-first-prompt t)
(defvar gud-filter-pending-text nil
"Non-nil means this is text that has been saved for later in `gud-filter'.")
(defun gud-gdb (command-line)
"Run gdb on program FILE in buffer *gud-FILE*.
The directory containing FILE becomes the initial working
directory and source-file directory for your debugger."
(interactive (list (gud-query-cmdline 'gud-gdb)))
(when (and gud-comint-buffer
(buffer-name gud-comint-buffer)
(get-buffer-process gud-comint-buffer)
(with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba)))
(gdb-restore-windows)
(error
"Multiple debugging requires restarting in text command mode"))
(gud-common-init command-line nil 'gud-gdb-marker-filter)
(set (make-local-variable 'gud-minor-mode) 'gdb)
(gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-tbreak "tbreak %f:%l" "\C-t"
"Set temporary breakpoint at current line.")
(gud-def gud-remove "clear %f:%l" "\C-d" "Remove breakpoint at current line")
(gud-def gud-step "step %p" "\C-s" "Step one source line with display.")
(gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.")
(gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).")
(gud-def gud-nexti "nexti %p" nil "Step one instruction (skip functions).")
(gud-def gud-cont "cont" "\C-r" "Continue with display.")
(gud-def gud-finish "finish" "\C-f" "Finish executing current function.")
(gud-def gud-jump
(progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l"))
"\C-j" "Set execution address to current line.")
(gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).")
(gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).")
(gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.")
(gud-def gud-pstar "print* %e" nil
"Evaluate C dereferenced pointer expression at point.")
(gud-def gud-pv "pv1 %e" "\C-v" "Print the value of the lisp variable.")
(gud-def gud-until "until %l" "\C-u" "Continue to current line.")
(gud-def gud-run "run" nil "Run the program.")
(local-set-key "\C-i" 'gud-gdb-complete-command)
(setq comint-prompt-regexp "^(.*gdb[+]?) *")
(setq paragraph-start comint-prompt-regexp)
(setq gdb-first-prompt t)
(setq gud-running nil)
(setq gdb-ready nil)
(setq gud-filter-pending-text nil)
(run-hooks 'gud-gdb-mode-hook))
(defvar gud-gdb-fetch-lines-in-progress)
(defvar gud-gdb-fetch-lines-string)
(defvar gud-gdb-fetch-lines-break)
(defvar gud-gdb-fetched-lines)
(defun gud-gdb-complete-command (&optional command a b)
"Perform completion on the GDB command preceding point.
This is implemented using the GDB `complete' command which isn't
available with older versions of GDB."
(interactive)
(if command
(setq command (concat "p " command))
(let ((end (point)))
(setq command (buffer-substring (comint-line-beginning-position) end))))
(let* ((command-word
(and (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command)
(substring command (match-beginning 2))))
(complete-list
(gud-gdb-run-command-fetch-lines (concat "complete " command)
(current-buffer)
(match-beginning 2))))
(and complete-list
(string-match "^Undefined command: \"complete\"" (car complete-list))
(error "This version of GDB doesn't support the `complete' command"))
(setq complete-list (sort complete-list (function string-lessp)))
(let ((first complete-list)
(second (cdr complete-list)))
(while second
(if (string-equal (car first) (car second))
(setcdr first (setq second (cdr second)))
(setq first second
second (cdr second)))))
(and (= (length complete-list) 1)
(let ((str (car complete-list))
(pos 0)
(count 0))
(while (string-match "\\([^'\\]\\|\\\\'\\)*'" str pos)
(setq count (1+ count)
pos (match-end 0)))
(and (= (mod count 2) 1)
(setq complete-list (list (concat str "'"))))))
(comint-dynamic-simple-complete command-word complete-list)))
(defun gud-gdb-fetch-lines-filter (string filter)
"Filter used to read the list of lines output by a command.
STRING is the output to filter.
It is passed through FILTER before we look at it."
(setq string (funcall filter string))
(setq string (concat gud-gdb-fetch-lines-string string))
(while (string-match "\n" string)
(push (substring string gud-gdb-fetch-lines-break (match-beginning 0))
gud-gdb-fetched-lines)
(setq string (substring string (match-end 0))))
(if (string-match comint-prompt-regexp string)
(progn
(setq gud-gdb-fetch-lines-in-progress nil)
string)
(progn
(setq gud-gdb-fetch-lines-string string)
"")))
(defun gud-gdb-goto-stackframe (text token indent)
"Goto the stackframe described by TEXT, TOKEN, and INDENT."
(speedbar-with-attached-buffer
(gud-basic-call (concat "server frame " (nth 1 token)))
(sit-for 1)))
(defvar gud-gdb-fetched-stack-frame nil
"Stack frames we are fetching from GDB.")
(defun gud-gdb-get-stackframe (buffer)
"Extract the current stack frame out of the GUD GDB BUFFER."
(let ((newlst nil)
(fetched-stack-frame-list
(gud-gdb-run-command-fetch-lines "server backtrace" buffer)))
(if (and (car fetched-stack-frame-list)
(string-match "No stack" (car fetched-stack-frame-list)))
nil
(dolist (e fetched-stack-frame-list)
(let ((name nil) (num nil))
(if (not (or
(string-match "^#\\([0-9]+\\) +[0-9a-fx]+ in \\([:0-9a-zA-Z_]+\\) (" e)
(string-match "^#\\([0-9]+\\) +\\([:0-9a-zA-Z_]+\\) (" e)))
(if (not (string-match
"at \\([-0-9a-zA-Z_.]+\\):\\([0-9]+\\)$" e))
nil
(setcar newlst
(list (nth 0 (car newlst))
(nth 1 (car newlst))
(match-string 1 e)
(match-string 2 e))))
(setq num (match-string 1 e)
name (match-string 2 e))
(setq newlst
(cons
(if (string-match
"at \\([-0-9a-zA-Z_.]+\\):\\([0-9]+\\)$" e)
(list name num (match-string 1 e)
(match-string 2 e))
(list name num))
newlst)))))
(nreverse newlst))))
(defun gud-gdb-run-command-fetch-lines (command buffer &optional skip)
"Run COMMAND, and return the list of lines it outputs.
BUFFER is the current buffer which may be the GUD buffer in which to run.
SKIP is the number of chars to skip on each line, it defaults to 0."
(with-current-buffer gud-comint-buffer
(if (and (eq gud-comint-buffer buffer)
(save-excursion
(goto-char (point-max))
(forward-line 0)
(not (looking-at comint-prompt-regexp))))
nil
(let ((gud-gdb-fetch-lines-in-progress t)
(gud-gdb-fetched-lines nil)
(gud-gdb-fetch-lines-string nil)
(gud-gdb-fetch-lines-break (or skip 0))
(gud-marker-filter
`(lambda (string)
(gud-gdb-fetch-lines-filter string ',gud-marker-filter))))
(gud-basic-call command)
(while gud-gdb-fetch-lines-in-progress
(accept-process-output (get-buffer-process gud-comint-buffer)))
(nreverse gud-gdb-fetched-lines)))))
(defvar gud-lldb-history nil)
(defvar gud-breakpoint-id nil)
(defun lldb-extract-breakpoint-id (string)
(if (string-match "Breakpoint created: \\([^:\n]*\\):" string)
(progn
(setq gud-breakpoint-id (match-string 1 string))
(message "breakpoint id: %s" gud-breakpoint-id)))
)
(defun gud-lldb-marker-filter (string)
(setq gud-marker-acc
(if gud-marker-acc (concat gud-marker-acc string) string))
(lldb-extract-breakpoint-id gud-marker-acc)
(let (start)
(while (or
(string-match " at \\([^:\n]*\\):\\([0-9]*\\), stop reason = .*\n"
gud-marker-acc start)
(string-match "^frame.* at \\([^:\n]*\\):\\([0-9]*\\)\n"
gud-marker-acc start))
(setq gud-last-frame
(cons (match-string 1 gud-marker-acc)
(string-to-number (match-string 2 gud-marker-acc)))
start (match-end 0)))
(while (string-match "\n" gud-marker-acc start)
(setq start (match-end 0)))
(setq gud-marker-acc (substring gud-marker-acc (or start 0))))
string)
(defvar lldb-oneshot-break-defined nil)
(defun lldb (command-line)
"Run lldb on program FILE in buffer *gud-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for your debugger."
(interactive (list (gud-query-cmdline 'lldb)))
(gud-common-init command-line nil 'gud-lldb-marker-filter)
(set (make-local-variable 'gud-minor-mode) 'lldb)
(setq lldb-oneshot-break-defined nil)
(progn
(gud-call "settings set frame-format frame #${frame.index}: ${frame.pc}{ ${module.file.basename}{`${function.name}${function.pc-offset}}}{ at ${line.file.fullpath}:${line.number}}\\n")
(sit-for 1)
(gud-call "settings set thread-format thread #${thread.index}: tid = ${thread.id}{, ${frame.pc}}{ ${module.file.basename}{`${function.name}${function.pc-offset}}}{ at ${line.file.fullpath}:${line.number}}{, stop reason = ${thread.stop-reason}}\\n")
(sit-for 1))
(gud-def gud-listb "breakpoint list"
"l" "List all breakpoints.")
(gud-def gud-bt "thread backtrace"
"b" "Show stack for the current thread.")
(gud-def gud-bt-all "thread backtrace all"
"B" "Show stacks for all the threads.")
(gud-def gud-break "breakpoint set -f %f -l %l"
"\C-b" "Set breakpoint at current line.")
(gud-def gud-tbreak
(progn (gud-call "breakpoint set -f %f -l %l")
(sit-for 1)
(if (not lldb-oneshot-break-defined)
(progn
(gud-call (concat "script exec \"def lldb_oneshot_break(frame, bp_loc):\\n"
" target=frame.GetThread().GetProcess().GetTarget()\\n"
" bp=bp_loc.GetBreakpoint()\\n"
" print 'Deleting oneshot breakpoint:', bp\\n"
" target.BreakpointDelete(bp.GetID())\""))
(sit-for 1)
(setq lldb-oneshot-break-defined t)))
(gud-call "breakpoint command add -p %b -o 'lldb_oneshot_break(frame, bp_loc)'"))
"\C-t" "Set temporary breakpoint at current line.")
(gud-def gud-remove "breakpoint clear -f %f -l %l"
"\C-d" "Remove breakpoint at current line")
(gud-def gud-step "thread step-in"
"\C-s" "Step one source line with display.")
(gud-def gud-stepi "thread step-inst"
"\C-i" "Step one instruction with display.")
(gud-def gud-next "thread step-over"
"\C-n" "Step one line (skip functions).")
(gud-def gud-nexti "thread step-inst-over"
nil "Step one instruction (skip functions).")
(gud-def gud-cont "process continue"
"\C-r" "Continue with display.")
(gud-def gud-finish "thread step-out"
"\C-f" "Finish executing current function.")
(gud-def gud-up
(progn (gud-call "frame select -r 1")
(sit-for 1))
"<" "Up 1 stack frame.")
(gud-def gud-down
(progn (gud-call "frame select -r -1")
(sit-for 1))
">" "Down 1 stack frame.")
(gud-def gud-print "expression -- %e"
"\C-p" "Evaluate C expression at point.")
(gud-def gud-pstar "expression -- *%e"
nil "Evaluate C dereferenced pointer expression at point.")
(gud-def gud-run "run"
"r" "Run the program.")
(gud-def gud-stop-subjob "process kill"
"s" "Stop the program.")
(setq comint-prompt-regexp "\\(^\\|\n\\)\\*")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'lldb-mode-hook)
)
(defvar gud-sdb-history nil)
(defvar gud-sdb-needs-tags (not (file-exists-p "/var"))
"If nil, we're on a System V Release 4 and don't need the tags hack.")
(defvar gud-sdb-lastfile nil)
(defun gud-sdb-marker-filter (string)
(setq gud-marker-acc
(if gud-marker-acc (concat gud-marker-acc string) string))
(let (start)
(while
(cond
((string-match "\\(^\\|\n\\)\\*?\\(0x\\w* in \\)?\\([^:\n]*\\):\\([0-9]*\\):.*\n"
gud-marker-acc start)
(setq gud-last-frame
(cons (match-string 3 gud-marker-acc)
(string-to-number (match-string 4 gud-marker-acc)))))
((string-match "^\\(BREAKPOINT\\|STEPPED\\) process [0-9]+ function [^ ]+ in \\(.+\\)\n\\([0-9]+\\):"
gud-marker-acc start)
(setq gud-sdb-lastfile (match-string 2 gud-marker-acc))
(setq gud-last-frame
(cons gud-sdb-lastfile
(string-to-number (match-string 3 gud-marker-acc)))))
((string-match "^\\(BREAKPOINT\\|STEPPED\\) process [0-9]+ function [^ ]+ in \\(.+\\)\n"
gud-marker-acc start)
(setq gud-sdb-lastfile (match-string 2 gud-marker-acc)))
((and gud-sdb-lastfile (string-match "^\\([0-9]+\\):"
gud-marker-acc start))
(setq gud-last-frame
(cons gud-sdb-lastfile
(string-to-number (match-string 1 gud-marker-acc)))))
(t
(setq gud-sdb-lastfile nil)))
(setq start (match-end 0)))
(while (string-match "\n" gud-marker-acc start)
(setq start (match-end 0)))
(setq gud-marker-acc (substring gud-marker-acc (or start 0))))
string)
(defun gud-sdb-find-file (f)
(if gud-sdb-needs-tags (find-tag-noselect f) (find-file-noselect f)))
(defun sdb (command-line)
"Run sdb on program FILE in buffer *gud-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for your debugger."
(interactive (list (gud-query-cmdline 'sdb)))
(if gud-sdb-needs-tags (require 'etags))
(if (and gud-sdb-needs-tags
(not (and (boundp 'tags-file-name)
(stringp tags-file-name)
(file-exists-p tags-file-name))))
(error "The sdb support requires a valid tags table to work"))
(gud-common-init command-line nil 'gud-sdb-marker-filter 'gud-sdb-find-file)
(set (make-local-variable 'gud-minor-mode) 'sdb)
(gud-def gud-break "%l b" "\C-b" "Set breakpoint at current line.")
(gud-def gud-tbreak "%l c" "\C-t" "Set temporary breakpoint at current line.")
(gud-def gud-remove "%l d" "\C-d" "Remove breakpoint at current line")
(gud-def gud-step "s %p" "\C-s" "Step one source line with display.")
(gud-def gud-stepi "i %p" "\C-i" "Step one instruction with display.")
(gud-def gud-next "S %p" "\C-n" "Step one line (skip functions).")
(gud-def gud-cont "c" "\C-r" "Continue with display.")
(gud-def gud-print "%e/" "\C-p" "Evaluate C expression at point.")
(setq comint-prompt-regexp "\\(^\\|\n\\)\\*")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'sdb-mode-hook)
)
(defvar gud-dbx-history nil)
(defcustom gud-dbx-directories nil
"*A list of directories that dbx should search for source code.
If nil, only source files in the program directory
will be known to dbx.
The file names should be absolute, or relative to the directory
containing the executable being debugged."
:type '(choice (const :tag "Current Directory" nil)
(repeat :value ("")
directory))
:group 'gud)
(defun gud-dbx-massage-args (file args)
(nconc (let ((directories gud-dbx-directories)
(result nil))
(while directories
(setq result (cons (car directories) (cons "-I" result)))
(setq directories (cdr directories)))
(nreverse result))
args))
(defun gud-dbx-marker-filter (string)
(setq gud-marker-acc (if gud-marker-acc (concat gud-marker-acc string) string))
(let (start)
(while (or (string-match
"stopped in .* at line \\([0-9]*\\) in file \"\\([^\"]*\\)\""
gud-marker-acc start)
(string-match
"signal .* in .* at line \\([0-9]*\\) in file \"\\([^\"]*\\)\""
gud-marker-acc start))
(setq gud-last-frame
(cons (match-string 2 gud-marker-acc)
(string-to-number (match-string 1 gud-marker-acc)))
start (match-end 0)))
(while (string-match "\n" gud-marker-acc start)
(setq start (match-end 0)))
(setq gud-marker-acc
(if (string-match "\\(stopped\\|signal\\)" gud-marker-acc start)
(substring gud-marker-acc (match-beginning 0))
nil)))
string)
(defvar gud-mips-p
(or (string-match "^mips-[^-]*-ultrix" system-configuration)
(string-match "^mips-[^-]*-riscos" system-configuration)
(string-match "^mips-[^-]*-osf1" system-configuration)
(string-match "^alpha[^-]*-[^-]*-osf" system-configuration))
"Non-nil to assume the MIPS/OSF dbx conventions (argument `-emacs').")
(defvar gud-dbx-command-name
(concat "dbx" (if gud-mips-p " -emacs")))
(defun gud-mipsdbx-marker-filter (string)
(setq gud-marker-acc (concat gud-marker-acc string))
(let ((output ""))
(while (string-match
"[][ 0-9]*\032\032\\([^:\n]*\\):\\([0-9]*\\):.*\n"
gud-marker-acc)
(setq
gud-last-frame
(cons (match-string 1 gud-marker-acc)
(string-to-number (match-string 2 gud-marker-acc)))
output (concat output
(substring gud-marker-acc 0 (match-beginning 0)))
gud-marker-acc (substring gud-marker-acc (match-end 0))))
(if (string-match "[][ 0-9]*\032.*\\'" gud-marker-acc)
(progn
(setq output (concat output (substring gud-marker-acc
0 (match-beginning 0))))
(setq gud-marker-acc
(substring gud-marker-acc (match-beginning 0))))
(setq output (concat output gud-marker-acc)
gud-marker-acc ""))
output))
(defvar gud-irix-p
(and (string-match "^mips-[^-]*-irix" system-configuration)
(not (string-match "irix[6-9]\\.[1-9]" system-configuration)))
"Non-nil to assume the interface appropriate for IRIX dbx.
This works in IRIX 4, 5 and 6, but `gud-dbx-use-stopformat-p' provides
a better solution in 6.1 upwards.")
(defvar gud-dbx-use-stopformat-p
(string-match "irix[6-9]\\.[1-9]" system-configuration)
"Non-nil to use the dbx feature present at least from Irix 6.1
whereby $stopformat=1 produces an output format compatible with
`gud-dbx-marker-filter'.")
(defun gud-irixdbx-marker-filter (string)
(let (result (case-fold-search nil))
(if (or (string-match comint-prompt-regexp string)
(string-match ".*\012" string))
(setq result (concat gud-marker-acc string)
gud-marker-acc "")
(setq gud-marker-acc (concat gud-marker-acc string)))
(if result
(cond
((string-match
"^\\(\\[[0-9]+] \\)?Process +[0-9]+ ([^)]*) [^[]+\\[[^]\n]*]\n"
result)
(process-send-string (get-buffer-process gud-comint-buffer)
"printf \"\032\032%1d:\",(int)$curline;file\n"))
((string-match
"^[^ ][^[]*\\[\"\\([^\"]+\\)\":\\([0-9]+\\), [^]]+]\n"
result)
(let ((file (match-string 1 result)))
(if (file-exists-p file)
(setq gud-last-frame
(cons (match-string 1 result)
(string-to-number (match-string 2 result))))))
result)
((string-match "\032\032\\([0-9]*\\):\\(.*\\)\n" result)
(let ((file (gud-file-name (match-string 2 result))))
(if (and file (file-exists-p file))
(setq gud-last-frame
(cons file
(string-to-number (match-string 1 result))))))
(setq result (substring result 0 (match-beginning 0))))))
(or result "")))
(defvar gud-dgux-p (string-match "-dgux" system-configuration)
"Non-nil means to assume the interface approriate for DG/UX dbx.
This was tested using R4.11.")
(defun gud-dguxdbx-marker-filter (string)
(setq gud-marker-acc (if gud-marker-acc
(concat gud-marker-acc string)
string))
(let ((re (concat "^\\(\\(([0-9]+) \\)?Stopped at\\|Frame [0-9]+,\\)"
" line \\([0-9]+\\), routine .*, file \\([^ \t\n]+\\)"))
start)
(while (string-match re gud-marker-acc start)
(setq gud-last-frame
(cons (match-string 4 gud-marker-acc)
(string-to-number (match-string 3 gud-marker-acc)))
start (match-end 0)))
(while (string-match "\n" gud-marker-acc start)
(setq start (match-end 0)))
(setq gud-marker-acc
(if (string-match "Stopped\\|Frame" gud-marker-acc start)
(substring gud-marker-acc (match-beginning 0))
nil)))
string)
(defun dbx (command-line)
"Run dbx on program FILE in buffer *gud-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for your debugger."
(interactive (list (gud-query-cmdline 'dbx)))
(cond
(gud-mips-p
(gud-common-init command-line nil 'gud-mipsdbx-marker-filter))
(gud-irix-p
(gud-common-init command-line 'gud-dbx-massage-args
'gud-irixdbx-marker-filter))
(gud-dgux-p
(gud-common-init command-line 'gud-dbx-massage-args
'gud-dguxdbx-marker-filter))
(t
(gud-common-init command-line 'gud-dbx-massage-args
'gud-dbx-marker-filter)))
(set (make-local-variable 'gud-minor-mode) 'dbx)
(cond
(gud-mips-p
(gud-def gud-up "up %p" "<" "Up (numeric arg) stack frames.")
(gud-def gud-down "down %p" ">" "Down (numeric arg) stack frames.")
(gud-def gud-break "stop at \"%f\":%l"
"\C-b" "Set breakpoint at current line.")
(gud-def gud-finish "return" "\C-f" "Finish executing current function."))
(gud-irix-p
(gud-def gud-break "stop at \"%d%f\":%l"
"\C-b" "Set breakpoint at current line.")
(gud-def gud-finish "return" "\C-f" "Finish executing current function.")
(gud-def gud-up "up %p; printf \"\032\032%1d:\",(int)$curline;file\n"
"<" "Up (numeric arg) stack frames.")
(gud-def gud-down "down %p; printf \"\032\032%1d:\",(int)$curline;file\n"
">" "Down (numeric arg) stack frames.")
(process-send-string (get-buffer-process gud-comint-buffer)
"printf \"\032\032%1d:\",(int)$curline;file\n"))
(t
(gud-def gud-up "up %p" "<" "Up (numeric arg) stack frames.")
(gud-def gud-down "down %p" ">" "Down (numeric arg) stack frames.")
(gud-def gud-break "file \"%d%f\"\nstop at %l"
"\C-b" "Set breakpoint at current line.")
(if gud-dbx-use-stopformat-p
(process-send-string (get-buffer-process gud-comint-buffer)
"set $stopformat=1\n"))))
(gud-def gud-remove "clear %l" "\C-d" "Remove breakpoint at current line")
(gud-def gud-step "step %p" "\C-s" "Step one line with display.")
(gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.")
(gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).")
(gud-def gud-nexti "nexti %p" nil "Step one instruction (skip functions).")
(gud-def gud-cont "cont" "\C-r" "Continue with display.")
(gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.")
(gud-def gud-run "run" nil "Run the program.")
(setq comint-prompt-regexp "^[^)\n]*dbx) *")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'dbx-mode-hook)
)
(defvar gud-xdb-history nil)
(defcustom gud-xdb-directories nil
"*A list of directories that xdb should search for source code.
If nil, only source files in the program directory
will be known to xdb.
The file names should be absolute, or relative to the directory
containing the executable being debugged."
:type '(choice (const :tag "Current Directory" nil)
(repeat :value ("")
directory))
:group 'gud)
(defun gud-xdb-massage-args (file args)
(nconc (let ((directories gud-xdb-directories)
(result nil))
(while directories
(setq result (cons (car directories) (cons "-d" result)))
(setq directories (cdr directories)))
(nreverse result))
args))
(defun gud-xdb-marker-filter (string)
(let (result)
(if (or (string-match comint-prompt-regexp string)
(string-match ".*\012" string))
(setq result (concat gud-marker-acc string)
gud-marker-acc "")
(setq gud-marker-acc (concat gud-marker-acc string)))
(if result
(if (or (string-match "\\([^\n \t:]+\\): [^:]+: \\([0-9]+\\)[: ]"
result)
(string-match "[^: \t]+:[ \t]+\\([^:]+\\): [^:]+: \\([0-9]+\\):"
result))
(let ((line (string-to-number (match-string 2 result)))
(file (gud-file-name (match-string 1 result))))
(if file
(setq gud-last-frame (cons file line))))))
(or result "")))
(defun xdb (command-line)
"Run xdb on program FILE in buffer *gud-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for your debugger.
You can set the variable `gud-xdb-directories' to a list of program source
directories if your program contains sources from more than one directory."
(interactive (list (gud-query-cmdline 'xdb)))
(gud-common-init command-line 'gud-xdb-massage-args
'gud-xdb-marker-filter)
(set (make-local-variable 'gud-minor-mode) 'xdb)
(gud-def gud-break "b %f:%l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-tbreak "b %f:%l\\t" "\C-t"
"Set temporary breakpoint at current line.")
(gud-def gud-remove "db" "\C-d" "Remove breakpoint at current line")
(gud-def gud-step "s %p" "\C-s" "Step one line with display.")
(gud-def gud-next "S %p" "\C-n" "Step one line (skip functions).")
(gud-def gud-cont "c" "\C-r" "Continue with display.")
(gud-def gud-up "up %p" "<" "Up (numeric arg) stack frames.")
(gud-def gud-down "down %p" ">" "Down (numeric arg) stack frames.")
(gud-def gud-finish "bu\\t" "\C-f" "Finish executing current function.")
(gud-def gud-print "p %e" "\C-p" "Evaluate C expression at point.")
(setq comint-prompt-regexp "^>")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'xdb-mode-hook))
(defvar gud-perldb-history nil)
(defun gud-perldb-massage-args (file args)
"Convert a command line as would be typed normally to run perldb
into one that invokes an Emacs-enabled debugging session.
\"-emacs\" is inserted where it will be $ARGV[0] (see perl5db.pl)."
(let* ((new-args nil)
(seen-e nil)
(shift (lambda () (push (pop args) new-args))))
(while (and args
(string-match "^-" (car args))
(not (equal "-" (car args)))
(not (equal "--" (car args))))
(when (equal "-e" (car args))
(or (funcall shift)
(error "No code specified for -e"))
(setq seen-e t))
(funcall shift))
(unless seen-e
(if (or (not args)
(string-match "^-" (car args)))
(error "Can't use stdin as the script to debug"))
(funcall shift))
(if (and args (equal "--" (car args)))
(funcall shift)
(and seen-e (push "--" new-args)))
(push "-emacs" new-args)
(while args
(funcall shift))
(nreverse new-args)))
(defun gud-perldb-marker-filter (string)
(setq gud-marker-acc (concat gud-marker-acc string))
(let ((output ""))
(while (string-match "\032\032\\(\\([a-zA-Z]:\\)?[^:\n]*\\):\\([0-9]*\\):.*\n"
gud-marker-acc)
(setq
gud-last-frame
(cons (match-string 1 gud-marker-acc)
(string-to-number (match-string 3 gud-marker-acc)))
output (concat output
(substring gud-marker-acc 0 (match-beginning 0)))
gud-marker-acc (substring gud-marker-acc (match-end 0))))
(if (string-match "\032.*\\'" gud-marker-acc)
(progn
(setq output (concat output (substring gud-marker-acc
0 (match-beginning 0))))
(setq gud-marker-acc
(substring gud-marker-acc (match-beginning 0))))
(setq output (concat output gud-marker-acc)
gud-marker-acc ""))
output))
(defcustom gud-perldb-command-name "perl -d"
"Default command to execute a Perl script under debugger."
:type 'string
:group 'gud)
(defun perldb (command-line)
"Run perldb on program FILE in buffer *gud-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for your debugger."
(interactive
(list (gud-query-cmdline 'perldb
(concat (or (buffer-file-name) "-e 0") " "))))
(gud-common-init command-line 'gud-perldb-massage-args
'gud-perldb-marker-filter)
(set (make-local-variable 'gud-minor-mode) 'perldb)
(gud-def gud-break "b %l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-remove "B %l" "\C-d" "Remove breakpoint at current line")
(gud-def gud-step "s" "\C-s" "Step one source line with display.")
(gud-def gud-next "n" "\C-n" "Step one line (skip functions).")
(gud-def gud-cont "c" "\C-r" "Continue with display.")
(gud-def gud-print "p %e" "\C-p" "Evaluate perl expression at point.")
(gud-def gud-until "c %l" "\C-u" "Continue to current line.")
(setq comint-prompt-regexp "^ DB<+[0-9]+>+ ")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'perldb-mode-hook))
(defvar gud-pdb-history nil)
(defvar gud-pdb-marker-regexp
"^> \\([-a-zA-Z0-9_/.:\\]*\\|<string>\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|<module>\\)()\\(->[^\n]*\\)?\n")
(defvar gud-pdb-marker-regexp-file-group 1)
(defvar gud-pdb-marker-regexp-line-group 2)
(defvar gud-pdb-marker-regexp-fnname-group 3)
(defvar gud-pdb-marker-regexp-start "^> ")
(defun gud-pdb-marker-filter (string)
(setq gud-marker-acc (concat gud-marker-acc string))
(let ((output ""))
(while (string-match gud-pdb-marker-regexp gud-marker-acc)
(setq
gud-last-frame
(let ((file (match-string gud-pdb-marker-regexp-file-group
gud-marker-acc))
(line (string-to-number
(match-string gud-pdb-marker-regexp-line-group
gud-marker-acc))))
(if (string-equal file "<string>")
gud-last-frame
(cons file line)))
output (concat output (substring gud-marker-acc 0 (match-end 0)))
gud-marker-acc (substring gud-marker-acc (match-end 0))))
(if (string-match gud-pdb-marker-regexp-start gud-marker-acc)
(progn
(setq output (concat output (substring gud-marker-acc
0 (match-beginning 0))))
(setq gud-marker-acc
(substring gud-marker-acc (match-beginning 0))))
(setq output (concat output gud-marker-acc)
gud-marker-acc ""))
output))
(defcustom gud-pdb-command-name "pdb"
"File name for executing the Python debugger.
This should be an executable on your path, or an absolute file name."
:type 'string
:group 'gud)
(defun pdb (command-line)
"Run pdb on program FILE in buffer `*gud-FILE*'.
The directory containing FILE becomes the initial working directory
and source-file directory for your debugger."
(interactive
(list (gud-query-cmdline 'pdb)))
(gud-common-init command-line nil 'gud-pdb-marker-filter)
(set (make-local-variable 'gud-minor-mode) 'pdb)
(gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-remove "clear %f:%l" "\C-d" "Remove breakpoint at current line")
(gud-def gud-step "step" "\C-s" "Step one source line with display.")
(gud-def gud-next "next" "\C-n" "Step one line (skip functions).")
(gud-def gud-cont "continue" "\C-r" "Continue with display.")
(gud-def gud-finish "return" "\C-f" "Finish executing current function.")
(gud-def gud-up "up" "<" "Up one stack frame.")
(gud-def gud-down "down" ">" "Down one stack frame.")
(gud-def gud-print "p %e" "\C-p" "Evaluate Python expression at point.")
(gud-def gud-statement "! %e" "\C-e" "Execute Python statement at point.")
(setq comint-prompt-regexp "^(Pdb) *")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'pdb-mode-hook))
(defcustom gud-jdb-command-name "jdb"
"Command that executes the Java debugger."
:type 'string
:group 'gud)
(defcustom gud-jdb-use-classpath t
"If non-nil, search for Java source files in classpath directories.
The list of directories to search is the value of `gud-jdb-classpath'.
The file pathname is obtained by converting the fully qualified
class information output by jdb to a relative pathname and appending
it to `gud-jdb-classpath' element by element until a match is found.
This method has a significant jdb startup time reduction advantage
since it does not require the scanning of all `gud-jdb-directories'
and parsing all Java files for class information.
Set to nil to use `gud-jdb-directories' to scan java sources for
class information on jdb startup (original method)."
:type 'boolean
:group 'gud)
(defvar gud-jdb-classpath nil
"Java/jdb classpath directories list.
If `gud-jdb-use-classpath' is non-nil, gud-jdb derives the `gud-jdb-classpath'
list automatically using the following methods in sequence
\(with subsequent successful steps overriding the results of previous
steps):
1) Read the CLASSPATH environment variable,
2) Read any \"-classpath\" argument used to run jdb,
or detected in jdb output (e.g. if jdb is run by a script
that echoes the actual jdb command before starting jdb),
3) Send a \"classpath\" command to jdb and scan jdb output for
classpath information if jdb is invoked with an \"-attach\" (to
an already running VM) argument (This case typically does not
have a \"-classpath\" command line argument - that is provided
to the VM when it is started).
Note that method 3 cannot be used with oldjdb (or Java 1 jdb) since
those debuggers do not support the classpath command. Use 1) or 2).")
(defvar gud-jdb-sourcepath nil
"Directory list provided by an (optional) \"-sourcepath\" option to jdb.
This list is prepended to `gud-jdb-classpath' to form the complete
list of directories searched for source files.")
(defvar gud-marker-acc-max-length 4000
"Maximum number of debugger output characters to keep.
This variable limits the size of `gud-marker-acc' which holds
the most recent debugger output history while searching for
source file information.")
(defvar gud-jdb-history nil
"History of argument lists passed to jdb.")
(defvar gud-jdb-directories (list ".")
"*A list of directories that gud jdb should search for source code.
The file names should be absolute, or relative to the current
directory.
The set of .java files residing in the directories listed are
syntactically analyzed to determine the classes they define and the
packages in which these classes belong. In this way gud jdb maps the
package-qualified class names output by the jdb debugger to the source
file from which the class originated. This allows gud mode to keep
the source code display in sync with the debugging session.")
(defvar gud-jdb-source-files nil
"List of the java source files for this debugging session.")
(defvar gud-jdb-class-source-alist nil
"Association list of fully qualified class names and source files.")
(defvar gud-jdb-analysis-buffer nil)
(defvar gud-jdb-classpath-string nil
"Holds temporary classpath values.")
(defun gud-jdb-build-source-files-list (path extn)
"Return a list of java source files (absolute paths).
PATH gives the directories in which to search for files with
extension EXTN. Normally EXTN is given as the regular expression
\"\\.java$\" ."
(apply 'nconc (mapcar (lambda (d)
(when (file-directory-p d)
(directory-files d t extn nil)))
path)))
(defun gud-jdb-skip-whitespace ()
(skip-chars-forward " \n\r\t\014"))
(defun gud-jdb-skip-single-line-comment ()
(end-of-line))
(defun gud-jdb-skip-traditional-or-documentation-comment ()
(forward-char 2)
(catch 'break
(while (not (eobp))
(if (eq (following-char) ?*)
(progn
(forward-char)
(if (not (eobp))
(if (eq (following-char) ?/)
(progn
(forward-char)
(throw 'break nil)))))
(forward-char)))))
(defun gud-jdb-skip-whitespace-and-comments ()
(gud-jdb-skip-whitespace)
(catch 'done
(while t
(cond
((looking-at "//")
(gud-jdb-skip-single-line-comment)
(gud-jdb-skip-whitespace))
((looking-at "/\\*")
(gud-jdb-skip-traditional-or-documentation-comment)
(gud-jdb-skip-whitespace))
(t (throw 'done nil))))))
(defun gud-jdb-skip-id-ish-thing ()
(skip-chars-forward "^ /\n\r\t\014,;{"))
(defun gud-jdb-skip-string-literal ()
(forward-char)
(while (not (cond
((eq (following-char) ?\\)
(forward-char))
((eq (following-char) ?\042))))
(forward-char))
(forward-char))
(defun gud-jdb-skip-character-literal ()
(forward-char)
(while
(progn
(if (eq (following-char) ?\\)
(forward-char 2))
(not (eq (following-char) ?\')))
(forward-char))
(forward-char))
(defun gud-jdb-skip-block ()
(while
(not (eq (following-char) ?{))
(cond
((looking-at "//")
(gud-jdb-skip-single-line-comment))
((looking-at "/\\*")
(gud-jdb-skip-traditional-or-documentation-comment))
((eq (following-char) ?\042)
(gud-jdb-skip-string-literal))
((eq (following-char) ?\')
(gud-jdb-skip-character-literal))
(t (forward-char))))
(forward-char)
(let ((open-level 1))
(while (not (eq open-level 0))
(cond
((looking-at "//")
(gud-jdb-skip-single-line-comment))
((looking-at "/\\*")
(gud-jdb-skip-traditional-or-documentation-comment))
((eq (following-char) ?\042)
(gud-jdb-skip-string-literal))
((eq (following-char) ?\')
(gud-jdb-skip-character-literal))
((eq (following-char) ?{)
(setq open-level (+ open-level 1))
(forward-char))
((eq (following-char) ?})
(setq open-level (- open-level 1))
(forward-char))
(t (forward-char))))))
(defun gud-jdb-analyze-source (buf file)
(let ((l nil))
(set-buffer buf)
(insert-file-contents file nil nil nil t)
(goto-char 0)
(catch 'abort
(let ((p ""))
(while (progn
(gud-jdb-skip-whitespace)
(not (eobp)))
(cond
((eq (following-char) ?\073)
(forward-char))
((looking-at "//")
(gud-jdb-skip-single-line-comment))
((looking-at "/\\*")
(gud-jdb-skip-traditional-or-documentation-comment))
((looking-at "package")
(forward-char 7)
(gud-jdb-skip-whitespace-and-comments)
(let ((s (point)))
(gud-jdb-skip-id-ish-thing)
(setq p (concat (buffer-substring s (point)) "."))
(gud-jdb-skip-whitespace-and-comments)
(if (eq (following-char) ?\073)
(forward-char))))
((looking-at "import")
(forward-char 6)
(gud-jdb-skip-whitespace-and-comments)
(gud-jdb-skip-id-ish-thing)
(gud-jdb-skip-whitespace-and-comments)
(if (eq (following-char) ?\073)
(forward-char)))
((looking-at "public")
(forward-char 6))
((looking-at "abstract")
(forward-char 8))
((looking-at "final")
(forward-char 5))
((looking-at "class")
(forward-char 5)
(gud-jdb-skip-whitespace-and-comments)
(let ((s (point)))
(gud-jdb-skip-id-ish-thing)
(setq
l (nconc l (list (concat p (buffer-substring s (point)))))))
(gud-jdb-skip-block))
((looking-at "interface")
(forward-char 9)
(gud-jdb-skip-block))
(t
(message "Error parsing file %s." file)
(throw 'abort nil))))))
l))
(defun gud-jdb-build-class-source-alist-for-file (file)
(mapcar
(lambda (c)
(cons c file))
(gud-jdb-analyze-source gud-jdb-analysis-buffer file)))
(defun gud-jdb-build-class-source-alist (sources)
(setq gud-jdb-analysis-buffer (get-buffer-create " *gud-jdb-scratch*"))
(prog1
(apply
'nconc
(mapcar
'gud-jdb-build-class-source-alist-for-file
sources))
(kill-buffer gud-jdb-analysis-buffer)
(setq gud-jdb-analysis-buffer nil)))
(defun gud-jdb-massage-args (file args)
(if args
(let (massaged-args user-error)
(while (and args (not user-error))
(cond
((setq user-error (string-match "-classpath$" (car args))))
((setq user-error (string-match "-sourcepath$" (car args))))
((string-match "-classpath\\(.+\\)" (car args))
(setq massaged-args
(append massaged-args
(list "-classpath"
(setq gud-jdb-classpath-string
(match-string 1 (car args)))))))
((string-match "-sourcepath\\(.+\\)" (car args))
(setq massaged-args
(append massaged-args
(list "-sourcepath"
(setq gud-jdb-sourcepath
(match-string 1 (car args)))))))
(t (setq massaged-args (append massaged-args (list (car args))))))
(setq args (cdr args)))
(if user-error
(progn
(kill-buffer (current-buffer))
(error "Error: Omit whitespace between '-classpath or -sourcepath' and its value")))
massaged-args)))
(defun gud-jdb-find-source-file (p)
(cdr (assoc p gud-jdb-class-source-alist)))
(defvar gud-jdb-lowest-stack-level 999)
(defun gud-jdb-find-source-using-classpath (p)
"Find source file corresponding to fully qualified class P.
Convert P from jdb's output, converted to a pathname
relative to a classpath directory."
(save-match-data
(let
( (filename
(concat
(mapconcat 'identity
(split-string
((lambda (x)
(if (string-match "$.*" x)
(replace-match "" t t x) p))
p)
"\\.") "/")
".java"))
(cplist (append gud-jdb-sourcepath gud-jdb-classpath))
found-file)
(while (and cplist
(not (setq found-file
(file-readable-p
(concat (car cplist) "/" filename)))))
(setq cplist (cdr cplist)))
(if found-file (concat (car cplist) "/" filename)))))
(defun gud-jdb-find-source (string)
"Alias for function used to locate source files.
Set to `gud-jdb-find-source-using-classpath' or `gud-jdb-find-source-file'
during jdb initialization depending on the value of
`gud-jdb-use-classpath'."
nil)
(defun gud-jdb-parse-classpath-string (string)
"Parse the classpath list and convert each item to an absolute pathname."
(mapcar (lambda (s) (if (string-match "[/\\]$" s)
(replace-match "" nil nil s) s))
(mapcar 'file-truename
(split-string
string
(concat "[ \t\n\r,\"" path-separator "]+")))))
(defun gud-jdb-marker-filter (string)
(setq gud-marker-acc
(if gud-marker-acc
(concat gud-marker-acc string)
string))
(if (and gud-jdb-use-classpath
(not gud-jdb-classpath-string)
(or (string-match "classpath:[ \t[]+\\([^]]+\\)" gud-marker-acc)
(string-match "-classpath[ \t\"]+\\([^ \"]+\\)" gud-marker-acc)))
(setq gud-jdb-classpath
(gud-jdb-parse-classpath-string
(setq gud-jdb-classpath-string
(match-string 1 gud-marker-acc)))))
(let (file-found)
(while
(string-match
"\\(\\[[0-9]+] \\)*\\([a-zA-Z0-9.$_]+\\)\\.[a-zA-Z0-9$_<>(),]+ \
\\(([a-zA-Z0-9.$_]+:\\|line=\\)\\([0-9.,]+\\)"
gud-marker-acc)
(if (if (match-beginning 1)
(let (n)
(setq n (string-to-number (substring
gud-marker-acc
(1+ (match-beginning 1))
(- (match-end 1) 2))))
(if (< n gud-jdb-lowest-stack-level)
(progn (setq gud-jdb-lowest-stack-level n) t)))
t)
(if (setq file-found
(gud-jdb-find-source (match-string 2 gud-marker-acc)))
(setq gud-last-frame
(cons file-found
(string-to-number
(let
((numstr (match-string 4 gud-marker-acc)))
(if (string-match "[.,]" numstr)
(replace-match "" nil nil numstr)
numstr)))))
(message "Could not find source file.")))
(setq gud-marker-acc (substring gud-marker-acc (match-end 0))))
(if (string-match comint-prompt-regexp gud-marker-acc)
(setq gud-jdb-lowest-stack-level 999)))
(if (> (length gud-marker-acc) gud-marker-acc-max-length)
(setq gud-marker-acc
(substring gud-marker-acc
(- (/ (* gud-marker-acc-max-length 3) 4)))))
string)
(defvar gud-jdb-command-name "jdb" "Command that executes the Java debugger.")
(defun jdb (command-line)
"Run jdb with command line COMMAND-LINE in a buffer.
The buffer is named \"*gud*\" if no initial class is given or
\"*gud-<initial-class-basename>*\" if there is. If the \"-classpath\"
switch is given, omit all whitespace between it and its value.
See `gud-jdb-use-classpath' and `gud-jdb-classpath' documentation for
information on how jdb accesses source files. Alternatively (if
`gud-jdb-use-classpath' is nil), see `gud-jdb-directories' for the
original source file access method.
For general information about commands available to control jdb from
gud, see `gud-mode'."
(interactive
(list (gud-query-cmdline 'jdb)))
(setq gud-jdb-classpath nil)
(setq gud-jdb-sourcepath nil)
(setq gud-jdb-classpath-string (getenv "CLASSPATH"))
(if gud-jdb-classpath-string
(setq gud-jdb-classpath
(gud-jdb-parse-classpath-string gud-jdb-classpath-string)))
(setq gud-jdb-classpath-string nil)
(gud-common-init command-line 'gud-jdb-massage-args
'gud-jdb-marker-filter)
(set (make-local-variable 'gud-minor-mode) 'jdb)
(if gud-jdb-classpath-string
(setq gud-jdb-classpath
(gud-jdb-parse-classpath-string gud-jdb-classpath-string)))
(setq gud-jdb-classpath-string nil) (if gud-jdb-sourcepath
(setq gud-jdb-sourcepath
(gud-jdb-parse-classpath-string gud-jdb-sourcepath)))
(gud-def gud-break "stop at %c:%l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-remove "clear %c:%l" "\C-d" "Remove breakpoint at current line")
(gud-def gud-step "step" "\C-s" "Step one source line with display.")
(gud-def gud-next "next" "\C-n" "Step one line (skip functions).")
(gud-def gud-cont "cont" "\C-r" "Continue with display.")
(gud-def gud-finish "step up" "\C-f" "Continue until current method returns.")
(gud-def gud-up "up\C-Mwhere" "<" "Up one stack frame.")
(gud-def gud-down "down\C-Mwhere" ">" "Up one stack frame.")
(gud-def gud-run "run" nil "Run the program.") (gud-def gud-print "print %e" "\C-p" "Evaluate Java expression at point.")
(setq comint-prompt-regexp "^> \\|^[^ ]+\\[[0-9]+\\] ")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'jdb-mode-hook)
(if gud-jdb-use-classpath
(progn
(if (string-match "-attach" command-line)
(gud-call "classpath"))
(fset 'gud-jdb-find-source
'gud-jdb-find-source-using-classpath))
(setq gud-jdb-class-source-alist
(gud-jdb-build-class-source-alist
(setq gud-jdb-source-files
(gud-jdb-build-source-files-list gud-jdb-directories
"\\.java$"))))
(fset 'gud-jdb-find-source 'gud-jdb-find-source-file)))
(defvar gud-delete-prompt-marker nil)
(put 'gud-mode 'mode-class 'special)
(define-derived-mode gud-mode comint-mode "Debugger"
"Major mode for interacting with an inferior debugger process.
You start it up with one of the commands M-x gdb, M-x sdb, M-x dbx,
M-x perldb, M-x xdb, M-x jdb, or M-x lldb. Each entry point finishes by
executing a hook; `gdb-mode-hook', `sdb-mode-hook', `dbx-mode-hook',
`perldb-mode-hook', `xdb-mode-hook', `jdb-mode-hook', or `lldb-mode-hook'
respectively.
After startup, the following commands are available in both the GUD
interaction buffer and any source buffer GUD visits due to a breakpoint stop
or step operation:
\\[gud-break] sets a breakpoint at the current file and line. In the
GUD buffer, the current file and line are those of the last breakpoint or
step. In a source buffer, they are the buffer's file and current line.
\\[gud-remove] removes breakpoints on the current file and line.
\\[gud-refresh] displays in the source window the last line referred to
in the gud buffer.
\\[gud-step], \\[gud-next], and \\[gud-stepi] do a step-one-line,
step-one-line (not entering function calls), and step-one-instruction
and then update the source window with the current file and position.
\\[gud-cont] continues execution.
\\[gud-print] tries to find the largest C lvalue or function-call expression
around point, and sends it to the debugger for value display.
The above commands are common to all supported debuggers except xdb which
does not support stepping instructions.
Under gdb, sdb and xdb, \\[gud-tbreak] behaves exactly like \\[gud-break],
except that the breakpoint is temporary; that is, it is removed when
execution stops on it.
Under gdb, dbx, xdb, and lldb, \\[gud-up] pops up through an enclosing stack
frame. \\[gud-down] drops back down through one.
If you are using gdb or xdb, \\[gud-finish] runs execution to the return from
the current function and stops.
All the keystrokes above are accessible in the GUD buffer
with the prefix C-c, and in all buffers through the prefix C-x C-a.
All pre-defined functions for which the concept make sense repeat
themselves the appropriate number of times if you give a prefix
argument.
You may use the `gud-def' macro in the initialization hook to define other
commands.
Other commands for interacting with the debugger process are inherited from
comint mode, which see."
(setq mode-line-process '(":%s"))
(define-key (current-local-map) "\C-c\C-l" 'gud-refresh)
(set (make-local-variable 'gud-last-frame) nil)
(set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
(make-local-variable 'comint-prompt-regexp)
(set (make-local-variable 'comint-input-ignoredups) t)
(make-local-variable 'paragraph-start)
(set (make-local-variable 'gud-delete-prompt-marker) (make-marker))
(add-hook 'kill-buffer-hook 'gud-kill-buffer-hook nil t))
(defcustom gud-chdir-before-run t
"Non-nil if GUD should `cd' to the debugged executable."
:group 'gud
:type 'boolean)
(defvar gud-target-name "--unknown--"
"The apparent name of the program being debugged in a gud buffer.")
(defun gud-common-init (command-line massage-args marker-filter
&optional find-file)
(let* ((words (split-string-and-unquote command-line))
(program (car words))
(dir default-directory)
(file-word (let ((w (cdr words)))
(while (and w (= ?- (aref (car w) 0)))
(setq w (cdr w)))
(and w
(prog1 (car w)
(setcar w t)))))
(file-subst
(and file-word (substitute-in-file-name file-word)))
(args (cdr words))
(file (and file-word
(if (file-name-directory file-subst)
(expand-file-name file-subst)
file-subst)))
(filepart (and file-word (concat "-" (file-name-nondirectory file))))
(existing-buffer (get-buffer (concat "*gud" filepart "*"))))
(pop-to-buffer (concat "*gud" filepart "*"))
(when (and existing-buffer (get-buffer-process existing-buffer))
(error "This program is already being debugged"))
(setq default-directory dir)
(and file-word
gud-chdir-before-run
(file-name-directory file)
(setq default-directory (file-name-directory file)))
(or (bolp) (newline))
(insert "Current directory is " default-directory "\n")
(let ((w args))
(while (and w (not (eq (car w) t)))
(setq w (cdr w)))
(if w
(setcar w file)))
(apply 'make-comint (concat "gud" filepart) program nil
(if massage-args (funcall massage-args file args) args))
(gud-mode)
(set (make-local-variable 'gud-target-name)
(and file-word (file-name-nondirectory file))))
(set (make-local-variable 'gud-marker-filter) marker-filter)
(if find-file (set (make-local-variable 'gud-find-file) find-file))
(setq gud-last-last-frame nil)
(set-process-filter (get-buffer-process (current-buffer)) 'gud-filter)
(set-process-sentinel (get-buffer-process (current-buffer)) 'gud-sentinel)
(gud-set-buffer))
(defun gud-set-buffer ()
(when (eq major-mode 'gud-mode)
(setq gud-comint-buffer (current-buffer))))
(defvar gud-filter-defer-flag nil
"Non-nil means don't process anything from the debugger right now.
It is saved for when this flag is not set.")
(defun gud-filter (proc string)
(let (output process-window)
(if (buffer-name (process-buffer proc))
(if gud-filter-defer-flag
(setq gud-filter-pending-text
(concat (or gud-filter-pending-text "") string))
(let ((gud-filter-defer-flag t))
(if gud-filter-pending-text
(setq string (concat gud-filter-pending-text string)
gud-filter-pending-text nil))
(with-current-buffer (process-buffer proc)
(save-restriction
(widen)
(if (marker-buffer gud-delete-prompt-marker)
(let ((inhibit-read-only t))
(delete-region (process-mark proc)
gud-delete-prompt-marker)
(comint-update-fence)
(set-marker gud-delete-prompt-marker nil)))
(setq output (gud-marker-filter string))
(setq process-window
(and gud-last-frame
(>= (point) (process-mark proc))
(get-buffer-window (current-buffer)))))
(comint-output-filter proc output))
(if process-window
(with-selected-window process-window
(gud-display-frame))
(with-current-buffer (process-buffer proc)
(gud-display-frame))))
(if gud-filter-pending-text
(gud-filter proc ""))))))
(defvar gud-minor-mode-type nil)
(defvar gud-overlay-arrow-position nil)
(add-to-list 'overlay-arrow-variable-list 'gud-overlay-arrow-position)
(defun gud-sentinel (proc msg)
(cond ((null (buffer-name (process-buffer proc)))
(setq gud-overlay-arrow-position nil)
(set-process-buffer proc nil)
(if (and (boundp 'speedbar-frame)
(string-equal speedbar-initial-expansion-list-name "GUD"))
(speedbar-change-initial-expansion-list
speedbar-previously-used-expansion-list-name))
(if (memq gud-minor-mode-type '(gdbmi gdba))
(gdb-reset)
(gud-reset)))
((memq (process-status proc) '(signal exit))
(setq gud-overlay-arrow-position nil)
(if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'(gdba gdbmi))
(gdb-reset)
(gud-reset))
(let* ((obuf (current-buffer)))
(unwind-protect
(progn
(set-buffer (process-buffer proc))
(setq mode-line-process
(concat ":"
(symbol-name (process-status proc))))
(force-mode-line-update)
(if (eobp)
(insert ?\n mode-name " " msg)
(save-excursion
(goto-char (point-max))
(insert ?\n mode-name " " msg)))
(delete-process proc))
(set-buffer obuf))))))
(defun gud-kill-buffer-hook ()
(setq gud-minor-mode-type gud-minor-mode)
(condition-case nil
(kill-process (get-buffer-process (current-buffer)))
(error nil)))
(defun gud-reset ()
(dolist (buffer (buffer-list))
(unless (eq buffer gud-comint-buffer)
(with-current-buffer buffer
(when gud-minor-mode
(setq gud-minor-mode nil)
(kill-local-variable 'tool-bar-map))))))
(defun gud-display-frame ()
"Find and obey the last filename-and-line marker from the debugger.
Obeying it means displaying in another window the specified file and line."
(interactive)
(when gud-last-frame
(gud-set-buffer)
(gud-display-line (car gud-last-frame) (cdr gud-last-frame))
(setq gud-last-last-frame gud-last-frame
gud-last-frame nil)))
(defun gud-display-line (true-file line)
(let* ((last-nonmenu-event t) (buffer
(with-current-buffer gud-comint-buffer
(gud-find-file true-file)))
(window (and buffer
(or (get-buffer-window buffer)
(if (memq gud-minor-mode '(gdbmi gdba))
(or (if (get-buffer-window buffer 0)
(display-buffer buffer nil 0))
(unless (gdb-display-source-buffer buffer)
(gdb-display-buffer buffer nil))))
(display-buffer buffer))))
(pos))
(if buffer
(progn
(with-current-buffer buffer
(unless (or (verify-visited-file-modtime buffer) gud-keep-buffer)
(if (yes-or-no-p
(format "File %s changed on disk. Reread from disk? "
(buffer-name)))
(revert-buffer t t)
(setq gud-keep-buffer t)))
(save-restriction
(widen)
(goto-line line)
(setq pos (point))
(or gud-overlay-arrow-position
(setq gud-overlay-arrow-position (make-marker)))
(set-marker gud-overlay-arrow-position (point) (current-buffer))
(when (featurep 'hl-line)
(cond
(global-hl-line-mode
(global-hl-line-highlight))
((and hl-line-mode hl-line-sticky-flag)
(hl-line-highlight)))))
(cond ((or (< pos (point-min)) (> pos (point-max)))
(widen)
(goto-char pos))))
(when window
(set-window-point window gud-overlay-arrow-position)
(if (memq gud-minor-mode '(gdbmi gdba))
(setq gdb-source-window window)))))))
(defun gud-format-command (str arg)
(let ((insource (not (eq (current-buffer) gud-comint-buffer)))
(frame (or gud-last-frame gud-last-last-frame))
result)
(while (and str
(let ((case-fold-search nil))
(string-match "\\([^%]*\\)%\\([abdefFlpc]\\)" str)))
(let ((key (string-to-char (match-string 2 str)))
subst)
(cond
((eq key ?f)
(setq subst (file-name-nondirectory (if insource
(buffer-file-name)
(car frame)))))
((eq key ?F)
(setq subst (file-name-sans-extension
(file-name-nondirectory (if insource
(buffer-file-name)
(car frame))))))
((eq key ?d)
(setq subst (file-name-directory (if insource
(buffer-file-name)
(car frame)))))
((eq key ?l)
(setq subst (int-to-string
(if insource
(save-restriction
(widen)
(+ (count-lines (point-min) (point))
(if (bolp) 1 0)))
(cdr frame)))))
((eq key ?e)
(setq subst (gud-find-expr)))
((eq key ?a)
(setq subst (gud-read-address)))
((eq key ?b)
(setq subst gud-breakpoint-id))
((eq key ?c)
(setq subst
(gud-find-class
(if insource
(buffer-file-name)
(car frame))
(if insource
(save-restriction
(widen)
(+ (count-lines (point-min) (point))
(if (bolp) 1 0)))
(cdr frame)))))
((eq key ?p)
(setq subst (if arg (int-to-string arg)))))
(setq result (concat result (match-string 1 str) subst)))
(setq str (substring str (match-end 2))))
(concat result str)))
(defun gud-read-address ()
"Return a string containing the core-address found in the buffer at point."
(save-match-data
(save-excursion
(let ((pt (point)) found begin)
(setq found (if (search-backward "0x" (- pt 7) t) (point)))
(cond
(found (forward-char 2)
(buffer-substring found
(progn (re-search-forward "[^0-9a-f]")
(forward-char -1)
(point))))
(t (setq begin (progn (re-search-backward "[^0-9]")
(forward-char 1)
(point)))
(forward-char 1)
(re-search-forward "[^0-9]")
(forward-char -1)
(buffer-substring begin (point))))))))
(defun gud-call (fmt &optional arg)
(let ((msg (gud-format-command fmt arg)))
(message "Command: %s" msg)
(sit-for 0)
(gud-basic-call msg)))
(defun gud-basic-call (command)
"Invoke the debugger COMMAND displaying source in other window."
(interactive)
(gud-set-buffer)
(let ((proc (get-buffer-process gud-comint-buffer)))
(or proc (error "Current buffer has no process"))
(save-excursion
(set-buffer gud-comint-buffer)
(save-restriction
(widen)
(if (marker-position gud-delete-prompt-marker)
(goto-char gud-delete-prompt-marker)
(goto-char (process-mark proc))
(forward-line 0))
(if (looking-at comint-prompt-regexp)
(set-marker gud-delete-prompt-marker (point)))
(if (memq gud-minor-mode '(gdbmi gdba))
(apply comint-input-sender (list proc command))
(process-send-string proc (concat command "\n")))))))
(defun gud-refresh (&optional arg)
"Fix up a possibly garbled display, and redraw the arrow."
(interactive "P")
(or gud-last-frame (setq gud-last-frame gud-last-last-frame))
(gud-display-frame)
(recenter arg))
(defvar gud-find-expr-function 'gud-find-c-expr)
(defun gud-find-expr (&rest args)
(let ((expr (if (and transient-mark-mode mark-active)
(buffer-substring (region-beginning) (region-end))
(apply gud-find-expr-function args))))
(save-match-data
(if (string-match "\n" expr)
(error "Expression must not include a newline"))
(with-current-buffer gud-comint-buffer
(save-excursion
(goto-char (process-mark (get-buffer-process gud-comint-buffer)))
(forward-line 0)
(when (looking-at comint-prompt-regexp)
(set-marker gud-delete-prompt-marker (point))
(set-marker-insertion-type gud-delete-prompt-marker t))
(unless (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'jdb)
(insert (concat expr " = "))))))
expr))
(defun gud-find-c-expr ()
"Returns the expr that surrounds point."
(interactive)
(save-excursion
(let ((p (point))
(expr (gud-innermost-expr))
(test-expr (gud-prev-expr)))
(while (and test-expr (gud-expr-compound test-expr expr))
(let ((prev-expr expr))
(setq expr (cons (car test-expr) (cdr expr)))
(goto-char (car expr))
(setq test-expr (gud-prev-expr))
(if (member (buffer-substring (car test-expr) (cdr test-expr))
'("if" "while" "for"))
(setq test-expr nil
expr prev-expr))))
(goto-char p)
(setq test-expr (gud-next-expr))
(while (gud-expr-compound expr test-expr)
(setq expr (cons (car expr) (cdr test-expr)))
(setq test-expr (gud-next-expr)))
(buffer-substring (car expr) (cdr expr)))))
(defun gud-innermost-expr ()
"Returns the smallest expr that point is in; move point to beginning of it.
The expr is represented as a cons cell, where the car specifies the point in
the current buffer that marks the beginning of the expr and the cdr specifies
the character after the end of the expr."
(let ((p (point)) begin end)
(gud-backward-sexp)
(setq begin (point))
(gud-forward-sexp)
(setq end (point))
(if (>= p end)
(progn
(setq begin p)
(goto-char p)
(gud-forward-sexp)
(setq end (point)))
)
(goto-char begin)
(cons begin end)))
(defun gud-backward-sexp ()
"Version of `backward-sexp' that catches errors."
(condition-case nil
(backward-sexp)
(error t)))
(defun gud-forward-sexp ()
"Version of `forward-sexp' that catches errors."
(condition-case nil
(forward-sexp)
(error t)))
(defun gud-prev-expr ()
"Returns the previous expr, point is set to beginning of that expr.
The expr is represented as a cons cell, where the car specifies the point in
the current buffer that marks the beginning of the expr and the cdr specifies
the character after the end of the expr"
(let ((begin) (end))
(gud-backward-sexp)
(setq begin (point))
(gud-forward-sexp)
(setq end (point))
(goto-char begin)
(cons begin end)))
(defun gud-next-expr ()
"Returns the following expr, point is set to beginning of that expr.
The expr is represented as a cons cell, where the car specifies the point in
the current buffer that marks the beginning of the expr and the cdr specifies
the character after the end of the expr."
(let ((begin) (end))
(gud-forward-sexp)
(gud-forward-sexp)
(setq end (point))
(gud-backward-sexp)
(setq begin (point))
(cons begin end)))
(defun gud-expr-compound-sep (span-start span-end)
"Scan from SPAN-START to SPAN-END for punctuation characters.
If `->' is found, return `?.'. If `.' is found, return `?.'.
If any other punctuation is found, return `??'.
If no punctuation is found, return `? '."
(let ((result ?\s)
(syntax))
(while (< span-start span-end)
(setq syntax (char-syntax (char-after span-start)))
(cond
((= syntax ?\s) t)
((= syntax ?.) (setq syntax (char-after span-start))
(cond
((= syntax ?.) (setq result ?.))
((and (= syntax ?-) (= (char-after (+ span-start 1)) ?>))
(setq result ?.)
(setq span-start (+ span-start 1)))
(t (setq span-start span-end)
(setq result ??)))))
(setq span-start (+ span-start 1)))
result))
(defun gud-expr-compound (first second)
"Non-nil if concatenating FIRST and SECOND makes a single C expression.
The two exprs are represented as a cons cells, where the car
specifies the point in the current buffer that marks the beginning of the
expr and the cdr specifies the character after the end of the expr.
Link exprs of the form:
Expr -> Expr
Expr . Expr
Expr (Expr)
Expr [Expr]
(Expr) Expr
[Expr] Expr"
(let ((span-start (cdr first))
(span-end (car second))
(syntax))
(setq syntax (gud-expr-compound-sep span-start span-end))
(cond
((= (car first) (car second)) nil)
((= (cdr first) (cdr second)) nil)
((= syntax ?.) t)
((= syntax ?\s)
(setq span-start (char-after (- span-start 1)))
(setq span-end (char-after span-end))
(cond
((= span-start ?)) t)
((= span-start ?]) t)
((= span-end ?() t)
((= span-end ?[) t)
(t nil)))
(t nil))))
(defun gud-find-class (f line)
"Find fully qualified class in file F at line LINE.
This function uses the `gud-jdb-classpath' (and optional
`gud-jdb-sourcepath') list(s) to derive a file
pathname relative to its classpath directory. The values in
`gud-jdb-classpath' are assumed to have been converted to absolute
pathname standards using file-truename.
If F is visited by a buffer and its mode is CC-mode(Java),
syntactic information of LINE is used to find the enclosing (nested)
class string which is appended to the top level
class of the file (using s to separate nested class ids)."
(if (and gud-jdb-use-classpath (or gud-jdb-classpath gud-jdb-sourcepath))
(save-match-data
(let ((cplist (append gud-jdb-sourcepath gud-jdb-classpath))
(fbuffer (get-file-buffer f))
syntax-symbol syntax-point class-found)
(setq f (file-name-sans-extension (file-truename f)))
(fset 'syntax-symbol (lambda (x) (c-langelem-sym (car x))))
(fset 'syntax-point (lambda (x) (c-langelem-pos (car x))))
(while (and cplist (not class-found))
(if (string-match (car cplist) f)
(setq class-found
(mapconcat 'identity
(split-string
(substring f (+ (match-end 0) 1))
"/") ".")))
(setq cplist (cdr cplist)))
(if (and fbuffer (equal (symbol-file 'java-mode) "cc-mode"))
(save-excursion
(set-buffer fbuffer)
(let ((nclass) (syntax))
(while (not (eq 'topmost-intro
(syntax-symbol (c-guess-basic-syntax))))
(setq syntax (c-guess-basic-syntax))
(while
(and (not (eq 'inclass (syntax-symbol syntax)))
(cdr syntax))
(setq syntax (cdr syntax)))
(if (eq 'inclass (syntax-symbol syntax))
(progn
(goto-char (syntax-point syntax))
(looking-at
"[A-Za-z0-9 \t\n]*?class[ \t\n]+\\([^ \t\n]+\\)")
(setq nclass
(append (list (match-string-no-properties 1))
nclass)))
(setq syntax (c-guess-basic-syntax))
(while (and (not (syntax-point syntax)) (cdr syntax))
(setq syntax (cdr syntax)))
(goto-char (syntax-point syntax))
))
(string-match (concat (car nclass) "$") class-found)
(setq class-found
(replace-match (mapconcat 'identity nclass "$")
t t class-found)))))
(if (not class-found)
(message "gud-find-class: class for file %s not found!" f))
class-found))
(let ((class-found (rassoc f gud-jdb-class-source-alist)))
(if class-found
(car class-found)
(message "gud-find-class: class for file %s not found in gud-jdb-class-source-alist!" f)
nil))))
(defvar gdb-script-mode-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?' "\"" st)
(modify-syntax-entry ?# "<" st)
(modify-syntax-entry ?\n ">" st)
st))
(defvar gdb-script-font-lock-keywords
'(("^define\\s-+\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-function-name-face))
("\\$\\(\\w+\\)" (1 font-lock-variable-name-face))
("^\\s-*\\(\\w\\(\\w\\|\\s_\\)*\\)" (1 font-lock-keyword-face))))
(defvar gdb-script-font-lock-syntactic-keywords
'(("^document\\s-.*\\(\n\\)" (1 "< b"))
("^end\\>"
(0 (unless (eq (match-beginning 0) (point-min))
(put-text-property (1- (match-beginning 0)) (match-beginning 0)
'syntax-table (eval-when-compile
(string-to-syntax "> b")))
(put-text-property (1- (match-beginning 0)) (match-end 0)
'font-lock-multiline t)
nil)))))
(defun gdb-script-font-lock-syntactic-face (state)
(cond
((nth 3 state) font-lock-string-face)
((nth 7 state) font-lock-doc-face)
(t font-lock-comment-face)))
(defvar gdb-script-basic-indent 2)
(defun gdb-script-skip-to-head ()
"We're just in front of an `end' and we need to go to its head."
(while (and (re-search-backward "^\\s-*\\(\\(end\\)\\|define\\|document\\|if\\|while\\|commands\\)\\>" nil 'move)
(match-end 2))
(gdb-script-skip-to-head)))
(defun gdb-script-calculate-indentation ()
(cond
((looking-at "end\\>")
(gdb-script-skip-to-head)
(current-indentation))
((looking-at "else\\>")
(while (and (re-search-backward "^\\s-*\\(if\\|\\(end\\)\\)\\>" nil 'move)
(match-end 2))
(gdb-script-skip-to-head))
(current-indentation))
(t
(forward-comment (- (point-max)))
(forward-line 0)
(skip-chars-forward " \t")
(+ (current-indentation)
(if (looking-at "\\(if\\|while\\|define\\|else\\|commands\\)\\>")
gdb-script-basic-indent 0)))))
(defun gdb-script-indent-line ()
"Indent current line of GDB script."
(interactive)
(if (and (eq (get-text-property (point) 'face) font-lock-doc-face)
(save-excursion
(forward-line 0)
(skip-chars-forward " \t")
(not (looking-at "end\\>"))))
'noindent
(let* ((savep (point))
(indent (condition-case nil
(save-excursion
(forward-line 0)
(skip-chars-forward " \t")
(if (>= (point) savep) (setq savep nil))
(max (gdb-script-calculate-indentation) 0))
(error 0))))
(if savep
(save-excursion (indent-line-to indent))
(indent-line-to indent)))))
(defun gdb-script-beginning-of-defun ()
"`beginning-of-defun' function for Gdb script mode.
Treats actions as defuns."
(unless (<= (current-column) (current-indentation))
(end-of-line))
(if (re-search-backward "^define \\|^document " nil t)
(beginning-of-line)
(goto-char (point-min)))
t)
(defun gdb-script-end-of-defun ()
"`end-of-defun' function for Gdb script mode.
Treats actions as defuns."
(end-of-line)
(if (re-search-forward "^end" nil t)
(beginning-of-line)
(goto-char (point-max)))
t)
(add-to-list 'auto-mode-alist '("/\\.[a-z0-9-]*gdbinit" . gdb-script-mode))
(define-derived-mode gdb-script-mode nil "GDB-Script"
"Major mode for editing GDB scripts."
(set (make-local-variable 'comment-start) "#")
(set (make-local-variable 'comment-start-skip) "#+\\s-*")
(set (make-local-variable 'outline-regexp) "[ \t]")
(set (make-local-variable 'imenu-generic-expression)
'((nil "^define[ \t]+\\(\\w+\\)" 1)))
(set (make-local-variable 'indent-line-function) 'gdb-script-indent-line)
(set (make-local-variable 'beginning-of-defun-function)
#'gdb-script-beginning-of-defun)
(set (make-local-variable 'end-of-defun-function)
#'gdb-script-end-of-defun)
(set (make-local-variable 'font-lock-defaults)
'(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil
(font-lock-syntactic-keywords
. gdb-script-font-lock-syntactic-keywords)
(font-lock-syntactic-face-function
. gdb-script-font-lock-syntactic-face))))
(define-minor-mode gud-tooltip-mode
"Toggle the display of GUD tooltips."
:global t
:group 'gud
:group 'tooltip
(require 'tooltip)
(if gud-tooltip-mode
(progn
(add-hook 'change-major-mode-hook 'gud-tooltip-change-major-mode)
(add-hook 'pre-command-hook 'tooltip-hide)
(add-hook 'tooltip-hook 'gud-tooltip-tips)
(define-key global-map [mouse-movement] 'gud-tooltip-mouse-motion))
(unless tooltip-mode (remove-hook 'pre-command-hook 'tooltip-hide)
(remove-hook 'change-major-mode-hook 'gud-tooltip-change-major-mode)
(remove-hook 'tooltip-hook 'gud-tooltip-tips)
(define-key global-map [mouse-movement] 'ignore)))
(gud-tooltip-activate-mouse-motions-if-enabled)
(if (and gud-comint-buffer
(buffer-name gud-comint-buffer) (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'(gdbmi gdba)))
(if gud-tooltip-mode
(progn
(dolist (buffer (buffer-list))
(unless (eq buffer gud-comint-buffer)
(with-current-buffer buffer
(when (and (memq gud-minor-mode '(gdbmi gdba))
(not (string-match "\\`\\*.+\\*\\'"
(buffer-name))))
(make-local-variable 'gdb-define-alist)
(gdb-create-define-alist)
(add-hook 'after-save-hook
'gdb-create-define-alist nil t))))))
(kill-local-variable 'gdb-define-alist)
(remove-hook 'after-save-hook 'gdb-create-define-alist t))))
(defcustom gud-tooltip-modes '(gud-mode c-mode c++-mode fortran-mode
python-mode)
"List of modes for which to enable GUD tooltips."
:type 'sexp
:group 'gud
:group 'tooltip)
(defcustom gud-tooltip-display
'((eq (tooltip-event-buffer gud-tooltip-event)
(marker-buffer gud-overlay-arrow-position)))
"List of forms determining where GUD tooltips are displayed.
Forms in the list are combined with AND. The default is to display
only tooltips in the buffer containing the overlay arrow."
:type 'sexp
:group 'gud
:group 'tooltip)
(defcustom gud-tooltip-echo-area nil
"Use the echo area instead of frames for GUD tooltips."
:type 'boolean
:group 'gud
:group 'tooltip)
(define-obsolete-variable-alias 'tooltip-gud-modes
'gud-tooltip-modes "22.1")
(define-obsolete-variable-alias 'tooltip-gud-display
'gud-tooltip-display "22.1")
(defun gud-tooltip-change-major-mode ()
"Function added to `change-major-mode-hook' when tooltip mode is on."
(add-hook 'post-command-hook 'gud-tooltip-activate-mouse-motions-if-enabled))
(defun gud-tooltip-activate-mouse-motions-if-enabled ()
"Reconsider for all buffers whether mouse motion events are desired."
(remove-hook 'post-command-hook
'gud-tooltip-activate-mouse-motions-if-enabled)
(dolist (buffer (buffer-list))
(save-excursion
(set-buffer buffer)
(if (and gud-tooltip-mode
(memq major-mode gud-tooltip-modes))
(gud-tooltip-activate-mouse-motions t)
(gud-tooltip-activate-mouse-motions nil)))))
(defvar gud-tooltip-mouse-motions-active nil
"Locally t in a buffer if tooltip processing of mouse motion is enabled.")
(defun gud-tooltip-activate-mouse-motions (activatep)
"Activate/deactivate mouse motion events for the current buffer.
ACTIVATEP non-nil means activate mouse motion events."
(if activatep
(progn
(make-local-variable 'gud-tooltip-mouse-motions-active)
(setq gud-tooltip-mouse-motions-active t)
(make-local-variable 'track-mouse)
(setq track-mouse t))
(when gud-tooltip-mouse-motions-active
(kill-local-variable 'gud-tooltip-mouse-motions-active)
(kill-local-variable 'track-mouse))))
(defun gud-tooltip-mouse-motion (event)
"Command handler for mouse movement events in `global-map'."
(interactive "e")
(tooltip-hide)
(when (car (mouse-pixel-position))
(setq tooltip-last-mouse-motion-event (copy-sequence event))
(tooltip-start-delayed-tip)))
(defvar gud-tooltip-original-filter nil
"Process filter to restore after GUD output has been received.")
(defvar gud-tooltip-dereference nil
"Non-nil means print expressions with a `*' in front of them.
For C this would dereference a pointer expression.")
(defvar gud-tooltip-event nil
"The mouse movement event that led to a tooltip display.
This event can be examined by forms in `gud-tooltip-display'.")
(defun gud-tooltip-dereference (&optional arg)
"Toggle whether tooltips should show `* expr' or `expr'.
With arg, dereference expr if ARG is positive, otherwise do not derereference."
(interactive "P")
(setq gud-tooltip-dereference
(if (null arg)
(not gud-tooltip-dereference)
(> (prefix-numeric-value arg) 0)))
(message "Dereferencing is now %s."
(if gud-tooltip-dereference "on" "off")))
(define-obsolete-function-alias 'tooltip-gud-toggle-dereference
'gud-tooltip-dereference "22.1")
(defun gud-tooltip-process-output (process output)
"Process debugger output and show it in a tooltip window."
(set-process-filter process gud-tooltip-original-filter)
(tooltip-show (tooltip-strip-prompt process output)
(or gud-tooltip-echo-area tooltip-use-echo-area)))
(defun gud-tooltip-print-command (expr)
"Return a suitable command to print the expression EXPR."
(case gud-minor-mode
(lldb (concat "expression -o -- " expr))
(gdba (concat "server print " expr))
((dbx gdbmi) (concat "print " expr))
((xdb pdb) (concat "p " expr))
(sdb (concat expr "/"))))
(defun gud-tooltip-tips (event)
"Show tip for identifier or selection under the mouse.
The mouse must either point at an identifier or inside a selected
region for the tip window to be shown. If `gud-tooltip-dereference' is t,
add a `*' in front of the printed expression. In the case of a C program
controlled by GDB, show the associated #define directives when program is
not executing.
This function must return nil if it doesn't handle EVENT."
(let (process)
(when (and (eventp event)
gud-tooltip-mode
gud-comint-buffer
(buffer-name gud-comint-buffer) (setq process (get-buffer-process gud-comint-buffer))
(posn-point (event-end event))
(or (and (eq gud-minor-mode 'gdba) (not gdb-active-process))
(progn (setq gud-tooltip-event event)
(eval (cons 'and gud-tooltip-display)))))
(let ((expr (tooltip-expr-to-print event)))
(when expr
(if (and (eq gud-minor-mode 'gdba)
(not gdb-active-process))
(progn
(with-current-buffer (tooltip-event-buffer event)
(let ((define-elt (assoc expr gdb-define-alist)))
(unless (null define-elt)
(tooltip-show
(cdr define-elt)
(or gud-tooltip-echo-area tooltip-use-echo-area))
expr))))
(when gud-tooltip-dereference
(setq expr (concat "*" expr)))
(let ((cmd (gud-tooltip-print-command expr)))
(when (and gud-tooltip-mode (eq gud-minor-mode 'gdb))
(gud-tooltip-mode -1)
(message-box "Using GUD tooltips in this mode is unsafe\n\
so they have been disabled."))
(unless (null cmd) (if (memq gud-minor-mode '(gdba gdbmi))
(if gdb-macro-info
(gdb-enqueue-input
(list (concat
gdb-server-prefix "macro expand " expr "\n")
`(lambda () (gdb-tooltip-print-1 ,expr))))
(gdb-enqueue-input
(list (concat cmd "\n")
`(lambda () (gdb-tooltip-print ,expr)))))
(setq gud-tooltip-original-filter (process-filter process))
(set-process-filter process 'gud-tooltip-process-output)
(gud-basic-call cmd))
expr))))))))
(provide 'gud)