X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/bfc50337514e1ed0fa23a1a3bde7e1e1dc1b5bab..bd9b3169be279adaeac792e1314c0b5049b94d73:/lisp/progmodes/gud.el diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index b06d95e6b9..c57c88d3ec 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -49,7 +49,6 @@ (defvar gdb-macro-info) (defvar gdb-server-prefix) (defvar gdb-show-changed-values) -(defvar gdb-force-update) (defvar gdb-var-list) (defvar gdb-speedbar-auto-raise) (defvar tool-bar-map) @@ -83,6 +82,8 @@ Supported debuggers include gdb, sdb, dbx, xdb, perldb, pdb (Python), jdb, and b (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) @@ -100,8 +101,8 @@ If SOFT is non-nil, returns nil if the symbol doesn't already exist." (if (boundp sym) (symbol-value sym)))) (defvar gud-running nil - "Non-nil if debuggee is running. -Used to grey out relevant togolbar icons.") + "Non-nil if debugged program is running. +Used to grey out relevant toolbar icons.") ;; Use existing Info buffer, if possible. (defun gud-goto-info () @@ -129,10 +130,10 @@ Used to grey out relevant togolbar icons.") (defun gud-stop-subjob () (interactive) - (if (string-equal - (buffer-local-value 'gud-target-name gud-comint-buffer) "emacs") - (comint-stop-subjob) - (comint-interrupt-subjob))) + (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) @@ -140,13 +141,15 @@ Used to grey out relevant togolbar icons.") :enable (and (not emacs-basic-display) (display-graphic-p) (fboundp 'x-show-tip)) + :visible (memq gud-minor-mode + '(gdbmi gdba dbx sdb xdb pdb)) :button (:toggle . gud-tooltip-mode)) ([refresh] "Refresh" . gud-refresh) ([run] menu-item "Run" gud-run - :enable (and (not gud-running) - (memq gud-minor-mode '(gdbmi gdb dbx jdb))) - :visible (not (eq gud-minor-mode 'gdba))) - ([go] menu-item "Run/Continue" gud-go + :enable (not gud-running) + :visible (and (memq gud-minor-mode '(gdbmi gdb dbx jdb)) + (not (eq gud-minor-mode 'gdba)))) + ([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 @@ -154,27 +157,28 @@ Used to grey out relevant togolbar icons.") (and gud-running (eq gud-minor-mode 'gdba)))) ([until] menu-item "Continue to selection" gud-until - :enable (and (not gud-running) - (memq gud-minor-mode '(gdbmi gdba gdb perldb))) - :visible (gud-tool-bar-item-visible-no-fringe)) + :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 (memq gud-minor-mode + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdba gdb sdb xdb bashdb))) ([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 (and (not gud-running) - (memq gud-minor-mode - '(gdbmi gdba gdb dbx xdb jdb pdb bashdb)))) + :enable (not gud-running) + :visible (memq gud-minor-mode + '(gdbmi gdba gdb dbx xdb jdb pdb bashdb))) ([down] menu-item "Down Stack" gud-down - :enable (and (not gud-running) - (memq gud-minor-mode - '(gdbmi gdba gdb dbx xdb jdb pdb bashdb)))) - ([pp] menu-item "Print the emacs s-expression" gud-pp + :enable (not gud-running) + :visible (memq gud-minor-mode + '(gdbmi gdba gdb dbx xdb jdb pdb bashdb))) + ([pp] menu-item "Print S-expression" gud-pp :enable (and (not gud-running) gdb-active-process) :visible (and (string-equal @@ -182,23 +186,23 @@ Used to grey out relevant togolbar icons.") 'gud-target-name gud-comint-buffer) "emacs") (eq gud-minor-mode 'gdba))) ([print*] menu-item "Print Dereference" gud-pstar - :enable (and (not gud-running) - (memq gud-minor-mode '(gdbmi gdba gdb)))) + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdba gdb))) ([print] menu-item "Print Expression" gud-print :enable (not gud-running)) ([watch] menu-item "Watch Expression" gud-watch - :enable (and (not gud-running) - (memq gud-minor-mode '(gdbmi gdba)))) + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdba))) ([finish] menu-item "Finish Function" gud-finish - :enable (and (not gud-running) - (memq gud-minor-mode - '(gdbmi gdba gdb xdb jdb pdb bashdb)))) + :enable (not gud-running) + :visible (memq gud-minor-mode + '(gdbmi gdba gdb xdb jdb pdb bashdb))) ([stepi] menu-item "Step Instruction" gud-stepi - :enable (and (not gud-running) - (memq gud-minor-mode '(gdbmi gdba gdb dbx)))) + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) ([nexti] menu-item "Next Instruction" gud-nexti - :enable (and (not gud-running) - (memq gud-minor-mode '(gdbmi gdba gdb dbx)))) + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) ([step] menu-item "Step Line" gud-step :enable (not gud-running)) ([next] menu-item "Next Line" gud-next @@ -234,9 +238,6 @@ Used to grey out relevant togolbar icons.") (gud-run . "gud/run") (gud-go . "gud/go") (gud-stop-subjob . "gud/stop") - ;; gud-s, gud-si etc. instead of gud-step, - ;; gud-stepi, to avoid file-name clashes on DOS - ;; 8+3 filesystems. (gud-cont . "gud/cont") (gud-until . "gud/until") (gud-next . "gud/next") @@ -304,13 +305,15 @@ Uses `gud--directories' to find the source files." 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 - %p prefix argument to the command (if any) as a number + %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. + %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 @@ -377,8 +380,9 @@ t means that there is no stack, and we are in display-file 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 4 var) - (speedbar-message "%s" (nth 3 var))))) + (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." @@ -440,38 +444,55 @@ required by the caller." (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)) - (when (or gdb-force-update - (not (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (looking-at "Watch Expressions:"))))) - (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)) - (expr (car var)) (varnum (nth 1 var)) - (type (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))) + (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 (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 ?? nil nil - (concat expr "\t" value) + '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 @@ -482,33 +503,15 @@ required by the caller." (t t))) t) depth) - (if (eq status 'out-of-scope) (setq parent 'shadow)) - (if (and (cadr var-list) - (string-match (concat varnum "\\.") - (cadr (cadr 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 status) - nil 'gdb-edit-value) - nil - (if (and (or parent (eq status 'out-of-scope)) - gdb-show-changed-values) 'shadow 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)))) - (setq gdb-force-update nil))) + (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:")) @@ -539,6 +542,7 @@ required by the caller." (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)))) @@ -682,6 +686,7 @@ To run GDB in text command mode, set `gud-gdb-command-name' to (if (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))) (error "Multiple debugging is only supported with \"gdb --fullname\"")) @@ -737,16 +742,18 @@ To run GDB in text command mode, set `gud-gdb-command-name' to ;; The completion list is constructed by the process filter. (defvar gud-gdb-fetched-lines) -(defvar gud-comint-buffer nil) - -(defun gud-gdb-complete-command () +(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) - (let* ((end (point)) - (command (buffer-substring (comint-line-beginning-position) end)) - (command-word + (if command + ;; Used by gud-watch in mini-buffer. + (setq command (concat "p " command)) + ;; Used in GUD buffer. + (let ((end (point))) + (setq command (buffer-substring (comint-line-beginning-position) end)))) + (let* ((command-word ;; Find the word break. This match will always succeed. (and (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command) (substring command (match-beginning 2)))) @@ -865,13 +872,14 @@ It is passed through FILTER before we look at it." (defun gud-gdb-run-command-fetch-lines (command buffer &optional skip) "Run COMMAND, and return the list of lines it outputs. -BUFFER is the GUD buffer in which to run the command. +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 lines, it defaults to 0." - (with-current-buffer buffer - (if (save-excursion - (goto-char (point-max)) - (forward-line 0) - (not (looking-at comint-prompt-regexp))) + (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 ;; Much of this copied from GDB complete, but I'm grabbing the stack ;; frame instead. @@ -880,12 +888,13 @@ SKIP is the number of chars to skip on each lines, it defaults to 0." (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)))) + `(lambda (string) + (gud-gdb-fetch-lines-filter string ',gud-marker-filter)))) ;; Issue the command to GDB. (gud-basic-call command) ;; Slurp the output. (while gud-gdb-fetch-lines-in-progress - (accept-process-output (get-buffer-process buffer))) + (accept-process-output (get-buffer-process gud-comint-buffer))) (nreverse gud-gdb-fetched-lines))))) @@ -2559,7 +2568,7 @@ comint mode, which see." (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 running under gdb")) + (error "This program is already being debugged")) ;; Set the dir, in case the buffer already existed with a different dir. (setq default-directory dir) ;; Set default-directory to the file's directory. @@ -2687,10 +2696,10 @@ It is saved for when this flag is not set.") ((memq (process-status proc) '(signal exit)) ;; Stop displaying an arrow in a source file. (setq gud-overlay-arrow-position nil) - (with-current-buffer gud-comint-buffer - (if (memq gud-minor-mode-type '(gdbmi gdba)) - (gdb-reset) - (gud-reset))) + (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdba gdbmi)) + (gdb-reset) + (gud-reset)) (let* ((obuf (current-buffer))) ;; save-excursion isn't the right thing if ;; process-buffer is current-buffer @@ -2795,7 +2804,9 @@ Obeying it means displaying in another window the specified file and line." (let ((insource (not (eq (current-buffer) gud-comint-buffer))) (frame (or gud-last-frame gud-last-last-frame)) result) - (while (and str (string-match "\\([^%]*\\)%\\([adeflpc]\\)" str)) + (while (and str + (let ((case-fold-search nil)) + (string-match "\\([^%]*\\)%\\([adefFlpc]\\)" str))) (let ((key (string-to-char (match-string 2 str))) subst) (cond @@ -2880,8 +2891,11 @@ Obeying it means displaying in another window the specified file and line." (set-buffer gud-comint-buffer) (save-restriction (widen) - (goto-char (process-mark proc)) - (forward-line 0) + (if (marker-position gud-delete-prompt-marker) + ;; We get here when printing an expression. + (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)) @@ -2902,7 +2916,21 @@ Obeying it means displaying in another window the specified file and line." (defvar gud-find-expr-function 'gud-find-c-expr) (defun gud-find-expr (&rest args) - (apply gud-find-expr-function 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)) + (insert (concat expr " = "))))) + expr)) ;; The next eight functions are hacked from gdbsrc.el by ;; Debby Ayers , @@ -3141,7 +3169,7 @@ class of the file (using s to separate nested class ids)." (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\\|\\s_\\)+\\)" (1 font-lock-keyword-face)))) + ("^\\s-*\\(\\w\\(\\w\\|\\s_\\)*\\)" (1 font-lock-keyword-face)))) ;; FIXME: The keyword "end" associated with "document" ;; should have font-lock-keyword-face (currently font-lock-doc-face). @@ -3269,11 +3297,10 @@ Treats actions as defuns." (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); gud-comint-buffer might be killed - (with-current-buffer gud-comint-buffer - (memq gud-minor-mode '(gdbmi gdba)))) + (if (and gud-comint-buffer + (buffer-name gud-comint-buffer); gud-comint-buffer might be killed + (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + '(gdbmi gdba))) (if gud-tooltip-mode (progn (dolist (buffer (buffer-list)) @@ -3289,7 +3316,8 @@ Treats actions as defuns." (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) +(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 @@ -3338,6 +3366,12 @@ only tooltips in the buffer containing the overlay arrow." (defvar gud-tooltip-mouse-motions-active nil "Locally t in a buffer if tooltip processing of mouse motion is enabled.") +;; We don't set track-mouse globally because this is a big redisplay +;; problem in buffers having a pre-command-hook or such installed, +;; which does a set-buffer, like the summary buffer of Gnus. Calling +;; set-buffer prevents redisplay optimizations, so every mouse motion +;; would be accompanied by a full redisplay. + (defun gud-tooltip-activate-mouse-motions (activatep) "Activate/deactivate mouse motion events for the current buffer. ACTIVATEP non-nil means activate mouse motion events." @@ -3403,9 +3437,8 @@ With arg, dereference expr iff arg is positive." (case gud-minor-mode (gdba (concat "server print " expr)) ((dbx gdbmi) (concat "print " expr)) - (xdb (concat "p " expr)) - (sdb (concat expr "/")) - (perldb expr))) + ((xdb pdb) (concat "p " expr)) + (sdb (concat expr "/")))) (defun gud-tooltip-tips (event) "Show tip for identifier or selection under the mouse. @@ -3456,7 +3489,8 @@ so they have been disabled.")) gdb-server-prefix "macro expand " expr "\n") `(lambda () (gdb-tooltip-print-1 ,expr)))) (gdb-enqueue-input - (list (concat cmd "\n") 'gdb-tooltip-print))) + (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))