Mercurial > hg > xemacs-beta
comparison lisp/comint/gdbsrc.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | b82b59fe008d |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; gdbsrc.el -- Source-based (as opposed to comint-based) debugger | |
| 2 ;; interaction mode eventually, this will be unified with GUD | |
| 3 ;; (after gud works reliably w/ XEmacs...) | |
| 4 ;; Keywords: c, unix, tools, debugging | |
| 5 | |
| 6 ;; Copyright (C) 1990 Debby Ayers <ayers@austin.ibm.com>, and | |
| 7 ;; Rich Schaefer <schaefer@asc.slb.com> | |
| 8 ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp. | |
| 9 ;; | |
| 10 ;; This file is part of XEmacs. | |
| 11 ;; | |
| 12 ;; XEmacs is free software; you can redistribute it and/or modify | |
| 13 ;; it under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2 of the License, or | |
| 15 ;; (at your option) any later version. | |
| 16 ;; | |
| 17 ;; XEmacs is distributed in the hope that it will be useful, | |
| 18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 20 ;; GNU General Public License for more details. | |
| 21 ;; | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 23 ;; along with XEmacs; if not, write to the Free Software | |
| 24 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 25 | |
| 26 ;; Based upon code for version18 by Debra Ayers <ayers@austin.ibm.com> | |
| 27 | |
| 28 ;;; GDBSRC:: | |
| 29 ;;; Gdbsrc extends the emacs GDB interface to accept gdb commands issued | |
| 30 ;;; from the source code buffer. Gdbsrc behaves similar to gdb except | |
| 31 ;;; now most debugging may be done from the source code using the *gdb* | |
| 32 ;;; buffer to view output. Supports a point and click model under X to | |
| 33 ;;; evaluate source code expressions (no more typing long variable names). | |
| 34 ;;; | |
| 35 ;;; Supports C source at the moment but C++ support will be added if there | |
| 36 ;;; is sufficient interest. | |
| 37 ;;; | |
| 38 | |
| 39 ;; GDBSRC::Gdb Source Mode Interface description. | |
| 40 ;; Gdbsrc extends the emacs GDB interface to accept gdb commands issued | |
| 41 ;; from the source code buffer. Gdbsrc behaves similar to gdb except now all | |
| 42 ;; debugging may be done from the currently focused source buffer using | |
| 43 ;; the *gdb* buffer to view output. | |
| 44 | |
| 45 ;; When source files are displayed through gdbsrc, buffers are put in | |
| 46 ;; gdbsrc-mode minor mode. This mode puts the buffer in read-only state | |
| 47 ;; and sets up a special key and mouse map to invoke communication with | |
| 48 ;; the current gdb process. The minor mode may be toggled on/off as needed. | |
| 49 ;; (ESC-T) | |
| 50 | |
| 51 ;; C-expressions may be evaluated by gdbsrc by simply pointing at text in the | |
| 52 ;; current source buffer with the mouse or by centering the cursor over text | |
| 53 ;; and typing a single key command. ('p' for print, '*' for print *). | |
| 54 | |
| 55 ;; As code is debugged and new buffers are displayed, the focus of gdbsrc | |
| 56 ;; follows to each new source buffer. Makes debugging fun. (sound like a | |
| 57 ;; commercial or what!) | |
| 58 ;; | |
| 59 | |
| 60 ;; Current Listing :: | |
| 61 ;;key binding Comment | |
| 62 ;;--- ------- ------- | |
| 63 ;; | |
| 64 ;; r gdb-return-from-src GDB return command | |
| 65 ;; n gdb-next-from-src GDB next command | |
| 66 ;; b gdb-back-from-src GDB back command | |
| 67 ;; w gdb-where-from-src GDB where command | |
| 68 ;; f gdb-finish-from-src GDB finish command | |
| 69 ;; u gdb-up-from-src GDB up command | |
| 70 ;; d gdb-down-from-src GDB down command | |
| 71 ;; c gdb-cont-from-src GDB continue command | |
| 72 ;; i gdb-stepi-from-src GDB step instruction command | |
| 73 ;; s gdb-step-from-src GDB step command | |
| 74 ;; ? gdb-whatis-c-sexp GDB whatis command for data at | |
| 75 ;; buffer point | |
| 76 ;; x gdbsrc-delete GDB Delete all breakpoints if no arg | |
| 77 ;; given or delete arg (C-u arg x) | |
| 78 ;; m gdbsrc-frame GDB Display current frame if no arg, | |
| 79 ;; given or display frame arg | |
| 80 ;; * gdb-*print-c-sexp GDB print * command for data at | |
| 81 ;; buffer point | |
| 82 ;; ! gdbsrc-goto-gdb Goto the GDB output buffer | |
| 83 ;; p gdb-print-c-sexp GDB print * command for data at | |
| 84 ;; buffer point | |
| 85 ;; g gdbsrc-goto-gdb Goto the GDB output buffer | |
| 86 ;; t gdbsrc-mode Toggles Gdbsrc mode (turns it off) | |
| 87 ;; | |
| 88 ;; C-c C-f gdb-finish-from-src GDB finish command | |
| 89 ;; | |
| 90 ;; C-x SPC gdb-break Set break for line with point | |
| 91 ;; ESC t gdbsrc-mode Toggle Gdbsrc mode | |
| 92 ;; | |
| 93 ;; Local Bindings for buffer when you exit Gdbsrc minor mode | |
| 94 ;; | |
| 95 ;; C-x SPC gdb-break Set break for line with point | |
| 96 ;; ESC t gdbsrc-mode Toggle Gdbsrc mode | |
| 97 ;; | |
| 98 | |
| 99 ;;; (eval-when-compile | |
| 100 ;;; (or noninteractive | |
| 101 ;;; (progn | |
| 102 ;;; (message "ONLY compile gdbsrc except with -batch because of advice") | |
| 103 ;;; (ding) | |
| 104 ;;; ))) | |
| 105 | |
| 106 (require 'gdb "gdb") ; NOT gud! (yet...) | |
| 107 | |
| 108 (defvar gdbsrc-active-p t | |
| 109 "*Set to nil if you do not want source files put in gdbsrc-mode") | |
| 110 | |
| 111 (defvar gdbsrc-call-p nil | |
| 112 "True if gdb command issued from a source buffer") | |
| 113 | |
| 114 (defvar gdbsrc-associated-buffer nil | |
| 115 "Buffer name of attached gdb process") | |
| 116 | |
| 117 (defvar gdbsrc-mode nil | |
| 118 "Indicates whether buffer is in gdbsrc-mode or not") | |
| 119 (make-variable-buffer-local 'gdbsrc-mode) | |
| 120 | |
| 121 (defvar gdbsrc-global-mode nil | |
| 122 "Indicates whether global gdbsrc bindings are in effect or not") | |
| 123 | |
| 124 (defvar gdb-prompt-pattern "^[^)#$%>\n]*[)#$%>] *" | |
| 125 "A regexp for matching the end of the gdb prompt") | |
| 126 | |
| 127 ;;; bindings | |
| 128 | |
| 129 (defvar gdbsrc-global-map | |
| 130 (let ((map (make-sparse-keymap))) | |
| 131 (set-keymap-name map 'gdbsrc-global-map) | |
| 132 (define-key map "\C-x " 'gdb-break) | |
| 133 (define-key map "\M-\C-t" 'gdbsrc-mode) | |
| 134 (define-key map "\M-\C-g" 'gdbsrc-goto-gdb) | |
| 135 | |
| 136 ;; middle button to select and print expressions... | |
| 137 (define-key map '(meta button2) 'gdbsrc-print-csexp) | |
| 138 (define-key map '(meta shift button2) 'gdbsrc-*print-csexp) | |
| 139 ;; left button to position breakpoints | |
| 140 (define-key map '(meta button1) 'gdbsrc-set-break) | |
| 141 (define-key map '(meta shift button1) 'gdbsrc-set-tbreak-continue) | |
| 142 map) | |
| 143 "Global minor keymap that is active whenever gdbsrc is running.") | |
| 144 | |
| 145 (add-minor-mode 'gdbsrc-global-mode " GdbGlobal" gdbsrc-global-map) | |
| 146 | |
| 147 (defvar gdbsrc-mode-map | |
| 148 (let ((map (make-sparse-keymap))) | |
| 149 (suppress-keymap map) | |
| 150 (set-keymap-name map 'gdbsrc-mode-map) | |
| 151 ;; inherit keys from global gdbsrc map just in case that somehow gets turned off. | |
| 152 (set-keymap-parents map (list gdbsrc-global-map)) | |
| 153 (define-key map "\C-x\C-q" 'gdbsrc-mode) ; toggle read-only | |
| 154 (define-key map "\C-c\C-c" 'gdbsrc-mode) | |
| 155 (define-key map "b" 'gdb-break) | |
| 156 (define-key map "g" 'gdbsrc-goto-gdb) | |
| 157 (define-key map "!" 'gdbsrc-goto-gdb) | |
| 158 (define-key map "p" 'gdb-print-c-sexp) | |
| 159 (define-key map "*" 'gdb-*print-c-sexp) | |
| 160 (define-key map "?" 'gdb-whatis-c-sexp) | |
| 161 (define-key map "R" 'gdbsrc-reset) | |
| 162 map) | |
| 163 "Minor keymap for buffers in gdbsrc-mode") | |
| 164 | |
| 165 (add-minor-mode 'gdbsrc-mode " GdbSrc" gdbsrc-mode-map) | |
| 166 | |
| 167 (defvar gdbsrc-toolbar | |
| 168 '([eos::toolbar-stop-at-icon | |
| 169 gdb-break | |
| 170 t | |
| 171 "Stop at selected position"] | |
| 172 [eos::toolbar-stop-in-icon | |
| 173 gdb-break | |
| 174 t | |
| 175 "Stop in function whose name is selected"] | |
| 176 [eos::toolbar-clear-at-icon | |
| 177 gdbsrc-delete | |
| 178 t | |
| 179 "Clear at selected position"] | |
| 180 [eos::toolbar-evaluate-icon | |
| 181 gdb-print-c-sexp | |
| 182 t | |
| 183 "Evaluate selected expression; shows in separate XEmacs frame"] | |
| 184 [eos::toolbar-evaluate-star-icon | |
| 185 gdb-*print-c-sexp | |
| 186 t | |
| 187 "Evaluate selected expression as a pointer; shows in separate XEmacs frame"] | |
| 188 [eos::toolbar-run-icon | |
| 189 gdbsrc-run | |
| 190 t | |
| 191 "Run current program"] | |
| 192 [eos::toolbar-cont-icon | |
| 193 gdbsrc-cont | |
| 194 t | |
| 195 "Continue current program"] | |
| 196 [eos::toolbar-step-into-icon | |
| 197 gdbsrc-step | |
| 198 t | |
| 199 "Step into (aka step)"] | |
| 200 [eos::toolbar-step-over-icon | |
| 201 gdbsrc-next | |
| 202 t | |
| 203 "Step over (aka next)"] | |
| 204 [eos::toolbar-up-icon | |
| 205 gdbsrc-up | |
| 206 t | |
| 207 "Stack Up (towards \"cooler\" - less recently visited - frames)"] | |
| 208 [eos::toolbar-down-icon | |
| 209 gdbsrc-down | |
| 210 t | |
| 211 "Stack Down (towards \"warmer\" - more recently visited - frames)"] | |
| 212 [eos::toolbar-fix-icon | |
| 213 nil | |
| 214 nil | |
| 215 "Fix (not available with gdb)"] | |
| 216 [eos::toolbar-build-icon | |
| 217 toolbar-compile | |
| 218 t | |
| 219 "Build (aka make -NYI)"] | |
| 220 )) | |
| 221 | |
| 222 (defmacro def-gdb-from-src (gdb-command key &optional doc &rest forms) | |
| 223 "Create a function that will call GDB-COMMAND with KEY." | |
| 224 (let* ((fname (format "gdbsrc-%s" gdb-command)) | |
| 225 (cstr (list 'if 'arg | |
| 226 (list 'format "%s %s" gdb-command '(prefix-numeric-value arg)) | |
| 227 gdb-command)) | |
| 228 fun) | |
| 229 (while (string-match " " fname) | |
| 230 (aset fname (match-beginning 0) ?-)) | |
| 231 (setq fun (intern fname)) | |
| 232 | |
| 233 (list 'progn | |
| 234 (nconc (list 'defun fun '(arg) | |
| 235 (or doc "") | |
| 236 '(interactive "P") | |
| 237 (list 'gdb-call-from-src cstr)) | |
| 238 forms) | |
| 239 (list 'define-key 'gdbsrc-mode-map key (list 'quote fun))))) | |
| 240 | |
| 241 (def-gdb-from-src "step" "s" "Step one instruction in src" | |
| 242 (gdb-delete-arrow-extent)) | |
| 243 (def-gdb-from-src "stepi" "i" "Step one source line (skip functions)" | |
| 244 (gdb-delete-arrow-extent)) | |
| 245 (def-gdb-from-src "cont" "c" "Continue with display" | |
| 246 (gdb-delete-arrow-extent)) | |
| 247 (def-gdb-from-src "down" "d" "Go down N stack frames (numeric arg) ") | |
| 248 (def-gdb-from-src "up" "u" "Go up N stack frames (numeric arg)") | |
| 249 (def-gdb-from-src "finish" "f" "Finish frame") | |
| 250 (def-gdb-from-src "where" "w" "Display (N frames of) backtrace") | |
| 251 (def-gdb-from-src "next" "n" "Step one line with display" | |
| 252 (gdb-delete-arrow-extent)) | |
| 253 (def-gdb-from-src "run" "r" "Run program from start" | |
| 254 (gdb-delete-arrow-extent)) | |
| 255 (def-gdb-from-src "return" "R" "Return from selected stack frame") | |
| 256 (def-gdb-from-src "disable" "x" "Disable all breakpoints") | |
| 257 (def-gdb-from-src "delete" "X" "Delete all breakpoints") | |
| 258 (def-gdb-from-src "quit" "Q" "Quit gdb." | |
| 259 (gdb-delete-arrow-extent)) | |
| 260 (def-gdb-from-src "info locals" "l" "Show local variables") | |
| 261 (def-gdb-from-src "info break" "B" "Show breakpoints") | |
| 262 (def-gdb-from-src "" "\r" "Repeat last command") | |
| 263 (def-gdb-from-src "frame" "m" "Show frame if no arg, with arg go to frame") | |
| 264 | |
| 265 ;;; code | |
| 266 | |
| 267 ;;;###autoload | |
| 268 (defun gdbsrc (path &optional core-or-pid) | |
| 269 "Activates a gdb session with gdbsrc-mode turned on. A numeric prefix | |
| 270 argument can be used to specify a running process to attach, and a non-numeric | |
| 271 prefix argument will cause you to be prompted for a core file to debug." | |
| 272 (interactive (let ((file (read-file-name "Program to debug: " nil nil t))) | |
| 273 (cond ((numberp current-prefix-arg) | |
| 274 (list file (int-to-string current-prefix-arg))) | |
| 275 (current-prefix-arg | |
| 276 (list file (read-file-name "Core file: " nil nil t))) | |
| 277 (t (list file))) | |
| 278 )) | |
| 279 ;; FIXME - this is perhaps an uncool thing to do --Stig | |
| 280 (delete-other-windows) | |
| 281 (split-window-vertically) | |
| 282 (other-window 0) | |
| 283 | |
| 284 (gdb path core-or-pid) | |
| 285 (local-set-key 'button2 'gdbsrc-select-or-yank) | |
| 286 (setq mode-motion-hook 'gdbsrc-mode-motion) | |
| 287 ;; XEmacs change: | |
| 288 (make-local-hook 'kill-buffer-hook) | |
| 289 (add-hook 'kill-buffer-hook 'gdbsrc-reset nil t)) | |
| 290 | |
| 291 (defun gdbsrc-global-mode () | |
| 292 ;; this can be used as a hook for gdb-mode.... | |
| 293 (or current-gdb-buffer | |
| 294 (and (eq major-mode 'gdb-mode) ; doesn't work w/ energize yet | |
| 295 (setq current-gdb-buffer (current-buffer)) | |
| 296 ;; XEmacs change: | |
| 297 (make-local-hook 'kill-buffer-hook) | |
| 298 (add-hook 'kill-buffer-hook 'gdbsrc-reset nil t)) | |
| 299 (error "Cannot determine current-gdb-buffer")) | |
| 300 ;;; (set-process-filter | |
| 301 ;;; (get-buffer-process current-gdb-buffer) 'gdbsrc-mode-filter) | |
| 302 ;;; (set-process-sentinel | |
| 303 ;;; (get-buffer-process current-gdb-buffer) 'gdbsrc-mode-sentinel) | |
| 304 ;; gdbsrc-global-mode was set to t here but that tended to piss | |
| 305 ;; people off | |
| 306 (setq gdbsrc-global-mode nil | |
| 307 gdbsrc-active-p t | |
| 308 gdbsrc-call-p nil | |
| 309 gdbsrc-mode nil) | |
| 310 (message "Gbd source mode active")) | |
| 311 | |
| 312 (add-hook 'gdb-mode-hook 'gdbsrc-global-mode) | |
| 313 | |
| 314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 315 ;;; Gdb Source minor mode. | |
| 316 ;;; | |
| 317 | |
| 318 (defvar gdbsrc-associated-buffer nil | |
| 319 "The gdb buffer to send commands to.") | |
| 320 (defvar gdbsrc-initial-readonly 'undefined | |
| 321 "read-only status of buffer when not in gdbsrc-mode") | |
| 322 (defvar gdbsrc-old-toolbar nil | |
| 323 "saved toolbar for buffer") | |
| 324 | |
| 325 (defun gdbsrc-mode (arg &optional quiet) | |
| 326 "Minor mode for interacting with gdb from a c source file. | |
| 327 With arg, turn gdbsrc-mode on iff arg is positive. In gdbsrc-mode, | |
| 328 you may send an associated gdb buffer commands from the current buffer | |
| 329 containing c source code." | |
| 330 (interactive "P") | |
| 331 (setq gdbsrc-mode | |
| 332 (if (null arg) | |
| 333 (not gdbsrc-mode) | |
| 334 (> (prefix-numeric-value arg) 0))) | |
| 335 | |
| 336 (cond (gdbsrc-mode | |
| 337 (cond ((not (local-variable-p 'gdbsrc-initial-readonly (current-buffer))) | |
| 338 (set (make-local-variable 'gdbsrc-initial-readonly) | |
| 339 buffer-read-only) | |
| 340 (set (make-local-variable 'gdbsrc-associated-buffer) | |
| 341 current-gdb-buffer) | |
| 342 (if (featurep 'toolbar) | |
| 343 (set (make-local-variable 'gdbsrc-old-toolbar) | |
| 344 (specifier-specs default-toolbar (current-buffer)))) | |
| 345 ) | |
| 346 ) | |
| 347 (if (featurep 'toolbar) | |
| 348 (set-specifier default-toolbar (cons (current-buffer) | |
| 349 gdbsrc-toolbar))) | |
| 350 (setq buffer-read-only t) | |
| 351 (or quiet (message "Entering gdbsrc-mode..."))) | |
| 352 (t | |
| 353 (and (local-variable-p 'gdbsrc-initial-readonly (current-buffer)) | |
| 354 (progn | |
| 355 (if (featurep 'toolbar) | |
| 356 (if gdbsrc-old-toolbar | |
| 357 (set-specifier default-toolbar | |
| 358 (cons (current-buffer) | |
| 359 gdbsrc-old-toolbar)) | |
| 360 (remove-specifier default-toolbar (current-buffer)))) | |
| 361 (kill-local-variable 'gdbsrc-old-toolbar) | |
| 362 (setq buffer-read-only gdbsrc-initial-readonly) | |
| 363 (kill-local-variable 'gdbsrc-initial-readonly) | |
| 364 (kill-local-variable 'gdbsrc-associated-buffer) | |
| 365 )) | |
| 366 (or quiet (message "Exiting gdbsrc-mode...")))) | |
| 367 (redraw-modeline t)) | |
| 368 | |
| 369 ;; | |
| 370 ;; Sends commands to gdb process. | |
| 371 | |
| 372 (defun gdb-call-from-src (command) | |
| 373 "Send associated gdb process COMMAND displaying source in this window." | |
| 374 (setq gdbsrc-call-p t) | |
| 375 (let ((buf (or gdbsrc-associated-buffer current-gdb-buffer))) | |
| 376 (or (buffer-name buf) | |
| 377 (error "GDB buffer deleted")) | |
| 378 (pop-to-buffer buf)) | |
| 379 (goto-char (point-max)) | |
| 380 (beginning-of-line) | |
| 381 ;; Go past gdb prompt | |
| 382 (re-search-forward | |
| 383 gdb-prompt-pattern (save-excursion (end-of-line) (point)) t) | |
| 384 ;; Delete any not-supposed-to-be-there text | |
| 385 (delete-region (point) (point-max)) | |
| 386 (insert command) | |
| 387 (comint-send-input)) | |
| 388 | |
| 389 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 390 ;;; | |
| 391 ;;; Define Commands for GDB SRC Mode Buffer | |
| 392 ;;; | |
| 393 | |
| 394 ;;; ;; #### - move elsewhere | |
| 395 (or (fboundp 'event-buffer) | |
| 396 (defun event-buffer (event) | |
| 397 "Return buffer assocaited with EVENT, or nil." | |
| 398 (let ((win (event-window event))) | |
| 399 (and win (window-buffer win))))) | |
| 400 | |
| 401 (defun set-gdbsrc-mode-motion-extent (st en action) | |
| 402 ;; by Stig@hackvan.com | |
| 403 (let ((ex (make-extent st en))) | |
| 404 (set-extent-face ex 'highlight) | |
| 405 (set-extent-property ex 'gdbsrc t) | |
| 406 (set-extent-property ex 'action action) | |
| 407 (setq mode-motion-extent ex))) | |
| 408 | |
| 409 (defun nuke-mode-motion-extent () | |
| 410 ;; by Stig@hackvan.com | |
| 411 (cond (mode-motion-extent | |
| 412 (delete-extent mode-motion-extent) | |
| 413 (setq mode-motion-extent nil)))) | |
| 414 | |
| 415 (defun looking-at-any (regex-list) | |
| 416 ;; by Stig@hackvan.com | |
| 417 (catch 'found | |
| 418 (while regex-list | |
| 419 (and (looking-at (car regex-list)) | |
| 420 (throw 'found t)) | |
| 421 (setq regex-list (cdr regex-list))))) | |
| 422 | |
| 423 (defconst gdb-breakpoint-patterns | |
| 424 '( | |
| 425 ;; when execution stops... | |
| 426 ;;Breakpoint 1, XlwMenuRedisplay (w=0x4d2e00, ev=0xefffe3f8, region=0x580e60) | |
| 427 ;; at /net/stig/src/xemacs/lwlib/xlwmenu.c:2518 | |
| 428 "^[BW][ra][et][ac][kh]point [0-9]+, .*\\(\n\\s .*\\)*" | |
| 429 ;; output of the breakpoint command: | |
| 430 ;;Breakpoint 1 at 0x19f5c8: file /net/stig/src/xemacs/lwlib/xlwmenu.c, line 2715. | |
| 431 "^[BW][ra][et][ac][kh]point [0-9]+ at .*: file \\([^ ,\n]+\\), line \\([0-9]+\\)." | |
| 432 ;;Num Type Disp Enb Address What | |
| 433 ;;1 breakpoint keep y 0x0019ee60 in XlwMenuRedisplay | |
| 434 ;; at /net/stig/src/xemacs/lwlib/xlwmenu.c:2518 | |
| 435 "^[0-9]+\\s +[bw][ra][et][ac][kh]point.* in .*\\(\n\\s +\\)?at [^ :\n]+:[0-9]+\\(\n\\s .*\\)*" | |
| 436 ) | |
| 437 "list of patterns to match gdb's various ways of displaying a breakpoint") | |
| 438 | |
| 439 (defun gdbsrc-make-breakpoint-action (string) | |
| 440 ;; by Stig@hackvan.com | |
| 441 (if (or (string-match "file \\([^ ,\n]+\\), line \\([0-9]+\\)" string) | |
| 442 (string-match "at \\([^ :\n]+\\):\\([0-9]+\\)" string)) | |
| 443 (list 'gdbsrc-display | |
| 444 (match-string 1 string) | |
| 445 (string-to-int (match-string 2 string))))) | |
| 446 | |
| 447 (defconst gdb-stack-frame-pattern | |
| 448 ;;#9 0x62f08 in emacs_Xt_next_event (emacs_event=0x4cf804) | |
| 449 ;; at /net/stig/src/xemacs/src/event-Xt.c:1778 | |
| 450 "^#\\([0-9]+\\)\\s +\\(0x[0-9a-f]+ in .*\\|.*\\sw+.* (.*) at .*\\)\\(\n\\s .*\\)*" | |
| 451 "matches the first line of a gdb stack frame and all continuation lines. | |
| 452 subex 1 is frame number.") | |
| 453 | |
| 454 (defun gdbsrc-mode-motion (ee) | |
| 455 ;; by Stig@hackvan.com | |
| 456 (save-excursion | |
| 457 (set-buffer (event-buffer ee)) | |
| 458 (save-excursion | |
| 459 (if (not (event-point ee)) | |
| 460 (nuke-mode-motion-extent) | |
| 461 (goto-char (event-point ee)) | |
| 462 (beginning-of-line) | |
| 463 (while (and (not (bobp)) (eq ? (char-syntax (following-char)))) | |
| 464 (forward-line -1)) | |
| 465 (if (extent-at (point) (current-buffer) 'gdbsrc) | |
| 466 nil | |
| 467 (nuke-mode-motion-extent) | |
| 468 (cond ((looking-at-any gdb-breakpoint-patterns) | |
| 469 (set-gdbsrc-mode-motion-extent | |
| 470 (match-beginning 0) | |
| 471 (match-end 0) | |
| 472 (gdbsrc-make-breakpoint-action (match-string 0)))) | |
| 473 ((looking-at gdb-stack-frame-pattern) | |
| 474 (set-gdbsrc-mode-motion-extent | |
| 475 (match-beginning 0) | |
| 476 (match-end 0) | |
| 477 (list 'gdbsrc-frame | |
| 478 (string-to-int (match-string 1))))) | |
| 479 ))) | |
| 480 ))) | |
| 481 | |
| 482 (defun gdbsrc-display (file line) | |
| 483 ;; by Stig@hackvan.com | |
| 484 (select-window (display-buffer (find-file-noselect file))) | |
| 485 (goto-line line)) | |
| 486 | |
| 487 (defun click-inside-selection-p (click) | |
| 488 (or (click-inside-extent-p click primary-selection-extent) | |
| 489 (click-inside-extent-p click zmacs-region-extent) | |
| 490 )) | |
| 491 | |
| 492 (defun click-inside-extent-p (click extent) | |
| 493 "Returns non-nil if the button event is within the bounds of the primary | |
| 494 selection-extent, nil otherwise." | |
| 495 ;; stig@hackvan.com | |
| 496 (let ((ewin (event-window click)) | |
| 497 (epnt (event-point click))) | |
| 498 (and ewin | |
| 499 epnt | |
| 500 extent | |
| 501 (eq (window-buffer ewin) | |
| 502 (extent-buffer extent)) | |
| 503 (extent-start-position extent) | |
| 504 (> epnt (extent-start-position extent)) | |
| 505 (> (extent-end-position extent) epnt)))) | |
| 506 | |
| 507 (defun point-inside-extent-p (extent) | |
| 508 "Returns non-nil if the point is within or just after the bounds of the | |
| 509 primary selection-extent, nil otherwise." | |
| 510 ;; stig@hackvan.com | |
| 511 (and extent ; FIXME - I'm such a sinner... | |
| 512 (eq (current-buffer) | |
| 513 (extent-buffer extent)) | |
| 514 (> (point) (extent-start-position extent)) | |
| 515 (>= (extent-end-position extent) (point)))) | |
| 516 | |
| 517 (defun gdbsrc-select-or-yank (ee) | |
| 518 ;; by Stig@hackvan.com | |
| 519 (interactive "e") | |
| 520 (let ((action (save-excursion | |
| 521 (set-buffer (event-buffer ee)) | |
| 522 (and mode-motion-extent | |
| 523 (click-inside-extent-p ee mode-motion-extent) | |
| 524 (extent-property mode-motion-extent 'action))) | |
| 525 )) | |
| 526 (if action | |
| 527 (eval action) | |
| 528 (mouse-yank ee)))) | |
| 529 | |
| 530 (defvar gdb-print-format "" | |
| 531 "Set this variable to a valid format string to print c-sexps in a | |
| 532 different way (hex,octal, etc).") | |
| 533 | |
| 534 (defun gdb-print-c-sexp () | |
| 535 "Find the nearest c-mode sexp. Send it to gdb with print command." | |
| 536 (interactive) | |
| 537 (let* ((tag (find-c-sexp)) | |
| 538 (command (concat "print " gdb-print-format tag))) | |
| 539 (gdb-call-from-src command))) | |
| 540 | |
| 541 (defun gdb-*print-c-sexp () | |
| 542 "Find the nearest c-mode sexp. Send it to gdb with the print * command." | |
| 543 (interactive) | |
| 544 (let* ((tag (find-c-sexp)) | |
| 545 (command (concat "print " gdb-print-format "*" tag))) | |
| 546 (gdb-call-from-src command))) | |
| 547 | |
| 548 (defun gdb-whatis-c-sexp () | |
| 549 "Find the nearest c-mode sexp. Send it to gdb with the whatis command. " | |
| 550 (interactive) | |
| 551 (let* ((tag (gdbsrc-selection-or-sexp)) | |
| 552 (command (concat "whatis " tag))) | |
| 553 (gdb-call-from-src command))) | |
| 554 | |
| 555 (defun gdbsrc-goto-gdb () | |
| 556 "Hop back and forth between the gdb interaction buffer and the gdb source | |
| 557 buffer. " | |
| 558 ;; by Stig@hackvan.com | |
| 559 (interactive) | |
| 560 (let ((gbuf (or gdbsrc-associated-buffer current-gdb-buffer))) | |
| 561 (cond ((eq (current-buffer) gbuf) | |
| 562 (and gdb-arrow-extent | |
| 563 (extent-buffer gdb-arrow-extent) | |
| 564 (progn (pop-to-buffer (extent-buffer gdb-arrow-extent)) | |
| 565 (goto-char (extent-start-position gdb-arrow-extent))))) | |
| 566 ((buffer-name gbuf) (pop-to-buffer gbuf)) | |
| 567 ((y-or-n-p "No debugger. Start a new one? ") | |
| 568 (call-interactively 'gdbsrc)) | |
| 569 (t (error "No gdb buffer.")) | |
| 570 ))) | |
| 571 | |
| 572 (defvar gdbsrc-last-src-buffer nil) | |
| 573 | |
| 574 (defun gdbsrc-goto-src () | |
| 575 (interactive) | |
| 576 (let* ((valid (and gdbsrc-last-src-buffer | |
| 577 (memq gdbsrc-last-src-buffer (buffer-list)))) | |
| 578 (win (and valid | |
| 579 (get-buffer-window gdbsrc-last-src-buffer)))) | |
| 580 (cond (win (select-window win)) | |
| 581 (valid (pop-to-buffer gdbsrc-last-src-buffer))))) | |
| 582 | |
| 583 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 584 ;;; | |
| 585 ;;; The following functions are used to extract the closest surrounding | |
| 586 ;;; c expression from point | |
| 587 ;;; | |
| 588 (defun back-sexp () | |
| 589 "Version of backward-sexp that catches errors" | |
| 590 (condition-case nil | |
| 591 (backward-sexp) | |
| 592 (error t))) | |
| 593 | |
| 594 (defun forw-sexp () | |
| 595 "Version of forward-sexp that catches errors" | |
| 596 (condition-case nil | |
| 597 (forward-sexp) | |
| 598 (error t))) | |
| 599 | |
| 600 (defun sexp-compound-sep (span-start span-end) | |
| 601 "Returns '.' for '->' & '.', returns ' ' for white space, | |
| 602 returns '?' for other puctuation" | |
| 603 (let ((result ? ) | |
| 604 (syntax)) | |
| 605 (while (< span-start span-end) | |
| 606 (setq syntax (char-syntax (char-after span-start))) | |
| 607 (cond | |
| 608 ((= syntax ? ) t) | |
| 609 ((= syntax ?.) (setq syntax (char-after span-start)) | |
| 610 (cond | |
| 611 ((= syntax ?.) (setq result ?.)) | |
| 612 ((and (= syntax ?-) (= (char-after (+ span-start 1)) ?>)) | |
| 613 (setq result ?.) | |
| 614 (setq span-start (+ span-start 1))) | |
| 615 (t (setq span-start span-end) | |
| 616 (setq result ??))))) | |
| 617 (setq span-start (+ span-start 1))) | |
| 618 result | |
| 619 ) | |
| 620 ) | |
| 621 | |
| 622 (defun sexp-compound (first second) | |
| 623 "Returns non-nil if the concatenation of two S-EXPs result in a Single C | |
| 624 token. The two S-EXPs are represented as a cons cells, where the car | |
| 625 specifies the point in the current buffer that marks the begging of the | |
| 626 S-EXP and the cdr specifies the character after the end of the S-EXP | |
| 627 Link S-Exps of the form: | |
| 628 Sexp -> SexpC | |
| 629 Sexp . Sexp | |
| 630 Sexp (Sexp) Maybe exclude if first Sexp is: if, while, do, for, switch | |
| 631 Sexp [Sexp] | |
| 632 (Sexp) Sexp | |
| 633 [Sexp] Sexp" | |
| 634 (let ((span-start (cdr first)) | |
| 635 (span-end (car second)) | |
| 636 (syntax)) | |
| 637 (setq syntax (sexp-compound-sep span-start span-end)) | |
| 638 (cond | |
| 639 ((= (car first) (car second)) nil) | |
| 640 ((= (cdr first) (cdr second)) nil) | |
| 641 ((= syntax ?.) t) | |
| 642 ((= syntax ? ) | |
| 643 (setq span-start (char-after (- span-start 1))) | |
| 644 (setq span-end (char-after span-end)) | |
| 645 (cond | |
| 646 ((= span-start ?) ) t ) | |
| 647 ((= span-start ?] ) t ) | |
| 648 ((= span-end ?( ) t ) | |
| 649 ((= span-end ?[ ) t ) | |
| 650 (t nil)) | |
| 651 ) | |
| 652 (t nil)) | |
| 653 ) | |
| 654 ) | |
| 655 | |
| 656 (defun sexp-cur () | |
| 657 "Returns the S-EXP that Point is a member, Point is set to begging of S-EXP. | |
| 658 The S-EXPs is represented as a cons cell, where the car specifies the point in | |
| 659 the current buffer that marks the begging of the S-EXP and the cdr specifies | |
| 660 the character after the end of the S-EXP" | |
| 661 (let ((p (point)) (begin) (end)) | |
| 662 (back-sexp) | |
| 663 (setq begin (point)) | |
| 664 (forw-sexp) | |
| 665 (setq end (point)) | |
| 666 (if (>= p end) | |
| 667 (progn | |
| 668 (setq begin p) | |
| 669 (goto-char p) | |
| 670 (forw-sexp) | |
| 671 (setq end (point)) | |
| 672 ) | |
| 673 ) | |
| 674 (goto-char begin) | |
| 675 (cons begin end) | |
| 676 ) | |
| 677 ) | |
| 678 | |
| 679 (defun sexp-prev () | |
| 680 "Returns the previous S-EXP, Point is set to begging of that S-EXP. | |
| 681 The S-EXPs is represented as a cons cell, where the car specifies the point in | |
| 682 the current buffer that marks the begging of the S-EXP and the cdr specifies | |
| 683 the character after the end of the S-EXP" | |
| 684 (let ((begin) (end)) | |
| 685 (back-sexp) | |
| 686 (setq begin (point)) | |
| 687 (forw-sexp) | |
| 688 (setq end (point)) | |
| 689 (goto-char begin) | |
| 690 (cons begin end)) | |
| 691 ) | |
| 692 | |
| 693 (defun sexp-next () | |
| 694 "Returns the following S-EXP, Point is set to begging of that S-EXP. | |
| 695 The S-EXPs is represented as a cons cell, where the car specifies the point in | |
| 696 the current buffer that marks the begging of the S-EXP and the cdr specifies | |
| 697 the character after the end of the S-EXP" | |
| 698 (let ((begin) (end)) | |
| 699 (forw-sexp) | |
| 700 (forw-sexp) | |
| 701 (setq end (point)) | |
| 702 (back-sexp) | |
| 703 (setq begin (point)) | |
| 704 (cons begin end) | |
| 705 ) | |
| 706 ) | |
| 707 | |
| 708 (defun find-c-sexp () | |
| 709 "Returns the Complex S-EXP that surrounds Point" | |
| 710 (interactive) | |
| 711 (save-excursion | |
| 712 (let ((p) (sexp) (test-sexp)) | |
| 713 (setq p (point)) | |
| 714 (setq sexp (sexp-cur)) | |
| 715 (setq test-sexp (sexp-prev)) | |
| 716 (while (sexp-compound test-sexp sexp) | |
| 717 (setq sexp (cons (car test-sexp) (cdr sexp))) | |
| 718 (goto-char (car sexp)) | |
| 719 (setq test-sexp (sexp-prev)) | |
| 720 ) | |
| 721 (goto-char p) | |
| 722 (setq test-sexp (sexp-next)) | |
| 723 (while (sexp-compound sexp test-sexp) | |
| 724 (setq sexp (cons (car sexp) (cdr test-sexp))) | |
| 725 (setq test-sexp (sexp-next)) | |
| 726 ) | |
| 727 (buffer-substring (car sexp) (cdr sexp)) | |
| 728 ) | |
| 729 ) | |
| 730 ) | |
| 731 | |
| 732 (defun gdbsrc-selection-or-sexp (&optional ee) | |
| 733 ;; FIXME - fix this docstring | |
| 734 "If the EVENT is within the primary selection, then return the selected | |
| 735 text, otherwise parse the expression at the point of the mouse click and | |
| 736 return that. If EVENT is nil, then return the C sexp at point." | |
| 737 ;; stig@hackvan.com | |
| 738 (cond ((or (and ee (click-inside-selection-p ee)) | |
| 739 (and (not ee) (point-inside-selection-p))) | |
| 740 (replace-in-string (extent-string primary-selection-extent) "\n\\s *" " ")) | |
| 741 (ee | |
| 742 (gdbsrc-get-csexp-at-click ee)) | |
| 743 (t | |
| 744 (find-c-sexp)) | |
| 745 )) | |
| 746 | |
| 747 (defun gdbsrc-get-csexp-at-click (ee) | |
| 748 "Returns the containing s-expression located at the mouse cursor to point." | |
| 749 ;; " | |
| 750 ;; by Stig@hackvan.com | |
| 751 (let ((ewin (event-window ee)) | |
| 752 (epnt (event-point ee))) | |
| 753 (or (and ewin epnt) | |
| 754 (error "Must click within a window")) | |
| 755 (save-excursion | |
| 756 (set-buffer (window-buffer ewin)) | |
| 757 (save-excursion | |
| 758 (goto-char epnt) | |
| 759 (find-c-sexp))))) | |
| 760 | |
| 761 (defun gdbsrc-print-csexp (&optional ee) | |
| 762 (interactive) | |
| 763 (or ee (setq ee current-mouse-event)) | |
| 764 (gdb-call-from-src | |
| 765 (concat "print " gdb-print-format (gdbsrc-selection-or-sexp ee)))) | |
| 766 | |
| 767 (defun gdbsrc-*print-csexp (&optional ee) | |
| 768 (interactive) | |
| 769 (or ee (setq ee current-mouse-event)) | |
| 770 (gdb-call-from-src | |
| 771 (concat "print *" gdb-print-format (gdbsrc-selection-or-sexp ee)))) | |
| 772 | |
| 773 ;; (defun gdbsrc-print-region (arg) | |
| 774 ;; (let (( command (concat "print " gdb-print-format (x-get-cut-buffer)))) | |
| 775 ;; (gdb-call-from-src command))) | |
| 776 ;; | |
| 777 ;; (defun gdbsrc-*print-region (arg) | |
| 778 ;; (let (( command (concat "print *" gdb-print-format (x-get-cut-buffer)))) | |
| 779 ;; (gdb-call-from-src command))) | |
| 780 | |
| 781 (defun gdbsrc-file:lno () | |
| 782 "returns \"file:lno\" specification for location of point. " | |
| 783 ;; by Stig@hackvan.com | |
| 784 (format "%s:%d" | |
| 785 (file-name-nondirectory buffer-file-name) | |
| 786 (save-restriction | |
| 787 (widen) | |
| 788 (1+ (count-lines (point-min) | |
| 789 (save-excursion (beginning-of-line) (point))))) | |
| 790 )) | |
| 791 | |
| 792 (defun gdbsrc-set-break (ee) | |
| 793 "Sets a breakpoint. Click on the selection and it will set a breakpoint | |
| 794 using the selected text. Click anywhere in a source file, and it will set | |
| 795 a breakpoint at that line number of that file." | |
| 796 ;; by Stig@hackvan.com | |
| 797 ;; there is already gdb-break, so this only needs to work with mouse clicks. | |
| 798 (interactive "e") | |
| 799 (gdb-call-from-src | |
| 800 (concat "break " | |
| 801 (if (click-inside-selection-p ee) | |
| 802 (extent-string primary-selection-extent) | |
| 803 (mouse-set-point ee) | |
| 804 (or buffer-file-name (error "No file in window")) | |
| 805 (gdbsrc-file:lno) | |
| 806 )))) | |
| 807 | |
| 808 (defun gdbsrc-set-tbreak-continue (&optional ee) | |
| 809 "Set a temporary breakpoint at the position of the mouse click and then | |
| 810 continues. This can be bound to either a key or a mouse button." | |
| 811 ;; by Stig@hackvan.com | |
| 812 (interactive) | |
| 813 (or ee (setq ee current-mouse-event)) | |
| 814 (and ee (mouse-set-point ee)) | |
| 815 (gdb-call-from-src (concat "tbreak " (gdbsrc-file:lno))) | |
| 816 (gdb-call-from-src "c")) | |
| 817 | |
| 818 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 819 ;; Functions extended from gdb.el for gdbsrc. | |
| 820 ;; | |
| 821 ;; gdbsrc-set-buffer - added a check to set buffer to gdbsrc-associated-buffer | |
| 822 ;; to handle multiple gdb sessions being driven from src | |
| 823 ;; files. | |
| 824 | |
| 825 (require 'advice) | |
| 826 | |
| 827 (defadvice gdb-set-buffer (after gdbsrc activate) ; () | |
| 828 "Advised to work from a source buffer instead of just the gdb buffer." | |
| 829 ;; by Stig@hackvan.com | |
| 830 ;; the operations below have tests which are disjoint from the tests in | |
| 831 ;; the original `gdb-set-buffer'. Current-gdb-buffer cannot be set twice. | |
| 832 (and gdbsrc-call-p | |
| 833 gdbsrc-associated-buffer | |
| 834 (setq current-gdb-buffer gdbsrc-associated-buffer))) | |
| 835 | |
| 836 (defadvice gdb-display-line (around gdbsrc activate) | |
| 837 ;; (true-file line &optional select-method) | |
| 838 "Advised to select the source buffer instead of the gdb-buffer" | |
| 839 ;; by Stig@hackvan.com | |
| 840 (ad-set-arg 2 'source) ; tell it not to select the gdb window | |
| 841 ad-do-it | |
| 842 (save-excursion | |
| 843 (let* ((buf (extent-buffer gdb-arrow-extent)) | |
| 844 (win (get-buffer-window buf))) | |
| 845 (setq gdbsrc-last-src-buffer buf) | |
| 846 (select-window win) | |
| 847 (set-window-point win (extent-start-position gdb-arrow-extent)) | |
| 848 (set-buffer buf)) | |
| 849 (and gdbsrc-active-p | |
| 850 (not gdbsrc-mode) | |
| 851 (not (eq (current-buffer) current-gdb-buffer)) | |
| 852 (gdbsrc-mode 1)))) | |
| 853 | |
| 854 (defadvice gdb-filter (after gdbsrc activate) ; (proc string) | |
| 855 ;; by Stig@hackvan.com | |
| 856 ;; if we got a gdb prompt and it wasn't a gdbsrc command, then it's gdb | |
| 857 ;; hitting a breakpoint or having a core dump, so bounce back to the gdb | |
| 858 ;; window. | |
| 859 (let* ((selbuf (window-buffer (selected-window))) | |
| 860 win) | |
| 861 ;; if we're at a gdb prompt, then display the buffer | |
| 862 (and (save-match-data (string-match gdb-prompt-pattern (ad-get-arg 1))) | |
| 863 (prog1 | |
| 864 (not gdbsrc-call-p) | |
| 865 (setq gdbsrc-call-p nil)) | |
| 866 (setq win (display-buffer current-gdb-buffer)) | |
| 867 ;; if we're not in either the source buffer or the gdb buffer, | |
| 868 ;; then select the window too... | |
| 869 (not (eq selbuf current-gdb-buffer)) | |
| 870 (not (eq selbuf gdbsrc-last-src-buffer)) | |
| 871 (progn | |
| 872 (ding nil 'warp) | |
| 873 (select-window win))) | |
| 874 )) | |
| 875 | |
| 876 (defun gdbsrc-reset () | |
| 877 ;; tidy house and turn off gdbsrc-mode in all buffers | |
| 878 ;; by Stig@hackvan.com | |
| 879 (gdb-delete-arrow-extent) | |
| 880 (setq gdbsrc-global-mode nil) | |
| 881 (mapcar #'(lambda (buffer) | |
| 882 (set-buffer buffer) | |
| 883 (cond ((eq gdbsrc-associated-buffer current-gdb-buffer) | |
| 884 (gdbsrc-mode -1)))) | |
| 885 (buffer-list))) | |
| 886 | |
| 887 (defadvice gdb-sentinel (after gdbsrc freeze) ; (proc msg) | |
| 888 ;; by Stig@hackvan.com | |
| 889 (gdbsrc-reset) | |
| 890 (message "Gdbsrc finished")) | |
| 891 | |
| 892 (provide 'gdbsrc) |