sdcc/debugger/mcs51/sdcdbsrc.el

   1 ;;; sdcdbsrc.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 ;; Copyright (C) 1999 Sandeep Dutta <sandeep.dutta@usa.net>
  11 ;;
  12 ;; This file is part of XEmacs.
  13 ;;
  14 ;; XEmacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2 of the License, or
  17 ;; (at your option) any later version.
  18 ;;
  19 ;; XEmacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23 ;;
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with XEmacs; if not, write to the Free Software
  26 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  27
  28 ;; Based upon code for version18 by Debra Ayers <ayers@austin.ibm.com>
  29
  30 ;;;  SDCDBSRC::
  31 ;;;  Sdcdbsrc extends the emacs SDCDB interface to accept sdcdb commands issued
  32 ;;;  from the source code buffer.  Sdcdbsrc behaves similar to sdcdb except
  33 ;;;  now most debugging may be done from the source code using the *sdcdb*
  34 ;;;  buffer to view output. Supports a point and click model under X to
  35 ;;;  evaluate source code expressions (no more typing long variable names).
  36 ;;;
  37 ;;; Supports C source at the moment but C++ support will be added if there
  38 ;;; is sufficient interest.
  39 ;;;
  40
  41 ;; SDCDBSRC::Sdcdb Source Mode Interface description.
  42 ;; Sdcdbsrc extends the emacs SDCDB interface to accept sdcdb commands issued
  43 ;; from the source code buffer. Sdcdbsrc behaves similar to sdcdb except now all
  44 ;; debugging may be done from the currently focused source buffer using
  45 ;; the *sdcdb* buffer to view output.
  46
  47 ;; When source files are displayed through sdcdbsrc, buffers are put in
  48 ;; sdcdbsrc-mode minor mode. This mode puts the buffer in read-only state
  49 ;; and sets up a special key and mouse map to invoke communication with
  50 ;; the current sdcdb process. The minor mode may be toggled on/off as needed.
  51 ;; (ESC-T)
  52
  53 ;; C-expressions may be evaluated by sdcdbsrc by simply pointing at text in the
  54 ;; current source buffer with the mouse or by centering the cursor over text
  55 ;; and typing a single key command. ('p' for print, '*' for print *).
  56
  57 ;; As code is debugged and new buffers are displayed, the focus of sdcdbsrc
  58 ;; follows to each new source buffer. Makes debugging fun. (sound like a
  59 ;; commercial or what!)
  60 ;;
  61
  62 ;; Current Listing ::
  63 ;;key           binding                                 Comment
  64 ;;---           -------                                 -------
  65 ;;
  66 ;; r               sdcdb-return-from-src        SDCDB return command
  67 ;; n               sdcdb-next-from-src  SDCDB next command
  68 ;; b               sdcdb-back-from-src  SDCDB back command
  69 ;; w               sdcdb-where-from-src SDCDB where command
  70 ;; f               sdcdb-finish-from-src        SDCDB finish command
  71 ;; u               sdcdb-up-from-src      SDCDB up command
  72 ;; d               sdcdb-down-from-src  SDCDB down command
  73 ;; c               sdcdb-cont-from-src  SDCDB continue command
  74 ;; i               sdcdb-stepi-from-src SDCDB step instruction command
  75 ;; s               sdcdb-step-from-src  SDCDB step command
  76 ;; ?               sdcdb-whatis-c-sexp  SDCDB whatis command for data at
  77 ;;                                           buffer point
  78 ;; x               sdcdbsrc-delete        SDCDB Delete all breakpoints if no arg
  79 ;;                                           given or delete arg (C-u arg x)
  80 ;; m               sdcdbsrc-frame         SDCDB Display current frame if no arg,
  81 ;;                                           given or display frame arg
  82 ;; *               sdcdb-*print-c-sexp  SDCDB print * command for data at
  83 ;;                                             buffer point
  84 ;; !               sdcdbsrc-goto-sdcdb          Goto the SDCDB output buffer
  85 ;; p               sdcdb-print-c-sexp   SDCDB print * command for data at
  86 ;;                                           buffer point
  87 ;; g               sdcdbsrc-goto-sdcdb          Goto the SDCDB output buffer
  88 ;; t               sdcdbsrc-mode                Toggles Sdcdbsrc mode (turns it off)
  89 ;;
  90 ;; C-c C-f         sdcdb-finish-from-src        SDCDB finish command
  91 ;;
  92 ;; C-x SPC         sdcdb-break          Set break for line with point
  93 ;; ESC t           sdcdbsrc-mode                Toggle Sdcdbsrc mode
  94 ;; ESC m           sdcdbsrc-srcmode             Toggle list mode
  95 ;;
  96 ;; Local Bindings for buffer when you exit Sdcdbsrc minor mode
  97 ;;
  98 ;; C-x SPC         sdcdb-break          Set break for line with point
  99 ;; ESC t           sdcdbsrc-mode                Toggle Sdcdbsrc mode
 100 ;;
 101
 102 ;;; (eval-when-compile
 103 ;;;   (or noninteractive
 104 ;;;       (progn
 105 ;;;         (message "ONLY compile sdcdbsrc except with -batch because of advice")
 106 ;;;         (ding)
 107 ;;;       )))
 108 ;;; sdcdb.el --- run sdcdb under Emacs
 109
 110 ;; Author: W. Schelter, University of Texas
 111 ;;     wfs@rascal.ics.utexas.edu
 112 ;; Rewritten by rms.
 113 ;; Keywords: c, unix, tools, debugging
 114
 115 ;; Some ideas are due to Masanobu.
 116
 117 ;; This file is part of XEmacs.
 118
 119 ;; XEmacs is free software; you can redistribute it and/or modify it
 120 ;; under the terms of the GNU General Public License as published by
 121 ;; the Free Software Foundation; either version 2, or (at your option)
 122 ;; any later version.
 123
 124 ;; XEmacs is distributed in the hope that it will be useful, but
 125 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 126 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 127 ;; General Public License for more details.
 128
 129 ;; You should have received a copy of the GNU General Public License
 130 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
 131 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 132 ;; 02111-1307, USA.
 133
 134 ;;; Synched up with: Not in FSF
 135
 136 ;;; Commentary:
 137
 138 ;; Description of SDCDB interface:
 139
 140 ;; A facility is provided for the simultaneous display of the source code
 141 ;; in one window, while using sdcdb to step through a function in the
 142 ;; other.  A small arrow in the source window, indicates the current
 143 ;; line.
 144
 145 ;; Starting up:
 146
 147 ;; In order to use this facility, invoke the command SDCDB to obtain a
 148 ;; shell window with the appropriate command bindings.  You will be asked
 149 ;; for the name of a file to run.  Sdcdb will be invoked on this file, in a
 150 ;; window named *sdcdb-foo* if the file is foo.
 151
 152 ;; M-s steps by one line, and redisplays the source file and line.
 153
 154 ;; You may easily create additional commands and bindings to interact
 155 ;; with the display.  For example to put the sdcdb command next on \M-n
 156 ;; (def-sdcdb next "\M-n")
 157
 158 ;; This causes the emacs command sdcdb-next to be defined, and runs
 159 ;; sdcdb-display-frame after the command.
 160
 161 ;; sdcdb-display-frame is the basic display function.  It tries to display
 162 ;; in the other window, the file and line corresponding to the current
 163 ;; position in the sdcdb window.  For example after a sdcdb-step, it would
 164 ;; display the line corresponding to the position for the last step.  Or
 165 ;; if you have done a backtrace in the sdcdb buffer, and move the cursor
 166 ;; into one of the frames, it would display the position corresponding to
 167 ;; that frame.
 168
 169 ;; sdcdb-display-frame is invoked automatically when a filename-and-line-number
 170 ;; appears in the output.
 171
 172 ;;; Code:
 173
 174 (require 'comint)
 175 (require 'shell)
 176
 177 (condition-case nil
 178     (if (featurep 'toolbar)
 179         (require 'eos-toolbar "sun-eos-toolbar"))
 180   (error nil))
 181
 182 (defvar sdcdb-last-frame)
 183 (defvar sdcdb-delete-prompt-marker)
 184 (defvar sdcdb-filter-accumulator)
 185 (defvar sdcdb-last-frame-displayed-p)
 186 (defvar sdcdb-arrow-extent nil)
 187 (or (fboundp 'make-glyph) (fset 'make-glyph 'identity)) ; work w/ pre beta v12
 188 (defvar sdcdb-arrow-glyph (make-glyph "=>"))
 189
 190 (make-face 'sdcdb-arrow-face)
 191 (or (face-differs-from-default-p 'sdcdb-arrow-face)
 192    ;; Usually has a better default value than highlight does
 193    (copy-face 'isearch 'sdcdb-arrow-face))
 194
 195 ;; Hooks can side-effect extent arg to change extent properties
 196 (defvar sdcdb-arrow-extent-hooks '())
 197
 198 (defvar sdcdb-prompt-pattern "^>\\|^(.*sdcdb[+]?) *\\|^---Type <return> to.*--- *"
 199   "A regexp to recognize the prompt for sdcdb or sdcdb+.")
 200
 201 (defvar sdcdb-mode-map nil
 202   "Keymap for sdcdb-mode.")
 203
 204 (defvar sdcdb-toolbar nil)
 205
 206 (if sdcdb-mode-map
 207    nil
 208   (setq sdcdb-mode-map (make-sparse-keymap))
 209   (set-keymap-name sdcdb-mode-map 'sdcdb-mode-map)
 210   (set-keymap-parents sdcdb-mode-map (list comint-mode-map))
 211   (define-key sdcdb-mode-map "\C-l" 'sdcdb-refresh)
 212   (define-key sdcdb-mode-map "\C-c\C-c" 'sdcdb-control-c-subjob)
 213   (define-key sdcdb-mode-map "\t" 'comint-dynamic-complete)
 214   (define-key sdcdb-mode-map "\M-?" 'comint-dynamic-list-completions))
 215
 216 (define-key ctl-x-map " " 'sdcdb-break)
 217 (define-key ctl-x-map "&" 'send-sdcdb-command)
 218
 219 ;;Of course you may use `def-sdcdb' with any other sdcdb command, including
 220 ;;user defined ones.
 221
 222 (defmacro def-sdcdb (name key &optional doc &rest forms)
 223   (let* ((fun (intern (format "sdcdb-%s" name)))
 224          (cstr (list 'if '(not (= 1 arg))
 225                      (list 'format "%s %s" name 'arg)
 226                      name)))
 227     (list 'progn
 228           (nconc (list 'defun fun '(arg)
 229                        (or doc "")
 230                        '(interactive "p")
 231                        (list 'sdcdb-call cstr))
 232                  forms)
 233           (and key (list 'define-key 'sdcdb-mode-map key  (list 'quote fun))))))
 234
 235 (def-sdcdb "step"   "\M-s" "Step one source line with display"
 236   (sdcdb-delete-arrow-extent))
 237 (def-sdcdb "stepi"  "\M-i" "Step one instruction with display"
 238   (sdcdb-delete-arrow-extent))
 239 (def-sdcdb "finish" "\C-c\C-f" "Finish executing current function"
 240   (sdcdb-delete-arrow-extent))
 241 (def-sdcdb "run" nil "Run the current program"
 242   (sdcdb-delete-arrow-extent))
 243
 244 ;;"next" and "cont" were bound to M-n and M-c in Emacs 18, but these are
 245 ;;poor choices, since M-n is used for history navigation and M-c is
 246 ;;capitalize-word.  These are defined without key bindings so that users
 247 ;;may choose their own bindings.
 248 (def-sdcdb "next"   "\C-c\C-n" "Step one source line (skip functions)"
 249   (sdcdb-delete-arrow-extent))
 250 (def-sdcdb "cont"   "\C-c\M-c" "Proceed with the program"
 251   (sdcdb-delete-arrow-extent))
 252
 253 (def-sdcdb "up"     "\C-c<" "Go up N stack frames (numeric arg) with display")
 254 (def-sdcdb "down"   "\C-c>" "Go down N stack frames (numeric arg) with display")
 255
 256 (defvar sdcdb-display-mode nil
 257   "Minor mode for sdcdb frame display")
 258 (or (assq 'sdcdb-display-mode minor-mode-alist)
 259     (setq minor-mode-alist
 260           (purecopy
 261            (append minor-mode-alist
 262                    '((sdcdb-display-mode " Frame"))))))
 263 \f
 264 (defun sdcdb-display-mode (&optional arg)
 265   "Toggle SDCDB Frame display mode
 266 With arg, turn display mode on if and only if arg is positive.
 267 In the display minor mode, source file are displayed in another
 268 window for repective \\[sdcdb-display-frame] commands."
 269   (interactive "P")
 270   (setq sdcdb-display-mode (if (null arg)
 271                              (not sdcdb-display-mode)
 272                            (> (prefix-numeric-value arg) 0))))
 273
 274 ;; Using cc-mode's syntax table is broken.
 275 (defvar sdcdb-mode-syntax-table nil
 276   "Syntax table for SDCDB mode.")
 277
 278 ;; This is adapted from CC Mode 5.11.
 279 (unless sdcdb-mode-syntax-table
 280   (setq sdcdb-mode-syntax-table (make-syntax-table))
 281   ;; DO NOT TRY TO SET _ (UNDERSCORE) TO WORD CLASS!
 282   (modify-syntax-entry ?_  "_" sdcdb-mode-syntax-table)
 283   (modify-syntax-entry ?\\ "\\" sdcdb-mode-syntax-table)
 284   (modify-syntax-entry ?+  "." sdcdb-mode-syntax-table)
 285   (modify-syntax-entry ?-  "." sdcdb-mode-syntax-table)
 286   (modify-syntax-entry ?=  "." sdcdb-mode-syntax-table)
 287   (modify-syntax-entry ?%  "." sdcdb-mode-syntax-table)
 288   (modify-syntax-entry ?<  "." sdcdb-mode-syntax-table)
 289   (modify-syntax-entry ?>  "." sdcdb-mode-syntax-table)
 290   (modify-syntax-entry ?&  "." sdcdb-mode-syntax-table)
 291   (modify-syntax-entry ?|  "." sdcdb-mode-syntax-table)
 292   (modify-syntax-entry ?\' "\"" sdcdb-mode-syntax-table)
 293   ;; add extra comment syntax
 294   (modify-syntax-entry ?/  ". 14"  sdcdb-mode-syntax-table)
 295   (modify-syntax-entry ?*  ". 23"  sdcdb-mode-syntax-table))
 296
 297 \f
 298 (defun sdcdb-mode ()
 299   "Major mode for interacting with an inferior Sdcdb process.
 300 The following commands are available:
 301
 302 \\{sdcdb-mode-map}
 303
 304 \\[sdcdb-display-frame] displays in the other window
 305 the last line referred to in the sdcdb buffer. See also
 306 \\[sdcdb-display-mode].
 307
 308 \\[sdcdb-step],\\[sdcdb-next], and \\[sdcdb-nexti] in the sdcdb window,
 309 call sdcdb to step,next or nexti and then update the other window
 310 with the current file and position.
 311
 312 If you are in a source file, you may select a point to break
 313 at, by doing \\[sdcdb-break].
 314
 315 Commands:
 316 Many commands are inherited from comint mode.
 317 Additionally we have:
 318
 319 \\[sdcdb-display-frame] display frames file in other window
 320 \\[sdcdb-step] advance one line in program
 321 \\[send-sdcdb-command] used for special printing of an arg at the current point.
 322 C-x SPACE sets break point at current line."
 323   (interactive)
 324   (comint-mode)
 325   (use-local-map sdcdb-mode-map)
 326   (set-syntax-table sdcdb-mode-syntax-table)
 327   (make-local-variable 'sdcdb-last-frame-displayed-p)
 328   (make-local-variable 'sdcdb-last-frame)
 329   (make-local-variable 'sdcdb-delete-prompt-marker)
 330   (make-local-variable 'sdcdb-display-mode)
 331   (make-local-variable' sdcdb-filter-accumulator)
 332   (setq sdcdb-last-frame nil
 333         sdcdb-delete-prompt-marker nil
 334         sdcdb-filter-accumulator nil
 335         sdcdb-display-mode t
 336         major-mode 'sdcdb-mode
 337         mode-name "Inferior SDCDB"
 338         comint-prompt-regexp sdcdb-prompt-pattern
 339         sdcdb-last-frame-displayed-p t)
 340   (set (make-local-variable 'shell-dirtrackp) t)
 341   ;;(make-local-variable 'sdcdb-arrow-extent)
 342   (and (extentp sdcdb-arrow-extent)
 343        (delete-extent sdcdb-arrow-extent))
 344   (setq sdcdb-arrow-extent nil)
 345   ;; XEmacs change:
 346   (make-local-hook 'kill-buffer-hook)
 347   (add-hook 'kill-buffer-hook 'sdcdb-delete-arrow-extent nil t)
 348   (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t)
 349   (run-hooks 'sdcdb-mode-hook))
 350
 351 (defun sdcdb-delete-arrow-extent ()
 352   (let ((inhibit-quit t))
 353     (if sdcdb-arrow-extent
 354         (delete-extent sdcdb-arrow-extent))
 355     (setq sdcdb-arrow-extent nil)))
 356
 357 (defvar current-sdcdb-buffer nil)
 358
 359 ;;;###autoload
 360 (defvar sdcdb-command-name "sdcdb"
 361   "Pathname for executing sdcdb.")
 362 ;;
 363 ;; default values should be changed as needed
 364 ;;
 365 (defvar sdcdbsrc-cpu-type "51")
 366 (defvar sdcdbsrc-frequency "11059200")
 367 (defvar sdcdbsrc-serial   nil)
 368
 369 ;;;###autoload
 370 (defun sdcdb (path &optional corefile)
 371   "Run sdcdb on program FILE in buffer *sdcdb-FILE*.
 372 The directory containing FILE becomes the initial working directory
 373 and source-file directory for SDCDB.  If you wish to change this, use
 374 the SDCDB commands `cd DIR' and `directory'."
 375   (interactive "FRun sdcdb on file: ")
 376   (setq path (file-truename (expand-file-name path)))
 377   (let ((file (file-name-nondirectory path)))
 378     (switch-to-buffer (concat "*sdcdb-" file "*"))
 379     (setq default-directory (file-name-directory path))
 380     (or (bolp) (newline))
 381     (insert "Current directory is " default-directory "\n")
 382     (apply 'make-comint
 383            (concat "sdcdb-" file)
 384            (substitute-in-file-name sdcdb-command-name)
 385            nil
 386            "-cpu"
 387            sdcdbsrc-cpu-type
 388            "-X"
 389            sdcdbsrc-frequency
 390            "-fullname"
 391            file
 392            (and corefile (list corefile)))
 393     (set-process-filter (get-buffer-process (current-buffer)) 'sdcdb-filter)
 394     (set-process-sentinel (get-buffer-process (current-buffer)) 'sdcdb-sentinel)
 395     ;; XEmacs change: turn on sdcdb mode after setting up the proc filters
 396     ;; for the benefit of shell-font.el
 397     (sdcdb-mode)
 398     (sdcdb-set-buffer)))
 399
 400 ;;;###autoload
 401 (defun sdcdb-with-core (file corefile)
 402   "Debug a program using a corefile."
 403   (interactive "fProgram to debug: \nfCore file to use: ")
 404   (sdcdb file corefile))
 405
 406 (defun sdcdb-set-buffer ()
 407   (cond ((eq major-mode 'sdcdb-mode)
 408          (setq current-sdcdb-buffer (current-buffer))
 409          (if (featurep 'eos-toolbar)
 410              (set-specifier default-toolbar (cons (current-buffer)
 411                                                   sdcdb-toolbar))))))
 412
 413 \f
 414 ;; This function is responsible for inserting output from SDCDB
 415 ;; into the buffer.
 416 ;; Aside from inserting the text, it notices and deletes
 417 ;; each filename-and-line-number;
 418 ;; that SDCDB prints to identify the selected frame.
 419 ;; It records the filename and line number, and maybe displays that file.
 420 (defun sdcdb-filter (proc string)
 421   (let ((inhibit-quit t))
 422     (save-current-buffer
 423      (set-buffer (process-buffer proc))
 424      (if sdcdb-filter-accumulator
 425          (sdcdb-filter-accumulate-marker
 426           proc (concat sdcdb-filter-accumulator string))
 427        (sdcdb-filter-scan-input proc string)))))
 428
 429 (defun sdcdb-filter-accumulate-marker (proc string)
 430   (setq sdcdb-filter-accumulator nil)
 431   (if (> (length string) 1)
 432       (if (= (aref string 1) ?\032)
 433           (let ((end (string-match "\n" string)))
 434             (if end
 435                 (progn
 436                   (let* ((first-colon (string-match ":" string 2))
 437                          (second-colon
 438                           (string-match ":" string (1+ first-colon))))
 439                     (setq sdcdb-last-frame
 440                           (cons (substring string 2 first-colon)
 441                                 (string-to-int
 442                                  (substring string (1+ first-colon)
 443                                             second-colon)))))
 444                   (setq sdcdb-last-frame-displayed-p nil)
 445                   (sdcdb-filter-scan-input proc
 446                                          (substring string (1+ end))))
 447               (setq sdcdb-filter-accumulator string)))
 448         (sdcdb-filter-insert proc "\032")
 449         (sdcdb-filter-scan-input proc (substring string 1)))
 450     (setq sdcdb-filter-accumulator string)))
 451
 452 (defun sdcdb-filter-scan-input (proc string)
 453   (if (equal string "")
 454       (setq sdcdb-filter-accumulator nil)
 455     (let ((start (string-match "\032" string)))
 456       (if start
 457           (progn (sdcdb-filter-insert proc (substring string 0 start))
 458                  (sdcdb-filter-accumulate-marker proc
 459                                                (substring string start)))
 460         (sdcdb-filter-insert proc string)))))
 461
 462 (defun sdcdb-filter-insert (proc string)
 463   (let ((moving (= (point) (process-mark proc)))
 464         (output-after-point (< (point) (process-mark proc))))
 465     (save-excursion
 466       ;; Insert the text, moving the process-marker.
 467       (goto-char (process-mark proc))
 468       (insert-before-markers string)
 469       (set-marker (process-mark proc) (point))
 470       (sdcdb-maybe-delete-prompt)
 471       ;; Check for a filename-and-line number.
 472       (sdcdb-display-frame
 473        ;; Don't display the specified file
 474        ;; unless (1) point is at or after the position where output appears
 475        ;; and (2) this buffer is on the screen.
 476        (or output-after-point
 477            (not (get-buffer-window (current-buffer))))
 478        ;; Display a file only when a new filename-and-line-number appears.
 479        t))
 480     (if moving (goto-char (process-mark proc))))
 481
 482   (let (s)
 483     (if (and (should-use-dialog-box-p)
 484              (setq s (or (string-match " (y or n) *\\'" string)
 485                          (string-match " (yes or no) *\\'" string))))
 486         (sdcdb-mouse-prompt-hack (substring string 0 s) (current-buffer))))
 487   )
 488
 489 (defun sdcdb-mouse-prompt-hack (prompt buffer)
 490   (popup-dialog-box
 491    (list prompt
 492          (vector "Yes"    (list 'sdcdb-mouse-prompt-hack-answer 't   buffer) t)
 493          (vector "No"     (list 'sdcdb-mouse-prompt-hack-answer 'nil buffer) t)
 494          nil
 495          (vector "Cancel" (list 'sdcdb-mouse-prompt-hack-answer 'nil buffer) t)
 496          )))
 497
 498 (defun sdcdb-mouse-prompt-hack-answer (answer buffer)
 499   (let ((b (current-buffer)))
 500     (unwind-protect
 501         (progn
 502           (set-buffer buffer)
 503           (goto-char (process-mark (get-buffer-process buffer)))
 504           (delete-region (point) (point-max))
 505           (insert (if answer "yes" "no"))
 506           (comint-send-input))
 507       (set-buffer b))))
 508
 509 (defun sdcdb-sentinel (proc msg)
 510   (cond ((null (buffer-name (process-buffer proc)))
 511          ;; buffer killed
 512          ;; Stop displaying an arrow in a source file.
 513          ;(setq overlay-arrow-position nil) -- done by kill-buffer-hook
 514          (set-process-buffer proc nil))
 515         ((memq (process-status proc) '(signal exit))
 516          ;; Stop displaying an arrow in a source file.
 517          (sdcdb-delete-arrow-extent)
 518          ;; Fix the mode line.
 519          (setq modeline-process
 520                (concat ": sdcdb " (symbol-name (process-status proc))))
 521          (let* ((obuf (current-buffer)))
 522            ;; save-excursion isn't the right thing if
 523            ;;  process-buffer is current-buffer
 524            (unwind-protect
 525                (progn
 526                  ;; Write something in *compilation* and hack its mode line,
 527                  (set-buffer (process-buffer proc))
 528                  ;; Force mode line redisplay soon
 529                  (set-buffer-modified-p (buffer-modified-p))
 530                  (if (eobp)
 531                      (insert ?\n mode-name " " msg)
 532                    (save-excursion
 533                      (goto-char (point-max))
 534                      (insert ?\n mode-name " " msg)))
 535                  ;; If buffer and mode line will show that the process
 536                  ;; is dead, we can delete it now.  Otherwise it
 537                  ;; will stay around until M-x list-processes.
 538                  (delete-process proc))
 539              ;; Restore old buffer, but don't restore old point
 540              ;; if obuf is the sdcdb buffer.
 541              (set-buffer obuf))))))
 542
 543
 544 (defun sdcdb-refresh (&optional arg)
 545   "Fix up a possibly garbled display, and redraw the arrow."
 546   (interactive "P")
 547   (recenter arg)
 548   (sdcdb-display-frame))
 549
 550 (defun sdcdb-display-frame (&optional nodisplay noauto)
 551   "Find, obey and delete the last filename-and-line marker from SDCDB.
 552 The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
 553 Obeying it means displaying in another window the specified file and line."
 554   (interactive)
 555   (sdcdb-set-buffer)
 556   (and sdcdb-last-frame (not nodisplay)
 557        sdcdb-display-mode
 558        (or (not sdcdb-last-frame-displayed-p) (not noauto))
 559        (progn (sdcdb-display-line (car sdcdb-last-frame) (cdr sdcdb-last-frame))
 560               (setq sdcdb-last-frame-displayed-p t))))
 561
 562 ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
 563 ;; and that its line LINE is visible.
 564 ;; Put the overlay-arrow on the line LINE in that buffer.
 565
 566 (defun sdcdb-display-line (true-file line &optional select-method)
 567   ;; FILE to display
 568   ;; LINE number to highlight and make visible
 569   ;; SELECT-METHOD 'source, 'debugger, or 'none.  (default is 'debugger)
 570   (and (null select-method) (setq select-method 'debugger))
 571   (let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen
 572          (pop-up-windows t)
 573          (source-buffer (find-file-noselect true-file))
 574          (source-window (display-buffer source-buffer))
 575          (debugger-window (get-buffer-window current-sdcdb-buffer))
 576          (extent sdcdb-arrow-extent)
 577          pos)
 578     ;; XEmacs change: make sure we find a window displaying the source file
 579     ;; even if we are already sitting in it when a breakpoint is hit.
 580     ;; Otherwise the t argument to display-buffer will prevent it from being
 581     ;; displayed.
 582     (save-excursion
 583       (cond ((eq select-method 'debugger)
 584              ;; might not already be displayed
 585              (setq debugger-window (display-buffer current-sdcdb-buffer))
 586              (select-window debugger-window))
 587             ((eq select-method 'source)
 588              (select-window source-window))))
 589     (and extent
 590          (not (eq (extent-object extent) source-buffer))
 591          (setq extent (delete-extent extent)))
 592     (or extent
 593         (progn
 594           (setq extent (make-extent 1 1 source-buffer))
 595           (set-extent-face extent 'sdcdb-arrow-face)
 596           (set-extent-begin-glyph extent sdcdb-arrow-glyph)
 597           (set-extent-begin-glyph-layout extent 'whitespace)
 598           (set-extent-priority extent 2000)
 599           (setq sdcdb-arrow-extent extent)))
 600     (save-current-buffer
 601       (set-buffer source-buffer)
 602       (save-restriction
 603         (widen)
 604         (goto-line line)
 605         (set-window-point source-window (point))
 606         (setq pos (point))
 607         (end-of-line)
 608         (set-extent-endpoints extent pos (point))
 609         (run-hook-with-args 'sdcdb-arrow-extent-hooks extent))
 610       (cond ((or (< pos (point-min)) (> pos (point-max)))
 611              (widen)
 612              (goto-char pos))))
 613     ;; Added by Stig.  It caused lots of problems for several users
 614     ;; and since its purpose is unclear it is getting commented out.
 615     ;;(and debugger-window
 616     ;; (set-window-point debugger-window pos))
 617     ))
 618 \f
 619 (defun sdcdb-call (command)
 620   "Invoke sdcdb COMMAND displaying source in other window."
 621   (interactive)
 622   (goto-char (point-max))
 623   ;; Record info on the last prompt in the buffer and its position.
 624   ;; This is used in  sdcdb-maybe-delete-prompt
 625   ;; to prevent multiple prompts from accumulating.
 626   (save-excursion
 627     (goto-char (process-mark (get-buffer-process current-sdcdb-buffer)))
 628     (let ((pt (point)))
 629       (beginning-of-line)
 630       (setq sdcdb-delete-prompt-marker
 631             (if (= (point) pt)
 632                 nil
 633               (list (point-marker) (- pt (point))
 634                     (buffer-substring (point) pt))))))
 635   (sdcdb-set-buffer)
 636   (process-send-string (get-buffer-process current-sdcdb-buffer)
 637                (concat command "\n")))
 638
 639 (defun sdcdb-maybe-delete-prompt ()
 640   (if sdcdb-delete-prompt-marker
 641       ;; Get the string that we used as the prompt before.
 642       (let ((prompt (nth 2 sdcdb-delete-prompt-marker))
 643             (length (nth 1 sdcdb-delete-prompt-marker)))
 644         ;; Position after it.
 645         (goto-char (+ (car sdcdb-delete-prompt-marker) length))
 646         ;; Delete any duplicates of it which follow right after.
 647         (while (and (<= (+ (point) length) (point-max))
 648                     (string= prompt
 649                              (buffer-substring (point) (+ (point) length))))
 650           (delete-region (point) (+ (point) length)))
 651         ;; If that didn't take us to where output is arriving,
 652         ;; we have encountered something other than a prompt,
 653         ;; so stop trying to delete any more prompts.
 654         (if (not (= (point)
 655                     (process-mark (get-buffer-process current-sdcdb-buffer))))
 656             (progn
 657               (set-marker (car sdcdb-delete-prompt-marker) nil)
 658               (setq sdcdb-delete-prompt-marker nil))))))
 659
 660 (defun sdcdb-break (temp)
 661   "Set SDCDB breakpoint at this source line.  With ARG set temporary breakpoint."
 662   (interactive "P")
 663   (let* ((file-name (file-name-nondirectory buffer-file-name))
 664          (line (save-restriction
 665                  (widen)
 666                  (beginning-of-line)
 667                  (1+ (count-lines 1 (point)))))
 668          (cmd (concat (if temp "tbreak " "break ") file-name ":"
 669                       (int-to-string line))))
 670     (set-buffer current-sdcdb-buffer)
 671     (goto-char (process-mark (get-buffer-process current-sdcdb-buffer)))
 672     (delete-region (point) (point-max))
 673     (insert cmd)
 674     (comint-send-input)
 675     ;;(process-send-string (get-buffer-process current-sdcdb-buffer) cmd)
 676     ))
 677
 678 (defun sdcdb-clear ()
 679   "Set SDCDB breakpoint at this source line."
 680   (interactive)
 681   (let* ((file-name (file-name-nondirectory buffer-file-name))
 682          (line (save-restriction
 683                  (widen)
 684                  (beginning-of-line)
 685                  (1+ (count-lines 1 (point)))))
 686          (cmd (concat "clear " file-name ":"
 687                       (int-to-string line))))
 688     (set-buffer current-sdcdb-buffer)
 689     (goto-char (process-mark (get-buffer-process current-sdcdb-buffer)))
 690     (delete-region (point) (point-max))
 691     (insert cmd)
 692     (comint-send-input)
 693     ;;(process-send-string (get-buffer-process current-sdcdb-buffer) cmd)
 694     ))
 695
 696 (defun sdcdb-read-address()
 697   "Return a string containing the core-address found in the buffer at point."
 698   (save-excursion
 699    (let ((pt (point)) found begin)
 700      (setq found (if (search-backward "0x" (- pt 7) t)(point)))
 701      (cond (found (forward-char 2)
 702                   (buffer-substring found
 703                                     (progn (re-search-forward "[^0-9a-f]")
 704                                            (forward-char -1)
 705                                            (point))))
 706            (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1)
 707                                  (point)))
 708               (forward-char 1)
 709               (re-search-forward "[^0-9]")
 710               (forward-char -1)
 711               (buffer-substring begin (point)))))))
 712
 713
 714 (defvar sdcdb-commands nil
 715   "List of strings or functions used by send-sdcdb-command.
 716 It is for customization by you.")
 717
 718 (defun send-sdcdb-command (arg)
 719
 720   "This command reads the number where the cursor is positioned.  It
 721  then inserts this ADDR at the end of the sdcdb buffer.  A numeric arg
 722  selects the ARG'th member COMMAND of the list sdcdb-print-command.  If
 723  COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise
 724  (funcall COMMAND ADDR) is inserted.  eg. \"p (rtx)%s->fld[0].rtint\"
 725  is a possible string to be a member of sdcdb-commands.  "
 726
 727
 728   (interactive "P")
 729   (let (comm addr)
 730     (if arg (setq comm (nth arg sdcdb-commands)))
 731     (setq addr (sdcdb-read-address))
 732     (if (eq (current-buffer) current-sdcdb-buffer)
 733         (set-mark (point)))
 734     (cond (comm
 735            (setq comm
 736                  (if (stringp comm) (format comm addr) (funcall comm addr))))
 737           (t (setq comm addr)))
 738     (switch-to-buffer current-sdcdb-buffer)
 739     (goto-char (point-max))
 740     (insert comm)))
 741
 742 (fset 'sdcdb-control-c-subjob 'comint-interrupt-subjob)
 743
 744 ;(defun sdcdb-control-c-subjob ()
 745 ;  "Send a Control-C to the subprocess."
 746 ;  (interactive)
 747 ;  (process-send-string (get-buffer-process (current-buffer))
 748 ;                      "\C-c"))
 749
 750 (defun sdcdb-toolbar-break ()
 751   (interactive)
 752   (save-excursion
 753     (message (car sdcdb-last-frame))
 754     (set-buffer (find-file-noselect (car sdcdb-last-frame)))
 755     (sdcdb-break nil)))
 756
 757 (defun sdcdb-toolbar-clear ()
 758   (interactive)
 759   (save-excursion
 760     (message (car sdcdb-last-frame))
 761     (set-buffer (find-file-noselect (car sdcdb-last-frame)))
 762     (sdcdb-clear)))
 763
 764 (provide 'sdcdb)
 765
 766 (require 'sdcdb "sdcdb")                        ; NOT gud!  (yet...)
 767
 768 (defvar sdcdbsrc-active-p t
 769   "*Set to nil if you do not want source files put in sdcdbsrc-mode")
 770
 771 (defvar sdcdbsrc-call-p nil
 772   "True if sdcdb command issued from a source buffer")
 773
 774 (defvar sdcdbsrc-associated-buffer nil
 775   "Buffer name of attached sdcdb process")
 776
 777 (defvar sdcdbsrc-mode nil
 778   "Indicates whether buffer is in sdcdbsrc-mode or not")
 779 (make-variable-buffer-local 'sdcdbsrc-mode)
 780
 781 (defvar sdcdbsrc-global-mode nil
 782   "Indicates whether global sdcdbsrc bindings are in effect or not")
 783
 784 (defvar sdcdb-prompt-pattern "^[^)#$%>\n]*[)#$%>] *"
 785   "A regexp for matching the end of the sdcdb prompt")
 786
 787 (defvar eos::toolbar-toggle-srcmode
 788
 789   (toolbar-make-button-list
 790    (expand-file-name "recycle.xbm" eos::toolbar-icon-directory))
 791   "A Run icon pair.")
 792 ;;; bindings
 793
 794 (defvar sdcdbsrc-global-map
 795   (let ((map (make-sparse-keymap)))
 796     (set-keymap-name map 'sdcdbsrc-global-map)
 797     (define-key map "\C-x " 'sdcdb-break)
 798     (define-key map "\M-\C-t" 'sdcdbsrc-mode)
 799     (define-key map "\M-\C-g" 'sdcdbsrc-goto-sdcdb)
 800     (define-key map "\M-m"    'sdcdbsrc-srcmode)
 801     ;; middle button to select and print expressions...
 802     (define-key map '(meta button2)       'sdcdbsrc-print-csexp)
 803     (define-key map '(meta shift button2) 'sdcdbsrc-*print-csexp)
 804     ;; left button to position breakpoints
 805     (define-key map '(meta button1)       'sdcdbsrc-set-break)
 806     (define-key map '(meta shift button1) 'sdcdbsrc-set-tbreak-continue)
 807     map)
 808   "Global minor keymap that is active whenever sdcdbsrc is running.")
 809
 810 (add-minor-mode 'sdcdbsrc-global-mode " SdcdbGlobal" sdcdbsrc-global-map)
 811
 812 (defvar sdcdbsrc-mode-map
 813   (let ((map (make-sparse-keymap)))
 814     (suppress-keymap map)
 815     (set-keymap-name map 'sdcdbsrc-mode-map)
 816     ;; inherit keys from global sdcdbsrc map just in case that somehow gets turned off.
 817     (set-keymap-parents map (list sdcdbsrc-global-map))
 818     (define-key map "\C-x\C-q" 'sdcdbsrc-mode) ; toggle read-only
 819     (define-key map "\C-c\C-c" 'sdcdbsrc-mode)
 820     (define-key map "b" 'sdcdb-break)
 821     (define-key map "g" 'sdcdbsrc-goto-sdcdb)
 822     (define-key map "!" 'sdcdbsrc-goto-sdcdb)
 823     (define-key map "p" 'sdcdb-print-c-sexp)
 824     (define-key map "*" 'sdcdb-*print-c-sexp)
 825     (define-key map "?" 'sdcdb-whatis-c-sexp)
 826     (define-key map "R" 'sdcdbsrc-reset)
 827     map)
 828   "Minor keymap for buffers in sdcdbsrc-mode")
 829
 830 (add-minor-mode 'sdcdbsrc-mode " SdcdbSrc" sdcdbsrc-mode-map)
 831
 832 (defvar sdcdbsrc-toolbar
 833   '([eos::toolbar-stop-at-icon
 834      sdcdb-break
 835      t
 836      "Stop at selected position"]
 837     [eos::toolbar-stop-in-icon
 838      sdcdb-break
 839      t
 840      "Stop in function whose name is selected"]
 841     [eos::toolbar-clear-at-icon
 842      sdcdb-clear
 843      t
 844      "Clear at selected position"]
 845     [eos::toolbar-evaluate-icon
 846      sdcdb-print-c-sexp
 847      t
 848      "Evaluate selected expression; shows in separate XEmacs frame"]
 849     [eos::toolbar-run-icon
 850      sdcdbsrc-run
 851      t
 852      "Run current program"]
 853     [eos::toolbar-cont-icon
 854      sdcdbsrc-cont
 855      t
 856      "Continue current program"]
 857     [eos::toolbar-step-into-icon
 858      sdcdbsrc-step
 859      t
 860      "Step into (aka step)"]
 861     [eos::toolbar-step-over-icon
 862      sdcdbsrc-next
 863      t
 864      "Step over (aka next)"]
 865     [eos::toolbar-fix-icon
 866      nil
 867      nil
 868      "Fix (not available with sdcdb)"]
 869     [eos::toolbar-build-icon
 870      toolbar-compile
 871      t
 872      "Build (aka make -NYI)"]
 873     [eos::toolbar-toggle-srcmode
 874      sdcdbsrc-srcmode
 875      t
 876      "Toggle Source C <-> Asm"]
 877     ))
 878
 879 (defmacro def-sdcdb-from-src (sdcdb-command key &optional doc &rest forms)
 880   "Create a function that will call SDCDB-COMMAND with KEY."
 881   (let* ((fname (format "sdcdbsrc-%s" sdcdb-command))
 882          (cstr (list 'if 'arg
 883                      (list 'format "%s %s" sdcdb-command '(prefix-numeric-value arg))
 884                      sdcdb-command))
 885          fun)
 886     (while (string-match " " fname)
 887       (aset fname (match-beginning 0) ?-))
 888     (setq fun (intern fname))
 889
 890      (list 'progn
 891            (nconc (list 'defun fun '(arg)
 892                         (or doc "")
 893                         '(interactive "P")
 894                         (list 'sdcdb-call-from-src cstr))
 895                   forms)
 896            (list 'define-key 'sdcdbsrc-mode-map key  (list 'quote fun)))))
 897
 898 (def-sdcdb-from-src "step"   "s" "Step one instruction in src"
 899   (sdcdb-delete-arrow-extent))
 900 (def-sdcdb-from-src "stepi"  "i" "Step one source line (skip functions)"
 901   (sdcdb-delete-arrow-extent))
 902 (def-sdcdb-from-src "cont"   "c" "Continue with display"
 903   (sdcdb-delete-arrow-extent))
 904 (def-sdcdb-from-src "down"   "d" "Go down N stack frames (numeric arg) ")
 905 (def-sdcdb-from-src "up"     "u" "Go up N stack frames (numeric arg)")
 906 (def-sdcdb-from-src "finish" "f" "Finish frame")
 907 (def-sdcdb-from-src "where"  "w" "Display (N frames of) backtrace")
 908 (def-sdcdb-from-src "next"   "n" "Step one line with display"
 909   (sdcdb-delete-arrow-extent))
 910 (def-sdcdb-from-src "run"    "r" "Run program from start"
 911   (sdcdb-delete-arrow-extent))
 912 (def-sdcdb-from-src "return" "R" "Return from selected stack frame")
 913 (def-sdcdb-from-src "disable" "x" "Disable all breakpoints")
 914 (def-sdcdb-from-src "delete" "X" "Delete all breakpoints")
 915 (def-sdcdb-from-src "quit"   "Q" "Quit sdcdb."
 916   (sdcdb-delete-arrow-extent))
 917 (def-sdcdb-from-src "info locals" "l" "Show local variables")
 918 (def-sdcdb-from-src "info break"  "B" "Show breakpoints")
 919 (def-sdcdb-from-src ""  "\r" "Repeat last command")
 920 (def-sdcdb-from-src "frame"  "m" "Show frame if no arg, with arg go to frame")
 921
 922 ;;; code
 923
 924 ;;;###autoload
 925 (defun sdcdbsrc (path &optional core-or-pid)
 926   "Activates a sdcdb session with sdcdbsrc-mode turned on.  A numeric prefix
 927 argument can be used to specify a running process to attach, and a non-numeric
 928 prefix argument will cause you to be prompted for a core file to debug."
 929   (interactive (let ((file (read-file-name "Program to debug: " nil nil t)))
 930                  (cond ((numberp current-prefix-arg)
 931                         (list file (int-to-string current-prefix-arg)))
 932                        (current-prefix-arg
 933                         (list file (read-file-name "Core file: " nil nil t)))
 934                        (t (list file)))
 935                  ))
 936   ;; FIXME - this is perhaps an uncool thing to do --Stig
 937   (delete-other-windows)
 938   (split-window-vertically)
 939   (other-window 0)
 940
 941   (sdcdb path core-or-pid)
 942   (local-set-key 'button2 'sdcdbsrc-select-or-yank)
 943   (setq mode-motion-hook 'sdcdbsrc-mode-motion)
 944   ;; XEmacs change:
 945   (make-local-hook 'kill-buffer-hook)
 946   (add-hook 'kill-buffer-hook 'sdcdbsrc-reset nil t))
 947
 948 (defun sdcdbsrc-global-mode ()
 949   ;; this can be used as a hook for sdcdb-mode....
 950   (or current-sdcdb-buffer
 951       (and (eq major-mode 'sdcdb-mode)  ; doesn't work w/ energize yet
 952            (setq current-sdcdb-buffer (current-buffer))
 953            ;; XEmacs change:
 954            (progn
 955              (make-local-hook 'kill-buffer-hook)
 956              (add-hook 'kill-buffer-hook 'sdcdbsrc-reset nil t)))
 957       (error "Cannot determine current-sdcdb-buffer"))
 958 ;;;   (set-process-filter
 959 ;;;    (get-buffer-process current-sdcdb-buffer) 'sdcdbsrc-mode-filter)
 960 ;;;   (set-process-sentinel
 961 ;;;    (get-buffer-process current-sdcdb-buffer) 'sdcdbsrc-mode-sentinel)
 962   ;; sdcdbsrc-global-mode was set to t here but that tended to piss
 963   ;; people off
 964   (setq sdcdbsrc-global-mode nil
 965         sdcdbsrc-active-p          t
 966         sdcdbsrc-call-p    nil
 967         sdcdbsrc-mode      nil)
 968   (message "Gbd source mode active"))
 969
 970 (add-hook 'sdcdb-mode-hook 'sdcdbsrc-global-mode)
 971
 972 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 973 ;;; Sdcdb Source minor mode.
 974 ;;;
 975
 976 (defvar sdcdbsrc-associated-buffer nil
 977   "The sdcdb buffer to send commands to.")
 978 (defvar sdcdbsrc-initial-readonly  'undefined
 979   "read-only status of buffer when not in sdcdbsrc-mode")
 980 (defvar sdcdbsrc-old-toolbar nil
 981   "saved toolbar for buffer")
 982
 983 (defun sdcdbsrc-mode (arg &optional quiet)
 984   "Minor mode for interacting with sdcdb from a c source file.
 985 With arg, turn sdcdbsrc-mode on iff arg is positive.  In sdcdbsrc-mode,
 986 you may send an associated sdcdb buffer commands from the current buffer
 987 containing c source code."
 988   (interactive "P")
 989   (setq sdcdbsrc-mode
 990         (if (null arg)
 991             (not sdcdbsrc-mode)
 992           (> (prefix-numeric-value arg) 0)))
 993
 994   (cond (sdcdbsrc-mode
 995          (cond ((not (local-variable-p 'sdcdbsrc-initial-readonly (current-buffer)))
 996                 (set (make-local-variable 'sdcdbsrc-initial-readonly)
 997                      buffer-read-only)
 998                 (set (make-local-variable 'sdcdbsrc-associated-buffer)
 999                      current-sdcdb-buffer)
1000                 (if (featurep 'toolbar)
1001                     (set (make-local-variable 'sdcdbsrc-old-toolbar)
1002                          (specifier-specs default-toolbar (current-buffer))))
1003                 )
1004                )
1005          (if (featurep 'toolbar)
1006              (set-specifier default-toolbar (cons (current-buffer)
1007                                                   sdcdbsrc-toolbar)))
1008          (setq buffer-read-only t)
1009          (or quiet (message "Entering sdcdbsrc-mode...")))
1010         (t
1011          (and (local-variable-p 'sdcdbsrc-initial-readonly (current-buffer))
1012               (progn
1013                 (if (featurep 'toolbar)
1014                     (if sdcdbsrc-old-toolbar
1015                         (set-specifier default-toolbar
1016                                        (cons (current-buffer)
1017                                              sdcdbsrc-old-toolbar))
1018                       (remove-specifier default-toolbar (current-buffer))))
1019                 (kill-local-variable 'sdcdbsrc-old-toolbar)
1020                 (setq buffer-read-only sdcdbsrc-initial-readonly)
1021                 (kill-local-variable 'sdcdbsrc-initial-readonly)
1022                 (kill-local-variable 'sdcdbsrc-associated-buffer)
1023                 ))
1024          (or quiet (message "Exiting sdcdbsrc-mode..."))))
1025   (redraw-modeline t))
1026
1027 ;;
1028 ;; Sends commands to sdcdb process.
1029
1030 (defun sdcdb-call-from-src (command)
1031   "Send associated sdcdb process COMMAND displaying source in this window."
1032   (setq sdcdbsrc-call-p t)
1033     (let ((src-win (selected-window))
1034           (buf (or sdcdbsrc-associated-buffer current-sdcdb-buffer)))
1035       (or (buffer-name buf)
1036           (error "SDCDB buffer deleted"))
1037       (pop-to-buffer buf)
1038       (goto-char (point-max))
1039       (beginning-of-line)
1040       ;; Go past sdcdb prompt
1041       (re-search-forward
1042        sdcdb-prompt-pattern (save-excursion (end-of-line) (point))  t)
1043       ;; Delete any not-supposed-to-be-there text
1044       (delete-region (point) (point-max))
1045       (insert command)
1046       (comint-send-input)
1047       (select-window src-win)
1048       ))
1049
1050 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1051 ;;;
1052 ;;; Define Commands for SDCDB SRC Mode Buffer
1053 ;;;
1054
1055 ;;; ;; #### - move elsewhere
1056 (or (fboundp 'event-buffer)
1057     (defun event-buffer (event)
1058       "Return buffer assocaited with EVENT, or nil."
1059       (let ((win (event-window event)))
1060         (and win (window-buffer win)))))
1061
1062 (defun set-sdcdbsrc-mode-motion-extent (st en action)
1063   ;; by Stig@hackvan.com
1064   (let ((ex  (make-extent st en)))
1065     (set-extent-face ex 'highlight)
1066     (set-extent-property ex 'sdcdbsrc t)
1067     (set-extent-property ex 'action action)
1068     (setq mode-motion-extent ex)))
1069
1070 (defun nuke-mode-motion-extent ()
1071   ;; by Stig@hackvan.com
1072   (cond (mode-motion-extent
1073          (delete-extent mode-motion-extent)
1074          (setq mode-motion-extent nil))))
1075
1076 (defun looking-at-any (regex-list)
1077   ;; by Stig@hackvan.com
1078   (catch 'found
1079     (while regex-list
1080       (and (looking-at (car regex-list))
1081            (throw 'found t))
1082       (setq regex-list (cdr regex-list)))))
1083
1084 (defconst sdcdb-breakpoint-patterns
1085   '(
1086     ;; when execution stops...
1087     ;;Breakpoint 1, XlwMenuRedisplay (w=0x4d2e00, ev=0xefffe3f8, region=0x580e60)
1088     ;;    at /net/stig/src/xemacs/lwlib/xlwmenu.c:2518
1089     "^[BW][ra][et][ac][kh]point [0-9]+, .*\\(\n\\s .*\\)*"
1090     ;; output of the breakpoint command:
1091     ;;Breakpoint 1 at 0x19f5c8: file /net/stig/src/xemacs/lwlib/xlwmenu.c, line 2715.
1092     "^[BW][ra][et][ac][kh]point [0-9]+ at .*: file \\([^ ,\n]+\\), line \\([0-9]+\\)."
1093     ;;Num Type           Disp Enb Address    What
1094     ;;1   breakpoint     keep y   0x0019ee60 in XlwMenuRedisplay
1095     ;;                                       at /net/stig/src/xemacs/lwlib/xlwmenu.c:2518
1096     "^[0-9]+\\s +[bw][ra][et][ac][kh]point.* in .*\\(\n\\s +\\)?at [^ :\n]+:[0-9]+\\(\n\\s .*\\)*"
1097     )
1098   "list of patterns to match sdcdb's various ways of displaying a breakpoint")
1099
1100 (defun sdcdbsrc-make-breakpoint-action (string)
1101   ;; by Stig@hackvan.com
1102   (if (or (string-match "file \\([^ ,\n]+\\), line \\([0-9]+\\)" string)
1103           (string-match "at \\([^ :\n]+\\):\\([0-9]+\\)" string))
1104       (list 'sdcdbsrc-display
1105             (match-string 1 string)
1106             (string-to-int (match-string 2 string)))))
1107
1108 (defconst sdcdb-stack-frame-pattern
1109   ;;#9  0x62f08 in emacs_Xt_next_event (emacs_event=0x4cf804)
1110   ;;    at /net/stig/src/xemacs/src/event-Xt.c:1778
1111   "^#\\([0-9]+\\)\\s +\\(0x[0-9a-f]+ in .*\\|.*\\sw+.* (.*) at .*\\)\\(\n\\s .*\\)*"
1112   "matches the first line of a sdcdb stack frame and all continuation lines.
1113 subex 1 is frame number.")
1114
1115 (defun sdcdbsrc-mode-motion (ee)
1116   ;; by Stig@hackvan.com
1117   (save-excursion
1118     (set-buffer (event-buffer ee))
1119     (save-excursion
1120       (if (not (event-point ee))
1121           (nuke-mode-motion-extent)
1122         (goto-char (event-point ee))
1123         (beginning-of-line)
1124         (while (and (not (bobp)) (eq ?  (char-syntax (following-char))))
1125           (forward-line -1))
1126         (if (extent-at (point) (current-buffer) 'sdcdbsrc)
1127             nil
1128           (nuke-mode-motion-extent)
1129           (cond ((looking-at-any sdcdb-breakpoint-patterns)
1130                  (set-sdcdbsrc-mode-motion-extent
1131                   (match-beginning 0)
1132                   (match-end 0)
1133                   (sdcdbsrc-make-breakpoint-action (match-string 0))))
1134                 ((looking-at sdcdb-stack-frame-pattern)
1135                  (set-sdcdbsrc-mode-motion-extent
1136                   (match-beginning 0)
1137                   (match-end 0)
1138                   (list 'sdcdbsrc-frame
1139                         (string-to-int (match-string 1)))))
1140                 )))
1141       )))
1142
1143 (defun sdcdbsrc-display (file line)
1144   ;; by Stig@hackvan.com
1145   (select-window (display-buffer (find-file-noselect file)))
1146   (goto-line line))
1147
1148 (defun click-inside-selection-p (click)
1149   (or (click-inside-extent-p click primary-selection-extent)
1150       (click-inside-extent-p click zmacs-region-extent)
1151       ))
1152
1153 (defun click-inside-extent-p (click extent)
1154   "Returns non-nil if the button event is within the bounds of the primary
1155 selection-extent, nil otherwise."
1156   ;; stig@hackvan.com
1157   (let ((ewin (event-window click))
1158         (epnt (event-point click)))
1159     (and ewin
1160          epnt
1161          extent
1162          (eq (window-buffer ewin)
1163              (extent-object extent))
1164          (extent-start-position extent)
1165          (> epnt (extent-start-position extent))
1166          (> (extent-end-position extent) epnt))))
1167
1168 (defun point-inside-extent-p (extent)
1169   "Returns non-nil if the point is within or just after the bounds of the
1170 primary selection-extent, nil otherwise."
1171   ;; stig@hackvan.com
1172   (and extent           ; FIXME - I'm such a sinner...
1173        (eq (current-buffer)
1174            (extent-object extent))
1175        (> (point) (extent-start-position extent))
1176        (>= (extent-end-position extent) (point))))
1177
1178 (defun sdcdbsrc-select-or-yank (ee)
1179   ;; by Stig@hackvan.com
1180   (interactive "e")
1181   (let ((action (save-excursion
1182                   (set-buffer (event-buffer ee))
1183                   (and mode-motion-extent
1184                        (click-inside-extent-p ee mode-motion-extent)
1185                        (extent-property mode-motion-extent 'action)))
1186                 ))
1187     (if action
1188         (eval action)
1189       (mouse-yank ee))))
1190
1191 (defvar sdcdb-print-format ""
1192   "Set this variable to a valid format string to print c-sexps in a
1193 different way (hex,octal, etc).")
1194
1195 (defun sdcdb-print-c-sexp ()
1196   "Find the nearest c-mode sexp. Send it to sdcdb with print command."
1197   (interactive)
1198   (let* ((tag (find-c-sexp))
1199          (command (concat "print " sdcdb-print-format tag)))
1200     (sdcdb-call-from-src command)))
1201
1202 (defun sdcdbsrc-srcmode ()
1203   "Toggle between assembler & C source modes."
1204   (sdcdb-call-from-src "set srcmode"))
1205
1206 (defun sdcdb-*print-c-sexp ()
1207   "Find the nearest c-mode sexp. Send it to sdcdb with the print * command."
1208   (interactive)
1209   (let* ((tag (find-c-sexp))
1210         (command (concat "print " sdcdb-print-format "*"  tag)))
1211     (sdcdb-call-from-src  command)))
1212
1213 (defun sdcdb-whatis-c-sexp ()
1214   "Find the nearest c-mode sexp. Send it to sdcdb with the whatis command. "
1215   (interactive)
1216   (let* ((tag (sdcdbsrc-selection-or-sexp))
1217          (command (concat "ptype " tag)))
1218     (sdcdb-call-from-src command)))
1219
1220 (defun sdcdbsrc-goto-sdcdb ()
1221   "Hop back and forth between the sdcdb interaction buffer and the sdcdb source
1222 buffer.  "
1223   ;; by Stig@hackvan.com
1224   (interactive)
1225   (let ((gbuf (or sdcdbsrc-associated-buffer current-sdcdb-buffer)))
1226     (cond ((eq (current-buffer) gbuf)
1227            (and sdcdb-arrow-extent
1228                 (extent-object sdcdb-arrow-extent)
1229                 (progn (pop-to-buffer (extent-object sdcdb-arrow-extent))
1230                        (goto-char (extent-start-position sdcdb-arrow-extent)))))
1231           ((buffer-name gbuf) (pop-to-buffer gbuf))
1232           ((y-or-n-p "No debugger.  Start a new one? ")
1233                  (call-interactively 'sdcdbsrc))
1234           (t (error "No sdcdb buffer."))
1235           )))
1236
1237 (defvar sdcdbsrc-last-src-buffer nil)
1238
1239 (defun sdcdbsrc-goto-src ()
1240   (interactive)
1241   (let* ((valid (and sdcdbsrc-last-src-buffer
1242                      (memq sdcdbsrc-last-src-buffer (buffer-list))))
1243          (win (and valid
1244                    (get-buffer-window sdcdbsrc-last-src-buffer))))
1245     (cond (win (select-window win))
1246           (valid (pop-to-buffer sdcdbsrc-last-src-buffer)))))
1247
1248 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1249 ;;;
1250 ;;;  The following functions are used to extract the closest surrounding
1251 ;;;  c expression from point
1252 ;;;
1253 (defun back-sexp ()
1254   "Version of backward-sexp that catches errors"
1255   (condition-case nil
1256       (backward-sexp)
1257     (error t)))
1258
1259 (defun forw-sexp ()
1260   "Version of forward-sexp that catches errors"
1261   (condition-case nil
1262      (forward-sexp)
1263     (error t)))
1264
1265 (defun sexp-compound-sep (span-start span-end)
1266   "Returns '.' for '->' & '.', returns ' ' for white space,
1267 returns '?' for other puctuation"
1268   (let ((result ? )
1269         (syntax))
1270     (while (< span-start span-end)
1271       (setq syntax (char-syntax (char-after span-start)))
1272       (cond
1273        ((= syntax ? ) t)
1274        ((= syntax ?.) (setq syntax (char-after span-start))
1275         (cond
1276          ((= syntax ?.) (setq result ?.))
1277          ((and (= syntax ?-) (= (char-after (+ span-start 1)) ?>))
1278           (setq result ?.)
1279           (setq span-start (+ span-start 1)))
1280          (t (setq span-start span-end)
1281             (setq result ??)))))
1282       (setq span-start (+ span-start 1)))
1283     result
1284     )
1285   )
1286
1287 (defun sexp-compound (first second)
1288   "Returns non-nil if the concatenation of two S-EXPs result in a Single C
1289 token. The two S-EXPs are represented as a cons cells, where the car
1290 specifies the point in the current buffer that marks the begging of the
1291 S-EXP and the cdr specifies the character after the end of the S-EXP
1292 Link S-Exps of the form:
1293       Sexp -> SexpC
1294       Sexp . Sexp
1295       Sexp (Sexp)        Maybe exclude if first Sexp is: if, while, do, for, switch
1296       Sexp [Sexp]
1297       (Sexp) Sexp
1298       [Sexp] Sexp"
1299   (let ((span-start (cdr first))
1300         (span-end (car second))
1301         (syntax))
1302     (setq syntax (sexp-compound-sep span-start span-end))
1303     (cond
1304      ((= (car first) (car second)) nil)
1305      ((= (cdr first) (cdr second)) nil)
1306      ((= syntax ?.) t)
1307      ((= syntax ? )
1308          (setq span-start (char-after (- span-start 1)))
1309          (setq span-end (char-after span-end))
1310          (cond
1311           ((= span-start ?) ) t )
1312           ((= span-start ?] ) t )
1313           ((= span-end ?( ) t )
1314           ((= span-end ?[ ) t )
1315           (t nil))
1316          )
1317      (t nil))
1318     )
1319   )
1320
1321 (defun sexp-cur ()
1322   "Returns the  S-EXP that Point is a member, Point is set to begging of S-EXP.
1323 The S-EXPs is represented as a cons cell, where the car specifies the point in
1324 the current buffer that marks the begging of the S-EXP and the cdr specifies
1325 the character after the end of the S-EXP"
1326   (let ((p (point)) (begin) (end))
1327     (back-sexp)
1328     (setq begin (point))
1329     (forw-sexp)
1330     (setq end (point))
1331     (if (>= p end)
1332         (progn
1333          (setq begin p)
1334          (goto-char p)
1335          (forw-sexp)
1336          (setq end (point))
1337          )
1338       )
1339     (goto-char begin)
1340     (cons begin end)
1341     )
1342   )
1343
1344 (defun sexp-prev ()
1345   "Returns the previous S-EXP, Point is set to begging of that S-EXP.
1346 The S-EXPs is represented as a cons cell, where the car specifies the point in
1347 the current buffer that marks the begging of the S-EXP and the cdr specifies
1348 the character after the end of the S-EXP"
1349   (let ((begin) (end))
1350     (back-sexp)
1351     (setq begin (point))
1352     (forw-sexp)
1353     (setq end (point))
1354     (goto-char begin)
1355     (cons begin end))
1356 )
1357
1358 (defun sexp-next ()
1359   "Returns the following S-EXP, Point is set to begging of that S-EXP.
1360 The S-EXPs is represented as a cons cell, where the car specifies the point in
1361 the current buffer that marks the begging of the S-EXP and the cdr specifies
1362 the character after the end of the S-EXP"
1363   (let ((begin) (end))
1364     (forw-sexp)
1365     (forw-sexp)
1366     (setq end (point))
1367     (back-sexp)
1368     (setq begin (point))
1369     (cons begin end)
1370     )
1371   )
1372
1373 (defun find-c-sexp ()
1374   "Returns the Complex  S-EXP that surrounds Point"
1375   (interactive)
1376   (save-excursion
1377     (let ((p) (sexp) (test-sexp))
1378       (setq p (point))
1379       (setq sexp (sexp-cur))
1380       (setq test-sexp (sexp-prev))
1381       (while (sexp-compound test-sexp sexp)
1382         (setq sexp (cons (car test-sexp) (cdr sexp)))
1383         (goto-char (car sexp))
1384         (setq test-sexp (sexp-prev))
1385         )
1386       (goto-char p)
1387       (setq test-sexp (sexp-next))
1388       (while (sexp-compound sexp test-sexp)
1389         (setq sexp (cons (car sexp) (cdr test-sexp)))
1390         (setq test-sexp (sexp-next))
1391         )
1392       (buffer-substring (car sexp) (cdr sexp))
1393       )
1394     )
1395   )
1396
1397 (defun sdcdbsrc-selection-or-sexp (&optional ee)
1398   ;; FIXME - fix this docstring
1399   "If the EVENT is within the primary selection, then return the selected
1400 text, otherwise parse the expression at the point of the mouse click and
1401 return that.  If EVENT is nil, then return the C sexp at point."
1402   ;; stig@hackvan.com
1403   (cond ((or (and ee (click-inside-selection-p ee))
1404              (and (not ee) (point-inside-selection-p)))
1405          (replace-in-string (extent-string primary-selection-extent) "\n\\s *" " "))
1406         (ee
1407          (sdcdbsrc-get-csexp-at-click ee))
1408         (t
1409          (find-c-sexp))
1410         ))
1411
1412 (defun sdcdbsrc-get-csexp-at-click (ee)
1413   "Returns the containing s-expression located at the mouse cursor to point."
1414   ;; "
1415   ;; by Stig@hackvan.com
1416   (let ((ewin (event-window ee))
1417         (epnt (event-point ee)))
1418     (or (and ewin epnt)
1419         (error "Must click within a window"))
1420     (save-excursion
1421       (set-buffer (window-buffer ewin))
1422       (save-excursion
1423         (goto-char epnt)
1424         (find-c-sexp)))))
1425
1426 (defun sdcdbsrc-print-csexp (&optional ee)
1427   (interactive)
1428   (or ee (setq ee current-mouse-event))
1429   (sdcdb-call-from-src
1430          (concat "print "  sdcdb-print-format (sdcdbsrc-selection-or-sexp ee))))
1431
1432 (defun sdcdbsrc-*print-csexp (&optional ee)
1433   (interactive)
1434   (or ee (setq ee current-mouse-event))
1435   (sdcdb-call-from-src
1436    (concat "print *"  sdcdb-print-format (sdcdbsrc-selection-or-sexp ee))))
1437
1438 ;; (defun sdcdbsrc-print-region (arg)
1439 ;;   (let (( command  (concat "print " sdcdb-print-format (x-get-cut-buffer))))
1440 ;;     (sdcdb-call-from-src command)))
1441 ;;
1442 ;; (defun sdcdbsrc-*print-region (arg)
1443 ;;   (let (( command  (concat "print *" sdcdb-print-format (x-get-cut-buffer))))
1444 ;;     (sdcdb-call-from-src command)))
1445
1446 (defun sdcdbsrc-file:lno ()
1447   "returns \"file:lno\" specification for location of point. "
1448   ;; by Stig@hackvan.com
1449   (format "%s:%d"
1450           (file-name-nondirectory buffer-file-name)
1451           (save-restriction
1452             (widen)
1453             (1+ (count-lines (point-min)
1454                              (save-excursion (beginning-of-line) (point)))))
1455           ))
1456
1457 (defun sdcdbsrc-set-break (ee)
1458   "Sets a breakpoint.  Click on the selection and it will set a breakpoint
1459 using the selected text.  Click anywhere in a source file, and it will set
1460 a breakpoint at that line number of that file."
1461   ;; by Stig@hackvan.com
1462   ;; there is already sdcdb-break, so this only needs to work with mouse clicks.
1463   (interactive "e")
1464   (sdcdb-call-from-src
1465    (concat "break "
1466            (if (click-inside-selection-p ee)
1467                (extent-string primary-selection-extent)
1468              (mouse-set-point ee)
1469              (or buffer-file-name (error "No file in window"))
1470              (- (sdcdbsrc-file:lno) 1)
1471              ))))
1472
1473 (defun sdcdbsrc-set-tbreak-continue (&optional ee)
1474   "Set a temporary breakpoint at the position of the mouse click and then
1475 continues.  This can be bound to either a key or a mouse button."
1476   ;; by Stig@hackvan.com
1477   (interactive)
1478   (or ee (setq ee current-mouse-event))
1479   (and ee (mouse-set-point ee))
1480   (sdcdb-call-from-src (concat "tbreak " (sdcdbsrc-file:lno)))
1481   (sdcdb-call-from-src "c"))
1482
1483 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1484 ;; Functions extended from sdcdb.el for sdcdbsrc.
1485 ;;
1486 ;; sdcdbsrc-set-buffer - added a check to set buffer to sdcdbsrc-associated-buffer
1487 ;;                  to handle multiple sdcdb sessions being driven from src
1488 ;;                  files.
1489
1490 (require 'advice)
1491
1492 (defadvice sdcdb-set-buffer (after sdcdbsrc activate) ; ()
1493   "Advised to work from a source buffer instead of just the sdcdb buffer."
1494   ;; by Stig@hackvan.com
1495   ;; the operations below have tests which are disjoint from the tests in
1496   ;; the original `sdcdb-set-buffer'.  Current-sdcdb-buffer cannot be set twice.
1497   (and sdcdbsrc-call-p
1498        sdcdbsrc-associated-buffer
1499        (setq current-sdcdb-buffer sdcdbsrc-associated-buffer)))
1500
1501 (defadvice sdcdb-display-line (around sdcdbsrc activate)
1502   ;; (true-file line &optional select-method)
1503   "Advised to select the source buffer instead of the sdcdb-buffer"
1504   ;; by Stig@hackvan.com
1505   (ad-set-arg 2 'source) ; tell it not to select the sdcdb window
1506   ad-do-it
1507   (save-excursion
1508     (let* ((buf (extent-object sdcdb-arrow-extent))
1509            (win (get-buffer-window buf)))
1510       (setq sdcdbsrc-last-src-buffer buf)
1511       (select-window win)
1512       (set-window-point win (extent-start-position sdcdb-arrow-extent))
1513       (set-buffer buf))
1514     (and sdcdbsrc-active-p
1515          (not sdcdbsrc-mode)
1516          (not (eq (current-buffer) current-sdcdb-buffer))
1517          (sdcdbsrc-mode 1))))
1518
1519 (defadvice sdcdb-filter (after sdcdbsrc activate) ; (proc string)
1520   ;; by Stig@hackvan.com
1521   ;; if we got a sdcdb prompt and it wasn't a sdcdbsrc command, then it's sdcdb
1522   ;; hitting a breakpoint or having a core dump, so bounce back to the sdcdb
1523   ;; window.
1524   (let* ((selbuf (window-buffer (selected-window)))
1525          win)
1526     ;; if we're at a sdcdb prompt, then display the buffer
1527     (and (save-match-data (string-match sdcdb-prompt-pattern (ad-get-arg 1)))
1528          (prog1
1529              (not sdcdbsrc-call-p)
1530            (setq sdcdbsrc-call-p nil))
1531          (setq win (display-buffer current-sdcdb-buffer))
1532          ;; if we're not in either the source buffer or the sdcdb buffer,
1533          ;; then select the window too...
1534          (not (eq selbuf current-sdcdb-buffer))
1535          (not (eq selbuf sdcdbsrc-last-src-buffer))
1536          (progn
1537            (ding nil 'warp)
1538            (select-window win)))
1539     ))
1540
1541 (defun sdcdbsrc-reset ()
1542   ;; tidy house and turn off sdcdbsrc-mode in all buffers
1543   ;; by Stig@hackvan.com
1544   (sdcdb-delete-arrow-extent)
1545   (setq sdcdbsrc-global-mode nil)
1546   (mapcar #'(lambda (buffer)
1547               (set-buffer buffer)
1548               (cond ((eq sdcdbsrc-associated-buffer current-sdcdb-buffer)
1549                      (sdcdbsrc-mode -1))))
1550           (buffer-list)))
1551
1552 (defadvice sdcdb-sentinel (after sdcdbsrc freeze) ; (proc msg)
1553   ;; by Stig@hackvan.com
1554   (sdcdbsrc-reset)
1555   (message "Sdcdbsrc finished"))
1556
1557 (provide 'sdcdbsrc)