gdb.tcl

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

			[lindex $log $pos] mvar function
		}
		# matching could fail (in currently unknown cases)
		# so be conservative and catch error if function
		# has not been identified properly.
		catch { set hotspot [list $function] }
	    }
    }

    return $hotspot
}

proc gdb:seek {context focuscmd location {focusvar {}} {localsvar {}}} {

    global gdb:mvmcr0 gdb:mvmcr1 gdb:mvmcr2

    # Direct stack context to the designated focus
    set scope [lindex $focuscmd 0]
    set flag [TkRequest $context GetCtlCode $scope]
    set id [lindex $focuscmd 1]

    gdb:command "set *((int *)${gdb:mvmcr0}) |= $flag"
    gdb:command "set *((int *)${gdb:mvmcr1}) = $id"
    set rl [gdb:command "call mvm_switch()" - {"^Breakpoint [0-9]+.*" }]

    if {$focusvar != {}} {
	# Fetch the current focus as a C string stored in the mvmcr2
	# control register. Note the explicit cast to pointer to character
	# in order to force a C string as a result, even if the module
	# implementing this routine does not include any debug
	# information (i.e. was not compiled using the -g option).
	# Otherwise, GDB would have output a signed integer representing
	# the value of the returned pointer, which is not what we asked for.
	set rl [gdb:command "print *((char **)${gdb:mvmcr2})" l "\$.*"]
	set matched [lindex $rl 1]
	# fetch current focus
	upvar $focusvar curfocus
	regexp "\[^\"\]+.(\[^\"\]+).*" $matched mvar curfocus
    }

    # query stack information
    set rl [gdb:command where ls]
    set stackinfo [lindex $rl 2]

    if {$stackinfo == {}} {
	upvar $location _location
	set _location {preamble}
	# no stack (i.e. no root level found)? this must be a thread preamble.
	return {}
    }

    # Find out at least the function name, and if possible, the source
    # file and the line number of the outer code location where we stopped.
    # The C++ support has already made the harder stuff, filtering out
    # internal frames and returned a significant stack information log of
    # the following format: { {fnum {frame-info}} {fnum2 {frame-info2}} ...} 
    # ordered from outer to inner locations.
    # We finish the job by searching for the outer viewable piece of code
    # (if any).

    upvar $location hotspot
    set oldfnum 0
    set viewspot {}
    set hotspot {}
    set ups 0

    foreach frame $stackinfo {
	set fnum [lindex $frame 0]
	set fdisp [expr $fnum - $oldfnum]
	# Note: "up 0" makes GDB nicely repeat its current location
	set _hotspot [gdb:movestack $context up $fdisp]

	if {$_hotspot == {}} {
	    # something weird happened!
	    return {}
	}
	if {$ups == 0} {
	    set hotspot $_hotspot
	}

	incr ups $fdisp

	if {[llength $_hotspot] > 1} {
	    # got debug information for this one
	    set viewspot $_hotspot
	    break
	}
	set oldfnum $fnum
    }

    if {[llength $hotspot] == 1 && $viewspot != {}} {
	# append a visible code location to the outer
	# function name (where we stopped). A ? prefix
	# is prepended to inform our caller that the function
	# name does not match the returned code location.
	set hotspot [concat ? $hotspot [lrange $viewspot 1 end]]
	# reset the stack pointer down to the outer frame
	gdb:movestack $context down $ups
    }

    if {$localsvar != {}} {
	# query locals list as needed
	upvar $localsvar locals
	set locals [gdb:getlocals]
    }

    return $stackinfo
}

proc gdb:backtrace {context focuscmd location focusvar {localsvar {}}} {

    global gdb:btcache

    upvar $location _location
    upvar $focusvar _focusvar

    if {$localsvar != {}} {
 	upvar $localsvar _localsvar
 	set locals _localsvar
	# never reuse the cache if locals are wanted.
	set gdb:btcache {}
     } {
 	set _localsvar {}
 	set locals {}
     }

    if {[lindex ${gdb:btcache} 0] != $focuscmd} {
	set stackinfo [gdb:seek $context \
			   $focuscmd _location _focusvar $locals]
	if {$stackinfo != {}} {
	    set gdb:btcache [list $focuscmd $stackinfo $_location \
				 $_focusvar $_localsvar]
	} {
	    set _location {$kprea$}
	    set _focusvar {preamble}
	}
	# exit from thread bump call() before returning
	gdb:switchout $context

    } {
	set stackinfo [lindex ${gdb:btcache} 1]
	set _location [lindex ${gdb:btcache} 2]
	set _focusvar [lindex ${gdb:btcache} 3]
    }

    return $stackinfo
}

proc gdb:down {context focuscmd fnum} {

    set location {}
    gdb:seek $context $focuscmd location

    if {$fnum > 0} {
	gdb:command "up $fnum"
    }

    set hotspot [gdb:movestack $context down]
    # exit from thread bump call() before returning
    gdb:command cont

    return $hotspot
}

proc gdb:up {context focuscmd fnum} {

    set location {}
    gdb:seek $context $focuscmd location
    set levels [expr $fnum + 1]

    set hotspot [gdb:movestack $context up $levels]
    # exit from thread bump call() before returning
    gdb:command cont

    return $hotspot
}

proc gdb:getdata {expr format treestyle} {

    global gdb:lastexpr

    set gdb:lastexpr $expr
    switch -exact -- $format {
       octal { set fmt o }
       decimal { set fmt d }
       unsigned { set fmt u }
       binary { set fmt t }
       float { set fmt f }
       address { set fmt a }
       char { set fmt c }
       hex { set fmt x}
       default { set fmt ""}
    }
    set rl [gdb:command "output /${fmt} $expr" l]
    set log [lindex $rl 2]

    if {${treestyle} == "true"} {
	set log [gdb:parsedata $log]
    } {
	# if no tree formatting is requested, perform some sanity
	# checks on the returned value.
	set s [lindex $log 0]
	if {$s == {} ||
	    [regexp "^Attempt .*" $s] == 1 ||
	    [regexp "^No symbol .*" $s] == 1 ||
	    [regexp "^A parse error .*" $s] == 1} {
	    # oops, does not look good! tell caller to forget it...
	    global gdb:lasterror
	    set gdb:lasterror $log
	    set log {}
	}
    }
    return $log
}

proc gdb:followdata {expr} {

    # followdata always requires tree style formatting
    return [gdb:getdata [format "*(%s)" $expr] "no_format" true]
}

proc gdb:dumpdata {expr format count size} {

    global gdb:lastexpr

    # compute format and size letters
    switch -exact -- $format {
	octal { set fmt o }
	decimal { set fmt d }
	unsigned { set fmt u }
	binary { set fmt t }
	float { set fmt f }
	address { set fmt a }
	char { set fmt c }
	string { set fmt s }
	instruction { set fmt i}
	default { set fmt x }
    }
    switch -exact -- $size {
	short { set sz h }
	long { set sz w }
	giant { set sz g }
	default -
	byte { set sz b }
    }

    set gdb:lastexpr $expr
    set rl [gdb:command "x/${count}${fmt}${sz} $expr" l]
    set log [lindex $rl 2]
    set s [lindex $log 0]

    if {$s == {} ||
	[regexp "^0x\[0-9A-Fa-f\]*:\[ \t\]*Cannot access memory.*" $s] == 1 ||
	[regexp "^Attempt .*" $s] == 1 ||
	[regexp "^No symbol .*" $s] == 1 ||
	[regexp "^A parse error .*" $s] == 1} {
	# oops, does not look good! tell caller to forget it...
	global gdb:lasterror
	set gdb:lasterror $log
	set log {}
    }
    return $log
}

proc gdb:setdata {lhs rhs} {

    # GDB's set command does not output anything unless
    # something wrong happened. Thus, this procedure's
    # return value is an error message on failure, or
    # nil if all is ok.
    set rl [gdb:command "set $lhs = $rhs" l]
    return [lindex $rl 2]
}

proc gdb:typeinfo {expr} {

    global gdb:lastexpr

    set gdb:lastexpr $expr

    set rl [gdb:command "ptype $expr" l]
    set nre [lindex $rl 0]
    set log [lindex $rl 2]

    if {$nre == -1} {
	return {}
    }
    
    set s [lindex $log 0]
    
    if {$s == {} || [regexp "^type = .*" $s] == 0} {
	# oops, does not look good! tell caller to forget it...
	set log {}
    } {
	# prepend the expression to the result -- note that
	# the tricky way to do this is absolutely needed
	# for Tcl lists evaluation reasons.
	set expr [format "\"%s\" " $expr]
	set s [concat $expr $s]
	set log [lreplace $log 0 0 $s]
    }

    return $log
}

proc gdb:getlocals {} {

    set rl1 [gdb:command "info args" l]
    set rl2 [gdb:command "info locals" l]
    set locals {}

    # Ensure each variable is unique.
    foreach line [concat [lindex $rl1 2] [lindex $rl2 2]] {
	# ...allow $ in identifiers...
	if {[regexp "^(\[a-zA-Z_\]\[a-zA-Z0-9_\$\]*) =.*" $line mvar varname] == 1} {
	    if {[lsearch -regexp $locals "^$varname"] == -1} {
		lappend locals $varname
	    }
	}
    }

    return $locals
}

proc gdb:setsrc {srcDirs} {
    global gdb:btcache
    # Setup source directories list (if empty,
    # GDB will reset it to the default ($cdir:$cwd))
    gdb:command "directory $srcDirs"
    # flush the backtrace cache to allow reevaluation
    # of current hotspot
    set gdb:btcache {}
}

proc gdb:locate {expr} {

    set rl [gdb:command "info line $expr" - \
		{ "^\032\032.*" \
		  "^Line number \[0-9\]+ is out of range.*" }]
    set nre [lindex $rl 0]
    set matched [lindex $rl 1]

    if {$nre == -1} {
	return {}
    }

    switch -- $nre {
	    0 {
		# ^Z^Z RE matched (usually for a function)
		set l [split $matched :]
		set sourcefile [string range [lindex $l 0] 2 end]
		set lineno [lindex $l 1]
	    }

	    1 {
		# Found a match, but we should help GDB to find the
		# actual file name (GDB seems to be confused when
		# trying to determine the location of a data
		# declaration -- in fact, GCC emits a N_SO stab with
		# the main input filename as value, which is our
		# temporary file path when compiling, not the original
		# one we cautiously kept unchanged from the line
		# information directives, and GDB uses it to search
		# for the source location, damn it!)
 		if {[regexp "^Line number (\[0-9\]+) is out of range for \"(.*)\".*" \
 			 $matched mvar lineno sourcefile] == 0} {
		    set lineno 0
		    set sourcefile {}
		} {
		    # This is a hack to work around the state of
		    # confusion GDB seems to experience with the
		    # source information of data symbols as tweaked by
		    # the C/C++ instrumenter.  this hack has a flaw:
		    # if multiple files share the same base name, the
		    # first one returned by GDB will always be
		    # picked. However, this is harmless for the debug
		    # session.  HACKHACK: we DO KNOW that gcic
		    # prepends the 'ic1@' string in front of the
		    # original source file to compose the temporary
		    # file name. So we have to remove it when asking
		    # GDB to find this file using its original
		    # name. Sorry for this...
		    # FIXME: maybe not needed by GCIC since data are
		    # not vectorized anymore?
		    set basename [file tail $sourcefile]
		    if {[string match ic1@* $basename]} {
			set basename [string range $basename 4 end]
		    }
		    gdb:command "list $basename:1,1"
		    set rl [gdb:command "info source" l]
		    set log [lindex $rl 2]
		    set fileloc [lindex $log [lsearch -regexp $log "^Located in.*"]]
		    regexp "^Located in (\[^ \]+)$" $fileloc mvar sourcefile
		}
	    }

	    default {
		# not found
		set lineno 0
		set sourcefile {}
	    }
    }

    return [list $sourcefile $lineno]
}