Mercurial > hg > xemacs-beta
diff lisp/comint/gdb-highlight.el @ 155:43dd3413c7c7 r20-3b4
Import from CVS: tag r20-3b4
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:39:39 +0200 |
| parents | |
| children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/comint/gdb-highlight.el Mon Aug 13 09:39:39 2007 +0200 @@ -0,0 +1,1588 @@ +;;; gdb-highlight.el --- make gdb buffers be mouse-sensitive. + +;;; Copyright (C) 1997 Jamie Zawinski <jwz@netscape.com> + +;; Author: Jamie Zawinski <jwz@netscape.com> +;; Created: 16-Apr-1997 +;; Version: 1.2 (17-May-97) +;; Keywords: extensions, c, unix, tools, debugging + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not synched. + +;;; Commentary: +;; +;; This package makes most objects printed in a *gdb* buffer be +;; mouse-sensitive: as text shows up in the buffer, it is parsed, +;; and objects which are recognized have context-sensitive commands +;; attached to them. Generally, the types that are noticed are: +;; +;; = function and method names; +;; = variable and parameter names; +;; = structure and object slots; +;; = source file names; +;; = type names; +;; = breakpoint numbers; +;; = stack frame numbers. +;; +;; Any time one of those objects is presented in the *gdb* buffer, +;; it will be mousable. Clicking middle mouse button (button2) on +;; it will take some default action -- edit the function, select +;; the stack frame, disable the breakpoint, etc. Clicking the right +;; mouse button (button3) will bring up a menu of commands, including +;; commands specific to the object under the mouse, or other objects +;; on the same line. +;; +;; In addition to these context-sensitive commands are more general +;; gdb commands which were previously inaccessible via the mouse +;; (listing breakpoints, returning values, etc); and the general +;; comint/shell-buffer commands which had been present before. +;; +;; If you notice an object being presented which could (usefully) +;; be made mouse sensitive, but which currently is not, please let +;; me know. + +;;; Installation: +;; +;; To install, add this to your .emacs file: +;; (add-hook 'gdb-mode-hook '(lambda () (require 'gdb-highlight))) + +;;; TODO: +;; +;; = It doesn't really work very well unless you've done `set width 0' +;; in your .gdbinit. It would be nice if this were fixed. +;; (And with `set width 0', `set print pretty on' is the way to go.) +;; +;; = In some contexts, the toggle-breakpoint command doesn't work, +;; because this code doesn't know whether it's enabled. It should +;; remember, or figure it out, or something. +;; +;; = Make it possible to edit the `keep' state of breakpoints. +;; +;; = Is it useful to make addresses clickable? If an address is +;; always acompanied by a variable, then no. +;; +;; = There has got to be a better way to implement `gdb-guess-file-name'. +;; +;; = Make some new toolbar icons and put the most common commands on it. +;; +;; = Maybe make gdb-toolbar-clear work more reliably by consulting a +;; breakpoint-number extent? +;; +;; = I want breakpoint icons in my source files, just like in Energize. +;; +;; = Add a command to quit-and-restart the debugger, with the same +;; breakpoints and program-arguments. (This wouldn't be interesting +;; if gdb didn't leak like a sieve...) +;; +;; = Figure out some way to realize when extents are no longer interesting +;; (stack frames and local variables that are no longer on the stack) +;; and make them no longer be mousable. This is tricky... Nuke them +;; whenever a "run" command is seen? +;; +;; = Make C-x SPC in a source buffer use gdb-menu-command so that it will +;; interrupt-and-continue the debugged program as necessary. +;; +;; = Do stuff for watchpoints (but I never use them, myself.) + +;;; WISHLIST: +;; +;; (extracted from my 13-May-1997 message to comp.emacs and +;; comp.emacs.xemacs, news:33785828.5A524730@netscape.com) +;; +;; 6.1. Make gdbsrc-mode not suck. +;; +;; The idea behind gdbsrc-mode is on the side of the angels: one +;; should be able to focus on the source code and not on the +;; debugger buffer, absolutely. But the implementation is just +;; awful. +;; +;; First and foremost, it should not change "modes" (in the more +;; general sense). Any commands that it defines should be on +;; keys which are exclusively used for that purpose, not keys +;; which are normally self-inserting. I can't be the only person +;; who usually has occasion to actually *edit* the sources which +;; the debugger has chosen to display! Switching into and out of +;; gdbsrc-mode is prohibitive. +;; +;; I want to be looking at my sources at all times, yet I don't +;; want to have to give up my source-editing gestures. I think +;; the right way to accomplish this is to put the gdbsrc commands +;; on the toolbar and on popup menus; or to let the user define +;; their own keys (I could see devoting my kp_enter key to +;; "step", or something common like that.) +;; +;; Also it's extremely frustrating that one can't turn off gdbsrc +;; mode once it has been loaded, without exiting and restarting +;; emacs; that alone means that I'd probably never take the time +;; to learn how to use it, without first having taken the time to +;; repair it... +;; +;; 6.2. Make it easier access to variable values. +;; +;; I want to be able to double-click on a variable name to +;; highlight it, and then drag it to the debugger window to have +;; its value printed. +;; +;; I want gestures that let me write as well as read: for +;; example, to store value A into slot B. +;; +;; 6.3. Make all breakpoints visible. +;; +;; Any time there is a running gdb which has breakpoints, the +;; buffers holding the lines on which those breakpoints are set +;; should have icons in them. These icons should be context- +;; sensitive: I should be able to pop up a menu to enable or +;; disable them, to delete them, to change their commands or +;; conditions. +;; +;; I should also be able to MOVE them. It's annoying when you +;; have a breakpoint with a complex condition or command on it, +;; and then you realize that you really want it to be at a +;; different location. I want to be able to drag-and-drop the +;; icon to its new home. +;; +;; 6.4. Make a debugger status display window. +;; +;; o I want a window off to the side that shows persistent +;; information -- it should have a pane which is a +;; drag-editable, drag-reorderable representation of the +;; elements on gdb's "display" list; they should be displayed +;; here instead of being just dumped in with the rest of the +;; output in the *gdb* buffer. +;; +;; o I want a pane that displays the current call-stack and +;; nothing else. I want a pane that displays the arguments +;; and locals of the currently-selected frame and nothing +;; else. I want these both to update as I move around on the +;; stack. +;; +;; Since the unfortunate reality is that excavating this +;; information from gdb can be slow, it would be a good idea +;; for these panes to have a toggle button on them which meant +;; "stop updating", so that when I want to move fast, I can, +;; but I can easily get the display back when I need it again. +;; +;; The reason for all of this is that I spend entirely too much +;; time scrolling around in the *gdb* buffer; with gdb-highlight, +;; I can just click on a line in the backtrace output to go to +;; that frame, but I find that I spend a lot of time *looking* +;; for that backtrace: since it's mixed in with all the other +;; random output, I waste time looking around for things (and +;; usually just give up and type "bt" again, then thrash around +;; as the buffer scrolls, and I try to find the lower frames that +;; I'm interested in, as they have invariably scrolled off the +;; window already... +;; +;; 6.5. Save and restore breakpoints across emacs/debugger sessions. +;; +;; This would be especially handy given that gdb leaks like a +;; sieve, and with a big program, I only get a few dozen +;; relink-and-rerun attempts before gdb has blown my swap space. +;; +;; 6.6. Keep breakpoints in sync with source lines. +;; +;; When a program is recompiled and then reloaded into gdb, the +;; breakpoints often end up in less-than-useful places. For +;; example, when I edit text which occurs in a file anywhere +;; before a breakpoint, emacs is aware that the line of the bp +;; hasn't changed, but just that it is in a different place +;; relative to the top of the file. Gdb doesn't know this, so +;; your breakpoints end up getting set in the wrong places +;; (usually the maximally inconvenient places, like *after* a +;; loop instead of *inside* it). But emacs knows, so emacs +;; should inform the debugger, and move the breakpoints back to +;; the places they were intended to be. +;; +;; (Possibly the OOBR stuff does some of this, but can't tell, +;; because I've never been able to get it to do anything but beep at +;; me and mumble about environments. I find it pretty funny that the +;; manual keeps explaining to me how intuitive it is, without +;; actually giving me a clue how to launch it...) + + +;;; Code: +;; +;; This code should be considered an example of how over-use of regular +;; expressions leads to code that is an unreadable, unmaintainable mess, +;; and why it's unfortunate that so much of emacs's speed depends on +;; their use, rather than on the use of more traditional parsers. + +(require 'gdb) + +(define-key gdb-mode-map 'button3 'gdb-popup-menu) +(defvar gdb-popup-menu + '("GDB Commands" + ["Up Stack" (gdb-menu-command "up" t) t] + ["Down Stack" (gdb-menu-command "down" t) t] + ["Next Line" (gdb-menu-command "next" t) t] + ["Next Line (Step In)" (gdb-menu-command "step" t) t] + ["Continue" (gdb-menu-command "continue" t) t] + ["Continue Until Return" (gdb-menu-command "finish" t) t] + ("Return..." + ["Return" (gdb-menu-command "return" t) t] + ["Return 0" (gdb-menu-command "return 0" t) t] + ["Return 1" (gdb-menu-command "return 1" t) t] + ["Return -1" (gdb-menu-command "return -1" t) t] + ["Return $" (gdb-menu-command "return $" t) t] + ) + "---" + ["Backtrace" (gdb-menu-command "backtrace" t) t] + ["List Breakpoints" (gdb-menu-command "info breakpoints" t) t] + ["List Local Variables" (gdb-menu-command "info locals" t) t] + ) + "Commands for the popup menu in gdb-mode. +The comint-popup-menu is appended to this, and certain context-sensitive +commands may be prepended to it, depending on the location of the mouse +when the `gdb-popup-menu' command is invoked.") + + +;;; Faces and keymaps used for mousable tokens in the *gdb* buffer. + +(defvar gdb-highlight-face 'gdb-highlight-face) ; the base face +(defvar gdb-breakpoint-number-face 'gdb-breakpoint-number-face) +;(defvar gdb-breakpoint-keep-face 'gdb-breakpoint-keep-face) +(defvar gdb-breakpoint-enabled-face 'gdb-breakpoint-enabled-face) +(defvar gdb-function-name-face 'gdb-function-name-face) +(defvar gdb-function-location-face 'gdb-function-location-face) +(defvar gdb-variable-name-face 'gdb-variable-name-face) +(defvar gdb-type-name-face 'gdb-type-name-face) + +(make-face 'gdb-highlight-face) +(or (face-differs-from-default-p 'gdb-highlight-face) + (make-face-italic 'gdb-highlight-face)) + +(let ((faces '(gdb-breakpoint-number-face + gdb-breakpoint-enabled-face + ;gdb-breakpoint-keep-face + gdb-function-name-face + gdb-function-location-face + gdb-variable-name-face + gdb-type-name-face))) + (while faces + (make-face (car faces)) + (or (face-differs-from-default-p (car faces)) + (if (fboundp 'set-face-parent) + (set-face-parent (car faces) 'gdb-highlight-face) + (copy-face 'gdb-highlight-face (car faces)))) + (setq faces (cdr faces)))) + + +(defvar gdb-token-map ; the base map, inherited by all. + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-token-map) + (define-key m 'button2 'undefined) + ;;(define-key m 'button3 'gdb-token-popup) + m)) + +(defvar gdb-breakpoint-number-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-breakpoint-number-map) + (set-keymap-parent m gdb-token-map) + ;; not sure if this is the most useful binding... maybe "delete" is better? + (define-key m 'button2 'gdb-mouse-disable-breakpoint) + m)) + +(defvar gdb-info-breakpoint-number-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-breakpoint-number-map) + (set-keymap-parent m gdb-token-map) + ;; not sure if this is the most useful binding... maybe "delete" is better? + (define-key m 'button2 'gdb-mouse-toggle-breakpoint-enabled) + m)) + +;(defvar gdb-breakpoint-keep-map +; (let ((m (make-sparse-keymap))) +; (set-keymap-name m 'gdb-breakpoint-keep-map) +; (set-keymap-parent m gdb-token-map) +; (define-key m 'button2 'gdb-token-mouse-toggle-keep) +; m)) + +(defvar gdb-breakpoint-enabled-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-breakpoint-enabled-map) + (set-keymap-parent m gdb-token-map) + (define-key m 'button2 'gdb-mouse-toggle-breakpoint-enabled) + m)) + +(defvar gdb-function-name-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-function-name-map) + (set-keymap-parent m gdb-token-map) + (define-key m 'button2 'gdb-mouse-edit-function) + m)) + +(defvar gdb-function-location-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-function-location-map) + (set-keymap-parent m gdb-token-map) + (define-key m 'button2 'gdb-mouse-edit-function-location) + m)) + +(defvar gdb-frame-number-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-frame-number-map) + (set-keymap-parent m gdb-token-map) + (define-key m 'button2 'gdb-mouse-goto-frame) + m)) + +(defvar gdb-variable-name-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-variable-name-map) + (set-keymap-parent m gdb-token-map) + (define-key m 'button2 'gdb-mouse-print-variable) + m)) + +(defvar gdb-type-name-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'gdb-type-name-map) + (set-keymap-parent m gdb-token-map) + (define-key m 'button2 'gdb-mouse-print-type) + m)) + + +;;; Token definitions. + +;; These properties enumerate the faces and keymaps that will be put over +;; the tokens. + +(put 'gdb-frame-number-token 'gdb-token-face gdb-breakpoint-number-face) +(put 'gdb-frame-number-token 'gdb-token-keymap gdb-frame-number-map) + +;(put 'gdb-breakpoint-keep-token 'gdb-token-face gdb-breakpoint-keep-face) +;(put 'gdb-breakpoint-keep-token 'gdb-token-keymap gdb-breakpoint-keep-map) + +(put 'gdb-enabled-token 'gdb-token-face gdb-breakpoint-enabled-face) +(put 'gdb-enabled-token 'gdb-token-keymap gdb-breakpoint-enabled-map) + +(put 'gdb-function-name-token 'gdb-token-face gdb-function-name-face) +(put 'gdb-function-name-token 'gdb-token-keymap gdb-function-name-map) + +(put 'gdb-function-location-token 'gdb-token-face gdb-function-location-face) +(put 'gdb-function-location-token 'gdb-token-keymap gdb-function-location-map) + +(put 'gdb-breakpoint-number-token 'gdb-token-face gdb-breakpoint-number-face) +(put 'gdb-breakpoint-number-token 'gdb-token-keymap gdb-breakpoint-number-map) +(put 'gdb-info-breakpoint-number-token 'gdb-token-face + gdb-breakpoint-number-face) +(put 'gdb-info-breakpoint-number-token 'gdb-token-keymap + gdb-info-breakpoint-number-map) + +(put 'gdb-frame-number-token 'gdb-token-face gdb-breakpoint-number-face) +(put 'gdb-frame-number-token 'gdb-token-keymap gdb-frame-number-map) + +(put 'gdb-variable-name-token 'gdb-token-face gdb-variable-name-face) +(put 'gdb-variable-name-token 'gdb-token-keymap gdb-variable-name-map) + +(put 'gdb-type-name-token 'gdb-token-face gdb-type-name-face) +(put 'gdb-type-name-token 'gdb-token-keymap gdb-type-name-map) + + +;;; These regular expressions control what text corresponds to which tokens. + +(defconst gdb-highlight-token-patterns + ;; "May god forgive me for what I have unleashed." -- Evil Dead II. + (purecopy + (list + ;; Breakpoints output: + ;; + ;; Breakpoint 5, XCreateWindow () at Window.c:136 + ;; Breakpoint 6, foobar (x=0x7fff3000 "baz") at blorp.c:5382 + ;; + (list (concat "\\(Breakpoint " ; 1 + "\\([0-9]+\\)" ; .2 + "\\), " ; 1 + "\\(0x[0-9a-fA-F]+ in \\)?" ; 3 + "\\(" ; 4 + "\\([a-zA-Z0-9_]+\\):[a-zA-Z0-9_:~]+" ; .5 + "\\|" ; . + "[a-zA-Z0-9_]+" ; . + "\\)" ; 4 + "\\(" ; 6 + " *\\((.*)\\)" ; .7 + " at \\(" ; .8 + "\\([^ \t\n:]+\\):" ; ..9 + "\\([0-9]+\\)" ; ..10 + "\\)" ; .8 + "\\)?" ; 6 + ) + '(gdb-breakpoint-number-token ; 1 + nil ; 2 + nil ; 3 + gdb-function-name-token ; 4 (+5) + gdb-type-name-token ; 5 + nil ; 6 + gdb-arglist-token ; 7 + gdb-function-location-token ; 8 (9+10) + )) + + ;; Output of the "Break" command: + ;; + ;; Breakpoint 1 at 0x4881d4 + ;; Breakpoint 6 at 0xfa50f68: file cuexit.c, line 58. + ;; + (list (concat "\\(Breakpoint " ; 1 + "\\([0-9]+\\)" ; .2 + "\\) at " ; 1 + "\\(0x[0-9A-Fa-f]+\\)" ; 3 + "\\(: file " ; 4 + "\\(" ; .5 + "\\([^ \t\n:]+\\)" ; ..6 + ", line \\([0-9]+\\)" ; ..7 + "\\)" ; .5 + "\\)?" ; 4 + ) + '(gdb-breakpoint-number-token ; 1 + nil ; 2 + nil ;gdb-address-token ; 3 + nil ; 4 + gdb-function-location-token ; 5 (6+7) + )) + + ;; Note: breakpoint 5 (disabled) also set at pc 0x40b420. + ;; Note: breakpoint 5 also set at pc 0x40b420. + ;; + (list (concat "Note: " ; + "\\(breakpoint " ; 1 + "\\([0-9]+\\)" ; .2 + "\\)" ; 1 + ) + '(gdb-breakpoint-number-token ; 1 + nil ; 2 + )) + + ;; Stack Frames: + ;; + ;; 0xe1b8e0 in _OS_SELECT () at os_IRIX.s:50 + ;; XCreateWindow () at Window.c:136 + ;; #0 0x8e0db0 in _OS_SELECT () at os_IRIX.s:50 + ;; #0 XCreateWindow () at Window.c:136 + ;; Run till exit from #0 __ll_mul () at llmul.s:51 + ;; + (list (concat "\\(Run till exit from \\)?" ; 1 + "\\(" ; 2 + "#\\([0-9]+ *\\)" ; .3 + "\\)?" ; 2 + "\\(" ; 4 + "\\(0x[0-9A-Fa-f]+\\)" ; .5 + " in +\\)?" ; 4 + "\\(" ; 6 + "\\([a-zA-Z0-9_]+\\):[a-zA-Z0-9_:~]+" ; .7 + "\\|" ; 6 + "[a-zA-Z0-9_]+" ; + "\\) (" ; 6 + "\\(" ; 8 + "\\(.*\\)" ; .9 + "\\bat \\(" ; .10 + "\\([^ \t\n:]+\\):" ; ..11 + "\\([0-9]+\\)" ; ..12 + "\\)" ; .10 + "\\)?" ; 8 + ) + '(nil ; 1 + gdb-frame-number-token ; 2 + nil ; 3 + nil ; 4 + nil ;gdb-address-token ; 5 + gdb-function-name-token ; 6 (+7) + gdb-type-name-token ; 7 + nil ; 8 + gdb-arglist-token ; 9 + gdb-function-location-token ; 10 (11+12) + )) + + ;; Info Breakpoints output: + ;; + ;; 1 breakpoint keep y 0x0fa50f68 in exit at exit.c:58 + ;; 1 breakpoint keep y 0x000a1b00 <exit+4> + ;; 1 breakpoint keep y 0x0fa429ac <_write> + ;; 6 breakpoint keep y 0x00789490 in foo::bar(bad *) at x.cpp:99 + ;; 7 breakpoint keep y 0x00789490 <foo::bar(bad *)+128> + ;; + (list (concat "\\([0-9]+ *\\) " ; 1 + "\\(breakpoint *\\|watchpoint *\\) " ; 2 + "\\(keep *\\|del *\\|dis *\\) " ; 3 + "\\([yn] *\\) " ; 4 + "\\(0x[0-9A-Fa-f]+\\) *" ; 5 + "\\(in " ; 6 + "\\(" ; .7 + "[a-zA-Z0-9_]+" ; .. + "\\|" ; .7 + "\\([a-zA-Z0-9_]+\\):[a-zA-Z0-9_:~]+" ; ..8 + "\\)" ; .7 + "\\((.*)\\)?" ; 9 + " at " ; . + "\\(" ; .10 + "\\([^ \t\n:]+\\):" ; ..11 + "\\([0-9]+\\)" ; ..12 + "\\)" ; .10 + "\\|" ; 6 + "<" ; . + "\\(" ; .13 + "\\([a-zA-Z0-9_]+\\):[a-zA-Z0-9_:~]+" ; ..14 + "\\|" ; .13 + "[a-zA-Z0-9_]+" ; .. + "\\)" ; .13 + "\\((.*)\\)?" ; .15 + "[^>\n]*>" ; . + "\\)?" ; 6 + ) + '(gdb-info-breakpoint-number-token ; 1 + nil ; 2 + nil ;gdb-breakpoint-keep-token ; 3 + gdb-enabled-token ; 4 + nil ;gdb-address-token ; 5 + nil ; 6 + gdb-function-name-token ; 7 (+8) + gdb-type-name-token ; 8 + gdb-arglist-types-token ; 9 + gdb-function-location-token ; 10 (11+12) + nil ; 11 + nil ; 12 + gdb-function-name-token ; 13 + gdb-type-name-token ; 14 + gdb-arglist-types-token ; 15 + )) + + ;; Whatis and Ptype output: + ;; type = struct _WidgetRec * + ;; type = struct _WidgetRec { + ;; type = int () + ;; type = struct <undefined> *(struct <undefined> *, void *, void (*)()) + ;; type = struct foo *(struct foo *, unsigned char, int) + ;; type = unsigned int [4] + ;; + (list (concat "type = " + "\\(" ; 1 + "\\(signed \\|unsigned \\)?" ; .2 + "\\(struct \\|class \\|union \\|enum \\)?" ; .3 + "\\(<?[a-zA-Z_][a-zA-Z0-9_:]*>?\\)" ; .4 + "\\)" ; 1 + "[ *]*" ; + "\\(" ; 5 + "{?$\\|" ; . + "\\[[0-9]*\\]$\\|" ; . + "\\((.*)\\)" ; .6 + "\\)" ; 5 + ) + '(gdb-type-name-token ; 1 (2+3+4) + nil ; 2 + nil ; 3 + nil ; 4 + nil ; 5 + gdb-arglist-types-token ; 6 + )) + + ;; Ptype output: + ;; CorePart core; + ;; void *constraints; + ;; short x; + ;; unsigned short width; + ;; struct <undefined> *event_table; + ;; XtTMRec tm; + ;; void (*class_initialize)(); + ;; unsigned char (*set_values)(); + ;; unsigned char st_fstype[16]; + ;; type = enum {XtGeometryYes, XtGeometryNo, XtGeometryAlmost} + ;; + (list (concat " *" + "\\(" ; 1 + "\\(signed \\|unsigned \\)?" ; .2 + "\\(struct \\|class \\|union \\|enum \\)?" ; .3 + "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; .4 + "\\)" ; 1 + "[ *]*" + "\\((\\**\\)?" ; 5 + "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; 6 + "\\()()\\)?" ; 7 + "\\( *\\[[0-9]*\\]\\)?" ; 8 + "; *$" + ) + '(gdb-type-name-token ; 1 (2+3+4) + )) + + ;; Ptype output on C++ classes: + ;; + ;; virtual foo (int); + ;; unsigned int foo(void); + ;; static long unsigned int * foo(bar *, baz *, unsigned int); + ;; + ;; not handled: + ;; foo(bar *, _WidgetRec *, char const *, int); + ;; foo (foo &); + ;; foo & operator=(foo const &); + ;; + (list (concat " *" + "\\(static \\)?" ; 1 + "\\(" ; 2 + "\\(signed \\|unsigned " ; .3 + ;; #### not so sure about this: + "\\|long unsigned \\|short unsigned " ; .3 + "\\)?" ; .3 + "\\(struct \\|class \\|union \\|enum \\)?" ; .4 + "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; .5 + "\\)" ; 1 + "[ *&]+" ; + " *\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; 6 + " *\\((.*)\\)" ; 7 + "; *$" ; + ) + '(nil ; 1 + gdb-type-name-token ; 2 (3+4+5) + nil ; 3 + nil ; 4 + nil ; 5 + gdb-function-name-token ; 6 + gdb-arglist-types-token ; 7 + )) + + ;; Pointers to functions: + ;; + ;; $1 = {void ()} 0x4a1334 <fe_pulldown_cb> + ;; $2 = (void (*)()) 0x4a1334 <fe_pulldown_cb> + ;; + (list (concat ".* = " + "[({]" + "\\(" ; 1 + "\\(signed \\|unsigned \\)?" ; .2 + "\\(struct \\|class \\|union \\|enum \\)?" ; .3 + "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; .4 + "\\)" ; 1 + " \\((\\*) ?\\)?" ; 5 + "\\((.*)\\)" ; 6 + "[)}] +" ; + "\\(0x[0-9A-Fa-f]+\\) +" ; 7 + "<\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)" ; 8 + "\\+?[0-9]+?>" ; + ) + '(gdb-type-name-token ; 1 (2+3+4) + nil ; 2 + nil ; 3 + nil ; 4 + nil ; 5 + gdb-arglist-types-token ; 6 + nil ;gdb-address-token ; 7 + gdb-function-name-token ; 8 + )) + + ;; Local variables and structures: + ;; + ;; shell = (struct _WidgetRec *) 0x10267350 + ;; delete_response = 270955344 + ;; allow_resize = 200 'È' + ;; is_modal = 47 '/' + ;; class_name = 0xf661d40 "TopLevelShell", + ;; static foo = 0x10791ec0, + ;; initialize = 0xf684770 <TopLevelInitialize>, + ;; av = {{ + ;; name = "foo", + ;; value = 270349836 + ;; }, { + ;; name = 0x12 <Address 0x12 out of bounds>, + ;; value = 0 + ;; }, { + ;; name = 0x0, + ;; value = 0 + ;; }} + ;; + (list (concat " *" + "\\(static \\)?" ; 1 + "\\([$a-zA-Z_][a-zA-Z0-9_:]*\\) = " ; 2 + "\\((" ; 3 + "\\(" ; .4 + "\\(signed \\|unsigned \\)?" ; ..5 + "\\(struct \\|class \\|union \\|enum \\)?"; ..6 + "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)" ; ..7 + "\\)" ; .4 + "[ *]*)" ; + "\\)?" ; 3 + "\\(" ; 8 + ".*" + " <\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)" ; .9 + "\\+?[0-9]+?>" ; . + "\\)?" ; 8 + ) + '(nil ; 1 + gdb-variable-name-token ; 2 + nil ; 3 + gdb-type-name-token ; 4 + nil ; 5 + nil ; 6 + nil ; 7 + nil ; 8 + gdb-function-name-token ; 9 + )) + + ;; Purify output: + ;; UMR: Uninitialized memory read: + ;; * This is occurring while in: + ;; SHA1_Update [algsha.c:137] + ;; * Reading 1 byte from 0xefffdb34 on the stack. + (list (concat "[ \t]+" + "\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)[ \t]*" ; 1 + "\\[\\(" ; 2 + "\\([^ \t\n:]+\\):" ; .3 + "\\([0-9]+\\)" ; .4 + "\\)\\]" ; 2 + ) + '(gdb-function-name-token ; 1 + gdb-function-location-token ; 2 (3+4) + )) + + ;; Purify output: + ;; * Address 0xefffdb34 is 36 bytes past start of local variable \ + ;; "data" in function fe_EventForRNG. + (list (concat ".*\\bAddress " + "\\(0x[0-9A-Fa-f]+\\) +" ; 1 + ".*\\bvariable \"" ; + "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)\"" ; 2 + "\\(" ; 3 + ".*\\bfunction " ; . + "\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)" ; .4 + "\\)?" ; 3 + ) + '(nil ;gdb-address-token ; 1 + gdb-variable-name-token ; 2 + nil ; 3 + gdb-function-name-token ; 4 + )) + )) + "Patterns to highlight in gdb buffers. +Each element of this list takes the form + ( \"regexp\" ( token-1 token-2 ... )) +where token-N is the token to place on the text matched + by sub-pattern N in the match data. + +The patterns should not begin with \"^\".") + + +(defun gdb-highlight-line () + "Highlight any tokens on the line which match gdb-highlight-token-patterns." + (map-extents #'(lambda (e ignore) (delete-extent e)) + nil + (point) (save-excursion (forward-line 1) (point)) + nil nil 'gdb-token) + (while (looking-at comint-prompt-regexp) + (goto-char (match-end 0))) + (if (eobp) + nil + (let ((tokens gdb-highlight-token-patterns) + (do-magic-variable-hack nil)) + (while tokens + (if (not (looking-at (car (car tokens)))) + (setq tokens (cdr tokens)) + (let ((i 1) + (types (nth 1 (car tokens)))) + (if (eq (car types) 'gdb-variable-name-token) + (setq do-magic-variable-hack t)) + (while types + (cond ((not (and (car types) + (match-beginning i))) + nil) + ((memq (car types) '(gdb-arglist-token + gdb-arglist-types-token)) + (gdb-highlight-arglist (car types) + (match-beginning i) + (match-end i))) + ((/= ?$ (char-after (match-beginning i))) + (gdb-highlight-token (car types) + (match-beginning i) + (match-end i)))) + (setq i (1+ i) + types (cdr types))) + + (if (not do-magic-variable-hack) + ;; we're done. + (setq tokens nil) + ;; else, do a grody hack to cope with multiple variables + ;; on the same line. + (save-restriction + (let ((p (point)) + (ok nil)) + (end-of-line) + (narrow-to-region p (point)) + (goto-char (match-end 0)) + (if (= (following-char) ?\{) + (progn + (forward-char 1) + (setq ok t)) + (setq p (scan-sexps (point) 1 nil t)) + (setq ok (if (null p) + nil + (goto-char p) + (if (or (= (following-char) ?\,) + (= (following-char) ?\})) + t + (setq p (scan-sexps (point) 1 nil t)) + (if (null p) + nil + (goto-char p) + t))))) + (if ok + ;; skip over the comma and go around again. + (and (looking-at "}?[ \t]*,[ \t]*") + (goto-char (match-end 0))) + ;; saw something unexpected; give up on this line. + (setq tokens nil))))) + ))))) + nil) + +(defun gdb-highlight-token (type start end) + "Helper for gdb-highlight-line -- makes an extent for one matched token." + (let ((e (make-extent start end))) + (set-extent-property e 'gdb-token type) + (set-extent-property e 'highlight 't) + (set-extent-property e 'help-echo 'gdb-token-help-echo) + (set-extent-property e 'face (get type 'gdb-token-face)) + (set-extent-property e 'keymap (get type 'gdb-token-keymap)) + e)) + +(defun gdb-highlight-arglist (type start end) + "Helper for gdb-highlight-line. +Makes extents for variables or types in an arglist." + (save-match-data + (save-excursion + (goto-char end) + (if (eq (preceding-char) ?\)) + (setq end (1- end))) + (goto-char start) + (if (eq (following-char) ?\() + (forward-char 1)) + (set-extent-property (make-extent start end) 'gdb-token type) + + (cond + ((eq type 'gdb-arglist-token) + (let* ((pat1 "\\([a-zA-Z_][a-zA-Z0-9_:]*\\)=") + (pat2 ", \\([a-zA-Z_][a-zA-Z0-9_:]*\\)=") + (pat pat1)) + (while(re-search-forward pat end t) + (gdb-highlight-token 'gdb-variable-name-token + (match-beginning 1) (match-end 1)) + (cond ((looking-at + "0?x?[0-9A-Fa-f]+ <\\([a-zA-Z_~][a-zA-Z0-9_:]*\\)>") + (goto-char (match-end 0)) + (gdb-highlight-token 'gdb-function-name-token + (match-beginning 1) (match-end 1)))) + (setq pat pat2)))) + + ((eq type 'gdb-arglist-types-token) + (let ((pat (eval-when-compile + (concat + "\\(" ; 1 + "\\(signed \\|unsigned \\)?" ; .2 + "\\(struct \\|class \\|union \\|enum \\)?" ; .3 + "\\(<?[a-zA-Z_~][a-zA-Z0-9_:]*>?\\)" ; .4 + "\\)" ; 1 + "[ *]*" + "\\((\\*) *(.*)\\)?" ; 5 + )))) + (while (< (point) end) + (cond ((looking-at pat) + (goto-char (match-end 0)) + (gdb-highlight-token 'gdb-type-name-token + (match-beginning 1) (match-end 1)) + (if (looking-at " *, *") + (goto-char (match-end 0)))) + (t + ;; error -- try to cope... + (search-forward "," (1+ end) t)))))) + (t + (error "unknown arglist type %s" type))))) + nil) + +(defun gdb-token-help-echo (extent) + "Used as the 'mouse-help property of gdb-token extents, +to describe the binding on button2." + (let* ((map (extent-property extent 'keymap)) + (key 'button2) + (fn (and map (lookup-key map key))) + (doc (and fn (symbolp fn) + (if (fboundp fn) + (format "%s: %s" key (documentation fn)) + (format "Error: %s is undefined" fn))))) + (if doc + (save-match-data + (if (string-match "\n" doc) + (setq doc (substring doc 0 (match-beginning 0)))))) + (or doc + (concat "Error: no doc for " + (symbol-name (extent-property extent 'gdb-token)))))) + +(defun gdb-get-line-token-extents (tokens) + "Given a list of gdb-tokens, returns this line's extents of those types. +The returned value is a list of the same length as the `tokens' list, with +the corresponding extents in the corresponding positions. If an extent +isn't found, nil is placed in the result-list instead." + (setq tokens (append tokens nil)) + (let* ((result (make-list (length tokens) nil))) + (save-excursion + (beginning-of-line) + (map-extents #'(lambda (e ignore) + (let ((type (extent-property e 'gdb-token)) + (r1 tokens) + (r2 result)) + (while r1 + (cond ((and (car r1) (eq type (car r1))) + (setcar r1 nil) + (setcar r2 e) + (setq r1 nil))) + (setq r1 (cdr r1) + r2 (cdr r2)))) + nil) + nil + (point) + (progn (forward-line 1) (point)) + nil nil + 'gdb-token) + result))) + + +;;; Remembering directory names. +;;; gdb and gdb-mode conspire to hide from us the full file names of things +;;; that are presented into the buffer; this is an attempt to circumvent that. + +(defvar gdb-highlight-last-directory nil) +(defvar gdb-highlight-last-directory-table nil) + +(defun gdb-highlight-remember-directory () + ;; When gdb deigns to give us a full pathname, and it's in a different + ;; directory than last time, cache it away on one of the nearby gdb-token + ;; extents. (We intern it to avoid hanging on to a lot of strings.) + (cond ((and (boundp 'gdb-last-frame) + (car gdb-last-frame)) + (cond ((not gdb-highlight-last-directory-table) + (set (make-local-variable 'gdb-highlight-last-directory) nil) + (set (make-local-variable 'gdb-highlight-last-directory-table) + (make-vector 211 0)))) + (let ((dir (file-name-directory (car gdb-last-frame)))) + (setq dir (intern dir gdb-highlight-last-directory-table)) + (cond ((not (eq dir gdb-highlight-last-directory)) + (let ((extent (previous-extent (current-buffer)))) + (setq gdb-highlight-last-directory dir) + (while extent + (cond ((extent-property extent 'gdb-token) + (set-extent-property extent 'gdb-directory dir) + (setq extent nil)) + (t + (setq extent (previous-extent extent)))))))))))) + +(defun gdb-guess-directory () + "Guess what directory gdb was talking about when it wrote the current line." + (let ((extent (or (map-extents #'(lambda (e ignore) e) + (current-buffer) (point) (point-max)) + (previous-extent (current-buffer)) + (error "no extents"))) + (dir nil)) + (while extent + (setq dir (extent-property extent 'gdb-directory)) + (if dir + (setq extent nil) + (setq extent (previous-extent extent)))) + (if dir + (symbol-name dir) + default-directory))) + +(defun gdb-guess-file-name (file) + "Given a directoryless file name printed by gdb, find the file. +First it tries to expand the file relative to `gdb-guess-directory', +and if the resultant file doesn't exist, it tries every other directory +gdb has ever told us about, in no particular order." + (abbreviate-file-name + (if (file-name-absolute-p file) + file + (let ((file2 (expand-file-name file (gdb-guess-directory)))) + (if (file-exists-p file2) + file2 + ;; Oh boy, gdb didn't tell us what directory it's in. + ;; A-hunting we will go. + (if (catch 'done + (mapatoms #'(lambda (dir) + (setq file2 (expand-file-name file + (symbol-name dir))) + (if (file-exists-p file2) + (throw 'done t))) + gdb-highlight-last-directory-table) + nil) + file2 + (expand-file-name file))))))) + + +;;; Commands which are invoked from bindings in the keymaps of the tokens. + +(defun gdb-mouse-toggle-breakpoint-enabled (event &optional what) + "Toggle whether the breakpoint is enabled. +Looks for a gdb-breakpoint extent on the line under the mouse, +and executes an `enable' or `disable' command as appropriate. +Optional arg `what' may be 'enable, 'disable, or 'toggle (default.)" + (interactive "@*e") + (let (number target enabled-p) + (save-excursion + (mouse-set-point event) + (let* ((extents (gdb-get-line-token-extents + '(gdb-breakpoint-number-token + gdb-info-breakpoint-number-token + gdb-enabled-token))) + (be (or (nth 0 extents) (nth 1 extents))) + (ee (nth 2 extents))) + + (or be + (error "no breakpoint-number extent on this line")) + (setq number + (buffer-substring (extent-start-position be) + (extent-end-position be))) + (if (string-match " [0-9]+\\'" number) + (setq number (substring number (1+ (match-beginning 0))))) + (setq number (string-to-int number)) + (or (> number 0) + (error "couldn't find breakpoint number")) + (if (null ee) + (setq enabled-p 'unknown) + (setq target (extent-start-position ee)) + (goto-char target) + (setq enabled-p + (cond ((looking-at "[yY]\\b") t) + ((looking-at "[nN]\\b") nil) + (t (error "enabled is not y or n?"))))) + + (cond ((eq what 'enable) + (setq enabled-p nil)) + ((eq what 'disable) + (setq enabled-p t)) + ((or (eq what 'toggle) (null what)) + (if (eq enabled-p 'unknown) + (error + "can't toggle breakpoint: don't know current state"))) + (t + (error "what must be enable, disable, toggle, or nil."))) + )) + + (gdb-menu-command (format "%s %d" + (if enabled-p "disable" "enable") + number) + nil) + (message "%s breakpoint %d." + (if enabled-p "Disabled" "Enabled") + number) + (cond (target + (save-excursion + (goto-char target) + (insert (if enabled-p "n" "y")) + (delete-char 1) + ;; don't let shell-fonts or font-lock second-guess us. + (remove-text-properties (1- (point)) (point) '(face)))))) + nil) + +(defun gdb-mouse-enable-breakpoint (event) + "Enable the breakpoint. +Looks for a gdb-breakpoint extent on the line under the mouse, +and executes an `enable' command" + (interactive "@*e") + (gdb-mouse-toggle-breakpoint-enabled event 'enable)) + +(defun gdb-mouse-disable-breakpoint (event) + "Disable the breakpoint. +Looks for a gdb-breakpoint extent on the line under the mouse, +and executes a `disable' command" + (interactive "@*e") + (gdb-mouse-toggle-breakpoint-enabled event 'disable)) + + +;; compatibility hack... +(or (fboundp 'extent-object) (fset 'extent-object 'extent-buffer)) + +(defun gdb-mouse-edit-function (event) + "Edit the definition of this function (as with \\[find-tag]) +Looks for a gdb-function-name extent on the line under the mouse, +and runs find-tag on the text under that extent." + (interactive "@*e") + (let (extent) + (save-excursion + (mouse-set-point event) + (setq extent (or (car (gdb-get-line-token-extents + '(gdb-function-name-token))) + (error "no function-name extent on this line")))) + (find-tag + (buffer-substring (extent-start-position extent) + (extent-end-position extent) + (extent-object extent))))) + + +(defun gdb-mouse-edit-function-location (event) + "Edit the source file of this function. +Looks for a gdb-function-location extent on line of the mouse, +and parses the text under it." + (interactive "@*e") + (let (file line) + (save-excursion + (mouse-set-point event) + (let ((extent (or (car (gdb-get-line-token-extents + '(gdb-function-location-token))) + (error "no function-location extent on this line")))) + (goto-char (extent-start-position extent)) + (or (looking-at "\\([^ \t\n:,]+\\):\\([0-9]+\\)") + (looking-at "\\([^ \t\n:,]+\\),? line \\([0-9]+\\)") + (error "no file position on this line")) + (setq file (buffer-substring (match-beginning 1) (match-end 1)) + line (buffer-substring (match-beginning 2) (match-end 2))) + (setq file (gdb-guess-file-name file) + line (string-to-int line)) + )) + (if (file-exists-p file) + (find-file-other-window file) + (signal 'file-error (list "File not found" file))) + (goto-line line))) + + +(defun gdb-mouse-goto-frame (event) + "Select this stack frame. +Looks for a gdb-frame-number extent on the line of the mouse, +and executes a `frame' command to select that frame." + (interactive "@*e") + (let (number) + (save-excursion + (mouse-set-point event) + (let ((extent (or (car (gdb-get-line-token-extents + '(gdb-frame-number-token))) + (error "no frame-number extent on this line")))) + (goto-char (extent-start-position extent)) + (if (eq (following-char) ?#) + (forward-char 1)) + (setq number (string-to-int + (buffer-substring (point) + (extent-end-position extent)))))) + (gdb-menu-command (format "frame %d" number) t)) + nil) + + +(defun gdb-mouse-get-variable-reference (event) + "Returns a string which references the variable under the mouse. +This works even if the variable is deep inside nested arrays or structures. +If the variable seems to hold a pointer, then a \"*\" will be prepended." + (save-excursion + (let* ((extent (if (extentp event) + event + (progn + (mouse-set-point event) + (extent-at (point) nil 'gdb-token)))) + dereference-p + name) + (or (and extent + (eq (extent-property extent 'gdb-token) + 'gdb-variable-name-token)) + (error "not over a variable name")) + (setq name (buffer-substring (extent-start-position extent) + (extent-end-position extent))) + (save-excursion + (goto-char (extent-end-position extent)) + (if (and (looking-at " *= *\\(([^)]+)\\)? *0x[0-9a-fA-F]+") ; pointer + (progn + (goto-char (match-end 0)) + (not (looking-at " +\"")))) ; but not string + (setq dereference-p t)) + + ;; Now, if this variable is buried in a structure, compose a complete + ;; reference-chain to it. + (goto-char (extent-start-position extent)) + + (let ((done nil)) + (while (not done) + (skip-chars-backward " \t") + (if (or (and (/= (preceding-char) ?\n) + (/= (preceding-char) ?\,) + (/= (preceding-char) ?\{)) + (<= (buffer-syntactic-context-depth) 0)) + (setq done t) + (let ((p (scan-lists (point) -1 1))) + (if (null p) + (setq done t) + (goto-char (setq p (- p 3))) + (cond + ((looking-at " = {") + (skip-chars-backward "a-zA-Z0-9_") + (if (= (preceding-char) ?\$) + (forward-char -1)) + (setq name (concat (buffer-substring (point) p) "." name))) + + ((looking-at "}, +{") + (forward-char 1) + (let ((parse-sexp-ignore-comments nil) + (count 0)) + (while (setq p (scan-sexps (point) -1 nil t)) + (goto-char p) + (setq count (1+ count))) + + (setq name (format "[%d].%s" count name)) + + ;; up out of the list + (skip-chars-backward " \t\n") + (if (= (preceding-char) ?\{) + (forward-char -1)) + + ;; we might be tightly nested in slot 0... + (while (= (preceding-char) ?\{) + (forward-char -1) + (setq name (concat "[0]" name))) + + (skip-chars-backward " \t") + (if (= (preceding-char) ?=) (forward-char -1)) + (skip-chars-backward " \t") + (setq p (point)) + (skip-chars-backward "a-zA-Z0-9_") + (if (= (preceding-char) ?\$) + (forward-char -1)) + + (setq name (concat (buffer-substring (point) p) name)) + )) + (t + (setq done t))))))))) + + (if dereference-p + (setq name (concat "*" name))) + name))) + +(defun gdb-mouse-print-variable (event) + "Print the value of this variable. +Finds a variable under the mouse, and figures out whether it is inside of +a structure, and composes and executes a `print' command. If the variable +seems to hold a pointer, prints the object pointed to." + (interactive "@*e") + (gdb-menu-command (concat "print " + (gdb-mouse-get-variable-reference event)) + t)) + +(defun gdb-mouse-print-variable-type (event) + "Describe the type of this variable. +Finds a variable under the mouse, and figures out whether it is inside of +a structure, and composes and executes a `whatis' command. If the variable +seems to hold a pointer, describes the type of the object pointed to." + (interactive "@*e") + (gdb-menu-command (concat "whatis " + (gdb-mouse-get-variable-reference event)) + t)) + +(defun gdb-mouse-print-type (event) + "Describe this type. +Finds a type description under the mouse, and executes a `ptype' command." + (interactive "@*e") + (let* ((extent (save-excursion + (mouse-set-point event) + (extent-at (point) nil 'gdb-token))) + name) + (or (and extent + (eq (extent-property extent 'gdb-token) 'gdb-type-name-token)) + (error "not over a type name")) + (setq name (buffer-substring (extent-start-position extent) + (extent-end-position extent))) + (gdb-menu-command (format "ptype %s" name) + t)) + nil) + + +;;; Popup menus + +(defun gdb-menu-command (command &optional scroll-to-bottom) + "Sends the command to gdb. +If gdb is not sitting at a prompt, interrupts it first +\(as if with \\[gdb-control-c-subjob]), executes the command, and then lets +the debugged program continue. + +If scroll-to-bottom is true, then point will be moved to after the new +output. Otherwise, an effort is made to avoid scrolling the window and +to keep point where it was." + + ;; this is kinda like gdb-call except for the interrupt-first behavior, + ;; but also it leaves the commands in the buffer instead of trying to + ;; hide them. + + (let* ((proc (or (get-buffer-process (current-buffer)) + (error "no process in %s" (buffer-name (current-buffer))))) + (window (selected-window)) + wstart + (opoint (point)) + was-at-bottom + running-p) + + (if (not (eq (current-buffer) (window-buffer window))) + (setq window (get-buffer-window (current-buffer)))) + (setq wstart (window-start window)) + + (let ((pmark (process-mark proc))) + (setq was-at-bottom (>= (point) pmark)) + (goto-char pmark) + (delete-region (point) (point-max))) + + (setq running-p (bolp)) ; maybe not the best way to tell... + + (cond (running-p + (message "Program is running -- interrupting first...") + (gdb-control-c-subjob) + (while (accept-process-output proc 1) + ;; continue accepting output as long as it's arriving + ))) + + (message "%s" command) + (goto-char (process-mark proc)) + (insert command) + (comint-send-input) + + ;; wait for the command to be accepted + (accept-process-output proc) + (goto-char (process-mark proc)) + + ;; continue, if we had interrupted + (cond (running-p + (insert "continue") + (comint-send-input))) + + (if scroll-to-bottom + (goto-char (process-mark proc)) + + (set-window-start window wstart) + (goto-char opoint) + (if was-at-bottom + (if (pos-visible-in-window-p (process-mark proc) window) + (goto-char (process-mark proc)) + (goto-char (window-end window)) + (forward-line -2)))) + ) + nil) + + +(defun gdb-make-context-menu (event) + "Returns a menu-desc corresponding to the stack-frame line under the mouse. +Returns nil if not over a stack-frame." + (save-excursion + (mouse-set-point event) + (let* ((extents (gdb-get-line-token-extents + '(gdb-breakpoint-number-token + gdb-info-breakpoint-number-token + gdb-enabled-token + gdb-frame-number-token + gdb-function-name-token + gdb-function-location-token + gdb-arglist-token + gdb-arglist-types-token + gdb-variable-name-token + gdb-type-name-token + ))) + (bnumber (or (nth 0 extents) + (nth 1 extents))) + (enabled-p (nth 2 extents)) + (fnumber (nth 3 extents)) + (name (nth 4 extents)) + (loc (nth 5 extents)) + (al (nth 6 extents)) + (alt (nth 7 extents)) + (var (nth 8 extents)) + (type (nth 9 extents)) + (var-e var)) + + ;; If this line has an arglist, only document variables and types + ;; if the mouse is directly over them. + (if (or al alt) + (setq var nil + type nil)) + + ;; Always prefer the object under the mouse to one elsewhere on the line. + (let* ((e (extent-at (point) nil 'gdb-token)) + (p (and e (extent-property e 'gdb-token)))) + (cond ((eq p 'gdb-function-name-token) (setq name e)) + ((eq p 'gdb-variable-name-token) (setq var e var-e e)) + ((eq p 'gdb-type-name-token) (setq type e)) + )) + + ;; Extract the frame number (it may begin with "#".) + (cond (fnumber + (goto-char (extent-start-position fnumber)) + (if (eq (following-char) ?#) + (forward-char 1)) + (setq fnumber + (string-to-int + (buffer-substring (point) + (extent-end-position fnumber)))))) + + ;; Extract the breakpoint number (it may begin with "Breakpoint ".) + (cond (bnumber + (setq bnumber + (buffer-substring (extent-start-position bnumber) + (extent-end-position bnumber))) + (if (string-match " [0-9]+\\'" bnumber) + (setq bnumber (substring bnumber (1+ (match-beginning 0))))) + (setq bnumber (string-to-int bnumber)) + (or (> bnumber 0) + (error "couldn't parse breakpoint number")))) + + (cond ((null enabled-p) + (setq enabled-p 'unknown)) + ((memq (char-after (extent-start-position enabled-p)) '(?y ?Y)) + (setq enabled-p 't)) + ((memq (char-after (extent-start-position enabled-p)) '(?n ?N)) + (setq enabled-p 'nil)) + (t + (setq enabled-p 'unknown))) + + ;; Convert the extents to strings. + ;; + (if name + (setq name (buffer-substring (extent-start-position name) + (extent-end-position name)))) + (if loc + (setq loc (buffer-substring (extent-start-position loc) + (extent-end-position loc)))) + (if var + (setq var (buffer-substring (extent-start-position var) + (extent-end-position var)))) + (if type + (setq type (buffer-substring (extent-start-position type) + (extent-end-position type)))) + + ;; Return a menu description list. + ;; + (nconc + (if (and bnumber (not (eq enabled-p 'nil))) + (list (vector (format "Disable Breakpoint %d" + bnumber) + (list 'gdb-mouse-disable-breakpoint event) + t))) + (if (and bnumber (not (eq enabled-p 't))) + (list (vector (format "Enable Breakpoint %d" + bnumber) + (list 'gdb-mouse-enable-breakpoint event) + t))) + (if bnumber + (list (vector (format "Delete Breakpoint %d" bnumber) + (list 'gdb-menu-command (format "delete %d" bnumber) + nil) + t))) + (if var + (list (vector (format "Print Value of `%s'" var) + (list 'gdb-mouse-print-variable var-e) + t) + (vector (format "Print Type of `%s'" var) + (list 'gdb-mouse-print-variable-type var-e) + t))) + (if name + (list (vector (format "Edit Definition of `%s'" name) + (list 'gdb-mouse-edit-function event) + t) + (vector (format "Set Breakpoint on `%s'" name) + (list 'gdb-menu-command (format "break %s" name) nil) + t))) + (if loc + (list (vector (format "Visit Source Line (%s)" loc) + (list 'gdb-mouse-edit-function-location event) + t))) + (if type + (list (vector (format "Describe Type `%s'" type) + (list 'gdb-menu-command (format "ptype %s" type) t) + t))) + (if fnumber + (list (vector (format "Select Stack Frame %d" fnumber) + (list 'gdb-menu-command (format "frame %d" fnumber) t) + t))) + )))) + + +(defun gdb-popup-menu (event) + "Pop up a context-sensitive menu of gdb-mode commands." + (interactive "_@e") + (select-window (event-window event)) + (let (menu) + (save-excursion + (setq menu (append (if (boundp 'gdb-popup-menu) + (append (cdr gdb-popup-menu) + '("---"))) + (if (boundp 'comint-popup-menu) + (cdr comint-popup-menu)))) + (let ((history (if (fboundp 'comint-make-history-menu) + (comint-make-history-menu))) + (context (gdb-make-context-menu event))) + (if history + (setq menu + (append menu (list "---" (cons "Command History" history))))) + (if context + (setq menu (append context (cons "---" menu)))) + ) + (setq menu (cons (if (boundp 'gdb-popup-menu) + (car gdb-popup-menu) + "GDB Commands") + menu))) + (popup-menu menu event))) + + +;;; Patch it in... + +(or (fboundp 'gdb-highlight-orig-filter) + (fset 'gdb-highlight-orig-filter (symbol-function 'gdb-filter))) + +(defun gdb-highlight-filter (proc string) + (let ((p (marker-position (process-mark proc)))) + (prog1 + (gdb-highlight-orig-filter proc string) + + (save-match-data + ;; + ;; If there are no newlines in this string at all, then don't + ;; bother processing it -- we will pick up these characters on + ;; the next time around, when the line's newline gets inserted. + ;; + (cond + ((string-match "\n" string) + (save-excursion + (set-buffer (process-buffer proc)) + (goto-char p) + (let ((p2 (marker-position (process-mark proc))) + p3) + ;; + ;; If gdb has given us a full pathname, remember it. (Do this + ;; before emitting any gdb-token extents, so that we attach it + ;; to the buffer *before* any of the extents to which it is + ;; known to correspond. + ;; + (gdb-highlight-remember-directory) + ;; + ;; Now highlight each line that has been written. If we wrote + ;; the last half of a line, re-highlight that whole line. (We + ;; need to do that so that the regexps will match properly; + ;; the "\n" test above also depends on this behavior.) + ;; + ;; But don't highlight lines longer than 5000 characters -- that + ;; probably means something is spewing, and we'll just get stuck + ;; hard in the regexp matcher. + ;; + (beginning-of-line) + (while (< (point) p2) + (goto-char (prog1 + (point) + (forward-line 1) + (setq p3 (point)))) + (if (< (- p3 (point)) 5000) + (gdb-highlight-line)) + (goto-char p3)))))))))) + +(fset 'gdb-filter 'gdb-highlight-filter) + + +(provide 'gdb-highlight) + +;;; gdb-highlight.el ends here + +--------------4273DDB4BB90CEC3B645B5AC-- + +