datawatch.tcl

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

    set context [set Debugger:f2c($debugfrm)]
    set level [set Debugger:stacklevel($debugfrm)]
    set focuscmd [Debugger:buildFocusCmd $debugfrm]
    set fnum [lindex [lindex [set Debugger:stackinfo($debugfrm)] $level] 0]
    set vlist {}

    # get control over the debugger (if not already held)

    if {$inctl == "true" ||
	[Debugger:resume $context $focuscmd $fnum] != "false"} {
	set vlist [eval gdb:$cmd]
	if {$inctl == "false"} {
	    Debugger:suspend $context $focuscmd
	}
    }

    return $vlist
}

proc DataDisplay:evalExpr {debugfrm expr format {inctl false}} {

    set cmd "getdata [list $expr] $format false"
    return [DataDisplay:evalWorker $debugfrm $cmd $inctl]
}

proc DataDisplay:dumpExpr {debugfrm expr format count size {inctl false}} {

    set cmd "dumpdata [list $expr] $format $count $size"
    return [DataDisplay:evalWorker $debugfrm $cmd $inctl]
}

proc DataDisplay:lookupExpr {debugfrm expr {inctl false}} {

    global Debugger:f2c
    global Debugger:stackinfo Debugger:stacklevel
    global Debugger:stacklength

    set context [set Debugger:f2c($debugfrm)]
    set level [set Debugger:stacklevel($debugfrm)]

    catch {
	set depth [expr [set Debugger:stacklength($debugfrm)] - $level]
    }

    set focuscmd [Debugger:buildFocusCmd $debugfrm]
    set fnum [lindex [lindex [set Debugger:stackinfo($debugfrm)] $level] 0]
    set location {}

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

    if {$inctl == "true" ||
	[Debugger:resume $context $focuscmd $fnum] != "false"} {
	set location [gdb:locate $expr]
	if {$inctl == "false"} {
	    Debugger:suspend $context $focuscmd
	}
    }

    return $location
}

proc DataDisplay:remExpr {debugfrm tree} {

    global DataDisplay:hiddenExprList DataDisplay:userExprList

    set hlist [$tree subwidget hlist]
    set top [$hlist info children]
    set sel [$hlist info selection]
    set entry [lindex $sel 0]
    set ndata [$hlist info data $entry]
    set ntype [lindex $ndata 0]
    set scope [lindex $ndata 2]

    DataDisplay:clearDataNode $debugfrm $tree $entry

    if {$ntype == "native" || $ntype == "user"} {
	# forgetting a toplevel entry means removing
	# the corresponding expression.
	$tree subwidget hlist delete entry $entry

	if {$top == "Locals"} {
	    global Debugger:stackinfo Debugger:stacklevel
	    global Debugger:stacklength Debugger:xcontext
	    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
	}

	if {$ntype == "user"} {
	    set nth [lsearch -exact \
			 [set DataDisplay:userExprList($debugfrm,$top,$xcontext,$depth)] $ndata]
	    if {$nth != -1} {
		set DataDisplay:userExprList($debugfrm,$top,$xcontext,$depth) \
		    [lreplace [set DataDisplay:userExprList($debugfrm,$top,$xcontext,$depth)] $nth $nth]
	    }
	    # forget user-defined expressions
	} {
	    lappend DataDisplay:hiddenExprList($debugfrm,$top,$xcontext,$depth) $ndata
	}
    }
}

proc DataDisplay:addExpr {debugfrm tree} {

    global DataDisplay:hiddenExprList

    set w [winfo toplevel $tree].addexpr
    set top [$tree subwidget hlist info children]
    toplevel $w
    wm title $w "Auto-Display $top"
    cascadeWindow $w

    if {$top == "Locals"} {
	global Debugger:stackinfo Debugger:stacklevel
	global Debugger:stacklength Debugger:xcontext
	    
	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 lbf1 [frame $w.lbf1 -relief raised -bd 1]
    pack $lbf1 -side top -expand yes -fill both

    tixScrolledListBox $lbf1.list -scrollbar auto \
	-command "DataDisplay:pickExpr $debugfrm $tree $lbf1.list \"$xcontext\" $depth"
    set lbox [$lbf1.list subwidget listbox]
    $lbox config -height 15 -width 30
    pack $lbf1.list -expand yes -fill both

    tixLabelFrame $w.lbf2 -label "Auto-display expression" \
	-labelside acrosstop
    pack $w.lbf2 -expand no -fill x
    set lbf2 [$w.lbf2 subwidget frame]
    
    set e $lbf2.entry
    entry $e -width 20
    pack $e -expand no -fill x
    bind $e <Return> "DataDisplay:readExpr $debugfrm $tree $w $e"
    bind $e <Escape> "destroy $w"
    focus $e

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

    if {[catch {set exprinfo \
		    [set DataDisplay:hiddenExprList($debugfrm,$top,$xcontext,$depth)]}] == 1} {
	set exprinfo {}
    }

    foreach vinfo $exprinfo {
	set ident [lindex $vinfo 1]
	$lbox insert end $ident
    }

    tkwait visibility $w
    grab $w
}

proc DataDisplay:displayVariable {debugfrm tree xcontext depth nth} {

    global DataDisplay:hiddenExprList Application:treeSeparator

    set top [$tree subwidget hlist info children]
    set vinfo [lindex [set DataDisplay:hiddenExprList($debugfrm,$top,$xcontext,$depth)] $nth]
    set DataDisplay:hiddenExprList($debugfrm,$top,$xcontext,$depth) \
	[lreplace [set DataDisplay:hiddenExprList($debugfrm,$top,$xcontext,$depth)] $nth $nth]

    set ntype [lindex $vinfo 0]
    set ident [lindex $vinfo 1]
    set scope [lindex $vinfo 2]
    set gdbvar [lindex $vinfo 3]
    set file [lindex $vinfo 4]
    set entry $top${Application:treeSeparator}$ident

    $tree subwidget hlist add $entry \
	-itemtype text \
	-style leafTextStyle \
	-data [list $ntype $ident $scope $gdbvar $file] \
	-text $ident

    $tree setmode $entry open
    DataDisplay:openDataNode $debugfrm $tree $entry

    return $entry
}

proc DataDisplay:displayExpr {debugfrm tree expr} {

    global DataDisplay:hiddenExprList
    global Application:treeSeparator DataDisplay:seqNum
    global Debugger:stackinfo Debugger:stacklevel
    global Debugger:stacklength Debugger:xcontext
    global Debugger:f2w DataDisplay:userExprList
    global gdb:lastexpr
    
    set hlist [$tree subwidget hlist]
    set top [$hlist info children]

    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 gdb:lastexpr $expr

    # Search in the hidden variables
    if {[catch {set exprinfo \
	    [set DataDisplay:hiddenExprList($debugfrm,$top,$xcontext,$depth)]}] == 1} {
	set exprinfo {}
    }

    set nth 0

    foreach vinfo $exprinfo {
	set gdbvar [lindex $vinfo 3]
	if {$gdbvar == $expr} {
	    return [DataDisplay:displayVariable $debugfrm $tree $xcontext $depth $nth]
	}
	incr nth
    }

    # Not a hidden variable -- try among visible user-defined expr.
    # (Remember that user-defined expr. are not stored in the hiding list
    # when removed)
    set allEntries [getHListEntries $hlist $top]

    foreach entry $allEntries {
	set ndata [$hlist info data $entry]
	set ntype [lindex $ndata 0]
	if {$ntype == "user"} {
	    set gdbvar [lindex $ndata 3]
	    if {$gdbvar == $expr} {
		DataDisplay:openDataNode $debugfrm $tree $entry
		return $entry
	    }
	}
    }

    # Not a known variable -- display the expression as a user-defined
    # one inside the target tree. Note that user-defined expr. are
    # assumed to be locally-scoped; this way openDataNode will always
    # reinstate the local context before sending the request to GDB,
    # thus enforcing a local scope precedence over the global one when
    # evaluating such expression.

    set ndata [list user $expr local $expr {}]
    lappend DataDisplay:userExprList($debugfrm,$top,$xcontext,$depth) $ndata
    set entry $top${Application:treeSeparator}@[incr DataDisplay:seqNum]

    $tree subwidget hlist add $entry \
	-itemtype text \
	-style leafTextStyle \
	-data $ndata \
	-text $expr \
	-at 0

    $tree setmode $entry open
    DataDisplay:openDataNode $debugfrm $tree $entry
    update idletasks
    $tree subwidget hlist see $entry 

    return $entry
}

proc DataDisplay:displayExprLocal {debugfrm expr} {

    global Debugger:f2w
    set tree [set Debugger:f2w($debugfrm,locals)]
    Debugger:forceSwitchOn $debugfrm locals
    DataDisplay:displayExpr $debugfrm $tree $expr
}

proc DataDisplay:dereferenceExprLocal {debugfrm expr} {

    global Debugger:f2w
    set tree [set Debugger:f2w($debugfrm,locals)]
    Debugger:forceSwitchOn $debugfrm locals
    set entry [DataDisplay:displayExpr $debugfrm $tree $expr]
    DataDisplay:dereferenceData $debugfrm $tree $entry
}

proc DataDisplay:pickExpr {debugfrm tree slist xcontext depth} {

    global DataDisplay:hiddenExprList Application:treeSeparator

    set lbox [$slist subwidget listbox]
    set nth [$lbox curselection]

    if {$nth != {}} {
	$lbox delete $nth
	DataDisplay:displayVariable $debugfrm $tree $xcontext $depth $nth
    }
}

proc DataDisplay:readExpr {debugfrm tree w e} {

    set expr [$e get]

    if {$expr == {}} {
	# this makes double-Return react as
	# if a Validate+Close sequence has
	# just been entered.
	destroy $w
	return
    }

    $e delete 0 end

    DataDisplay:displayExpr $debugfrm $tree $expr
}

proc DataDisplay:showGlobals {context} {

    global DataDisplay:tracedEntryList

    set w $context.gbldisp
    set oldstate [wm state $w]
    wm deiconify $w

    if {$oldstate != "normal" &&
	[set DataDisplay:tracedEntryList($context,Globals,system,0)] != {}} {
	# window was dismissed - resynch display
	# get control over debugger
	if {[Debugger:resume $context] != "false"} {
	    DataDisplay:updateGlobalData $context
	    Debugger:suspend $context
	}
    }

    raise $w
}

proc DataDisplay:visibleGlobals {context} {
    set w $context.gbldisp
    set state [wm state $w]
    if {$state != "normal"} {
	return false
    }
    return true
}

proc DataDisplay:destroyGlobals {context} {
    global DataDisplay:tracedEntryList
    global DataDisplay:hiddenExprList
    global DataDisplay:userExprList
    # hiding means destroying in this case
    catch { DataDisplay:saveGlobals $context }
    catch { destroy $context.gbldisp }
    catch { unset DataDisplay:tracedEntryList($context,Globals,system,0) }
    catch { unset DataDisplay:hiddenExprList($context,Globals,system,0) }
    catch { unset DataDisplay:userExprList($context,Globals,system,0) }
}

proc DataDisplay:hideLocals {debugfrm tree} {
    global DataDisplay:tracedEntryList
    global DataDisplay:hiddenExprList
    global DataDisplay:userExprList

    set hlist [$tree subwidget hlist]
    set top [$hlist info children]
    $hlist delete offsprings $top

    foreach subscript \
	[array names DataDisplay:tracedEntryList $debugfrm,Locals,*,*] {
	set DataDisplay:tracedEntryList($subscript) {}
    }
    foreach subscript \
	[array names DataDisplay:hiddenExprList $debugfrm,Locals,*,*] {
	set DataDisplay:hiddenExprList($subscript) {}
    }
    foreach subscript \
	[array names DataDisplay:userExprList $debugfrm,Locals,*,*] {
	set DataDisplay:userExprList($subscript) {}
    }
}

proc DataDisplay:updateGlobalData {context} {

    # do not actually update the tree if the window is dismissed
    # or does not even exist (e.g. fatal error at startup)
    if {[winfo exists $context.gbldisp] == 1 &&
	[wm state $context.gbldisp] == "normal"} {
	global DataDisplay:tracedEntryList Project:settings
	set tree $context.gbldisp.f.tree
	if {[set Project:settings(Options,autoRaise)] == 1} {
	    raise $context.gbldisp
	}
	foreach entry [set DataDisplay:tracedEntryList($context,Globals,system,0)] {
	    DataDisplay:displayDataNode $context $tree $entry
	}
    }
}

proc DataDisplay:updateLocalData {debugfrm tree {autofocus true}} {

    global DataDisplay:tracedEntryList Debugger:stacklevel
    global Debugger:stackinfo Debugger:stacklength
    global Debugger:xcontext DataDisplay:hiddenExprList
    global DataDisplay:userExprList DataDisplay:localNatives
    global DataDisplay:seqNum Application:treeSeparator
    global Debugger:localinfo Debugger:f2c

    set hlist [$tree subwidget hlist]
    set context [set Debugger:f2c($debugfrm)]

    # determine the local context
    set level [set Debugger:stacklevel($debugfrm)]
    set xcontext [set Debugger:xcontext($debugfrm)]
    set depth [expr [set Debugger:stacklength($debugfrm)] - $level]
    # build the display list and pass the local information to GDB.
    set localinfo [set Debugger:localinfo($xcontext,$level)]
    set displayList [TkRequest $context BuildLocalInfo $localinfo]

    # fetch currently hidden expressions; because this list may not exist for
    # the current level, catch substitution error silently.
    set hiddenList {}
    catch {
	set hiddenList \
	    [set DataDisplay:hiddenExprList($debugfrm,Locals,$xcontext,$depth)]
    }

    # automatically promote currently defined user expressions
    # to the next auto-display list.
    set userList {}
    catch {
	set userList \
	    [set DataDisplay:userExprList($debugfrm,Locals,$xcontext,$depth)]
    }

    if {$userList != {}} {
	set displayList [concat $userList $displayList]
    }

    # destroy previous tree
    $hlist delete offsprings Locals
    set pollList {}
    set DataDisplay:localNatives($debugfrm,$xcontext,$depth) {}

    foreach expr $displayList {
	if {[lsearch $hiddenList $expr] != -1} {
	    # expr was explicitely undisplayed -- ignore it
	    continue
	}

	foreach {ntype ident scope gdbvar} $expr {
	    if {$ntype == "user"} {
		set entry Locals${Application:treeSeparator}@[incr DataDisplay:seqNum]
		lappend pollList $entry
	    } {
		set entry Locals${Application:treeSeparator}$ident