--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/eos/sun-eos-common.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,533 @@
+;; 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) 'whitespace))
+	  (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)