comparison lisp/progmodes/gdb-mi.el @ 104148:3bbb840267e1

(gdb-add-pending, gdb-pending-p, gdb-delete-pending): Macros to handle pending triggers. (gdb-threads-mode-map, def-gdb-thread-buffer-command) (def-gdb-thread-buffer-simple-command) (gdb-display-stack-for-thread, gdb-display-locals-for-thread) (gdb-display-registers-for-thread, gdb-frame-stack-for-thread) (gdb-frame-locals-for-thread, gdb-frame-registers-for-thread): New commands which show buffers bound to thread. (gdb-stack-list-locals-regexp): Removed unused regexp.

104147:9629847b09ed

	       for subsequent processing by a command.  This is the
	       disposition of output generated by commands that
	       gdb mode sends to gdb on its own behalf.")

(defvar gdb-pending-triggers '()
  "A list of trigger functions that have run later than their output handlers.")

(defcustom gdb-debug-log-max 128
  "Maximum size of `gdb-debug-log'.  If nil, size is unlimited."
  :group 'gdb
  :type '(choice (integer :tag "Number of elements")

		       ,(car var) nil)))))
    (message-box "No symbol \"%s\" in current context." expr)))

(defun gdb-speedbar-update ()
  (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)
	     (not (member 'gdb-speedbar-timer gdb-pending-triggers)))
    ;; Dummy command to update speedbar even when idle.
    (gdb-input (list "-environment-pwd" 'gdb-speedbar-timer-fn))
    ;; Keep gdb-pending-triggers non-nil till end.
    (push 'gdb-speedbar-timer gdb-pending-triggers)))

(defun gdb-speedbar-timer-fn ()
  (if gdb-speedbar-auto-raise
      (raise-frame speedbar-frame))
  (setq gdb-pending-triggers
	(delq 'gdb-speedbar-timer gdb-pending-triggers))
  (speedbar-timer-fn))

(defun gdb-var-evaluate-expression-handler (varnum changed)
  (goto-char (point-min))
  (re-search-forward ".*value=\\(\".*\"\\)" nil t)

  (if (re-search-forward gdb-error-regexp nil t)
      (message-box "Invalid number or expression (%s)" value)))

; Uses "-var-update --all-values".  Needs GDB 6.4 onwards.
(defun gdb-var-update ()
  (if (not (member 'gdb-var-update gdb-pending-triggers))
      (gdb-input
       (list "-var-update --all-values *" 'gdb-var-update-handler)))
  (push 'gdb-var-update gdb-pending-triggers))

(defconst gdb-var-update-regexp
  "{.*?name=\"\\(.*?\\)\".*?,\\(?:value=\\(\".*?\"\\),\\)?.*?\
in_scope=\"\\(.*?\\)\".*?}")

		 (setcar (nthcdr 5 var) 'changed)
		 (setcar (nthcdr 4 var)
			 (read (match-string 2))))
		((string-equal match "invalid")
		 (gdb-var-delete-1 varnum)))))))
  (setq gdb-pending-triggers
   (delq 'gdb-var-update gdb-pending-triggers))
  (gdb-speedbar-update))

(defun gdb-speedbar-expand-node (text token indent)
  "Expand the node the user clicked on.
TEXT is the text of the button we clicked on, a + or - item.

(defun gdb-get-buffer (key &optional thread)
  "Get a specific GDB buffer.

In that buffer, `gdb-buffer-type' must be equal to KEY and
`gdb-thread-number' (if provided) must be equal to THREAD."
  (catch 'found
    (dolist (buffer (buffer-list) nil)
      (with-current-buffer buffer
        (when (and (eq gdb-buffer-type key)
                   (or (not thread)
                       (equal gdb-thread-number thread)))
          (throw 'found buffer))))))

(defun gdb-get-buffer-create (key &optional thread)
  "Create a new GDB buffer of the type specified by KEY.
The key should be one of the cars in `gdb-buffer-rules'.

  (setcar item (concat (number-to-string gdb-token-number) (car item)))
  (push (cons gdb-token-number (car (cdr item))) gdb-handler-alist)
  (process-send-string (get-buffer-process gud-comint-buffer)
		       (concat (car item) "\n")))

(defmacro gdb-current-context-command (command)
  "Add --thread option to gdb COMMAND.

Option value is taken from `gdb-thread-number'."
  (concat command " --thread " gdb-thread-number))


(defcustom gud-gdb-command-name "gdb -i=mi"
  "Default command to execute an executable under the GDB debugger."
  :type 'string

;; See how it's done in gdb-get-buffer-create.

(defmacro def-gdb-auto-update-trigger (trigger-name gdb-command
                                                    handler-name)
  `(defun ,trigger-name (&optional signal)
     (if (not (member (cons (current-buffer) ',trigger-name)
                      gdb-pending-triggers))
         (progn
           (gdb-input
            (list ,gdb-command
                  (gdb-bind-function-to-buffer ',handler-name (current-buffer))))
           (push (cons (current-buffer) ',trigger-name) gdb-pending-triggers)))))

;; Used by disassembly buffer only, the rest use
;; def-gdb-trigger-and-handler
(defmacro def-gdb-auto-update-handler (handler-name trigger-name custom-defun)
  "Define a handler HANDLER-NAME for TRIGGER-NAME with CUSTOM-DEFUN.

Delete ((current-buffer) . TRIGGER) from `gdb-pending-triggers',
erase current buffer and evaluate CUSTOM-DEFUN."
  `(defun ,handler-name ()
     (setq gdb-pending-triggers
           (delq (cons (current-buffer) ',trigger-name)
                 gdb-pending-triggers))
     (let* ((buffer-read-only nil))
       (erase-buffer)
       (,custom-defun)
       (gdb-update-buffer-name))))

 'gdb-breakpoints-buffer-name 
 'gdb-breakpoints-mode
 'gdb-invalidate-breakpoints)

(defun gdb-breakpoints-list-handler-custom ()
  (setq gdb-pending-triggers (delq 'gdb-invalidate-breakpoints
				  gdb-pending-triggers))
  (let ((breakpoints-list (gdb-get-field 
                           (json-partial-output "bkpt" "script")
                           'BreakpointTable 'body)))
    (setq gdb-breakpoints-list breakpoints-list)
    (insert "Num\tType\t\tDisp\tEnb\tHits\tAddr       What\n")

  "Font lock keywords used in `gdb-threads-mode'.")

(defvar gdb-threads-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map " " 'gdb-select-thread)
    map))

(defvar gdb-breakpoints-header
  (list
   (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer

      (when (string-equal gdb-thread-number
                          (gdb-get-field thread 'id))
        (set-marker gdb-thread-position (line-beginning-position)))
      (newline))))

(defun gdb-select-thread ()
  "Select the thread at current line of threads buffer."
  (interactive)
  (save-excursion
  (beginning-of-line)
  (let ((thread (get-text-property (point) 'gdb-thread)))
    (if thread
        (if (string-equal (gdb-get-field thread 'state) "running")
            (error "Cannot select running thread")
          (let ((new-id (gdb-get-field thread 'id)))
            (setq gdb-thread-number new-id)
            (gud-basic-call (concat "-thread-select " new-id))))
      (error "Not recognized as thread line")))))


;;; Memory view

(defcustom gdb-memory-rows 8

                   (put-text-property bl (+ bl 4)
                                      'face '(:inverse-video t)))))
             (forward-line 1)))))

(defun gdb-stack-buffer-name ()
  (concat "*stack frames of " (gdb-get-target-string) " (thread " gdb-thread-number ")*"))

(def-gdb-display-buffer
 gdb-display-stack-buffer
 'gdb-stack-buffer
 "Display backtrace of current stack.")

(gdb-set-buffer-rules
 'gdb-locals-buffer
 'gdb-locals-buffer-name
 'gdb-locals-mode
 'gdb-invalidate-locals)

(defconst gdb-stack-list-locals-regexp
  (concat "name=\"\\(.*?\\)\",type=\"\\(.*?\\)\""))

(defvar gdb-locals-watch-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    (define-key map "\r" 'gud-watch)

       '(gdb-locals-font-lock-keywords))
  (run-mode-hooks 'gdb-locals-mode-hook)
  'gdb-invalidate-locals)

(defun gdb-locals-buffer-name ()
  (concat "*locals of " (gdb-get-target-string) "*"))

(def-gdb-display-buffer
 gdb-display-locals-buffer
 'gdb-locals-buffer
 "Display local variables of current stack and their values.")

  (use-local-map gdb-registers-mode-map)
  (run-mode-hooks 'gdb-registers-mode-hook)
  'gdb-invalidate-registers)

(defun gdb-registers-buffer-name ()
  (concat "*registers of " (gdb-get-target-string) "*"))

(def-gdb-display-buffer
 gdb-display-registers-buffer
 'gdb-registers-buffer
 "Display integer register contents.")

  "Display integer register contents in a new frame.")

;; Needs GDB 6.4 onwards (used to fail with no stack).
(defun gdb-get-changed-registers ()
  (if (and (gdb-get-buffer 'gdb-registers-buffer)
	   (not (member 'gdb-get-changed-registers gdb-pending-triggers)))
      (progn
	(gdb-input
	 (list
	  "-data-list-changed-registers"
	  'gdb-changed-registers-handler))
	(push 'gdb-get-changed-registers gdb-pending-triggers))))

(defun gdb-changed-registers-handler ()
  (setq gdb-pending-triggers
        (delq 'gdb-get-changed-registers gdb-pending-triggers))
  (setq gdb-changed-registers nil)
  (dolist (register-number (gdb-get-field (json-partial-output) 'changed-registers))
    (push register-number gdb-changed-registers)))

(defun gdb-register-names-handler ()

	(gdb-init-buffer))))
  (gdb-force-mode-line-update
   (propertize "ready" 'face font-lock-variable-name-face)))

(defun gdb-get-selected-frame ()
  (if (not (member 'gdb-get-selected-frame gdb-pending-triggers))
      (progn
	(gdb-input
	 (list (gdb-current-context-command "-stack-info-frame") 'gdb-frame-handler))
	(push 'gdb-get-selected-frame
	       gdb-pending-triggers))))

(defun gdb-frame-handler ()
  (setq gdb-pending-triggers
	(delq 'gdb-get-selected-frame gdb-pending-triggers))
  (let ((frame (gdb-get-field (json-partial-output) 'frame)))
    (when frame
      (setq gdb-frame-number (gdb-get-field frame 'level))
      (setq gdb-pc-address (gdb-get-field frame 'addr))
      (setq gdb-selected-frame (gdb-get-field frame 'func))

104148:3bbb840267e1

	       for subsequent processing by a command.  This is the
	       disposition of output generated by commands that
	       gdb mode sends to gdb on its own behalf.")

(defvar gdb-pending-triggers '()
  "A list of trigger functions which have not yet been handled.

Elements are either function names or pairs (buffer . function)")

(defmacro gdb-add-pending (item)
  `(push ,item gdb-pending-triggers))
(defmacro gdb-pending-p (item)
  `(member ,item gdb-pending-triggers))
(defmacro gdb-delete-pending (item)
  `(setq gdb-pending-triggers
         (delete ,item gdb-pending-triggers)))

(defcustom gdb-debug-log-max 128
  "Maximum size of `gdb-debug-log'.  If nil, size is unlimited."
  :group 'gdb
  :type '(choice (integer :tag "Number of elements")

		       ,(car var) nil)))))
    (message-box "No symbol \"%s\" in current context." expr)))

(defun gdb-speedbar-update ()
  (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)
	     (not (gdb-pending-p 'gdb-speedbar-timer)))
    ;; Dummy command to update speedbar even when idle.
    (gdb-input (list "-environment-pwd" 'gdb-speedbar-timer-fn))
    ;; Keep gdb-pending-triggers non-nil till end.
    (gdb-add-pending 'gdb-speedbar-timer)))

(defun gdb-speedbar-timer-fn ()
  (if gdb-speedbar-auto-raise
      (raise-frame speedbar-frame))
  (gdb-delete-pending 'gdb-speedbar-timer)
  (speedbar-timer-fn))

(defun gdb-var-evaluate-expression-handler (varnum changed)
  (goto-char (point-min))
  (re-search-forward ".*value=\\(\".*\"\\)" nil t)

  (if (re-search-forward gdb-error-regexp nil t)
      (message-box "Invalid number or expression (%s)" value)))

; Uses "-var-update --all-values".  Needs GDB 6.4 onwards.
(defun gdb-var-update ()
  (if (not (gdb-pending-p 'gdb-var-update))
      (gdb-input
       (list "-var-update --all-values *" 'gdb-var-update-handler)))
  (gdb-add-pending 'gdb-var-update))

(defconst gdb-var-update-regexp
  "{.*?name=\"\\(.*?\\)\".*?,\\(?:value=\\(\".*?\"\\),\\)?.*?\
in_scope=\"\\(.*?\\)\".*?}")

		 (setcar (nthcdr 5 var) 'changed)
		 (setcar (nthcdr 4 var)
			 (read (match-string 2))))
		((string-equal match "invalid")
		 (gdb-var-delete-1 varnum)))))))
  (gdb-delete-pending 'gdb-var-update)
  (gdb-speedbar-update))

(defun gdb-speedbar-expand-node (text token indent)
  "Expand the node the user clicked on.
TEXT is the text of the button we clicked on, a + or - item.

(defun gdb-get-buffer (key &optional thread)
  "Get a specific GDB buffer.

In that buffer, `gdb-buffer-type' must be equal to KEY and
`gdb-thread-number' (if provided) must be equal to THREAD.

When THREAD is nil, global `gdb-thread-number' value is used."
  (when (not thread) (setq thread gdb-thread-number))
  (catch 'found
    (dolist (buffer (buffer-list) nil)
      (with-current-buffer buffer
        (when (and (eq gdb-buffer-type key)
                   (equal gdb-thread-number thread))
          (throw 'found buffer))))))

(defun gdb-get-buffer-create (key &optional thread)
  "Create a new GDB buffer of the type specified by KEY.
The key should be one of the cars in `gdb-buffer-rules'.

  (setcar item (concat (number-to-string gdb-token-number) (car item)))
  (push (cons gdb-token-number (car (cdr item))) gdb-handler-alist)
  (process-send-string (get-buffer-process gud-comint-buffer)
		       (concat (car item) "\n")))

(defun gdb-current-context-command (command)
  "Add --thread option to gdb COMMAND.

Option value is taken from `gdb-thread-number'."
  (concat command " --thread " gdb-thread-number))

(defun gdb-current-context-buffer-name (name)
  "Add thread information and asterisks to string NAME."
  (concat "*" name
          (if (local-variable-p 'gdb-thread-number) 
              " (bound to thread "
            " (current thread ")
          gdb-thread-number ")*"))


(defcustom gud-gdb-command-name "gdb -i=mi"
  "Default command to execute an executable under the GDB debugger."
  :type 'string

;; See how it's done in gdb-get-buffer-create.

(defmacro def-gdb-auto-update-trigger (trigger-name gdb-command
                                                    handler-name)
  `(defun ,trigger-name (&optional signal)
     (if (not (gdb-pending-p
               (cons (current-buffer) ',trigger-name)))
         (progn
           (gdb-input
            (list ,gdb-command
                  (gdb-bind-function-to-buffer ',handler-name (current-buffer))))
           (gdb-add-pending (cons (current-buffer) ',trigger-name))))))

;; Used by disassembly buffer only, the rest use
;; def-gdb-trigger-and-handler
(defmacro def-gdb-auto-update-handler (handler-name trigger-name custom-defun)
  "Define a handler HANDLER-NAME for TRIGGER-NAME with CUSTOM-DEFUN.

Delete ((current-buffer) . TRIGGER) from `gdb-pending-triggers',
erase current buffer and evaluate CUSTOM-DEFUN."
  `(defun ,handler-name ()
     (gdb-delete-pending (cons (current-buffer) ',trigger-name))
     (let* ((buffer-read-only nil))
       (erase-buffer)
       (,custom-defun)
       (gdb-update-buffer-name))))

 'gdb-breakpoints-buffer-name 
 'gdb-breakpoints-mode
 'gdb-invalidate-breakpoints)

(defun gdb-breakpoints-list-handler-custom ()
  (let ((breakpoints-list (gdb-get-field 
                           (json-partial-output "bkpt" "script")
                           'BreakpointTable 'body)))
    (setq gdb-breakpoints-list breakpoints-list)
    (insert "Num\tType\t\tDisp\tEnb\tHits\tAddr       What\n")

  "Font lock keywords used in `gdb-threads-mode'.")

(defvar gdb-threads-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map " " 'gdb-select-thread)
    (define-key map "s" 'gdb-display-stack-for-thread)
    (define-key map "S" 'gdb-frame-stack-for-thread)
    (define-key map "l" 'gdb-display-locals-for-thread)
    (define-key map "L" 'gdb-frame-locals-for-thread)
    (define-key map "r" 'gdb-display-registers-for-thread)
    (define-key map "R" 'gdb-frame-registers-for-thread)
    map))

(defvar gdb-breakpoints-header
  (list
   (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer

      (when (string-equal gdb-thread-number
                          (gdb-get-field thread 'id))
        (set-marker gdb-thread-position (line-beginning-position)))
      (newline))))

(defmacro def-gdb-thread-buffer-command (name custom-defun &optional doc)
  "Define a NAME command which will act upon thread on the current line.

CUSTOM-DEFUN may use locally bound `thread' variable, which will
be the value of 'gdb-thread propery of the current line. If
'gdb-thread is nil, error is signaled."
  `(defun ,name ()
     ,(when doc doc)
     (interactive)
     (save-excursion
       (beginning-of-line)
       (let ((thread (get-text-property (point) 'gdb-thread)))
         (if thread
             ,custom-defun
           (error "Not recognized as thread line"))))))

(defmacro def-gdb-thread-buffer-simple-command (name buffer-command &optional doc)
  "Define a NAME which will call BUFFER-COMMAND with id of thread
on the current line."
  `(def-gdb-thread-buffer-command ,name
     (,buffer-command (gdb-get-field thread 'id))
     ,doc))

(def-gdb-thread-buffer-command gdb-select-thread
  (if (string-equal (gdb-get-field thread 'state) "running")
      (error "Cannot select running thread")
    (let ((new-id (gdb-get-field thread 'id)))
      (setq gdb-thread-number new-id)
      (gud-basic-call (concat "-thread-select " new-id))))
  "Select the thread at current line of threads buffer.")

(def-gdb-thread-simple-buffer-command
  gdb-display-stack-for-thread
  gdb-display-stack-buffer
  "Display stack buffer for the thread at current line.")

(def-gdb-thread-simple-buffer-command
  gdb-display-locals-for-thread
  gdb-display-locals-buffer
  "Display locals buffer for the thread at current line.")

(def-gdb-thread-simple-buffer-command
  gdb-display-registers-for-thread
  gdb-display-registers-buffer
  "Display registers buffer for the thread at current line.")

(def-gdb-thread-simple-buffer-command
  gdb-frame-stack-for-thread
  gdb-frame-stack-buffer
  "Display a new frame with stack buffer for the thread at
current line.")

(def-gdb-thread-simple-buffer-command
  gdb-frame-locals-for-thread
  gdb-frame-locals-buffer
  "Display a new frame with locals buffer for the thread at
current line.")

(def-gdb-thread-simple-buffer-command
  gdb-frame-registers-for-thread
  gdb-frame-registers-buffer
  "Display a new frame with registers buffer for the thread at
current line.")


;;; Memory view

(defcustom gdb-memory-rows 8

                   (put-text-property bl (+ bl 4)
                                      'face '(:inverse-video t)))))
             (forward-line 1)))))

(defun gdb-stack-buffer-name ()
  (gdb-current-context-buffer-name
   (concat "stack frames of " (gdb-get-target-string))))

(def-gdb-display-buffer
 gdb-display-stack-buffer
 'gdb-stack-buffer
 "Display backtrace of current stack.")

(gdb-set-buffer-rules
 'gdb-locals-buffer
 'gdb-locals-buffer-name
 'gdb-locals-mode
 'gdb-invalidate-locals)

(defvar gdb-locals-watch-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    (define-key map "\r" 'gud-watch)

       '(gdb-locals-font-lock-keywords))
  (run-mode-hooks 'gdb-locals-mode-hook)
  'gdb-invalidate-locals)

(defun gdb-locals-buffer-name ()
  (gdb-current-context-buffer-name
   (concat "locals of " (gdb-get-target-string))))

(def-gdb-display-buffer
 gdb-display-locals-buffer
 'gdb-locals-buffer
 "Display local variables of current stack and their values.")

  (use-local-map gdb-registers-mode-map)
  (run-mode-hooks 'gdb-registers-mode-hook)
  'gdb-invalidate-registers)

(defun gdb-registers-buffer-name ()
  (gdb-current-context-buffer-name
   (concat "registers of " (gdb-get-target-string))))

(def-gdb-display-buffer
 gdb-display-registers-buffer
 'gdb-registers-buffer
 "Display integer register contents.")

  "Display integer register contents in a new frame.")

;; Needs GDB 6.4 onwards (used to fail with no stack).
(defun gdb-get-changed-registers ()
  (if (and (gdb-get-buffer 'gdb-registers-buffer)
	   (not (gdb-pending-p 'gdb-get-changed-registers)))
      (progn
	(gdb-input
	 (list
	  "-data-list-changed-registers"
	  'gdb-changed-registers-handler))
	(gdb-add-pending 'gdb-get-changed-registers))))

(defun gdb-changed-registers-handler ()
  (gdb-delete-pending 'gdb-get-changed-registers)
  (setq gdb-changed-registers nil)
  (dolist (register-number (gdb-get-field (json-partial-output) 'changed-registers))
    (push register-number gdb-changed-registers)))

(defun gdb-register-names-handler ()

	(gdb-init-buffer))))
  (gdb-force-mode-line-update
   (propertize "ready" 'face font-lock-variable-name-face)))

(defun gdb-get-selected-frame ()
  (if (not (gdb-pending-p 'gdb-get-selected-frame))
      (progn
	(gdb-input
	 (list (gdb-current-context-command "-stack-info-frame") 'gdb-frame-handler))
	(push 'gdb-get-selected-frame
	       gdb-pending-triggers))))

(defun gdb-frame-handler ()
  (gdb-delete-pending 'gdb-get-selected-frame)
  (let ((frame (gdb-get-field (json-partial-output) 'frame)))
    (when frame
      (setq gdb-frame-number (gdb-get-field frame 'level))
      (setq gdb-pc-address (gdb-get-field frame 'addr))
      (setq gdb-selected-frame (gdb-get-field frame 'func))