comparison lisp/progmodes/gdb-mi.el @ 103755:a1a6e341fa6e

* progmodes/gdb-mi.el (gdb-input): Add trailing newline to command.

103754:b186b013ff68

    (gdb-clear-inferior-io)
    (set-process-filter (get-process "gdb-inferior") 'gdb-inferior-filter)
    (gdb-input
     ;; Needs GDB 6.4 onwards
     (list (concat "-inferior-tty-set "
		   (process-tty-name (get-process "gdb-inferior")) "\n")
	   'ignore)))
  (if (eq window-system 'w32)
      (gdb-input (list "-gdb-set new-console off\n" 'ignore)))
  (gdb-input (list "-gdb-set height 0\n" 'ignore))
  ;; find source file and compilation directory here
  (gdb-input
   ; Needs GDB 6.2 onwards.
   (list "-file-list-exec-source-files\n" 'gdb-get-source-file-list))
  (if gdb-create-source-file-list
      (gdb-input
        ; Needs GDB 6.0 onwards.
       (list "-file-list-exec-source-file\n" 'gdb-get-source-file)))
  (gdb-input
   (list "-data-list-register-names\n" 'gdb-get-register-names))
  (gdb-input
   (list "-gdb-show prompt\n" 'gdb-get-prompt)))

(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.")

(defun gdb-create-define-alist ()
  "Create an alist of #define directives for GUD tooltips."

  (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
    (goto-char (point-min))
    (if (search-forward "expands to: " nil t)
	(unless (looking-at "\\S-+.*(.*).*")
	  (gdb-input
	   (list  (concat "print " expr "\n")
		  `(lambda () (gdb-tooltip-print ,expr))))))))

(defun gdb-init-buffer ()
  (set (make-local-variable 'gud-minor-mode) 'gdbmi)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)

			 (buffer-substring (region-beginning) (region-end))
		       (concat (if (eq major-mode 'gdb-registers-mode) "$")
			       (tooltip-identifier-from-point (point)))))))
	      (set-text-properties 0 (length expr) nil expr)
	      (gdb-input
	       (list (concat"-var-create - * "  expr "\n")
		     `(lambda () (gdb-var-create-handler ,expr)))))))
      (message "gud-watch is a no-op in this mode."))))

(defconst gdb-var-create-regexp
  "name=\"\\(.*?\\)\",.*numchild=\"\\(.*?\\)\",\\(?:.*value=\\(\".*\"\\),\\)?.*type=\"\\(.*?\\)\"")

	(unless (string-equal
		 speedbar-initial-expansion-list-name "GUD")
	  (speedbar-change-initial-expansion-list "GUD"))
	(gdb-input
	 (list
	  (concat "-var-evaluate-expression " (car var) "\n")
	  `(lambda () (gdb-var-evaluate-expression-handler
		       ,(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\n" '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

  (gdb-speedbar-update))

; Uses "-var-list-children --all-values".  Needs GDB 6.1 onwards.
(defun gdb-var-list-children (varnum)
  (gdb-input
   (list (concat "-var-update " varnum "\n") 'ignore))
  (gdb-input
   (list (concat "-var-list-children --all-values "
		varnum "\n")
	     `(lambda () (gdb-var-list-children-handler ,varnum)))))

(defconst gdb-var-list-children-regexp
  "child={.*?name=\"\\(.+?\\)\".*?,exp=\"\\(.+?\\)\".*?,\
numchild=\"\\(.+?\\)\".*?,value=\\(\".*?\"\\).*?,type=\"\\(.+?\\)\".*?}")

(defun gdb-var-set-format (format)
  "Set the output format for a variable displayed in the speedbar."
  (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
	 (varnum (car var)))
    (gdb-input
     (list (concat "-var-set-format " varnum " " format "\n") 'ignore))
    (gdb-var-update)))

(defun gdb-var-delete-1 (varnum)
  (gdb-input
   (list (concat "-var-delete " varnum "\n") 'ignore))
  (setq gdb-var-list (delq var gdb-var-list))
  (dolist (varchild gdb-var-list)
    (if (string-match (concat (car var) "\\.") (car varchild))
	(setq gdb-var-list (delq varchild gdb-var-list)))))

	   (gdb-var-delete-1 varnum)))))

(defun gdb-var-delete-children (varnum)
  "Delete children of variable object at point from the speedbar."
  (gdb-input
   (list (concat "-var-delete -c " varnum "\n") 'ignore)))

(defun gdb-edit-value (text token indent)
  "Assign a value to a variable displayed in the speedbar."
  (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
	 (varnum (car var)) (value))
    (setq value (read-string "New value: "))
    (gdb-input
     (list (concat "-var-assign " varnum " " value "\n")
	   `(lambda () (gdb-edit-value-handler ,value))))))

(defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)")

(defun gdb-edit-value-handler (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 *\n" 'gdb-var-update-handler)))
  (push 'gdb-var-update gdb-pending-triggers))

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

  (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log))
  (setq gdb-token-number (1+ gdb-token-number))
  (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)
		       (car item)))


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

(gdb-set-buffer-rules 'gdb-breakpoints-buffer
		      'gdb-breakpoints-buffer-name
		      'gdb-breakpoints-mode)

(def-gdb-auto-updated-buffer gdb-breakpoints-buffer
  gdb-invalidate-breakpoints "-break-list\n"
  gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom)

(defun gdb-breakpoints-list-handler-custom ()
  (setq gdb-pending-triggers (delq 'gdb-invalidate-breakpoints
				  gdb-pending-triggers))

                  ;; Only want one breakpoint icon at each location.
                  (save-excursion
                    (goto-line (string-to-number line))
                    (gdb-put-breakpoint-icon (string-equal flag "y") bptno)))
              (gdb-input
               (list (concat "list " file ":1\n")
                     'ignore))
              (gdb-input
               (list "-file-list-exec-source-file\n"
                     `(lambda () (gdb-get-location
                                  ,bptno ,line ,flag)))))))))))

(defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"")

		   (concat
		    (if (get-text-property
			 0 'gdb-enabled (car (posn-string posn)))
			"-break-disable "
		      "-break-enable ")
		    bptno "\n")))))))))

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

	    (gud-basic-call
	     (concat
	      (if (get-text-property 0 'gdb-enabled obj)
		  "-break-disable "
		"-break-enable ")
	       (get-text-property 0 'gdb-bptno obj) "\n"))))))))

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

(gdb-set-buffer-rules 'gdb-threads-buffer
                      'gdb-threads-buffer-name
                      'gdb-threads-mode)

(def-gdb-auto-updated-buffer gdb-threads-buffer
  gdb-invalidate-threads "-thread-info\n"
  gdb-thread-list-handler gdb-thread-list-handler-custom)


(defvar gdb-threads-font-lock-keywords
  '(("in \\([^ ]+\\) ("  (1 font-lock-function-name-face))

		      'gdb-memory-buffer-name
		      'gdb-memory-mode)

(def-gdb-auto-updated-buffer gdb-memory-buffer
  gdb-invalidate-memory
  (format "-data-read-memory %s %s %d %d %d\n" 
          gdb-memory-address
          gdb-memory-format
          gdb-memory-unit
          gdb-memory-rows
          gdb-memory-columns)

(def-gdb-auto-update-trigger gdb-invalidate-disassembly
  (gdb-get-buffer 'gdb-disassembly-buffer)
  (let ((file (or gdb-selected-file gdb-main-file))
        (line (or gdb-selected-line 1)))
    (if (not file) (error "Disassembly invalidated with no file selected.")
      (format "-data-disassemble -f %s -l %d -n -1 -- 0\n" file line)))
  gdb-disassembly-handler)

(def-gdb-auto-update-handler
  gdb-disassembly-handler
  gdb-invalidate-disassembly

		      'gdb-stack-buffer-name
		      'gdb-frames-mode)

(def-gdb-auto-updated-buffer gdb-stack-buffer
  gdb-invalidate-frames
  "-stack-list-frames\n"
  gdb-stack-list-frames-handler
  gdb-stack-list-frames-custom)

(defun gdb-insert-frame-location (frame)
  "Insert \"of file:line\" button or library name for structure FRAME.

		      'gdb-locals-buffer-name
		      'gdb-locals-mode)

(def-gdb-auto-update-trigger gdb-invalidate-locals
  (gdb-get-buffer 'gdb-locals-buffer)
  "-stack-list-locals --simple-values\n"
  gdb-stack-list-locals-handler)

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

		      'gdb-registers-buffer-name
		      'gdb-registers-mode)

(def-gdb-auto-update-trigger gdb-invalidate-registers
  (gdb-get-buffer 'gdb-registers-buffer)
  "-data-list-register-values x\n"
  gdb-data-list-register-values-handler)

(defconst gdb-data-list-register-values-regexp
  "number=\"\\(.*?\\)\",value=\"\\(.*?\\)\"")

  (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\n"
	  'gdb-get-changed-registers-handler))
	(push 'gdb-get-changed-registers gdb-pending-triggers))))

(defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"")

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

(defun gdb-frame-handler ()
  (setq gdb-pending-triggers

103755:a1a6e341fa6e

    (gdb-clear-inferior-io)
    (set-process-filter (get-process "gdb-inferior") 'gdb-inferior-filter)
    (gdb-input
     ;; Needs GDB 6.4 onwards
     (list (concat "-inferior-tty-set "
		   (process-tty-name (get-process "gdb-inferior")))
	   'ignore)))
  (if (eq window-system 'w32)
      (gdb-input (list "-gdb-set new-console off" 'ignore)))
  (gdb-input (list "-gdb-set height 0" 'ignore))
  ;; find source file and compilation directory here
  (gdb-input
   ; Needs GDB 6.2 onwards.
   (list "-file-list-exec-source-files" 'gdb-get-source-file-list))
  (if gdb-create-source-file-list
      (gdb-input
        ; Needs GDB 6.0 onwards.
       (list "-file-list-exec-source-file" 'gdb-get-source-file)))
  (gdb-input
   (list "-data-list-register-names" 'gdb-get-register-names))
  (gdb-input
   (list "-gdb-show prompt" 'gdb-get-prompt)))

(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.")

(defun gdb-create-define-alist ()
  "Create an alist of #define directives for GUD tooltips."

  (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
    (goto-char (point-min))
    (if (search-forward "expands to: " nil t)
	(unless (looking-at "\\S-+.*(.*).*")
	  (gdb-input
	   (list  (concat "print " expr)
		  `(lambda () (gdb-tooltip-print ,expr))))))))

(defun gdb-init-buffer ()
  (set (make-local-variable 'gud-minor-mode) 'gdbmi)
  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)

			 (buffer-substring (region-beginning) (region-end))
		       (concat (if (eq major-mode 'gdb-registers-mode) "$")
			       (tooltip-identifier-from-point (point)))))))
	      (set-text-properties 0 (length expr) nil expr)
	      (gdb-input
	       (list (concat"-var-create - * "  expr "")
		     `(lambda () (gdb-var-create-handler ,expr)))))))
      (message "gud-watch is a no-op in this mode."))))

(defconst gdb-var-create-regexp
  "name=\"\\(.*?\\)\",.*numchild=\"\\(.*?\\)\",\\(?:.*value=\\(\".*\"\\),\\)?.*type=\"\\(.*?\\)\"")

	(unless (string-equal
		 speedbar-initial-expansion-list-name "GUD")
	  (speedbar-change-initial-expansion-list "GUD"))
	(gdb-input
	 (list
	  (concat "-var-evaluate-expression " (car var))
	  `(lambda () (gdb-var-evaluate-expression-handler
		       ,(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

  (gdb-speedbar-update))

; Uses "-var-list-children --all-values".  Needs GDB 6.1 onwards.
(defun gdb-var-list-children (varnum)
  (gdb-input
   (list (concat "-var-update " varnum) 'ignore))
  (gdb-input
   (list (concat "-var-list-children --all-values "
		varnum)
	     `(lambda () (gdb-var-list-children-handler ,varnum)))))

(defconst gdb-var-list-children-regexp
  "child={.*?name=\"\\(.+?\\)\".*?,exp=\"\\(.+?\\)\".*?,\
numchild=\"\\(.+?\\)\".*?,value=\\(\".*?\"\\).*?,type=\"\\(.+?\\)\".*?}")

(defun gdb-var-set-format (format)
  "Set the output format for a variable displayed in the speedbar."
  (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
	 (varnum (car var)))
    (gdb-input
     (list (concat "-var-set-format " varnum " " format) 'ignore))
    (gdb-var-update)))

(defun gdb-var-delete-1 (varnum)
  (gdb-input
   (list (concat "-var-delete " varnum) 'ignore))
  (setq gdb-var-list (delq var gdb-var-list))
  (dolist (varchild gdb-var-list)
    (if (string-match (concat (car var) "\\.") (car varchild))
	(setq gdb-var-list (delq varchild gdb-var-list)))))

	   (gdb-var-delete-1 varnum)))))

(defun gdb-var-delete-children (varnum)
  "Delete children of variable object at point from the speedbar."
  (gdb-input
   (list (concat "-var-delete -c " varnum) 'ignore)))

(defun gdb-edit-value (text token indent)
  "Assign a value to a variable displayed in the speedbar."
  (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
	 (varnum (car var)) (value))
    (setq value (read-string "New value: "))
    (gdb-input
     (list (concat "-var-assign " varnum " " value)
	   `(lambda () (gdb-edit-value-handler ,value))))))

(defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)")

(defun gdb-edit-value-handler (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=\"\\(.*?\\)\".*?}")

  (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log))
  (setq gdb-token-number (1+ gdb-token-number))
  (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")))


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

(gdb-set-buffer-rules 'gdb-breakpoints-buffer
		      'gdb-breakpoints-buffer-name
		      'gdb-breakpoints-mode)

(def-gdb-auto-updated-buffer gdb-breakpoints-buffer
  gdb-invalidate-breakpoints "-break-list"
  gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom)

(defun gdb-breakpoints-list-handler-custom ()
  (setq gdb-pending-triggers (delq 'gdb-invalidate-breakpoints
				  gdb-pending-triggers))

                  ;; Only want one breakpoint icon at each location.
                  (save-excursion
                    (goto-line (string-to-number line))
                    (gdb-put-breakpoint-icon (string-equal flag "y") bptno)))
              (gdb-input
               (list (concat "list " file ":1")
                     'ignore))
              (gdb-input
               (list "-file-list-exec-source-file"
                     `(lambda () (gdb-get-location
                                  ,bptno ,line ,flag)))))))))))

(defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"")

		   (concat
		    (if (get-text-property
			 0 'gdb-enabled (car (posn-string posn)))
			"-break-disable "
		      "-break-enable ")
		    bptno)))))))))

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

	    (gud-basic-call
	     (concat
	      (if (get-text-property 0 'gdb-enabled obj)
		  "-break-disable "
		"-break-enable ")
	       (get-text-property 0 'gdb-bptno obj)))))))))

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

(gdb-set-buffer-rules 'gdb-threads-buffer
                      'gdb-threads-buffer-name
                      'gdb-threads-mode)

(def-gdb-auto-updated-buffer gdb-threads-buffer
  gdb-invalidate-threads "-thread-info"
  gdb-thread-list-handler gdb-thread-list-handler-custom)


(defvar gdb-threads-font-lock-keywords
  '(("in \\([^ ]+\\) ("  (1 font-lock-function-name-face))

		      'gdb-memory-buffer-name
		      'gdb-memory-mode)

(def-gdb-auto-updated-buffer gdb-memory-buffer
  gdb-invalidate-memory
  (format "-data-read-memory %s %s %d %d %d" 
          gdb-memory-address
          gdb-memory-format
          gdb-memory-unit
          gdb-memory-rows
          gdb-memory-columns)

(def-gdb-auto-update-trigger gdb-invalidate-disassembly
  (gdb-get-buffer 'gdb-disassembly-buffer)
  (let ((file (or gdb-selected-file gdb-main-file))
        (line (or gdb-selected-line 1)))
    (if (not file) (error "Disassembly invalidated with no file selected.")
      (format "-data-disassemble -f %s -l %d -n -1 -- 0" file line)))
  gdb-disassembly-handler)

(def-gdb-auto-update-handler
  gdb-disassembly-handler
  gdb-invalidate-disassembly

		      'gdb-stack-buffer-name
		      'gdb-frames-mode)

(def-gdb-auto-updated-buffer gdb-stack-buffer
  gdb-invalidate-frames
  "-stack-list-frames"
  gdb-stack-list-frames-handler
  gdb-stack-list-frames-custom)

(defun gdb-insert-frame-location (frame)
  "Insert \"of file:line\" button or library name for structure FRAME.

		      'gdb-locals-buffer-name
		      'gdb-locals-mode)

(def-gdb-auto-update-trigger gdb-invalidate-locals
  (gdb-get-buffer 'gdb-locals-buffer)
  "-stack-list-locals --simple-values"
  gdb-stack-list-locals-handler)

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

		      'gdb-registers-buffer-name
		      'gdb-registers-mode)

(def-gdb-auto-update-trigger gdb-invalidate-registers
  (gdb-get-buffer 'gdb-registers-buffer)
  "-data-list-register-values x"
  gdb-data-list-register-values-handler)

(defconst gdb-data-list-register-values-regexp
  "number=\"\\(.*?\\)\",value=\"\\(.*?\\)\"")

  (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-get-changed-registers-handler))
	(push 'gdb-get-changed-registers gdb-pending-triggers))))

(defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"")

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

(defun gdb-frame-handler ()
  (setq gdb-pending-triggers