datawatch.tcl

rtai-3.1-test3的源代码(Real-Time Application Interface )

#  This file is part of the XENOMAI project.
#
#  Copyright (C) 1997-2000 Realiant Systems.  All rights reserved.
#  Copyright (C) 2001,2002 Philippe Gerum <[e-mail]>.
# 
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License as
#  published by the Free Software Foundation; either version 2 of the
#  License, or (at your option) any later version.
# 
#  This program 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.
# 
#  Author(s): rpm
#  Contributor(s):
#
#  - Adapted to XENOMAI by Philippe Gerum.
#  - "Instruction" formatting by Viktor Tarasov <[e-mail]>.

#  global tcl_traceExec
#  set tcl_traceExec 1

set DataDisplay:hiddenExprList(0,0,0,0) {}
set DataDisplay:userExprList(0,0,0,0) {}
set DataDisplay:tracedEntryList(0,0,0,0) {}
set DataDisplay:localNatives(0,0,0,0) {}
set DataDisplay:seqNum 0
set DataDisplay:typeTagNum 0

proc DataDisplay:makeGlobalsTree {context} {

    global Application:treeSeparator
    global DataDisplay:tracedEntryList DataDisplay:hiddenExprList

    set w $context.gbldisp
    toplevel $w
    wm title $w "Globals Display"
    wm protocol $w WM_DELETE_WINDOW "wm withdraw $w"
    bind $w <Escape> "wm withdraw $w"
    cascadeWindow $w $context
    TkRequest $context CacheWindowIn $w Globals

    frame $w.f
    pack $w.f -expand yes -fill both
    set tree $w.f.tree

    tixTree $tree -options {
	hlist.width 50
	hlist.height 25
    }

    pack $tree -fill both -expand yes
    set hlist [$tree subwidget hlist]
    $hlist config -separator ${Application:treeSeparator}
    $tree config -opencmd "DataDisplay:openDataNode $context $tree" \
	          -closecmd "DataDisplay:clearDataNode $context $tree"

    $hlist add Globals -style rootTextStyle -itemtype text \
	-text Globals

    DataDisplay:setBackMenu $context $tree

    tixButtonBox $w.bbox -orientation horizontal -relief flat -bd 0
    $w.bbox add dismiss -text Close -command "wm withdraw $w"
    pack $w.bbox -side bottom -fill x

    set DataDisplay:tracedEntryList($context,Globals,system,0) {}
    set DataDisplay:hiddenExprList($context,Globals,system,0) {}
    DataDisplay:restoreGlobals $context

    $tree setmode Globals none
    wm withdraw $context.gbldisp
}

proc DataDisplay:makeLocalsTree {debugfrm tree} {

    global Application:treeSeparator

    tixTree $tree
    pack $tree -fill both -expand yes
    set hlist [$tree subwidget hlist]
    $hlist config -separator ${Application:treeSeparator}
    $tree config -opencmd "DataDisplay:openDataNode $debugfrm $tree" \
	          -closecmd "DataDisplay:clearDataNode $debugfrm $tree"
    $hlist add Locals -itemtype text -text Locals -style rootTextStyle
    $tree setmode Locals none

    DataDisplay:setBackMenu $debugfrm $tree
}

proc DataDisplay:setBackMenu {debugfrm tree} {

    set hlist [$tree subwidget hlist]
    backmenu $tree.popup -tearoff 0
    set menu [$tree.popup subwidget menu]
    $menu add command -label "Display *" -command \
	"DataDisplay:followData $debugfrm $tree"
    $menu add command -label "Show type" -command \
	"DataDisplay:showType $debugfrm $tree"
    $menu add command -label "Set value" -command \
	"DataDisplay:setExpr $debugfrm $tree"
    $menu add command -label "Remove" -command \
	"DataDisplay:remExpr $debugfrm $tree"
    $menu add sep
    $menu add command -label "Select..." -command \
	"DataDisplay:addExpr $debugfrm $tree"
    $tree.popup validate  \
	"DataDisplay:postBackMenu $debugfrm $menu $hlist"
    $tree.popup bind $hlist
}

proc DataDisplay:postBackMenu {debugfrm menu hlist rx ry} {

    set sensitivity [$hlist cget -command]

    if {$sensitivity == {}} {
	# simulation is running -- (see setTreeState)
	# backmenu is locked down
	return false
    }

    $hlist selection clear
    set top [$hlist info children]
    # turn root coordinates into local coordinates
    set y [expr $ry - [winfo rooty $hlist]]
    set entry [$hlist nearest $y]

    if {$entry != {} && $entry != $top} {
	$hlist selection set $entry
	set ndata [$hlist info data $entry]

	if {$ndata != {}} {
	    # some leaf data (such as unnamed bitfield
	    # members) cannot be reached directly through
	    # a valid name -- do not allow them to be changed
	    # this way.
	    set ntype [lindex $ndata 0]
	    $menu entryconfig 1 -state normal
	    $menu entryconfig 2 -state normal
	    $menu entryconfig 3 -state normal
	    if {$ntype != "node"} {
		# allow dereferencing root and leaf nodes
		# (i.e. all but intermediate "node"-typed entries)
		$menu entryconfig 0 -state normal
	    } {
		$menu entryconfig 0 -state disabled
	    }
	} {
	    $menu entryconfig 0 -state disabled
	    $menu entryconfig 1 -state disabled
	    $menu entryconfig 2 -state disabled
	    $menu entryconfig 3 -state disabled
	}
    } {
	# no expression selected for change.
	$menu entryconfig 0 -state disabled
	$menu entryconfig 1 -state disabled
	$menu entryconfig 2 -state disabled
	$menu entryconfig 3 -state disabled
    }

    return true
}

proc DataDisplay:setExpr {debugfrm tree} {

    set hlist [$tree subwidget hlist]
    set sel [$hlist info selection]

    if {$sel == {}} {
	# Yes! This happened.
	return
    }

    set entry [lindex $sel 0]
    set ndata [$hlist info data $entry]
    set name [lindex $ndata 1]

    set w $tree.set
    toplevel $w
    wm title $w "Set `$name'"
    cascadeWindow $w [winfo toplevel $tree]

    set lbf [frame $w.lbf -relief raised -bd 1]

    tixLabelEntry $lbf.entry -label "New value: " \
	-options {
	    entry.width 20
	}

    set e [$lbf.entry subwidget entry]
    $e configure -textvariable $e:value
    global $e:value
    set $e:value {}
    bind $e <Return> "DataDisplay:setExprOk $debugfrm $tree [list $entry]"
    bind $e <Escape> "destroy $w"
    pack $lbf.entry -pady 5 -padx 15 -anchor w
    pack $w.lbf -expand yes -fill both

    tixButtonBox $w.bbox -orientation horizontal -relief flat -bd 0
    $w.bbox add ok -text OK -command \
	"DataDisplay:setExprOk $debugfrm $tree [list $entry]"
    $w.bbox add cancel -text Cancel -command "destroy $w"
    pack $w.bbox -side bottom -fill x

    focus $e
    tkwait visibility $w
    grab $w
}

proc DataDisplay:setExprOk {debugfrm tree entry} {

    global Debugger:stackinfo Debugger:stacklevel
    global Debugger:f2c

    set context [set Debugger:f2c($debugfrm)]
    set hlist [$tree subwidget hlist]
    set ndata [$hlist info data $entry]
    set w $tree.set
    set lbf $w.lbf
    set e [$lbf.entry subwidget entry]

    global $e:value

    if {[set $e:value] == {}} {
	# silently abort operation on empty input
	destroy $w
	return
    }

    set scope [lindex $ndata 2]
    set gdbvar [lindex $ndata 3]

    if {$scope == "local"} {
	set focuscmd [Debugger:buildFocusCmd $debugfrm]
	set level [set Debugger:stacklevel($debugfrm)]
	set fnum [lindex [lindex [set Debugger:stackinfo($debugfrm)] $level] 0]
    } {
	set focuscmd {}
	set fnum {}
    }

    # get control over the debugger (update routines assume this)
    if {[Debugger:resume $context $focuscmd $fnum] == "false"} {
	set log "internal error"
    } {
	set log [gdb:setdata $gdbvar [set $e:value]]
	Debugger:suspend $context $focuscmd
    }

    if {$log != {}} {
	# the "set" command log should be empty -- otherwise, and error occured.
	tk_messageBox -parent $debugfrm \
	    -message [lindex $log 0] \
	    -type ok -icon error -title Error
	raise $w
	return
    } {
	DataDisplay:closeDataNode $debugfrm $tree $entry
	DataDisplay:openDataNode $debugfrm $tree $entry
    }
    
    raise [winfo toplevel $tree]
    destroy $w
}

proc DataDisplay:buildRefPath {hlist entry rootvar} {

    upvar $rootvar root
    set root $entry
    set refpath {}

    while {$root != {}} {
	set ndata [$hlist info data $root]
	set ntype [lindex $ndata 0]
	if {$ntype != "leaf" && $ntype != "node"} {
	    # i.e. must be "native" or "user" in this case:
	    # thus we've found the entry's root...
	    break
	}
	set parent [$hlist info parent $root]
	set refpath [linsert $refpath 0 \
			 [lsearch -exact [$hlist info children $parent] $root]]
	set root $parent
    }

    return $refpath
}

proc DataDisplay:followData {debugfrm tree} {

    global Debugger:f2c
    global Debugger:stackinfo Debugger:stacklevel

    set context [set Debugger:f2c($debugfrm)]
    set hlist [$tree subwidget hlist]
    set sel [$hlist info selection]
    set entry [lindex $sel 0]

    if {[$tree getmode $entry] == "open"} {
	# node to follow is closed -- open it before dereferencing
	DataDisplay:openDataNode $debugfrm $tree $entry
    }

    # Update the reference path list stored in the root entry.
    # Each member of this list is a reference path.
    # This path is a list of dereferenced members on a per-level basis,
    # outer first, inner (deeper) last. Each member is a sub-list of
    # the node positions to follow.
    # For instance, the expressions "*global_var.link->next->link"
    # and "*global_var.next" could generate the following reference
    # path (pretending "next" and "link" respectively are the 4th and
    # 5th members from the top of the "global_var" type (0-based)):
    # {4 3 4} {3}

    set root {}
    set refpath [DataDisplay:buildRefPath $hlist $entry root]
    if {$refpath == {}} {
	# i.e. root entry? put it on the reference path as item no. -1
	set refpath -1
    }
    set rdata [$hlist info data $root]
    set pathlist [lindex $rdata 5]

    if {[lsearch -exact $pathlist $refpath] == -1} {
	lappend pathlist $refpath
	$hlist entryconfig $root -data [concat [lrange $rdata 0 4] [list $pathlist]]
    }

    DataDisplay:dereferenceData $debugfrm $tree $entry
}

proc DataDisplay:dereferenceData {debugfrm tree entry {inctl false}} {

    global Debugger:f2c
    global Debugger:stackinfo Debugger:stacklevel

    set context [set Debugger:f2c($debugfrm)]
    set hlist [$tree subwidget hlist]
    set ndata [$hlist info data $entry]
    set ntype [lindex $ndata 0]
    set ident [lindex $ndata 1]
    set scope [lindex $ndata 2]
    set gdbvar [lindex $ndata 3]

    if {$scope == "local"} {
	set focuscmd [Debugger:buildFocusCmd $debugfrm]
	set level [set Debugger:stacklevel($debugfrm)]
	set fnum [lindex [lindex [set Debugger:stackinfo($debugfrm)] $level] 0]
    } {
	set focuscmd {}
	set fnum {}
    }

    # get control over the debugger (if not "in control")

    if {$inctl == "true" ||
	[Debugger:resume $context $focuscmd $fnum] != "false"} {

	set vlist [gdb:followdata $gdbvar]

	if {$inctl == "false"} {
	    Debugger:suspend $context $focuscmd
	}

	if {[lindex $vlist 0] != "@node"} {
	    # the datum accessed by dereferencing a pointer is always
	    # displayed as a sub-tree of the source pointer.
	    set vlist [list @node [list [concat *$ident $vlist]]]
	}

	DataDisplay:displayAggr $debugfrm $tree $entry $gdbvar $vlist
	$tree setmode $entry close
    }

    $hlist entryconfig $entry -style highlightedLeafStyle
}

proc DataDisplay:showTypeWorker {debugfrm hostw expr} {

    global DataDisplay:typeTagNum Debugger:f2c

    set cmd "typeinfo [list $expr]"
    set typeinfo [DataDisplay:evalWorker $debugfrm $cmd false]

    if {$typeinfo == {}} {
	tk_messageBox -parent $debugfrm \
	    -message "No type information available for `$expr'" \
	    -type ok -icon error -title Error
	return {}
    }

    # all typeinfo windows are children of the global data display so
    # that they are destroyed when the simulation is killed.
    set context [set Debugger:f2c($debugfrm)]
    set w $context.gbldisp.typeinfo[incr DataDisplay:typeTagNum]
    toplevel $w
    wm title $w "Type of `$expr'"
    cascadeWindow $w $hostw

    tixScrolledText $w.text -scrollbar auto
    set textw [$w.text subwidget text]
    set lines 0
    set cols 0
    foreach l $typeinfo {
	$textw insert end "$l\n"
	incr lines
	set len [string length $l]
	if {$cols < $len} {
	    set cols $len
	}
    }
    if {$lines < [$textw cget -height]} {
	$textw config -height $lines
    } {
	if {$lines > 40} {
	    # set a reasonable max. height for the text buffer
	    $textw config -height 40
	}
    }
    if {$cols < [$textw cget -width]} {
	$textw config -width $cols
    } {
	if {$width > 80} {
	    # set a reasonable max. width for the text buffer
	    $textw config -width 80
	}
    }
    $textw config -state disabled
    pack $w.text -expand yes -fill both

    tixButtonBox $w.bbox -orientation horizontal -relief flat -bd 0
    $w.bbox add dismiss -text Close -command "destroy $w"
    pack $w.bbox -side bottom -fill x

    bind $w <Escape> "destroy $w"
    focus $w

    return $w
}

proc DataDisplay:showType {debugfrm tree} {

    set hlist [$tree subwidget hlist]
    set sel [$hlist info selection]

    if {$sel == {}} {
	# Yes! This happened.
	return
    }

    set entry [lindex $sel 0]
    set ndata [$hlist info data $entry]
    set gdbvar [lindex $ndata 3]
    DataDisplay:showTypeWorker $debugfrm [winfo toplevel $tree] $gdbvar
}

proc DataDisplay:evalWorker {debugfrm cmd inctl} {

    global Debugger:f2c Debugger:stackinfo Debugger:stacklevel
    global Debugger:xcontext