comparison lisp/progmodes/gdb-ui.el @ 91204:53108e6cea98

Merge from emacs--devo--0 Revision: [e-mail]/emacs--unicode--0--patch-294

91203:db40129142b2

;; You don't need to know about annotations to use this mode as a debugger,
;; but if you are interested developing the mode itself, see the Annotations
;; section in the GDB info manual.

;; GDB developers plan to make the annotation interface obsolete.  A new
;; interface called GDB/MI (machine interface) has been designed to replace
;; it.  Some GDB/MI commands are used in this file through the CLI command
;; 'interpreter mi <mi-command>'.  A file called gdb-mi.el is included with
;; GDB (6.2 onwards) that uses GDB/MI as the primary interface to GDB.  It is
;; still under development and is part of a process to migrate Emacs from
;; annotations to GDB/MI.

;; This mode SHOULD WORK WITH GDB 5.0 or later but you will NEED AT LEAST
;; GDB 6.0 to use watch expressions.  It works best with GDB 6.4 or later
;; where watch expressions will update more quickly.

;; and compiling with -DUNBUFFERED while debugging.

;;; Known Bugs:

;; 1) Strings that are watched don't update in the speedbar when their
;;    contents change unless the first character changes.
;; 2) Cannot handle multiple debug sessions.
;; 3) M-x gdb doesn't work with "run" command in .gdbinit, use M-x gdba instead.
;; 4) M-x gdb doesn't work if the corefile is specified in the command in the
;;    minibuffer, use M-x gdba instead (or specify the core in the GUD buffer).
;; 5) If you wish to call procedures from your program in GDB
;;    e.g "call myproc ()", "p mysquare (5)" then use level 2 annotations
;;    "gdb --annotate=2 myprog" to keep source buffer/selected frame fixed.
;; 6) After detaching from a process, clicking on the "GO" icon on toolbar
;;    (gud-go) sends "continue" to GDB (should be "run").

;;; Problems with watch expressions, GDB/MI:

;; 1) They go out of scope when the inferior is re-run.
;; 2) -stack-list-locals has a type field but also prints type in values field.
;; 3) VARNUM increments even when variable object is not created
;;    (maybe trivial).

;;; TODO:

;; 1) Use MI command -data-read-memory for memory window.
;; 2) Use tree-widget.el instead of the speedbar for watch-expressions?

(defvar gdb-continuation nil)
(defvar gdb-look-up-stack nil)
(defvar gdb-frame-begin nil
  "Non-nil when GDB generates frame-begin annotation.")
(defvar gdb-printing t)

(defvar gdb-buffer-type nil
  "One of the symbols bound in `gdb-buffer-rules'.")
(make-variable-buffer-local 'gdb-buffer-type)

;;;###autoload
(defun 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.


If `gdb-many-windows' is nil (the default value) then gdb just
pops up the GUD buffer unless `gdb-show-main' is t.  In this case
it starts with two windows: one displaying the GUD buffer and the
other with the source file with the main routine of the inferior.

    (t :background "gray"))
  "Face for disabled breakpoint icon in fringe."
  :group 'gud)

(defconst gdb-breakpoint-regexp
  "\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\s-+\\(.\\)\\s-+")

;; Put breakpoint icons in relevant margins (even those set in the GUD buffer).
(defun gdb-info-breakpoints-custom ()
  (let ((flag) (bptno))
    ;; Remove all breakpoint-icons in source buffers but not assembler buffer.

	(goto-char (point-min))
	(while (< (point) (- (point-max) 1))
	  (forward-line 1)
	  (if (looking-at gdb-breakpoint-regexp)
	      (progn
		(setq bptno (match-string 1))
		(setq flag (char-after (match-beginning 2)))
		(add-text-properties
		 (match-beginning 2) (match-end 2)
		 (if (eq flag ?y)
		     '(face font-lock-warning-face)
		   '(face font-lock-type-face)))
		(let ((bl (point))
		      (el (line-end-position)))

		       (match-beginning 1) (match-end 1)
		       '(face font-lock-variable-name-face)))))))
	  (end-of-line))))))
  (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)))

(defun gdb-mouse-set-clear-breakpoint (event)
  "Set/clear breakpoint in left fringe/margin with mouse click."
  (interactive "e")
  (mouse-minibuffer-check event)
  (let ((posn (event-end event)))

    (if (numberp (posn-point posn))
	(with-selected-window (posn-window posn)
	  (save-excursion
	    (goto-char (posn-point posn))
	    (if	(posn-object posn)
		(gdb-enqueue-input
		 (list
		  (let ((bptno (get-text-property
				0 'gdb-bptno (car (posn-string posn)))))
		    (concat gdb-server-prefix
			    (if (get-text-property
				 0 'gdb-enabled (car (posn-string posn)))
				"disable "
			      "enable ")
			    bptno "\n"))
		  'ignore))))))))

(defun gdb-mouse-toggle-breakpoint-fringe (event)
  "Enable/disable breakpoint in left fringe with mouse click."
  (interactive "e")
  (mouse-minibuffer-check event)

	  (goto-char pos)
	  (dolist (overlay (overlays-in pos pos))
	    (when (overlay-get overlay 'put-break)
	      (setq obj (overlay-get overlay 'before-string))))
	  (when (stringp obj)
	    (gdb-enqueue-input
	     (list
	      (concat gdb-server-prefix
	       (if (get-text-property 0 'gdb-enabled obj)
		   "disable "
		 "enable ")
	       (get-text-property 0 'gdb-bptno obj) "\n")
	      'ignore))))))))

(defun gdb-breakpoints-buffer-name ()
  (with-current-buffer gud-comint-buffer
    (concat "*breakpoints of " (gdb-get-target-string) "*")))

    (beginning-of-line 1)
    (if (looking-at gdb-breakpoint-regexp)
	(gdb-enqueue-input
	 (list
	  (concat gdb-server-prefix
		  (if (eq ?y (char-after (match-beginning 2)))
		      "disable "
		    "enable ")
		  (match-string 1) "\n") 'ignore))
      (error "Not recognized as break/watchpoint line"))))

(defun gdb-delete-breakpoint ()
  "Delete the breakpoint at current line."
  (interactive)
  (beginning-of-line 1)
  (if (looking-at gdb-breakpoint-regexp)
      (gdb-enqueue-input
       (list
	(concat gdb-server-prefix "delete " (match-string 1) "\n") 'ignore))
    (error "Not recognized as break/watchpoint line")))

(defun gdb-goto-breakpoint (&optional event)
  "Display the breakpoint location specified at current line."
  (interactive (list last-input-event))
  (if event (posn-set-point (event-end event)))
  (save-excursion
    (beginning-of-line 1)
    (if (looking-at "\\([0-9]+\\) .+ in .+ at\\s-+\\(\\S-+\\):\\([0-9]+\\)")
	(let ((bptno (match-string 1))
	      (file  (match-string 2))
	      (line  (match-string 3)))
	  (save-selected-window
	    (let* ((buffer (find-file-noselect

  (dolist (overlay (overlays-in start end))
    (when (overlay-get overlay 'put-break)
	  (delete-overlay overlay))))

(defun gdb-put-breakpoint-icon (enabled bptno)
  (let ((start (- (line-beginning-position) 1))
	(end (+ (line-end-position) 1))
	(putstring (if enabled "B" "b"))
	(source-window (get-buffer-window (current-buffer) 0)))
    (add-text-properties

      (when (< left-margin-width 2)
	(save-current-buffer
	  (setq left-margin-width 2)
	  (let ((window (get-buffer-window (current-buffer) 0)))
	    (if window
	      (set-window-margins
	       window left-margin-width right-margin-width)))))
      (gdb-put-string
       (propertize putstring
		   'face (if enabled 'breakpoint-enabled 'breakpoint-disabled))
       (1+ start)))))

	(gdb-remove-breakpoint-icons (point-min) (point-max))))
    (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
      (goto-char (point-min))
      (while (< (point) (- (point-max) 1))
	(forward-line 1)
	(if (looking-at "[^\t].*?breakpoint")
	    (progn
	      (looking-at
	    "\\([0-9]+\\)\\s-+\\S-+\\s-+\\S-+\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)")
	      (setq bptno (match-string 1))
	      (setq flag (char-after (match-beginning 2)))
	      (setq address (match-string 3))
	      (with-current-buffer buffer
		(save-excursion
		  (goto-char (point-min))
		  (if (search-forward address nil t)
		      (gdb-put-breakpoint-icon (eq flag ?y) bptno))))))))
    (if (not (equal gdb-pc-address "main"))
	(with-current-buffer buffer
	  (set-window-point (get-buffer-window buffer 0) pos)))))

(defvar gdb-assembler-mode-map

	  (gdb-create-define-alist)
	  (add-hook 'after-save-hook 'gdb-create-define-alist nil t)))))
  (gdb-force-mode-line-update
   (propertize "ready" 'face font-lock-variable-name-face)))

; Uses "-var-list-children --all-values".  Needs GDB 6.1 onwards.
(defun gdb-var-list-children-1 (varnum)
  (gdb-enqueue-input
   (list
    (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
	(concat "server interpreter mi \"-var-list-children --all-values "

91204:53108e6cea98

;; You don't need to know about annotations to use this mode as a debugger,
;; but if you are interested developing the mode itself, see the Annotations
;; section in the GDB info manual.

;; GDB developers plan to make the annotation interface obsolete.  A new
;; interface called GDB/MI (machine interface) has been designed to replace it.
;; Some GDB/MI commands are used in this file through the CLI command
;; 'interpreter mi <mi-command>'.  To help with the process of fully migrating
;; Emacs from annotations to GDB/MI, there is an experimental package called
;; gdb-mi in the Emacs Lisp Package Archive ("http://tromey.com/elpa/").  It
;; comprises of modified gud.el and a file called gdb-mi.el which replaces
;; gdb-ui.el.  When installed, this overrides the current files and invoking
;; M-x gdb will use GDB/MI directly (starts with "gdb -i=mi").  When deleted
;; ('d' followed by 'x' in Package Menu mode), the files are deleted and old
;; functionality restored.  This provides a convenient way to review the
;; current status/contribute to its improvement.  For someone who just wants to
;; use GDB, however, the current mode in Emacs 22 is a much better option.
;; There is also a file, also called gdb-mi.el, a version of which is included
;; the GDB distribution.  This will probably only work with versions
;; distributed with GDB 6.5 or later.  Unlike the version in ELPA it works on
;; top of gdb-ui.el and you can only start it with M-x gdbmi.

;; This mode SHOULD WORK WITH GDB 5.0 or later but you will NEED AT LEAST
;; GDB 6.0 to use watch expressions.  It works best with GDB 6.4 or later
;; where watch expressions will update more quickly.

;; and compiling with -DUNBUFFERED while debugging.

;;; Known Bugs:

;; 1) Cannot handle multiple debug sessions.
;; 2) If you wish to call procedures from your program in GDB
;;    e.g "call myproc ()", "p mysquare (5)" then use level 2 annotations
;;    "gdb --annotate=2 myprog" to keep source buffer/selected frame fixed.
;; 3) After detaching from a process, clicking on the "GO" icon on toolbar
;;    (gud-go) sends "continue" to GDB (should be "run").

;;; TODO:

;; 1) Use MI command -data-read-memory for memory window.
;; 2) Use tree-widget.el instead of the speedbar for watch-expressions?

(defvar gdb-continuation nil)
(defvar gdb-look-up-stack nil)
(defvar gdb-frame-begin nil
  "Non-nil when GDB generates frame-begin annotation.")
(defvar gdb-printing t)
(defvar gdb-parent-bptno-enabled nil)

(defvar gdb-buffer-type nil
  "One of the symbols bound in `gdb-buffer-rules'.")
(make-variable-buffer-local 'gdb-buffer-type)

;;;###autoload
(defun 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.

If `gdb-many-windows' is nil (the default value) then gdb just
pops up the GUD buffer unless `gdb-show-main' is t.  In this case
it starts with two windows: one displaying the GUD buffer and the
other with the source file with the main routine of the inferior.

    (t :background "gray"))
  "Face for disabled breakpoint icon in fringe."
  :group 'gud)

(defconst gdb-breakpoint-regexp
  "\\(?:\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\|\\([0-9]+\\.[0-9]+\\)\\)\\s-+\\(.\\)\\s-+")

;; Put breakpoint icons in relevant margins (even those set in the GUD buffer).
(defun gdb-info-breakpoints-custom ()
  (let ((flag) (bptno))
    ;; Remove all breakpoint-icons in source buffers but not assembler buffer.

	(goto-char (point-min))
	(while (< (point) (- (point-max) 1))
	  (forward-line 1)
	  (if (looking-at gdb-breakpoint-regexp)
	      (progn
		(setq bptno (or (match-string 1) (match-string 2)))
		(setq flag (char-after (match-beginning 3)))
		(if (match-string 1)
		    (setq gdb-parent-bptno-enabled (eq flag ?y)))
		(add-text-properties
		 (match-beginning 3) (match-end 3)
		 (if (eq flag ?y)
		     '(face font-lock-warning-face)
		   '(face font-lock-type-face)))
		(let ((bl (point))
		      (el (line-end-position)))

		       (match-beginning 1) (match-end 1)
		       '(face font-lock-variable-name-face)))))))
	  (end-of-line))))))
  (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)))

(declare-function gud-remove "gdb-ui" t t) ; gud-def
(declare-function gud-break  "gdb-ui" t t) ; gud-def

(defun gdb-mouse-set-clear-breakpoint (event)
  "Set/clear breakpoint in left fringe/margin with mouse click."
  (interactive "e")
  (mouse-minibuffer-check event)
  (let ((posn (event-end event)))

    (if (numberp (posn-point posn))
	(with-selected-window (posn-window posn)
	  (save-excursion
	    (goto-char (posn-point posn))
	    (if	(posn-object posn)
		(let* ((bptno (get-text-property
			       0 'gdb-bptno (car (posn-string posn)))))
		  (string-match "\\([0-9+]\\)*" bptno)
		  (gdb-enqueue-input
		   (list
		    (concat gdb-server-prefix
			    (if (get-text-property
				 0 'gdb-enabled (car (posn-string posn)))
				"disable "
			      "enable ")
			    (match-string 1 bptno) "\n")
		   'ignore)))))))))

(defun gdb-mouse-toggle-breakpoint-fringe (event)
  "Enable/disable breakpoint in left fringe with mouse click."
  (interactive "e")
  (mouse-minibuffer-check event)

	  (goto-char pos)
	  (dolist (overlay (overlays-in pos pos))
	    (when (overlay-get overlay 'put-break)
	      (setq obj (overlay-get overlay 'before-string))))
	  (when (stringp obj)
	    (let* ((bptno (get-text-property 0 'gdb-bptno obj)))
	      (string-match "\\([0-9+]\\)*" bptno)
	      (gdb-enqueue-input
	       (list
		(concat gdb-server-prefix
			(if (get-text-property 0 'gdb-enabled obj)
			    "disable "
			  "enable ")
			(match-string 1 bptno) "\n")
		'ignore)))))))))

(defun gdb-breakpoints-buffer-name ()
  (with-current-buffer gud-comint-buffer
    (concat "*breakpoints of " (gdb-get-target-string) "*")))

    (beginning-of-line 1)
    (if (looking-at gdb-breakpoint-regexp)
	(gdb-enqueue-input
	 (list
	  (concat gdb-server-prefix
		  (if (eq ?y (char-after (match-beginning 3)))
		      "disable "
		    "enable ")
		  (or (match-string 1) (match-string 2)) "\n") 'ignore))
      (error "Not recognized as break/watchpoint line"))))

(defun gdb-delete-breakpoint ()
  "Delete the breakpoint at current line."
  (interactive)
  (save-excursion
    (beginning-of-line 1)
    (if (looking-at gdb-breakpoint-regexp)
	(if (match-string 1)
	    (gdb-enqueue-input
	     (list
	      (concat gdb-server-prefix "delete " (match-string 1) "\n")
	      'ignore))
	  (message-box "This breakpoint cannot be deleted on its own."))
      (error "Not recognized as break/watchpoint line"))))

(defun gdb-goto-breakpoint (&optional event)
  "Display the breakpoint location specified at current line."
  (interactive (list last-input-event))
  (if event (posn-set-point (event-end event)))
  (save-excursion
    (beginning-of-line 1)
    (if (looking-at "\\([0-9]+\\.?[0-9]*\\) .+ in .+ at\\s-+\\(\\S-+\\):\\([0-9]+\\)")
	(let ((bptno (match-string 1))
	      (file  (match-string 2))
	      (line  (match-string 3)))
	  (save-selected-window
	    (let* ((buffer (find-file-noselect

  (dolist (overlay (overlays-in start end))
    (when (overlay-get overlay 'put-break)
	  (delete-overlay overlay))))

(defun gdb-put-breakpoint-icon (enabled bptno)
  (if (string-match "[0-9+]+\\." bptno)
      (setq enabled gdb-parent-bptno-enabled))
  (let ((start (- (line-beginning-position) 1))
	(end (+ (line-end-position) 1))
	(putstring (if enabled "B" "b"))
	(source-window (get-buffer-window (current-buffer) 0)))
    (add-text-properties

      (when (< left-margin-width 2)
	(save-current-buffer
	  (setq left-margin-width 2)
	  (let ((window (get-buffer-window (current-buffer) 0)))
	    (if window
		(set-window-margins
		 window left-margin-width right-margin-width)))))
      (gdb-put-string
       (propertize putstring
		   'face (if enabled 'breakpoint-enabled 'breakpoint-disabled))
       (1+ start)))))

	(gdb-remove-breakpoint-icons (point-min) (point-max))))
    (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
      (goto-char (point-min))
      (while (< (point) (- (point-max) 1))
	(forward-line 1)
	(when (looking-at
	       "\\([0-9]+\\.?[0-9]*\\).*?\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)")
	  (setq bptno (match-string 1))
	  (setq flag (char-after (match-beginning 2)))
	  (setq address (match-string 3))
	  (with-current-buffer buffer
	    (save-excursion
	      (goto-char (point-min))
	      (if (search-forward address nil t)
		  (gdb-put-breakpoint-icon (eq flag ?y) bptno)))))))
    (if (not (equal gdb-pc-address "main"))
	(with-current-buffer buffer
	  (set-window-point (get-buffer-window buffer 0) pos)))))

(defvar gdb-assembler-mode-map

	  (gdb-create-define-alist)
	  (add-hook 'after-save-hook 'gdb-create-define-alist nil t)))))
  (gdb-force-mode-line-update
   (propertize "ready" 'face font-lock-variable-name-face)))

; Uses "-var-list-children --all-values".  Needs GDB 6.4 onwards.
(defun gdb-var-list-children-1 (varnum)
  (gdb-enqueue-input
   (list
    (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
	(concat "server interpreter mi \"-var-list-children --all-values "