Initial revision

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
+}