diff options
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/debugger.exp')
| -rw-r--r-- | contrib/bluegnu2.0.3/lib/debugger.exp | 252 |
1 files changed, 0 insertions, 252 deletions
diff --git a/contrib/bluegnu2.0.3/lib/debugger.exp b/contrib/bluegnu2.0.3/lib/debugger.exp deleted file mode 100644 index 8dd0701..0000000 --- a/contrib/bluegnu2.0.3/lib/debugger.exp +++ /dev/null @@ -1,252 +0,0 @@ -# Copyright (C) 92, 93, 94, 95, 1996 Free Software Foundation, Inc. - -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -# Please email any bugs, comments, and/or additions to this file to: -# bug-dejagnu@prep.ai.mit.edu - -# This file was written by Rob Savoye. (rob@welcomehome.org) - -# -# Dump the values of a shell expression representing variable -# names. -proc dumpvars { args } { - uplevel 1 [list foreach i [uplevel 1 "info vars $args"] { - if { [catch "array names $i" names ] } { - eval "puts \"${i} = \$${i}\"" - } else { - foreach k $names { - eval "puts \"$i\($k\) = \$$i\($k\)\"" - } - } - } - ] -} - -# -# dump the values of a shell expression representing variable -# names. -proc dumplocals { args } { - uplevel 1 [list foreach i [uplevel 1 "info locals $args"] { - if { [catch "array names $i" names ] } { - eval "puts \"${i} = \$${i}\"" - } else { - foreach k $names { - eval "puts \"$i\($k\) = \$$i\($k\)\"" - } - } - } - ] -} -# -# Dump the body of procedures specified by a regexp. -# -proc dumprocs { args } { - foreach i [info procs $args] { - puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}" - } -} - -# -# Dump all the current watchpoints -# -proc dumpwatch { args } { - foreach i [uplevel 1 "info vars $args"] { - set tmp "" - if { [catch "uplevel 1 array name $i" names] } { - set tmp [uplevel 1 trace vinfo $i] - if ![string match "" $tmp] { - puts "$i $tmp" - } - } else { - foreach k $names { - set tmp [uplevel 1 trace vinfo [set i]($k)] - if ![string match "" $tmp] { - puts "[set i]($k) = $tmp" - } - } - } - } -} - -# -# Trap a watchpoint for an array -# -proc watcharray { element type} { - upvar [set array]($element) avar - case $type { - "w" { puts "New value of [set array]($element) is $avar" } - "r" { puts "[set array]($element) (= $avar) was just read" } - "u" { puts "[set array]($element) (= $avar) was just unset" } - } -} - -proc watchvar { v type } { - upvar $v var - case $type { - "w" { puts "New value of $v is $var" } - "r" { puts "$v (=$var) was just read" } - "u" { puts "$v (=$var) was just unset" } - } -} - -# -# Watch when a variable is written -# -proc watchunset { arg } { - if { [catch "uplevel 1 array name $arg" names ] } { - if ![uplevel 1 info exists $arg] { - puts stderr "$arg does not exist" - return - } - uplevel 1 trace variable $arg u watchvar - } else { - foreach k $names { - if ![uplevel 1 info exists $arg] { - puts stderr "$arg does not exist" - return - } - uplevel 1 trace variable [set arg]($k) u watcharray - } - } -} - -# -# Watch when a variable is written -# -proc watchwrite { arg } { - if { [catch "uplevel 1 array name $arg" names ] } { - if ![uplevel 1 info exists $arg] { - puts stderr "$arg does not exist" - return - } - uplevel 1 trace variable $arg w watchvar - } else { - foreach k $names { - if ![uplevel 1 info exists $arg] { - puts stderr "$arg does not exist" - return - } - uplevel 1 trace variable [set arg]($k) w watcharray - } - } -} - -# -# Watch when a variable is read -# -proc watchread { arg } { - if { [catch "uplevel 1 array name $arg" names ] } { - if ![uplevel 1 info exists $arg] { - puts stderr "$arg does not exist" - return - } - uplevel 1 trace variable $arg r watchvar - } else { - foreach k $names { - if ![uplevel 1 info exists $arg] { - puts stderr "$arg does not exist" - return - } - uplevel 1 trace variable [set arg]($k) r watcharray - } - } -} - -# -# Delete a watch point -# -proc watchdel { args } { - foreach i [uplevel 1 "info vars $args"] { - set tmp "" - if { [catch "uplevel 1 array name $i" names] } { - catch "uplevel 1 trace vdelete $i w watchvar" - catch "uplevel 1 trace vdelete $i r watchvar" - catch "uplevel 1 trace vdelete $i u watchvar" - } else { - foreach k $names { - catch "uplevel 1 trace vdelete [set i]($k) w watcharray" - catch "uplevel 1 trace vdelete [set i]($k) r watcharray" - catch "uplevel 1 trace vdelete [set i]($k) u watcharray" - } - } - } -} - -# -# This file creates GDB style commands for the Tcl debugger -# -proc print { var } { - puts "$var" -} - -proc quit { } { - log_summary - exit -} - -proc bt { } { - puts "[w]" -} - -# -# create some stub procedures since we can't alias the command names -# -proc dp { args } { - uplevel 1 dumprocs $args -} - -proc dv { args } { - uplevel 1 dumpvars $args -} - -proc dl { args } { - uplevel 1 dumplocals $args -} - -proc dw { args } { - uplevel 1 dumpwatch $args -} - -proc q { } { - quit -} - -proc p { args } { - uplevel 1 print $args -} - -proc wu { args } { - uplevel 1 watchunset $args -} - -proc ww { args } { - uplevel 1 watchwrite $args -} - -proc wr { args } { - uplevel 1 watchread $args -} - -proc wd { args } { - uplevel 1 watchdel $args -} - - - - - - - |