comparison lisp/gdb-ui.el @ 48685:19bf840bede8

Replace uses of (gdb-get-instance-buffer 'gdba) and gdb-proc with gud-comint-buffer instead. (gdb-proc): Remove. (def-gdb-var): Simplify. (gdb-get-create-instance-buffer): Avoid make-variable-buffer-local. Set gud-comint-buffer as well as gud-minor-mode and tool-bar-map. (gdb-goto-bp-this-line): Select the window while doing the goto-line. (gdb-info-locals-handler): Avoid replace-regexp.

48684:9f1f766e9675

(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-first-time nil)
(defvar gdb-proc nil "The process associated with gdb.")

;;;###autoload
(defun gdba (command-line)
  "Run gdb on program FILE in buffer *gdb-FILE*.
The directory containing FILE becomes the initial working directory

  (setq gdb-main-or-pc "main")
  (setq gdb-current-address nil)
  (setq gdb-display-in-progress nil)
  (setq gdb-dive nil)

  (setq gdb-proc (get-buffer-process (current-buffer)))
  (gdb-make-instance)
  (gdb-clear-inferior-io)

  ;; find source file and compilation directory here
  (gdb-instance-enqueue-idle-input (list "server list\n" 'ignore))

	 (name (intern (concat "gdb-" root))))
    `(progn
       (defvar ,name ,default ,doc)
       (if (not (memq ',name gdb-instance-variables))
	   (push ',name gdb-instance-variables))
       ,(and accessor
	     `(defun ,accessor ()
		(let ((buffer (gdb-get-instance-buffer 'gdba)))
		  (and buffer (buffer-local-value ',name buffer)))))
       ,(and setter
	     `(defun ,setter (val)
		(let ((buffer (gdb-get-instance-buffer 'gdba)))
		  (and buffer (with-current-buffer buffer
				(setq ,name val)))))))))

(def-gdb-var buffer-type nil
  "One of the symbols bound in gdb-instance-buffer-rules")

(def-gdb-var burst ""

  "A list of trigger functions that have run later than their output
handlers.")

(defun in-gdb-instance-context (form)
  "Funcall FORM in the GUD buffer."
  (save-excursion
    (set-buffer (gdb-get-instance-buffer 'gdba))
    (funcall form)))

;; end of instance vars

(defun gdb-make-instance ()
  "Create a gdb instance object from a gdb process."
  (with-current-buffer (process-buffer gdb-proc)
    (mapc 'make-local-variable gdb-instance-variables)
    (setq gdb-buffer-type 'gdba)))

(defun gdb-instance-target-string ()
  "The apparent name of the program being debugged by a gdb instance.
For sure this the root string used in smashing together the gdb
buffer's name, even if that doesn't happen to be the name of a

The key should be one of the cars in `gdb-instance-buffer-rules-assoc'."
  (or (gdb-get-instance-buffer key)
      (let* ((rules (assoc key gdb-instance-buffer-rules-assoc))
	     (name (funcall (gdb-rules-name-maker rules)))
	     (new (get-buffer-create name)))
	(save-excursion
	  (set-buffer new)
	  (make-variable-buffer-local 'gdb-buffer-type)
	  (setq gdb-buffer-type key)
	  (if (cdr (cdr rules))
	      (funcall (car (cdr (cdr rules)))))
	  new))))

(defun gdb-rules-name-maker (rules) (car (cdr rules)))

(defun gdb-look-for-tagged-buffer (key bufs)

(defun gdb-set-instance-buffer-rules (buffer-type &rest rules)
  (let ((binding (assoc buffer-type gdb-instance-buffer-rules-assoc)))
    (if binding
	(setcdr binding rules)
      (setq gdb-instance-buffer-rules-assoc
	    (cons (cons buffer-type rules)
		  gdb-instance-buffer-rules-assoc)))))

;; GUD buffers are an exception to the rules
(gdb-set-instance-buffer-rules 'gdba 'error)

;;

  ;; features.  We don't need a process, but comint wants one, so create
  ;; a dummy one.
  (make-comint-in-buffer
   (substring (buffer-name) 1 (- (length (buffer-name)) 1))
   (current-buffer) "/bin/cat")
  (set (make-local-variable 'gud-minor-mode) 'gdba)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
  (setq comint-input-sender 'gdb-inferior-io-sender))

(defun gdb-inferior-io-sender (proc string)
  (save-excursion
    (set-buffer (process-buffer proc))
      (set-buffer (gdb-get-instance-buffer 'gdba))
	(process-send-string gdb-proc string)
	(process-send-string gdb-proc "\n")))

(defun gdb-inferior-io-interrupt ()
  "Interrupt the program being debugged."
  (interactive)
  (interrupt-process
   (get-buffer-process (gdb-get-instance-buffer 'gdba)) comint-ptyp))

(defun gdb-inferior-io-quit ()
  "Send quit signal to the program being debugged."
  (interactive)
  (quit-process
   (get-buffer-process (gdb-get-instance-buffer 'gdba)) comint-ptyp))

(defun gdb-inferior-io-stop ()
  "Stop the program being debugged."
  (interactive)
  (stop-process
   (get-buffer-process (gdb-get-instance-buffer 'gdba)) comint-ptyp))

(defun gdb-inferior-io-eof ()
  "Send end-of-file to the program being debugged."
  (interactive)
  (process-send-eof
   (get-buffer-process (gdb-get-instance-buffer 'gdba))))


;;
;; gdb communications
;;

(defun gdb-send-item (item)
  (set-gdb-instance-current-item item)
  (if (stringp item)
      (progn
	(set-gdb-instance-output-sink 'user)
	(process-send-string gdb-proc item))
    (progn
      (gdb-clear-partial-output)
      (set-gdb-instance-output-sink 'pre-emacs)
      (process-send-string gdb-proc (car item)))))

(defun gdb-pre-prompt (ignored)
  "An annotation handler for `pre-prompt'. This terminates the collection of
output from a previous command if that happens to be in effect."
  (let ((sink (gdb-instance-output-sink)))

			    (put-string "b" (point) "disabled"
					'left-margin)))))))))
	  (end-of-line))))))

(defun gdb-breakpoints-buffer-name ()
  (save-excursion
    (set-buffer (process-buffer gdb-proc))
    (concat "*breakpoints of " (gdb-instance-target-string) "*")))

(defun gdb-display-breakpoints-buffer ()
  (interactive)
  (gdb-display-buffer

\\{gdb-breakpoints-mode-map}"
  (setq major-mode 'gdb-breakpoints-mode)
  (setq mode-name "Breakpoints")
  (use-local-map gdb-breakpoints-mode-map)
  (set (make-local-variable 'gud-minor-mode) 'gdba)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
  (setq buffer-read-only t)
  (gdb-invalidate-breakpoints))

(defun gdb-toggle-bp-this-line ()
"Enable/disable the breakpoint on this line."

	'ignore))))

(defvar gdb-source-window nil)

(defun gdb-goto-bp-this-line ()
"Display the file at the specified breakpoint."
  (interactive)
  (save-excursion
    (beginning-of-line 1)
    (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+")
    (looking-at "\\(\\S-*\\):\\([0-9]+\\)"))
  (let ((line (match-string 2))
	(file (match-string 1)))
    (set-window-buffer gdb-source-window
		       (find-file-noselect
			(if (file-exists-p file)
			    file
			  (expand-file-name file gdb-cdir))))
    (goto-line (string-to-number line))))

;;
;; Frames buffers.  These display a perpetually correct bactracktrace
;; (from the command `where').
;;

			   (progn (end-of-line) (point))
			   'mouse-face 'highlight)
	(forward-line 1)))))

(defun gdb-stack-buffer-name ()
  (save-excursion
    (set-buffer (process-buffer gdb-proc))
    (concat "*stack frames of "
	    (gdb-instance-target-string) "*")))

(defun gdb-display-stack-buffer ()
  (interactive)

  "Major mode for gdb frames.

\\{gdb-frames-mode-map}"
  (setq major-mode 'gdb-frames-mode)
  (setq mode-name "Frames")
  (set (make-local-variable 'gud-minor-mode) 'gdba)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
  (setq buffer-read-only t)
  (use-local-map gdb-frames-mode-map)
  (gdb-invalidate-frames))

(defun gdb-get-frame-number ()

      (save-excursion
	(goto-char (posn-point (event-end e)))
	(setq selection (gdb-get-frame-number))))
    (select-window (posn-window (event-end e)))
    (save-excursion
      (set-buffer (gdb-get-instance-buffer 'gdba))
  (gdb-instance-enqueue-idle-input
   (list (gud-format-command "server frame %p\n" selection)
	 'ignore))
  (gud-display-frame))))

  "Major mode for gdb registers.

\\{gdb-registers-mode-map}"
  (setq major-mode 'gdb-registers-mode)
  (setq mode-name "Registers")
  (set (make-local-variable 'gud-minor-mode) 'gdba)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
  (setq buffer-read-only t)
  (use-local-map gdb-registers-mode-map)
  (gdb-invalidate-registers))

(defun gdb-registers-buffer-name ()
  (save-excursion
    (set-buffer (process-buffer gdb-proc))
    (concat "*registers of " (gdb-instance-target-string) "*")))

(defun gdb-display-registers-buffer ()
  (interactive)
  (gdb-display-buffer

					   (gdb-instance-pending-triggers)))
  (let ((buf (gdb-get-instance-buffer 'gdb-partial-output-buffer)))
    (save-excursion
      (set-buffer buf)
      (goto-char (point-min))
      (replace-regexp "^ .*\n" "")
      (goto-char (point-min))
      (replace-regexp "{[-0-9, {}\]*\n" "(array);\n")))
      (goto-char (point-min))
      (replace-regexp "{.*=.*\n" "(structure);\n")
  (let ((buf (gdb-get-instance-buffer 'gdb-locals-buffer)))
    (and buf (save-excursion
	       (set-buffer buf)
	       (let ((p (point))
		     (buffer-read-only nil))

  "Major mode for gdb locals.

\\{gdb-locals-mode-map}"
  (setq major-mode 'gdb-locals-mode)
  (setq mode-name "Locals")
  (set (make-local-variable 'gud-minor-mode) 'gdba)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
  (setq buffer-read-only t)
  (use-local-map gdb-locals-mode-map)
  (gdb-invalidate-locals))

(defun gdb-locals-buffer-name ()
  (save-excursion
    (set-buffer (process-buffer gdb-proc))
    (concat "*locals of " (gdb-instance-target-string) "*")))

(defun gdb-display-locals-buffer ()
  (interactive)
  (gdb-display-buffer

  "Major mode for gdb display.

\\{gdb-display-mode-map}"
  (setq major-mode 'gdb-display-mode)
  (setq mode-name "Display")
  (set (make-local-variable 'gud-minor-mode) 'gdba)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
  (setq buffer-read-only t)
  (use-local-map gdb-display-mode-map)
  (gdb-invalidate-display))

(defun gdb-display-buffer-name ()
  (save-excursion
    (set-buffer (process-buffer gdb-proc))
    (concat "*Displayed expressions of " (gdb-instance-target-string) "*")))

(defun gdb-display-display-buffer ()
  (interactive)
  (gdb-display-buffer

  "Major mode for viewing code assembler.

\\{gdb-assembler-mode-map}"
  (setq major-mode 'gdb-assembler-mode)
  (setq mode-name "Assembler")
  (set (make-local-variable 'gud-minor-mode) 'gdba)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
  (setq left-margin-width 2)
  (setq buffer-read-only t)
  (use-local-map gdb-assembler-mode-map)
  (gdb-invalidate-assembler)
  (gdb-invalidate-breakpoints))

(defun gdb-assembler-buffer-name ()
  (save-excursion
    (set-buffer (process-buffer gdb-proc))
    (concat "*Machine Code " (gdb-instance-target-string) "*")))

(defun gdb-display-assembler-buffer ()
  (interactive)
  (gdb-display-buffer

	       (not (string-equal gdb-main-or-pc gdb-prev-main-or-pc))))
      (progn

	;; take previous disassemble command off the queue
	(save-excursion
	  (set-buffer (gdb-get-instance-buffer 'gdba))
	  (let ((queue gdb-idle-input-queue) (item))
	    (while queue
	      (setq item (car queue))
	      (if (equal (cdr item) '(gdb-assembler-handler))
		  (delete item gdb-idle-input-queue))

48685:19bf840bede8

(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-first-time nil)

;;;###autoload
(defun gdba (command-line)
  "Run gdb on program FILE in buffer *gdb-FILE*.
The directory containing FILE becomes the initial working directory

  (setq gdb-main-or-pc "main")
  (setq gdb-current-address nil)
  (setq gdb-display-in-progress nil)
  (setq gdb-dive nil)

  (gdb-make-instance)
  (gdb-clear-inferior-io)

  ;; find source file and compilation directory here
  (gdb-instance-enqueue-idle-input (list "server list\n" 'ignore))

	 (name (intern (concat "gdb-" root))))
    `(progn
       (defvar ,name ,default ,doc)
       (if (not (memq ',name gdb-instance-variables))
	   (push ',name gdb-instance-variables))
       (defun ,accessor ()
	 (buffer-local-value ',name gud-comint-buffer))
       (defun ,setter (val)
	 (with-current-buffer gud-comint-buffer
	   (setq ,name val))))))

(def-gdb-var buffer-type nil
  "One of the symbols bound in gdb-instance-buffer-rules")

(def-gdb-var burst ""

  "A list of trigger functions that have run later than their output
handlers.")

(defun in-gdb-instance-context (form)
  "Funcall FORM in the GUD buffer."
  (with-current-buffer gud-comint-buffer
    (funcall form)))

;; end of instance vars

(defun gdb-make-instance ()
  "Create a gdb instance object from the current buffer."
  (mapc 'make-local-variable gdb-instance-variables)
  (setq gdb-buffer-type 'gdba))

(defun gdb-instance-target-string ()
  "The apparent name of the program being debugged by a gdb instance.
For sure this the root string used in smashing together the gdb
buffer's name, even if that doesn't happen to be the name of a

The key should be one of the cars in `gdb-instance-buffer-rules-assoc'."
  (or (gdb-get-instance-buffer key)
      (let* ((rules (assoc key gdb-instance-buffer-rules-assoc))
	     (name (funcall (gdb-rules-name-maker rules)))
	     (new (get-buffer-create name)))
	(with-current-buffer new
	  ;; FIXME: This should be set after calling the function, since the
	  ;; function should run kill-all-local-variables.
	  (set (make-local-variable 'gdb-buffer-type) key)
	  (if (cdr (cdr rules))
	      (funcall (car (cdr (cdr rules)))))
	  (set (make-local-variable 'gud-comint-buffer) gud-comint-buffer)
	  (set (make-local-variable 'gud-minor-mode) 'gdba)
	  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
	  new))))

(defun gdb-rules-name-maker (rules) (car (cdr rules)))

(defun gdb-look-for-tagged-buffer (key bufs)

(defun gdb-set-instance-buffer-rules (buffer-type &rest rules)
  (let ((binding (assoc buffer-type gdb-instance-buffer-rules-assoc)))
    (if binding
	(setcdr binding rules)
      (push (cons buffer-type rules)
	    gdb-instance-buffer-rules-assoc))))

;; GUD buffers are an exception to the rules
(gdb-set-instance-buffer-rules 'gdba 'error)

;;

  ;; features.  We don't need a process, but comint wants one, so create
  ;; a dummy one.
  (make-comint-in-buffer
   (substring (buffer-name) 1 (- (length (buffer-name)) 1))
   (current-buffer) "/bin/cat")
  (setq comint-input-sender 'gdb-inferior-io-sender))

(defun gdb-inferior-io-sender (proc string)
  ;; PROC is the pseudo-process created to satisfy comint.
  (with-current-buffer (process-buffer proc)
    (setq proc (get-buffer-process gud-comint-buffer))
    (process-send-string proc string)
    (process-send-string proc "\n")))

(defun gdb-inferior-io-interrupt ()
  "Interrupt the program being debugged."
  (interactive)
  (interrupt-process
   (get-buffer-process gud-comint-buffer) comint-ptyp))

(defun gdb-inferior-io-quit ()
  "Send quit signal to the program being debugged."
  (interactive)
  (quit-process
   (get-buffer-process gud-comint-buffer) comint-ptyp))

(defun gdb-inferior-io-stop ()
  "Stop the program being debugged."
  (interactive)
  (stop-process
   (get-buffer-process gud-comint-buffer) comint-ptyp))

(defun gdb-inferior-io-eof ()
  "Send end-of-file to the program being debugged."
  (interactive)
  (process-send-eof
   (get-buffer-process gud-comint-buffer)))


;;
;; gdb communications
;;

(defun gdb-send-item (item)
  (set-gdb-instance-current-item item)
  (if (stringp item)
      (progn
	(set-gdb-instance-output-sink 'user)
	(process-send-string (get-buffer-process gud-comint-buffer) item))
    (progn
      (gdb-clear-partial-output)
      (set-gdb-instance-output-sink 'pre-emacs)
      (process-send-string (get-buffer-process gud-comint-buffer)
			   (car item)))))

(defun gdb-pre-prompt (ignored)
  "An annotation handler for `pre-prompt'. This terminates the collection of
output from a previous command if that happens to be in effect."
  (let ((sink (gdb-instance-output-sink)))

			    (put-string "b" (point) "disabled"
					'left-margin)))))))))
	  (end-of-line))))))

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

(defun gdb-display-breakpoints-buffer ()
  (interactive)
  (gdb-display-buffer

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

(defun gdb-toggle-bp-this-line ()
"Enable/disable the breakpoint on this line."

	'ignore))))

(defvar gdb-source-window nil)

(defun gdb-goto-bp-this-line ()
  "Display the file at the specified breakpoint."
  (interactive)
  (save-excursion
    (beginning-of-line 1)
    (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+")
    (looking-at "\\(\\S-*\\):\\([0-9]+\\)"))
  (let ((line (match-string 2))
	(file (match-string 1)))
    (save-selected-window
      (select-window gdb-source-window)
      (switch-to-buffer (find-file-noselect
			 (if (file-exists-p file)
			     file
			   (expand-file-name file gdb-cdir))))
      (goto-line (string-to-number line)))))

;;
;; Frames buffers.  These display a perpetually correct bactracktrace
;; (from the command `where').
;;

			   (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-instance-target-string) "*")))

(defun gdb-display-stack-buffer ()
  (interactive)

  "Major mode for gdb frames.

\\{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
	(goto-char (posn-point (event-end e)))
	(setq selection (gdb-get-frame-number))))
    (select-window (posn-window (event-end e)))
    (save-excursion
      (set-buffer gud-comint-buffer)
  (gdb-instance-enqueue-idle-input
   (list (gud-format-command "server frame %p\n" selection)
	 'ignore))
  (gud-display-frame))))

  "Major mode for gdb registers.

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

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

(defun gdb-display-registers-buffer ()
  (interactive)
  (gdb-display-buffer

					   (gdb-instance-pending-triggers)))
  (let ((buf (gdb-get-instance-buffer 'gdb-partial-output-buffer)))
    (save-excursion
      (set-buffer buf)
      (goto-char (point-min))
      (while (re-search-forward "^ .*\n" nil t)
	(replace-match "" nil nil))
      (goto-char (point-min))
      (while (re-search-forward "{[-0-9, {}\]*\n" nil t)
	(replace-match "(array);\n" nil nil))
      (goto-char (point-min))
      (while (re-search-forward "{.*=.*\n" nil t)
	(replace-match "(structure);\n" nil nil))))
  (let ((buf (gdb-get-instance-buffer 'gdb-locals-buffer)))
    (and buf (save-excursion
	       (set-buffer buf)
	       (let ((p (point))
		     (buffer-read-only nil))

  "Major mode for gdb locals.

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

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

(defun gdb-display-locals-buffer ()
  (interactive)
  (gdb-display-buffer

  "Major mode for gdb display.

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

(defun gdb-display-buffer-name ()
  (with-current-buffer gud-comint-buffer
    (concat "*Displayed expressions of " (gdb-instance-target-string) "*")))

(defun gdb-display-display-buffer ()
  (interactive)
  (gdb-display-buffer

  "Major mode for viewing code assembler.

\\{gdb-assembler-mode-map}"
  (setq major-mode 'gdb-assembler-mode)
  (setq mode-name "Assembler")
  (setq left-margin-width 2)
  (setq buffer-read-only t)
  (use-local-map gdb-assembler-mode-map)
  (gdb-invalidate-assembler)
  (gdb-invalidate-breakpoints))

(defun gdb-assembler-buffer-name ()
  (with-current-buffer gud-comint-buffer
    (concat "*Machine Code " (gdb-instance-target-string) "*")))

(defun gdb-display-assembler-buffer ()
  (interactive)
  (gdb-display-buffer

	       (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))
	    (while queue
	      (setq item (car queue))
	      (if (equal (cdr item) '(gdb-assembler-handler))
		  (delete item gdb-idle-input-queue))