/usr/share/emacs/site-lisp/sdcc-ucsim/sdcdbsrc.el

;;; sdcdbsrc.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.
;; 
;; Copyright (C) 1999 Sandeep Dutta <sandeep.dutta@usa.net>
;;
;; 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>

;;;  SDCDBSRC::
;;;  Sdcdbsrc extends the emacs SDCDB interface to accept sdcdb commands issued
;;;  from the source code buffer.  Sdcdbsrc behaves similar to sdcdb except
;;;  now most debugging may be done from the source code using the *sdcdb*
;;;  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.
;;; 

;; SDCDBSRC::Sdcdb Source Mode Interface description.
;; Sdcdbsrc extends the emacs SDCDB interface to accept sdcdb commands issued
;; from the source code buffer. Sdcdbsrc behaves similar to sdcdb except now all 
;; debugging may be done from the currently focused source buffer using 
;; the *sdcdb* buffer to view output.

;; When source files are displayed through sdcdbsrc, buffers are put in 
;; sdcdbsrc-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 sdcdb process. The minor mode may be toggled on/off as needed.
;; (ESC-T) 

;; C-expressions may be evaluated by sdcdbsrc 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 sdcdbsrc
;; follows to each new source buffer. Makes debugging fun. (sound like a
;; commercial or what!)
;; 

;; Current Listing ::
;;key		binding					Comment
;;---		-------					-------
;;
;; r               sdcdb-return-from-src	SDCDB return command
;; n               sdcdb-next-from-src	SDCDB next command
;; b               sdcdb-back-from-src	SDCDB back command
;; w               sdcdb-where-from-src	SDCDB where command
;; f               sdcdb-finish-from-src	SDCDB finish command
;; u               sdcdb-up-from-src      SDCDB up command
;; d               sdcdb-down-from-src	SDCDB down command
;; c               sdcdb-cont-from-src	SDCDB continue command
;; i               sdcdb-stepi-from-src	SDCDB step instruction command
;; s               sdcdb-step-from-src	SDCDB step command
;; ?               sdcdb-whatis-c-sexp	SDCDB whatis command for data at
;;					     buffer point
;; x               sdcdbsrc-delete        SDCDB Delete all breakpoints if no arg
;;					     given or delete arg (C-u arg x)
;; m               sdcdbsrc-frame         SDCDB Display current frame if no arg,
;;					     given or display frame arg
;; *               sdcdb-*print-c-sexp	SDCDB print * command for data at
;;					       buffer point
;; !               sdcdbsrc-goto-sdcdb		Goto the SDCDB output buffer
;; p               sdcdb-print-c-sexp	SDCDB print * command for data at
;;					     buffer point
;; g               sdcdbsrc-goto-sdcdb		Goto the SDCDB output buffer
;; t               sdcdbsrc-mode		Toggles Sdcdbsrc mode (turns it off)
;; 
;; C-c C-f         sdcdb-finish-from-src	SDCDB finish command
;; 
;; C-x SPC         sdcdb-break		Set break for line with point
;; ESC t           sdcdbsrc-mode		Toggle Sdcdbsrc mode
;; ESC m           sdcdbsrc-srcmode             Toggle list mode
;;
;; Local Bindings for buffer when you exit Sdcdbsrc minor mode
;;
;; C-x SPC         sdcdb-break		Set break for line with point
;; ESC t           sdcdbsrc-mode		Toggle Sdcdbsrc mode
;;

;;; (eval-when-compile
;;;   (or noninteractive
;;;       (progn 
;;;         (message "ONLY compile sdcdbsrc except with -batch because of advice")
;;;         (ding)
;;;       )))
;;; sdcdb.el --- run sdcdb under Emacs

;; Author: W. Schelter, University of Texas
;;     wfs@rascal.ics.utexas.edu
;; Rewritten by rms.
;; Keywords: c, unix, tools, debugging

;; Some ideas are due to Masanobu.

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; Description of SDCDB interface:

;; A facility is provided for the simultaneous display of the source code
;; in one window, while using sdcdb to step through a function in the
;; other.  A small arrow in the source window, indicates the current
;; line.

;; Starting up:

;; In order to use this facility, invoke the command SDCDB to obtain a
;; shell window with the appropriate command bindings.  You will be asked
;; for the name of a file to run.  Sdcdb will be invoked on this file, in a
;; window named *sdcdb-foo* if the file is foo.

;; M-s steps by one line, and redisplays the source file and line.

;; You may easily create additional commands and bindings to interact
;; with the display.  For example to put the sdcdb command next on \M-n
;; (def-sdcdb next "\M-n")

;; This causes the emacs command sdcdb-next to be defined, and runs
;; sdcdb-display-frame after the command.

;; sdcdb-display-frame is the basic display function.  It tries to display
;; in the other window, the file and line corresponding to the current
;; position in the sdcdb window.  For example after a sdcdb-step, it would
;; display the line corresponding to the position for the last step.  Or
;; if you have done a backtrace in the sdcdb buffer, and move the cursor
;; into one of the frames, it would display the position corresponding to
;; that frame.

;; sdcdb-display-frame is invoked automatically when a filename-and-line-number
;; appears in the output.

;;; Code:

(require 'comint)
(require 'shell)

(condition-case nil
    (if (featurep 'toolbar)
	(require 'eos-toolbar "sun-eos-toolbar"))
  (error nil))

(defvar sdcdb-last-frame)
(defvar sdcdb-delete-prompt-marker)
(defvar sdcdb-filter-accumulator)
(defvar sdcdb-last-frame-displayed-p)
(defvar sdcdb-arrow-extent nil)
(or (fboundp 'make-glyph) (fset 'make-glyph 'identity)) ; work w/ pre beta v12
(defvar sdcdb-arrow-glyph (make-glyph "=>"))

(make-face 'sdcdb-arrow-face)
(or (face-differs-from-default-p 'sdcdb-arrow-face)
   ;; Usually has a better default value than highlight does
   (copy-face 'isearch 'sdcdb-arrow-face))

;; Hooks can side-effect extent arg to change extent properties
(defvar sdcdb-arrow-extent-hooks '())

(defvar sdcdb-prompt-pattern "^>\\|^(.*sdcdb[+]?) *\\|^---Type <return> to.*--- *"
  "A regexp to recognize the prompt for sdcdb or sdcdb+.") 

(defvar sdcdb-mode-map nil
  "Keymap for sdcdb-mode.")

(defvar sdcdb-toolbar nil)
 
(if sdcdb-mode-map
   nil
  (setq sdcdb-mode-map (make-sparse-keymap))
  (set-keymap-name sdcdb-mode-map 'sdcdb-mode-map)
  (set-keymap-parents sdcdb-mode-map (list comint-mode-map))
  (define-key sdcdb-mode-map "\C-l" 'sdcdb-refresh)
  (define-key sdcdb-mode-map "\C-c\C-c" 'sdcdb-control-c-subjob)
  (define-key sdcdb-mode-map "\t" 'comint-dynamic-complete)
  (define-key sdcdb-mode-map "\M-?" 'comint-dynamic-list-completions))

(define-key ctl-x-map " " 'sdcdb-break)
(define-key ctl-x-map "&" 'send-sdcdb-command)

;;Of course you may use `def-sdcdb' with any other sdcdb command, including
;;user defined ones.   

(defmacro def-sdcdb (name key &optional doc &rest forms)
  (let* ((fun (intern (format "sdcdb-%s" name)))
	 (cstr (list 'if '(not (= 1 arg))
		     (list 'format "%s %s" name 'arg)
		     name)))
    (list 'progn
	  (nconc (list 'defun fun '(arg)
		       (or doc "")
		       '(interactive "p")
		       (list 'sdcdb-call cstr))
		 forms)
	  (and key (list 'define-key 'sdcdb-mode-map key  (list 'quote fun))))))

(def-sdcdb "step"   "\M-s" "Step one source line with display"
  (sdcdb-delete-arrow-extent))
(def-sdcdb "stepi"  "\M-i" "Step one instruction with display"
  (sdcdb-delete-arrow-extent))
(def-sdcdb "finish" "\C-c\C-f" "Finish executing current function"
  (sdcdb-delete-arrow-extent))
(def-sdcdb "run" nil "Run the current program"
  (sdcdb-delete-arrow-extent))

;;"next" and "cont" were bound to M-n and M-c in Emacs 18, but these are
;;poor choices, since M-n is used for history navigation and M-c is
;;capitalize-word.  These are defined without key bindings so that users
;;may choose their own bindings.
(def-sdcdb "next"   "\C-c\C-n" "Step one source line (skip functions)"
  (sdcdb-delete-arrow-extent))
(def-sdcdb "cont"   "\C-c\M-c" "Proceed with the program"
  (sdcdb-delete-arrow-extent))

(def-sdcdb "up"     "\C-c<" "Go up N stack frames (numeric arg) with display")
(def-sdcdb "down"   "\C-c>" "Go down N stack frames (numeric arg) with display")

(defvar sdcdb-display-mode nil
  "Minor mode for sdcdb frame display")
(or (assq 'sdcdb-display-mode minor-mode-alist)
    (setq minor-mode-alist
	  (purecopy
	   (append minor-mode-alist
		   '((sdcdb-display-mode " Frame"))))))

(defun sdcdb-display-mode (&optional arg)
  "Toggle SDCDB Frame display mode
With arg, turn display mode on if and only if arg is positive.
In the display minor mode, source file are displayed in another
window for repective \\[sdcdb-display-frame] commands."
  (interactive "P")
  (setq sdcdb-display-mode (if (null arg)
			     (not sdcdb-display-mode)
			   (> (prefix-numeric-value arg) 0))))

;; Using cc-mode's syntax table is broken.
(defvar sdcdb-mode-syntax-table nil
  "Syntax table for SDCDB mode.")

;; This is adapted from CC Mode 5.11.
(unless sdcdb-mode-syntax-table
  (setq sdcdb-mode-syntax-table (make-syntax-table))
  ;; DO NOT TRY TO SET _ (UNDERSCORE) TO WORD CLASS!
  (modify-syntax-entry ?_  "_" sdcdb-mode-syntax-table)
  (modify-syntax-entry ?\\ "\\" sdcdb-mode-syntax-table)
  (modify-syntax-entry ?+  "." sdcdb-mode-syntax-table)
  (modify-syntax-entry ?-  "." sdcdb-mode-syntax-table)
  (modify-syntax-entry ?=  "." sdcdb-mode-syntax-table)
  (modify-syntax-entry ?%  "." sdcdb-mode-syntax-table)
  (modify-syntax-entry ?<  "." sdcdb-mode-syntax-table)
  (modify-syntax-entry ?>  "." sdcdb-mode-syntax-table)
  (modify-syntax-entry ?&  "." sdcdb-mode-syntax-table)
  (modify-syntax-entry ?|  "." sdcdb-mode-syntax-table)
  (modify-syntax-entry ?\' "\"" sdcdb-mode-syntax-table)
  ;; add extra comment syntax
  (modify-syntax-entry ?/  ". 14"  sdcdb-mode-syntax-table)
  (modify-syntax-entry ?*  ". 23"  sdcdb-mode-syntax-table))


(defun sdcdb-mode ()
  "Major mode for interacting with an inferior Sdcdb process.
The following commands are available:

\\{sdcdb-mode-map}

\\[sdcdb-display-frame] displays in the other window
the last line referred to in the sdcdb buffer. See also
\\[sdcdb-display-mode].

\\[sdcdb-step],\\[sdcdb-next], and \\[sdcdb-nexti] in the sdcdb window,
call sdcdb to step,next or nexti and then update the other window
with the current file and position.

If you are in a source file, you may select a point to break
at, by doing \\[sdcdb-break].

Commands:
Many commands are inherited from comint mode. 
Additionally we have:

\\[sdcdb-display-frame] display frames file in other window
\\[sdcdb-step] advance one line in program
\\[send-sdcdb-command] used for special printing of an arg at the current point.
C-x SPACE sets break point at current line."
  (interactive)
  (comint-mode)
  (use-local-map sdcdb-mode-map)
  (set-syntax-table sdcdb-mode-syntax-table)
  (make-local-variable 'sdcdb-last-frame-displayed-p)
  (make-local-variable 'sdcdb-last-frame)
  (make-local-variable 'sdcdb-delete-prompt-marker)
  (make-local-variable 'sdcdb-display-mode)
  (make-local-variable' sdcdb-filter-accumulator)
  (setq sdcdb-last-frame nil
        sdcdb-delete-prompt-marker nil
        sdcdb-filter-accumulator nil
	sdcdb-display-mode t
        major-mode 'sdcdb-mode
        mode-name "Inferior SDCDB"
        comint-prompt-regexp sdcdb-prompt-pattern
        sdcdb-last-frame-displayed-p t)
  (set (make-local-variable 'shell-dirtrackp) t)
  ;;(make-local-variable 'sdcdb-arrow-extent)
  (and (extentp sdcdb-arrow-extent)
       (delete-extent sdcdb-arrow-extent))
  (setq sdcdb-arrow-extent nil)
  ;; XEmacs change:
  (make-local-hook 'kill-buffer-hook)
  (add-hook 'kill-buffer-hook 'sdcdb-delete-arrow-extent nil t)
  (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t)
  (run-hooks 'sdcdb-mode-hook))

(defun sdcdb-delete-arrow-extent ()
  (let ((inhibit-quit t))
    (if sdcdb-arrow-extent
        (delete-extent sdcdb-arrow-extent))
    (setq sdcdb-arrow-extent nil)))

(defvar current-sdcdb-buffer nil)

;;;###autoload
(defvar sdcdb-command-name "sdcdb"
  "Pathname for executing sdcdb.")
;;
;; default values should be changed as needed
;;
(defvar sdcdbsrc-cpu-type "51")
(defvar sdcdbsrc-frequency "11059200")
(defvar sdcdbsrc-serial   nil)

;;;###autoload
(defun sdcdb (path &optional corefile)
  "Run sdcdb on program FILE in buffer *sdcdb-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for SDCDB.  If you wish to change this, use
the SDCDB commands `cd DIR' and `directory'."
  (interactive "FRun sdcdb on file: ")
  (setq path (file-truename (expand-file-name path)))
  (let ((file (file-name-nondirectory path)))
    (switch-to-buffer (concat "*sdcdb-" file "*"))
    (setq default-directory (file-name-directory path))
    (or (bolp) (newline))
    (insert "Current directory is " default-directory "\n")
    (apply 'make-comint
	   (concat "sdcdb-" file)
	   (substitute-in-file-name sdcdb-command-name)
	   nil
	   "-cpu"
	   sdcdbsrc-cpu-type
	   "-X"
	   sdcdbsrc-frequency
	   "-fullname"	  	  	 
	   file
	   (and corefile (list corefile)))
    (set-process-filter (get-buffer-process (current-buffer)) 'sdcdb-filter)
    (set-process-sentinel (get-buffer-process (current-buffer)) 'sdcdb-sentinel)
    ;; XEmacs change: turn on sdcdb mode after setting up the proc filters
    ;; for the benefit of shell-font.el
    (sdcdb-mode)
    (sdcdb-set-buffer)))

;;;###autoload
(defun sdcdb-with-core (file corefile)
  "Debug a program using a corefile."
  (interactive "fProgram to debug: \nfCore file to use: ")
  (sdcdb file corefile))

(defun sdcdb-set-buffer ()
  (cond ((eq major-mode 'sdcdb-mode)
	 (setq current-sdcdb-buffer (current-buffer))
	 (if (featurep 'eos-toolbar)
	     (set-specifier default-toolbar (cons (current-buffer)
						  sdcdb-toolbar))))))


;; This function is responsible for inserting output from SDCDB
;; into the buffer.
;; Aside from inserting the text, it notices and deletes
;; each filename-and-line-number;
;; that SDCDB prints to identify the selected frame.
;; It records the filename and line number, and maybe displays that file.
(defun sdcdb-filter (proc string)
  (let ((inhibit-quit t))
    (save-current-buffer
     (set-buffer (process-buffer proc))
     (if sdcdb-filter-accumulator
	 (sdcdb-filter-accumulate-marker
	  proc (concat sdcdb-filter-accumulator string))
       (sdcdb-filter-scan-input proc string)))))

(defun sdcdb-filter-accumulate-marker (proc string)
  (setq sdcdb-filter-accumulator nil)
  (if (> (length string) 1)
      (if (= (aref string 1) ?\032)
	  (let ((end (string-match "\n" string)))
	    (if end
		(progn
		  (let* ((first-colon (string-match ":" string 2))
			 (second-colon
			  (string-match ":" string (1+ first-colon))))
		    (setq sdcdb-last-frame
			  (cons (substring string 2 first-colon)
				(string-to-int
				 (substring string (1+ first-colon)
					    second-colon)))))
		  (setq sdcdb-last-frame-displayed-p nil)
		  (sdcdb-filter-scan-input proc
					 (substring string (1+ end))))
	      (setq sdcdb-filter-accumulator string)))
	(sdcdb-filter-insert proc "\032")
	(sdcdb-filter-scan-input proc (substring string 1)))
    (setq sdcdb-filter-accumulator string)))

(defun sdcdb-filter-scan-input (proc string)
  (if (equal string "")
      (setq sdcdb-filter-accumulator nil)
    (let ((start (string-match "\032" string)))
      (if start
	  (progn (sdcdb-filter-insert proc (substring string 0 start))
		 (sdcdb-filter-accumulate-marker proc
					       (substring string start)))
	(sdcdb-filter-insert proc string)))))

(defun sdcdb-filter-insert (proc string)
  (let ((moving (= (point) (process-mark proc)))
	(output-after-point (< (point) (process-mark proc))))
    (save-excursion
      ;; Insert the text, moving the process-marker.
      (goto-char (process-mark proc))
      (insert-before-markers string)
      (set-marker (process-mark proc) (point))
      (sdcdb-maybe-delete-prompt)
      ;; Check for a filename-and-line number.
      (sdcdb-display-frame
       ;; Don't display the specified file
       ;; unless (1) point is at or after the position where output appears
       ;; and (2) this buffer is on the screen.
       (or output-after-point
           (not (get-buffer-window (current-buffer))))
       ;; Display a file only when a new filename-and-line-number appears.
       t))
    (if moving (goto-char (process-mark proc))))

  (let (s)
    (if (and (should-use-dialog-box-p)
	     (setq s (or (string-match " (y or n) *\\'" string)
			 (string-match " (yes or no) *\\'" string))))
	(sdcdb-mouse-prompt-hack (substring string 0 s) (current-buffer))))
  )

(defun sdcdb-mouse-prompt-hack (prompt buffer)
  (popup-dialog-box
   (list prompt
	 (vector "Yes"    (list 'sdcdb-mouse-prompt-hack-answer 't   buffer) t)
	 (vector "No"     (list 'sdcdb-mouse-prompt-hack-answer 'nil buffer) t)
	 nil
	 (vector "Cancel" (list 'sdcdb-mouse-prompt-hack-answer 'nil buffer) t)
	 )))

(defun sdcdb-mouse-prompt-hack-answer (answer buffer)
  (let ((b (current-buffer)))
    (unwind-protect
	(progn
	  (set-buffer buffer)
	  (goto-char (process-mark (get-buffer-process buffer)))
	  (delete-region (point) (point-max))
	  (insert (if answer "yes" "no"))
	  (comint-send-input))
      (set-buffer b))))

(defun sdcdb-sentinel (proc msg)
  (cond ((null (buffer-name (process-buffer proc)))
	 ;; buffer killed
	 ;; Stop displaying an arrow in a source file.
	 ;(setq overlay-arrow-position nil) -- done by kill-buffer-hook
	 (set-process-buffer proc nil))
	((memq (process-status proc) '(signal exit))
	 ;; Stop displaying an arrow in a source file.
         (sdcdb-delete-arrow-extent)
	 ;; Fix the mode line.
	 (setq modeline-process
	       (concat ": sdcdb " (symbol-name (process-status proc))))
	 (let* ((obuf (current-buffer)))
	   ;; save-excursion isn't the right thing if
	   ;;  process-buffer is current-buffer
	   (unwind-protect
	       (progn
		 ;; Write something in *compilation* and hack its mode line,
		 (set-buffer (process-buffer proc))
		 ;; Force mode line redisplay soon
		 (set-buffer-modified-p (buffer-modified-p))
		 (if (eobp)
		     (insert ?\n mode-name " " msg)
		   (save-excursion
		     (goto-char (point-max))
		     (insert ?\n mode-name " " msg)))
		 ;; If buffer and mode line will show that the process
		 ;; is dead, we can delete it now.  Otherwise it
		 ;; will stay around until M-x list-processes.
		 (delete-process proc))
	     ;; Restore old buffer, but don't restore old point
	     ;; if obuf is the sdcdb buffer.
	     (set-buffer obuf))))))


(defun sdcdb-refresh (&optional arg)
  "Fix up a possibly garbled display, and redraw the arrow."
  (interactive "P")
  (recenter arg)
  (sdcdb-display-frame))

(defun sdcdb-display-frame (&optional nodisplay noauto)
  "Find, obey and delete the last filename-and-line marker from SDCDB.
The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
Obeying it means displaying in another window the specified file and line."
  (interactive)
  (sdcdb-set-buffer)
  (and sdcdb-last-frame (not nodisplay)
       sdcdb-display-mode
       (or (not sdcdb-last-frame-displayed-p) (not noauto))
       (progn (sdcdb-display-line (car sdcdb-last-frame) (cdr sdcdb-last-frame))
	      (setq sdcdb-last-frame-displayed-p t))))

;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
;; and that its line LINE is visible.
;; Put the overlay-arrow on the line LINE in that buffer.

(defun sdcdb-display-line (true-file line &optional select-method)
  ;; FILE to display
  ;; LINE number to highlight and make visible
  ;; SELECT-METHOD 'source, 'debugger, or 'none.  (default is 'debugger)
  (and (null select-method) (setq select-method 'debugger))
  (let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen
	 (pop-up-windows t)
	 (source-buffer (find-file-noselect true-file))
	 (source-window (display-buffer source-buffer))
	 (debugger-window (get-buffer-window current-sdcdb-buffer))
         (extent sdcdb-arrow-extent)
	 pos)
    ;; XEmacs change: make sure we find a window displaying the source file
    ;; even if we are already sitting in it when a breakpoint is hit.
    ;; Otherwise the t argument to display-buffer will prevent it from being
    ;; displayed.
    (save-excursion 
      (cond ((eq select-method 'debugger)
	     ;; might not already be displayed
	     (setq debugger-window (display-buffer current-sdcdb-buffer))
	     (select-window debugger-window))
	    ((eq select-method 'source)
	     (select-window source-window))))
    (and extent
	 (not (eq (extent-object extent) source-buffer))
	 (setq extent (delete-extent extent)))
    (or extent
        (progn
          (setq extent (make-extent 1 1 source-buffer))
          (set-extent-face extent 'sdcdb-arrow-face)
	  (set-extent-begin-glyph extent sdcdb-arrow-glyph)
          (set-extent-begin-glyph-layout extent 'whitespace)
          (set-extent-priority extent 2000)
          (setq sdcdb-arrow-extent extent)))
    (save-current-buffer
      (set-buffer source-buffer)
      (save-restriction
	(widen)
	(goto-line line)
	(set-window-point source-window (point))
	(setq pos (point))
        (end-of-line)
        (set-extent-endpoints extent pos (point))
        (run-hook-with-args 'sdcdb-arrow-extent-hooks extent))
      (cond ((or (< pos (point-min)) (> pos (point-max)))
	     (widen)
	     (goto-char pos))))
    ;; Added by Stig.  It caused lots of problems for several users
    ;; and since its purpose is unclear it is getting commented out.
    ;;(and debugger-window
    ;; (set-window-point debugger-window pos))
    ))

(defun sdcdb-call (command)
  "Invoke sdcdb COMMAND displaying source in other window."
  (interactive)
  (goto-char (point-max))
  ;; Record info on the last prompt in the buffer and its position.
  ;; This is used in  sdcdb-maybe-delete-prompt
  ;; to prevent multiple prompts from accumulating.
  (save-excursion
    (goto-char (process-mark (get-buffer-process current-sdcdb-buffer)))
    (let ((pt (point)))
      (beginning-of-line)
      (setq sdcdb-delete-prompt-marker
	    (if (= (point) pt)
		nil
	      (list (point-marker) (- pt (point))
		    (buffer-substring (point) pt))))))
  (sdcdb-set-buffer)
  (process-send-string (get-buffer-process current-sdcdb-buffer)
	       (concat command "\n")))

(defun sdcdb-maybe-delete-prompt ()
  (if sdcdb-delete-prompt-marker
      ;; Get the string that we used as the prompt before.
      (let ((prompt (nth 2 sdcdb-delete-prompt-marker))
	    (length (nth 1 sdcdb-delete-prompt-marker)))
	;; Position after it.
	(goto-char (+ (car sdcdb-delete-prompt-marker) length))
	;; Delete any duplicates of it which follow right after.
	(while (and (<= (+ (point) length) (point-max))
		    (string= prompt
			     (buffer-substring (point) (+ (point) length))))
	  (delete-region (point) (+ (point) length)))
	;; If that didn't take us to where output is arriving,
	;; we have encountered something other than a prompt,
	;; so stop trying to delete any more prompts.
	(if (not (= (point)
		    (process-mark (get-buffer-process current-sdcdb-buffer))))
	    (progn
	      (set-marker (car sdcdb-delete-prompt-marker) nil)
	      (setq sdcdb-delete-prompt-marker nil))))))

(defun sdcdb-break (temp)
  "Set SDCDB breakpoint at this source line.  With ARG set temporary breakpoint."
  (interactive "P")
  (let* ((file-name (file-name-nondirectory buffer-file-name))
	 (line (save-restriction
		 (widen)
		 (beginning-of-line)
		 (1+ (count-lines 1 (point)))))
	 (cmd (concat (if temp "tbreak " "break ") file-name ":"
		      (int-to-string line))))
    (set-buffer current-sdcdb-buffer)
    (goto-char (process-mark (get-buffer-process current-sdcdb-buffer)))
    (delete-region (point) (point-max))
    (insert cmd)
    (comint-send-input)
    ;;(process-send-string (get-buffer-process current-sdcdb-buffer) cmd)
    ))

(defun sdcdb-clear ()
  "Set SDCDB breakpoint at this source line."
  (interactive)
  (let* ((file-name (file-name-nondirectory buffer-file-name))
	 (line (save-restriction
		 (widen)
		 (beginning-of-line)
		 (1+ (count-lines 1 (point)))))
	 (cmd (concat "clear " file-name ":"
		      (int-to-string line))))
    (set-buffer current-sdcdb-buffer)
    (goto-char (process-mark (get-buffer-process current-sdcdb-buffer)))
    (delete-region (point) (point-max))
    (insert cmd)
    (comint-send-input)
    ;;(process-send-string (get-buffer-process current-sdcdb-buffer) cmd)
    ))

(defun sdcdb-read-address()
  "Return a string containing the core-address found in the buffer at point."
  (save-excursion
   (let ((pt (point)) found begin)
     (setq found (if (search-backward "0x" (- pt 7) t)(point)))
     (cond (found (forward-char 2)
		  (buffer-substring found
				    (progn (re-search-forward "[^0-9a-f]")
					   (forward-char -1)
					   (point))))
	   (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1)
				 (point)))
	      (forward-char 1)
	      (re-search-forward "[^0-9]")
	      (forward-char -1)
	      (buffer-substring begin (point)))))))


(defvar sdcdb-commands nil
  "List of strings or functions used by send-sdcdb-command.
It is for customization by you.")

(defun send-sdcdb-command (arg)

  "This command reads the number where the cursor is positioned.  It
 then inserts this ADDR at the end of the sdcdb buffer.  A numeric arg
 selects the ARG'th member COMMAND of the list sdcdb-print-command.  If
 COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise
 (funcall COMMAND ADDR) is inserted.  eg. \"p (rtx)%s->fld[0].rtint\"
 is a possible string to be a member of sdcdb-commands.  "


  (interactive "P")
  (let (comm addr)
    (if arg (setq comm (nth arg sdcdb-commands)))
    (setq addr (sdcdb-read-address))
    (if (eq (current-buffer) current-sdcdb-buffer)
	(set-mark (point)))
    (cond (comm
	   (setq comm
		 (if (stringp comm) (format comm addr) (funcall comm addr))))
	  (t (setq comm addr)))
    (switch-to-buffer current-sdcdb-buffer)
    (goto-char (point-max))
    (insert comm)))

(fset 'sdcdb-control-c-subjob 'comint-interrupt-subjob)

;(defun sdcdb-control-c-subjob ()
;  "Send a Control-C to the subprocess."
;  (interactive)
;  (process-send-string (get-buffer-process (current-buffer))
;		       "\C-c"))

(defun sdcdb-toolbar-break ()
  (interactive)
  (save-excursion
    (message (car sdcdb-last-frame))
    (set-buffer (find-file-noselect (car sdcdb-last-frame)))
    (sdcdb-break nil)))

(defun sdcdb-toolbar-clear ()
  (interactive)
  (save-excursion
    (message (car sdcdb-last-frame))
    (set-buffer (find-file-noselect (car sdcdb-last-frame)))
    (sdcdb-clear)))

(provide 'sdcdb)

(require 'sdcdb "sdcdb")			; NOT gud!  (yet...)

(defvar sdcdbsrc-active-p t
  "*Set to nil if you do not want source files put in sdcdbsrc-mode")

(defvar sdcdbsrc-call-p nil
  "True if sdcdb command issued from a source buffer")

(defvar sdcdbsrc-associated-buffer nil
  "Buffer name of attached sdcdb process")

(defvar sdcdbsrc-mode nil
  "Indicates whether buffer is in sdcdbsrc-mode or not")
(make-variable-buffer-local 'sdcdbsrc-mode)

(defvar sdcdbsrc-global-mode nil
  "Indicates whether global sdcdbsrc bindings are in effect or not")

(defvar sdcdb-prompt-pattern "^[^)#$%>\n]*[)#$%>] *"
  "A regexp for matching the end of the sdcdb prompt")

(defvar eos::toolbar-toggle-srcmode
  
  (toolbar-make-button-list
   (expand-file-name "recycle.xbm" eos::toolbar-icon-directory))
  "A Run icon pair.")
;;; bindings

(defvar sdcdbsrc-global-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-name map 'sdcdbsrc-global-map)
    (define-key map "\C-x " 'sdcdb-break)
    (define-key map "\M-\C-t" 'sdcdbsrc-mode)
    (define-key map "\M-\C-g" 'sdcdbsrc-goto-sdcdb)
    (define-key map "\M-m"    'sdcdbsrc-srcmode)
    ;; middle button to select and print expressions...
    (define-key map '(meta button2)       'sdcdbsrc-print-csexp)
    (define-key map '(meta shift button2) 'sdcdbsrc-*print-csexp)
    ;; left button to position breakpoints
    (define-key map '(meta button1)       'sdcdbsrc-set-break)
    (define-key map '(meta shift button1) 'sdcdbsrc-set-tbreak-continue)
    map)
  "Global minor keymap that is active whenever sdcdbsrc is running.")

(add-minor-mode 'sdcdbsrc-global-mode " SdcdbGlobal" sdcdbsrc-global-map)

(defvar sdcdbsrc-mode-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    (set-keymap-name map 'sdcdbsrc-mode-map)
    ;; inherit keys from global sdcdbsrc map just in case that somehow gets turned off.
    (set-keymap-parents map (list sdcdbsrc-global-map))
    (define-key map "\C-x\C-q" 'sdcdbsrc-mode) ; toggle read-only
    (define-key map "\C-c\C-c" 'sdcdbsrc-mode)
    (define-key map "b" 'sdcdb-break)
    (define-key map "g" 'sdcdbsrc-goto-sdcdb)
    (define-key map "!" 'sdcdbsrc-goto-sdcdb)
    (define-key map "p" 'sdcdb-print-c-sexp)
    (define-key map "*" 'sdcdb-*print-c-sexp)
    (define-key map "?" 'sdcdb-whatis-c-sexp)
    (define-key map "R" 'sdcdbsrc-reset)
    map)
  "Minor keymap for buffers in sdcdbsrc-mode")

(add-minor-mode 'sdcdbsrc-mode " SdcdbSrc" sdcdbsrc-mode-map)

(defvar sdcdbsrc-toolbar
  '([eos::toolbar-stop-at-icon
     sdcdb-break
     t
     "Stop at selected position"]
    [eos::toolbar-stop-in-icon
     sdcdb-break
     t
     "Stop in function whose name is selected"]
    [eos::toolbar-clear-at-icon
     sdcdb-clear
     t
     "Clear at selected position"]
    [eos::toolbar-evaluate-icon
     sdcdb-print-c-sexp
     t
     "Evaluate selected expression; shows in separate XEmacs frame"]    
    [eos::toolbar-run-icon
     sdcdbsrc-run
     t
     "Run current program"]
    [eos::toolbar-cont-icon
     sdcdbsrc-cont
     t
     "Continue current program"]
    [eos::toolbar-step-into-icon
     sdcdbsrc-step
     t
     "Step into (aka step)"]
    [eos::toolbar-step-over-icon
     sdcdbsrc-next
     t
     "Step over (aka next)"]       
    [eos::toolbar-fix-icon
     nil
     nil
     "Fix (not available with sdcdb)"]    
    [eos::toolbar-build-icon
     toolbar-compile
     t
     "Build (aka make -NYI)"]
    [eos::toolbar-toggle-srcmode
     sdcdbsrc-srcmode
     t
     "Toggle Source C <-> Asm"]
    ))

(defmacro def-sdcdb-from-src (sdcdb-command key &optional doc &rest forms)
  "Create a function that will call SDCDB-COMMAND with KEY."
  (let* ((fname (format "sdcdbsrc-%s" sdcdb-command))
	 (cstr (list 'if 'arg
		     (list 'format "%s %s" sdcdb-command '(prefix-numeric-value arg))
		     sdcdb-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 'sdcdb-call-from-src cstr))
		  forms)
	   (list 'define-key 'sdcdbsrc-mode-map key  (list 'quote fun)))))

(def-sdcdb-from-src "step"   "s" "Step one instruction in src"
  (sdcdb-delete-arrow-extent))
(def-sdcdb-from-src "stepi"  "i" "Step one source line (skip functions)"
  (sdcdb-delete-arrow-extent))
(def-sdcdb-from-src "cont"   "c" "Continue with display"
  (sdcdb-delete-arrow-extent))
(def-sdcdb-from-src "down"   "d" "Go down N stack frames (numeric arg) ")
(def-sdcdb-from-src "up"     "u" "Go up N stack frames (numeric arg)")
(def-sdcdb-from-src "finish" "f" "Finish frame")
(def-sdcdb-from-src "where"  "w" "Display (N frames of) backtrace")
(def-sdcdb-from-src "next"   "n" "Step one line with display"
  (sdcdb-delete-arrow-extent))
(def-sdcdb-from-src "run"    "r" "Run program from start"
  (sdcdb-delete-arrow-extent))
(def-sdcdb-from-src "return" "R" "Return from selected stack frame")
(def-sdcdb-from-src "disable" "x" "Disable all breakpoints")
(def-sdcdb-from-src "delete" "X" "Delete all breakpoints")
(def-sdcdb-from-src "quit"   "Q" "Quit sdcdb."
  (sdcdb-delete-arrow-extent))
(def-sdcdb-from-src "info locals" "l" "Show local variables")
(def-sdcdb-from-src "info break"  "B" "Show breakpoints")
(def-sdcdb-from-src ""  "\r" "Repeat last command")
(def-sdcdb-from-src "frame"  "m" "Show frame if no arg, with arg go to frame")

;;; code

;;;###autoload
(defun sdcdbsrc (path &optional core-or-pid)
  "Activates a sdcdb session with sdcdbsrc-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)

  (sdcdb path core-or-pid)
  (local-set-key 'button2 'sdcdbsrc-select-or-yank)
  (setq mode-motion-hook 'sdcdbsrc-mode-motion)
  ;; XEmacs change:
  (make-local-hook 'kill-buffer-hook)
  (add-hook 'kill-buffer-hook 'sdcdbsrc-reset nil t))

(defun sdcdbsrc-global-mode ()
  ;; this can be used as a hook for sdcdb-mode....
  (or current-sdcdb-buffer
      (and (eq major-mode 'sdcdb-mode)	; doesn't work w/ energize yet
	   (setq current-sdcdb-buffer (current-buffer))
	   ;; XEmacs change:
	   (progn
	     (make-local-hook 'kill-buffer-hook)
	     (add-hook 'kill-buffer-hook 'sdcdbsrc-reset nil t)))
      (error "Cannot determine current-sdcdb-buffer"))
;;;   (set-process-filter 
;;;    (get-buffer-process current-sdcdb-buffer) 'sdcdbsrc-mode-filter)
;;;   (set-process-sentinel 
;;;    (get-buffer-process current-sdcdb-buffer) 'sdcdbsrc-mode-sentinel)
  ;; sdcdbsrc-global-mode was set to t here but that tended to piss
  ;; people off
  (setq sdcdbsrc-global-mode nil
	sdcdbsrc-active-p	   t
	sdcdbsrc-call-p	   nil
	sdcdbsrc-mode	   nil)
  (message "Gbd source mode active"))
 
(add-hook 'sdcdb-mode-hook 'sdcdbsrc-global-mode)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sdcdb Source minor mode.
;;; 

(defvar sdcdbsrc-associated-buffer nil
  "The sdcdb buffer to send commands to.")
(defvar sdcdbsrc-initial-readonly  'undefined
  "read-only status of buffer when not in sdcdbsrc-mode")
(defvar sdcdbsrc-old-toolbar nil
  "saved toolbar for buffer")

(defun sdcdbsrc-mode (arg &optional quiet)
  "Minor mode for interacting with sdcdb from a c source file.
With arg, turn sdcdbsrc-mode on iff arg is positive.  In sdcdbsrc-mode,
you may send an associated sdcdb buffer commands from the current buffer
containing c source code."
  (interactive "P")
  (setq sdcdbsrc-mode
	(if (null arg)
	    (not sdcdbsrc-mode)
	  (> (prefix-numeric-value arg) 0)))

  (cond (sdcdbsrc-mode
	 (cond ((not (local-variable-p 'sdcdbsrc-initial-readonly (current-buffer)))
		(set (make-local-variable 'sdcdbsrc-initial-readonly)
		     buffer-read-only)
		(set (make-local-variable 'sdcdbsrc-associated-buffer)
		     current-sdcdb-buffer)
		(if (featurep 'toolbar)
		    (set (make-local-variable 'sdcdbsrc-old-toolbar)
			 (specifier-specs default-toolbar (current-buffer))))
		)
	       )
	 (if (featurep 'toolbar)
	     (set-specifier default-toolbar (cons (current-buffer)
						  sdcdbsrc-toolbar)))
	 (setq buffer-read-only t)
	 (or quiet (message "Entering sdcdbsrc-mode...")))
	(t
	 (and (local-variable-p 'sdcdbsrc-initial-readonly (current-buffer))
	      (progn
		(if (featurep 'toolbar)
		    (if sdcdbsrc-old-toolbar
			(set-specifier default-toolbar
				       (cons (current-buffer)
					     sdcdbsrc-old-toolbar))
		      (remove-specifier default-toolbar (current-buffer))))
		(kill-local-variable 'sdcdbsrc-old-toolbar)
		(setq buffer-read-only sdcdbsrc-initial-readonly)
		(kill-local-variable 'sdcdbsrc-initial-readonly)
		(kill-local-variable 'sdcdbsrc-associated-buffer)
		))
	 (or quiet (message "Exiting sdcdbsrc-mode..."))))
  (redraw-modeline t))

;;
;; Sends commands to sdcdb process.

(defun sdcdb-call-from-src (command)
  "Send associated sdcdb process COMMAND displaying source in this window."
  (setq sdcdbsrc-call-p t)
    (let ((src-win (selected-window))
	  (buf (or sdcdbsrc-associated-buffer current-sdcdb-buffer)))
      (or (buffer-name buf)
	  (error "SDCDB buffer deleted"))
      (pop-to-buffer buf)
      (goto-char (point-max))
      (beginning-of-line)
      ;; Go past sdcdb prompt 
      (re-search-forward
       sdcdb-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)
      (select-window src-win)
      ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Define Commands for SDCDB 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-sdcdbsrc-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 'sdcdbsrc 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 sdcdb-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 sdcdb's various ways of displaying a breakpoint")

(defun sdcdbsrc-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 'sdcdbsrc-display
	    (match-string 1 string)
	    (string-to-int (match-string 2 string)))))

(defconst sdcdb-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 sdcdb stack frame and all continuation lines.
subex 1 is frame number.")

(defun sdcdbsrc-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) 'sdcdbsrc)
	    nil
	  (nuke-mode-motion-extent)
	  (cond ((looking-at-any sdcdb-breakpoint-patterns)
		 (set-sdcdbsrc-mode-motion-extent
		  (match-beginning 0)
		  (match-end 0)
		  (sdcdbsrc-make-breakpoint-action (match-string 0))))
		((looking-at sdcdb-stack-frame-pattern)
		 (set-sdcdbsrc-mode-motion-extent
		  (match-beginning 0)
		  (match-end 0)
		  (list 'sdcdbsrc-frame
			(string-to-int (match-string 1)))))
		)))
      )))
  
(defun sdcdbsrc-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-object 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-object extent))
       (> (point) (extent-start-position extent))
       (>= (extent-end-position extent) (point))))

(defun sdcdbsrc-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 sdcdb-print-format ""
  "Set this variable to a valid format string to print c-sexps in a
different way (hex,octal, etc).")

(defun sdcdb-print-c-sexp ()
  "Find the nearest c-mode sexp. Send it to sdcdb with print command."
  (interactive)
  (let* ((tag (find-c-sexp))
	 (command (concat "print " sdcdb-print-format tag)))
    (sdcdb-call-from-src command)))

(defun sdcdbsrc-srcmode ()
  "Toggle between assembler & C source modes."
  (sdcdb-call-from-src "set srcmode"))

(defun sdcdb-*print-c-sexp ()
  "Find the nearest c-mode sexp. Send it to sdcdb with the print * command."
  (interactive)
  (let* ((tag (find-c-sexp))
	(command (concat "print " sdcdb-print-format "*"  tag)))
    (sdcdb-call-from-src  command)))
 
(defun sdcdb-whatis-c-sexp ()
  "Find the nearest c-mode sexp. Send it to sdcdb with the whatis command. "
  (interactive)
  (let* ((tag (sdcdbsrc-selection-or-sexp))
	 (command (concat "ptype " tag)))
    (sdcdb-call-from-src command)))

(defun sdcdbsrc-goto-sdcdb ()
  "Hop back and forth between the sdcdb interaction buffer and the sdcdb source
buffer.  "
  ;; by Stig@hackvan.com
  (interactive)
  (let ((gbuf (or sdcdbsrc-associated-buffer current-sdcdb-buffer)))
    (cond ((eq (current-buffer) gbuf)
	   (and sdcdb-arrow-extent
		(extent-object sdcdb-arrow-extent)
		(progn (pop-to-buffer (extent-object sdcdb-arrow-extent))
		       (goto-char (extent-start-position sdcdb-arrow-extent)))))
	  ((buffer-name gbuf) (pop-to-buffer gbuf))
	  ((y-or-n-p "No debugger.  Start a new one? ")
	         (call-interactively 'sdcdbsrc))
	  (t (error "No sdcdb buffer."))
	  )))

(defvar sdcdbsrc-last-src-buffer nil)

(defun sdcdbsrc-goto-src ()
  (interactive)
  (let* ((valid (and sdcdbsrc-last-src-buffer
		     (memq sdcdbsrc-last-src-buffer (buffer-list))))
	 (win (and valid
		   (get-buffer-window sdcdbsrc-last-src-buffer))))
    (cond (win (select-window win))
	  (valid (pop-to-buffer sdcdbsrc-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 sdcdbsrc-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 
	 (sdcdbsrc-get-csexp-at-click ee))
	(t
	 (find-c-sexp))
	))

(defun sdcdbsrc-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 sdcdbsrc-print-csexp (&optional ee)
  (interactive) 
  (or ee (setq ee current-mouse-event))
  (sdcdb-call-from-src
	 (concat "print "  sdcdb-print-format (sdcdbsrc-selection-or-sexp ee))))

(defun sdcdbsrc-*print-csexp (&optional ee)
  (interactive) 
  (or ee (setq ee current-mouse-event))
  (sdcdb-call-from-src
   (concat "print *"  sdcdb-print-format (sdcdbsrc-selection-or-sexp ee))))

;; (defun sdcdbsrc-print-region (arg)
;;   (let (( command  (concat "print " sdcdb-print-format (x-get-cut-buffer))))
;;     (sdcdb-call-from-src command)))
;; 
;; (defun sdcdbsrc-*print-region (arg)
;;   (let (( command  (concat "print *" sdcdb-print-format (x-get-cut-buffer))))
;;     (sdcdb-call-from-src command)))

(defun sdcdbsrc-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 sdcdbsrc-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 sdcdb-break, so this only needs to work with mouse clicks.
  (interactive "e") 
  (sdcdb-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"))
	     (- (sdcdbsrc-file:lno) 1)
	     ))))

(defun sdcdbsrc-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))
  (sdcdb-call-from-src (concat "tbreak " (sdcdbsrc-file:lno)))
  (sdcdb-call-from-src "c"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions extended from sdcdb.el for sdcdbsrc.
;;
;; sdcdbsrc-set-buffer - added a check to set buffer to sdcdbsrc-associated-buffer
;;                  to handle multiple sdcdb sessions being driven from src
;;                  files.

(require 'advice)

(defadvice sdcdb-set-buffer (after sdcdbsrc activate) ; ()
  "Advised to work from a source buffer instead of just the sdcdb buffer."
  ;; by Stig@hackvan.com
  ;; the operations below have tests which are disjoint from the tests in
  ;; the original `sdcdb-set-buffer'.  Current-sdcdb-buffer cannot be set twice.
  (and sdcdbsrc-call-p
       sdcdbsrc-associated-buffer
       (setq current-sdcdb-buffer sdcdbsrc-associated-buffer)))

(defadvice sdcdb-display-line (around sdcdbsrc activate)
  ;; (true-file line &optional select-method)
  "Advised to select the source buffer instead of the sdcdb-buffer"
  ;; by Stig@hackvan.com
  (ad-set-arg 2 'source) ; tell it not to select the sdcdb window
  ad-do-it
  (save-excursion
    (let* ((buf (extent-object sdcdb-arrow-extent))
	   (win (get-buffer-window buf)))
      (setq sdcdbsrc-last-src-buffer buf)
      (select-window win)
      (set-window-point win (extent-start-position sdcdb-arrow-extent))
      (set-buffer buf))
    (and sdcdbsrc-active-p
	 (not sdcdbsrc-mode)
	 (not (eq (current-buffer) current-sdcdb-buffer))
	 (sdcdbsrc-mode 1))))

(defadvice sdcdb-filter (after sdcdbsrc activate) ; (proc string)
  ;; by Stig@hackvan.com
  ;; if we got a sdcdb prompt and it wasn't a sdcdbsrc command, then it's sdcdb
  ;; hitting a breakpoint or having a core dump, so bounce back to the sdcdb
  ;; window.
  (let* ((selbuf (window-buffer (selected-window)))
	 win)
    ;; if we're at a sdcdb prompt, then display the buffer
    (and (save-match-data (string-match sdcdb-prompt-pattern (ad-get-arg 1)))
	 (prog1
	     (not sdcdbsrc-call-p)
	   (setq sdcdbsrc-call-p nil))
	 (setq win (display-buffer current-sdcdb-buffer))
	 ;; if we're not in either the source buffer or the sdcdb buffer,
	 ;; then select the window too...
	 (not (eq selbuf current-sdcdb-buffer))
	 (not (eq selbuf sdcdbsrc-last-src-buffer))
	 (progn
	   (ding nil 'warp)
	   (select-window win)))
    ))

(defun sdcdbsrc-reset ()
  ;; tidy house and turn off sdcdbsrc-mode in all buffers
  ;; by Stig@hackvan.com
  (sdcdb-delete-arrow-extent)
  (setq sdcdbsrc-global-mode nil)
  (mapcar #'(lambda (buffer) 
	      (set-buffer buffer)
	      (cond ((eq sdcdbsrc-associated-buffer current-sdcdb-buffer)
		     (sdcdbsrc-mode -1))))
	  (buffer-list)))

(defadvice sdcdb-sentinel (after sdcdbsrc freeze) ; (proc msg)
  ;; by Stig@hackvan.com
  (sdcdbsrc-reset)
  (message "Sdcdbsrc finished"))

(provide 'sdcdbsrc)
cc1111 2.9.0-7 / usr / share / emacs / site-lisp / sdcc-ucsim / sdcdbsrc.el
