datawatch.tcl

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

		if {$ntype == "native"} {
		    lappend DataDisplay:localNatives($debugfrm,$xcontext,$depth) $gdbvar
		}
	    }

	    catch {
		$hlist add $entry \
		    -itemtype text \
		    -style leafTextStyle \
		    -data [list $ntype $ident $scope $gdbvar {}] \
		    -text $ident
	    }

	    $tree setmode $entry open
	}
    }

    # filter the obsolete variables out of the poll list (i.e.
    # those variables which used to be displayed but are
    # no more defined in the current lexical scope). Remember
    # that user-defined expressions have new names which may
    # never conflict with variable names.

    set oldList {}

    catch {
	set oldList \
	    [set DataDisplay:tracedEntryList($debugfrm,Locals,$xcontext,$depth)]
    }

    foreach entry $oldList {
	if {[$hlist info exists $entry] == 1} {
	    lappend pollList $entry
	}
    }

    if {$pollList != {}} {
	if {$autofocus == "true"} {
	    set focuscmd [Debugger:buildFocusCmd $debugfrm]
	    # direct stack context to the current focus -- unlike
	    # Debugger:resume{} entry context, we already control
	    # the debuggee. So there is no need for a HoldSimulation
	    # request to be issued.
	    set fnum [lindex [lindex [set Debugger:stackinfo($debugfrm)] $level] 0]
	    gdb:switchin $context $focuscmd $fnum
	}
	foreach entry $pollList {
	    DataDisplay:displayDataNode $debugfrm $tree $entry
	}
	if {$autofocus == "true"} {
	    gdb:switchout $context
	}
    }

    # reset the poll list to what is really viewable at
    # this point of execution from this context.
    set DataDisplay:tracedEntryList($debugfrm,Locals,$xcontext,$depth) $pollList
}

proc DataDisplay:openDataNode {debugfrm tree entry} {

    global Debugger:f2c DataDisplay:tracedEntryList
    global DataDisplay:hiddenExprList
    global Debugger:stackinfo Debugger:stacklevel
    global Debugger:stacklength Debugger:xcontext

    set hlist [$tree subwidget hlist]
    set top [$hlist info children]
    set context [set Debugger:f2c($debugfrm)]
    set ndata [$hlist info data $entry]
    set scope [lindex $ndata 2]

    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 0
    }

    if {$top == "Locals"} {
	set level [set Debugger:stacklevel($debugfrm)]
	set depth [expr [set Debugger:stacklength($debugfrm)] - $level]
	set xcontext [set Debugger:xcontext($debugfrm)]
    } {
	set depth 0
	set xcontext system
    }

    set pollList {}
    catch { set pollList [set DataDisplay:tracedEntryList($debugfrm,$top,$xcontext,$depth)] }
    if {[lsearch -exact $pollList $entry] != -1} {
	# this can occur as we reenter the Tk notifier
	# when regaining control over the debugger...
	return
    }
    if {[Debugger:resume $context $focuscmd $fnum] == "false"} {
	return
    }

    DataDisplay:displayDataNode $debugfrm $tree $entry

    set ntype [lindex $ndata 0]
    if {$ntype == "native" || $ntype == "user"} {
	# only register root nodes for polling
	lappend DataDisplay:tracedEntryList($debugfrm,$top,$xcontext,$depth) $entry
    }
    Debugger:suspend $context $focuscmd
}

proc DataDisplay:closeDataNode {debugfrm tree entry} {

    global DataDisplay:tracedEntryList Debugger:stacklength

    if {[$tree getmode $entry] == "open"} {
	# already closed -- ignore silently
	return
    }

    set hlist [$tree subwidget hlist]
    set top [$hlist info children]
    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 {$top == "Locals"} {
	global Debugger:stacklevel Debugger:xcontext
	global Debugger:stackinfo

	set level [set Debugger:stacklevel($debugfrm)]
	set depth [expr [set Debugger:stacklength($debugfrm)] - $level]
	set xcontext [set Debugger:xcontext($debugfrm)]
    } {
	set depth 0
	set xcontext system
    }

    set n [lsearch -exact \
	       [set DataDisplay:tracedEntryList($debugfrm,$top,$xcontext,$depth)] $entry]
    set DataDisplay:tracedEntryList($debugfrm,$top,$xcontext,$depth) \
	[lreplace [set DataDisplay:tracedEntryList($debugfrm,$top,$xcontext,$depth)] $n $n]

    if {[$hlist info children $entry] != {}} {
	# entry has children, we have to destroy its offsprings
	$hlist delete offsprings $entry
    }

    # just in case the value is listed beside the identifier, reset the
    # entry label to the expression name, except if this is not a
    # toplevel node (i.e. not a "user" or "native" entry).

    if {$ntype != "leaf" && $ntype != "node"} {
	$hlist entryconfig $entry -text [lindex $ndata 1] \
	    -style leafTextStyle
    }
}

proc DataDisplay:clearDataNode {debugfrm tree entry} {

    DataDisplay:closeDataNode $debugfrm $tree $entry

    set hlist [$tree subwidget hlist]
    set ndata [$hlist info data $entry]
    set ntype [lindex $ndata 0]

    if {$ntype != "node" && $ntype != "leaf"} {
	# closing a root -- discard all reference pathes
	$hlist entryconfig $entry -data [lrange $ndata 0 4]
	return
    }

    # remove intermediate entry from reference path list,
    # and all its offsprings.

    set root {}
    set parent [$hlist info parent $entry]
    set refpath [DataDisplay:buildRefPath $hlist $parent root]
    set rdata [$hlist info data $root]
    set pathlist [lindex $rdata 5]

    if {$refpath == {}} {
	# empty path found? we are closing a member which is
	# directly hooked below the root entry.
	if {[lindex $pathlist 0] == -1} {
	    # this one is an absolute kludge:: i wonder if i just remember
	    # how it works! Anyway, this is relevant with the special value
	    # of -1 which can be set by followDataNode to force the root
	    # entry to be dereferenced (pretending it's a pointer). The
	    # resulting expr (of the dereference) which is fold has rank
	    # number 0 in the root child list, but we need to match -1
	    # to have it removed from this list. So help ourselves, and
	    # hack a bit to force the reference path value to -1, if the
	    # first dereferenced member of the root entry was itself...
	    set refpath -1
	} {
	    set refpath [lsearch [$hlist info children $root] $entry]
	}
    }

    # closing a sub-node or leaf -- try removing its path from the list
    set rmid [lsearch -exact $pathlist $refpath]
    set l [expr [llength $refpath] - 1]

    if {$rmid != -1} {
	set newlist {}
	foreach path $pathlist {
	    if {[lrange $path 0 $l] != $refpath} {
		lappend newlist $path
	    }
	}
	$hlist entryconfig $root -data [concat [lrange $rdata 0 4] [list $newlist]]
    }

    # Now, update the entry indicator according to its new state --
    # it should be noted that all actions on the entry are
    # postponed until the notifier is idle using an "after" clause.
    # This way, Tix can return from the running callback without
    # having to complain about inexistent indicator or entry it
    # tries to update, after we've just deleted it.

    set ident [lindex $ndata 1]

    if {[string index $ident 0] == "*"} {
	# folding a dereference node means deleting it
	after idle "catch { $hlist delete entry $entry }"
	set pdata [$hlist info data $parent]
	set ptype [lindex $pdata 0]
	if {$ptype == "leaf"} {
	    # if parent used to be a leaf entry, remove the indicator
	    after idle "catch { $tree setmode $parent none }"
	}
	$hlist entryconfig $parent -style leafTextStyle
    } {
	if {$ntype == "leaf"} {
	    # if this used to be a leaf entry, remove the indicator
	    after idle "catch { $tree setmode $entry none }"
	    $hlist entryconfig $entry -style leafTextStyle
	} {
	    # otherwise, finish updating the indicator to reflect
	    # the new state fold state.
	    after idle "catch { $tree setmode $entry open }"
	    $hlist entryconfig $entry -style leafTextStyle
	}
    }
}

proc DataDisplay:displayDataNode {debugfrm tree entry} {

    set hlist [$tree subwidget hlist]

    if {![$hlist info exists $entry]} {
	# This may happen when global data are tracked
	# in the local variable window...
	return
    }

    set ndata [$hlist info data $entry]
    set ntype [lindex $ndata 0]
    set scope [lindex $ndata 2]
    set gdbvar [lindex $ndata 3]
    set refpath [lindex $ndata 5]

    set vlist [gdb:getdata $gdbvar "no_format" true]
    DataDisplay:displayAggr $debugfrm $tree $entry $gdbvar $vlist

    if {$ntype == "leaf"} {
	$hlist entryconfig $entry -style leafTextStyle
	$tree setmode $entry none
    } {
	$hlist entryconfig $entry -style leafTextStyle
	$tree setmode $entry close
    }

    # now, automatically dereference followed pointers

    foreach path $refpath {
	set subentry $entry
	foreach pos $path {
	    if {$pos < 0} {
		DataDisplay:dereferenceData $debugfrm $tree $entry true
	    } {
		set children [$hlist info children $subentry]
		set subentry [lindex $children $pos]
		if {$subentry != {}} {
		    DataDisplay:dereferenceData $debugfrm $tree $subentry true
		}
	    } 
	}
    }
}

proc DataDisplay:displayAggr {debugfrm tree entry gdbvar vlist} {

    set hlist [$tree subwidget hlist]
    catch { $hlist delete offsprings $entry }

    if {[lindex $vlist 0] == "@node"} {
	foreach member [lindex $vlist 1] {
	    DataDisplay:displayMember $debugfrm $tree $entry $gdbvar $member
	}
    } {
	set ndata [$hlist info data $entry]
	set ident [lindex $ndata 1]
	append ident " = " $vlist
	$hlist entryconfig $entry -text $ident
    }
}

proc DataDisplay:displayMember {debugfrm tree entry gdbvar value} {

    global Application:treeSeparator DataDisplay:seqNum

    set hlist [$tree subwidget hlist]
    set ndata [$hlist info data $entry]
    set ident [lindex $ndata 1]
    set scope [lindex $ndata 2]
    set file [lindex $ndata 4]
    set name [lindex $value 0]
    set info [lindex $value 1]

    if {$name == "@node"} {
	# Partial struct requests do not print out their
	# head member -- thus trap the case when the
	# member name is in fact the @node keyword and
	# assume that we are processing a sub-aggregate
	# of a global struct.
	DataDisplay:displayAggr $debugfrm $tree $entry \
	    $gdbvar [list @node $info]
	return
    }

    append entry ${Application:treeSeparator}@[incr DataDisplay:seqNum]

    # FIXME: the following lines should be moved to the GDB helper
    # since they are language dependent.  However, '*' should be kept
    # as a generic "dereference" marker.

    set strictid [string trimleft $name *]

    if {$name != $strictid} {
	set gdbvar *($gdbvar)
    } {
	append gdbvar . $name
    }

    # ENDFIXME

    if {$info == "@node"} {
	set info [lindex $value 2]
	$hlist add $entry -itemtype text -text $name \
	    -style leafTextStyle \
	    -data [list node $name $scope $gdbvar $file]
	$tree setmode $entry close
	DataDisplay:displayAggr $debugfrm $tree $entry \
	    $gdbvar [lrange $value 1 end]
	return
    }

    if {$info == {}} {
	set label [format " = %s" $name]
	$hlist add $entry -itemtype text -text $label \
	    -style leafTextStyle
    } {
	set label [format "%s = %s" $name $info]
	$hlist add $entry -itemtype text -text $label \
	    -style leafTextStyle \
	    -data [list leaf $name $scope $gdbvar $file]
    }

    $tree setmode $entry none
}

proc DataDisplay:setTreeState {debugfrm state {tree {}}} {

    if {$tree == {}} {
	# no tree specified means "globals" tree
	set tree $debugfrm.gbldisp.f.tree
    }

    # kludge: there is no easy method to globally invalidate
    # the sensitivity of a tixTree widget, thus we just assign
    # a void -command callback at the HList level to disable the
    # whole tree.

    if {[winfo exists $tree]} {
	set hlist [$tree subwidget hlist]
	set top [$hlist info children]
	if {$state == "disabled"} {
	    set cmd [$hlist cget -command]
	    $hlist entryconfig $top -data $cmd
	    $hlist config -command {}
	} {
	    set cmd [$hlist info data $top]
	    if {$cmd != {}} {
		$hlist config -command $cmd
	    }
	}
    }
}

proc DataDisplay:saveGlobals {context} {

    set hlist [$context.gbldisp.f.tree subwidget hlist]
    set settings {}
    # Note: we save the contents of the global data tree
    # instead of using the tracedEntryList array variable
    # because we want every variable pinned on the watch
    # board being remembered, including those which are
    # currently collapsed.
    set tracelist [$hlist info children Globals]

    foreach entry $tracelist {
	set ndata [$hlist info data $entry]
	# don't save the reference path list
	lappend settings [lrange $ndata 0 4]
    }

    Project:setResource DebuggerGlobals $settings
}

proc DataDisplay:restoreGlobals {context} {

    global DataDisplay:hiddenExprList Application:treeSeparator
    global DataDisplay:userExprList

    set settings [Project:getResource DebuggerGlobals]
    set tree $context.gbldisp.f.tree

    foreach ndata $settings {
	set ntype [lindex $ndata 0]
	if {$ntype == "user"} {
	    lappend DataDisplay:userExprList($context,Globals,system,0) $ndata
	} {
	    set nth [lsearch -exact \
			 [set DataDisplay:hiddenExprList($context,Globals,system,0)] $ndata]
	    if {$nth != -1} {
		set DataDisplay:hiddenExprList($context,Globals,system,0) \
		    [lreplace [set DataDisplay:hiddenExprList($context,Globals,system,0)] $nth $nth]
	    } {
		# variable is no more defined -- forget it.
		continue
	    }
	}
	set ident [lindex $ndata 1]
	set gdbvar [lindex $ndata 3]
	set top [$tree subwidget hlist info children]
	set entry $top${Application:treeSeparator}$ident

	$tree subwidget hlist add $entry \
	    -itemtype text \
	    -style leafTextStyle \
	    -data $ndata \
	    -text $ident
	
	$tree setmode $entry open
    }
}