lib/debugger.exp

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