debugger.tcl

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

    set mbar [frame $w.mbar -bd 1 -relief raised]
    pack $mbar -fill x

    menubutton $mbar.file -text File \
	-menu $mbar.file.m \
	-underline 0 \
	-takefocus 0
    menu $mbar.file.m -tearoff false

    $mbar.file.m add command -label Close \
	-command "destroy $w" \
	-underline 0

    pack $mbar.file -side left

    set debugfrm $w.f
    Debugger:createDebugFrame \
	$context $debugfrm [set Debugger:workspace($context)]
    pack $debugfrm.toolbar -side top -expand no -fill x
    pack $debugfrm.selectors -expand no -fill x
    pack $debugfrm.messages -expand no -fill x
    pack $debugfrm.window -expand yes -fill both
    # create local status bar
    global $debugfrm:statusMsg
    frame $debugfrm.status -height 20 -relief groove -bd 1
    pack $debugfrm.status -fill x
    label $debugfrm.status.message -textvariable $debugfrm:statusMsg
    pack $debugfrm.status.message -side left
    # pack it all
    pack $debugfrm -expand yes -fill both

    tkwait visibility $w

    incr Debugger:fserial
    if {[Debugger:resume $context] != "false"} {
	Debugger:updateFocus $debugfrm {}
	Debugger:suspend $context
	Debugger:updateThreads $debugfrm
	$debugfrm.selectors.focus pick 0
    }
}

proc Debugger:destroySecondaryFrame {debugfrm} {

    regexp "^(.*)\\.f$" $debugfrm mvar root
    destroy $root
}

proc Debugger:toolbarExec {toolbar debugfrm button state} {

    # a little trick to have the tix select widget
    # behave like a toolbar: a selected button is
    # immediately re-invoked to restore its initial
    # graphic state. This is why the button state is
    # checked to filter out "off" invocations.

    if {$state == 1} {

	$toolbar invoke $button
	if {[$toolbar subwidget $button cget -state] == "disabled"} {
	    # this can occur if triggered thru a function key
	    # whose bindings are never disabled. So we need to
	    # test the corresponding button's state to confirm
	    # the operation.
	    return
	}

	global Debugger:f2c Debugger:operating
	global Debugger:stacklevel Debugger:stackinfo
	global Debugger:stacklength $debugfrm:statusMsg

	set Debugger:operating $debugfrm
	set $debugfrm:statusMsg {}

	# clear last warning (if any)
	$debugfrm.messages.warning configure -text {}
	set context [set Debugger:f2c($debugfrm)]

	switch $button {
	    up {
		set level [set Debugger:stacklevel($debugfrm)]

		if {[expr $level + 1] >= [set Debugger:stacklength($debugfrm)]} {
		    # already at outer level
		    $debugfrm.messages.warning configure \
			-text "Outer frame reached - cannot go up"
		    bell -displayof $debugfrm
		    return
		}
		incr Debugger:stacklevel($debugfrm)
		Debugger:displayStackFrame $debugfrm
	    }

	    down {
		set level [set Debugger:stacklevel($debugfrm)]

		if {$level <= 0} {
		    # already at inner level
		    $debugfrm.messages.warning configure \
			-text "Inner frame reached - cannot go down"
		    bell -displayof $debugfrm
		    return
		}
		incr Debugger:stacklevel($debugfrm) -1
		Debugger:displayStackFrame $debugfrm
	    }

	    stepover {
		# fetch command appropriate to initiate a step over
		# the instruction pointed by the current debugging
		# focus for this debug frame...
		set focuscmd [Debugger:buildStepCmd $debugfrm]
		TkRequest $context StepOver $focuscmd
	    }

	    stepinto {
		# fetch command appropriate to initiate a step into
		# the instruction pointed by the current debugging
		# focus for this debug frame...
		set focuscmd [Debugger:buildStepCmd $debugfrm]
		TkRequest $context StepInto $focuscmd
	    }
	    
	    stepout {
		# fetch command appropriate to initiate a step out
		# the last traced context...
		set focuscmd [Debugger:buildStepCmd $debugfrm]
		TkRequest $context StepOut $focuscmd
	    }
	    
	    cont {
		TkRequest $context ContSimulation
	    }

	    xbreak {
		TkRequest $context HoldSimulation
	    }

	    breakpoints {
		Debugger:editBreakpoints $debugfrm
	    }

	    watchpoints {
		Debugger:editWatchpoints $debugfrm
	    }

	    globals {
		DataDisplay:showGlobals $context
	    }

	    examine {
		Examiner:popup $context
	    }

	    thrlock {
		Debugger:setThreadLock $debugfrm
	    }

	    newframe {
		Debugger:createSecondaryFrame $context
	    }

	    resynch {
		Debugger:sourceSynch $debugfrm
	    }

	    reload {
		Debugger:sourceReload $debugfrm
	    }

	    default {
		gdb:$button $context
	    }
	}
    }
}

proc Debugger:toolbarSwitch {debugfrm button state} {

    global $debugfrm:statusMsg

    set $debugfrm:statusMsg {}

    if {$state == 1} {
	# Toggle on
	if {[$debugfrm.toolbar.switches \
		 subwidget $button cget -state] == "disabled"} {
	    # this can occur if triggered thru a function key
	    # which bindings are never disabled. So we need to
	    # test the corresponding button's state to confirm
	    # the operation.
	    return
	}
	switch -- $button {
	    stack {
		Debugger:showStack $debugfrm
	    }
	    locals {
		Debugger:showLocals $debugfrm
	    }
	}
    } {
	# Toggle off
	switch -- $button {
	    stack {
		Debugger:hideStack $debugfrm
	    }
	    locals {
		Debugger:hideLocals $debugfrm
	    }
	}
    }
}

proc Debugger:closeDebugFrame {wdestroyed w} {

    if {$wdestroyed == $w} {

	global Debugger:f2c Debugger:c2f Debugger:f2w
	global Debugger:f2s Debugger:pcfile Debugger:pcline
	global Debugger:focus Debugger:xcontext
	global Debugger:stackinfo Debugger:stacklevel
	global Debugger:stacklength Debugger:searchinfo
	global $w:tools $w:focus $w:scratchpad $w:switches
	global $w:statusMsg Debugger:workspace Debugger:operating

	# cancel the currently running eval timer (if any)
	Debugger:resetEvalTimer $w

	# Remove destroyed window from context's window list
	set context [set Debugger:f2c($w)]
	set n [lsearch -exact [set Debugger:c2f($context)] $w]
	set Debugger:c2f($context) \
	    [lreplace [set Debugger:c2f($context)] $n $n]

	if {${Debugger:operating} == $w} {
	    set Debugger:operating $context
	}

	# destroy current source pick window (if any) as it could
	# be attached to the destroyed frame
	catch { destroy $context.srcpick }

	# clear per-frame variables
	catch { unset Debugger:f2w($w,source) }
	catch { unset Debugger:f2w($w,data) }
	catch { unset Debugger:f2w($w,stack) }
	catch { unset Debugger:f2s($w) }
	catch { unset Debugger:pcfile($w) }
	catch { unset Debugger:pcline($w) }
	catch { unset Debugger:focus($w) }
	catch { unset Debugger:xcontext($w) }
	catch { unset Debugger:stackinfo($w) }
	catch { unset Debugger:stacklength($w) }
	catch { unset Debugger:stacklevel($w) }
	catch { unset Debugger:workspace($w) }
	catch { unset Debugger:searchinfo($w,searchwhence) }
	catch { unset Debugger:searchinfo($w,searchindex) }
	catch { unset $w:tools }
	catch { unset $w:focus }
	catch { unset $w:scratchpad }
	catch { unset $w:switches }
	catch { unset $w:statusMsg }
    }
}

proc Debugger:run {context flags} {

    global Debugger:state
    global Debugger:threadlist Debugger:pipeout
    global Debugger:configHasChanged Monitor:main
    global Debugger:childState Project:settings

    Monitor:tcpListen ${Monitor:main} [set Project:settings(ServerPort)]

    set args [Monitor:getMvmArgs $flags]

    unset Debugger:threadlist
    set Debugger:threadlist {}
    set Debugger:configHasChanged false
    
    pushEvent Application:event DebuggerStartedEvent
    $context.messages.location configure -text (Loading)

    if {[catch {set gdbPath [file nativename [set Project:settings(GdbPath)]]}] == 1} {
	# may be an invalid ~user syntax
	set gdbPath [set Project:settings(GdbPath)]
    }

    global Debugger:zombieCause
    set Debugger:zombieCause {}
    set Debugger:childState released
    set executable [set Project:settings(Executable)]
    set srcdirs [set Project:settings(SourceDirs)]

    if {[gdb:init $context $gdbPath $executable $args $srcdirs ${Debugger:pipeout}] != {}} {
	set Debugger:state alive
	Debugger:restoreGeometry $context
    } {
	set Debugger:childState dead
	pushEvent Application:event DebuggerAbortEvent
	return
    }

    gdb:run $context $args
    Debugger:listen $context Busy

    if {${Debugger:state} == "alive"} {
	Debugger:restoreSwitches $context
	Debugger:restoreScratchPad $context
    }
}

proc Debugger:stop {context} {

    global Debugger:state

    # ask driver to close the debug connection
    gdb:stop $context
    set Debugger:state dead
    # trigger appropriate event at a global level
    pushEvent Application:event DebuggerStoppedEvent
}

proc Debugger:exit {context {errmsg {}}} {

    global Debugger:state

    set Debugger:state dead
    update idletasks
    bell

    if {$errmsg != {}} {
	tk_messageBox \
	    -message "[string toupper gdb]: $errmsg" \
	    -type ok -icon error -title Error
    } {
	tk_messageBox \
	    -message "Application exited normally" \
	    -type ok -icon info -title Information
    }

    pushEvent Application:event DebuggerStoppedEvent
}

proc Debugger:visitFile {debugfrm filename} {

    if  {$filename != {}} {
	# if file is already known -- display it
	# then return...
	displaySource $debugfrm $filename
	return
    }

    # otherwise, open a file dialog to get its name...

    set dialog [tix filedialog tixExFileSelectDialog]
    $dialog config -command "Debugger:displaySource $debugfrm" \
	-title "Select a File"

    $dialog subwidget fsbox config -filetypes { \
	{{*.c}	{*.c  -- C source files}}
	{{*.h}	{*.h  -- C/C++ header files}}
	{{*.cc}	{*.cc  -- C++ source files}}
	{{*.C}	{*.C  -- C++ source files}}
	{{*.cpp}	{*.cpp  -- C++ source files}}
	{{*}		{*      -- All files}}
    }

    $dialog subwidget fsbox subwidget types pick 0
    cascadeWindow $dialog [winfo toplevel $debugfrm]
    $dialog popup
}

proc Debugger:buildSourceStack {debugfrm menu} {

    global Debugger:fcache Debugger:f2c
    global Debugger:fpos Debugger:pcfile
    global Debugger:f2s

    $menu delete 0 end

    if {${Debugger:fcache} == {}} {
	return
    }

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

    foreach file ${Debugger:fcache} {
	if {$file == [set Debugger:pcfile($debugfrm)]} {
	    set mark " * "
	} {
	    if {$file == [set Debugger:f2s($debugfrm)]} {
		set mark " + "
	    } {
		set mark "   "
	    }
	}
	$menu add command -label $mark[TkRequest $context GetUserPath $file] \
	    -command "Debugger:pickSource $debugfrm $file"
    }

    if {[expr [array size Debugger:fpos] - 1] > [llength ${Debugger:fcache}]} {
	# -1 because we need to substract the dummy entry '-'
	$menu add separator
	$menu add command -label "More..." \
	    -command "Debugger:pickSource $debugfrm {}"
    }
}

proc Debugger:pickSource {debugfrm filepath} {

    global Debugger:fpos Debugger:f2c Debugger:pcfile Debugger:f2s

    if {$filepath != {}} {
	Debugger:displaySource $debugfrm $filepath
	return
    }

    # if no file has been given, open a selection toplevel
    # to have the user pick the file among all known sources

    set flist [lsort -dictionary [array names Debugger:fpos]]

    set context [set Debugger:f2c($debugfrm)]
    set w $context.srcpick

    if {[winfo exists $w]} {
	destroy $w
    } 

    toplevel $w
    wm title $w "Source Files"
    cascadeWindow $w

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

    tixScrolledListBox $f.list -scrollbar auto \
	-browsecmd "Debugger:pickSourceSel $debugfrm $f.list"
    set lbox [$f.list subwidget listbox]
    $lbox config -height 20 -width 60 -selectmode single
    pack $f.list -expand yes -fill both
    bind $w <Escape> "destroy $w"

    foreach filepath $flist {
	if {$filepath != "-"} {
	    if {$filepath == [set Debugger:pcfile($debugfrm)]} {
		set mark " * "
	    } {
		if {$filepath == [set Debugger:f2s($debugfrm)]} {
		    set mark " + "
		} {
		    set mark "   "
		}
	    }
	    $lbox insert end $mark$filepath
	}
    }