- It fails if the code that being debugged throws an error
- It can not restart the program
- It only looks at procedures, not code outside procedures
- It does a very superficial analysis of the code, so it can be fooled easily
- You can set a breakpoint
- You can step through the code line by line or step over procedures
- You can print variables (admittedly, not arrays)
- You can let it continue until the end or until a breakpoint
# debug.tcl --
# Optimistic debugger
#
# Note:
# The reason for calling it an optimistic debugger, rather than
# a minimalist debugger or the like is simple: it is not
# minimal, as it contains a more options and frills than absolutely
# necessary and it is not at all finished - no attention is paid
# to command aliases or namespaces for instance nor to code outside
# any procedures.
# So it is rather optimistic to view this as a useful tool. Well,
# it may the basis of one. On the other hand, there are lots of
# good and complete debuggers out there. This is merely an
# illustration that building a debugger does not need more than
# what Tcl already offers.
namespace eval ::dbg {
variable dbg
}
# dbg_proc --
# Replacement for the ordinary proc command
# Arguments:
# name Name of the new procedure
# arglist Argument list
# body Body of the procedure
# Result:
# None
# Side effect:
# A new procedure $name is created with a debug-ready implementation
#
proc dbg_proc {name arglist body} {
set newbody {}
set lineno -1
set complete 0
set cmdline {}
set control ""
foreach line [split $body \n] {
incr lineno
set words [split [string trim $line]]
set extra ""
switch -glob -- [lindex $words 0] {
"if" -
"for" -
"foreach" -
"while" {
set prefix "__dbg__ [list $name] $lineno;"
set extra "\}"
set control "any"
}
"switch" {
set prefix "__dbg__ [list $name] $lineno;"
set extra "\}"
set control "switch"
}
default {
#
# Try to skip switch patterns
if { $control == "switch" } {
if { [llength $words] == 2 &&
([lindex $words end] == "-" ||
[lindex $words end] == "\}" ) } {
set prefix ""
}
} else {
if { ! [string match "\}*" $words] &&
! [string match "#*" $words] } {
set prefix "__dbg__ [list $name] $lineno;"
}
}
}
}
append cmdline "$prefix$line"
if { [info complete $cmdline$extra] } {
lappend newbody $cmdline
set cmdline {}
}
}
_proc_ $name [list $arglist] [join $newbody \n]
}
namespace eval ::dbg {
variable dbg
set dbg(prompt) "> "
set dbg(mode) "step"
}
# __dbg__ --
# Central debugging procedure
# Arguments:
# name Name of the procedure
# lineno Line number in the procedure
# Result:
# None
# Side effect:
# Whatever the user does
#
proc __dbg__ {name lineno} {
upvar 0 ::dbg::dbg Dbg
if { $Dbg(mode) == "step" ||
( $Dbg(mode) == "next" && $Dbg(proc) == "$name" ) ||
[info exists Dbg($name,$lineno)] } {
__dbg__proc $name $lineno
while { 1 } {
puts -nonewline $Dbg(prompt)
flush stdout
gets stdin answer
set cmd [lindex [split $answer] 0]
set argum [lindex [split $answer] 1]
switch -- $cmd {
"p" - "print" {
if { [catch {
uplevel 1 [string map [list VAR $argum] {puts "VAR = [set VAR]"}]
} msg] } {
puts $msg
}
}
"s" - "step" {
set Dbg(mode) "step"
return
}
"n" - "next" {
# Note: no level information yet!
set Dbg(mode) "next"
set Dbg(proc) "$name"
return
}
"c" - "cont" {
set Dbg(mode) "cont"
return
}
"b" - "break" {
set Dbg($name,$argum) 1
}
"q" - "quit" {
exit
}
default {
puts "Unknown command - $cmd"
}
}
}
}
}
# __dbg__proc --
# Print one or more lines from a procedure's body
# Arguments:
# name Name of the procedure
# lineno Line number in the procedure (optional)
# Result:
# None
# Side effect:
# Printed lines
#
proc __dbg__proc {name {lineno {}}} {
set body [info body $name]
if { $lineno != {} } {
regsub {__dbg__ .*;} [lindex [split $body \n] $lineno] {} line
puts " $line"
}
}
rename proc _proc_
rename dbg_proc proc
# test --
# Just a simple numerical procedure ...
#
proc theta2 {q} {
if { $q >= 1.0 || $q < 0 } {
return -code error "Argument out of range: q must be < 1 and >= 0"
}
set r 1.0
if { $q == 0.0 } {
return $r
}
set logq [expr {log($q)}]
set n 1
while { 1 } {
set term [expr {exp(($n*$n+$n)*$logq)}]
set r [expr {$r + $term}]
if { $term < 1.0e-8 } {
break
}
incr n
}
return [expr {2.0*sqrt(sqrt($q))*$r}]
}
proc theta3 {q} {
if { abs($q) >= 1.0 } {
return -code error "Argument out of range: |q| must be < 1"
}
set r 1.0
if { $q == 0.0 } {
return $r
}
set logq [expr {log(abs($q))}]
set sign [expr {$q > 0? 1.0 : -1.0}]
set n 1
while { 1 } {
set term [expr {2.0*exp($n*$n*$logq)}]
set r [expr {$r + $sign*$term}]
if { $term < 1.0e-8 } {
break
}
incr n
if { $q < 0 } {
set sign [expr {-$sign}]
}
}
return $r
}
puts [theta2 0.1][ Category Debugging | Category Dev. Tools | Category Toys ]
