debugger.tcl

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

		set Debugger:searchinfo($debugfrm,searchindex) $eow
	    } {
		set Debugger:searchinfo($debugfrm,searchindex) $sow
	    }
	    if {$w != {}} {
		$w.status.msg config -text {}
	    }
	    return
	}
    }

    if {$w != {}} {
	$w.status.msg config -text "`$s' not found."
    }
    bell
}

proc Debugger:getThreadName {tid} {

    global Debugger:threadlist

    set ndx [lsearch -regexp ${Debugger:threadlist} "^$tid .*"]

    if {$ndx < 0} {
	set name $tid
    } {
	set name [lindex [lindex ${Debugger:threadlist} $ndx] 1]
    }

    return $name
}

proc Debugger:setThreadLock {debugfrm} {

    global Debugger:xcontext Debugger:threadlist Debugger:lockview

    set xcontext [set Debugger:xcontext($debugfrm)]
    set type [lindex $xcontext 0]
    set tid [lindex $xcontext 1]

    if {$type == "thread"} {
	# +1 to bypass (system) entry at the beginning of the combo
	set nth [expr [lsearch -regexp ${Debugger:threadlist} "^$tid .*"] + 1]
    } {
	# "0" stands for "system" focus
	set nth 0
    }

    $debugfrm.selectors.focus pick $nth
}

proc Debugger:getThreadTypeName {} {

    global Debugger:syspecs
    return [lindex ${Debugger:syspecs} 0]
}

proc Debugger:routeMainStatus {context name1 name2 op} {
    global Workspace:statusMsg $context:statusMsg
    set Workspace:statusMsg [set $context:statusMsg]
}

proc Debugger:saveGeometry {context} {
    set srch [$context.window panecget p1 -size]
    set loch [$context.window panecget p2 -size]
    Project:setResource DebuggerGeometry [list $srch $loch]
}

proc Debugger:restoreGeometry {context} {

    set geometry [Project:getResource DebuggerGeometry]
    if {$geometry != {}} {
	set srch [lindex $geometry 0]
	set loch [lindex $geometry 1]
	$context.window paneconfigure p1 -size $srch
	$context.window paneconfigure p2 -size $loch
    }
}

proc Debugger:saveSwitches {context} {

    global Debugger:f2w $context:switches

    set panew [set Debugger:f2w($context,data)] 
    set stackpsize [$panew panecget stack -size]
    set localpsize [$panew panecget locals -size]

    Project:setResource DebuggerSwitches \
	[list [set $context:switches] [list $stackpsize $localpsize]]
}

proc Debugger:restoreSwitches {context} {

    global Debugger:f2w

    set info [Project:getResource DebuggerSwitches]
    set switches [lindex $info 0]
    set geometries [lindex $info 1]

    foreach sw $switches {
	Debugger:forceSwitchOn $context $sw
    }

    set panew [set Debugger:f2w($context,data)] 
    $panew paneconfigure stack -size [lindex $geometries 0]
    $panew paneconfigure locals -size [lindex $geometries 1]
}

proc Debugger:saveScratchPad {context} {

    set pad $context.selectors.scratchpad
    # save the first 20 historized items from the main scratchpad --
    # note that we cannot use the "history limit" attribute from a combo.
    # It does prevent more than 20 items to be entered in the history,
    # but it does not behave in a FIFO manner with the oldest strings
    # but rather locks out the newest one!... :-(
    set history [$pad subwidget listbox]
    set strings [lrange [$history get 0 end] 0 19]
    Project:setResource DebuggerScratchPad $strings
}

proc Debugger:restoreScratchPad {context} {

    set pad $context.selectors.scratchpad
    set strings [Project:getResource DebuggerScratchPad]
    foreach e $strings {
	$pad appendhistory $e
    }
}

proc Debugger:lookupWord {debugfrm textw x y X Y} {

    global Debugger:hotSymbol $debugfrm:statusMsg

    set bow [$textw index "@$x,$y wordstart"]
    set eow [$textw index "@$x,$y wordend"]
    set hotword [string trim [$textw get $bow $eow]]

    ## YM
    ## Now, let's see... don't we have a "->" before us ??
    ##
    set temparrow [$textw get [$textw index "$bow -2 chars"] $bow]
    if {$temparrow == "->"} {
	## Yes we do !!
	## Now, let's find our class pointer...
	set index [$textw index "$bow -3 chars"]
	set bow [$textw index "$index wordstart"]
	set eow [$textw index "$index wordend"]
	set classptr [string trim [$textw get $bow $eow]]
	set hotword "$classptr->$hotword"
    }

    if {$hotword != {}} {
	if {$hotword == ${Debugger:hotSymbol}} {
	    return
	}
	global Debugger:childState

	if {${Debugger:childState} == "held" ||
	    ${Debugger:childState} == "zombie"} {
	    # Lookup functions can only perform when 
	    # the debuggee is under control.
	    set Debugger:hotSymbol $hotword
	    if {[gdb:lookup $hotword] != {}} {
		global Project:settings
		set $debugfrm:statusMsg "Control+Mouse<1> seeks `$hotword'..."
		$textw config -cursor hand2
		if {[set Project:settings(Options,evalBubbles)] == 1} {
		    # try to evaluate the symbol after a full second pointing at it
		    Debugger:resetEvalTimer $debugfrm 500 $X $Y
		}
		return
	    }
	}
    }

    Debugger:stopPointerNoise $debugfrm $textw
}

proc Debugger:stopPointerNoise {debugfrm textw} {

    global Debugger:hotSymbol $debugfrm:statusMsg

    if {${Debugger:hotSymbol} != {}} {
	$textw config -cursor xterm
	set Debugger:hotSymbol {}
	set $debugfrm:statusMsg {}
	Debugger:resetEvalTimer $debugfrm
    }
}

proc Debugger:lookupSymbol {debugfrm {symbol {}}} {

    global $debugfrm:statusMsg Debugger:f2w
    global Debugger:hotSymbol

    if {$symbol == {}} {
	set symbol ${Debugger:hotSymbol}
	if {$symbol == {}} {
	    return
	}
    }

    set location [DataDisplay:lookupExpr $debugfrm $symbol]
    set filepath [lindex $location 0]
    set lineno [lindex $location 1]
    set textw [set Debugger:f2w($debugfrm,source)]
    Debugger:stopPointerNoise $debugfrm $textw

    if {$filepath != {}} {
	Debugger:displaySource $debugfrm $filepath
	$textw tag remove sel 1.0 end
	catch {
	    $textw tag add sel $lineno.2 $lineno.end
	    $textw see $lineno.0
	}
    } {
	# set a strange cursor to tell about the failure
	# (the normal xterm cursor will be reinstated when
	# the mouse leaves the unreachable symbol area)
	$textw config -cursor spider
    }

    set $debugfrm:statusMsg {}
}

proc Debugger:resetEvalTimer {debugfrm {nextime 0} {X -1} {Y -1}} {

    global Debugger:symbolEvalTimer
	
    set etimer [set Debugger:symbolEvalTimer($debugfrm)]

    if {$etimer != {}} {
	# cancel the currently running timer
	after cancel $etimer
	set Debugger:symbolEvalTimer($debugfrm) {}
    } {
	# if no timer is running, an eval bubble may be visible --
	# destroy it.
	global Debugger:f2w
	set w [set Debugger:f2w($debugfrm,source)].evalbubble
	catch { destroy $w }
    }

    if {$nextime != 0} {
	set Debugger:symbolEvalTimer($debugfrm) \
	    [after $nextime "Debugger:evaluateHotSymbol $debugfrm $X $Y"]
    }
}

proc Debugger:evaluateHotSymbol {debugfrm X Y} {
    
    global Debugger:hotSymbol Debugger:f2w
    global Debugger:symbolEvalTimer

    # timer has elapsed -- forget its id.
    set Debugger:symbolEvalTimer($debugfrm) {}
    set w [set Debugger:f2w($debugfrm,source)].evalbubble

    if {${Debugger:hotSymbol} != {} &&
	![winfo exists $w]} {
	set symbol ${Debugger:hotSymbol}
	set value [DataDisplay:evalExpr $debugfrm $symbol "no_format"]
	if {$value == {}} {
	    # muhh? nothing valuable to display
	    return
	}
	# build the bubble frame to display the value
	toplevel $w
	wm overrideredirect $w 1
	incr X 5
	incr Y 15
	wm geometry $w +${X}+${Y}
	if {[string length $value] > 80} {
	    # truncate the value to a reasonable length
	    set value [string range $value 0 79]...
	}
	label $w.l -text "$symbol = $value" -border 1 -relief solid \
	    -bg \#ccffcc -padx 5
	pack $w.l
    }
}

proc Debugger:applyConfigUpdate {context} {

    global Debugger:childState
    global Debugger:configHasChanged
    global Debugger:c2f Project:settings

    set filter {}

    if {[set Project:settings(Options,traceKernel)] == 1} {
	append filter 0
    }
    if {[set Project:settings(Options,traceIface)] == 1} {
	append filter 1
    }
    if {[set Project:settings(Options,traceApp)] == 1} {
	append filter 2
    }

    TkRequest $context SetDebugFilter $filter

    if {${Debugger:childState} == "held" ||
	${Debugger:childState} == "zombie"} {
	# if debuggee is under control, perform the update now.
	if {[Debugger:resume $context] != "false"} {
	    gdb:setsrc [set Project:settings(SourceDirs)]
	    foreach debugfrm [set Debugger:c2f($context)] {
		# resync the frame displays with the new directory setting
		Debugger:updateFocus $debugfrm {} true
	    }
	    Debugger:resynchBreakpoints $context
	    Debugger:suspend $context
	}
    } {
	# Otherwise, raise the flag telling notifyBreak() to apply
	# the changes to GDB before attempting to update the focus.
	set Debugger:configHasChanged true
    }
}

proc Debugger:applyOptionUpdate {context} {

    global Debugger:childState Debugger:c2f

    if {${Debugger:childState} != "dead"} {
	foreach debugfrm [set Debugger:c2f($context)] {
	    # reload thread selector
	    Debugger:updateThreads $debugfrm
	}
    }
}

proc Debugger:processGlobalEvent {context name1 name2 op} {

    global Debugger:c2f
    global Debugger:f2w

    global Monitor:simulationState Debugger:childState

    while {[popEvent globalEventQueue:$context e] == "true"} {
	switch $e {
	    InitDebuggerEvent {
		# disable main debug frame toolbars
		$context.toolbar.tools configure -state disabled
		$context.toolbar.switches configure -state disabled
		$context.selectors.focus configure -state disabled
		$context.selectors.scratchpad configure -state disabled
	    }
	    
	    ConfigureWallpaperEvent {
		Debugger:removeWallPaper $context
		if {${Monitor:simulationState} == "dead"} {
		    Debugger:displayWallPaper $context
		}
	    }

	    DebuggerStartedEvent {
		global Debugger:ptimer Debugger:workspace Application:visualType
		set progressbar [set Debugger:workspace($context)].mtoolbar.progress
		tixMeter $progressbar -value 0 -text "Loading..." -width 110
		if {${Application:visualType} == "color"} {
		    $progressbar config -fillcolor white
		}
		Debugger:removeWallPaper $context
		pack $progressbar -side right -padx 6
		set Debugger:ptimer [after 250 "Debugger:progress $context"]
		# ensure the source/data panedwin is last in the packing
		# order to have it laid on the remaining cavity space
		# after all other frames.
		pack forget $context.window
		pack $context.toolbar -side top -expand no -fill x
		pack $context.selectors -after $context.toolbar -expand no -fill x
		pack $context.messages -after $context.selectors -expand no -fill x
		pack $context.window -expand yes -fill both
		# freeze the source actions until the debugger is up
		foreach slave [pack slaves $context.toolbar.srcmd] {
		    $slave config -state disabled
		}
	    }

	    DebuggerAbortEvent -
	    DebuggerStoppedEvent {

		# cancel startup timer (if any)
		global Debugger:workspace
		set progressbar [set Debugger:workspace($context)].mtoolbar.progress
		if {[winfo exists $progressbar] == 1} {
		    global Debugger:ptimer
		    after cancel ${Debugger:ptimer}
		    destroy $progressbar
		}

		if {$e == "DebuggerStoppedEvent"} {
		    Debugger:saveBreakpoints $context
		    Debugger:saveWatchpoints $context
		    Debugger:saveGeometry $context
		    Debugger:saveSwitches $context
		    Debugger:saveScratchPad $context

		    # destroy all secondary debug frames
		    foreach debugfrm [set Debugger:c2f($context)] {
			if {$debugfrm != $context} {
			    Debugger:destroySecondaryFrame $debugfrm
			}
		    }

		    # cancel eval timer for main frame
		    Debugger:resetEvalTimer $context

		    # delete main source window contents
		    set textw [set Debugger:f2w($context,source)]
		    $textw tag delete hotspot
		    $textw configure -state normal
		    $textw delete 1.0 end
		    $textw configure -state disabled
		    # redraw wallpaper
		    Debugger:displayWallPaper $context
		
		    # hide stack display for main debug frame (if open)
		    global $context:switches
		    set dataw [set Debugger:f2w($context,data)]
		    foreach disp [set $context:switches] {
			if {$disp != "asynch"} {
			    $dataw forget $disp
			}
		    }
		    if {[lsearch -exact [set $context:switches] locals] != -1} {
			DataDisplay:hideLocals $context [set Debugger:f2w($context,locals)]
		    }
		    set $context:switches {}
		} {
		    $context.messages.location configure -text (Aborted)
		    bell
		    global Project:settings
		    tk_messageBox -parent $context \
			-message "Failed to load/start [set Project:settings(GdbPath)]." \
			-type ok -icon error -title Error
		    Debugger:displayWallPaper $context
		}
	    
		# disable main debug frame toolbars
		$context.toolbar.tools configure -state disabled
		$context.toolbar.switches configure -state disabled
		global $context:focus $context:scratchpad
		global $context:tickval
		# reset thread list - keep the first entry unaltered
		# (i.e. "(system)")
		set $context:focus {}
		set $context:tickval {}
		Debugger:clearFocus $context
		$context.selectors.focus configure -state disabled
		set $context:scratchpad {}
		$context.selectors.scratchpad subwidget entry delete 0 end
		$context.selectors.scratchpad subwidget listbox delete 0 end
		$context.selectors.scratchpad configure -state disabled
		pack forget $c