comparison lisp/gdb-ui.el @ 48662:d29870d63092

Fix up comment markers.

48661:b092bff770ec

  (local-set-key "\C-i" 'gud-gdb-complete-command)

  (setq comint-prompt-regexp "^(.*gdb[+]?) *")
  (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)
  (setq gud-last-last-frame nil)

  (run-hooks 'gdb-mode-hook)
  (setq gdb-proc (get-buffer-process (current-buffer)))
  (gdb-make-instance)
  (if gdb-first-time (gdb-clear-inferior-io))

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

(defun gud-break (arg)
  "Set breakpoint at current line or address."
  (interactive "p")
  (if (not (string-equal mode-name "Assembler"))
      (gud-call "break %f:%l" arg)
;else
    (save-excursion
      (beginning-of-line)
      (forward-char 2)
      (gud-call "break *%a" arg))))

(defun gud-remove (arg)
  "Remove breakpoint at current line or address."
  (interactive "p")
  (if (not (string-equal mode-name "Assembler"))
    (gud-call "clear %f:%l" arg)
;else
    (save-excursion
      (beginning-of-line)
      (forward-char 2)
      (gud-call "clear *%a" arg))))

(defun gud-display1 (expr)
  (goto-char (point-min))
    (if (re-search-forward "\*" nil t)
	(gdb-instance-enqueue-idle-input
	 (list (concat "server display* " expr "\n") 'ignore))
;else
      (gdb-instance-enqueue-idle-input
       (list (concat "server display " expr "\n") 'ignore))))


;; The completion process filter is installed temporarily to slurp the

	(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)

;;
;; partial-output buffers
;;

	   (let ((answer (car queue)))
	     (set-gdb-instance-idle-input-queue '())
	     answer)
	 (gdb-take-last-elt queue)))))

; Don't use this in general.
(defun gdb-take-last-elt (l)
  (if (cdr (cdr l))
      (gdb-take-last-elt (cdr l))
    (let ((answer (car (cdr l))))
      (setcdr l '())

    ("display-begin" gdb-display-begin)
    ("display-end" gdb-display-end)
    ("display-number-end" gdb-display-number-end)
    ("array-section-begin" gdb-array-section-begin)
    ("array-section-end" gdb-array-section-end)
;    ("elt" gdb-elt)
    ("field-begin" gdb-field-begin)
    ("field-end" gdb-field-end)
    ) "An assoc mapping annotation tags to functions which process them.")

(defun gdb-ignore-annotation (args)

	(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-prompt (ignored)
  "An annotation handler for `prompt'. 
This sends the next command (if any) to gdb."

  (goto-char (point-min))
  (search-forward ": ")
  (looking-at "\\(.*?\\) =")
  (let ((char "")
	(gdb-temp-value (match-string 1)))
;move * to front of expression if necessary
    (if (looking-at ".*\\*")
	(progn
	  (setq char "*")
	  (setq gdb-temp-value (substring gdb-temp-value 1 nil))))
    (save-excursion
      (set-buffer gdb-expression-buffer-name)
      (setq gdb-expression gdb-temp-value)
      (if (not (string-match "::" gdb-expression))
	  (setq gdb-expression (concat char gdb-current-frame
				       "::" gdb-expression))
;else put * back on if necessary
	(setq gdb-expression (concat char gdb-expression)))
      (setq header-line-format (concat "-- " gdb-expression " %-"))))

;-if scalar/string
  (if (not (re-search-forward "##" nil t))
      (progn
	(save-excursion
	  (set-buffer gdb-expression-buffer-name)
	  (setq buffer-read-only nil)
	  (delete-region (point-min) (point-max))
	  (insert-buffer (gdb-get-instance-buffer 'gdb-partial-output-buffer))
	  (setq buffer-read-only t)))
; else
; display expression name...
    (goto-char (point-min))
    (let ((start (progn (point)))
	  (end (progn (end-of-line) (point))))
      (save-excursion
	(set-buffer gdb-expression-buffer-name)

(define-button-type 'gdb-display-back
  'help-echo (purecopy "mouse-2, RET: go back to previous display buffer")
  'action (lambda (button) (gdb-display-go-back)))

(defun gdb-display-go-back ()
  ; delete display so they don't accumulate and delete buffer
  (let ((number gdb-display-number))
    (gdb-instance-enqueue-idle-input
     (list (concat "server delete display " number "\n") 'ignore))
    (switch-to-buffer (concat "*display " gdb-dive-display-number "*"))
    (kill-buffer (get-buffer (concat "*display " number "*")))))

; prefix annotations with ## and process whole output in one chunk
; in gdb-partial-output-buffer (to allow recursion).

; array-section flags are just removed again but after counting. They
; might also be useful for arrays of structures and structures with arrays.
(defun gdb-array-section-begin (args)
  (if gdb-display-in-progress
      (progn
	(save-excursion
	  (set-buffer (gdb-get-instance-buffer 'gdb-partial-output-buffer))

      (progn
	(goto-char (point-max))
	(insert "\n##elt\n"))))

(defun gdb-field-format-begin ()
; get rid of ##field-begin
	(gdb-delete-line)
	(gdb-insert-field)
	(setq gdb-nesting-level (+ gdb-nesting-level 1))
	(while (re-search-forward "##" nil t)
; keep making recursive calls...
	  (if (looking-at "field-begin \\(.\\)")
	      (progn
		(setq gdb-annotation-arg (match-string 1))
		(gdb-field-format-begin)))
; until field-end.
	  (if (looking-at "field-end") (gdb-field-format-end))))

(defun gdb-field-format-end ()
; get rid of ##field-end and `,' or `}'
  (gdb-delete-line)
  (gdb-delete-line)
  (setq gdb-nesting-level (- gdb-nesting-level 1)))

(defvar gdb-dive-map

(defvar gdb-values)

(defun gdb-array-format ()
  (while (re-search-forward "##" nil t)
; keep making recursive calls...
    (if (looking-at "array-section-begin")
	(progn
;get rid of ##array-section-begin
	  (gdb-delete-line)
	  (setq gdb-nesting-level (+ gdb-nesting-level 1))
	  (gdb-array-format)))
;until *matching* array-section-end is found
    (if (looking-at "array-section-end")
	(if (eq gdb-nesting-level 0)
	    (progn
	      (let ((values (buffer-substring gdb-point (- (point) 2))))
		(save-excursion
		  (set-buffer gdb-expression-buffer-name)
		  (setq gdb-values
			(concat "{" (replace-regexp-in-string "\n" "" values)
				"}"))
		  (gdb-array-format1))))
;else get rid of ##array-section-end etc
	  (gdb-delete-line)
	  (setq gdb-nesting-level (- gdb-nesting-level 1))
	  (gdb-array-format)))))

(defvar gdb-array-start)

(defvar gdb-cdir nil "Compilation directory.")
(defvar breakpoint-enabled-icon) 
(defvar breakpoint-disabled-icon)

;-put breakpoint icons in relevant margins (even those set in the GUD buffer)
(defun gdb-info-breakpoints-custom ()
  (let ((flag)(address))

    ;; remove all breakpoint-icons in source buffers but not assembler buffer
    (let ((buffers (buffer-list)))

  "server info locals\n"
  gdb-info-locals-handler
  gdb-info-locals-custom)


;Abbreviate for arrays and structures. These can be expanded using gud-display
(defun gdb-info-locals-handler nil
  (set-gdb-instance-pending-triggers (delq 'gdb-invalidate-locals
					   (gdb-instance-pending-triggers)))
  (let ((buf (gdb-get-instance-buffer 'gdb-partial-output-buffer)))
    (save-excursion

  "server info display\n"
  gdb-info-display-handler
  gdb-info-display-custom)

(defun gdb-info-display-custom ()
; TODO: ensure frames of expressions that have been deleted are also deleted
;       these can be missed currently eg through GUD buffer, restarting a
;       recompiled program.
)

(defvar gdb-display-mode-map
  (let ((map (make-sparse-keymap))
	(menu (make-sparse-keymap "Display")))
    (define-key menu [toggle] '("Toggle" . gdb-toggle-disp-this-line))

	(gdb-instance-enqueue-idle-input
	 (list (concat "server delete display " number "\n")
	       'ignore))
	(if (not (display-graphic-p))
	    (kill-buffer (get-buffer (concat "*display " number "*")))
	  ;else
	  (catch 'frame-found
	    (let ((frames (frame-list)))
	      (while frames
		(if (string-equal (frame-parameter (car frames) 'name)
				  (concat "*display " number "*"))

  (if gdb-many-windows
      (progn
	(switch-to-buffer gud-comint-buffer)
	(delete-other-windows)
	(gdb-setup-windows))
;else
    (switch-to-buffer gud-comint-buffer)
    (delete-other-windows)
    (split-window)
    (other-window 1)
    (switch-to-buffer

      (other-window 1)
      (switch-to-buffer (gud-find-file gdb-main-file))
      (other-window 1)
      (setq gdb-source-window (get-buffer-window (current-buffer))))))

;from put-image
(defun put-string (putstring pos &optional string area)
  "Put string PUTSTRING in front of POS in the current buffer.
PUTSTRING is displayed by putting an overlay into the current buffer with a
`before-string' STRING that has a `display' property whose value is
PUTSTRING.  STRING is defaulted if you omit it.

	  (prop (if (null area) putstring (list (list 'margin area) putstring))))
      (put-text-property 0 (length string) 'display prop string)
      (overlay-put overlay 'put-text t)
      (overlay-put overlay 'before-string string))))

;from remove-images
(defun remove-strings (start end &optional buffer)
  "Remove strings between START and END in BUFFER.
Remove only images that were put in BUFFER with calls to `put-string'.
BUFFER nil or omitted means use the current buffer."
  (unless buffer

	    (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))))

	(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))

  (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-instance-buffer 'gdb-assembler-buffer)
	   (or (not (member 'gdb-invalidate-assembler
			    (gdb-instance-pending-triggers)))
	       (not (string-equal gdb-main-or-pc gdb-prev-main-or-pc))))

48662:d29870d63092

  (local-set-key "\C-i" 'gud-gdb-complete-command)

  (setq comint-prompt-regexp "^(.*gdb[+]?) *")
  (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)
  (setq gud-last-last-frame nil)

  (run-hooks 'gdb-mode-hook)
  (setq gdb-proc (get-buffer-process (current-buffer)))
  (gdb-make-instance)
  (if gdb-first-time (gdb-clear-inferior-io))

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

(defun gud-break (arg)
  "Set breakpoint at current line or address."
  (interactive "p")
  (if (not (string-equal mode-name "Assembler"))
      (gud-call "break %f:%l" arg)
    (save-excursion
      (beginning-of-line)
      (forward-char 2)
      (gud-call "break *%a" arg))))

(defun gud-remove (arg)
  "Remove breakpoint at current line or address."
  (interactive "p")
  (if (not (string-equal mode-name "Assembler"))
      (gud-call "clear %f:%l" arg)
    (save-excursion
      (beginning-of-line)
      (forward-char 2)
      (gud-call "clear *%a" arg))))

(defun gud-display1 (expr)
  (goto-char (point-min))
    (if (re-search-forward "\*" nil t)
	(gdb-instance-enqueue-idle-input
	 (list (concat "server display* " expr "\n") 'ignore))
      (gdb-instance-enqueue-idle-input
       (list (concat "server display " expr "\n") 'ignore))))


;; The completion process filter is installed temporarily to slurp the

	(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)

;;
;; partial-output buffers
;;

	   (let ((answer (car queue)))
	     (set-gdb-instance-idle-input-queue '())
	     answer)
	 (gdb-take-last-elt queue)))))

;; Don't use this in general.
(defun gdb-take-last-elt (l)
  (if (cdr (cdr l))
      (gdb-take-last-elt (cdr l))
    (let ((answer (car (cdr l))))
      (setcdr l '())

    ("display-begin" gdb-display-begin)
    ("display-end" gdb-display-end)
    ("display-number-end" gdb-display-number-end)
    ("array-section-begin" gdb-array-section-begin)
    ("array-section-end" gdb-array-section-end)
    ;; ("elt" gdb-elt)
    ("field-begin" gdb-field-begin)
    ("field-end" gdb-field-end)
    ) "An assoc mapping annotation tags to functions which process them.")

(defun gdb-ignore-annotation (args)

	(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-prompt (ignored)
  "An annotation handler for `prompt'. 
This sends the next command (if any) to gdb."

  (goto-char (point-min))
  (search-forward ": ")
  (looking-at "\\(.*?\\) =")
  (let ((char "")
	(gdb-temp-value (match-string 1)))
    ;;move * to front of expression if necessary
    (if (looking-at ".*\\*")
	(progn
	  (setq char "*")
	  (setq gdb-temp-value (substring gdb-temp-value 1 nil))))
    (save-excursion
      (set-buffer gdb-expression-buffer-name)
      (setq gdb-expression gdb-temp-value)
      (if (not (string-match "::" gdb-expression))
	  (setq gdb-expression (concat char gdb-current-frame
				       "::" gdb-expression))
	;;else put * back on if necessary
	(setq gdb-expression (concat char gdb-expression)))
      (setq header-line-format (concat "-- " gdb-expression " %-"))))

  ;;-if scalar/string
  (if (not (re-search-forward "##" nil t))
      (progn
	(save-excursion
	  (set-buffer gdb-expression-buffer-name)
	  (setq buffer-read-only nil)
	  (delete-region (point-min) (point-max))
	  (insert-buffer (gdb-get-instance-buffer 'gdb-partial-output-buffer))
	  (setq buffer-read-only t)))
    ;; display expression name...
    (goto-char (point-min))
    (let ((start (progn (point)))
	  (end (progn (end-of-line) (point))))
      (save-excursion
	(set-buffer gdb-expression-buffer-name)

(define-button-type 'gdb-display-back
  'help-echo (purecopy "mouse-2, RET: go back to previous display buffer")
  'action (lambda (button) (gdb-display-go-back)))

(defun gdb-display-go-back ()
  ;; delete display so they don't accumulate and delete buffer
  (let ((number gdb-display-number))
    (gdb-instance-enqueue-idle-input
     (list (concat "server delete display " number "\n") 'ignore))
    (switch-to-buffer (concat "*display " gdb-dive-display-number "*"))
    (kill-buffer (get-buffer (concat "*display " number "*")))))

;; prefix annotations with ## and process whole output in one chunk
;; in gdb-partial-output-buffer (to allow recursion).

;; array-section flags are just removed again but after counting. They
;; might also be useful for arrays of structures and structures with arrays.
(defun gdb-array-section-begin (args)
  (if gdb-display-in-progress
      (progn
	(save-excursion
	  (set-buffer (gdb-get-instance-buffer 'gdb-partial-output-buffer))

      (progn
	(goto-char (point-max))
	(insert "\n##elt\n"))))

(defun gdb-field-format-begin ()
  ;; get rid of ##field-begin
  (gdb-delete-line)
  (gdb-insert-field)
  (setq gdb-nesting-level (+ gdb-nesting-level 1))
  (while (re-search-forward "##" nil t)
    ;; keep making recursive calls...
    (if (looking-at "field-begin \\(.\\)")
	(progn
	  (setq gdb-annotation-arg (match-string 1))
	  (gdb-field-format-begin)))
    ;; until field-end.
    (if (looking-at "field-end") (gdb-field-format-end))))

(defun gdb-field-format-end ()
  ;; get rid of ##field-end and `,' or `}'
  (gdb-delete-line)
  (gdb-delete-line)
  (setq gdb-nesting-level (- gdb-nesting-level 1)))

(defvar gdb-dive-map

(defvar gdb-values)

(defun gdb-array-format ()
  (while (re-search-forward "##" nil t)
    ;; keep making recursive calls...
    (if (looking-at "array-section-begin")
	(progn
	  ;;get rid of ##array-section-begin
	  (gdb-delete-line)
	  (setq gdb-nesting-level (+ gdb-nesting-level 1))
	  (gdb-array-format)))
    ;;until *matching* array-section-end is found
    (if (looking-at "array-section-end")
	(if (eq gdb-nesting-level 0)
	    (progn
	      (let ((values (buffer-substring gdb-point (- (point) 2))))
		(save-excursion
		  (set-buffer gdb-expression-buffer-name)
		  (setq gdb-values
			(concat "{" (replace-regexp-in-string "\n" "" values)
				"}"))
		  (gdb-array-format1))))
	  ;;else get rid of ##array-section-end etc
	  (gdb-delete-line)
	  (setq gdb-nesting-level (- gdb-nesting-level 1))
	  (gdb-array-format)))))

(defvar gdb-array-start)

(defvar gdb-cdir nil "Compilation directory.")
(defvar breakpoint-enabled-icon) 
(defvar breakpoint-disabled-icon)

;;-put breakpoint icons in relevant margins (even those set in the GUD buffer)
(defun gdb-info-breakpoints-custom ()
  (let ((flag)(address))

    ;; remove all breakpoint-icons in source buffers but not assembler buffer
    (let ((buffers (buffer-list)))

  "server info locals\n"
  gdb-info-locals-handler
  gdb-info-locals-custom)


;;Abbreviate for arrays and structures. These can be expanded using gud-display
(defun gdb-info-locals-handler nil
  (set-gdb-instance-pending-triggers (delq 'gdb-invalidate-locals
					   (gdb-instance-pending-triggers)))
  (let ((buf (gdb-get-instance-buffer 'gdb-partial-output-buffer)))
    (save-excursion

  "server info display\n"
  gdb-info-display-handler
  gdb-info-display-custom)

(defun gdb-info-display-custom ()
  ;; TODO: ensure frames of expressions that have been deleted are also deleted
  ;;       these can be missed currently eg through GUD buffer, restarting a
  ;;       recompiled program.
  )

(defvar gdb-display-mode-map
  (let ((map (make-sparse-keymap))
	(menu (make-sparse-keymap "Display")))
    (define-key menu [toggle] '("Toggle" . gdb-toggle-disp-this-line))

	(gdb-instance-enqueue-idle-input
	 (list (concat "server delete display " number "\n")
	       'ignore))
	(if (not (display-graphic-p))
	    (kill-buffer (get-buffer (concat "*display " number "*")))
	  (catch 'frame-found
	    (let ((frames (frame-list)))
	      (while frames
		(if (string-equal (frame-parameter (car frames) 'name)
				  (concat "*display " number "*"))

  (if gdb-many-windows
      (progn
	(switch-to-buffer gud-comint-buffer)
	(delete-other-windows)
	(gdb-setup-windows))
    (switch-to-buffer gud-comint-buffer)
    (delete-other-windows)
    (split-window)
    (other-window 1)
    (switch-to-buffer

      (other-window 1)
      (switch-to-buffer (gud-find-file gdb-main-file))
      (other-window 1)
      (setq gdb-source-window (get-buffer-window (current-buffer))))))

;;from put-image
(defun put-string (putstring pos &optional string area)
  "Put string PUTSTRING in front of POS in the current buffer.
PUTSTRING is displayed by putting an overlay into the current buffer with a
`before-string' STRING that has a `display' property whose value is
PUTSTRING.  STRING is defaulted if you omit it.

	  (prop (if (null area) putstring (list (list 'margin area) putstring))))
      (put-text-property 0 (length string) 'display prop string)
      (overlay-put overlay 'put-text t)
      (overlay-put overlay 'before-string string))))

;;from remove-images
(defun remove-strings (start end &optional buffer)
  "Remove strings between START and END in BUFFER.
Remove only images that were put in BUFFER with calls to `put-string'.
BUFFER nil or omitted means use the current buffer."
  (unless buffer

	    (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))))

	(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))

  (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-instance-buffer 'gdb-assembler-buffer)
	   (or (not (member 'gdb-invalidate-assembler
			    (gdb-instance-pending-triggers)))
	       (not (string-equal gdb-main-or-pc gdb-prev-main-or-pc))))