breakpoints.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.

set Debugger:bpToolTips {}

proc Debugger:computeBPFocus {bpid w X Y} {

    global Debugger:bplist

    set bpinfo [lindex ${Debugger:bplist} $bpid]
    set focuscmd [lindex $bpinfo 0]
    set state [lindex $bpinfo 1]
    set condition [lindex $bpinfo 5]
    set tip [Debugger:getBreakpointFocus $focuscmd]

    if {$condition != {}} {
	append tip ", if $condition"
    }

    if {$state == "disabled"} {
	append tip " (disabled)"
    }

    return $tip
}

proc Debugger:getBreakpointFocus {focuscmd} {

    switch [lindex $focuscmd 0] {
	SYSTEM_SCOPE {
	    set focusinfo system
	}
	THREAD_SCOPE {
	    set tid [lindex $focuscmd 1]
	    set tsktype [string tolower [Debugger:getThreadTypeName]]
	    set focusinfo "$tsktype [Debugger:getThreadName $tid]"
	}
	HARD_SCOPE {
	    set focusinfo hard
	}
	default {
	    set focusinfo {}
	}
    }

    return $focusinfo
}

proc Debugger:selectBreakAtLine {debugfrm menu file lineno} {

    global Debugger:bplist Debugger:focus

    # a breakpoint is: { focus state bpnum file lineno condition }

    if {[winfo exists $menu.cond]} {
	destroy $menu.cond
    }

    set bpfound {}

    foreach bpinfo ${Debugger:bplist} {
	set bpfile [lindex $bpinfo 3]
	set bpline [lindex $bpinfo 4]
	if {$file == $bpfile && $bpline == $lineno} {
	    set bpfound $bpinfo
	    break
	}
    }

    set scope [lindex [set Debugger:focus($debugfrm)] 0]

    switch $scope {
	system {
	    $menu add command -label "Break here" \
		-command "Debugger:setBreakAtLine $debugfrm $lineno {SYSTEM_SCOPE 0}"
	}

	default {
	    # some thread context...
	    $menu add cascade -label "Break here" -menu $menu.cond
	    menu $menu.cond -tearoff 0
	    set tsktype [Debugger:getThreadTypeName]
	    $menu.cond add command -label "unconditionally" \
		-command "Debugger:setBreakAtLine $debugfrm $lineno {SYSTEM_SCOPE 0}"
	    $menu.cond add command -label "if $tsktype \"[Debugger:getThreadName $scope]\" runs" \
		-command "Debugger:setBreakAtLine $debugfrm $lineno \"[list THREAD_SCOPE $scope]\""
	}
    }

    $menu add command -label "Disable breakpoint"
    set disndx [$menu index end]
    $menu add command -label "Enable breakpoint"
    set enbndx [$menu index end]
    $menu add command -label "Remove breakpoint"
    set remndx [$menu index end]

    if {$bpfound == {}} {
	# may not disable/remove a previously set (active) bp
	$menu entryconfigure $disndx -state disabled
	$menu entryconfigure $enbndx -state disabled
	$menu entryconfigure $remndx -state disabled
    } {
	if {[lindex $bpfound 1] == "disabled"} { 
	    # BP is currently disabled: one may enable it
	    # or remove it definitively...
	    $menu entryconfigure $disndx -state disabled
	    $menu entryconfigure $enbndx \
		-command "Debugger:toggleBreakAtLine $debugfrm \"$bpfound\" enabled"
	} {
	    # BP is currently enabled: one may disable it
	    # or remove it definitively...
	    $menu entryconfigure $enbndx -state disabled
	    $menu entryconfigure $disndx \
		-command "Debugger:toggleBreakAtLine $debugfrm \"$bpfound\" disabled"
	}
	$menu entryconfigure $remndx \
	    -command "Debugger:removeBreakAtLine $debugfrm \"$bpfound\""
    }

    $menu add separator
    $menu add command -label "Run until..." \
	-command "Debugger:runUntil $debugfrm $file $lineno"
}

proc Debugger:runUntil {debugfrm file lineno} {

    global Debugger:f2c Debugger:focus
    global $debugfrm:statusMsg
    
    # A "run until" command is a step out command combined
    # with a temporary breakpoint on the designated line.
    # This implies locking the focus on the current thread.

    # give some feed back, the operation could be slow...
    set $debugfrm:statusMsg "Running until [file tail $file]:$lineno..."

    set scope [lindex [set Debugger:focus($debugfrm)] 0]
    if {$scope == "system"} {
	Debugger:setThreadLock $debugfrm
	# reread the scope which may have changed
	set scope [lindex [set Debugger:focus($debugfrm)] 0]
    }

    # set the temporary breakpoint -- remember that a thread lock is
    # pending, thus the focus must be "system" (an ISR or a callout
    # was active), or any valid real-time thread.
    if {$scope == "system"} {
	set schedbp [list SYSTEM_SCOPE 0]
    } {
	set schedbp [list THREAD_SCOPE $scope]
    }
    Debugger:setBreakAtLine $debugfrm $lineno $schedbp oneshot

    # then perform the step out...
    set context [set Debugger:f2c($debugfrm)]
    set focuscmd [Debugger:buildStepCmd $debugfrm]
    TkRequest $context StepOut $focuscmd
}

proc Debugger:setBreakAtLine {debugfrm lineno focuscmd {state enabled}} {

    global Debugger:bplist
    global Debugger:f2w Debugger:f2c Debugger:f2s

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

    # get "hard" control over debuggee
    if {[Debugger:resume $context] == "false"} {
	return
    }

    set file [set Debugger:f2s($debugfrm)]
    set emsg {}
    set bpnum [gdb:setsoftbp $context $focuscmd $file $lineno]
    Debugger:suspend $context

    if {$bpnum == {}} {
	global gdb:lasterror
	$debugfrm.messages.warning configure \
	    -text [set gdb:lasterror]
	bell -displayof $debugfrm
	return
    }

    set bpinfo [list $focuscmd $state $bpnum $file $lineno {}]

    if {$state == "oneshot"} {
	global Debugger:bpOneshot
	set Debugger:bpOneshot $bpinfo
    }
    lappend Debugger:bplist $bpinfo

    Debugger:plotBreakpoints $context
}

proc Debugger:removeBreakAtLine {debugfrm bpinfo} {

    global Debugger:bplist Debugger:f2c

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

    # get "hard" control over debuggee
    if {[Debugger:resume $context] == "false"} {
	return
    }

    set bpnum [lindex $bpinfo 2]
    gdb:removebp $bpnum

    Debugger:suspend $context

    # remove BP from the bplist
    set rmid [lsearch -exact ${Debugger:bplist} $bpinfo]
    set Debugger:bplist [lreplace ${Debugger:bplist} $rmid $rmid]

    # remove BP tag from the source windows
    Debugger:unplotBreakpoint $context $bpinfo
}

proc Debugger:toggleBreakAtLine {debugfrm bpinfo {status {}}} {

    global Debugger:bplist Debugger:f2c

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

    if {$status == {}} {
	# default action -- complement the current bp state
	if {[lindex $bpinfo 1] == "enabled"} {
	    set status disabled
	} {
	    set status enabled
	}
    }

    # get "hard" control over debuggee
    if {[Debugger:resume $context] == "false"} {
	return
    }

    set bpnum [lindex $bpinfo 2]

    if {$status == "enabled"} {
	gdb:enablebp $bpnum
    } {
	if {[gdb:disablebp $bpnum] == "false"} {
	    # Failed to disable -- don't change status
	    set status enabled
	}
    }

    Debugger:suspend $context

    # find BP to update in the bplist
    set id [lsearch -exact ${Debugger:bplist} $bpinfo]

    # update enabled/disabled status
    set bpinfo [lreplace $bpinfo 1 1 $status]
    set Debugger:bplist [lreplace ${Debugger:bplist} $id $id $bpinfo]

    # update BP tag in the source windows
    Debugger:plotBreakpoints $context
}

proc Debugger:plotBreakpoints {context {debugfrm {}}} {

    global Debugger:bplist Debugger:c2f Debugger:f2s
    global Debugger:f2w

    if {$debugfrm != {}} {
	set framelist $debugfrm
    } {
	set framelist [set Debugger:c2f($context)]
    }

    set bpid 0

    foreach bpinfo ${Debugger:bplist} {
	foreach {focus state bpnum bpfile lineno cond supp} $bpinfo {
	    foreach debugfrm $framelist {
		set filepath [set Debugger:f2s($debugfrm)]
		if {$bpfile != $filepath} {
		    continue
		}
		set textw [set Debugger:f2w($debugfrm,source)]
		$textw configure -state normal
		$textw delete $lineno.0
		set bpwin $textw.$bpnum
		switch -- $state {
		    enabled {
			set image [fetchImage stopenb]
		    }
		    disabled {
			set image [fetchImage stopdis]
		    }
		    oneshot {
			set image [fetchImage stoptmp]
		    }
		}
		# we could have used an embedded image here...
		label $bpwin -bd 0 -relief flat -padx 0 -pady 0 \
		    -image $image -background [$textw cget -background]
		setDynamicTooltip $bpwin "Debugger:computeBPFocus $bpid" 0
		$textw window create $lineno.0 -window $bpwin
		$textw configure -state disabled
	    }
	}
	incr bpid
    }
}

proc Debugger:unplotBreakpoint {context bpinfo} {

    global Debugger:c2f Debugger:f2s Debugger:f2w

    set framelist [set Debugger:c2f($context)]
    set bpnum [lindex $bpinfo 2]
    set bpfile [lindex $bpinfo 3]

    foreach debugfrm $framelist {
	set filepath [set Debugger:f2s($debugfrm)]
	if {$bpfile == $filepath} {
	    set textw [set Debugger:f2w($debugfrm,source)]
	    catch { destroy $textw.$bpnum }
	}
    }
}

proc Debugger:editBreakpoints {debugfrm} {

    global Debugger:bplist Debugger:f2c
    global Debugger:bpToolTips Debugger:bpLocation

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

    set w $context.editbp
    toplevel $w
    wm title $w "Debug Breakpoints"
    bind $w <Escape> "destroy $w"
    cascadeWindow $w

    set toolbar [frame $w.toolbar -bd 1 -relief groove]
    pack $toolbar -side top -fill x

    set toggles $toolbar.toggles
    tixSelect $toggles -allowzero true -radio true
    pack $toggles -expand no -anchor w -padx 4 -pady 4 -side left

    set inputfield $toolbar.inputfield
    set Debugger:bpLocation {}
    tixComboBox $inputfield -dropdown true -label "Stop at: " \
	-editable true \
	-grab local \
	-history true \
	-prunehistory true \
	-variable Debugger:bpLocation \
	-options {
	    listbox.height 6
	    listbox.width 6
	    label.anchor e
	}

    set e [$inputfield subwidget entry]
    $e configure -width 28
    focus $e
    pack $inputfield -pady 4 -padx 4 -side right

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

    $toggles add addbp -image [fetchImage stopadd]
    Workspace:addToolTip $toggles addbp Debugger:bpToolTips \
	"Add breakpoint" "Create a new breakpoint in program"
    $toggles add rembp -image [fetchImage stoprem]
    Workspace:addToolTip $toggles rembp Debugger:bpToolTips \
	"Remove breakpoint(s)" "Remove selected/all breakpoint(s) from program"
    $toggles add togglebp -image [fetchImage stoptoggle]
    Workspace:addToolTip $toggles togglebp Debugger:bpToolTips \
	"Toggle breakpoint(s)" "Enable/Disable selected/all breakpoint(s)"

    tixScrolledHList $lbf.list -options {
	hlist.columns 4
	hlist.header true
	hlist.selectmode single
	hlist.drawbranch 0
	hlist.indent 5
	hlist.height 10
	hlist.width 85
    }