diff options
Diffstat (limited to 'lib/debugger.exp')
| -rw-r--r-- | lib/debugger.exp | 244 |
1 files changed, 244 insertions, 0 deletions
diff --git a/lib/debugger.exp b/lib/debugger.exp new file mode 100644 index 0000000..f00076d --- /dev/null +++ b/lib/debugger.exp @@ -0,0 +1,244 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 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@cygnus.com) + +# +# 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_and_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 +} |