--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/eos/sun-eos-debugger.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,594 @@
+;;; sun-eos-debugger.el --- Implements the XEmacs/SPARCworks 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 Debugger dbx
+
+;;; Commentary:
+
+;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com
+
+;;; Code:
+
+(require 'eos-common "sun-eos-common")
+
+;;; =================
+;;; debugger protocol
+;;; =================
+
+(defvar eos::current-hollow-arrow nil)
+(defvar eos::current-solid-arrow nil)
+(defvar eos::current-dbx-proc-id nil
+  "TT id for the current dbx")
+(defvar eos::current-debugger-clique-id nil
+  "Clique_ID for the current debugger/dbx")
+
+;; currentpc.color
+
+(defvar eos::currentpc-inst   "/* XPM */
+static char * file[] = {
+\"16 11 5 1\",
+\" 	s background c #BDBDBDBDBDBD\",
+\".	c #000000000000\",
+\"X	c #0000FFFF0000\",
+\"o	c #000077770000\",
+\"O	c #000044440000\",
+\"         .      \",
+\"         ..     \",
+\"         .X.    \",
+\" .........XX.   \",
+\" .XXXXXXXXXoX.  \",
+\" .Xooooooooooo. \",
+\" .oOOOOOOOOoO.  \",
+\" .........OO.   \",
+\"         .O.    \",
+\"         ..     \",
+\"         .      \"};")
+
+(defvar eos::currentpc-inst-alt
+   "/* XPM */
+static char * file[] = {
+\"16 11 5 1\",
+\" 	s background c #BDBDBDBDBDBD\",
+\".	c #000000000000\",
+\"X	c #0000FFFF0000\",
+\"o	c #000077770000\",
+\"O	c #000044440000\",
+\"         .      \",
+\"         ..     \",
+\"         .X.    \",
+\" .........XX.   \",
+\" .XXXXXXXXXoX.  \",
+\" .Xooooooooooo. \",
+\" .oOOOOOOOOoO.  \",
+\" .........OO.   \",
+\"         .O.    \",
+\"         ..   ..\",
+\"         .    ..\"};")
+
+(defvar eos::visitedpc-inst
+   "/* XPM */
+static char * file[] ={
+\"16 11 5 1\",
+\" 	s background c #BDBDBDBDBDBD\",
+\".	c #000000000000\",
+\"X	c #AFAFAFAFAFAF\",
+\"o	c #7E7E7E7EA9A9\",
+\"O	c #666633339999\",
+\"         .      \",
+\"         ..     \",
+\"         .X.    \",
+\" .........XX.   \",
+\" .XXXXXXXXXoX.  \",
+\" .XooooooooooO. \",
+\" .XOOOOOOOOoO.  \",
+\" .........OO.   \",
+\"         .O.    \",
+\"         ..     \",
+\"         .      \"};")
+
+(defvar eos::visitedpc-inst-alt
+   "/* XPM */
+static char * file[] ={
+\"16 11 5 1\",
+\" 	s background c #BDBDBDBDBDBD\",
+\".	c #000000000000\",
+\"X	c #AFAFAFAFAFAF\",
+\"o	c #7E7E7E7EA9A9\",
+\"O	c #666633339999\",
+\"         .      \",
+\"         ..     \",
+\"         .X.    \",
+\" .........XX.   \",
+\" .XXXXXXXXXoX.  \",
+\" .XooooooooooO. \",
+\" .XOOOOOOOOoO.  \",
+\" .........OO.   \",
+\"         .O.    \",
+\"         ..   ..\",
+\"         .    ..\"};")
+
+(defvar eos::breakpoint-inst
+   "/* XPM */
+static char * file[] ={
+\"11 11 5 1\",
+\" 	s background c #BDBDBDBDBDBD\",
+\".	c #000000000000\",
+\"X	c #FFFF66666666\",
+\"o	c #FFFF00000000\",
+\"O	c #777700000000\",
+\"   .....   \",
+\"  .XXXXX.  \",
+\" .XXoooXX. \",
+\".XXoooooXO.\",
+\".XoooooooO.\",
+\".XoooooooO.\",
+\".XoooooooO.\",
+\".XXoooooOO.\",
+\" .XXoooOO. \",
+\"  .OOOOO.  \",
+\"   .....   \"};")
+
+(defvar eos::breakpoint-inst-alt
+   "/* XPM */
+static char * file[] ={
+\"11 11 5 1\",
+\" 	s background c #BDBDBDBDBDBD\",
+\".	c #000000000000\",
+\"X	c #FFFF66666666\",
+\"o	c #FFFF00000000\",
+\"O	c #777700000000\",
+\"   .....   \",
+\"  .XXXXX.  \",
+\" .XXoooXX. \",
+\".XXoooooXO.\",
+\".XoooooooO.\",
+\".XoooooooO.\",
+\".XoooooooO.\",
+\".XXoooooOO.\",
+\" .XXoooOO. \",
+\"  .OOOOO...\",
+\"   ..... ..\"};")
+
+;; The TT protocol does not provide enough information to
+;; use the eos::disabledBreakpoint glyph.
+
+(defvar eos::disabledBreakpoint-inst
+   "/* XPM */
+static char * file[] ={
+\"11 11 4 1\",
+\" 	s background c #BDBDBDBDBDBD\",
+\".	c #000000000000\",
+\"X	c Grey\",
+\"O	c Grey80\",
+\"   .....   \",
+\"  .XXXXX.  \",
+\" .XXXXXXX. \",
+\".XXXXXXXXO.\",
+\".XXXXXXXXO.\",
+\".XXXXXXXXO.\",
+\".XXXXXXXXO.\",
+\".XXXXXXXOO.\",
+\" .XXXXXOO. \",
+\"  .OOOOO.  \",
+\"   .....   \"};")
+
+(defvar eos::disabledBreakpoint-inst-alt
+   "/* XPM */
+static char * file[] ={
+\"11 11 4 1\",
+\" 	s background c #BDBDBDBDBDBD\",
+\".	c #000000000000\",
+\"X	c Grey\",
+\"O	c Grey80\",
+\"   .....   \",
+\"  .XXXXX.  \",
+\" .XXXXXXX. \",
+\".XXXXXXXXO.\",
+\".XXXXXXXXO.\",
+\".XXXXXXXXO.\",
+\".XXXXXXXXO.\",
+\".XXXXXXXOO.\",
+\" .XXXXXOO. \",
+\"  .OOOOO...\",
+\"   ..... ..\"};")
+
+(defvar eos::dbx-pattern-list nil)
+
+(defun eos::debugger-startup ()
+  ;; Actions to do at startup for eos-debugger.el
+  (make-face 'stop-face)
+  (make-face 'solid-arrow-face)
+  (make-face 'hollow-arrow-face)
+  
+  (set-face-foreground 'stop-face eos::stop-color)
+  (set-face-background 'stop-face 
+		       (face-background (get-face 'default)))
+  (set-face-foreground 'solid-arrow-face eos::solid-arrow-color)
+  (set-face-background 'solid-arrow-face 
+		       (face-background (get-face 'default)))
+  (set-face-foreground 'hollow-arrow-face eos::hollow-arrow-color)
+  (set-face-background 'hollow-arrow-face 
+		       (face-background (get-face 'default)))
+
+  (setq eos::dbx-pattern-list		; list of dbx TT patterns
+	(eos::create-debugger-patterns))
+
+;; should there be only one stop-face, with different properties depending
+;; on the frame/device?
+
+  (eos::annotation-set-inst 'debugger-stop 'x eos::breakpoint-inst [nothing])
+  (eos::annotation-set-inst 'debugger-stop 'tty "[S]" [nothing])
+  (eos::annotation-set-face 'debugger-stop 'x
+			    (get-face 'stop-face) (get-face 'stop-face))
+  (eos::annotation-set-face 'debugger-stop 'tty
+			    (get-face 'highlight) (get-face 'highlight))
+
+  (eos::annotation-set-inst 'debugger-hollow-arrow 'x eos::visitedpc-inst [nothing])
+  (eos::annotation-set-inst 'debugger-hollow-arrow 'tty "[]>" [nothing])
+  (eos::annotation-set-face 'debugger-hollow-arrow 'x
+			    (get-face 'hollow-arrow-face)
+			    (get-face 'hollow-arrow-face))
+  (eos::annotation-set-face 'debugger-hollow-arrow 'tty
+			    (get-face 'highlight) (get-face 'highlight))
+
+  (eos::annotation-set-inst 'debugger-solid-arrow 'x eos::currentpc-inst [nothing])
+  (eos::annotation-set-inst 'debugger-solid-arrow 'tty "=>" [nothing])
+  (eos::annotation-set-face 'debugger-solid-arrow 'x
+			    (get-face 'solid-arrow-face)
+			    (get-face 'solid-arrow-face))
+  (eos::annotation-set-face 'debugger-solid-arrow 'tty
+			    (get-face 'highlight) (get-face 'highlight))
+)
+
+;; Not yet ready for prime time.
+
+(defvar eos::fill-stack-buffer nil
+  "when t don't try any stack tracing")
+
+(defvar eos::stack-buffer "*Eos Stack*"
+  "name of buffer where to log Stack")
+
+(defun eos::empty-stack ()
+  ;; No valid stack data - e.g. resume/run program -
+  (if eos::fill-stack-buffer
+      (progn
+	(set-buffer (get-buffer-create eos::stack-buffer))
+	(toggle-read-only -1)
+	(delete-region (point-min) (point-max))
+	(toggle-read-only 1)
+	)))
+
+(defun eos::load-stack ()
+  ;; Should send a TT message requesting for the stack information;
+  ;; with the real work done in a callback
+  (if eos::fill-stack-buffer
+      (eos::stack-test 1)))
+
+(defun eos::visit-stack (stackpos)
+  (if eos::fill-stack-buffer
+      (progn
+	(eos::empty-stack)
+	(eos::stack-test 1)
+	)))
+
+(defun eos::create-stack-patterns ()
+  ;; returns a list of patterns
+  (list
+   (make-an-observer "SPRO_SPIDER_FRAMES" 'eos::spro_spider_frames)
+   ))
+
+(defun eos::spro_spider_frames (msg pat)
+  ;; We have received a SPRO_SPIDER_FRAMES notice
+  (let ((count (get-tooltalk-message-attribute msg 'args_count))
+	(i 1))
+    (set-buffer (get-buffer-create eos::stack-buffer))
+    (toggle-read-only -1)
+    (while (< i count)
+      ;; optional leading comment
+      (if (equal (get-tooltalk-message-attribute msg 'arg_type i)
+		 "Stack_Info1")
+	  (progn
+	    (insert (get-tooltalk-message-attribute msg 'arg_val i))
+	    (setq i (1+ i))))
+      ;; current frame?
+      (insert (if (equal (get-tooltalk-message-attribute msg 'arg_ival i)
+			 "0") "  " "> "))
+      (setq i (1+ i))
+      (insert (format "[%s] %s%s %s:%s"
+		      ;; frameno
+		      (get-tooltalk-message-attribute msg 'arg_ival i)
+		      ;; funcname
+		      (get-tooltalk-message-attribute msg 'arg_val (+ i 1))
+		      ;; funcargs
+		      (get-tooltalk-message-attribute msg 'arg_val (+ i 2))
+      		      ;; source
+		      (get-tooltalk-message-attribute msg 'arg_val (+ i 3))
+		      ;; line
+		      (get-tooltalk-message-attribute msg 'arg_val (+ i 4))))
+      (setq i (+ i 5))
+      (if (equal (get-tooltalk-message-attribute msg 'arg_type i)
+		 "Stack_Info2")
+	  (progn
+	    (insert (get-tooltalk-message-attribute msg 'arg_val i))
+	    (setq i (1+ i))))
+      (insert "\n"))
+    (toggle-read-only 1)
+;;    (return-tooltalk-message msg)
+    ))
+
+(defun eos::spider-stack-callback (msg pat)
+  ;; Callback after processing a spider_stack request
+  (destroy-tooltalk-message msg)
+  )
+
+(defmacro eos::stack-tt-args (spider-id clique-id hidden verbose quick starting-index count)
+  (` (list
+      'class TT_REQUEST
+      'address TT_HANDLER
+      'scope TT_SESSION
+      'handler (, spider-id)
+      'op "SPRO_SPIDER_STACK"
+      'callback 'eos::spider-stack-callback
+      'args (list
+	     (list 'TT_IN (, clique-id) "Context_ID")
+	     (list 'TT_IN (, hidden) "Boolean")
+	     (list 'TT_IN (, verbose) "Boolean")
+	     (list 'TT_IN (, quick) "Boolean")
+	     (list 'TT_IN (, starting-index) "int")
+	     (list 'TT_IN (, count) "int"))
+      )))
+
+(defun eos::stack-test (starting-index)
+  (let ((msg (make-tooltalk-message
+	      (eos::stack-tt-args eos::current-dbx-proc-id
+				  eos::current-debugger-clique-id
+				  0	; hidden
+				  1	; verbose
+				  0	; quick
+				  starting-index
+				  4	; count
+				  ))))
+    (send-tooltalk-message msg)
+;;    (destroy-tooltalk-message msg)
+    ))
+
+;; (setq eos::fill-stack-buffer t)
+;; (setq eos::fill-stack-buffer nil)
+;; (setq eos::stack-pattern-list (eos::create-stack-patterns))
+;; (mapcar 'register-tooltalk-pattern eos::stack-pattern-list)
+;; (mapcar 'unregister-tooltalk-pattern eos::stack-pattern-list)
+;; (eos::stack-test 1)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;
+
+(defun eos::spro_te_eventset (msg pat)
+  ;; thread_id trap_id string string filename lineno string string
+  (let* ((trap-id
+	  (get-tooltalk-message-attribute msg 'arg_val 1))
+	 (filename
+	  (get-tooltalk-message-attribute msg 'arg_val 4))
+	 (lineno
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 5))))
+    (eos::add-annotation 'debugger-stop filename lineno trap-id)
+;;    (return-tooltalk-message msg)
+    ))
+
+(defun eos::spro_te_eventdel (msg pat)
+  ;; trap_id string string filename lineno string string
+  (let* ((trap-id
+	  (get-tooltalk-message-attribute msg 'arg_val 0))
+	 (filename
+	  (get-tooltalk-message-attribute msg 'arg_val 3))
+	 (lineno
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 4))))
+    (eos::delete-annotation 'debugger-stop filename lineno trap-id)
+;;    (return-tooltalk-message msg)
+    ))
+
+(defun eos::spro_te_stopped (msg pat)
+  ;; thread_id filename procname lineno filename procname lineno
+  (let* ((filename-hollow
+	  (get-tooltalk-message-attribute msg 'arg_val 1))
+	 (procname-hollow
+	  (get-tooltalk-message-attribute msg 'arg_val 2))
+	 (lineno-hollow
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 3)))
+	 (filename-solid
+	  (get-tooltalk-message-attribute msg 'arg_val 4))
+	 (lineno-solid
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 6)))
+	 )
+    (setq eos::current-solid-arrow
+	  (eos::make-annotation-visible eos::current-solid-arrow
+					filename-solid
+					lineno-solid
+					'debugger-solid-arrow))
+    (if (or (not (equal filename-solid filename-hollow))
+	    (not (equal lineno-solid lineno-hollow)))
+	(setq eos::current-hollow-arrow
+	      (eos::make-annotation-visible eos::current-hollow-arrow
+				 filename-hollow
+				 lineno-hollow
+				 'debugger-hollow-arrow)))
+;;    (return-tooltalk-message msg)
+    (eos::load-stack)
+    ))
+
+;; Tracking current id's
+;;
+
+(defun eos::update-dbx-proc-id (msg)
+  (setq eos::current-dbx-proc-id
+	(get-tooltalk-message-attribute msg 'sender))
+  ;; the following is needed to make toolbar entries be active or not
+  ;; I think it is not needed in 19.13
+  (eos::select-debugger-frame eos::debugger-frame)
+  )
+
+(defun eos::update-current-debugger-clique-id (msg)
+  (setq eos::current-debugger-clique-id
+	(get-tooltalk-message-attribute msg 'arg_val 0))
+  )
+
+;;
+;; Updating arrows
+;;
+
+
+(defun eos::update-pids (msg)
+  (eos::update-dbx-proc-id msg)
+  (eos::update-current-debugger-clique-id msg))
+
+(defun eos::internal-clear-annotations (stack arrows stops &optional clique)
+  (if stack
+      (eos::empty-stack))
+  (if arrows
+      (progn
+	(eos::make-annotation-invisible eos::current-hollow-arrow)
+	(eos::make-annotation-invisible eos::current-solid-arrow)))
+  (if clique
+      (progn
+	(setq eos::current-debugger-clique-id nil)
+	;; not needed in 19.13?
+	(eos::select-debugger-frame eos::debugger-frame)))
+  (if stops
+      (eos::remove-all-from-annotation-list 'debugger-stop)))
+
+
+(defun eos::clear-arrows (msg pat)
+  (eos::internal-clear-annotations t t nil)
+;;  (return-tooltalk-message msg)
+  )
+
+(defun eos::update-clear-stops (msg pat)
+  (eos::update-pids msg)
+  (eos::internal-clear-annotations t nil t)
+;;  (return-tooltalk-message msg)
+  )
+
+(defun eos::update-clear-arrows-stops (msg pat)
+  (eos::update-pids msg)
+  (eos::internal-clear-annotations t t t)
+;;  (return-tooltalk-message msg)
+  )
+
+(defun eos::clear-arrows-stops (msg pat)
+  (let ((this-proc-id
+	 (get-tooltalk-message-attribute msg 'sender)))
+    (if (equal eos::current-dbx-proc-id this-proc-id)
+	(progn
+	  (eos::internal-clear-annotations t t t)
+	  ;;  (return-tooltalk-message msg)
+	  ))))
+
+;;
+
+;;
+
+(defun eos::spro_detach (msg pat)
+  ;; a detach notification has been received. this means dbx/debugger
+  ;; is exiting
+  (eos::internal-clear-annotations t t t t)
+  (eos::dismiss-print-frame))
+
+(defun eos::spro_te_location (msg pat)
+  ;; thread_id filename procname lineno filename procname lineno
+  (let* ((filename-hollow
+	  (get-tooltalk-message-attribute msg 'arg_val 1))
+	 (lineno-hollow
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 3)))
+	 (filename-solid
+	  (get-tooltalk-message-attribute msg 'arg_val 4))
+	 (lineno-solid
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 6)))
+	 )
+    (setq eos::current-solid-arrow
+	  (eos::make-annotation-visible eos::current-solid-arrow
+			     filename-solid
+			     lineno-solid
+			     'debugger-solid-arrow))
+    (if (or (not (equal filename-solid filename-hollow))
+	    (not (equal lineno-solid lineno-hollow)))
+	(setq eos::current-hollow-arrow
+	      (eos::make-annotation-visible eos::current-hollow-arrow
+				 filename-hollow
+				 lineno-hollow
+				 'debugger-hollow-arrow)))
+;;    (return-tooltalk-message msg)
+    ))
+
+(defun eos::spro_te_visit (msg pat)
+  ;; thread_id filename procname lineno stackpos
+  (let* ((filename
+	  (get-tooltalk-message-attribute msg 'arg_val 1))
+	 (procname
+	  (get-tooltalk-message-attribute msg 'arg_val 2))
+	 (lineno
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 3)))
+	 (stackpos
+	  (read (get-tooltalk-message-attribute msg 'arg_ival 4)))
+	 )
+    (eos::make-annotation-invisible eos::current-hollow-arrow)
+    (if (equal stackpos 1)
+	(progn
+	  (eos::make-annotation-invisible eos::current-solid-arrow)
+	  (setq eos::current-solid-arrow
+		(eos::make-annotation-visible eos::current-solid-arrow
+					      filename
+					      lineno
+					      'debugger-solid-arrow))
+	  )
+      (setq eos::current-hollow-arrow
+	    (eos::make-annotation-visible eos::current-hollow-arrow
+					  filename
+					  lineno
+					  'debugger-hollow-arrow))
+      )
+;;    (return-tooltalk-message msg)
+    (eos::visit-stack stackpos)
+    ))
+
+;; generate a list of patterns
+;; so it can be registered and unregistered.
+
+
+(defun eos::create-debugger-patterns ()
+  ;; returns a list of patterns
+  (list
+   (make-an-observer "SPRO_TE_STOPPED" 'eos::spro_te_stopped)
+   (make-an-observer "SPRO_SE_STARTED" 'eos::clear-arrows)
+   (make-an-observer "SPRO_TE_STEPPED" 'eos::clear-arrows)
+   (make-an-observer "SPRO_TE_CONTINUED" 'eos::clear-arrows)
+   (make-an-observer "SPRO_SE_DROPPED" 'eos::clear-arrows-stops)
+   (make-an-observer "SPRO_SE_DEBUGGED" 'eos::update-clear-stops)
+   (make-an-observer "SPRO_SE_REVIVED" 'eos::update-clear-arrows-stops)
+   (make-an-observer "SPRO_SE_ATTACHED" 'eos::update-clear-arrows-stops)
+   (make-an-observer "SPRO_SE_GONE" 'eos::clear-arrows)
+   (make-an-observer "SPRO_TE_LOCATION" 'eos::spro_te_location)
+   (make-an-observer "SPRO_TE_VISIT" 'eos::spro_te_visit)
+   (make-an-observer "SPRO_TE_EVENTSET" 'eos::spro_te_eventset)
+   (make-an-observer "SPRO_TE_EVENTDEL" 'eos::spro_te_eventdel)
+   (make-an-observer "SPRO_DETACH" 'eos::spro_detach)
+   ))
+
+(defun eos::register-debugger-patterns ()
+  ;; register all dbx patterns
+  (mapcar 'register-tooltalk-pattern eos::dbx-pattern-list)
+  (eos::register-debugger-extra-patterns))
+
+(defun eos::unregister-debugger-patterns ()
+  ;; unregister all dbx patterns
+  (mapcar 'unregister-tooltalk-pattern eos::dbx-pattern-list)
+  (eos::unregister-debugger-extra-patterns))
+
+(provide 'eos-debugger)
+
+;;; sun-eos-debugger.el ends here