emacs: lisp/progmodes/gdb-ui.el comparison

comparison lisp/progmodes/gdb-ui.el @ 83407:37d0562504bf

Merged in changes from CVS trunk. Patches applied: * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-664 Update from CVS * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-665 Update from CVS * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-666 Update from CVS git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-447

author	Karoly Lorentey <lorentey@elte.hu>
date	Sat, 10 Dec 2005 21:18:28 +0000
parents	1955a4462bf9 7736e7015779
children	14a4eb789b45

comparison

equal deleted inserted replaced

-:8e25aa911e3e
+:37d0562504bf
 ;;; TODO:
 ;; 1) Use MI command -data-read-memory for memory window.
 ;; 2) Highlight changed register values (use MI commands
 ;;    -data-list-register-values and -data-list-changed-registers instead
-;;    of 'info registers'.
+;;    of 'info registers' after release of 22.1.
 ;; 3) Use tree-widget.el instead of the speedbar for watch-expressions?
 ;; 4) Mark breakpoint locations on scroll-bar of source buffer?
 ;; 5) After release of 22.1, use "-var-list-children --all-values"
 ;;    and "-stack-list-locals --simple-values" which need GDB 6.1 onwards.
 ;; 6) After release of 22.1, use "-var-update --all-values" which needs
 ;;; Code:
 (require 'gud)
 (defvar tool-bar-map)
+(defvar speedbar-initial-expansion-list-name)
 (defvar gdb-frame-address "main" "Initialization for Assembler buffer.")
 (defvar gdb-previous-frame-address nil)
 (defvar gdb-memory-address "main")
 (defvar gdb-previous-frame nil)
 (defvar gdb-overlay-arrow-position nil)
 (defvar gdb-server-prefix nil)
 (defvar gdb-flush-pending-output nil)
 (defvar gdb-location-alist nil
 "Alist of breakpoint numbers and full filenames.")
-(defvar gdb-find-file-unhook nil)
 (defvar gdb-active-process nil "GUD tooltips display variable values when t, \
 and #define directives otherwise.")
 (defvar gdb-error "Non-nil when GDB is reporting an error.")
 (defvar gdb-macro-info nil
 "Non-nil if GDB knows that the inferior includes preprocessor macro info.")
 (defvar gdb-pending-triggers '()
 "A list of trigger functions that have run later than their output
 handlers.")
-;; end of gdb variables
+(defvar gdb-first-post-prompt nil)
+(defvar gdb-version nil)
+(defvar gdb-locals-font-lock-keywords nil)
+(defvar gdb-source-file-list nil
+"List of source files for the current executable")
+(defconst gdb-error-regexp "\\^error,msg=\"\\(.+\\)\"")
+(defvar gdb-locals-font-lock-keywords-1
+'(
+;; var = (struct struct_tag) value
+( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(struct\\) \\(\\(\\sw\\|[_.]\\)+\\)"
+(1 font-lock-variable-name-face)
+(3 font-lock-keyword-face)
+(4 font-lock-type-face))
+;; var = (type) value
+( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(\\(\\sw\\|[_.]\\)+\\)"
+(1 font-lock-variable-name-face)
+(3 font-lock-type-face))
+;; var = val
+( "\\(^\\(\\sw\\|[_.]\\)+\\) += +[^(]"
+(1 font-lock-variable-name-face))
+)
+"Font lock keywords used in `gdb-local-mode'.")
+(defvar gdb-locals-font-lock-keywords-2
+'(
+;; var = type value
+( "\\(^\\(\\sw\\|[_.]\\)+\\)\t+\\(\\(\\sw\\|[_.]\\)+\\)"
+(1 font-lock-variable-name-face)
+(3 font-lock-type-face))
+)
+"Font lock keywords used in `gdb-local-mode'.")
+;; Variables for GDB 6.4+
+(defvar gdb-register-names nil "List of register names.")
+(defvar gdb-changed-registers nil
+"List of changed register numbers (strings).")
 ;;;###autoload
 (defun gdba (command-line)
 "Run gdb on program FILE in buffer *gud-FILE*.
 The directory containing FILE becomes the initial working directory
 ;;
 (interactive (list (gud-query-cmdline 'gdba)))
 ;;
 ;; Let's start with a basic gud-gdb buffer and then modify it a bit.
 (gdb command-line)
-(gdb-ann3))
+(gdb-init-1))
 (defvar gdb-debug-log nil)
 ;;;###autoload
 (defcustom gdb-enable-debug-log nil
 (interactive "P")
 (setq gdb-use-inferior-io-buffer
 	(if (null arg)
 	    (not gdb-use-inferior-io-buffer)
 	  (> (prefix-numeric-value arg) 0)))
+(message (format "Separate inferior IO %sabled"
+		   (if gdb-use-inferior-io-buffer "en" "dis")))
 (if (and gud-comint-buffer
 	   (buffer-name gud-comint-buffer))
 (condition-case nil
 	  (if gdb-use-inferior-io-buffer
 	      (gdb-restore-windows)
 	(unless (looking-at "\\S-+.*(.*).*")
 	  (gdb-enqueue-input
 	   (list  (concat gdb-server-prefix "print " expr "\n")
 		  'gdb-tooltip-print))))))
-(defun gdb-set-gud-minor-mode (buffer)
+(defconst gdb-source-file-regexp "\\(.+?\\), \\|\\([^, \n].*$\\)")
-"Set `gud-minor-mode' from find-file if appropriate."
+(defun gdb-set-gud-minor-mode-existing-buffers ()
+"Create list of source files for current GDB session."
 (goto-char (point-min))
-(unless (search-forward "No source file named " nil t)
+(when (search-forward "read in on demand:" nil t)
-(condition-case nil
+(while (re-search-forward gdb-source-file-regexp nil t)
-	(gdb-enqueue-input
+(push (or (match-string 1) (match-string 2)) gdb-source-file-list))
-	 (list (concat gdb-server-prefix "info source\n")
+(dolist (buffer (buffer-list))
-	       `(lambda () (gdb-set-gud-minor-mode-1 ,buffer))))
+(with-current-buffer buffer
-(error (setq gdb-find-file-unhook t)))))
+	(when (and buffer-file-name
+		   (member (file-name-nondirectory buffer-file-name)
-(defun gdb-set-gud-minor-mode-1 (buffer)
+			   gdb-source-file-list))
-(goto-char (point-min))
+	  (set (make-local-variable 'gud-minor-mode) 'gdba)
-(when (and (search-forward "Located in " nil t)
+	  (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
-	     (looking-at "\\S-+")
+	  (when gud-tooltip-mode
-	     (string-equal (buffer-file-name buffer)
+	    (make-local-variable 'gdb-define-alist)
-			   (match-string 0)))
+	    (gdb-create-define-alist)
-(with-current-buffer buffer
+	    (add-hook 'after-save-hook 'gdb-create-define-alist nil t)))))))
-(set (make-local-variable 'gud-minor-mode) 'gdba)
-(set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
-(when gud-tooltip-mode
-	(make-local-variable 'gdb-define-alist)
-	(gdb-create-define-alist)
-	(add-hook 'after-save-hook 'gdb-create-define-alist nil t)))))
-(defun gdb-set-gud-minor-mode-existing-buffers ()
-(dolist (buffer (buffer-list))
-(let ((file (buffer-file-name buffer)))
-(if file
-	(progn
-	  (gdb-enqueue-input
-	   (list (concat gdb-server-prefix "list "
-			 (file-name-nondirectory file) ":1\n")
-		 `(lambda () (gdb-set-gud-minor-mode ,buffer)))))))))
 (defun gdb-find-watch-expression ()
 (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list))
 	 (varno (nth 1 var)) (expr))
 (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varno)
 (dolist (var1 gdb-var-list)
 (if (string-equal (nth 1 var1) (match-string 1 varno))
 	  (setq expr (concat (car var1) "." (match-string 2 varno)))))
 expr))
-(defun gdb-ann3 ()
+(defun gdb-init-1 ()
 (setq gdb-debug-log nil)
 (set (make-local-variable 'gud-minor-mode) 'gdba)
 (set (make-local-variable 'gud-marker-filter) 'gud-gdba-marker-filter)
 ;;
 (gud-def gud-break (if (not (string-match "Machine" mode-name))
 			  (forward-char 2)
 			  (gud-call "clear *%a" arg)))
 	   "\C-d" "Remove breakpoint at current line or address.")
 ;;
 (gud-def gud-until (if (not (string-match "Machine" mode-name))
-			  (gud-call "until %f:%l" arg)
+			 (gud-call "until %f:%l" arg)
-			(save-excursion
+		       (save-excursion
-			  (beginning-of-line)
+			 (beginning-of-line)
-			  (forward-char 2)
+			 (forward-char 2)
-			  (gud-call "until *%a" arg)))
+			 (gud-call "until *%a" arg)))
 	   "\C-u" "Continue to current line or address.")
 ;;
 (gud-def gud-go (gud-call (if gdb-active-process "continue" "run") arg)
 	   nil "Start or continue execution.")
 'gdb-mouse-toggle-breakpoint-margin)
 (define-key gud-minor-mode-map [left-fringe mouse-3]
 'gdb-mouse-toggle-breakpoint-fringe)
 (setq comint-input-sender 'gdb-send)
-;;
 ;; (re-)initialize
 (setq gdb-frame-address (if gdb-show-main "main" nil))
 (setq gdb-previous-frame-address nil
 	gdb-memory-address "main"
 	gdb-previous-frame nil
 	gdb-selected-frame nil
 	gdb-current-language nil
 	gdb-frame-number nil
 	gdb-var-list nil
 	gdb-var-changed nil
-	gdb-first-prompt nil
+	gdb-first-post-prompt t
 	gdb-prompting nil
 	gdb-input-queue nil
 	gdb-current-item nil
 	gdb-pending-triggers nil
 	gdb-output-sink 'user
 	gdb-server-prefix "server "
 	gdb-flush-pending-output nil
 	gdb-location-alist nil
-	gdb-find-file-unhook nil
+	gdb-source-file-list nil
 	gdb-error nil
 	gdb-macro-info nil
 	gdb-buffer-fringe-width (car (window-fringes)))
-;;
 (setq gdb-buffer-type 'gdba)
-;;
 (if gdb-use-inferior-io-buffer (gdb-clear-inferior-io))
-;;
+;; Hack to see test for GDB 6.4+ (-stack-info-frame was implemented in 6.4)
+(setq gdb-version nil)
+(gdb-enqueue-input (list "server interpreter mi -stack-info-frame\n"
+			   'gdb-get-version)))
+(defun gdb-init-2 ()
 (if (eq window-system 'w32)
 (gdb-enqueue-input (list "set new-console off\n" 'ignore)))
 (gdb-enqueue-input (list "set height 0\n" 'ignore))
 (gdb-enqueue-input (list "set width 0\n" 'ignore))
+(if (string-equal gdb-version "pre-6.4")
+(progn
+	(gdb-enqueue-input (list (concat gdb-server-prefix "info sources\n")
+				 'gdb-set-gud-minor-mode-existing-buffers))
+	(setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-1))
+(gdb-enqueue-input
+(list "server interpreter mi -data-list-register-names\n"
+	 'gdb-get-register-names))
+; Needs GDB 6.2 onwards.
+(gdb-enqueue-input
+(list "server interpreter mi \"-file-list-exec-source-files\"\n"
+	   'gdb-set-gud-minor-mode-existing-buffers-1))
+(setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-2))
 ;; find source file and compilation directory here
 (gdb-enqueue-input (list "server list main\n"   'ignore))   ; C program
 (gdb-enqueue-input (list "server list MAIN__\n" 'ignore))   ; Fortran program
 (gdb-enqueue-input (list "server info source\n" 'gdb-source-info))
-;;
-(gdb-set-gud-minor-mode-existing-buffers)
 (run-hooks 'gdba-mode-hook))
+(defun gdb-get-version ()
+(goto-char (point-min))
+(if (and (re-search-forward gdb-error-regexp nil t)
+	   (string-match ".*(missing implementation)" (match-string 1)))
+(setq gdb-version "pre-6.4")
+(setq gdb-version "6.4+"))
+(gdb-init-2))
 (defun gdb-mouse-until (event)
 "Execute source lines by dragging the overlay arrow (fringe) with the mouse."
 (interactive "e")
 (if gud-overlay-arrow-position
 "Toggle automatic raising of the speedbar for watch expressions."
 (interactive "P")
 (setq gdb-speedbar-auto-raise
 	(if (null arg)
 	    (not gdb-speedbar-auto-raise)
-	  (> (prefix-numeric-value arg) 0))))
+	  (> (prefix-numeric-value arg) 0)))
+(message (format "Auto raising %sabled"
+		   (if gdb-speedbar-auto-raise "en" "dis"))))
 (defcustom gdb-use-colon-colon-notation nil
 "If non-nil use FUN::VAR format to display variables in the speedbar."
 :type 'boolean
 :group 'gud
 :version "22.1")
-(defun gud-watch ()
+(defun gud-watch (&optional event)
 "Watch expression at point."
-(interactive)
+(interactive (list last-input-event))
+(if event (posn-set-point (event-end event)))
 (require 'tooltip)
 (save-selected-window
 (let ((expr (tooltip-identifier-from-point (point))))
 (if (and (string-equal gdb-current-language "c")
 	       gdb-use-colon-colon-notation gdb-selected-frame)
 (defconst gdb-var-create-regexp
 "name=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
 (defun gdb-var-create-handler (expr)
-(with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
+(goto-char (point-min))
-(goto-char (point-min))
+(if (re-search-forward gdb-var-create-regexp nil t)
-(if (re-search-forward gdb-var-create-regexp nil t)
+(let ((var (list expr
-	(let ((var (list expr
+		       (match-string 1)
-			 (match-string 1)
+		       (match-string 2)
-			 (match-string 2)
+		       (match-string 3)
-			 (match-string 3)
+		       nil nil)))
-			 nil nil)))
+	(push var gdb-var-list)
-	  (push var gdb-var-list)
+	(speedbar 1)
-	  (speedbar 1)
+	(unless (string-equal
-	  (unless (string-equal
+		 speedbar-initial-expansion-list-name "GUD")
-		   speedbar-initial-expansion-list-name "GUD")
+	  (speedbar-change-initial-expansion-list "GUD"))
-	    (speedbar-change-initial-expansion-list "GUD"))
+	(gdb-enqueue-input
-	  (gdb-enqueue-input
+	 (list
-	   (list
+	  (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
-	    (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+		  'gdba)
-		    'gdba)
+	      (concat "server interpreter mi \"-var-evaluate-expression "
-		(concat "server interpreter mi \"-var-evaluate-expression "
+		      (nth 1 var) "\"\n")
-			(nth 1 var) "\"\n")
+	    (concat "-var-evaluate-expression " (nth 1 var) "\n"))
-	      (concat "-var-evaluate-expression " (nth 1 var) "\n"))
+	  `(lambda () (gdb-var-evaluate-expression-handler
-	    `(lambda () (gdb-var-evaluate-expression-handler
+		       ,(nth 1 var) nil))))
-			 ,(nth 1 var) nil))))
+	(setq gdb-var-changed t))
-	    (setq gdb-var-changed t))
+(if (search-forward "Undefined command" nil t)
-(if (re-search-forward "Undefined command" nil t)
+	(message-box "Watching expressions requires gdb 6.0 onwards")
-	  (message-box "Watching expressions requires gdb 6.0 onwards")
+(message "No symbol \"%s\" in current context." expr))))
-	(message "No symbol \"%s\" in current context." expr)))))
 (defun gdb-var-evaluate-expression-handler (varnum changed)
-(with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
+(goto-char (point-min))
-(goto-char (point-min))
+(re-search-forward ".*value=\\(\".*\"\\)" nil t)
-(re-search-forward ".*value=\\(\".*\"\\)" nil t)
+(catch 'var-found
-(catch 'var-found
+(let ((num 0))
-(let ((num 0))
+(dolist (var gdb-var-list)
-	(dolist (var gdb-var-list)
+	(if (string-equal varnum (cadr var))
-	  (if (string-equal varnum (cadr var))
+	    (progn
-	      (progn
+	      (if changed (setcar (nthcdr 5 var) t))
-		(if changed (setcar (nthcdr 5 var) t))
+	      (setcar (nthcdr 4 var) (read (match-string 1)))
-		(setcar (nthcdr 4 var) (read (match-string 1)))
+	      (setcar (nthcdr num gdb-var-list) var)
-		(setcar (nthcdr num gdb-var-list) var)
+	      (throw 'var-found nil)))
-		(throw 'var-found nil)))
+	(setq num (+ num 1)))))
-	  (setq num (+ num 1))))))
 (setq gdb-var-changed t))
 (defun gdb-var-list-children (varnum)
 (gdb-enqueue-input
 (list (concat "server interpreter mi \"-var-list-children " varnum "\"\n")
 (defconst gdb-var-list-children-regexp
 "name=\"\\(.*?\\)\",exp=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",\
 type=\"\\(.*?\\)\"")
 (defun gdb-var-list-children-handler (varnum)
-(with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
+(goto-char (point-min))
-(goto-char (point-min))
+(let ((var-list nil))
-(let ((var-list nil))
+(catch 'child-already-watched
-(catch 'child-already-watched
+(dolist (var gdb-var-list)
-(dolist (var gdb-var-list)
+	(if (string-equal varnum (cadr var))
-	 (if (string-equal varnum (cadr var))
+	    (progn
-	     (progn
+	      (push var var-list)
-	       (push var var-list)
+	      (while (re-search-forward gdb-var-list-children-regexp nil t)
-	       (while (re-search-forward gdb-var-list-children-regexp nil t)
+		(let ((varchild (list (match-string 2)
-		 (let ((varchild (list (match-string 2)
+				      (match-string 1)
-				       (match-string 1)
+				      (match-string 3)
-				       (match-string 3)
+				      (match-string 4)
-				       (match-string 4)
+				      nil nil)))
-				       nil nil)))
+		  (dolist (var1 gdb-var-list)
-		   (dolist (var1 gdb-var-list)
+		    (if (string-equal (cadr var1) (cadr varchild))
-		     (if (string-equal (cadr var1) (cadr varchild))
+			(throw 'child-already-watched nil)))
-			 (throw 'child-already-watched nil)))
+		  (push varchild var-list)
-		   (push varchild var-list)
+		  (gdb-enqueue-input
-		   (gdb-enqueue-input
+		   (list
-		    (list
+		    (concat
-		     (concat
+		     "server interpreter mi \"-var-evaluate-expression "
-		      "server interpreter mi \"-var-evaluate-expression "
+		     (nth 1 varchild) "\"\n")
-		      (nth 1 varchild) "\"\n")
+		    `(lambda () (gdb-var-evaluate-expression-handler
-		     `(lambda () (gdb-var-evaluate-expression-handler
+				 ,(nth 1 varchild) nil)))))))
-				  ,(nth 1 varchild) nil)))))))
+	  (push var var-list)))
-	   (push var var-list)))
+(setq gdb-var-list (nreverse var-list)))))
-(setq gdb-var-list (nreverse var-list))))))
 (defun gdb-var-update ()
 (when (not (member 'gdb-var-update gdb-pending-triggers))
 (gdb-enqueue-input
 (list "server interpreter mi \"-var-update *\"\n"
 (push 'gdb-var-update gdb-pending-triggers)))
 (defconst gdb-var-update-regexp "name=\"\\(.*?\\)\"")
 (defun gdb-var-update-handler ()
-(with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
+(goto-char (point-min))
-(goto-char (point-min))
+(while (re-search-forward gdb-var-update-regexp nil t)
-(while (re-search-forward gdb-var-update-regexp nil t)
+(catch 'var-found-1
-(catch 'var-found-1
+(let ((varnum (match-string 1)))
-	(let ((varnum (match-string 1)))
+	(dolist (var gdb-var-list)
-	  (dolist (var gdb-var-list)
+	  (gdb-enqueue-input
-	    (gdb-enqueue-input
+	   (list
-	     (list
+	    (concat "server interpreter mi \"-var-evaluate-expression "
-	      (concat "server interpreter mi \"-var-evaluate-expression "
+		    varnum "\"\n")
-		      varnum "\"\n")
+	    `(lambda () (gdb-var-evaluate-expression-handler ,varnum t))))
-	      `(lambda () (gdb-var-evaluate-expression-handler ,varnum t))))
+	  (throw 'var-found-1 nil)))))
-	    (throw 'var-found-1 nil))))))
 (setq gdb-pending-triggers
-(delq 'gdb-var-update gdb-pending-triggers))
+	(delq 'gdb-var-update gdb-pending-triggers))
 (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
 ;; Dummy command to update speedbar at right time.
 (gdb-enqueue-input (list "server pwd\n" 'gdb-speedbar-timer-fn))
 ;; Keep gdb-pending-triggers non-nil till end.
 (push 'gdb-speedbar-timer gdb-pending-triggers)))
 TEXT is the text of the button we clicked on, a + or - item.
 TOKEN is data related to this node.
 INDENT is the current indentation depth."
 (cond ((string-match "+" text)        ;expand this node
 	 (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
-	     (gdb-var-list-children token)
+	     (if (string-equal gdb-version "pre-6.4")
+		 (gdb-var-list-children token)
+	       (gdb-var-list-children-1 token))
 	   (progn
 	     (gdbmi-var-update)
 	     (gdbmi-var-list-children token))))
 	((string-match "-" text)	;contract this node
 	 (dolist (var gdb-var-list)
 	    gdb-buffer-rules-assoc))))
 ;; GUD buffers are an exception to the rules
 (gdb-set-buffer-rules 'gdba 'error)
-;;
 ;; Partial-output buffer : This accumulates output from a command executed on
 ;; behalf of emacs (rather than the user).
 ;;
 (gdb-set-buffer-rules 'gdb-partial-output-buffer
 		      'gdb-partial-output-name)
 (interactive)
 (process-send-eof
 (get-buffer-process gud-comint-buffer)))
-;;
 ;; gdb communications
 ;;
 ;; INPUT: things sent to gdb
 ;;
 (error "Phase error in gdb-pre-prompt (got %s)" sink)))))
 (defun gdb-prompt (ignored)
 "An annotation handler for `prompt'.
 This sends the next command (if any) to gdb."
-(when gdb-first-prompt (gdb-ann3))
+(when gdb-first-prompt
+(gdb-init-1)
+(setq gdb-first-prompt nil))
 (let ((sink gdb-output-sink))
 (cond
 ((eq sink 'user) t)
 ((eq sink 'post-emacs)
 (setq gdb-output-sink 'user)
 (defun gdb-post-prompt (ignored)
 "An annotation handler for `post-prompt'.
 This begins the collection of output from the current command if that
 happens to be appropriate."
-(unless gdb-pending-triggers
+;; Don't add to queue if there outstanding items or GDB is not known yet.
+(unless (or gdb-pending-triggers gdb-first-post-prompt)
 (gdb-get-selected-frame)
 (gdb-invalidate-frames)
 (gdb-invalidate-breakpoints)
 ;; Do this through gdb-get-selected-frame -> gdb-frame-handler
 ;; so gdb-frame-address is updated.
 ;; (gdb-invalidate-assembler)
-(gdb-invalidate-registers)
+(if (string-equal gdb-version "pre-6.4")
+	(gdb-invalidate-registers)
+(gdb-get-changed-registers)
+(gdb-invalidate-registers-1))
 (gdb-invalidate-memory)
-(gdb-invalidate-locals)
+(if (string-equal gdb-version "pre-6.4")
+	(gdb-invalidate-locals)
+(gdb-invalidate-locals-1))
 (gdb-invalidate-threads)
 (unless (eq system-type 'darwin) ;Breaks on Darwin's GDB-5.3.
 ;; FIXME: with GDB-6 on Darwin, this might very well work.
 ;; Only needed/used with speedbar/watch expressions.
 (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
 	(setq gdb-var-changed t)    ; force update
 	(dolist (var gdb-var-list)
 	  (setcar (nthcdr 5 var) nil))
-	(gdb-var-update))))
+	(if (string-equal gdb-version "pre-6.4")
+	    (gdb-var-update)
+	  (gdb-var-update-1)))))
+(setq gdb-first-post-prompt nil)
 (let ((sink gdb-output-sink))
 (cond
 ((eq sink 'user) t)
 ((eq sink 'pre-emacs)
 (setq gdb-output-sink 'emacs))
 (kill-all-local-variables)
 (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)
 (run-mode-hooks 'gdb-frames-mode-hook)
 (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
 'gdb-invalidate-frames
 'gdbmi-invalidate-frames))
 (defvar gdb-registers-mode-map
 (let ((map (make-sparse-keymap)))
 (suppress-keymap map)
 (define-key map "\r" 'gdb-edit-register-value)
 (define-key map [mouse-2] 'gdb-edit-register-value)
-(define-key map " " 'toggle-gdb-all-registers)
+(define-key map " " 'gdb-all-registers)
 (define-key map "q" 'kill-this-buffer)
 map))
 (defun gdb-registers-mode ()
 "Major mode for gdb registers.
 \\{gdb-registers-mode-map}"
 (kill-all-local-variables)
 (setq major-mode 'gdb-registers-mode)
-(setq mode-name "Registers:")
+(setq mode-name "Registers")
 (setq buffer-read-only t)
 (use-local-map gdb-registers-mode-map)
 (run-mode-hooks 'gdb-registers-mode-hook)
-(if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
+(if (string-equal gdb-version "pre-6.4")
-'gdb-invalidate-registers
+(progn
-'gdbmi-invalidate-registers))
+	(if gdb-all-registers (setq mode-name "Registers:All"))
+	'gdb-invalidate-registers)
+'gdb-invalidate-registers-1))
 (defun gdb-registers-buffer-name ()
 (with-current-buffer gud-comint-buffer
 (concat "*registers of " (gdb-get-target-string) "*")))
 (interactive)
 (let ((special-display-regexps (append special-display-regexps '(".*")))
 	(special-display-frame-alist gdb-frame-parameters))
 (display-buffer (gdb-get-create-buffer 'gdb-registers-buffer))))
-(defun toggle-gdb-all-registers ()
+(defun gdb-all-registers ()
-"Toggle the display of floating-point registers."
+"Toggle the display of floating-point registers (pre GDB 6.4 only)."
 (interactive)
-(if gdb-all-registers
+(when (string-equal gdb-version "pre-6.4")
-(progn
+(if gdb-all-registers
-	(setq gdb-all-registers nil)
+	(progn
-	(with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
+	  (setq gdb-all-registers nil)
-	  (setq mode-name "Registers:")))
+	  (with-current-buffer (gdb-get-create-buffer 'gdb-registers-buffer)
-(setq gdb-all-registers t)
+	    (setq mode-name "Registers")))
-(with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
+(setq gdb-all-registers t)
-(setq mode-name "Registers:All")))
+(with-current-buffer (gdb-get-create-buffer 'gdb-registers-buffer)
-(gdb-invalidate-registers))
+	(setq mode-name "Registers:All")))
+(message (format "Display of floating-point registers %sabled"
+		     (if gdb-all-registers "en" "dis")))
+(gdb-invalidate-registers)))
 ;; Memory buffer.
 ;;
 (defcustom gdb-memory-repeat-count 32
 "Set the display format to hexadecimal."
 (interactive)
 (customize-set-variable 'gdb-memory-format "x")
 (gdb-invalidate-memory))
-(defvar gdb-memory-format-keymap
+(defvar gdb-memory-format-map
 (let ((map (make-sparse-keymap)))
 (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1)
 map)
 "Keymap to select format in the header line.")
 "Set the unit size to bytes."
 (interactive)
 (customize-set-variable 'gdb-memory-unit "b")
 (gdb-invalidate-memory))
-(defvar gdb-memory-unit-keymap
+(defvar gdb-memory-unit-map
 (let ((map (make-sparse-keymap)))
 (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1)
 map)
 "Keymap to select units in the header line.")
 	   "  Display Format: "
 	   (propertize gdb-memory-format
 		       'face font-lock-warning-face
 		       'help-echo "mouse-3: Select display format"
 		       'mouse-face 'mode-line-highlight
-		       'local-map gdb-memory-format-keymap)
+		       'local-map gdb-memory-format-map)
 	   "  Unit Size: "
 	   (propertize gdb-memory-unit
 		       'face font-lock-warning-face
 		       'help-echo "mouse-3: Select unit size"
 		       'mouse-face 'mode-line-highlight
-		       'local-map gdb-memory-unit-keymap))))
+		       'local-map gdb-memory-unit-map))))
 (set (make-local-variable 'font-lock-defaults)
 '(gdb-memory-font-lock-keywords))
 (run-mode-hooks 'gdb-memory-mode-hook)
 'gdb-invalidate-memory)
 (def-gdb-auto-update-trigger gdb-invalidate-locals
 (gdb-get-buffer 'gdb-locals-buffer)
 "server info locals\n"
 gdb-info-locals-handler)
-(defvar gdb-locals-watch-keymap
+(defvar gdb-locals-watch-map
 (let ((map (make-sparse-keymap)))
 (define-key map "\r" '(lambda () (interactive)
 			    (beginning-of-line)
 			    (gud-watch)))
 (define-key map [mouse-2] '(lambda (event) (interactive "e")
 (defconst gdb-struct-string
 (concat (propertize "[struct/union]"
 		      'mouse-face 'highlight
 		      'help-echo "mouse-2: create watch expression"
-		      'local-map gdb-locals-watch-keymap) "\n"))
+		      'local-map gdb-locals-watch-map) "\n"))
 (defconst gdb-array-string
 (concat " " (propertize "[array]"
 			  'mouse-face 'highlight
 			  'help-echo "mouse-2: create watch expression"
-			  'local-map gdb-locals-watch-keymap) "\n"))
+			  'local-map gdb-locals-watch-map) "\n"))
 ;; Abbreviate for arrays and structures.
 ;; These can be expanded using gud-display.
 (defun gdb-info-locals-handler ()
 (setq gdb-pending-triggers (delq 'gdb-invalidate-locals
 (let ((map (make-sparse-keymap)))
 (suppress-keymap map)
 (define-key map "q" 'kill-this-buffer)
 map))
-(defvar gdb-locals-font-lock-keywords
-'(
-;; var = (struct struct_tag) value
-( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(struct\\) \\(\\(\\sw\\|[_.]\\)+\\)"
-(1 font-lock-variable-name-face)
-(3 font-lock-keyword-face)
-(4 font-lock-type-face))
-;; var = (type) value
-( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(\\(\\sw\\|[_.]\\)+\\)"
-(1 font-lock-variable-name-face)
-(3 font-lock-type-face))
-;; var = val
-( "\\(^\\(\\sw\\|[_.]\\)+\\) += +[^(]"
-(1 font-lock-variable-name-face))
-)
-"Font lock keywords used in `gdb-local-mode'.")
 (defun gdb-locals-mode ()
 "Major mode for gdb locals.
 \\{gdb-locals-mode-map}"
 (kill-all-local-variables)
 (use-local-map gdb-locals-mode-map)
 (set (make-local-variable 'font-lock-defaults)
 '(gdb-locals-font-lock-keywords))
 (run-mode-hooks 'gdb-locals-mode-hook)
 (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
-'gdb-invalidate-locals
+(if (string-equal gdb-version "pre-6.4")
+	  'gdb-invalidate-locals
+	'gdb-invalidate-locals-1)
 'gdbmi-invalidate-locals))
 (defun gdb-locals-buffer-name ()
 (with-current-buffer gud-comint-buffer
 (concat "*locals of " (gdb-get-target-string) "*")))
 	(gdb-put-breakpoint-icon (eq flag ?y) bptno)))))
 (add-hook 'find-file-hook 'gdb-find-file-hook)
 (defun gdb-find-file-hook ()
 "Set up buffer for debugging if file is part of the source code
 of the current session."
-(if (and (not gdb-find-file-unhook)
+(if (and (buffer-name gud-comint-buffer)
 	   ;; in case gud or gdb-ui is just loaded
 	   gud-comint-buffer
-	   (buffer-name gud-comint-buffer)
 	   (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
 	       'gdba))
-(condition-case nil
+(if (member buffer-file-name gdb-source-file-list)
-	(gdb-enqueue-input
+	  (with-current-buffer (find-buffer-visiting buffer-file-name)
-	 (list (concat gdb-server-prefix "list "
+	    (set (make-local-variable 'gud-minor-mode) 'gdba)
-		       (file-name-nondirectory buffer-file-name)
+	    (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)))))
-		       ":1\n")
-	       `(lambda () (gdb-set-gud-minor-mode ,(current-buffer)))))
-	(error (setq gdb-find-file-unhook t)))))
 ;;from put-image
 (defun gdb-put-string (putstring pos &optional dprop &rest sprops)
 "Put string PUTSTRING in front of POS in the current buffer.
 PUTSTRING is displayed by putting an overlay into the current buffer with a
 (save-excursion
 	(if (not (equal gdb-frame-address "main"))
 	    (progn
 	      (goto-char (point-min))
 	      (if (and gdb-frame-address
-		       (re-search-forward gdb-frame-address nil t))
+		       (search-forward gdb-frame-address nil t))
 		  (progn
 		    (setq pos (point))
 		    (beginning-of-line)
 		    (or gdb-overlay-arrow-position
 			(setq gdb-overlay-arrow-position (make-marker)))
 	      (setq flag (char-after (match-beginning 2)))
 	      (setq address (match-string 3))
 	      (with-current-buffer buffer
 		(save-excursion
 		  (goto-char (point-min))
-		  (if (re-search-forward address nil t)
+		  (if (search-forward address nil t)
 		      (gdb-put-breakpoint-icon (eq flag ?y) bptno))))))))
 (if (not (equal gdb-frame-address "main"))
 	(with-current-buffer buffer
 	  (set-window-point (get-buffer-window buffer 0) pos)))))
 	       gdb-pending-triggers))))
 (defun gdb-frame-handler ()
 (setq gdb-pending-triggers
 	(delq 'gdb-get-selected-frame gdb-pending-triggers))
-(with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
+(goto-char (point-min))
+(if (re-search-forward  "Stack level \\([0-9]+\\)" nil t)
+(setq gdb-frame-number (match-string 1)))
+(goto-char (point-min))
+(if (re-search-forward
+".*=\\s-+0x0*\\(\\S-*\\)\\s-+in\\s-+\\(\\S-*?\\);? " nil t)
+(progn
+	(setq gdb-selected-frame (match-string 2))
+	(if (gdb-get-buffer 'gdb-locals-buffer)
+	    (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer)
+	      (setq mode-name (concat "Locals:" gdb-selected-frame))))
+	(if (gdb-get-buffer 'gdb-assembler-buffer)
+	    (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer)
+	      (setq mode-name (concat "Machine:" gdb-selected-frame))))
+	(setq gdb-frame-address (match-string 1))))
+(goto-char (point-min))
+(if (re-search-forward " source language \\(\\S-*\\)\." nil t)
+(setq gdb-current-language (match-string 1)))
+(gdb-invalidate-assembler))
+;; Code specific to GDB 6.4
+(defconst gdb-source-file-regexp-1 "fullname=\"\\(.*?\\)\"")
+(defun gdb-set-gud-minor-mode-existing-buffers-1 ()
+"Create list of source files for current GDB session."
+(goto-char (point-min))
+(while (re-search-forward gdb-source-file-regexp-1 nil t)
+(push (match-string 1) gdb-source-file-list))
+(dolist (buffer (buffer-list))
+(with-current-buffer buffer
+(when (member buffer-file-name gdb-source-file-list)
+	(set (make-local-variable 'gud-minor-mode) 'gdba)
+	(set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
+	(when gud-tooltip-mode
+	  (make-local-variable 'gdb-define-alist)
+	  (gdb-create-define-alist)
+	  (add-hook 'after-save-hook 'gdb-create-define-alist nil t))))))
+; Uses "-var-list-children --all-values".  Needs GDB 6.1 onwards.
+(defun gdb-var-list-children-1 (varnum)
+(gdb-enqueue-input
+(list (concat "server interpreter mi \"-var-update " varnum "\"\n")
+	 'ignore))
+(gdb-enqueue-input
+(list (concat "server interpreter mi \"-var-list-children --all-values "
+		 varnum "\"\n")
+	     `(lambda () (gdb-var-list-children-handler-1 ,varnum)))))
+(defconst gdb-var-list-children-regexp-1
+"name=\"\\(.+?\\)\",exp=\"\\(.+?\\)\",numchild=\"\\(.+?\\)\",\
+value=\\(\".*?\"\\),type=\"\\(.+?\\)\"}")
+(defun gdb-var-list-children-handler-1 (varnum)
+(goto-char (point-min))
+(let ((var-list nil))
+(catch 'child-already-watched
+(dolist (var gdb-var-list)
+	(if (string-equal varnum (cadr var))
+	    (progn
+	      (push var var-list)
+	      (while (re-search-forward gdb-var-list-children-regexp-1 nil t)
+		(let ((varchild (list (match-string 2)
+				      (match-string 1)
+				      (match-string 3)
+				      (match-string 5)
+				      (read (match-string 4))
+				      nil)))
+		  (dolist (var1 gdb-var-list)
+		    (if (string-equal (cadr var1) (cadr varchild))
+			(throw 'child-already-watched nil)))
+		  (push varchild var-list))))
+	  (push var var-list)))
+(setq gdb-var-changed t)
+(setq gdb-var-list (nreverse var-list)))))
+; Uses "-var-update --all-values".  Needs GDB 6.4 onwards.
+(defun gdb-var-update-1 ()
+(if (not (member 'gdb-var-update gdb-pending-triggers))
+(progn
+	(gdb-enqueue-input
+	 (list
+	  (if (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))
+	      "server interpreter mi \"-var-update --all-values *\"\n"
+	    "-var-update --all-values *\n")
+				 'gdb-var-update-handler-1))
+	(push 'gdb-var-update gdb-pending-triggers))))
+(defconst gdb-var-update-regexp-1 "name=\"\\(.*?\\)\",value=\\(\".*?\"\\),")
+(defun gdb-var-update-handler-1 ()
+(goto-char (point-min))
+(while (re-search-forward gdb-var-update-regexp-1 nil t)
+(let ((varnum (match-string 1)))
+(catch 'var-found1
+	(let ((num 0))
+	  (dolist (var gdb-var-list)
+	    (if (string-equal varnum (cadr var))
+		(progn
+		  (setcar (nthcdr 5 var) t)
+		  (setcar (nthcdr 4 var) (read (match-string 2)))
+		  (setcar (nthcdr num gdb-var-list) var)
+		  (throw 'var-found1 nil)))
+	    (setq num (+ num 1))))))
+(setq gdb-var-changed t))
+(setq gdb-pending-triggers
+(delq 'gdb-var-update gdb-pending-triggers))
+(when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
+;; dummy command to update speedbar at right time
+(gdb-enqueue-input (list "server pwd\n" 'gdb-speedbar-timer-fn))
+;; keep gdb-pending-triggers non-nil till end
+(push 'gdb-speedbar-timer gdb-pending-triggers)))
+;; Registers buffer.
+;;
+(gdb-set-buffer-rules 'gdb-registers-buffer
+		      'gdb-registers-buffer-name
+		      'gdb-registers-mode)
+(def-gdb-auto-update-trigger gdb-invalidate-registers-1
+(gdb-get-buffer 'gdb-registers-buffer)
+(if (eq gud-minor-mode 'gdba)
+"server interpreter mi \"-data-list-register-values x\"\n"
+"-data-list-register-values x\n")
+gdb-data-list-register-values-handler)
+(defconst gdb-data-list-register-values-regexp
+"number=\"\\(.*?\\)\",value=\"\\(.*?\\)\"")
+(defun gdb-data-list-register-values-handler ()
+(setq gdb-pending-triggers (delq 'gdb-invalidate-registers-1
+				   gdb-pending-triggers))
+(goto-char (point-min))
+(if (re-search-forward gdb-error-regexp nil t)
+(with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
+	(let ((buffer-read-only nil))
+	  (erase-buffer)
+	  (insert (match-string 1))
+	  (goto-char (point-min))))
+(let ((register-list (reverse gdb-register-names))
+	  (register nil) (register-string nil) (register-values nil))
+(goto-char (point-min))
+(while (re-search-forward gdb-data-list-register-values-regexp nil t)
+	(setq register (pop register-list))
+	(setq register-string (concat register "\t" (match-string 2) "\n"))
+	(if (member (match-string 1) gdb-changed-registers)
+	    (put-text-property 0 (length register-string)
+			       'face 'font-lock-warning-face
+			       register-string))
+	(setq register-values
+	      (concat register-values register-string)))
+(let ((buf (gdb-get-buffer 'gdb-registers-buffer)))
+	(with-current-buffer buf
+	  (let ((p (window-point (get-buffer-window buf 0)))
+		(buffer-read-only nil))
+	    (erase-buffer)
+	    (insert register-values)
+	    (set-window-point (get-buffer-window buf 0) p))))))
+(gdb-data-list-register-values-custom))
+(defun gdb-data-list-register-values-custom ()
+(with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
+(save-excursion
+(let ((buffer-read-only nil)
+	    start end)
+	(goto-char (point-min))
+	(while (< (point) (point-max))
+	  (setq start (line-beginning-position))
+	  (setq end (line-end-position))
+	  (when (looking-at "^[^\t]+")
+	    (unless (string-equal (match-string 0) "No registers.")
+	      (put-text-property start (match-end 0)
+				 'face font-lock-variable-name-face)
+	      (add-text-properties start end
+		                   '(help-echo "mouse-2: edit value"
+				     mouse-face highlight))))
+	  (forward-line 1))))))
+;; Needs GDB 6.4 onwards (used to fail with no stack).
+(defun gdb-get-changed-registers ()
+(if (not (member 'gdb-get-changed-registers gdb-pending-triggers))
+(progn
+	(gdb-enqueue-input
+	 (list
+	  (if (eq gud-minor-mode 'gdba)
+	      "server interpreter mi -data-list-changed-registers\n"
+	    "-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-changed-registers-handler ()
+(setq gdb-pending-triggers
+	(delq 'gdb-get-changed-registers gdb-pending-triggers))
+(setq gdb-changed-registers nil)
+(goto-char (point-min))
+(while (re-search-forward gdb-data-list-register-names-regexp nil t)
+(push (match-string 1) gdb-changed-registers)))
+;; Locals buffer.
+;;
+;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards.
+(gdb-set-buffer-rules 'gdb-locals-buffer
+		      'gdb-locals-buffer-name
+		      'gdb-locals-mode)
+(def-gdb-auto-update-trigger gdb-invalidate-locals-1
+(gdb-get-buffer 'gdb-locals-buffer)
+"server interpreter mi -\"stack-list-locals --simple-values\"\n"
+gdb-stack-list-locals-handler)
+(defconst gdb-stack-list-locals-regexp
+"name=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
+(defvar gdb-locals-watch-map-1
+(let ((map (make-sparse-keymap)))
+(define-key map [mouse-2] 'gud-watch)
+map)
+"Keymap to create watch expression of a complex data type local variable.")
+;; Dont display values of arrays or structures.
+;; These can be expanded using gud-watch.
+(defun gdb-stack-list-locals-handler ()
+(setq gdb-pending-triggers (delq 'gdb-invalidate-locals-1
+				  gdb-pending-triggers))
+(let (local locals-list)
 (goto-char (point-min))
-(if (re-search-forward  "Stack level \\([0-9]+\\)" nil t)
+(while (re-search-forward gdb-stack-list-locals-regexp nil t)
-	(setq gdb-frame-number (match-string 1)))
+(let ((local (list (match-string 1)
-(goto-char (point-min))
+			 (match-string 2)
-(if (re-search-forward
+			 nil)))
-	 ".*=\\s-+0x0*\\(\\S-*\\)\\s-+in\\s-+\\(\\S-*?\\);? " nil t)
+	(if (looking-at ",value=\\(\".*\"\\)}")
-	(progn
+	    (setcar (nthcdr 2 local) (read (match-string 1))))
-	  (setq gdb-selected-frame (match-string 2))
+	(push local locals-list)))
-	  (if (gdb-get-buffer 'gdb-locals-buffer)
+(let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
-	      (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer)
+(and buf (with-current-buffer buf
-		(setq mode-name (concat "Locals:" gdb-selected-frame))))
+		 (let* ((window (get-buffer-window buf 0))
-	  (if (gdb-get-buffer 'gdb-assembler-buffer)
+			(p (window-point window))
-	      (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer)
+			(buffer-read-only nil))
-		(setq mode-name (concat "Machine:" gdb-selected-frame))))
+		   (erase-buffer)
-	  (setq gdb-frame-address (match-string 1))))
+		   (dolist (local locals-list)
-(goto-char (point-min))
+		     (setq name (car local))
-(if (re-search-forward " source language \\(\\S-*\\)\." nil t)
+		     (if (or (not (nth 2 local))
-	(setq gdb-current-language (match-string 1))))
+			     (string-match "\\*$" (nth 1 local)))
-(gdb-invalidate-assembler))
+		       (add-text-properties 0 (length name)
+			    `(mouse-face highlight
+			      help-echo "mouse-2: create watch expression"
+			      local-map ,gdb-locals-watch-map-1)
+			    name))
+		       (insert
+			(concat name "\t" (nth 1 local)
+				"\t" (nth 2 local) "\n")))
+		   (set-window-point window p)))))))
+(defun gdb-get-register-names ()
+"Create a list of register names."
+(goto-char (point-min))
+(setq gdb-register-names nil)
+(while (re-search-forward gdb-data-list-register-names-regexp nil t)
+(push (match-string 1) gdb-register-names)))
 (provide 'gdb-ui)
 ;; arch-tag: e9fb00c5-74ef-469f-a088-37384caae352
 ;;; gdb-ui.el ends here

Mercurial > emacs

comparison lisp/progmodes/gdb-ui.el @ 83407:37d0562504bf