debugger.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): ym
#
#  Adapted to XENOMAI by Philippe Gerum.

#  global tcl_traceExec
#  set tcl_traceExec 1
# GDB state among "dead" or "alive"
set Debugger:state dead
# Debug frame to parent context array: f2c($debugfrm)
set Debugger:f2c(0) {}
# Context to debug frames array: c2f($context)
set Debugger:c2f(0) {}
# Debug frame to its subwindows: f2w($debugfrm,wintype)
set Debugger:f2w(0,0) ""
# Current source file displayed in debug frame: f2s($debugfrm)
set Debugger:f2s(0) ""
# Source file of last updated PC: pcfile($debugfrm)
set Debugger:pcfile(0) {}
# Line number within pcfile of last updated PC: pcline($debugfrm)
set Debugger:pcline(0) {}
# View position within visited source files (never cleared): fpos($path)
set Debugger:fpos(-) {}
# File access cache, last 8 pathes kept
set Debugger:fcache {}
# Current focus tracked by debug frame: focus($debugfrm) may contain
# "system" or a numeric value standing for and internal thread
# identifier (i.e. oid)
set Debugger:focus(0) 0
# Last executing context, which can be different from the
# focus() value if a specific thread focus in currently in effect.
# This context is of the form { type numid1 numid2 }
# as returned by the VRTOS monitor answering a GetContext
# request.
set Debugger:xcontext(0) {}
# current stack information obtained on a debug context
# since the last breakpoint hit 
set Debugger:stackinfo(0) {}
# length of current call chain information (i.e. stackinfo)
set Debugger:stacklength(0) {}
# local data information obtained on a debug context
set Debugger:localinfo(0,0) {}
# current frame number since last focus update (including up/down)
set Debugger:stacklevel(0) {}
# current state of debuggee among "dead", "held", "released" or "zombie"
set Debugger:childState dead
# the event which made the debuggee enter the zombie state
set Debugger:zombieCause {}
# serial id for secondary debug frames - starts at 2
set Debugger:fserial 2
# Known threads list {threadID threadName threadEntry}
set Debugger:threadlist {}
# Host workspace context of debugger context
set Debugger:workspace(0) {}
# Flag telling whether the configuration has changed.
set Debugger:configHasChanged false
# Last search-string information from debug frame
set Debugger:searchinfo(0,0) {}
# Misc. information about the simulated system
# syspecs currenty is: {threadTypeName}
set Debugger:syspecs {}
# Operating debug frame (i.e. the last for which were invoked
# trace commands)
set Debugger:operating {}
# Thread lock flag set for frame
set Debugger:lockview(0) 0
# Last hot symbol marked
set Debugger:hotSymbol {}
# The array of per-frame hot symbol evaluation timers
set Debugger:symbolEvalTimer(0) {}
# List of breakpoints; each element is a sublist describing
# a breakpoint: { focus state bpnum file lineno condition [systeminfo] }
set Debugger:bplist {}
# identifier of pending oneshot bp
set Debugger:bpOneshot {}

proc Debugger:initialize {context workspace pipeout} {

    global Workspace:statusBar Debugger:operating
    global Debugger:main Debugger:pipeout

    # create main debug window in workspace
    set Debugger:operating $context
    set Debugger:main $context
    set Debugger:pipeout $pipeout
    Debugger:createDebugFrame $context $context $workspace
    pack $context.window -side bottom -expand yes -fill both
    pack $context -before ${Workspace:statusBar} -expand yes -fill both
    global $context:statusMsg
    trace variable $context:statusMsg w "Debugger:routeMainStatus $context"

    # register trace hook to get informed of major context changes
    traceEvent Application:event \
	globalEventQueue:$context \
	"Debugger:processGlobalEvent $context"

    # trigger initialization event
    pushEvent Application:event InitDebuggerEvent
}

proc Debugger:createDebugFrame {context debugfrm workspace} {

    global Debugger:f2c Debugger:c2f Debugger:f2s Debugger:f2w
    global Debugger:pcline Debugger:pcfile
    global Debugger:xcontext Debugger:focus
    global Debugger:stackinfo Debugger:stacklength
    global Debugger:localinfo Debugger:stacklevel
    global Debugger:workspace Debugger:lockview
    global Debugger:symbolEvalTimer
    global tixOption

    # save host workspace handle for this frame
    set Debugger:workspace($debugfrm) $workspace
    
    set Debugger:f2c($debugfrm) $context
    lappend Debugger:c2f($context) $debugfrm
    set Debugger:f2s($debugfrm) {}
    set Debugger:pcfile($debugfrm) {}
    set Debugger:pcline($debugfrm) 0
    set Debugger:focus($debugfrm) system
    set Debugger:xcontext($debugfrm) {init 0 0 0}
    set Debugger:stackinfo($debugfrm) {}
    set Debugger:stacklength($debugfrm) {}
    set Debugger:stacklevel($debugfrm) 0
    set Debugger:symbolEvalTimer($debugfrm) {}
    set Debugger:lockview($debugfrm) 0

    frame $debugfrm
    bind $debugfrm <Destroy> "Debugger:closeDebugFrame %W $debugfrm"

    ### Toolbar frame

    frame $debugfrm.toolbar -width 600 -bd 1 -relief groove

    ## Tools shortcuts

    global $debugfrm:tools
    set $debugfrm:tools {}

    set tools $debugfrm.toolbar.tools

    tixSelect $tools -allowzero true -radio true \
	-variable $debugfrm:tools \
	-command "Debugger:toolbarExec $tools $debugfrm" \
	-options {
	    label.anchor e
	}

    $tools add stepover -image [fetchImage stepover]
    Workspace:addToolTip $tools stepover $debugfrm:statusMsg \
	"Step over" "Step over next statement (F10)" <Key-F10>

    $tools add stepinto -image [fetchImage stepinto]
    Workspace:addToolTip $tools stepinto $debugfrm:statusMsg \
	"Step into" "Step into next statement (F11)" <Key-F11>

    $tools add stepout -image [fetchImage stepout]
    Workspace:addToolTip $tools stepout $debugfrm:statusMsg \
	"Step out" "Step out current function (F12)" <Key-F12>

    $tools add cont -image [fetchImage cont]
    Workspace:addToolTip $tools cont $debugfrm:statusMsg \
	"Continue" "Resume execution (F5)" <Key-F5>

    $tools add xbreak -image [fetchImage break]
    Workspace:addToolTip $tools xbreak $debugfrm:statusMsg \
	"Stop" "Suspend execution (F6)" <Key-F6>

    $tools add up -image [fetchImage up]
    Workspace:addToolTip $tools up $debugfrm:statusMsg \
	"Up stack" "Move stack pointer upward (to outer frames)"

    $tools add down -image [fetchImage down]
    Workspace:addToolTip $tools down $debugfrm:statusMsg \
	"Down stack" "Move stack pointer downward (to inner frames)"

    $tools add breakpoints -image [fetchImage stoplst]
    Workspace:addToolTip $tools breakpoints $debugfrm:statusMsg \
	"Breakpoints" "Edit breakpoints"

    $tools add watchpoints -image [fetchImage watchlst]
    Workspace:addToolTip $tools watchpoints $debugfrm:statusMsg \
	"Watchpoints" "Edit watchpoints"

    $tools add globals -image [fetchImage globals]
    Workspace:addToolTip $tools globals $debugfrm:statusMsg \
	"Globals" "Display global symbols"

    $tools add examine -image [fetchImage examine]
    Workspace:addToolTip $tools examine $debugfrm:statusMsg \
	"Examine" "Examine memory and evaluate expressions"

    $tools add thrlock -image [fetchImage thrlock]
    Workspace:addToolTip $tools thrlock $debugfrm:statusMsg \
	"Follow thread" "Lock focus on current thread"

    $tools add newframe -image [fetchImage newfrm]
    Workspace:addToolTip $tools newframe $debugfrm:statusMsg \
	"New frame" "Open new debug window"

    pack $tools -anchor w -padx 4 -pady 4 -side left

    ## Switches

    global $debugfrm:switches
    set $debugfrm:switches {}

    # warning: this variable name is used for bindings later
    # in this proc.
    set switches $debugfrm.toolbar.switches

    tixSelect $switches -allowzero true -radio false \
	-command "Debugger:toolbarSwitch $debugfrm" \
	-variable $debugfrm:switches \
	-selectedbg $tixOption(dark1_bg) \
	-options {
	    label.anchor e
	}

    pack $switches -anchor e -padx 6 -pady 4 -side right

    $switches add stack -image [fetchImage stack]
    Workspace:addToolTip $switches stack $debugfrm:statusMsg \
	"Stack" "Toggle backtrace display window"
    $switches add locals -image [fetchImage locals]
    Workspace:addToolTip $switches locals $debugfrm:statusMsg \
	"Locals" "Toggle locals display window"
    $switches add asynch -image [fetchImage asynch]
    Workspace:addToolTip $switches asynch $debugfrm:statusMsg \
	"Trace asynch." "Toggle asynchronous contexts trace"

    ## source file commands

    global $debugfrm:factions
    set $debugfrm:factions {}

    set srcmd [frame $debugfrm.toolbar.srcmd -bd 0 -relief flat]
    pack $srcmd -side right -fill both
    set filecmd $srcmd.factions

    tixSelect $filecmd -allowzero true -radio true \
	-variable $debugfrm:factions \
	-command "Debugger:toolbarExec $filecmd $debugfrm" \
	-options {
	    label.anchor e
	}

    $filecmd add resynch -image [fetchImage resynch]
    Workspace:addToolTip $filecmd resynch $debugfrm:statusMsg \
	"Show next statement" "Show next executable statement"

    $filecmd add reload -image [fetchImage reload]
    Workspace:addToolTip $filecmd reload $debugfrm:statusMsg \
	"Reload file" "Reload current source file"

    menubutton $srcmd.fstack -image [fetchImage files] \
	-takefocus 0 -indicatoron yes -bd 1 -relief raised \
	-menu $srcmd.fstack.m

    menu $srcmd.fstack.m -tearoff false \
	-relief raised -bd 2 \
	-postcommand "Debugger:buildSourceStack $debugfrm $srcmd.fstack.m"

    Workspace:addToolTipSimple $srcmd.fstack \
	$debugfrm:statusMsg \
	"Recent files" "Visit recent files"

    pack $srcmd.fstack -side right -padx 0 -ipady 1
    pack $filecmd -side right -padx 0

    # Selectors frame
    frame $debugfrm.selectors -width 600 -bd 1 -relief groove

    ## focus selector

    global $debugfrm:focus
    set $debugfrm:focus {}

    tixComboBox $debugfrm.selectors.focus -label "Focus " -dropdown true \
	-command "Debugger:setFocus $debugfrm" \
	-editable false \
	-variable $debugfrm:focus \
	-grab local \
	-history false \
	-options {
	    slistbox.scrollbar auto
	    listbox.height 12
	    listbox.width 30
	    label.width 6
	    label.anchor w
	}

    $debugfrm.selectors.focus subwidget entry configure -width 20
    Debugger:clearFocus $debugfrm
    pack $debugfrm.selectors.focus -padx 5 -side left

    ## Tick count display

    global $debugfrm:tickval
    set $debugfrm:tickval {}

    label $debugfrm.selectors.ticks -textvariable $debugfrm:tickval
    pack $debugfrm.selectors.ticks -padx 5 -side left

    ## Scratchpad

    global $debugfrm:scratchpad
    set $debugfrm:scratchpad {}

    tixComboBox $debugfrm.selectors.scratchpad \
	-variable $debugfrm:scratchpad \
	-label {} \
	-labelside left \
	-dropdown true \
	-editable true \
	-grab local \
	-history true \
	-prunehistory true \
	-options {
	    slistbox.scrollbar auto
	    listbox.height 6
	    listbox.width 21
	    label.padX 0
	    entry.width 21
	}

    pack $debugfrm.selectors.scratchpad -padx 5 -side right

    ### Msg frame

    frame $debugfrm.messages -width 600 -bd 1 -relief groove
    label $debugfrm.messages.location -text {} -anchor e
    label $debugfrm.messages.warning -text {} -anchor e
    pack $debugfrm.messages.location -side left -padx 4
    pack $debugfrm.messages.warning -side right -padx 4

    ### Main Paned Window

    tixPanedWindow $debugfrm.window -orientation vertical 

    set p1 [$debugfrm.window add p1 -min 70 -expand 0.85]
    set p2 [$debugfrm.window add p2 -min 70 -expand 0.15]

    ### Source pane

    tixScrolledText $p1.source -height 300 -width 600 -options {
	text.spacing1 0
	text.spacing3 0
	text.state disabled
	text.font SourceFont
    }
    set text [$p1.source subwidget text]
    pack $p1.source -expand yes -fill both
    set Debugger:f2w($debugfrm,source) $text
    # force focus on the text widget upon Mouse-click 1. Having it disabled
    # seems to prevent the defaut binding to be applied. So help ourselves.
    bind $text <1> "+ focus $text"
    bind $text <Motion> "+ Debugger:lookupWord $debugfrm $text %x %y %X %Y"
    bind $text <Control-Button-1> "+ Debugger:lookupSymbol $debugfrm"
    rearrangeBindings $text

    set popup $text.popup
    backmenu $popup -tearoff 0
    $popup validate "Debugger:postSourceMenu $debugfrm"
    $popup bind $text

    ### Data pane

    #### Data Paned SubWindow

    tixPanedWindow $p2.data -orientation horizontal \
	-dynamicgeometry false
    pack $p2.data -expand yes -fill both
    set Debugger:f2w($debugfrm,data) $p2.data

    #### Stack pane
    set subp1 [$p2.data add stack -expand 0.50 -min 200]
    tixScrolledListBox $subp1.stack -scrollbar auto \
	-browsecmd "Debugger:browseStack $debugfrm"
    set lbox [$subp1.stack subwidget listbox]
    bind $lbox <1> "+ focus $lbox"
    pack $subp1.stack -expand yes -fill both
    set Debugger:f2w($debugfrm,stack) $subp1.stack
    $p2.data forget stack
    bind $lbox <Escape> "$switches invoke stack"

    #### Locals pane
    set subp2 [$p2.data add locals -expand 0.50 -min 200]
    DataDisplay:makeLocalsTree $debugfrm $subp2.locals
    set Debugger:f2w($debugfrm,locals) $subp2.locals
    $p2.data forget locals
    bind [$subp2.locals subwidget hlist] <Escape> "$switches invoke locals"
}

proc Debugger:displayWallPaper {context} {

    global Debugger:workspace Debugger:f2w

    set wsmbar [set Debugger:workspace($context)].mbar
    set textw [set Debugger:f2w($context,source)]
    set wallpaper [canvas $textw.wallpaper]
    bind $wallpaper <Configure> \
	"+ Debugger:resizeWallPaper $context $wallpaper %w %h"
    pack $wallpaper -expand yes -fill both
}

proc Debugger:removeWallPaper {context} {

    global Debugger:f2w
    set textw [set Debugger:f2w($context,source)]
    catch { destroy $textw.wallpaper }
}

proc Debugger:resizeWallPaper {context wallpaper w h} {

    global Debugger:workspace Project:settings

    catch { $wallpaper delete plaid }

    if {[set Project:settings(Preferences,displaywp)] == 1} {
	set bgimage [fetchImage [set Project:settings(Preferences,wallpaper)]]
	if {$bgimage != {}} {
	    set y 0
	    while {$y < $h} {
		set x 0
		while {$x < $w} {
		    $wallpaper create image $x $y -image $bgimage -anchor nw -tag plaid
		    set x [expr $x + [image width $bgimage]]
		}
		set y [expr $y + [image height $bgimage]]
	    }
	}
    }
}

proc Debugger:createSecondaryFrame {context} {

    global Debugger:fserial Debugger:workspace

    regexp "^(.*)\\..*$" $context mvar root
    set w $context.frm${Debugger:fserial}
    toplevel $w
    wm title $w [format "%s #%d" [wm title $root] ${Debugger:fserial}]
    wm geometry $w 700x600
    cascadeWindow $w