comparison lisp/gdb-ui.el @ 51028:323ddc93f3fe

(gdb-info-frames-custom): Reverse contrast of face for selected frame. (gdb-annotation-rules): Stop using frames-invalid and breakpoints-invalid annotations. Update after post-prompt instead. (gdb-post-prompt): Update frames and breakpoints here. (gdb-invalidate-frame-and-assembler) (gdb-invalidate-breakpoints-and-assembler): Remove. (gdb-current-address): Remove. (gdb-previous-address): New variable. (gud-until): Extend to work in Assembler buffer (gdb-append-to-inferior-io): Select IO buffer when there is output. (gdb-assembler-custom): Try to get line marker (arrow) to display in window. Correct parsing for OS dependent output syntax of Gdb command, where. (gdb-frame-handler): Correct parsing for OS dependent output syntax of Gdb command, frame. (gdb-invalidate-assembler): Update assembler buffer correctly when frame changes (revisited).

51027:08b938c3a5fc

(defcustom gdb-window-width 30
  "Width of a frame for a displayed expression in GDB-UI."
  :type 'integer
  :group 'gud)

(defvar gdb-main-or-pc nil "Initialisation for Assembler buffer.")
(defvar gdb-current-address nil)
(defvar gdb-display-in-progress nil)
(defvar gdb-dive nil)
(defvar gdb-buffer-type nil)
(defvar gdb-variables '()
  "A list of variables that are local to the GUD buffer.")

			  (beginning-of-line)
			  (forward-char 2)
			  (gud-call "clear *%a" arg)))
	   "\C-d" "Remove breakpoint at current line or address.")
  ;;
  (setq comint-input-sender 'gdb-send)
  ;;
  ;; (re-)initialise
  (setq gdb-main-or-pc "main")
  (setq gdb-current-address nil)
  (setq gdb-display-in-progress nil)
  (setq gdb-dive nil)
  ;;
  (mapc 'make-local-variable gdb-variables)
  (setq gdb-buffer-type 'gdba)

  "Default command to execute an executable under the GDB-UI debugger."
  :type 'string
  :group 'gud)

(defvar gdb-annotation-rules
  '(("frames-invalid" gdb-invalidate-frame-and-assembler)
    ("breakpoints-invalid" gdb-invalidate-breakpoints-and-assembler)
    ("pre-prompt" gdb-pre-prompt)
    ("prompt" gdb-prompt)
    ("commands" gdb-subprompt)
    ("overload-choice" gdb-subprompt)
    ("query" gdb-subprompt)
    ("prompt-for-continue" gdb-subprompt)

    ("exited" gdb-stopping)
    ("signalled" gdb-stopping)
    ("signal" gdb-stopping)
    ("breakpoint" gdb-stopping)
    ("watchpoint" gdb-stopping)
;    ("frame-begin" gdb-frame-begin)
    ("stopped" gdb-stopped)
    ("display-begin" gdb-display-begin)
    ("display-end" gdb-display-end)
; GDB commands info stack, info locals and frame generate an error-begin
; annotation at start when there is no stack but this is a quirk/bug in

  (setq gud-last-frame
	(cons
	 (match-string 1 args)
	 (string-to-int (match-string 2 args))))
  (setq gdb-current-address (match-string 3 args))
  (setq gdb-main-or-pc gdb-current-address)
  ;;update with new frame for machine code if necessary
  (gdb-invalidate-assembler))

(defun gdb-send-item (item)
  (gdb-set-current-item item)

  "An annotation handler for `post-prompt'. This begins the collection of
output from the current command if that happens to be appropriate."
  (if (not (gdb-get-pending-triggers))
      (progn
	(gdb-get-current-frame)
	(gdb-invalidate-registers ignored)
	(gdb-invalidate-locals ignored)
	(gdb-invalidate-display ignored)
	(gdb-invalidate-threads)))
  (let ((sink (gdb-get-output-sink)))
    (cond
     ((eq sink 'user) t)
     ((eq sink 'pre-emacs)

    (set-buffer
     (gdb-get-create-buffer 'gdb-inferior-io))
    (goto-char (point-max))
    (insert-before-markers string))
  (if (not (string-equal string ""))
      (gdb-display-buffer
       (gdb-get-create-buffer 'gdb-inferior-io))))

(defun gdb-clear-inferior-io ()
  (save-excursion
    (set-buffer
     (gdb-get-create-buffer 'gdb-inferior-io))

	(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-*\\(.\\)")
		(setq flag (char-after (match-beginning 2)))
		(beginning-of-line)
		(if (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+" nil t)
		    (progn
		      (looking-at "\\(\\S-*\\):\\([0-9]+\\)")
		      (let ((line (match-string 2)) (buffer-read-only nil)

  gdb-info-frames-custom)

(defun gdb-info-frames-custom ()
  (save-excursion
    (set-buffer (gdb-get-buffer 'gdb-stack-buffer))
    (let ((buffer-read-only nil))
      (goto-char (point-min))
      (while (< (point) (point-max))
	(put-text-property (progn (beginning-of-line) (point))
			   (progn (end-of-line) (point))
			   'mouse-face 'highlight)
	(forward-line 1)))))

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

\\{gdb-frames-mode-map}"
  (setq major-mode 'gdb-frames-mode)
  (setq mode-name "Frames")
  (setq buffer-read-only t)
  (use-local-map gdb-frames-mode-map)
  (gdb-invalidate-frames))

(defun gdb-get-frame-number ()
  (save-excursion
    (let* ((pos (re-search-backward "^#\\([0-9]*\\)" nil t))

		      'gdb-assembler-buffer-name
		      'gdb-assembler-mode)

(def-gdb-auto-updated-buffer gdb-assembler-buffer
  gdb-invalidate-assembler
  (concat "server disassemble " gdb-main-or-pc "\n")
  gdb-assembler-handler
  gdb-assembler-custom)

(defun gdb-assembler-custom ()
  (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer))
	(gdb-arrow-position) (address) (flag))
    (if gdb-current-address
	(progn
	  (save-excursion
	    (set-buffer buffer)
	    (remove-arrow)
	    (goto-char (point-min))
	    (re-search-forward gdb-current-address)
	    (setq gdb-arrow-position (point))
	    (put-arrow "=>" gdb-arrow-position nil 'left-margin))))
    ;; remove all breakpoint-icons in assembler buffer  before updating.
    (save-excursion
      (set-buffer buffer)
      (if (display-graphic-p)
	  (remove-images (point-min) (point-max))
	(remove-strings (point-min) (point-max))))
    (save-excursion
      (set-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-*\\)")
	      ;; info break gives '0x0' (8 digit) while dump gives '0x' (7 digit)
	      (setq address (concat "0x" (match-string 3)))
	      (setq flag (char-after (match-beginning 2)))
	      (save-excursion
		(set-buffer buffer)
		(goto-char (point-min))
		(if (re-search-forward address nil t)
		    (let ((start (progn (beginning-of-line) (- (point) 1)))
			  (end (progn (end-of-line) (+ (point) 1))))
		      (if (display-graphic-p)
			  (progn
			    (remove-images start end)
			    (if (eq ?y flag)
				(put-image breakpoint-enabled-icon (point)
					   "breakpoint icon enabled"
					   'left-margin)
			      (put-image breakpoint-disabled-icon (point)
					 "breakpoint icon disabled"
					 'left-margin)))
			(remove-strings start end)
			(if (eq ?y flag)
			    (put-string "B" (point) "enabled" 'left-margin)
			  (put-string "b" (point) "disabled"
				      'left-margin))))))))))
    (if gdb-current-address
	(set-window-point (get-buffer-window buffer) gdb-arrow-position))))

(defvar gdb-assembler-mode-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    map))

(defun gdb-frame-assembler-buffer ()
  (interactive)
  (switch-to-buffer-other-frame
   (gdb-get-create-buffer 'gdb-assembler-buffer)))

(defun gdb-invalidate-frame-and-assembler (&optional ignored)
  (gdb-invalidate-frames)
  (gdb-invalidate-assembler))

(defun gdb-invalidate-breakpoints-and-assembler (&optional ignored)
  (gdb-invalidate-breakpoints)
  (gdb-invalidate-assembler))

(defvar gdb-prev-main-or-pc nil)

;; modified because if gdb-main-or-pc has changed value a new command
;; must be enqueued to update the buffer with the new output
(defun gdb-invalidate-assembler (&optional ignored)
  (if (and (gdb-get-buffer 'gdb-assembler-buffer)
	   (or (not (member 'gdb-invalidate-assembler
			    (gdb-get-pending-triggers)))
	       (not (string-equal gdb-main-or-pc gdb-prev-main-or-pc))))
      (progn
	;; take previous disassemble command off the queue
	(save-excursion
	  (set-buffer gud-comint-buffer)
	  (let ((queue gdb-idle-input-queue) (item))
	    (dolist (item queue)
	      (setq item (car queue))
	      (if (equal (cdr item) '(gdb-assembler-handler))
		  (setq gdb-idle-input-queue 
			(delete item gdb-idle-input-queue))))))
	(gdb-enqueue-idle-input
	 (list (concat "server disassemble " gdb-main-or-pc "\n")
	       'gdb-assembler-handler))
	(gdb-set-pending-triggers
	 (cons 'gdb-invalidate-assembler
	       (gdb-get-pending-triggers)))
	(setq gdb-prev-main-or-pc gdb-main-or-pc))))

(defun gdb-get-current-frame ()
  (if (not (member 'gdb-get-current-frame (gdb-get-pending-triggers)))
      (progn
	(gdb-enqueue-idle-input

  (gdb-set-pending-triggers
   (delq 'gdb-get-current-frame (gdb-get-pending-triggers)))
  (save-excursion
    (set-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer))
    (goto-char (point-min))
    (if (looking-at "^#[0-9]*\\s-*0x\\S-* in \\(\\S-*\\)")
	(setq gdb-current-frame (match-string 1))
      (if (looking-at "^#[0-9]*\\s-*\\(\\S-*\\)")
	  (setq gdb-current-frame (match-string 1))))))

(provide 'gdb-ui)

51028:323ddc93f3fe

(defcustom gdb-window-width 30
  "Width of a frame for a displayed expression in GDB-UI."
  :type 'integer
  :group 'gud)

(defvar gdb-current-address nil "Initialisation for Assembler buffer.")
(defvar gdb-previous-address nil)
(defvar gdb-display-in-progress nil)
(defvar gdb-dive nil)
(defvar gdb-buffer-type nil)
(defvar gdb-variables '()
  "A list of variables that are local to the GUD buffer.")

			  (beginning-of-line)
			  (forward-char 2)
			  (gud-call "clear *%a" arg)))
	   "\C-d" "Remove breakpoint at current line or address.")
  ;;
  (gud-def gud-until  (if (not (string-equal mode-name "Assembler"))
			  (gud-call "until %f:%l" arg)
			(save-excursion
			  (beginning-of-line)
			  (forward-char 2)
			  (gud-call "until *%a" arg)))
	   "\C-u" "Continue up to current line or address.")

  (setq comint-input-sender 'gdb-send)
  ;;
  ;; (re-)initialise
  (setq gdb-current-address "main")
  (setq gdb-previous-address nil)
  (setq gdb-display-in-progress nil)
  (setq gdb-dive nil)
  ;;
  (mapc 'make-local-variable gdb-variables)
  (setq gdb-buffer-type 'gdba)

  "Default command to execute an executable under the GDB-UI debugger."
  :type 'string
  :group 'gud)

(defvar gdb-annotation-rules
  '(("pre-prompt" gdb-pre-prompt)
    ("prompt" gdb-prompt)
    ("commands" gdb-subprompt)
    ("overload-choice" gdb-subprompt)
    ("query" gdb-subprompt)
    ("prompt-for-continue" gdb-subprompt)

    ("exited" gdb-stopping)
    ("signalled" gdb-stopping)
    ("signal" gdb-stopping)
    ("breakpoint" gdb-stopping)
    ("watchpoint" gdb-stopping)
    ("frame-begin" gdb-frame-begin)
    ("stopped" gdb-stopped)
    ("display-begin" gdb-display-begin)
    ("display-end" gdb-display-end)
; GDB commands info stack, info locals and frame generate an error-begin
; annotation at start when there is no stack but this is a quirk/bug in

  (setq gud-last-frame
	(cons
	 (match-string 1 args)
	 (string-to-int (match-string 2 args))))
  (setq gdb-current-address (match-string 3 args))
  ;;update with new frame for machine code if necessary
  (gdb-invalidate-assembler))

(defun gdb-send-item (item)
  (gdb-set-current-item item)

  "An annotation handler for `post-prompt'. This begins the collection of
output from the current command if that happens to be appropriate."
  (if (not (gdb-get-pending-triggers))
      (progn
	(gdb-get-current-frame)
	(gdb-invalidate-frames)
	(gdb-invalidate-breakpoints)
	(gdb-invalidate-assembler)
	(gdb-invalidate-registers)
	(gdb-invalidate-locals)
	(gdb-invalidate-display)
	(gdb-invalidate-threads)))
  (let ((sink (gdb-get-output-sink)))
    (cond
     ((eq sink 'user) t)
     ((eq sink 'pre-emacs)

    (set-buffer
     (gdb-get-create-buffer 'gdb-inferior-io))
    (goto-char (point-max))
    (insert-before-markers string))
  (if (not (string-equal string ""))
      (select-window 
	(gdb-display-buffer (gdb-get-create-buffer 'gdb-inferior-io)))))

(defun gdb-clear-inferior-io ()
  (save-excursion
    (set-buffer
     (gdb-get-create-buffer 'gdb-inferior-io))

	(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-*\\(.\\)")
		(setq flag (char-after (match-beginning 1)))
		(beginning-of-line)
		(if (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+" nil t)
		    (progn
		      (looking-at "\\(\\S-*\\):\\([0-9]+\\)")
		      (let ((line (match-string 2)) (buffer-read-only nil)

  gdb-info-frames-custom)

(defun gdb-info-frames-custom ()
  (save-excursion
    (set-buffer (gdb-get-buffer 'gdb-stack-buffer))
    (save-excursion
      (let ((buffer-read-only nil))
	(goto-char (point-min))
	(while (< (point) (point-max))
	  (put-text-property (progn (beginning-of-line) (point))
			     (progn (end-of-line) (point))
			     'mouse-face 'highlight)
	  (beginning-of-line)
	  (if (or (looking-at "^#[0-9]*\\s-*\\S-* in \\(\\S-*\\)")
		  (looking-at "^#[0-9]*\\s-*\\(\\S-*\\)"))
	      (if (equal (match-string 1) gdb-current-frame)
		  (put-text-property (progn (beginning-of-line) (point))
				     (progn (end-of-line) (point))
				     'face 
				     `(:background ,(face-attribute 'default :foreground)
				       :foreground ,(face-attribute 'default :background)))))
	  (forward-line 1))))))

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

\\{gdb-frames-mode-map}"
  (setq major-mode 'gdb-frames-mode)
  (setq mode-name "Frames")
  (setq buffer-read-only t)
  (use-local-map gdb-frames-mode-map)
  (font-lock-mode -1)
  (gdb-invalidate-frames))

(defun gdb-get-frame-number ()
  (save-excursion
    (let* ((pos (re-search-backward "^#\\([0-9]*\\)" nil t))

		      'gdb-assembler-buffer-name
		      'gdb-assembler-mode)

(def-gdb-auto-updated-buffer gdb-assembler-buffer
  gdb-invalidate-assembler
  (concat "server disassemble " gdb-current-address "\n")
  gdb-assembler-handler
  gdb-assembler-custom)

(defun gdb-assembler-custom ()
  (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer))
	(address) (flag))
    (save-excursion
      (set-buffer buffer)
      (if (not (equal gdb-current-address "main"))
	  (progn
	    (remove-arrow)
	    (goto-char (point-min))
	    (if (re-search-forward gdb-current-address nil t)
		(progn
		  (put-arrow "=>" (point) nil 'left-margin)
		  (set-window-point gdb-source-window (point))))))
      ;; remove all breakpoint-icons in assembler buffer  before updating.
      (save-excursion
	(if (display-graphic-p)
	    (remove-images (point-min) (point-max))
	  (remove-strings (point-min) (point-max))))
      (set-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-*0x\\(\\S-*\\)")
	      (setq flag (char-after (match-beginning 1)))
	      (let ((number (match-string 2)))
		;; remove leading 0s from output of info break.
		(if (string-match "0x0+\\(.*\\)" number)
		    (setq address (concat "0x" (match-string 1 address)))
		  (setq address number)))
	      (save-excursion
		(set-buffer buffer)
		(save-excursion
		  (goto-char (point-min))
		  (if (re-search-forward address nil t)
		      (let ((start (progn (beginning-of-line) (- (point) 1)))
			    (end (progn (end-of-line) (+ (point) 1))))
			(if (display-graphic-p)
			    (progn
			      (remove-images start end)
			      (if (eq ?y flag)
				  (put-image breakpoint-enabled-icon (point)
					     "breakpoint icon enabled"
					     'left-margin)
				(put-image breakpoint-disabled-icon (point)
					   "breakpoint icon disabled"
					   'left-margin)))
			  (remove-strings start end)
			  (if (eq ?y flag)
			      (put-string "B" (point) "enabled" 'left-margin)
			    (put-string "b" (point) "disabled"
					'left-margin)))))))))))))

(defvar gdb-assembler-mode-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    map))

(defun gdb-frame-assembler-buffer ()
  (interactive)
  (switch-to-buffer-other-frame
   (gdb-get-create-buffer 'gdb-assembler-buffer)))

;; modified because if gdb-current-address has changed value a new command
;; must be enqueued to update the buffer with the new output
(defun gdb-invalidate-assembler (&optional ignored)
  (if (and (gdb-get-buffer 'gdb-assembler-buffer)
	   (or (not (member 'gdb-invalidate-assembler
			    (gdb-get-pending-triggers)))
	       (not (string-equal gdb-current-address gdb-previous-address))))
      (progn
	;; take previous disassemble command off the queue
	(save-excursion
	  (set-buffer gud-comint-buffer)
	  (let ((queue (gdb-get-idle-input-queue)) (item))
	    (dolist (item queue)
	      (if (equal (cdr item) '(gdb-assembler-handler))
		  (gdb-set-idle-input-queue 
		   (delete item (gdb-get-idle-input-queue)))))))
	(gdb-enqueue-idle-input
	 (list (concat "server disassemble " gdb-current-address "\n")
	       'gdb-assembler-handler))
	(gdb-set-pending-triggers
	 (cons 'gdb-invalidate-assembler
	       (gdb-get-pending-triggers)))
	(setq gdb-previous-address gdb-current-address))))

(defun gdb-get-current-frame ()
  (if (not (member 'gdb-get-current-frame (gdb-get-pending-triggers)))
      (progn
	(gdb-enqueue-idle-input

  (gdb-set-pending-triggers
   (delq 'gdb-get-current-frame (gdb-get-pending-triggers)))
  (save-excursion
    (set-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer))
    (goto-char (point-min))
    (if (looking-at "^#[0-9]*\\s-*\\(\\S-*\\) in \\(\\S-*\\)")
	(progn
	  (setq gdb-current-frame (match-string 2))
	  (let ((address (match-string 1)))
	    ;; remove leading 0s from output of frame command.
	    (if (string-match "0x0+\\(.*\\)" address)
		(setq gdb-current-address (concat "0x" (match-string 1 address)))
	      (setq gdb-current-address address)))
	  (if (not (looking-at ".*) at "))
	      (progn
		(set-window-buffer gdb-source-window
				   (gdb-get-create-buffer 'gdb-assembler-buffer))
		(gdb-invalidate-assembler))))
      (if (looking-at "^#[0-9]*\\s-*\\(\\S-*\\)")
	  (setq gdb-current-frame (match-string 1))))))

(provide 'gdb-ui)