+++ /dev/null
-;;; 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
projects / packages / blobdiff