1# Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc. 2# 3# This file is part of DejaGnu. 4# 5# DejaGnu is free software; you can redistribute it and/or modify it 6# under the terms of the GNU General Public License as published by 7# the Free Software Foundation; either version 3 of the License, or 8# (at your option) any later version. 9# 10# DejaGnu is distributed in the hope that it will be useful, but 11# WITHOUT ANY WARRANTY; without even the implied warranty of 12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13# General Public License for more details. 14# 15# You should have received a copy of the GNU General Public License 16# along with DejaGnu; if not, write to the Free Software Foundation, 17# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA. 18 19# This file was written by Rob Savoye <rob@welcomehome.org>. 20 21# Dump the values of a shell expression representing variable names. 22# 23proc dumpvars { args } { 24 uplevel 1 [list foreach i [uplevel 1 "info vars $args"] { 25 if { [catch "array names $i" names ] } { 26 eval "puts \"$i = \$$i\"" 27 } else { 28 foreach k $names { 29 eval "puts \"$i\($k\) = \$$i\($k\)\"" 30 } 31 } 32 } 33 ] 34} 35 36# Dump the values of a shell expression representing variable names. 37# 38proc dumplocals { args } { 39 uplevel 1 [list foreach i [uplevel 1 "info locals $args"] { 40 if { [catch "array names $i" names ] } { 41 eval "puts \"${i} = \$${i}\"" 42 } else { 43 foreach k $names { 44 eval "puts \"$i\($k\) = \$$i\($k\)\"" 45 } 46 } 47 } 48 ] 49} 50 51# Dump the body of procedures specified by a pattern. 52# 53proc dumprocs { args } { 54 foreach i [info procs $args] { 55 puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}" 56 } 57} 58 59# Dump all the current watchpoints. 60# 61proc dumpwatch { args } { 62 foreach i [uplevel 1 "info vars $args"] { 63 set tmp "" 64 if { [catch "uplevel 1 array name $i" names] } { 65 set tmp [uplevel 1 trace vinfo $i] 66 if {$tmp ne ""} { 67 puts "$i $tmp" 68 } 69 } else { 70 foreach k $names { 71 set tmp [uplevel 1 trace vinfo [set i]($k)] 72 if {$tmp ne ""} { 73 puts "[set i]($k) = $tmp" 74 } 75 } 76 } 77 } 78} 79 80# Trap a watchpoint for an array. 81# 82proc watcharray { array element op } { 83 upvar [set array]($element) avar 84 switch -- $op { 85 "w" { puts "New value of [set array]($element) is $avar" } 86 "r" { puts "[set array]($element) (= $avar) was just read" } 87 "u" { puts "[set array]($element) (= $avar) was just unset" } 88 } 89} 90 91proc watchvar { v ignored op } { 92 upvar $v var 93 switch -- $op { 94 "w" { puts "New value of $v is $var" } 95 "r" { puts "$v (=$var) was just read" } 96 "u" { puts "$v (=$var) was just unset" } 97 } 98} 99 100# Watch when a variable is written. 101# 102proc watchunset { arg } { 103 if { [catch "uplevel 1 array name $arg" names ] } { 104 if {![uplevel 1 info exists $arg]} { 105 puts stderr "$arg does not exist" 106 return 107 } 108 uplevel 1 trace variable $arg u watchvar 109 } else { 110 foreach k $names { 111 if {![uplevel 1 info exists $arg]} { 112 puts stderr "$arg does not exist" 113 return 114 } 115 uplevel 1 trace variable [set arg]($k) u watcharray 116 } 117 } 118} 119 120# Watch when a variable is written. 121# 122proc watchwrite { arg } { 123 if { [catch "uplevel 1 array name $arg" names ] } { 124 if {![uplevel 1 info exists $arg]} { 125 puts stderr "$arg does not exist" 126 return 127 } 128 uplevel 1 trace variable $arg w watchvar 129 } else { 130 foreach k $names { 131 if {![uplevel 1 info exists $arg]} { 132 puts stderr "$arg does not exist" 133 return 134 } 135 uplevel 1 trace variable [set arg]($k) w watcharray 136 } 137 } 138} 139 140# Watch when a variable is read. 141# 142proc watchread { arg } { 143 if { [catch "uplevel 1 array name $arg" names ] } { 144 if {![uplevel 1 info exists $arg]} { 145 puts stderr "$arg does not exist" 146 return 147 } 148 uplevel 1 trace variable $arg r watchvar 149 } else { 150 foreach k $names { 151 if {![uplevel 1 info exists $arg]} { 152 puts stderr "$arg does not exist" 153 return 154 } 155 uplevel 1 trace variable [set arg]($k) r watcharray 156 } 157 } 158} 159 160# Delete a watchpoint. 161# 162proc watchdel { args } { 163 foreach i [uplevel 1 "info vars $args"] { 164 set tmp "" 165 if { [catch "uplevel 1 array name $i" names] } { 166 catch "uplevel 1 trace vdelete $i w watchvar" 167 catch "uplevel 1 trace vdelete $i r watchvar" 168 catch "uplevel 1 trace vdelete $i u watchvar" 169 } else { 170 foreach k $names { 171 catch "uplevel 1 trace vdelete [set i]($k) w watcharray" 172 catch "uplevel 1 trace vdelete [set i]($k) r watcharray" 173 catch "uplevel 1 trace vdelete [set i]($k) u watcharray" 174 } 175 } 176 } 177} 178 179# This file creates GDB style commands for the Tcl debugger 180# 181proc print { var } { 182 puts $var 183} 184 185proc quit { } { 186 log_and_exit 187} 188 189proc bt { } { 190 # The w command is provided by the Tcl debugger. 191 puts "[w]" 192} 193 194# Create some stub procedures since we can't alias the command names. 195# 196proc dp { args } { 197 uplevel 1 dumprocs $args 198} 199 200proc dv { args } { 201 uplevel 1 dumpvars $args 202} 203 204proc dl { args } { 205 uplevel 1 dumplocals $args 206} 207 208proc dw { args } { 209 uplevel 1 dumpwatch $args 210} 211 212proc q { } { 213 quit 214} 215 216proc p { args } { 217 uplevel 1 print $args 218} 219 220proc wu { args } { 221 uplevel 1 watchunset $args 222} 223 224proc ww { args } { 225 uplevel 1 watchwrite $args 226} 227 228proc wr { args } { 229 uplevel 1 watchread $args 230} 231 232proc wd { args } { 233 uplevel 1 watchdel $args 234} 235