Mercurial > hg > xemacs-beta
diff 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 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/comint/gdbsrc.el Mon Aug 13 08:45:50 2007 +0200 @@ -0,0 +1,892 @@ +;;; gdbsrc.el -- Source-based (as opposed to comint-based) debugger +;; interaction mode eventually, this will be unified with GUD +;; (after gud works reliably w/ XEmacs...) +;; Keywords: c, unix, tools, debugging + +;; Copyright (C) 1990 Debby Ayers <ayers@austin.ibm.com>, and +;; Rich Schaefer <schaefer@asc.slb.com> +;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp. +;; +;; 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 of the License, 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;; Based upon code for version18 by Debra Ayers <ayers@austin.ibm.com> + +;;; GDBSRC:: +;;; Gdbsrc extends the emacs GDB interface to accept gdb commands issued +;;; from the source code buffer. Gdbsrc behaves similar to gdb except +;;; now most debugging may be done from the source code using the *gdb* +;;; buffer to view output. Supports a point and click model under X to +;;; evaluate source code expressions (no more typing long variable names). +;;; +;;; Supports C source at the moment but C++ support will be added if there +;;; is sufficient interest. +;;; + +;; GDBSRC::Gdb Source Mode Interface description. +;; Gdbsrc extends the emacs GDB interface to accept gdb commands issued +;; from the source code buffer. Gdbsrc behaves similar to gdb except now all +;; debugging may be done from the currently focused source buffer using +;; the *gdb* buffer to view output. + +;; When source files are displayed through gdbsrc, buffers are put in +;; gdbsrc-mode minor mode. This mode puts the buffer in read-only state +;; and sets up a special key and mouse map to invoke communication with +;; the current gdb process. The minor mode may be toggled on/off as needed. +;; (ESC-T) + +;; C-expressions may be evaluated by gdbsrc by simply pointing at text in the +;; current source buffer with the mouse or by centering the cursor over text +;; and typing a single key command. ('p' for print, '*' for print *). + +;; As code is debugged and new buffers are displayed, the focus of gdbsrc +;; follows to each new source buffer. Makes debugging fun. (sound like a +;; commercial or what!) +;; + +;; Current Listing :: +;;key binding Comment +;;--- ------- ------- +;; +;; r gdb-return-from-src GDB return command +;; n gdb-next-from-src GDB next command +;; b gdb-back-from-src GDB back command +;; w gdb-where-from-src GDB where command +;; f gdb-finish-from-src GDB finish command +;; u gdb-up-from-src GDB up command +;; d gdb-down-from-src GDB down command +;; c gdb-cont-from-src GDB continue command +;; i gdb-stepi-from-src GDB step instruction command +;; s gdb-step-from-src GDB step command +;; ? gdb-whatis-c-sexp GDB whatis command for data at +;; buffer point +;; x gdbsrc-delete GDB Delete all breakpoints if no arg +;; given or delete arg (C-u arg x) +;; m gdbsrc-frame GDB Display current frame if no arg, +;; given or display frame arg +;; * gdb-*print-c-sexp GDB print * command for data at +;; buffer point +;; ! gdbsrc-goto-gdb Goto the GDB output buffer +;; p gdb-print-c-sexp GDB print * command for data at +;; buffer point +;; g gdbsrc-goto-gdb Goto the GDB output buffer +;; t gdbsrc-mode Toggles Gdbsrc mode (turns it off) +;; +;; C-c C-f gdb-finish-from-src GDB finish command +;; +;; C-x SPC gdb-break Set break for line with point +;; ESC t gdbsrc-mode Toggle Gdbsrc mode +;; +;; Local Bindings for buffer when you exit Gdbsrc minor mode +;; +;; C-x SPC gdb-break Set break for line with point +;; ESC t gdbsrc-mode Toggle Gdbsrc mode +;; + +;;; (eval-when-compile +;;; (or noninteractive +;;; (progn +;;; (message "ONLY compile gdbsrc except with -batch because of advice") +;;; (ding) +;;; ))) + +(require 'gdb "gdb") ; NOT gud! (yet...) + +(defvar gdbsrc-active-p t + "*Set to nil if you do not want source files put in gdbsrc-mode") + +(defvar gdbsrc-call-p nil + "True if gdb command issued from a source buffer") + +(defvar gdbsrc-associated-buffer nil + "Buffer name of attached gdb process") + +(defvar gdbsrc-mode nil + "Indicates whether buffer is in gdbsrc-mode or not") +(make-variable-buffer-local 'gdbsrc-mode) + +(defvar gdbsrc-global-mode nil + "Indicates whether global gdbsrc bindings are in effect or not") + +(defvar gdb-prompt-pattern "^[^)#$%>\n]*[)#$%>] *" + "A regexp for matching the end of the gdb prompt") + +;;; bindings + +(defvar gdbsrc-global-map + (let ((map (make-sparse-keymap))) + (set-keymap-name map 'gdbsrc-global-map) + (define-key map "\C-x " 'gdb-break) + (define-key map "\M-\C-t" 'gdbsrc-mode) + (define-key map "\M-\C-g" 'gdbsrc-goto-gdb) + + ;; middle button to select and print expressions... + (define-key map '(meta button2) 'gdbsrc-print-csexp) + (define-key map '(meta shift button2) 'gdbsrc-*print-csexp) + ;; left button to position breakpoints + (define-key map '(meta button1) 'gdbsrc-set-break) + (define-key map '(meta shift button1) 'gdbsrc-set-tbreak-continue) + map) + "Global minor keymap that is active whenever gdbsrc is running.") + +(add-minor-mode 'gdbsrc-global-mode " GdbGlobal" gdbsrc-global-map) + +(defvar gdbsrc-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (set-keymap-name map 'gdbsrc-mode-map) + ;; inherit keys from global gdbsrc map just in case that somehow gets turned off. + (set-keymap-parents map (list gdbsrc-global-map)) + (define-key map "\C-x\C-q" 'gdbsrc-mode) ; toggle read-only + (define-key map "\C-c\C-c" 'gdbsrc-mode) + (define-key map "b" 'gdb-break) + (define-key map "g" 'gdbsrc-goto-gdb) + (define-key map "!" 'gdbsrc-goto-gdb) + (define-key map "p" 'gdb-print-c-sexp) + (define-key map "*" 'gdb-*print-c-sexp) + (define-key map "?" 'gdb-whatis-c-sexp) + (define-key map "R" 'gdbsrc-reset) + map) + "Minor keymap for buffers in gdbsrc-mode") + +(add-minor-mode 'gdbsrc-mode " GdbSrc" gdbsrc-mode-map) + +(defvar gdbsrc-toolbar + '([eos::toolbar-stop-at-icon + gdb-break + t + "Stop at selected position"] + [eos::toolbar-stop-in-icon + gdb-break + t + "Stop in function whose name is selected"] + [eos::toolbar-clear-at-icon + gdbsrc-delete + t + "Clear at selected position"] + [eos::toolbar-evaluate-icon + gdb-print-c-sexp + t + "Evaluate selected expression; shows in separate XEmacs frame"] + [eos::toolbar-evaluate-star-icon + gdb-*print-c-sexp + t + "Evaluate selected expression as a pointer; shows in separate XEmacs frame"] + [eos::toolbar-run-icon + gdbsrc-run + t + "Run current program"] + [eos::toolbar-cont-icon + gdbsrc-cont + t + "Continue current program"] + [eos::toolbar-step-into-icon + gdbsrc-step + t + "Step into (aka step)"] + [eos::toolbar-step-over-icon + gdbsrc-next + t + "Step over (aka next)"] + [eos::toolbar-up-icon + gdbsrc-up + t + "Stack Up (towards \"cooler\" - less recently visited - frames)"] + [eos::toolbar-down-icon + gdbsrc-down + t + "Stack Down (towards \"warmer\" - more recently visited - frames)"] + [eos::toolbar-fix-icon + nil + nil + "Fix (not available with gdb)"] + [eos::toolbar-build-icon + toolbar-compile + t + "Build (aka make -NYI)"] + )) + +(defmacro def-gdb-from-src (gdb-command key &optional doc &rest forms) + "Create a function that will call GDB-COMMAND with KEY." + (let* ((fname (format "gdbsrc-%s" gdb-command)) + (cstr (list 'if 'arg + (list 'format "%s %s" gdb-command '(prefix-numeric-value arg)) + gdb-command)) + fun) + (while (string-match " " fname) + (aset fname (match-beginning 0) ?-)) + (setq fun (intern fname)) + + (list 'progn + (nconc (list 'defun fun '(arg) + (or doc "") + '(interactive "P") + (list 'gdb-call-from-src cstr)) + forms) + (list 'define-key 'gdbsrc-mode-map key (list 'quote fun))))) + +(def-gdb-from-src "step" "s" "Step one instruction in src" + (gdb-delete-arrow-extent)) +(def-gdb-from-src "stepi" "i" "Step one source line (skip functions)" + (gdb-delete-arrow-extent)) +(def-gdb-from-src "cont" "c" "Continue with display" + (gdb-delete-arrow-extent)) +(def-gdb-from-src "down" "d" "Go down N stack frames (numeric arg) ") +(def-gdb-from-src "up" "u" "Go up N stack frames (numeric arg)") +(def-gdb-from-src "finish" "f" "Finish frame") +(def-gdb-from-src "where" "w" "Display (N frames of) backtrace") +(def-gdb-from-src "next" "n" "Step one line with display" + (gdb-delete-arrow-extent)) +(def-gdb-from-src "run" "r" "Run program from start" + (gdb-delete-arrow-extent)) +(def-gdb-from-src "return" "R" "Return from selected stack frame") +(def-gdb-from-src "disable" "x" "Disable all breakpoints") +(def-gdb-from-src "delete" "X" "Delete all breakpoints") +(def-gdb-from-src "quit" "Q" "Quit gdb." + (gdb-delete-arrow-extent)) +(def-gdb-from-src "info locals" "l" "Show local variables") +(def-gdb-from-src "info break" "B" "Show breakpoints") +(def-gdb-from-src "" "\r" "Repeat last command") +(def-gdb-from-src "frame" "m" "Show frame if no arg, with arg go to frame") + +;;; code + +;;;###autoload +(defun gdbsrc (path &optional core-or-pid) + "Activates a gdb session with gdbsrc-mode turned on. A numeric prefix +argument can be used to specify a running process to attach, and a non-numeric +prefix argument will cause you to be prompted for a core file to debug." + (interactive (let ((file (read-file-name "Program to debug: " nil nil t))) + (cond ((numberp current-prefix-arg) + (list file (int-to-string current-prefix-arg))) + (current-prefix-arg + (list file (read-file-name "Core file: " nil nil t))) + (t (list file))) + )) + ;; FIXME - this is perhaps an uncool thing to do --Stig + (delete-other-windows) + (split-window-vertically) + (other-window 0) + + (gdb path core-or-pid) + (local-set-key 'button2 'gdbsrc-select-or-yank) + (setq mode-motion-hook 'gdbsrc-mode-motion) + ;; XEmacs change: + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'gdbsrc-reset nil t)) + +(defun gdbsrc-global-mode () + ;; this can be used as a hook for gdb-mode.... + (or current-gdb-buffer + (and (eq major-mode 'gdb-mode) ; doesn't work w/ energize yet + (setq current-gdb-buffer (current-buffer)) + ;; XEmacs change: + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'gdbsrc-reset nil t)) + (error "Cannot determine current-gdb-buffer")) +;;; (set-process-filter +;;; (get-buffer-process current-gdb-buffer) 'gdbsrc-mode-filter) +;;; (set-process-sentinel +;;; (get-buffer-process current-gdb-buffer) 'gdbsrc-mode-sentinel) + ;; gdbsrc-global-mode was set to t here but that tended to piss + ;; people off + (setq gdbsrc-global-mode nil + gdbsrc-active-p t + gdbsrc-call-p nil + gdbsrc-mode nil) + (message "Gbd source mode active")) + +(add-hook 'gdb-mode-hook 'gdbsrc-global-mode) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Gdb Source minor mode. +;;; + +(defvar gdbsrc-associated-buffer nil + "The gdb buffer to send commands to.") +(defvar gdbsrc-initial-readonly 'undefined + "read-only status of buffer when not in gdbsrc-mode") +(defvar gdbsrc-old-toolbar nil + "saved toolbar for buffer") + +(defun gdbsrc-mode (arg &optional quiet) + "Minor mode for interacting with gdb from a c source file. +With arg, turn gdbsrc-mode on iff arg is positive. In gdbsrc-mode, +you may send an associated gdb buffer commands from the current buffer +containing c source code." + (interactive "P") + (setq gdbsrc-mode + (if (null arg) + (not gdbsrc-mode) + (> (prefix-numeric-value arg) 0))) + + (cond (gdbsrc-mode + (cond ((not (local-variable-p 'gdbsrc-initial-readonly (current-buffer))) + (set (make-local-variable 'gdbsrc-initial-readonly) + buffer-read-only) + (set (make-local-variable 'gdbsrc-associated-buffer) + current-gdb-buffer) + (if (featurep 'toolbar) + (set (make-local-variable 'gdbsrc-old-toolbar) + (specifier-specs default-toolbar (current-buffer)))) + ) + ) + (if (featurep 'toolbar) + (set-specifier default-toolbar (cons (current-buffer) + gdbsrc-toolbar))) + (setq buffer-read-only t) + (or quiet (message "Entering gdbsrc-mode..."))) + (t + (and (local-variable-p 'gdbsrc-initial-readonly (current-buffer)) + (progn + (if (featurep 'toolbar) + (if gdbsrc-old-toolbar + (set-specifier default-toolbar + (cons (current-buffer) + gdbsrc-old-toolbar)) + (remove-specifier default-toolbar (current-buffer)))) + (kill-local-variable 'gdbsrc-old-toolbar) + (setq buffer-read-only gdbsrc-initial-readonly) + (kill-local-variable 'gdbsrc-initial-readonly) + (kill-local-variable 'gdbsrc-associated-buffer) + )) + (or quiet (message "Exiting gdbsrc-mode...")))) + (redraw-modeline t)) + +;; +;; Sends commands to gdb process. + +(defun gdb-call-from-src (command) + "Send associated gdb process COMMAND displaying source in this window." + (setq gdbsrc-call-p t) + (let ((buf (or gdbsrc-associated-buffer current-gdb-buffer))) + (or (buffer-name buf) + (error "GDB buffer deleted")) + (pop-to-buffer buf)) + (goto-char (point-max)) + (beginning-of-line) + ;; Go past gdb prompt + (re-search-forward + gdb-prompt-pattern (save-excursion (end-of-line) (point)) t) + ;; Delete any not-supposed-to-be-there text + (delete-region (point) (point-max)) + (insert command) + (comint-send-input)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Define Commands for GDB SRC Mode Buffer +;;; + +;;; ;; #### - move elsewhere +(or (fboundp 'event-buffer) + (defun event-buffer (event) + "Return buffer assocaited with EVENT, or nil." + (let ((win (event-window event))) + (and win (window-buffer win))))) + +(defun set-gdbsrc-mode-motion-extent (st en action) + ;; by Stig@hackvan.com + (let ((ex (make-extent st en))) + (set-extent-face ex 'highlight) + (set-extent-property ex 'gdbsrc t) + (set-extent-property ex 'action action) + (setq mode-motion-extent ex))) + +(defun nuke-mode-motion-extent () + ;; by Stig@hackvan.com + (cond (mode-motion-extent + (delete-extent mode-motion-extent) + (setq mode-motion-extent nil)))) + +(defun looking-at-any (regex-list) + ;; by Stig@hackvan.com + (catch 'found + (while regex-list + (and (looking-at (car regex-list)) + (throw 'found t)) + (setq regex-list (cdr regex-list))))) + +(defconst gdb-breakpoint-patterns + '( + ;; when execution stops... + ;;Breakpoint 1, XlwMenuRedisplay (w=0x4d2e00, ev=0xefffe3f8, region=0x580e60) + ;; at /net/stig/src/xemacs/lwlib/xlwmenu.c:2518 + "^[BW][ra][et][ac][kh]point [0-9]+, .*\\(\n\\s .*\\)*" + ;; output of the breakpoint command: + ;;Breakpoint 1 at 0x19f5c8: file /net/stig/src/xemacs/lwlib/xlwmenu.c, line 2715. + "^[BW][ra][et][ac][kh]point [0-9]+ at .*: file \\([^ ,\n]+\\), line \\([0-9]+\\)." + ;;Num Type Disp Enb Address What + ;;1 breakpoint keep y 0x0019ee60 in XlwMenuRedisplay + ;; at /net/stig/src/xemacs/lwlib/xlwmenu.c:2518 + "^[0-9]+\\s +[bw][ra][et][ac][kh]point.* in .*\\(\n\\s +\\)?at [^ :\n]+:[0-9]+\\(\n\\s .*\\)*" + ) + "list of patterns to match gdb's various ways of displaying a breakpoint") + +(defun gdbsrc-make-breakpoint-action (string) + ;; by Stig@hackvan.com + (if (or (string-match "file \\([^ ,\n]+\\), line \\([0-9]+\\)" string) + (string-match "at \\([^ :\n]+\\):\\([0-9]+\\)" string)) + (list 'gdbsrc-display + (match-string 1 string) + (string-to-int (match-string 2 string))))) + +(defconst gdb-stack-frame-pattern + ;;#9 0x62f08 in emacs_Xt_next_event (emacs_event=0x4cf804) + ;; at /net/stig/src/xemacs/src/event-Xt.c:1778 + "^#\\([0-9]+\\)\\s +\\(0x[0-9a-f]+ in .*\\|.*\\sw+.* (.*) at .*\\)\\(\n\\s .*\\)*" + "matches the first line of a gdb stack frame and all continuation lines. +subex 1 is frame number.") + +(defun gdbsrc-mode-motion (ee) + ;; by Stig@hackvan.com + (save-excursion + (set-buffer (event-buffer ee)) + (save-excursion + (if (not (event-point ee)) + (nuke-mode-motion-extent) + (goto-char (event-point ee)) + (beginning-of-line) + (while (and (not (bobp)) (eq ? (char-syntax (following-char)))) + (forward-line -1)) + (if (extent-at (point) (current-buffer) 'gdbsrc) + nil + (nuke-mode-motion-extent) + (cond ((looking-at-any gdb-breakpoint-patterns) + (set-gdbsrc-mode-motion-extent + (match-beginning 0) + (match-end 0) + (gdbsrc-make-breakpoint-action (match-string 0)))) + ((looking-at gdb-stack-frame-pattern) + (set-gdbsrc-mode-motion-extent + (match-beginning 0) + (match-end 0) + (list 'gdbsrc-frame + (string-to-int (match-string 1))))) + ))) + ))) + +(defun gdbsrc-display (file line) + ;; by Stig@hackvan.com + (select-window (display-buffer (find-file-noselect file))) + (goto-line line)) + +(defun click-inside-selection-p (click) + (or (click-inside-extent-p click primary-selection-extent) + (click-inside-extent-p click zmacs-region-extent) + )) + +(defun click-inside-extent-p (click extent) + "Returns non-nil if the button event is within the bounds of the primary +selection-extent, nil otherwise." + ;; stig@hackvan.com + (let ((ewin (event-window click)) + (epnt (event-point click))) + (and ewin + epnt + extent + (eq (window-buffer ewin) + (extent-buffer extent)) + (extent-start-position extent) + (> epnt (extent-start-position extent)) + (> (extent-end-position extent) epnt)))) + +(defun point-inside-extent-p (extent) + "Returns non-nil if the point is within or just after the bounds of the +primary selection-extent, nil otherwise." + ;; stig@hackvan.com + (and extent ; FIXME - I'm such a sinner... + (eq (current-buffer) + (extent-buffer extent)) + (> (point) (extent-start-position extent)) + (>= (extent-end-position extent) (point)))) + +(defun gdbsrc-select-or-yank (ee) + ;; by Stig@hackvan.com + (interactive "e") + (let ((action (save-excursion + (set-buffer (event-buffer ee)) + (and mode-motion-extent + (click-inside-extent-p ee mode-motion-extent) + (extent-property mode-motion-extent 'action))) + )) + (if action + (eval action) + (mouse-yank ee)))) + +(defvar gdb-print-format "" + "Set this variable to a valid format string to print c-sexps in a +different way (hex,octal, etc).") + +(defun gdb-print-c-sexp () + "Find the nearest c-mode sexp. Send it to gdb with print command." + (interactive) + (let* ((tag (find-c-sexp)) + (command (concat "print " gdb-print-format tag))) + (gdb-call-from-src command))) + +(defun gdb-*print-c-sexp () + "Find the nearest c-mode sexp. Send it to gdb with the print * command." + (interactive) + (let* ((tag (find-c-sexp)) + (command (concat "print " gdb-print-format "*" tag))) + (gdb-call-from-src command))) + +(defun gdb-whatis-c-sexp () + "Find the nearest c-mode sexp. Send it to gdb with the whatis command. " + (interactive) + (let* ((tag (gdbsrc-selection-or-sexp)) + (command (concat "whatis " tag))) + (gdb-call-from-src command))) + +(defun gdbsrc-goto-gdb () + "Hop back and forth between the gdb interaction buffer and the gdb source +buffer. " + ;; by Stig@hackvan.com + (interactive) + (let ((gbuf (or gdbsrc-associated-buffer current-gdb-buffer))) + (cond ((eq (current-buffer) gbuf) + (and gdb-arrow-extent + (extent-buffer gdb-arrow-extent) + (progn (pop-to-buffer (extent-buffer gdb-arrow-extent)) + (goto-char (extent-start-position gdb-arrow-extent))))) + ((buffer-name gbuf) (pop-to-buffer gbuf)) + ((y-or-n-p "No debugger. Start a new one? ") + (call-interactively 'gdbsrc)) + (t (error "No gdb buffer.")) + ))) + +(defvar gdbsrc-last-src-buffer nil) + +(defun gdbsrc-goto-src () + (interactive) + (let* ((valid (and gdbsrc-last-src-buffer + (memq gdbsrc-last-src-buffer (buffer-list)))) + (win (and valid + (get-buffer-window gdbsrc-last-src-buffer)))) + (cond (win (select-window win)) + (valid (pop-to-buffer gdbsrc-last-src-buffer))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; The following functions are used to extract the closest surrounding +;;; c expression from point +;;; +(defun back-sexp () + "Version of backward-sexp that catches errors" + (condition-case nil + (backward-sexp) + (error t))) + +(defun forw-sexp () + "Version of forward-sexp that catches errors" + (condition-case nil + (forward-sexp) + (error t))) + +(defun sexp-compound-sep (span-start span-end) + "Returns '.' for '->' & '.', returns ' ' for white space, +returns '?' for other puctuation" + (let ((result ? ) + (syntax)) + (while (< span-start span-end) + (setq syntax (char-syntax (char-after span-start))) + (cond + ((= syntax ? ) t) + ((= syntax ?.) (setq syntax (char-after span-start)) + (cond + ((= syntax ?.) (setq result ?.)) + ((and (= syntax ?-) (= (char-after (+ span-start 1)) ?>)) + (setq result ?.) + (setq span-start (+ span-start 1))) + (t (setq span-start span-end) + (setq result ??))))) + (setq span-start (+ span-start 1))) + result + ) + ) + +(defun sexp-compound (first second) + "Returns non-nil if the concatenation of two S-EXPs result in a Single C +token. The two S-EXPs are represented as a cons cells, where the car +specifies the point in the current buffer that marks the begging of the +S-EXP and the cdr specifies the character after the end of the S-EXP +Link S-Exps of the form: + Sexp -> SexpC + Sexp . Sexp + Sexp (Sexp) Maybe exclude if first Sexp is: if, while, do, for, switch + Sexp [Sexp] + (Sexp) Sexp + [Sexp] Sexp" + (let ((span-start (cdr first)) + (span-end (car second)) + (syntax)) + (setq syntax (sexp-compound-sep span-start span-end)) + (cond + ((= (car first) (car second)) nil) + ((= (cdr first) (cdr second)) nil) + ((= syntax ?.) t) + ((= syntax ? ) + (setq span-start (char-after (- span-start 1))) + (setq span-end (char-after span-end)) + (cond + ((= span-start ?) ) t ) + ((= span-start ?] ) t ) + ((= span-end ?( ) t ) + ((= span-end ?[ ) t ) + (t nil)) + ) + (t nil)) + ) + ) + +(defun sexp-cur () + "Returns the S-EXP that Point is a member, Point is set to begging of S-EXP. +The S-EXPs is represented as a cons cell, where the car specifies the point in +the current buffer that marks the begging of the S-EXP and the cdr specifies +the character after the end of the S-EXP" + (let ((p (point)) (begin) (end)) + (back-sexp) + (setq begin (point)) + (forw-sexp) + (setq end (point)) + (if (>= p end) + (progn + (setq begin p) + (goto-char p) + (forw-sexp) + (setq end (point)) + ) + ) + (goto-char begin) + (cons begin end) + ) + ) + +(defun sexp-prev () + "Returns the previous S-EXP, Point is set to begging of that S-EXP. +The S-EXPs is represented as a cons cell, where the car specifies the point in +the current buffer that marks the begging of the S-EXP and the cdr specifies +the character after the end of the S-EXP" + (let ((begin) (end)) + (back-sexp) + (setq begin (point)) + (forw-sexp) + (setq end (point)) + (goto-char begin) + (cons begin end)) +) + +(defun sexp-next () + "Returns the following S-EXP, Point is set to begging of that S-EXP. +The S-EXPs is represented as a cons cell, where the car specifies the point in +the current buffer that marks the begging of the S-EXP and the cdr specifies +the character after the end of the S-EXP" + (let ((begin) (end)) + (forw-sexp) + (forw-sexp) + (setq end (point)) + (back-sexp) + (setq begin (point)) + (cons begin end) + ) + ) + +(defun find-c-sexp () + "Returns the Complex S-EXP that surrounds Point" + (interactive) + (save-excursion + (let ((p) (sexp) (test-sexp)) + (setq p (point)) + (setq sexp (sexp-cur)) + (setq test-sexp (sexp-prev)) + (while (sexp-compound test-sexp sexp) + (setq sexp (cons (car test-sexp) (cdr sexp))) + (goto-char (car sexp)) + (setq test-sexp (sexp-prev)) + ) + (goto-char p) + (setq test-sexp (sexp-next)) + (while (sexp-compound sexp test-sexp) + (setq sexp (cons (car sexp) (cdr test-sexp))) + (setq test-sexp (sexp-next)) + ) + (buffer-substring (car sexp) (cdr sexp)) + ) + ) + ) + +(defun gdbsrc-selection-or-sexp (&optional ee) + ;; FIXME - fix this docstring + "If the EVENT is within the primary selection, then return the selected +text, otherwise parse the expression at the point of the mouse click and +return that. If EVENT is nil, then return the C sexp at point." + ;; stig@hackvan.com + (cond ((or (and ee (click-inside-selection-p ee)) + (and (not ee) (point-inside-selection-p))) + (replace-in-string (extent-string primary-selection-extent) "\n\\s *" " ")) + (ee + (gdbsrc-get-csexp-at-click ee)) + (t + (find-c-sexp)) + )) + +(defun gdbsrc-get-csexp-at-click (ee) + "Returns the containing s-expression located at the mouse cursor to point." + ;; " + ;; by Stig@hackvan.com + (let ((ewin (event-window ee)) + (epnt (event-point ee))) + (or (and ewin epnt) + (error "Must click within a window")) + (save-excursion + (set-buffer (window-buffer ewin)) + (save-excursion + (goto-char epnt) + (find-c-sexp))))) + +(defun gdbsrc-print-csexp (&optional ee) + (interactive) + (or ee (setq ee current-mouse-event)) + (gdb-call-from-src + (concat "print " gdb-print-format (gdbsrc-selection-or-sexp ee)))) + +(defun gdbsrc-*print-csexp (&optional ee) + (interactive) + (or ee (setq ee current-mouse-event)) + (gdb-call-from-src + (concat "print *" gdb-print-format (gdbsrc-selection-or-sexp ee)))) + +;; (defun gdbsrc-print-region (arg) +;; (let (( command (concat "print " gdb-print-format (x-get-cut-buffer)))) +;; (gdb-call-from-src command))) +;; +;; (defun gdbsrc-*print-region (arg) +;; (let (( command (concat "print *" gdb-print-format (x-get-cut-buffer)))) +;; (gdb-call-from-src command))) + +(defun gdbsrc-file:lno () + "returns \"file:lno\" specification for location of point. " + ;; by Stig@hackvan.com + (format "%s:%d" + (file-name-nondirectory buffer-file-name) + (save-restriction + (widen) + (1+ (count-lines (point-min) + (save-excursion (beginning-of-line) (point))))) + )) + +(defun gdbsrc-set-break (ee) + "Sets a breakpoint. Click on the selection and it will set a breakpoint +using the selected text. Click anywhere in a source file, and it will set +a breakpoint at that line number of that file." + ;; by Stig@hackvan.com + ;; there is already gdb-break, so this only needs to work with mouse clicks. + (interactive "e") + (gdb-call-from-src + (concat "break " + (if (click-inside-selection-p ee) + (extent-string primary-selection-extent) + (mouse-set-point ee) + (or buffer-file-name (error "No file in window")) + (gdbsrc-file:lno) + )))) + +(defun gdbsrc-set-tbreak-continue (&optional ee) + "Set a temporary breakpoint at the position of the mouse click and then +continues. This can be bound to either a key or a mouse button." + ;; by Stig@hackvan.com + (interactive) + (or ee (setq ee current-mouse-event)) + (and ee (mouse-set-point ee)) + (gdb-call-from-src (concat "tbreak " (gdbsrc-file:lno))) + (gdb-call-from-src "c")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Functions extended from gdb.el for gdbsrc. +;; +;; gdbsrc-set-buffer - added a check to set buffer to gdbsrc-associated-buffer +;; to handle multiple gdb sessions being driven from src +;; files. + +(require 'advice) + +(defadvice gdb-set-buffer (after gdbsrc activate) ; () + "Advised to work from a source buffer instead of just the gdb buffer." + ;; by Stig@hackvan.com + ;; the operations below have tests which are disjoint from the tests in + ;; the original `gdb-set-buffer'. Current-gdb-buffer cannot be set twice. + (and gdbsrc-call-p + gdbsrc-associated-buffer + (setq current-gdb-buffer gdbsrc-associated-buffer))) + +(defadvice gdb-display-line (around gdbsrc activate) + ;; (true-file line &optional select-method) + "Advised to select the source buffer instead of the gdb-buffer" + ;; by Stig@hackvan.com + (ad-set-arg 2 'source) ; tell it not to select the gdb window + ad-do-it + (save-excursion + (let* ((buf (extent-buffer gdb-arrow-extent)) + (win (get-buffer-window buf))) + (setq gdbsrc-last-src-buffer buf) + (select-window win) + (set-window-point win (extent-start-position gdb-arrow-extent)) + (set-buffer buf)) + (and gdbsrc-active-p + (not gdbsrc-mode) + (not (eq (current-buffer) current-gdb-buffer)) + (gdbsrc-mode 1)))) + +(defadvice gdb-filter (after gdbsrc activate) ; (proc string) + ;; by Stig@hackvan.com + ;; if we got a gdb prompt and it wasn't a gdbsrc command, then it's gdb + ;; hitting a breakpoint or having a core dump, so bounce back to the gdb + ;; window. + (let* ((selbuf (window-buffer (selected-window))) + win) + ;; if we're at a gdb prompt, then display the buffer + (and (save-match-data (string-match gdb-prompt-pattern (ad-get-arg 1))) + (prog1 + (not gdbsrc-call-p) + (setq gdbsrc-call-p nil)) + (setq win (display-buffer current-gdb-buffer)) + ;; if we're not in either the source buffer or the gdb buffer, + ;; then select the window too... + (not (eq selbuf current-gdb-buffer)) + (not (eq selbuf gdbsrc-last-src-buffer)) + (progn + (ding nil 'warp) + (select-window win))) + )) + +(defun gdbsrc-reset () + ;; tidy house and turn off gdbsrc-mode in all buffers + ;; by Stig@hackvan.com + (gdb-delete-arrow-extent) + (setq gdbsrc-global-mode nil) + (mapcar #'(lambda (buffer) + (set-buffer buffer) + (cond ((eq gdbsrc-associated-buffer current-gdb-buffer) + (gdbsrc-mode -1)))) + (buffer-list))) + +(defadvice gdb-sentinel (after gdbsrc freeze) ; (proc msg) + ;; by Stig@hackvan.com + (gdbsrc-reset) + (message "Gdbsrc finished")) + +(provide 'gdbsrc)