/[emacs]/emacs/lisp/gdb-ui.el
ViewVC logotype

Diff of /emacs/lisp/gdb-ui.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.43 by nickrob, Thu Sep 4 22:34:47 2003 UTC revision 1.44 by nickrob, Tue Sep 30 17:56:24 2003 UTC
# Line 50  Line 50 
50    
51  (require 'gud)  (require 'gud)
52    
 (defcustom gdb-window-height 20  
   "Number of lines in a frame for a displayed expression in GDB-UI."  
   :type 'integer  
   :group 'gud)  
   
 (defcustom gdb-window-width 30  
   "Width of a frame for a displayed expression in GDB-UI."  
   :type 'integer  
   :group 'gud)  
   
53  (defvar gdb-current-address "main" "Initialisation for Assembler buffer.")  (defvar gdb-current-address "main" "Initialisation for Assembler buffer.")
54  (defvar gdb-previous-address nil)  (defvar gdb-previous-address nil)
55  (defvar gdb-previous-frame nil)  (defvar gdb-previous-frame nil)
56  (defvar gdb-current-frame "main")  (defvar gdb-current-frame "main")
 (defvar gdb-display-in-progress nil)  
 (defvar gdb-dive nil)  
57  (defvar gdb-view-source t "Non-nil means that source code can be viewed")  (defvar gdb-view-source t "Non-nil means that source code can be viewed")
58  (defvar gdb-selected-view 'source "Code type that user wishes to view")  (defvar gdb-selected-view 'source "Code type that user wishes to view")
59    (defvar  gdb-var-list nil "List of variables in watch window")
60    (defvar  gdb-var-changed nil "Non-nil means that gdb-var-list has changed")
61    (defvar gdb-update-flag t "Non-il means update buffers")
62  (defvar gdb-buffer-type nil)  (defvar gdb-buffer-type nil)
63  (defvar gdb-variables '()  (defvar gdb-variables '()
64    "A list of variables that are local to the GUD buffer.")    "A list of variables that are local to the GUD buffer.")
65    
   
66  ;;;###autoload  ;;;###autoload
67  (defun gdba (command-line)  (defun gdba (command-line)
68    "Run gdb on program FILE in buffer *gud-FILE*.    "Run gdb on program FILE in buffer *gud-FILE*.
# Line 162  The following interactive lisp functions Line 152  The following interactive lisp functions
152    (setq gdb-previous-address nil)    (setq gdb-previous-address nil)
153    (setq gdb-previous-frame nil)    (setq gdb-previous-frame nil)
154    (setq gdb-current-frame "main")    (setq gdb-current-frame "main")
   (setq gdb-display-in-progress nil)  
   (setq gdb-dive nil)  
155    (setq gdb-view-source t)    (setq gdb-view-source t)
156    (setq gdb-selected-view 'source)    (setq gdb-selected-view 'source)
157      (setq gdb-var-list nil)
158      (setq gdb-var-changed nil)
159      (setq gdb-update-flag t)
160    ;;    ;;
161    (mapc 'make-local-variable gdb-variables)    (mapc 'make-local-variable gdb-variables)
162    (setq gdb-buffer-type 'gdba)    (setq gdb-buffer-type 'gdba)
# Line 182  The following interactive lisp functions Line 173  The following interactive lisp functions
173    ;;    ;;
174    (run-hooks 'gdba-mode-hook))    (run-hooks 'gdba-mode-hook))
175    
176  (defun gud-display ()  (defun gud-watch ()
177    "Auto-display (possibly dereferenced) C expression at point."    "Watch expression."
178    (interactive)    (interactive)
179    (save-excursion    (let ((expr (tooltip-identifier-from-point (point))))
180      (let ((expr (gud-find-c-expr)))      (setq expr (concat gdb-current-frame "::" expr))
181        (catch 'already-watched
182          (dolist (var gdb-var-list)
183            (if (string-equal expr (car var)) (throw 'already-watched nil)))
184        (gdb-enqueue-input        (gdb-enqueue-input
185         (list (concat "server ptype " expr "\n")         (list (concat "interpreter mi \"-var-create - * "  expr "\"\n")
186               `(lambda () (gud-display1 ,expr)))))))               `(lambda () (gdb-var-create-handler ,expr))))))
187      (select-window (get-buffer-window gud-comint-buffer)))
188    
189  (defun gud-display1 (expr)  (defconst gdb-var-create-regexp
190    (goto-char (point-min))  "name=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
191    (if (looking-at "No symbol")  
192    (defun gdb-var-create-handler (expr)
193      (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
194        (goto-char (point-min))
195        (if (re-search-forward gdb-var-create-regexp nil t)
196            (let ((var (list expr
197                             (match-string-no-properties 1)
198                             (match-string-no-properties 2)
199                             (match-string-no-properties 3)
200                             nil)))
201              (push var gdb-var-list)
202              (speedbar 1)
203              (if (equal (nth 2 var) "0")
204                  (gdb-enqueue-input
205                   (list (concat "interpreter mi \"-var-evaluate-expression "
206                                 (nth 1 var) "\"\n")
207                         `(lambda () (gdb-var-evaluate-expression-handler
208                                      ,(nth 1 var)))))
209                (setq gdb-var-changed t)))
210          (if (re-search-forward "Undefined command" nil t)
211              (message "Watching expressions requires gdb 6.0 onwards")
212            (message "No symbol %s in current context." expr)))))
213    
214    (defun gdb-var-evaluate-expression-handler (varnum)
215      (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
216        (goto-char (point-min))
217        (re-search-forward ".*value=\"\\(.*?\\)\"" nil t)
218        (let ((var-list nil))
219          (dolist (var gdb-var-list)
220            (if (string-equal varnum (cadr var))
221                (progn
222                  (push (nreverse (cons (match-string-no-properties 1)
223                                        (cdr (nreverse var)))) var-list))
224              (push var var-list)))
225          (setq gdb-var-list (nreverse var-list))))
226      (setq gdb-var-changed t))
227    
228    (defun gdb-var-list-children (varnum)
229      (gdb-enqueue-input
230       (list (concat "interpreter mi \"-var-list-children "  varnum "\"\n")
231                 `(lambda () (gdb-var-list-children-handler ,varnum)))))
232    
233    (defconst gdb-var-list-children-regexp
234    "name=\"\\(.*?\\)\",exp=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
235    
236    (defun gdb-var-list-children-handler (varnum)
237      (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
238        (goto-char (point-min))
239        (let ((var-list nil))
240         (catch 'child-already-watched
241           (dolist (var gdb-var-list)
242             (if (string-equal varnum (cadr var))
243                 (progn
244                   (push var var-list)
245                   (while (re-search-forward gdb-var-list-children-regexp nil t)
246                     (let ((varchild (list (match-string-no-properties 2)
247                                           (match-string-no-properties 1)
248                                           (match-string-no-properties 3)
249                                           (match-string-no-properties 4)
250                                           nil)))
251                       (dolist (var1 gdb-var-list)
252                         (if (string-equal (cadr var1) (cadr varchild))
253                             (throw 'child-already-watched nil)))
254                       (push varchild var-list)
255                       (if (equal (nth 2 varchild) "0")
256                           (gdb-enqueue-input
257                            (list
258                             (concat "interpreter mi \"-var-evaluate-expression "
259                                     (nth 1 varchild) "\"\n")
260                             `(lambda () (gdb-var-evaluate-expression-handler
261                                          ,(nth 1 varchild)))))))))
262               (push var var-list)))
263           (setq gdb-var-list (nreverse var-list))))))
264    
265    (defun gdb-var-update ()
266      (setq gdb-update-flag nil)
267      (if (not (member 'gdb-var-update (gdb-get-pending-triggers)))
268        (progn        (progn
269          (gdb-set-output-sink 'user)          (gdb-enqueue-input (list "server interpreter mi \"-var-update *\"\n"
270          (gud-call (concat "server ptype " expr)))                                   'gdb-var-update-handler))
271      (goto-char (- (point-max) 1))          (gdb-set-pending-triggers (cons 'gdb-var-update
272      (if (equal (char-before) (string-to-char "\*"))                                          (gdb-get-pending-triggers))))))
         (gud-call (concat "display* " expr))  
       (gud-call (concat "display " expr)))))  
   
 ; this would messy because these bindings don't work with M-x gdb  
 ; (define-key global-map "\C-x\C-a\C-a" 'gud-display)  
 ; (define-key gud-minor-mode-map "\C-c\C-a" 'gud-display)  
273    
274    (defconst gdb-var-update-regexp "name=\"\\(.*?\\)\"")
275    
276    (defun gdb-var-update-handler ()
277      (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
278        (goto-char (point-min))
279        (while (re-search-forward gdb-var-update-regexp nil t)
280            (let ((varnum (match-string-no-properties 1)))
281              (gdb-enqueue-input
282               (list (concat "interpreter mi \"-var-evaluate-expression "
283                             varnum "\"\n")
284                         `(lambda () (gdb-var-evaluate-expression-handler
285                                      ,varnum)))))))
286      (gdb-set-pending-triggers
287       (delq 'gdb-var-update (gdb-get-pending-triggers))))
288    
289    (defun gdb-var-delete (text token indent)
290      "Delete watched expression."
291      (interactive)
292      (when (eq indent 0)
293        (string-match "\\(\\S-+\\)" text)
294        (let* ((expr (match-string 1 text))
295               (var (assoc expr gdb-var-list))
296               (varnum (cadr var)))
297          (gdb-enqueue-input
298           (list (concat "interpreter mi \"-var-delete "  varnum "\"\n")
299                 'ignore))
300          (setq gdb-var-list (delq var gdb-var-list))
301          (dolist (varchild gdb-var-list)
302            (if (string-match (concat (nth 1 var) "\\.") (nth 1 varchild))
303                (setq gdb-var-list (delq varchild gdb-var-list)))))
304        (setq gdb-var-changed t)))
305    
306    (defun gdb-speedbar-expand-node (text token indent)
307      "Expand the node the user clicked on.
308    TEXT is the text of the button we clicked on, a + or - item.
309    TOKEN is data related to this node.
310    INDENT is the current indentation depth."
311      (cond ((string-match "+" text)        ;expand this node
312             (gdb-var-list-children token))
313            ((string-match "-" text)        ;contract this node
314             (dolist (var gdb-var-list)
315               (if (string-match (concat token "\\.") (nth 1 var))
316                   (setq gdb-var-list (delq var gdb-var-list))))
317             (setq gdb-var-changed t))))
318    
319    
320  ;; ======================================================================  ;; ======================================================================
# Line 445  This filter may simply queue output for Line 554  This filter may simply queue output for
554    (gdb-enqueue-input (concat string "\n")))    (gdb-enqueue-input (concat string "\n")))
555    
556  ;; Note: Stuff enqueued here will be sent to the next prompt, even if it  ;; Note: Stuff enqueued here will be sent to the next prompt, even if it
557  ;; is a query, or other non-top-level prompt.  ;; is a query, or other non-top-level prompt.
558    
559  (defun gdb-enqueue-input (item)  (defun gdb-enqueue-input (item)
560    (if (gdb-get-prompting)    (if (gdb-get-prompting)
# Line 489  This filter may simply queue output for Line 598  This filter may simply queue output for
598  ;; any newlines.  ;; any newlines.
599  ;;  ;;
600    
601  (defcustom gud-gdba-command-name "gdb -annotate=2 -noasync"  (defcustom gud-gdba-command-name "~/gdb/gdb/gdb -annotate=3"
602    "Default command to execute an executable under the GDB-UI debugger."    "Default command to execute an executable under the GDB-UI debugger."
603    :type 'string    :type 'string
604    :group 'gud)    :group 'gud)
# Line 511  This filter may simply queue output for Line 620  This filter may simply queue output for
620      ("watchpoint" gdb-stopping)      ("watchpoint" gdb-stopping)
621      ("frame-begin" gdb-frame-begin)      ("frame-begin" gdb-frame-begin)
622      ("stopped" gdb-stopped)      ("stopped" gdb-stopped)
     ("display-begin" gdb-display-begin)  
     ("display-end" gdb-display-end)  
 ; GDB commands info stack, info locals and frame generate an error-begin  
 ; annotation at start when there is no stack but this is a quirk/bug in  
 ; annotations.  
 ;    ("error-begin" gdb-error-begin)  
     ("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)  
623      ) "An assoc mapping annotation tags to functions which process them.")      ) "An assoc mapping annotation tags to functions which process them.")
624    
625  (defconst gdb-source-spec-regexp  (defconst gdb-source-spec-regexp
# Line 558  output from a previous command if that h Line 655  output from a previous command if that h
655      (cond      (cond
656       ((eq sink 'user) t)       ((eq sink 'user) t)
657       ((eq sink 'emacs)       ((eq sink 'emacs)
658        (gdb-set-output-sink 'post-emacs)        (gdb-set-output-sink 'post-emacs))
       (let ((handler  
              (car (cdr (gdb-get-current-item)))))  
         (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)  
           (funcall handler))))  
659       (t       (t
660        (gdb-set-output-sink 'user)        (gdb-set-output-sink 'user)
661        (error "Phase error in gdb-pre-prompt (got %s)" sink)))))        (error "Phase error in gdb-pre-prompt (got %s)" sink)))))
# Line 574  This sends the next command (if any) to Line 667  This sends the next command (if any) to
667      (cond      (cond
668       ((eq sink 'user) t)       ((eq sink 'user) t)
669       ((eq sink 'post-emacs)       ((eq sink 'post-emacs)
670        (gdb-set-output-sink 'user))        (gdb-set-output-sink 'user)
671          (let ((handler
672                 (car (cdr (gdb-get-current-item)))))
673            (with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
674              (funcall handler))))
675       (t       (t
676        (gdb-set-output-sink 'user)        (gdb-set-output-sink 'user)
677        (error "Phase error in gdb-prompt (got %s)" sink))))        (error "Phase error in gdb-prompt (got %s)" sink))))
# Line 632  that if we already set the output sink t Line 729  that if we already set the output sink t
729  (defun gdb-post-prompt (ignored)  (defun gdb-post-prompt (ignored)
730    "An annotation handler for `post-prompt'. This begins the collection of    "An annotation handler for `post-prompt'. This begins the collection of
731  output from the current command if that happens to be appropriate."  output from the current command if that happens to be appropriate."
732    (if (not (gdb-get-pending-triggers))    (if (and (not (gdb-get-pending-triggers)) gdb-update-flag)
733        (progn        (progn
734          (gdb-get-current-frame)          (gdb-get-current-frame)
735          (gdb-invalidate-frames)          (gdb-invalidate-frames)
# Line 640  output from the current command if that Line 737  output from the current command if that
737          (gdb-invalidate-assembler)          (gdb-invalidate-assembler)
738          (gdb-invalidate-registers)          (gdb-invalidate-registers)
739          (gdb-invalidate-locals)          (gdb-invalidate-locals)
         (gdb-invalidate-display)  
740          (gdb-invalidate-threads)))          (gdb-invalidate-threads)))
741      (setq gdb-update-flag t)
742    (let ((sink (gdb-get-output-sink)))    (let ((sink (gdb-get-output-sink)))
743      (cond      (cond
744       ((eq sink 'user) t)       ((eq sink 'user) t)
# Line 651  output from the current command if that Line 748  output from the current command if that
748        (gdb-set-output-sink 'user)        (gdb-set-output-sink 'user)
749        (error "Phase error in gdb-post-prompt (got %s)" sink)))))        (error "Phase error in gdb-post-prompt (got %s)" sink)))))
750    
 ;; If we get an error whilst evaluating one of the expressions  
 ;; we won't get the display-end annotation. Set the sink back to  
 ;; user to make sure that the error message is seen.  
 ;; NOT USED: see annotation-rules for reason.  
 ;(defun gdb-error-begin (ignored)  
 ;  (gdb-set-output-sink 'user))  
   
 (defun gdb-display-begin (ignored)  
   (gdb-set-output-sink 'emacs)  
   (gdb-clear-partial-output)  
   (setq gdb-display-in-progress t))  
   
 (defvar gdb-expression-buffer-name nil)  
 (defvar gdb-display-number nil)  
 (defvar gdb-dive-display-number nil)  
   
 (defun gdb-display-number-end (ignored)  
   (set-buffer (gdb-get-buffer 'gdb-partial-output-buffer))  
   (setq gdb-display-number (buffer-string))  
   (setq gdb-expression-buffer-name  
         (concat "*display " gdb-display-number "*"))  
   (save-excursion  
     (if (progn  
           (set-buffer (window-buffer))  
           gdb-dive)  
         (progn  
           (let ((number gdb-display-number))  
             (switch-to-buffer  
              (set-buffer (get-buffer-create gdb-expression-buffer-name)))  
             (gdb-expressions-mode)  
             (setq gdb-dive-display-number number)))  
       (set-buffer (get-buffer-create gdb-expression-buffer-name))  
       (if (display-graphic-p)  
           (catch 'frame-exists  
             (dolist (frame (frame-list))  
               (if (string-equal (frame-parameter frame 'name)  
                                 gdb-expression-buffer-name)  
                   (throw 'frame-exists nil)))  
             (gdb-expressions-mode)  
             (make-frame `((height . ,gdb-window-height)  
                           (width . ,gdb-window-width)  
                           (tool-bar-lines . nil)  
                           (menu-bar-lines . nil)  
                           (minibuffer . nil))))  
         (gdb-expressions-mode)  
         (gdb-display-buffer (get-buffer gdb-expression-buffer-name)))))  
   (set-buffer (gdb-get-buffer 'gdb-partial-output-buffer))  
   (setq gdb-dive nil))  
   
 (defvar gdb-nesting-level nil)  
 (defvar gdb-expression nil)  
 (defvar gdb-point nil)  
 (defvar gdb-annotation-arg nil)  
   
 (defun gdb-delete-line ()  
   "Delete the current line."  
   (delete-region (line-beginning-position) (line-beginning-position 2)))  
   
 (defun gdb-display-end (ignored)  
   (set-buffer (gdb-get-buffer 'gdb-partial-output-buffer))  
   (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))))  
     (with-current-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)))  
       (if (not header-line-format)  
           (setq header-line-format (concat "-- " gdb-expression " %-")))))  
   ;;  
   ;;-if scalar/string  
   (if (not (re-search-forward "##" nil t))  
       (progn  
         (with-current-buffer gdb-expression-buffer-name  
           (let ((buffer-read-only nil))  
             (delete-region (point-min) (point-max))  
             (insert-buffer-substring  
              (gdb-get-buffer 'gdb-partial-output-buffer)))))  
     ;; display expression name...  
     (goto-char (point-min))  
     (let ((start (progn (point)))  
           (end (progn (end-of-line) (point))))  
       (with-current-buffer gdb-expression-buffer-name  
         (let ((buffer-read-only nil))  
           (delete-region (point-min) (point-max))  
           (insert-buffer-substring (gdb-get-buffer  
                                     'gdb-partial-output-buffer)  
                                    start end)  
           (insert "\n"))))  
     (goto-char (point-min))  
     (re-search-forward "##" nil t)  
     (setq gdb-nesting-level 0)  
     (if (looking-at "array-section-begin")  
         (progn  
           (gdb-delete-line)  
           (setq gdb-point (point))  
           (gdb-array-format)))  
     (if (looking-at "field-begin \\(.\\)")  
         (progn  
           (setq gdb-annotation-arg (match-string 1))  
           (gdb-field-format-begin))))  
   (with-current-buffer gdb-expression-buffer-name  
     (if gdb-dive-display-number  
         (progn  
           (let ((buffer-read-only nil))  
             (goto-char (point-max))  
             (insert "\n")  
             (insert-text-button "[back]" 'type 'gdb-display-back)))))  
   (gdb-clear-partial-output)  
   (gdb-set-output-sink 'user)  
   (setq gdb-display-in-progress nil))  
   
 (define-button-type 'gdb-display-back  
   'help-echo "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-enqueue-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  
         (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)  
           (goto-char (point-max))  
           (insert (concat "\n##array-section-begin " args "\n"))))))  
   
 (defun gdb-array-section-end (ignored)  
   (if gdb-display-in-progress  
       (progn  
         (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)  
           (goto-char (point-max))  
           (insert "\n##array-section-end\n")))))  
   
 (defun gdb-field-begin (args)  
   (if gdb-display-in-progress  
       (progn  
         (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)  
           (goto-char (point-max))  
           (insert (concat "\n##field-begin " args "\n"))))))  
   
 (defun gdb-field-end (ignored)  
   (if gdb-display-in-progress  
       (progn  
         (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)  
           (goto-char (point-max))  
           (insert "\n##field-end\n")))))  
   
 (defun gdb-elt (ignored)  
   (if gdb-display-in-progress  
       (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  
   (let ((map (make-sparse-keymap)))  
     (define-key map [mouse-2] 'gdb-dive)  
     (define-key map [S-mouse-2] 'gdb-dive-new-frame)  
     map))  
   
 (defun gdb-dive (event)  
   "Dive into structure."  
   (interactive "e")  
   (setq gdb-dive t)  
   (gdb-dive-new-frame event))  
   
 (defun gdb-dive-new-frame (event)  
   "Dive into structure and display in a new frame."  
   (interactive "e")  
   (save-excursion  
     (mouse-set-point event)  
     (let ((point (point)) (gdb-full-expression gdb-expression)  
           (end (progn (end-of-line) (point)))  
           (gdb-part-expression "") (gdb-last-field nil) (gdb-display-char nil))  
       (beginning-of-line)  
       (if (looking-at "\*") (setq gdb-display-char "*"))  
       (re-search-forward "\\(\\S-+\\) = " end t)  
       (setq gdb-last-field (match-string-no-properties 1))  
       (goto-char (match-beginning 1))  
       (let ((last-column (current-column)))  
         (while (re-search-backward "\\s-\\(\\S-+\\) = {" nil t)  
           (goto-char (match-beginning 1))  
           (if (and (< (current-column) last-column)  
                    (> (count-lines 1 (point)) 1))  
               (progn  
                 (setq gdb-part-expression  
                       (concat "." (match-string-no-properties 1)  
                               gdb-part-expression))  
                 (setq last-column (current-column))))))  
       ;; * not needed for components of a pointer to a structure in gdb  
       (if (string-equal "*" (substring gdb-full-expression 0 1))  
           (setq gdb-full-expression (substring gdb-full-expression 1 nil)))  
       (setq gdb-full-expression  
             (concat gdb-full-expression gdb-part-expression "." gdb-last-field))  
       (gdb-enqueue-input  
        (list (concat "server display" gdb-display-char  
                      " " gdb-full-expression "\n")  
              'ignore)))))  
   
 (defun gdb-insert-field ()  
   (let ((start (progn (point)))  
         (end (progn (next-line) (point)))  
         (num 0))  
     (with-current-buffer gdb-expression-buffer-name  
       (let ((buffer-read-only nil))  
         (if (string-equal gdb-annotation-arg "\*") (insert "\*"))  
         (while (<= num gdb-nesting-level)  
           (insert "\t")  
           (setq num (+ num 1)))  
         (insert-buffer-substring (gdb-get-buffer  
                                   'gdb-partial-output-buffer)  
                                  start end)  
         (add-text-properties  
          (- (point) (- end start)) (- (point) 1)  
          `(mouse-face highlight  
            local-map ,gdb-dive-map  
            help-echo "mouse-2: dive, S-mouse-2: dive in a new frame"))))  
     (delete-region start end)))  
   
 (defvar gdb-values nil)  
   
 (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))))  
                 (with-current-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 nil)  
 (defvar gdb-array-stop nil)  
   
 (defvar gdb-array-slice-map  
   (let ((map (make-sparse-keymap)))  
     (define-key map "\r" 'gdb-array-slice)  
     (define-key map [mouse-2] 'gdb-mouse-array-slice)  
     map))  
   
 (defun gdb-mouse-array-slice (event)  
   "Select an array slice to display."  
   (interactive "e")  
   (mouse-set-point event)  
   (gdb-array-slice))  
   
 (defun gdb-array-slice ()  
   (interactive)  
   (save-excursion  
     (let ((n -1) (stop 0) (start 0) (point (point)))  
       (beginning-of-line)  
       (while (search-forward "[" point t)  
         (setq n (+ n 1)))  
       (setq start (string-to-int (read-string "Start index: ")))  
       (aset gdb-array-start n start)  
       (setq stop (string-to-int (read-string "Stop index: ")))  
       (aset gdb-array-stop n stop)))  
   (gdb-array-format1))  
   
 (defvar gdb-display-string nil)  
 (defvar gdb-array-size nil)  
   
 (defun gdb-array-format1 ()  
   (setq gdb-display-string "")  
   (let ((buffer-read-only nil))  
     (delete-region (point-min) (point-max))  
     (let ((gdb-value-list (split-string gdb-values  ", ")))  
       (string-match "\\({+\\)" (car gdb-value-list))  
       (let* ((depth (- (match-end 1) (match-beginning 1)))  
              (indices  (make-vector depth '0))  
              (index 0) (num 0) (array-start "")  
              (array-stop "") (array-slice "") (array-range nil)  
              (flag t) (indices-string ""))  
         (dolist (gdb-value gdb-value-list)  
           (string-match "{*\\([^}]*\\)\\(}*\\)" gdb-value)  
           (setq num 0)  
           (while (< num depth)  
             (setq indices-string  
                   (concat indices-string  
                           "[" (int-to-string (aref indices num)) "]"))  
             (if (not (= (aref gdb-array-start num) -1))  
                 (if (or (< (aref indices num) (aref gdb-array-start num))  
                         (> (aref indices num) (aref gdb-array-stop num)))  
                     (setq flag nil))  
               (aset gdb-array-size num (aref indices num)))  
             (setq num (+ num 1)))  
           (if flag  
               (let ((gdb-display-value (match-string 1 gdb-value)))  
                 (setq gdb-display-string (concat gdb-display-string " "  
                                                  gdb-display-value))  
                 (insert  
                  (concat indices-string "\t" gdb-display-value "\n"))))  
           (setq indices-string "")  
           (setq flag t)  
           ;; 0<= index < depth, start at right : (- depth 1)  
           (setq index (- (- depth 1)  
                          (- (match-end 2) (match-beginning 2))))  
           ;;don't set for very last brackets  
           (when (>= index 0)  
             (aset indices index (+ 1 (aref indices index)))  
             (setq num (+ 1 index))  
             (while (< num depth)  
               (aset indices num 0)  
               (setq num (+ num 1)))))  
         (setq num 0)  
         (while (< num depth)  
           (if (= (aref gdb-array-start num) -1)  
               (progn  
                 (aset gdb-array-start num 0)  
                 (aset gdb-array-stop num (aref indices num))))  
           (setq array-start (int-to-string (aref gdb-array-start num)))  
           (setq array-stop (int-to-string (aref gdb-array-stop num)))  
           (setq array-range (concat "[" array-start  
                                     ":" array-stop "]"))  
           (add-text-properties  
            1 (+ (length array-start) (length array-stop) 2)  
            `(mouse-face highlight  
              local-map ,gdb-array-slice-map  
              help-echo "mouse-2, RET: select slice for this index") array-range)  
           (goto-char (point-min))  
           (setq array-slice (concat array-slice array-range))  
           (setq num (+ num 1)))  
         (goto-char (point-min))  
         (insert "Array Size : ")  
         (setq num 0)  
         (while (< num depth)  
           (insert  
            (concat "["  
                    (int-to-string (+ (aref gdb-array-size num) 1)) "]"))  
           (setq num (+ num 1)))  
         (insert  
          (concat "\n     Slice : " array-slice "\n\nIndex\tValues\n\n"))))))  
   
751  (defun gud-gdba-marker-filter (string)  (defun gud-gdba-marker-filter (string)
752    "A gud marker filter for gdb. Handle a burst of output from GDB."    "A gud marker filter for gdb. Handle a burst of output from GDB."
753    (let (    (let (
# Line 1728  the source buffer." Line 1439  the source buffer."
1439    (switch-to-buffer-other-frame    (switch-to-buffer-other-frame
1440     (gdb-get-create-buffer 'gdb-locals-buffer)))     (gdb-get-create-buffer 'gdb-locals-buffer)))
1441    
 ;;  
 ;; Display expression buffer.  
 ;;  
 (gdb-set-buffer-rules 'gdb-display-buffer  
                       'gdb-display-buffer-name  
                       'gdb-display-mode)  
   
 (def-gdb-auto-updated-buffer gdb-display-buffer  
   ;; `gdb-display-buffer'.  
   gdb-invalidate-display  
   "server info display\n"  
   gdb-info-display-handler  
   gdb-info-display-custom)  
   
 (defun gdb-info-display-custom ()  
   (let ((display-list nil))  
     (with-current-buffer (gdb-get-buffer 'gdb-display-buffer)  
       (goto-char (point-min))  
       (while (< (point) (- (point-max) 1))  
         (forward-line 1)  
         (if (looking-at "\\([0-9]+\\):   \\([ny]\\)")  
             (setq display-list  
                   (cons (string-to-int (match-string 1)) display-list)))  
         (end-of-line)))  
     (if (not (display-graphic-p))  
         (progn  
           (dolist (buffer (buffer-list))  
             (if (string-match "\\*display \\([0-9]+\\)\\*" (buffer-name buffer))  
                 (progn  
                   (let ((number  
                          (match-string 1 (buffer-name buffer))))  
                     (if (not (memq (string-to-int number) display-list))  
                         (kill-buffer  
                          (get-buffer (concat "*display " number "*")))))))))  
       (gdb-delete-frames display-list))))  
   
 (defun gdb-delete-frames (display-list)  
   (dolist (frame (frame-list))  
     (let ((frame-name (frame-parameter frame 'name)))  
       (if (string-match "\\*display \\([0-9]+\\)\\*" frame-name)  
           (progn  
             (let ((number (match-string 1 frame-name)))  
               (if (not (memq (string-to-int number) display-list))  
                   (progn (kill-buffer  
                           (get-buffer (concat "*display " number "*")))  
                          (delete-frame frame)))))))))  
   
 (defvar gdb-display-mode-map  
   (let ((map (make-sparse-keymap))  
         (menu (make-sparse-keymap "Display")))  
     (define-key menu [toggle] '("Toggle" . gdb-toggle-display))  
     (define-key menu [delete] '("Delete" . gdb-delete-display))  
   
     (suppress-keymap map)  
     (define-key map [menu-bar display] (cons "Display" menu))  
     (define-key map " " 'gdb-toggle-display)  
     (define-key map "d" 'gdb-delete-display)  
     map))  
   
 (defun gdb-display-mode ()  
   "Major mode for gdb display.  
   
 \\{gdb-display-mode-map}"  
   (setq major-mode 'gdb-display-mode)  
   (setq mode-name "Display")  
   (setq buffer-read-only t)  
   (use-local-map gdb-display-mode-map)  
   (gdb-invalidate-display))  
   
 (defun gdb-display-buffer-name ()  
   (with-current-buffer gud-comint-buffer  
     (concat "*Displayed expressions of " (gdb-get-target-string) "*")))  
   
 (defun gdb-display-display-buffer ()  
   (interactive)  
   (gdb-display-buffer  
    (gdb-get-create-buffer 'gdb-display-buffer)))  
   
 (defun gdb-frame-display-buffer ()  
   (interactive)  
   (switch-to-buffer-other-frame  
    (gdb-get-create-buffer 'gdb-display-buffer)))  
   
 (defun gdb-toggle-display ()  
   "Enable/disable the displayed expression at current line."  
   (interactive)  
   (save-excursion  
     (beginning-of-line 1)  
     (if (not (looking-at "\\([0-9]+\\):   \\([ny]\\)"))  
         (error "No expression on this line")  
       (gdb-enqueue-input  
        (list  
         (concat  
          (if (eq ?y (char-after (match-beginning 2)))  
              "server disable display "  
            "server enable display ")  
          (match-string 1) "\n")  
         'ignore)))))  
   
 (defun gdb-delete-display ()  
   "Delete the displayed expression at current line."  
   (interactive)  
   (with-current-buffer (gdb-get-buffer 'gdb-display-buffer)  
     (beginning-of-line 1)  
     (if (not (looking-at "\\([0-9]+\\):   \\([ny]\\)"))  
         (error "No expression on this line")  
       (let ((number (match-string 1)))  
         (gdb-enqueue-input  
          (list (concat "server delete display " number "\n") 'ignore))))))  
   
 (defvar gdb-expressions-mode-map  
   (let ((map (make-sparse-keymap)))  
     (suppress-keymap map)  
     (define-key map "v" 'gdb-array-visualise)  
     (define-key map "q" 'gdb-delete-expression)  
     (define-key map [mouse-3] 'gdb-expressions-popup-menu)  
     map))  
   
 (defvar gdb-expressions-mode-menu  
   '("GDB Expressions Commands"  
     "----"  
     ["Visualise" gdb-array-visualise t]  
     ["Delete"    gdb-delete-expression  t])  
   "Menu for `gdb-expressions-mode'.")  
   
 (defun gdb-expressions-popup-menu (event)  
   "Explicit Popup menu as this buffer doesn't have a menubar."  
   (interactive "@e")  
   (mouse-set-point event)  
   (popup-menu gdb-expressions-mode-menu))  
   
 (defun gdb-expressions-mode ()  
   "Major mode for display expressions.  
   
 \\{gdb-expressions-mode-map}"  
   (setq major-mode 'gdb-expressions-mode)  
   (setq mode-name "Expressions")  
   (use-local-map gdb-expressions-mode-map)  
   (make-local-variable 'gdb-display-number)  
   (make-local-variable 'gdb-values)  
   (make-local-variable 'gdb-expression)  
   (set (make-local-variable 'gdb-display-string) nil)  
   (set (make-local-variable 'gdb-dive-display-number) nil)  
   (set (make-local-variable 'gud-minor-mode) 'gdba)  
   (set (make-local-variable 'gdb-array-start) (make-vector 16 '-1))  
   (set (make-local-variable 'gdb-array-stop)  (make-vector 16 '-1))  
   (set (make-local-variable 'gdb-array-size)  (make-vector 16 '-1))  
   (setq buffer-read-only t))  
   
1442    
1443  ;;;; Window management  ;;;; Window management
1444    
# Line 1943  the source buffer." Line 1505  the source buffer."
1505    (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))    (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
1506    (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))    (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))
1507    (define-key menu [breakpoints] '("Breakpoints" . gdb-frame-breakpoints-buffer))    (define-key menu [breakpoints] '("Breakpoints" . gdb-frame-breakpoints-buffer))
   (define-key menu [display] '("Display" . gdb-frame-display-buffer))  
1508    (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))    (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
1509  ;  (define-key menu [assembler] '("Assembler" . gdb-frame-assembler-buffer))  ;  (define-key menu [assembler] '("Assembler" . gdb-frame-assembler-buffer))
1510  )  )
# Line 1956  the source buffer." Line 1517  the source buffer."
1517    (define-key menu [registers] '("Registers" . gdb-display-registers-buffer))    (define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
1518    (define-key menu [frames] '("Stack" . gdb-display-stack-buffer))    (define-key menu [frames] '("Stack" . gdb-display-stack-buffer))
1519    (define-key menu [breakpoints] '("Breakpoints" . gdb-display-breakpoints-buffer))    (define-key menu [breakpoints] '("Breakpoints" . gdb-display-breakpoints-buffer))
   (define-key menu [display] '("Display" . gdb-display-display-buffer))  
1520    (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))    (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
1521  ;  (define-key menu [assembler] '("Assembler" . gdb-display-assembler-buffer))  ;  (define-key menu [assembler] '("Assembler" . gdb-display-assembler-buffer))
1522  )  )
# Line 2021  the source buffer." Line 1581  the source buffer."
1581    (gdb-display-stack-buffer)    (gdb-display-stack-buffer)
1582    (delete-other-windows)    (delete-other-windows)
1583    (gdb-display-breakpoints-buffer)    (gdb-display-breakpoints-buffer)
   (gdb-display-display-buffer)  
1584    (delete-other-windows)    (delete-other-windows)
1585    (switch-to-buffer gud-comint-buffer)    (switch-to-buffer gud-comint-buffer)
1586    (split-window nil ( / ( * (window-height) 3) 4))    (split-window nil ( / ( * (window-height) 3) 4))
# Line 2089  This arrangement depends on the value of Line 1648  This arrangement depends on the value of
1648  (defun gdb-reset ()  (defun gdb-reset ()
1649    "Exit a debugging session cleanly by killing the gdb buffers and resetting    "Exit a debugging session cleanly by killing the gdb buffers and resetting
1650   the source buffers."   the source buffers."
   (gdb-delete-frames '())  
1651    (dolist (buffer (buffer-list))    (dolist (buffer (buffer-list))
1652      (if (not (eq buffer gud-comint-buffer))      (if (not (eq buffer gud-comint-buffer))
1653          (with-current-buffer buffer          (with-current-buffer buffer
1654            (if (eq gud-minor-mode 'gdba)            (if (memq gud-minor-mode '(gdba pdb))
1655                (if (string-match "^\*.+*$" (buffer-name))                (if (string-match "^\*.+*$" (buffer-name))
1656                    (kill-buffer nil)                    (kill-buffer nil)
1657                  (if (display-images-p)                  (if (display-images-p)
# Line 2128  buffers." Line 1686  buffers."
1686    (if gdb-many-windows    (if gdb-many-windows
1687        (gdb-setup-windows)        (gdb-setup-windows)
1688      (gdb-display-breakpoints-buffer)      (gdb-display-breakpoints-buffer)
     (gdb-display-display-buffer)  
1689      (delete-other-windows)      (delete-other-windows)
1690      (split-window)      (split-window)
1691      (other-window 1)      (other-window 1)
# Line 2195  BUFFER nil or omitted means use the curr Line 1752  BUFFER nil or omitted means use the curr
1752          (when (overlay-get overlay 'put-arrow)          (when (overlay-get overlay 'put-arrow)
1753            (delete-overlay overlay)))            (delete-overlay overlay)))
1754        (setq overlays (cdr overlays)))))        (setq overlays (cdr overlays)))))
   
 (defun gdb-array-visualise ()  
   "Visualise arrays and slices using graph program from plotutils."  
   (interactive)  
   (when (and (display-graphic-p) gdb-display-string)  
     (let ((n 0) m)  
       (catch 'multi-dimensional  
         (while (eq (aref gdb-array-start n) (aref gdb-array-stop n))  
           (setq n (+ n 1)))  
         (setq m (+ n 1))  
         (while (< m (length gdb-array-start))  
           (if (not (eq (aref gdb-array-start m) (aref gdb-array-stop m)))  
               (progn  
                 (x-popup-dialog  
                  t `(,(concat "Only one dimensional data can be visualised.\n"  
                               "Use an array slice to reduce the number of\n"  
                               "dimensions") ("OK" t)))  
                 (throw 'multi-dimensional nil))  
             (setq m (+ m 1))))  
         (shell-command (concat "echo" gdb-display-string " | graph -a 1 "  
                                (int-to-string (aref gdb-array-start n))  
                                " -x "  
                                (int-to-string (aref gdb-array-start n))  
                                " "  
                                (int-to-string (aref gdb-array-stop  n))  
                                " 1 -T X"))))))  
   
 (defun gdb-delete-expression ()  
   "Delete displayed expression and its frame."  
   (interactive)  
   (gdb-enqueue-input  
    (list (concat "server delete display " gdb-display-number "\n")  
          'ignore)))  
1755    
1756  ;;  ;;
1757  ;; Assembler buffer.  ;; Assembler buffer.

Legend:
Removed from v.1.43  
changed lines
  Added in v.1.44

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26