Commits

Anonymous committed 911e658

Created

  • Participants
  • Tags xemacs

Comments (0)

Files changed (21)

+1998-01-04  SL Baur  <steve@altair.xemacs.org>
+
+	* dumped-lisp.el: New file from standard dumped-lisp.el.
+
+1997-12-24  SL Baur  <steve@altair.xemacs.org>
+
+	* Makefile: Created.
+
+# Makefile for Sun specific lisp code
+
+# 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.
+
+VERSION = 1.03
+PACKAGE = Sun
+PKG_TYPE = regular
+REQUIRES = cc-mode xemacs-base
+CATEGORY = libs
+
+ELCS = eos.elc sccs.elc sun-eos-browser.elc sun-eos-common.elc \
+	sun-eos-debugger-extra.elc sun-eos-debugger.elc \
+	sun-eos-editor.elc sun-eos-init.elc sun-eos-load.elc \
+	sun-eos-menubar.elc sun-eos-toolbar.elc sun-eos.elc \
+	sunpro-init.elc sunpro-keys.elc sunpro-menubar.elc \
+	sunpro-sparcworks.elc
+
+include ../../XEmacs.rules
+
+all:: $(ELCS) auto-autoloads.elc
+
+srckit: srckit-std
+
+binkit: binkit-sourceonly
+### Makefile --- The makefile to build EOS
+
+## Copyright (C) 1995 Sun Microsystems, Inc.
+
+## Maintainer:	Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
+## Author:      Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
+
+## Keywords:	SPARCworks EOS Era on SPARCworks make makefile
+
+### Commentary:
+
+## Please send feedback to eduardo.pelegri-llopart@eng.sun.com
+
+### Code:
+
+# what emacs is called on your system
+EMACS = ../../src/xemacs
+
+# compile with noninteractive and relatively clean environment
+BATCHFLAGS = -batch -vanilla -eval "(push \"$$(pwd)\" load-path)"
+
+# files that contain variables and macros that everything else depends on
+CORE = sun-eos-common.el
+
+OBJECTS = \
+	sun-eos-browser.elc sun-eos-common.elc sun-eos-debugger-extra.elc  \
+	sun-eos-debugger.elc sun-eos-editor.elc sun-eos-init.elc \
+	sun-eos-menubar.elc sun-eos-toolbar.elc sun-eos-load.elc
+
+SOURCES = \
+	sun-eos-browser.el sun-eos-common.el sun-eos-debugger-extra.el  \
+	sun-eos-debugger.el sun-eos-editor.el sun-eos-init.el \
+	sun-eos-menubar.el sun-eos-toolbar.el sun-eos-load.el
+
+EXTRA = custom-load.elc
+
+all:	$(OBJECTS)
+
+clean:
+	rm -f $(OBJECTS)
+
+custom-load.elc: auto-autoloads.el
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile custom-load.el
+
+sun-eos-browser.elc: sun-eos-browser.el $(CORE)
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-browser.el
+
+sun-eos-debugger.elc: sun-eos-debugger.el $(CORE)
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-debugger.el
+
+sun-eos-debugger-extra.elc: sun-eos-debugger-extra.el $(CORE)
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-debugger-extra.el
+
+sun-eos-editor.elc: sun-eos-editor.el $(CORE)
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-editor.el
+
+sun-eos-toolbar.elc: sun-eos-toolbar.el $(CORE)
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-toolbar.el
+
+sun-eos-menubar.elc: sun-eos-menubar.el $(CORE)
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-menubar.el
+
+sun-eos-common.elc: sun-eos-common.el
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-common.el
+
+sun-eos-init.elc: sun-eos-init.el
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-init.el
+
+sun-eos-load.elc: sun-eos-load.el
+	${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-load.el
+
+autoloads: custom-load.el
+
+custom-load.el: $(SOURCES)
+	$(EMACS) -batch -q -no-site-file \
+		-eval '(setq autoload-target-directory "'`pwd`'/")' \
+		-l autoload \
+		-f batch-update-autoloads $?
+
+### Makefile ends here
+(setq package-lisp
+      '(
+	#+sparcworks "cc-mode" ; Requires cc-mode package
+	#+sparcworks "sunpro-init"
+	#+sparcworks "ring"
+	#+sparcworks "comint" ; Requires comint package
+	#+sparcworks "annotations"
+))
+;;; eos.el --- Intereactively loads the XEmacs/SPARCworks interface
+;;; this file is an alias for sun-eos.el
+
+;; Copyright (C) 1995  Sun Microsystems, Inc.
+
+;; Maintainer:	Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
+;; Author:      Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
+
+;; Keywords:	SPARCworks EOS Era on SPARCworks load
+
+;;; Commentary:
+
+;; If manual loading is desired...
+;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com
+
+;;; Code:
+
+(load "sun-eos-load.el")
+(eos::start)
+
+;;; sun-eos-eos.el ends here
+(Sun
+  (version VERSION
+   description "Support for Sparcworks."
+   filename FILENAME
+   md5sum MD5SUM
+   size SIZE
+   provides (sccs eos-browser eos-common eos-debugger eos-debugger eos-editor eos-init eos-load eos-menubar eos-toolbar sunpro)
+   requires (REQUIRES)
+   type regular
+))
+;; sccs.el -- easy-to-use SCCS control from within Emacs
+;;	@(#)sccs.el	3.5
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY.  No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing.  Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License.   A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities.  It should be in a
+;; file named COPYING.  Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+;;;
+;;; Synched up with: Not in FSF.
+;;; #### Chuck -- I say remove this piece of crap!  Use VC instead.
+
+;;; Author: Eric S. Raymond (eric@snark.thyrsus.com).
+;;;
+;;; It is distantly derived from an rcs mode written by Ed Simpson
+;;; ({decvax, seismo}!mcnc!duke!dukecdu!evs) in years gone by
+;;; and revised at MIT's Project Athena.
+;;; 
+;;; Modified: Made to work for Lucid Emacs by persons who don't know SCCS.
+;;; Modified: Ben Wing (Ben.Wing@eng.sun.com) -- fixed up and redid menus
+;;;
+
+;; User options
+
+(defvar sccs-bin-directory nil
+  "*Directory that holds the SCCS executables.
+Initialized automatically the first time you execute an SCCS command,
+if not already set.")
+
+(defvar sccs-max-log-size 510
+  "*Maximum allowable size of an SCCS log message.")
+(defvar sccs-diff-command '("diff" "-c")
+  "*The command/flags list to be used in constructing SCCS diff commands.")
+(defvar sccs-headers-wanted '("\%\W\%")
+  "*SCCS header keywords to be inserted when sccs-insert-header is executed.")
+(defvar sccs-insert-static t
+  "*Insert a static character string when inserting SCCS headers in C mode.")
+(defvar sccs-mode-expert nil
+  "*Treat user as expert; suppress yes-no prompts on some things.")
+
+;; Vars the user doesn't need to know about.
+
+(defvar sccs-log-entry-mode nil)
+(defvar sccs-current-major-version nil)
+
+;; Some helper functions
+
+(defun sccs-name (file &optional letter)
+  "Return the sccs-file name corresponding to a given file."
+  (format "%sSCCS/%s.%s"
+	  (concat (file-name-directory (expand-file-name file)))
+	  (or letter "s")
+	  (concat (file-name-nondirectory (expand-file-name file)))))
+
+(defun sccs-lock-info (file index)
+   "Return the nth token in a file's SCCS-lock information."
+   (let
+       ((pfile (sccs-name file "p")))
+     (and (file-exists-p pfile)
+	  (save-excursion
+	    (find-file pfile)
+	    (auto-save-mode nil)
+	    (goto-char (point-min))
+	    (replace-string " " "\n")
+	    (goto-char (point-min))
+	    (forward-line index)
+	    (prog1
+		(buffer-substring (point) (progn (end-of-line) (point)))
+	      (set-buffer-modified-p nil)
+	      (kill-buffer (current-buffer)))
+	    )
+	  )
+     )
+   )
+
+(defun sccs-locking-user (file)
+  "Return the name of the person currently holding a lock on FILE.
+Return nil if there is no such person."
+  (sccs-lock-info file 2)
+  )
+
+(defun sccs-locked-revision (file)
+  "Return the revision number currently locked for FILE, nil if none such."
+  (sccs-lock-info file 1)
+  )
+
+(defmacro error-occurred (&rest body)
+  (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
+
+;; There has *got* to be a better way to do this...
+(defmacro chmod (perms file)
+  (list 'call-process "chmod" nil nil nil perms file))
+
+(defun sccs-save-vars (sid)
+  (save-excursion
+    (find-file "SCCS/emacs-vars.el")
+    (erase-buffer)
+    (insert "(setq sccs-current-major-version \"" sid "\")")
+    (basic-save-buffer)
+    )
+  )
+
+(defun sccs-load-vars ()
+  (if (error-occurred (load-file "SCCS/emacs-vars.el"))
+      (setq sccs-current-major-version "1"))
+)
+
+(defun sccs-init-bin-directory ()
+  (setq sccs-bin-directory
+	(cond ((file-executable-p "/usr/sccs/unget") "/usr/sccs")
+	      ((file-executable-p "/usr/bin/unget") "/usr/bin")
+	      ((file-directory-p "/usr/sccs") "/usr/sccs")
+	      ((file-directory-p "/usr/bin/sccs") "/usr/bin/sccs")
+	      (t "/usr/bin"))))
+
+;; The following functions do most of the real work
+
+(defun sccs-get-version (file sid)
+   "For the given FILE, retrieve a copy of the version with given SID.
+The text is retrieved into a tempfile.  Return the tempfile name, or nil
+if no such version exists."
+  (let (oldversion vbuf)
+    (setq oldversion (sccs-name file (or sid "new")))
+    (setq vbuf (create-file-buffer oldversion))
+    (prog1
+	(if (not (error-occurred
+	     (sccs-do-command vbuf "get" file
+			      (and sid (concat "-r" sid))
+			      "-p" "-s")))
+	    (save-excursion
+	      (set-buffer vbuf)
+	      (write-region (point-min) (point-max) oldversion t 0)
+	      oldversion)
+	  )
+      (kill-buffer vbuf)
+      )
+    )
+  )
+
+(defun sccs-mode-line (file)
+  "Set the mode line for an SCCS buffer.
+FILE is the file being visited to put in the modeline."
+  (setq mode-line-process
+	(if (file-exists-p (sccs-name file "p"))
+	    (format " <SCCS: %s>" (sccs-locked-revision file))
+	  ""))
+
+    ; force update of frame
+    (save-excursion (set-buffer (other-buffer)))
+    (sit-for 0)
+    )
+
+(defun sccs-do-command (buffer command file &rest flags)
+  "  Execute an SCCS command, notifying the user and checking for errors."
+  (setq file (expand-file-name file))
+  (message "Running %s on %s..." command file)
+  (or sccs-bin-directory (sccs-init-bin-directory))
+  (let ((status
+	 (save-window-excursion
+	   (set-buffer (get-buffer-create buffer))
+	   (erase-buffer)
+	   (while (and flags (not (car flags)))
+	     (setq flags (cdr flags)))
+	   (setq flags (append flags (and file (list (sccs-name file)))))
+	   (let ((default-directory (file-name-directory (or file "./")))
+		 (exec-path (cons sccs-bin-directory exec-path)))
+	     (apply 'call-process command nil t nil flags)
+	     )
+	   (goto-char (point-max))
+	   (previous-line 1)
+	   (if (looking-at "ERROR")
+	       (progn
+		 (previous-line 1)
+		 (print (cons command flags))
+		 (next-line 1)
+		 nil)
+	     t))))
+    (if status
+	(message "Running %s...OK" command)
+      (pop-to-buffer buffer)
+      (error "Running %s...FAILED" command)))
+  (if file (sccs-mode-line file)))
+
+(defun sccs-shell-command (command)
+  "Like shell-command except that the *Shell Command Output*buffer
+is created even if the command does not output anything"
+  (shell-command command)
+  (get-buffer-create "*Shell Command Output*"))
+
+(defun sccs-tree-walk (func &rest optargs)
+  "Apply FUNC to each SCCS file under the default directory.
+If present, OPTARGS are also passed."
+  (sccs-shell-command (concat "/bin/ls -1 " default-directory "SCCS/s.*"))
+  (set-buffer "*Shell Command Output*")
+  (goto-char (point-min))
+  (replace-string "SCCS/s." "")
+  (goto-char (point-min))
+  (if (eobp)
+      (error "No SCCS files under %s" default-directory))
+  (while (not (eobp))
+    (let ((file (buffer-substring (point) (progn (end-of-line) (point)))))
+      (apply func file optargs)
+      )
+    (forward-line 1)
+    )
+  )
+
+(defun sccs-init ()
+  (or (current-local-map) (use-local-map (make-sparse-keymap)))
+  (condition-case nil
+      ;; If C-c s is already defined by another mode, then we
+      ;; will get an error.  In that case, just don't do anything.
+      (progn
+	(define-key (current-local-map) "\C-cs?" 'describe-mode)
+	(define-key (current-local-map) "\C-csn" 'sccs)
+	(define-key (current-local-map) "\C-csm" 'sccs-register-file)
+	(define-key (current-local-map) "\C-csh" 'sccs-insert-headers)
+	(define-key (current-local-map) "\C-csd" 'sccs-revert-diff)
+	(define-key (current-local-map) "\C-csp" 'sccs-prs)
+	(define-key (current-local-map) "\C-csr" 'sccs-revert-buffer)
+	(define-key (current-local-map) "\C-cs\C-d" 'sccs-version-diff)
+	(define-key (current-local-map) "\C-cs\C-p" 'sccs-pending)
+	(define-key (current-local-map) "\C-cs\C-r" 'sccs-registered)
+	)
+    (error nil)))
+
+;; Here's the major entry point
+
+(defun sccs (verbose)
+  "*Do the next logical SCCS operation on the file in the current buffer.
+You must have an SCCS subdirectory in the same directory as the file being
+operated on.
+   If the file is not already registered with SCCS, this does an admin -i
+followed by a get -e.
+   If the file is registered and not locked by anyone, this does a get -e.
+   If the file is registered and locked by the calling user, this pops up a
+buffer for creation of a log message, then does a delta -n on the file.
+A read-only copy of the changed file is left in place afterwards.
+   If the file is registered and locked by someone else, an error message is
+returned indicating who has locked it."
+  (interactive "P")
+  (sccs-init)
+  (if (buffer-file-name)
+      (let
+	  (do-update revision owner
+		     (file (buffer-file-name))
+		     (sccs-file (sccs-name (buffer-file-name)))
+		     (sccs-log-buf (get-buffer-create "*SCCS-Log*"))
+		     (err-msg nil))
+
+	;; if there is no SCCS file corresponding, create one
+	(if (not (file-exists-p sccs-file))
+	    (progn
+	      (sccs-load-vars)
+	      (sccs-admin 
+	       file
+	       (cond 
+		(verbose (read-string "Initial SID: "))
+		((error-occurred (load-file "SCCS/emacs-vars.el")) "1")
+		(t sccs-current-major-version))
+	       )
+	      )
+	  )
+
+	(cond
+
+	 ;; if there is no lock on the file, assert one and get it
+	 ((not (file-exists-p (sccs-name file "p")))
+	  (progn
+	    (sccs-get file t)
+	    (revert-buffer nil t)
+	    (sccs-mode-line file)
+	    ))
+
+	 ;; a checked-out version exists, but the user may not own the lock
+	 ((not (string-equal
+		(setq owner (sccs-locking-user file)) (user-login-name)))
+	  (error "Sorry, %s has that file checked out" owner))
+
+	 ;; OK, user owns the lock on the file 
+	 (t (progn
+
+	      ;; if so, give luser a chance to save before delta-ing.
+	      (if (and (buffer-modified-p)
+		       (or
+			sccs-mode-expert
+			(y-or-n-p (format "%s has been modified. Write it out? "
+					  (buffer-name)))))
+		       (save-buffer))
+
+	      (setq revision (sccs-locked-revision file))
+
+	      ;; user may want to set nonstandard parameters
+	      (if verbose
+		  (if (or sccs-mode-expert (y-or-n-p 
+		       (format "SID: %s  Change revision level? " revision)))
+		      (setq revision (read-string "New revision level: "))))
+
+	      ;; OK, let's do the delta
+	      (if
+		  ;; this excursion returns t if the new version was saved OK
+		  (save-window-excursion
+		    (pop-to-buffer (get-buffer-create "*SCCS*"))
+		    (erase-buffer)
+		    (set-buffer-modified-p nil)
+		    (sccs-mode)
+		    (message 
+		     "Enter log message. Type C-c C-c when done, C-c ? for help.")
+		    (prog1
+			(and (not (error-occurred (recursive-edit)))
+			     (not (error-occurred (sccs-delta file revision))))
+		      (setq buffer-file-name nil)
+		      (bury-buffer "*SCCS*")))
+
+		  ;; if the save went OK do some post-checking
+		  (if (buffer-modified-p)
+		      (error
+		       "Delta-ed version of file does not match buffer!")
+		    (progn
+		      ;; sccs-delta already turned off write-privileges on the
+		      ;; file, let's not re-fetch it unless there's something
+		      ;; in it that get would expand
+		      ;;
+		      ;; fooey on this.  You always need to refetch the
+		      ;; file; otherwise weirdness will ensue when you're
+		      ;; trying to do a make. --bpw
+		      ; (if (sccs-check-headers)
+		      (sccs-get file nil)
+		      (revert-buffer nil t)
+		      (sccs-mode-line file)
+		      (run-hooks 'sccs-delta-ok)
+		      )
+		    ))))))
+    (error "There is no file associated with buffer %s" (buffer-name))))
+
+(defun sccs-insert-last-log ()
+  "*Insert the log message of the last SCCS check in at point."
+  (interactive)
+  (insert-buffer sccs-log-buf))
+
+;;; These functions help the sccs entry point
+
+(defun sccs-get (file writeable)
+  "Retrieve a copy of the latest delta of the given file."
+    (sccs-do-command "*SCCS*" "get" file (if writeable "-e")))
+
+(defun sccs-admin (file sid)
+  "Checks a file into sccs.
+FILE is the unmodified name of the file.  SID should be the base-level sid to
+check it in under."
+  ; give a change to save the file if it's modified
+  (if (and (buffer-modified-p)
+	   (y-or-n-p (format "%s has been modified. Write it out? "
+			     (buffer-name))))
+      (save-buffer))
+  (sccs-do-command "*SCCS*" "admin" file
+		   (concat "-i" file) (concat "-r" sid))
+  (chmod "-w" file)
+  (if (sccs-check-headers)
+      (sccs-get file nil))	;; expand SCCS headers
+  (revert-buffer nil t)
+  (sccs-mode-line file)
+)
+
+(defun sccs-delta (file &optional rev comment)
+   "Delta the file specified by FILE.
+The optional argument REV may be a string specifying the new revision level
+\(if nil increment the current level). The file is retained with write
+permissions zeroed. COMMENT is a comment string; if omitted, the contents of
+the current buffer up to point becomes the comment for this delta."
+  (if (not comment)
+      (progn
+	(goto-char (point-max))
+	(if (not (bolp)) (newline))
+	(newline)
+	(setq comment (buffer-substring (point-min) (1- (point)))))
+    )
+  (sccs-do-command "*SCCS*" "delta" file "-n"
+	   (if rev (format "-r%s" rev))
+	   (format "-y%s" comment))
+  (chmod "-w" file))
+
+(defun sccs-delta-abort ()
+  "Abort an SCCS delta command."
+  (interactive)
+  (if (or sccs-mode-expert (y-or-n-p "Abort the delta? "))
+      (progn
+	(delete-window)
+	(error "Delta aborted")))
+  )
+
+(defun sccs-log-exit ()
+  "Leave the recursive edit of an SCCS log message."
+  (interactive)
+  (if (< (buffer-size) sccs-max-log-size)
+	 (progn
+	   (copy-to-buffer sccs-log-buf (point-min) (point-max))
+	   (exit-recursive-edit)
+	   (delete-window))
+	 (progn
+	   (goto-char sccs-max-log-size)
+	   (error
+	    "Log must be less than %d characters. Point is now at char %d."
+	    sccs-max-log-size sccs-max-log-size)))
+)
+
+;; Additional entry points for examining version histories
+
+(defun sccs-revert-diff (&rest flags)
+  "*Compare the version being edited with the last checked-in revision.
+Or, if given a prefix argument, with another specified revision."
+  (interactive)
+  (let (old file)
+    (if
+	(setq old (sccs-get-version (buffer-file-name) 
+				    (and
+				     current-prefix-arg
+				     (read-string "Revision to compare against: "))
+				    ))
+	(progn
+	  (if (and (buffer-modified-p)
+		   (or
+		    sccs-mode-expert
+		    (y-or-n-p (format "%s has been modified. Write it out? "
+				      (buffer-name)))))
+	      (save-buffer))
+
+	  (setq file (buffer-file-name))
+	  (set-buffer (get-buffer-create "*SCCS*"))
+	  (erase-buffer)
+	  (apply 'call-process (car sccs-diff-command) nil t nil
+		 (append (cdr sccs-diff-command) flags (list old) (list file)))
+	  (set-buffer-modified-p nil)
+	  (goto-char (point-min))
+	  (delete-file old)
+	  (if (equal (point-min) (point-max))
+	      (message "No changes to %s since last get." file)
+	      (pop-to-buffer "*SCCS*")
+	      )
+	  )
+      )
+    )
+  )
+
+(defun sccs-prs ()
+  "*List the SCCS log of the current buffer in an emacs window."
+  (interactive)
+  (if (and buffer-file-name (file-exists-p (sccs-name buffer-file-name "s")))
+      (progn
+	(sccs-do-command "*SCCS*" "prs" buffer-file-name)
+	(pop-to-buffer (get-buffer-create "*SCCS*"))
+	)
+    (error "There is no SCCS file associated with this buffer")
+    )
+  )
+
+(defun sccs-version-diff (file rel1 rel2)
+  "*For FILE, report diffs between two stored deltas REL1 and REL2 of it."
+  (interactive "fFile: \nsOlder version: \nsNewer version: ")
+  (if (string-equal rel1 "") (setq rel1 nil))
+  (if (string-equal rel2 "") (setq rel2 nil))
+  (set-buffer (get-buffer-create "*SCCS*"))
+  (erase-buffer)
+  (sccs-vdiff file rel1 rel2)
+  (set-buffer-modified-p nil)
+  (goto-char (point-min))
+  (if (equal (point-min) (point-max))
+      (message "No changes to %s between %s and %s." file rel1 rel2)
+    (pop-to-buffer "*SCCS*")
+    )
+  )
+
+(defun sccs-vdiff (file rel1 rel2 &optional flags)
+  "Compare two deltas into the current buffer."
+  (let (vers1 vers2)
+    (and
+     (setq vers1 (sccs-get-version file rel1))
+     (setq vers2 (if rel2 (sccs-get-version file rel2) file))
+;     (prog1
+;	 (save-excursion
+;	   (not (error-occurred
+;		 (call-process "prs" nil t t
+;			       (sccs-name file))))
+;	 )
+;       )
+     (unwind-protect
+	 (apply 'call-process (car sccs-diff-command) nil t t
+		(append (cdr sccs-diff-command) flags (list vers1) (list vers2)))
+       (condition-case () (delete-file vers1) (error nil))
+       (if rel2
+	   (condition-case () (delete-file vers2) (error nil)))
+       )
+     )
+    )
+  )
+
+;; SCCS header insertion code
+
+(defun sccs-insert-headers ()
+  "*Insert headers for use with the Source Code Control System.
+Headers desired are inserted at the start of the buffer, and are pulled from 
+the variable sccs-headers-wanted"
+  (interactive)
+  (save-excursion
+    (save-restriction
+      (widen)
+      (if (or (not (sccs-check-headers))
+	      (y-or-n-p "SCCS headers already exist.  Insert another set?"))
+	  (progn
+	     (goto-char (point-min))
+	     (run-hooks 'sccs-insert-headers-hook)
+	     (cond ((eq major-mode 'c-mode) (sccs-insert-c-header))
+		   ((eq major-mode 'lisp-mode) (sccs-insert-lisp-header))
+		   ((eq major-mode 'emacs-lisp-mode) (sccs-insert-lisp-header))
+		   ((eq major-mode 'scheme-mode) (sccs-insert-lisp-header))
+		   ((eq major-mode 'nroff-mode) (sccs-insert-nroff-header))
+		   ((eq major-mode 'plain-tex-mode) (sccs-insert-tex-header))
+		   ((eq major-mode 'texinfo-mode) (sccs-insert-texinfo-header))
+		   (t (sccs-insert-generic-header))))))))
+
+(defun sccs-insert-c-header ()
+  (let (st en)
+    (insert "/*\n")
+    (mapcar '(lambda (s)
+	       (insert " *\t" s "\n"))
+	    sccs-headers-wanted)
+    (insert " */\n\n")
+    (if (and sccs-insert-static 
+	     (not (string-match "\\.h$" (buffer-file-name))))
+	(progn
+	  (insert "#ifndef lint\n"
+		  "static char *sccsid")
+;;	  (setq st (point))
+;;	  (insert (file-name-nondirectory (buffer-file-name)))
+;;	  (setq en (point))
+;;	  (subst-char-in-region st en ?. ?_)
+	  (insert " = \"\%\W\%\";\n"
+		  "#endif /* lint */\n\n")))
+    (run-hooks 'sccs-insert-c-header-hook)))
+
+(defun sccs-insert-lisp-header ()
+  (mapcar '(lambda (s) 
+		  (insert ";;;\t" s "\n"))
+	  sccs-headers-wanted)
+  (insert "\n")
+  (run-hooks 'sccs-insert-lisp-header-hook))
+
+(defun sccs-insert-nroff-header ()
+  (mapcar '(lambda (s) 
+		  (insert ".\\\"\t" s "\n"))
+	  sccs-headers-wanted)
+  (insert "\n")
+  (run-hooks 'sccs-insert-nroff-header-hook))
+
+(defun sccs-insert-tex-header ()
+  (mapcar '(lambda (s) 
+		  (insert "%%\t" s "\n"))
+	  sccs-headers-wanted)
+  (insert "\n")
+  (run-hooks 'sccs-insert-tex-header-hook))
+
+(defun sccs-insert-texinfo-header ()
+  (mapcar '(lambda (s) 
+		  (insert "@comment\t" s "\n"))
+	  sccs-headers-wanted)
+  (insert "\n")
+  (run-hooks 'sccs-insert-texinfo-header-hook))
+
+(defun sccs-insert-generic-header ()
+  (let* ((comment-start-sccs (or comment-start "#"))
+	 (comment-end-sccs (or comment-end ""))
+	 (dont-insert-nl-p (string-match "\n" comment-end-sccs)))
+    (mapcar '(lambda (s)
+	       (insert comment-start-sccs "\t" s ""
+		       comment-end-sccs (if dont-insert-nl-p "" "\n")))
+	  sccs-headers-wanted)
+  (insert comment-start-sccs comment-end-sccs (if dont-insert-nl-p "" "\n"))))
+
+(defun sccs-check-headers ()
+  "Check if the current file has any SCCS headers in it."
+  (interactive)
+  (save-excursion
+    (goto-char (point-min))
+    (re-search-forward  "%[MIRLBSDHTEGUYFPQCZWA]%" (point-max) t)))
+
+;; Status-checking functions
+
+(defun sccs-status (prefix legend)
+   "List all files underneath the current directory matching a prefix type."
+   (sccs-shell-command
+    (concat "/bin/ls -1 SCCS/" prefix ".*"))
+   (if
+       (save-excursion
+	 (set-buffer "*Shell Command Output*")
+	 (if (= (point-max) (point-min))
+	     (not (message
+		   "No files are currently %s under %s"
+		   legend default-directory))
+	   (progn
+	     (goto-char (point-min))
+	     (insert
+	      "The following files are currently " legend
+	      " under " default-directory ":\n")
+	     (replace-string (format "SCCS/%s." prefix) "")
+	     )
+	   )
+	 )
+       (pop-to-buffer "*Shell Command Output*")
+       )
+     )
+
+(defun sccs-pending ()
+  "*List all files currently SCCS locked."
+  (interactive)
+  (sccs-status "p" "locked"))
+
+(defun sccs-registered ()
+  "*List all files currently SCCS registered."
+  (interactive)
+  (sccs-status "s" "registered"))
+       
+(defun sccs-register-file (override)
+  "*Register the file visited by the current buffer into SCCS."
+  (interactive "P")
+  (if (file-exists-p (sccs-name (buffer-file-name)))
+      (error "This file is already registered into SCCS.")
+    (progn
+      (if (and (buffer-modified-p)
+	       (or
+		sccs-mode-expert
+		(y-or-n-p (format "%s has been modified. Write it out? "
+				  (buffer-name)))))
+	  (save-buffer))
+      (sccs-load-vars)
+      (sccs-admin 
+       (buffer-file-name)
+       (cond 
+	(override (read-string "Initial SID: "))
+	((error-occurred (load-file "SCCS/emacs-vars.el")) "1")
+	(t sccs-current-major-version))
+       )
+      )
+    )
+  )
+
+;; Major functions for release-tracking and generation.
+
+(defun sccs-release-diff (rel1 rel2)
+  "*Diff all files below default-directory between versions REL1 and REL2.
+The report goes to a shell output buffer which is popped to.  If REL2 is
+omitted or nil, the comparison is done against the most recent version."
+  (interactive "sOlder version: \nsNewer version: ")
+  (if (string-equal rel1 "") (setq rel1 nil))
+  (if (string-equal rel2 "") (setq rel2 nil))
+  (sccs-shell-command (concat
+		       "/bin/ls -1 " default-directory "SCCS/s.*"
+		       ))
+  (set-buffer "*Shell Command Output*")
+  (goto-char (point-min))
+  (replace-string "SCCS/s." "")
+  (goto-char (point-min))
+  (if (eobp)
+      (error "No SCCS files under %s" default-directory))
+  (let
+      ((sccsbuf (get-buffer-create "*SCCS*")))
+    (save-excursion
+      (set-buffer sccsbuf)
+      (erase-buffer)
+      (insert (format "Diffs from %s to %s.\n\n"
+		      (or rel1 "current") (or rel2 "current"))))
+    (while (not (eobp))
+	 (let ((file (buffer-substring (point) (progn (end-of-line) (point)))))
+	   (save-excursion
+	     (set-buffer sccsbuf)
+	     (set-buffer-modified-p nil)
+
+	     (sccs-vdiff file rel1 rel2)
+	     (if (buffer-modified-p)
+		 (insert "\n"))
+	     )
+	   (forward-line 1)
+	   )
+	 )
+    (kill-buffer "*Shell Command Output*")
+    (pop-to-buffer sccsbuf)
+    (insert "\nEnd of diffs.\n")
+    (goto-char (point-min))
+    (replace-string (format "/SCCS/%s." rel1) "/")
+    (goto-char (point-min))
+    (replace-string (format "/SCCS/%s." rel2) "/new/")
+    (goto-char (point-min))
+    (replace-string "/SCCS/new." "/new/")
+    (goto-char (point-min))
+    (replace-regexp (concat "^*** " default-directory) "*** ")
+    (goto-char (point-min))
+    (replace-regexp (concat "^--- " default-directory) "--- ")
+    (goto-char (point-min))
+    (set-buffer-modified-p nil)
+    )
+  )
+
+(defun sccs-dummy-delta (file sid)
+  "Make a dummy delta to the given FILE with the given SID."
+  (interactive "sFile: \nsRelease ID: ")
+  (if (not (sccs-locked-revision file))
+      (sccs-get file t))
+  ;; Grottiness alert -- to get around SCCS's obsessive second-guessing we
+  ;; have to mung the p-file
+  (save-excursion
+    (let ((pfile (sccs-name file "p")))
+      (chmod "u+w" pfile)
+      (find-file pfile)
+      (auto-save-mode nil)
+      (replace-regexp "^\\([0-9.]+\\) \\([0-9.]+\\)" (concat "\\1 " sid) t)
+      (write-region (point-min) (point-max) pfile t 0)
+      (chmod "u-w" pfile)
+      (set-buffer-modified-p nil)
+      (kill-buffer (current-buffer))
+      )
+    )
+  (sccs-delta file sid (concat "Release " sid))
+  (sccs-get file nil)
+  (sccs-save-vars sid)
+  )
+
+(defun sccs-delta-release (sid)
+  "*Delta everything underneath the current directory to mark it as a release."
+  (interactive "sRelease: ")
+  (sccs-tree-walk 'sccs-dummy-delta sid)
+  (kill-buffer "*SCCS*")
+  )
+
+;; Miscellaneous other entry points
+
+(defun sccs-revert-buffer ()
+  "*Revert the current buffer's file back to the last saved version."
+  (interactive)
+  (let ((file (buffer-file-name)))
+    (if (y-or-n-p (format "Revert file %s to last SCCS revision?" file))
+	(progn
+	  (delete-file file)
+	  (delete-file (sccs-name file "p"))
+	  (rename-file (sccs-get-version file nil) file)
+	  (chmod "-w" file)
+	  (revert-buffer nil t)
+	  (sccs-mode-line file)))))
+
+(defun sccs-rename-file (old new)
+  "*Rename a file, taking its SCCS files with it."
+  (interactive "fOld name: \nFNew name: ")
+  (let ((owner (sccs-locking-user old)))
+    (if (and owner (not (string-equal owner (user-login-name))))
+	(error "Sorry, %s has that file checked out" owner))
+    )
+  (rename-file old new)
+  (if (file-exists-p (sccs-name old "p"))
+      (rename-file (sccs-name old "p") (sccs-name new "p")))
+  (if (file-exists-p (sccs-name old "s"))
+      (rename-file (sccs-name old "s") (sccs-name new "s")))
+  )
+
+;; Set up key bindings for SCCS use, e.g. while editing log messages
+
+(defun sccs-mode ()
+  "Minor mode for driving the SCCS tools.
+
+These bindings are added to the global keymap when you enter this mode:
+\\[sccs]	perform next logical SCCS operation (`sccs') on current file
+\\[sccs-register-file]		register current file into SCCS
+\\[sccs-insert-headers]		insert SCCS headers in current file
+\\[sccs-prs]		display change history of current file
+\\[sccs-revert-buffer]		revert buffer to last saved version
+\\[sccs-revert-diff]		show difference between buffer and last saved delta
+\\[sccs-pending]		show all files currently locked by any user in or below .
+\\[sccs-registered]		show all files registered into SCCS in or below .
+\\[sccs-version-diff]		show diffs between saved versions for all files in or below .
+
+When you generate headers into a buffer using C-c h, the value of
+sccs-insert-headers-hook is called before insertion. If the file is
+recognized a C or Lisp source, sccs-insert-c-header-hook or
+sccs-insert-lisp-header-hook is called after insertion respectively.
+
+While you are entering a change log message for a delta, the following
+additional bindings will be in effect.
+
+\\[sccs-log-exit]		proceed with check in, ending log message entry
+\\[sccs-insert-last-log]		insert log message from last check-in
+\\[sccs-delta-abort]		abort this delta check-in
+
+Entry to the change-log submode calls the value of text-mode-hook, then
+the value sccs-mode-hook.
+
+Global user options:
+        sccs-mode-expert        suppresses some conformation prompts,
+				notably for delta aborts and file saves.
+	sccs-max-log-size	specifies the maximum allowable size
+				of a log message plus one.
+	sccs-diff-command	A list consisting of the command and flags
+				to be used for generating context diffs.
+	sccs-headers-wanted	which %-keywords to insert when adding
+				SCCS headers with C-c h
+	sccs-insert-static	if non-nil, SCCS keywords inserted in C files
+				get stuffed in a static string area so that
+				what(1) can see them in the compiled object
+				code.
+"
+  (interactive)
+  (set-syntax-table text-mode-syntax-table)
+  (use-local-map sccs-log-entry-mode)
+  (setq local-abbrev-table text-mode-abbrev-table)
+  (setq major-mode 'sccs-mode)
+  (setq mode-name "SCCS Change Log Entry")
+  (run-hooks 'text-mode-hook 'sccs-mode-hook)
+)
+
+;; Initialization code, to be done just once at load-time
+(if sccs-log-entry-mode
+    nil
+  (setq sccs-log-entry-mode (make-sparse-keymap))
+  (define-key sccs-log-entry-mode "\C-ci" 'sccs-insert-last-log)
+  (define-key sccs-log-entry-mode "\C-c\C-i" 'sccs-insert-last-log)
+  (define-key sccs-log-entry-mode "\C-ca" 'sccs-delta-abort)
+  (define-key sccs-log-entry-mode "\C-c\C-a" 'sccs-delta-abort)
+  (define-key sccs-log-entry-mode "\C-c\C-c" 'sccs-log-exit)
+  (define-key sccs-log-entry-mode "\C-x\C-s" 'sccs-log-exit)
+  )
+
+
+;;; Lucid Emacs support
+
+(defconst sccs-menu
+  '("SCCS Commands"
+
+    ["SCCS"			sccs			t	nil] ; C-c s n
+    ["Insert Headers"		sccs-insert-headers	t]	     ; C-c s h
+    ["Archive History:"		sccs-prs		t	nil] ; C-c s p
+    ["Diffs from Archive:"	sccs-revert-diff	t	nil] ; C-c s d
+    ["Revert to Archive:"	sccs-revert-buffer	t	nil] ; C-c s r
+    "----"
+    ["Check In..."		sccs-dummy-delta	t]
+    ["Create Archive..."	sccs-register-file	t] ; C-c s h
+    ["Rename Archive..."	sccs-rename-file	t]
+    "----"
+    ["List Checked-Out Files"	sccs-pending		t]	   ; C-c s C-p
+    ["List Registered Files"	sccs-registered		t]	   ; C-c s C-r
+    ["Diff Directory"		sccs-release-diff	t]
+    ["Delta Directory"		sccs-delta-release	t]
+    ))
+
+(progn
+  (delete-menu-item '("SCCS"))
+  (add-menu '() "SCCS" (cdr sccs-menu)))
+
+(defun sccs-sensitize-menu ()
+  (let* ((rest (cdr (car (find-menu-item current-menubar '("SCCS")))))
+	 (case-fold-search t)
+	 (file (if buffer-file-name
+		   (file-name-nondirectory buffer-file-name)
+		 (buffer-name)))
+	 (dir (file-name-directory
+	       (if buffer-file-name buffer-file-name default-directory)))
+	 (sccs-file (and buffer-file-name (sccs-name buffer-file-name)))
+	 (known-p (and sccs-file (file-exists-p sccs-file)))
+	 (checked-out-p (and known-p
+			     (file-exists-p (sccs-name buffer-file-name "p"))))
+	 command
+	 item)
+    (while rest
+      (setq item (car rest))
+      (if (not (vectorp item))
+	  nil
+	(setq command (aref item 1))
+	(if (eq 'sccs command)
+	    (aset item 0
+		  (cond ((or (null sccs-file) (not known-p))
+			 "Create Archive:")
+			((not checked-out-p)
+			 "Check Out")
+			(t
+			 "Check In"))))
+	(cond
+	 ((and (> (length item) 3)
+	       (string-match "directory" (aref item 0)))
+	  (aset item 3 dir))
+	 ((> (length item) 3)
+	  (aset item 3 file))
+	 (t nil))
+	(aset item 2
+	      (cond
+	       ((memq command '(sccs-prs))
+		known-p)
+	       ((memq command '(sccs-revert-diff sccs-revert-buffer))
+		checked-out-p)
+	       (t))))
+	(setq rest (cdr rest))))
+  nil)
+
+(add-hook 'activate-menubar-hook 'sccs-sensitize-menu)
+
+(provide 'sccs)
+
+;; sccs.el ends here

sun-eos-browser.el

+;;; sun-eos-browser.el --- Implements the XEmacs/SPARCworks SourceBrowser interface
+
+;; Copyright (C) 1995  Sun Microsystems, Inc.
+
+;; Maintainer:	Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
+;; Author:      Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
+
+;; Keywords:	SPARCworks EOS Era on SPARCworks SBrowser Source Browser
+
+;;; Commentary:
+;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com
+
+;;; Code:
+
+(require 'eos-common "sun-eos-common")
+
+;; ================
+;; Browser Protocol
+;; ================
+;;
+;; three notifications
+;;
+;; SPRO_SBENG_START
+;; SPRO_SBENG_CURRENT_ELEMENT CONTEXT_UID filename lineno center==0
+;; SPRO_SBENG_QUIT
+
+(defvar eos::currentMatch-inst "/* XPM */
+static char * file[] = {
+\"14 11 5 1\",
+\" 	s background c #FFFFFFFFFFFF\",
+\".	c #000000000000\",
+\"X	c #0000FFFF0000\",
+\"o	c #000077770000\",
+\"O	c #000044440000\",
+\"              \",
+\"   oo         \",
+\"   oXOo       \",
+\"   oXXXOo     \",
+\"   oXXXXXOo   \",
+\"   oXXXXXXXo. \",
+\"   oXXXXXOo   \",
+\"   oXXXOo     \",
+\"   oXOo       \",
+\"   oo         \",
+\"              \"};")
+
+(defvar eos::currentMatch-inst-alt "/* XPM */
+static char * file[] = {
+\"14 11 5 1\",
+\" 	s background c #FFFFFFFFFFFF\",
+\".	c #000000000000\",
+\"X	c #0000FFFF0000\",
+\"o	c #000077770000\",
+\"O	c #000044440000\",
+\"              \",
+\"   oo         \",
+\"   oXOo       \",
+\"   oXXXOo     \",
+\"   oXXXXXOo   \",
+\"   oXXXXXXXo. \",
+\"   oXXXXXOo   \",
+\"   oXXXOo     \",
+\"   oXOo       \",
+\"   oo      .. \",
+\"           .. \"};")
+
+(defvar sbrowser-pattern-list nil)
+
+
+(defun eos::browser-startup ()
+  ;; Actions to do at startup for eos-browser.el
+  (make-face 'sbrowse-arrow-face)
+
+  (set-face-foreground 'sbrowse-arrow-face
+		       eos::sbrowse-arrow-color)
+  (set-face-background 'sbrowse-arrow-face
+		       (face-background (get-face 'default)))
+
+  (setq sbrowser-pattern-list		; list of browser TT patterns
+	(eos::create-sbrowser-patterns))
+
+  ;; now register glyphs and faces...
+
+  (eos::annotation-set-inst 'sbrowser 'x eos::currentMatch-inst [nothing])
+  (eos::annotation-set-inst 'sbrowser 'tty "|>" [nothing])
+  (eos::annotation-set-face 'sbrowser 'x
+			    (get-face 'sbrowse-arrow-face)
+			    (get-face 'sbrowse-arrow-face))
+  (eos::annotation-set-face 'sbrowser 'tty
+			    (get-face 'highlight)
+			    (get-face 'highlight))
+)
+
+(defvar eos::current-match nil)
+
+(defun eos::spro_sbeng_current_element (msg pat)
+  ;; SPRO_SBENG_CURRENT_ELEMENT CONTEXT_UID filename lineno center==0
+  (let* ((filename
+	  (get-tooltalk-message-attribute msg 'arg_val 1))
+	 (lineno
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 2)))
+	 )
+    (setq eos::current-match
+	  (eos::make-annotation-visible eos::current-match
+					filename
+					lineno
+					'sbrowser))
+    (return-tooltalk-message msg)
+    ))
+
+(defun eos::spro_sbeng_start (msg pat)
+    (eos::make-annotation-invisible eos::current-match)
+    (return-tooltalk-message msg)
+    )
+
+(defun eos::spro_sbeng_quit (msg pat)
+    (eos::make-annotation-invisible eos::current-match)
+    (return-tooltalk-message msg)
+    )
+
+(defun eos::create-sbrowser-patterns ()
+  ;; returns list of patterns
+  (list
+   (make-an-observer "SPRO_SBENG_CURRENT_ELEMENT"
+		     'eos::spro_sbeng_current_element)
+   (make-an-observer "SPRO_SBENG_START"
+		     'eos::spro_sbeng_start)
+   (make-an-observer "SPRO_SBENG_QUIT"
+		     'eos::spro_sbeng_quit)
+   ))
+
+(defun eos::register-sbrowser-patterns ()
+  ;; register all sbrowser patterns
+  (mapcar 'register-tooltalk-pattern sbrowser-pattern-list))
+
+(defun eos::unregister-sbrowser-patterns ()
+  ;; unregister all sbrowser patterns
+  (mapcar 'unregister-tooltalk-pattern sbrowser-pattern-list))
+
+;; Actions to start a sourcebrowser in the background.
+
+(defvar eos::sbrowser-process nil
+  "sbrowser process for the background.  Only one per XEmacs")
+
+(defun eos::start-sbrowser ()
+  ;; Start an "sbrowser -editor" in the background. Will ask for confirmation if
+  ;; XEmacs somehow believes there is already one running
+  (interactive)
+  (if (or (not (processp eos::sbrowser-process))
+	  (not (eq (process-status eos::sbrowser-process) 'run))
+	  (yes-or-no-p
+	   "Warning! XEmacs believes there already is a sbrowser -editor, proceed?"))
+      (progn
+	(setq eos::sbrowser-process
+	      (start-process "*eos sbrowser*" nil "sbrowser" "-editor"))
+	(message "Starting SBrowser subprocess")
+	(eos::select-sbrowser-frame (selected-frame))
+	)))
+
+(provide 'eos-browser) 
+
+;;; sun-eos-browser.el ends here

sun-eos-common.el

+;; Copyright (C) 1995, Sun Microsystems
+;;
+;; Light Weight Editor Integration for Sparcworks.
+;; "Era on Sparcworks" (EOS)
+;;
+;; Author: Eduardo Pelegri-Llopart
+;;
+;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com
+
+;; Common routines for EOS
+
+(defvar eos::version "1.5.2"
+  "Version of Eos")
+
+(defvar eos::left-margin-width 5
+  "size of left margin")
+
+(defvar eos::stop-color "red"
+  "foreground color for stop signs")
+(defvar eos::solid-arrow-color "purple"
+  "foreground color for solid arrow")
+(defvar eos::hollow-arrow-color "purple"
+  "foreground color for hollow arrow")
+(defvar eos::sbrowse-arrow-color "blue"
+  "foreground color for browser glyphs")
+
+(defun eos::recompute-presentation ()
+  (set-face-foreground 'stop-face eos::stop-color)
+  (set-face-foreground 'solid-arrow-face eos::solid-arrow-color)
+  (set-face-foreground 'hollow-arrow-face eos::hollow-arrow-color)
+  (set-face-foreground 'sbrowse-arrow-face eos::sbrowse-arrow-color)
+  )
+
+;;
+
+(defvar eos::displayed-initial-message nil
+  "Whether we have shown the initial display message")
+
+(defconst eos::startup-message-lines
+  '("Please send feedback to eos-comments@cs.uiuc.edu."
+    "The latest Eos news are under SPARCworks->News"
+    "See Options->SPARCworks for configuration and Help->SPARCworks for help"
+    ))
+
+;; copied from vm
+
+(defun eos::display-initial-message ()
+  ;; Display initial Eos message - REMOVED
+  )
+
+(defun eos-old::display-initial-message ()
+  ;; Display initial Eos message
+  (if (not eos::displayed-initial-message)
+      (let ((lines eos::startup-message-lines))
+	(message "Eos %s, Copyright (C) 1995 Sun MicroSystems"
+		 eos::version)
+	(setq eos::displayed-initial-message t)
+	(while (and (sit-for 3) lines)
+	  (message (car lines))
+	  (setq lines (cdr lines))))
+    (message "")))
+
+;; misc
+
+(defun eos::line-at (pos)
+  ;; At what line is POS
+  (save-restriction
+    (widen)
+    (save-excursion
+      (goto-char pos)
+      (beginning-of-line)
+      (1+ (count-lines 1 (point))))))
+
+;; frame-specific enabling
+;;
+;; will maintain at most one frame to debugger, one to sbrowser
+;; annotations have a type, either
+;;
+;;	sbrowser
+;;	debugger-solid-arrow
+;;	debugger-holow-arrow
+;;	debugger-stop
+;;	debugger-visit
+;;
+;; adding an annotation of type sbrowser will be only on frame sbrowser
+;; adding an annotation of type debugger will be only on frame debugger
+;;
+;; turn off patterns when there is no frame.
+
+
+;;;
+;;; Common ToolTalk function
+;;;
+
+(defun make-an-observer (op callback)
+  (let ((pattern-desc
+	 (list
+	  'category 'TT_OBSERVE
+	  'scope 'TT_SESSION
+	  'class 'TT_NOTICE
+	  'op op
+	  'callback callback)))
+    (make-tooltalk-pattern pattern-desc)
+    ))
+
+;;;
+;;; Frame management
+;;;
+
+(defun eos::log (msg)
+  (if (fboundp 'ut-log-text)
+      (ut-log-text "eos version: %s; %s" eos::version msg)))
+
+(defvar eos::sbrowser-frame nil)
+(defvar eos::debugger-frame nil)
+
+(defun eos::update-specifiers (type old-frame new-frame)
+  ;; Change the database for annotations of TYPE, so that OLD-FRAME is
+  ;; now using the alternate specifier, while NEW-FRAME uses the main one
+  (let* ((device-type (device-type (selected-device)))
+	 (g (eos::annotation-get-glyph type device-type))
+	 (im (and (glyphp g) (glyph-image g)))
+	 (new-instantiator (eos::annotation-get-inst type device-type))
+	 (alt-instantiator (eos::annotation-get-inst-alt type device-type))
+	 )
+    (if (eq device-type 'x)
+	(progn
+	  (if (frame-live-p old-frame)
+	      (progn
+		(remove-specifier im old-frame)
+		(add-spec-to-specifier im alt-instantiator old-frame)))
+	  (if new-frame
+	      (progn
+		(add-spec-to-specifier im new-instantiator new-frame)
+	  ))))))
+
+
+(defun eos::select-sbrowser-frame (frame)
+  (require 'eos-toolbar  "sun-eos-toolbar")
+  (let ((toolbar (eos::toolbar-position)))
+    (eos::display-initial-message)
+    ;; logging
+    (if frame
+	(eos::log "selected frame for sbrowser")
+      (eos::log "unselected frame for sbrowser"))
+    ;; TT patterns
+    (cond
+     ((and (null eos::sbrowser-frame) frame)
+      (eos::register-sbrowser-patterns))
+     ((and (null frame) eos::sbrowser-frame)
+      (eos::unregister-sbrowser-patterns)))
+    ;; adjust  toolbars
+    (if (frame-live-p eos::sbrowser-frame)
+	(remove-specifier toolbar eos::sbrowser-frame))
+    (if (frame-live-p eos::debugger-frame)
+	(remove-specifier toolbar eos::debugger-frame))
+    ;; then add
+    (cond
+     ((and (frame-live-p eos::debugger-frame) (frame-live-p frame)
+	   (equal eos::debugger-frame frame))
+      (add-spec-to-specifier toolbar eos::debugger-sbrowser-toolbar frame))
+     ((and (frame-live-p eos::debugger-frame) (frame-live-p frame))
+      (add-spec-to-specifier toolbar eos::sbrowser-toolbar frame)
+      (add-spec-to-specifier toolbar eos::debugger-toolbar eos::debugger-frame))
+     ((frame-live-p frame)
+      (add-spec-to-specifier toolbar eos::sbrowser-toolbar frame))
+     ((frame-live-p eos::debugger-frame)
+      (add-spec-to-specifier toolbar eos::debugger-toolbar eos::debugger-frame))
+     )
+    ;; adjust specifiers for glyphs
+    (eos::update-specifiers 'sbrowser eos::sbrowser-frame frame)
+    (if (frame-live-p eos::sbrowser-frame)
+	(progn
+	  (remove-specifier use-left-overflow eos::sbrowser-frame)
+	  (remove-specifier left-margin-width eos::sbrowser-frame)))
+    (if (frame-live-p frame)
+	(progn
+	  (add-spec-to-specifier use-left-overflow t frame)
+	  (add-spec-to-specifier left-margin-width eos::left-margin-width frame)
+	  (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
+    (if (frame-live-p eos::debugger-frame)
+	(progn
+	  (add-spec-to-specifier use-left-overflow t eos::debugger-frame)
+	  (add-spec-to-specifier left-margin-width eos::left-margin-width eos::debugger-frame)
+	  (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
+    ;;
+    (setq eos::sbrowser-frame frame)
+    (set-menubar-dirty-flag)
+    ))
+
+(defun eos::select-debugger-frame (frame)
+  (require 'eos-toolbar  "sun-eos-toolbar")
+  (let ((toolbar (eos::toolbar-position)))
+    (eos::display-initial-message)
+    (save-excursion
+      (eos::ensure-debugger-buffer)
+      (bury-buffer))
+    ;; logging
+    (if frame
+	(eos::log "selected frame for debugger")
+      (eos::log "unselected frame for debugger"))
+    ;; TT patterns
+    (cond
+     ((and (null eos::debugger-frame) frame)
+      (eos::register-debugger-patterns)
+      (eos::register-visit-file-pattern))
+     ((and (null frame) eos::debugger-frame)
+      (eos::unregister-debugger-patterns)
+      (eos::unregister-visit-file-pattern)))
+    ;; adjust toolbars, remove
+    (if (frame-live-p eos::sbrowser-frame)
+	(remove-specifier toolbar eos::sbrowser-frame))
+    (if (frame-live-p eos::debugger-frame)
+	(remove-specifier toolbar eos::debugger-frame))
+    ;; then add
+    (cond
+     ((and (frame-live-p eos::sbrowser-frame) (frame-live-p frame)
+	   (equal eos::sbrowser-frame frame))
+      (add-spec-to-specifier toolbar eos::debugger-sbrowser-toolbar frame))
+     ((and (frame-live-p eos::sbrowser-frame) (frame-live-p frame))
+      (add-spec-to-specifier toolbar eos::debugger-toolbar frame)
+      (add-spec-to-specifier toolbar eos::sbrowser-toolbar eos::sbrowser-frame))
+     ((frame-live-p frame)
+      (add-spec-to-specifier toolbar eos::debugger-toolbar frame))
+     ((frame-live-p eos::sbrowser-frame)
+      (add-spec-to-specifier toolbar eos::sbrowser-toolbar eos::sbrowser-frame))
+     )
+    ;; update glyph specifiers
+    (eos::update-specifiers 'debugger-solid-arrow eos::debugger-frame frame)
+    (eos::update-specifiers 'debugger-hollow-arrow eos::debugger-frame frame)
+    (eos::update-specifiers 'debugger-stop eos::debugger-frame frame)
+    (if (frame-live-p eos::debugger-frame)
+	(progn
+	  (remove-specifier use-left-overflow eos::debugger-frame)
+	  (remove-specifier left-margin-width eos::debugger-frame)))
+    (if (frame-live-p frame)
+	(progn
+	  (add-spec-to-specifier use-left-overflow t frame)
+	  (add-spec-to-specifier left-margin-width eos::left-margin-width frame)
+	  (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
+    (if (frame-live-p eos::sbrowser-frame)
+	(progn
+	  (add-spec-to-specifier use-left-overflow t eos::sbrowser-frame)
+	  (add-spec-to-specifier left-margin-width eos::left-margin-width eos::sbrowser-frame)
+	  (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
+    ;;
+    (setq eos::debugger-frame frame)
+    (set-menubar-dirty-flag)
+    ))
+
+;; HERE  use file-truename
+
+(defun eos::select-frame (type)
+  ;; Select a frame; return nil if should skip
+  (cond ((eq type 'sbrowser) 
+	 (if (frame-live-p eos::sbrowser-frame)
+	     eos::sbrowser-frame
+	   (message "selecting destroyed frame; will ignore")
+	   (eos::select-sbrowser-frame nil)
+	   nil))
+	((or (eq type 'debugger-solid-arrow)
+	     (eq type 'debugger-hollow-arrow)
+	     (eq type 'debugger-stop)
+	     (eq type 'debugger-visit))
+	 (if (frame-live-p eos::debugger-frame)
+	     eos::debugger-frame
+	   (message "selecting destroyed frame; will ignore")
+	   (eos::select-debugger-frame nil)
+	   nil))
+	(t (selected-frame))))
+
+(defun eos::select-window (win)
+  ;; Will select a window if it is not showing neither of eos::debugger-buffer or
+  ;; eos::toolbar-buffer"
+  (let ((name (buffer-name (window-buffer win))))
+    (if (and (>= (length name) 4)
+	     (equal (substring name 0 4) "*Eos"))
+	nil
+      (select-window win)
+      (throw 'found t)
+      )))
+
+(defun eos::find-line (file line type)
+  ;; Show FILE at LINE; returns frame or nil if inappropriate
+  ;; if type is nil
+  (if (eos::null-file file)
+      (selected-frame)
+    (let ((sc (eos::select-frame type))
+	  (win (selected-window)))
+      (if (null sc)
+	  nil
+	(select-frame sc)
+	(if (catch 'found
+	      (eos::select-window (selected-window))
+	      (walk-windows 'eos::select-window)
+	       nil)
+	    nil				; do nothing, already there
+	  (select-window win)
+	  (split-window-vertically)
+	  (other-window 1)
+	  )
+	(switch-to-buffer (find-file-noselect file t)) ;; no warn!
+	(if (eq (device-type) 'x) (x-disown-selection))
+	(goto-line line)
+	sc
+	))))
+
+(defun eos::null-file (file)
+  ;; returns t if FILE is nil or the empty string
+  (or (null file) (equal file "")))
+
+;;;
+;;; Annotation handling
+;;;
+
+(defun eos::valid-annotation (annotation)
+  ;; returns t if ANNOTATION is an annotation and its buffer exists
+  (and (annotationp annotation)
+       (bufferp (extent-buffer annotation))
+       (buffer-name (extent-buffer annotation)))
+  )
+
+(defvar eos::annotation-list nil
+  "list of annotations set")
+
+(defun eos::add-to-annotation-list (ann type)
+  (if (not (eq type 'debugger-stop))
+      (error "not implemented"))
+  (setq eos::annotation-list (cons ann
+				      eos::annotation-list))
+  )
+
+(defun eos::remove-from-annotation-list (ann type)
+  (if (not (eq type 'debugger-stop))
+      (error "not implemented"))
+  (setq eos::annotation-list (delq ann eos::annotation-list))
+  )
+
+(defun eos::remove-all-from-annotation-list (type)
+  (if (not (eq type 'debugger-stop))
+      (error "not implemented"))
+  (mapcar (function (lambda (annot)
+		      (if (extent-live-p annot)
+			  (delete-annotation annot))))
+	  eos::annotation-list)
+  (setq eos::annotation-list nil))
+
+(defun eos::add-annotation (type file line uid)
+  (let ((anot nil)
+	(fr (selected-frame))
+	(win (selected-window))
+	)
+      (if (eos::null-file file)
+	  (setq anot nil)
+	(if (null (eos::find-line file line type))
+	    (error "No frame to select"))
+	(let* ((device-type (device-type (selected-device)))
+	       (graphics (eos::annotation-get-glyph type device-type))
+	       (face (eos::annotation-get-face type device-type))
+	       )
+	  (setq anot (make-annotation graphics (point) 'outside-margin))
+	  (set-annotation-data anot uid)
+	  (set-extent-face anot face)
+	  (eos::add-to-annotation-list anot type)
+	  ))
+      (select-frame fr)
+      (select-window win)
+      anot
+  ))
+
+(defun eos::compare-uid (extent uid)
+  (and (annotationp extent)
+       (equal (annotation-data extent) uid)
+       extent))
+
+(defun eos::delete-annotation (type file line uid)
+  ;; ignore file and line, they are here for backward compatibility
+  (let ((anot nil)
+	(alist eos::annotation-list)
+	)
+    (if (not (eq type 'debugger-stop))
+	(error "not implemented"))
+    (while (and alist
+		(not (equal (annotation-data (car alist)) uid)))
+      (setq alist (cdr alist)))
+    (if (null alist)
+	(error "Event UID not found; ignored")
+      (setq anot (car alist))
+      (delete-annotation anot)
+      (eos::remove-from-annotation-list anot type))
+    ))
+
+;; probably type should not be given here... (already stored in the annotation-data
+;; field)  but it is a bit more robust this way.
+
+(defun eos::make-annotation-visible (annotation file line type)
+  ;; returns nil or moves the ANNOTATION to FILE and LINE; annotation is of TYPE
+  (let ((back nil)
+	(fr (selected-frame))
+	(win (selected-window))
+	)
+    ;;    (save-window-excursion
+    (if (not (eos::null-file file))
+	(progn
+	  (if (eos::valid-annotation annotation)
+	      (detach-extent annotation) ; should operate on annotations
+	    )
+	  (if (null (eos::find-line file line type))
+		(error "No frame to select"))
+	  (let* ((device-type (device-type (selected-device)))
+		 (graphics (eos::annotation-get-glyph type device-type))
+		 (face (eos::annotation-get-face type device-type))
+		 )
+	    (if (and (eos::valid-annotation annotation)
+		     (extent-detached-p annotation))
+		(progn
+		  (setq back (insert-extent annotation (point) (point) t))
+		  (set-annotation-glyph back graphics 'whitespace)
+		  )
+	      (setq back (make-annotation graphics (point) 'whitespace))
+	      )
+	    (set-annotation-data back type)
+	    (set-extent-face back face)
+	    )))
+    ;;      )
+    (if (not (eq (selected-frame) fr))
+	(select-frame fr))
+    (select-window win)
+    back
+    ))
+
+(defun eos::make-annotation-invisible (annotation)
+  ;; make this ANNOTATION invisible
+  (if (eos::valid-annotation annotation)
+      (detach-extent annotation)	;;  should operate on annotations
+  ))
+
+
+;; mapping between annotation types and their screen representations.
+
+(defvar eos::alist-annotation-glyph nil) ; assoc list of annotation type
+					;  device type, and glyph
+(defvar eos::alist-annotation-inst nil) ; assoc list of annotation type
+					;  device type, and instantiator
+(defvar eos::alist-annotation-inst-alt nil) ; alternate assoc list of annotation type
+					;  device type, and instantiator
+
+(defvar eos::alist-annotation-face nil)  ;;  assoc list of annotation type,
+				       ;; device type and face
+
+;; PUBLIC
+
+;; TBD! merge both instance lists.
+
+(defun eos::annotation-set-inst (annotation-type device-type inst inst-alt)
+  "define the instantiator for ANNOTATION-TYPE on DEVICE-TYPE to be
+INST for the frame enabled for this type and INST-ALT for other frames"
+  (interactive)
+  (setq eos::alist-annotation-inst
+	(cons (cons (cons annotation-type device-type) inst)
+	      eos::alist-annotation-inst))
+  (setq eos::alist-annotation-inst-alt
+	(cons (cons (cons annotation-type device-type) inst-alt)
+	      eos::alist-annotation-inst-alt))  )
+
+(defun eos::annotation-set-face (annotation-type device-type face-1 face-2)
+  "define the face for ANNOTATION-TYPE on DEVICE-TYPE to be
+FACE-1 for the frame enabled for this type and FACE-2 for other frames"
+  (interactive)
+  (setq eos::alist-annotation-face
+	(cons (cons (cons annotation-type device-type) face-1)
+	      eos::alist-annotation-face))
+  )
+
+;; PRIVATE
+
+(defun eos::annotation-get-glyph (annotation-type device-type)
+  ;; Get the glyph for ANNOTATION-TYPE on DEVICE-TYPE
+  (interactive)
+  (let ((found (assoc (cons annotation-type device-type)
+		      eos::alist-annotation-glyph)))
+    (if found
+	(cdr found)
+      (let ((inst (eos::annotation-get-inst annotation-type device-type))
+	    (alt-inst (eos::annotation-get-inst-alt annotation-type device-type))
+	    (glyph nil)
+	    (frame (selected-frame)))
+	(if (null inst)
+	    nil
+	  (setq glyph (make-glyph `((global . (nil . ,alt-inst)))))
+	  (add-spec-to-specifier (glyph-image glyph) inst frame)
+	  (setq eos::alist-annotation-glyph
+		(cons (cons (cons annotation-type device-type) glyph)
+		    eos::alist-annotation-glyph))
+	  glyph))
+      )))
+
+(defun eos::annotation-get-inst (annotation-type device-type)
+  ;; Get the primary instantiator for ANNOTATION-TYPE on DEVICE-TYPE
+  (interactive)
+  (let ((found (assoc (cons annotation-type device-type)
+		      eos::alist-annotation-inst)))
+    (if found
+	(cdr found)
+      nil)))
+
+(defun eos::annotation-get-inst-alt (annotation-type device-type)
+  ;; Get the alternate instantiator for ANNOTATION-TYPE on DEVICE-TYPE
+  (interactive)
+  (let ((found (assoc (cons annotation-type device-type)
+		      eos::alist-annotation-inst-alt)))
+    (if found
+	(cdr found)
+      nil)))
+
+(defun eos::annotation-get-face (annotation-type device-type)
+  ;; Get the face for ANNOTATION-TYPE on DEVICE-TYPE 
+  (interactive)
+  (let ((found (assoc (cons annotation-type device-type)
+		      eos::alist-annotation-face))
+	)
+    (if found
+	(cdr found)
+      nil
+      ))
+  )
+
+
+(defun eos::common-startup () )
+;;
+
+
+(provide 'eos-common)

sun-eos-debugger-extra.el

+;;; sun-eos-debugger.el --- Implements the XEmacs/SPARCworks Debugger interface
+
+;; Copyright (C) Sun Microsystems, Inc.
+
+;; Maintainer:	Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
+;; Author:      Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
+
+;; Keywords:	SPARCworks EOS Era on SPARCworks Debugger dbx
+
+;;; Commentary:
+;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com
+
+;;; Code:
+
+;; debugger buffer
+
+(require 'eos-common   "sun-eos-common")
+(require 'eos-debugger "sun-eos-debugger")
+(require 'eos-menubar  "sun-eos-menubar")
+
+(defvar eos::debugger-buffer "*Eos Debugger Log*"
+  "name of buffer where to log debugger activity; see eos::use-debugger-buffer")
+(defvar eos::dbx-buffer nil)
+(defvar eos::key-mode 'none "Style of key mode interaction for Eos")
+
+(defun eos::ensure-debugger-buffer ()
+  ;; will ensure a debugger buffer, with the proper major mode
+  (let ((buf (get-buffer eos::debugger-buffer)))
+    (if buf
+	(switch-to-buffer buf)
+      (setq buf (get-buffer-create eos::debugger-buffer))
+      (set-buffer buf)
+      (eos::debugger-mode)
+      (toggle-read-only -1)		; writeable
+      (eos::insert-string-as-extent "[Debugger] " t (get-face 'bold))
+      (toggle-read-only 1)		; read-only
+      )))
+
+(defun eos::synchronize-debugger-buffer ()
+  ;; ensure all views of this buffer are at the end
+  (eos::ensure-debugger-buffer)
+  (let ((x (point-max)))
+    (goto-char x)
+    (mapcar (function
+	     (lambda (win)
+	       (set-window-point win x)))
+	    (get-buffer-window-list eos::debugger-buffer))
+    ))
+
+(defvar eos::debugger-mode-map nil)
+
+(if eos::debugger-mode-map
+    nil
+  (progn
+    (setq eos::debugger-mode-map (make-keymap))
+    (set-keymap-name eos::debugger-mode-map 'eos::debugger-mode-map)
+    (define-key eos::debugger-mode-map [(meta p)] 'eos::debugger-previous-cmd)
+    (define-key eos::debugger-mode-map [(meta n)] 'eos::debugger-next-cmd)
+    (define-key eos::debugger-mode-map [return] 'eos::debugger-send-cmd)
+    ))
+
+(defun eos::debugger-mode ()
+  (interactive)
+  "local mode"
+  (kill-all-local-variables)    
+  (setq major-mode 'eos::debugger-mode)
+  (setq mode-name "eos::debugger")
+  (setq truncate-lines t)
+  (set-syntax-table emacs-lisp-mode-syntax-table)
+  (use-local-map eos::debugger-mode-map))
+
+
+;; Handling of command lists
+
+(defvar eos::current-command nil "Current command navigated; as an extent")
+(defvar eos::last-command nil "last command sent to debugger, as an extent")
+
+(defun eos::debugger-previous-cmd ()
+  ;; present the previous command
+  (interactive)
+  (save-excursion
+    (let ((xt nil))
+      (if (null eos::current-command)
+	  (setq xt eos::last-command)
+	(setq xt (extent-property 
+		  eos::current-command
+		  'previous-command)))
+      (if xt
+	  (progn
+	    (eos::debugger-delete-last-cmd-line)
+	    (goto-char (point-max))
+	    (insert (buffer-substring
+		     (extent-start-position xt)
+		     (1- (extent-end-position xt)) ; remove <CR>
+		     ))
+	    (setq eos::current-command xt))
+	(error "no previous command")
+	))
+    ))
+
+(defun eos::debugger-next-cmd ()
+  ;; present the next command
+  (interactive)
+  (save-excursion
+    (let ((xt nil))
+      (if (null eos::current-command)
+	  (error "no next command")
+	(setq xt (extent-property 
+		  eos::current-command
+		  'next-command)))
+      (eos::debugger-delete-last-cmd-line)
+      (if xt
+	  (progn
+	    (goto-char (point-max))
+	    (insert (buffer-substring
+		     (extent-start-position xt)
+		     (1- (extent-end-position xt)) ; remove <CR>
+		     ))
+	    (setq eos::current-command xt))
+	(setq eos::current-command nil)
+	))
+    ))
+
+(defun eos::debugger-delete-last-cmd-line ()
+  ;; delete the last command line, not yet inputed, returns that cmd line
+  (goto-char (point-max))
+  (let ((e (point)))
+    (beginning-of-line)
+    (let* ((xt (extent-at (point)))
+	   (p (extent-end-position xt))
+	   (str (buffer-substring p e))
+	   )
+      (delete-region p e)
+      str
+      )))
+
+(defun eos::debugger-send-cmd ()
+  ;; send the message in the current line
+  (interactive)
+  (end-of-line)
+  (let ((e (point)))
+    (beginning-of-line)
+    (let* ((xt (extent-at (point)))
+	   (p (extent-end-position xt))
+	   (str (buffer-substring p e))
+	   )
+      (delete-region p e)
+      (eos::send-spider-current-do-msg (concat str "\n"))
+      (goto-char (point-max))
+      (setq eos::current-command nil)
+      )))
+
+;; client
+;;
+
+(defun get-buffer-window-list (buffer)
+  ;; like get-buffer-window except that will generate a list of windows
+  ;; instead of just the first one"
+  (let* ((buf (get-buffer buffer))
+	 (win1 (next-window nil 'foo t t))
+	 (win win1)
+	 (first t)
+	 (ret nil)
+	 )
+    (if (null buf)
+	nil
+      (while (or
+	      (and first win)
+	      (not (or first (equal win win1)))
+	      )
+	(setq first nil)
+	(if (equal
+	     buf
+	     (window-buffer win))
+	    (setq ret (cons win ret)))
+	(setq win (next-window win t t t))
+	)
+      ret)))
+
+(defun eos::dbx-process ()
+  ;; Returns nil, or the corresponding process where to insert
+  (let ((pl (process-list))
+	(found-proc nil)
+	)
+    (while (and pl (null found-proc))
+      (let* ((proc (car pl))
+	     (name (process-name proc))
+	     )
+	(if (and (>= (length name) 3)
+		 (equal (substring name 0 3) "Eos"))
+	    (setq found-proc proc)
+	  (setq pl (cdr pl))
+	  )
+	))
+    found-proc
+    ))
+
+(defun eos::insert-echo (process string)
+  (if (null process)
+      nil
+    (save-excursion
+      (set-buffer (process-buffer process))
+      (goto-char (point-max))
+;;      (let ((beg (point)))
+;;	(insert-before-markers string))
+      (insert-before-markers string)
+      (if (process-mark process)
+	  (set-marker (process-mark process) (point-max))))
+    (if (eq (process-buffer process)
+	    (current-buffer))
+	(goto-char (point-max)))
+    ))
+
+
+(defun eos::insert-on-debugger-buffer (msg rdonly face &optional previous-command)
+  ;; will insert MSG at end of debugger buffer with RDONLY property and with FACE. 
+  ;; If PREVIOUS-COMMAND is given, the newly created extent will be doubly linked into this one
+  ;; using 'previous-command and 'next-command properties
+  (save-window-excursion
+  (let ((fr (selected-frame))
+	(buf (current-buffer))
+	(xt nil))
+    (eos::ensure-debugger-buffer)
+    (toggle-read-only -1)		; not read-only 
+    (eos::insert-echo (eos::dbx-process) msg)
+    (setq xt (eos::insert-string-as-extent msg rdonly face))
+    (if previous-command
+	(progn
+	  (set-extent-property xt 'previous-command previous-command)
+	  (set-extent-property previous-command 'next-command xt)
+	  ))
+    (toggle-read-only 1)		; now read-only 
+    (switch-to-buffer buf)
+    (select-frame fr)
+    xt
+  ))
+  )
+
+(defun eos::insert-string-as-extent (msg rdonly face)
+  ;; insert MSG as a extent with RDONLY and FACE.  Returns the extent
+  (let ((here nil)
+	(xt nil))
+    (goto-char (point-max))
+    (setq here (point))
+    (insert msg)
+    (setq xt (make-extent here (point) nil))
+    (if rdonly
+	(progn
+	  (set-extent-property xt 'read-only t)
+	  (set-extent-property xt 'duplicable nil)
+	  ))
+    (set-extent-face xt face)
+    (eos::synchronize-debugger-buffer)
+    xt
+    ))
+
+
+;; (require 'comint)
+
+(defvar eos::dbx-program "dbx")
+(defvar eos::dbx-switches (list "-editor"))
+
+(defun eos::expand-file-name (file)
+  ;; expand file name depending on first character
+  (cond
+   ((null file)
+    nil)
+   ((eq (elt file 0) ?~)
+    (expand-file-name file))
+   ((eq (elt file 0) ?$)
+    (substitute-in-file-name file))
+   (t file)))
+
+(defun eos::read-dbx-request (program switches)
+  ;; will prompt to the user with PROGRAM and SWITCHES, let her modify this
+  ;; and then will read the result and split it into program and switches.
+  (let* ((prompt
+	  (concat program " " (mapconcat 'identity switches " ")))
+	 (ret (read-from-minibuffer "Run dbx as: " prompt))
+	 (ret2 (split-string ret " ")))
+    ;; some testing
+    (cons (car ret2) (cdr ret2))
+  ))
+
+(defun eos::dbx ()
+;; Run an inferior dbx -editor process, with I/O through buffer *Eos Dbx*.
+;; If buffer exists but dbx process is not running, make new dbx.
+;; If buffer exists and dbx process is running, 
+;; just switch to buffer `*Eos Dbx*'.
+  (let ((buffer "*Eos Dbx*")
+	(buffer-name "Eos Dbx")
+	(input nil))
+    (cond ((not (comint-check-proc buffer))
+	   (setq input (eos::read-dbx-request eos::dbx-program
+					      eos::dbx-switches))
+	   (setq eos::dbx-program (car input))
+	   (setq eos::dbx-switches (cdr input))
+	   (message "Starting Dbx subprocess")
+	   (setq buffer
+		 (set-buffer
+		  (apply 'make-comint 
+			 buffer-name
+			 (eos::expand-file-name eos::dbx-program)
+			 nil
+			 (mapcar 'eos::expand-file-name eos::dbx-switches))))
+	   (comint-mode)
+	   (if (and (eq (device-type (frame-device (selected-frame))) 'tty)
+		    (eq eos::key-mode 'none)
+		    (yes-or-no-p 
+		     "Do you want the prefix map activated?"))
+	       (eos::set-key-mode 'prefix))
+	   (setq eos::dbx-or-debugger 'dbx)
+	   (setq eos::dbx-buffer (current-buffer))
+	   (make-local-variable 'kill-buffer-hook)
+	   (setq kill-buffer-hook
+		 (list (function (lambda ()
+				   (cond
+				    ((null (eos::dbx-process)) t)
+				    ((not (eq (process-status (eos::dbx-process)) 'run)) t)
+				    ((yes-or-no-p
+					  "Warning! Killing this buffer will kill a dbx process, proceed? ")
+				     (eos::internal-clear-annotations t t t t))
+				    (t (error "kill-buffer aborted!")))
+				   ))))
+	   )
+	  (t
+	   (message "Reusing existing dbx buffer and dbx process")))
+    (switch-to-buffer buffer)
+  ))
+
+
+;; Actions to start a debugger in the background.
+
+(defvar eos::debugger-process nil
+  "Debugger process for the background.  Only one per XEmacs")
+
+(defvar eos::dbx-or-debugger nil)
+
+(defun eos::start-debugger ()
+  "Start an \"debugger -editor\" in the background. Will ask for confirmation if
+XEmacs somehow believes there is already one running"
+  (interactive)
+  (if (and (or (not (processp eos::debugger-process))
+	       (not (eq (process-status eos::debugger-process) 'run))
+	       (yes-or-no-p
+		"Warning! XEmacs believes there already is a debugger -editor, proceed? "))
+	   (or (not (eos::dbx-process))
+	       (not (eq (process-status (eos::dbx-process)) 'run))
+	       (yes-or-no-p
+		"Warning! XEmacs believes there already is a dbx -editor, proceed? ")))
+      (progn
+	(setq eos::debugger-process
+	      (start-process "*eos debugger*" nil "debugger" "-editor"))
+	(message "Starting Debugger subprocess")
+	(eos::select-debugger-frame (selected-frame))
+	(setq eos::dbx-or-debugger 'debugger)
+	)))
+
+;; Ditto for dbx.
+
+(defun eos::start-dbx ()
+  "Start an \"dbx -editor\" as a subprocess. Will ask for confirmation if
+XEmacs somehow believes there is already one running"
+  (interactive)
+  (if (and (or (not (processp eos::debugger-process))
+	       (not (eq (process-status eos::debugger-process) 'run))
+	       (yes-or-no-p
+		"Warning! XEmacs believes there already is a debugger -editor, proceed? "))
+	   (or (not (eos::dbx-process))
+	       (not (eq (process-status (eos::dbx-process)) 'run))
+	       (yes-or-no-p
+		"Warning! XEmacs believes there already is a dbx -editor, proceed? ")))
+      (progn
+	(eos::select-debugger-frame (selected-frame))
+	(eos::dbx)
+	)))
+
+
+;;
+;; Communication commands
+;;
+
+(defun eos::spider-do-callback (msg pat)
+  ;; Callback after processing a spider_do request
+  (eos::insert-on-debugger-buffer
+   (format "%s" (get-tooltalk-message-attribute msg 'arg_val 2))
+   t
+   (get-face 'bold))
+  (destroy-tooltalk-message msg)
+  )
+
+(defvar eos::last-command-was-print nil "(eos:: internal)")
+
+(defun eos::spro_spider_output (msg pat)
+  ;; For spider output
+  (let ((s (get-tooltalk-message-attribute msg 'arg_val 1))
+	(err (get-tooltalk-message-attribute msg 'arg_val 2))
+	)
+    (message (format "%s" s))
+    (eos::insert-on-debugger-buffer (format "%s" s)
+				    t
+				    (get-face 'default))
+    (if (and err (not (string-equal err "")))
+	(eos::insert-on-debugger-buffer
+	 (insert (format "STDERR> %s" err))
+	 t
+	 (get-face 'default))
+      )