The primary purpose of this problem was to expose the new trace execution command that was added in Tcl 8.4. Andrej Vckovski took the laurels on this problem, with the following solution, which even favored us with a test harness to demonstrate its execution:
# display a call graph of the passed command line
# AVckovski, 2002-11-20
proc callGraph {cmdLine} {
proc ::_myEnterstep {cmdString ops} {
set cmdName [lindex $cmdString 0]
if {[string length [info proc $cmdName]]} {
if {![info exists ::_traces($cmdName)]} {
trace add execution $cmdName enterstep ::_myEnterstep
# lazy cleanup; just remember all traces instead of using trace info
set ::_traces($cmdName) ::_myEnterstep
}
}
# display command word, indented
# if more than one line, just 1st, and limit line length
set cmdString [lindex [split $cmdString \n] 0]
if {[string length $cmdString]>40} {
set cmdString "[string range $cmdString 0 40] ..."
}
puts "[string repeat -- [info level]] $cmdString"
}
# init some state
#set ::_traces {}
# setup and start
set cmdName [lindex $cmdLine 0]
uplevel [list ::_myEnterstep $cmdLine enterfirst]
uplevel $cmdLine
# cleanup our recorded traces
foreach cmdName [array names ::_traces] {
trace remove execution $cmdName enterstep $::_traces($cmdName)
}
# cleanup state
rename ::_myEnterstep ""
unset ::_traces
}
# test case
proc sum {a b} {
return [expr $a + $b]
}
proc z {} {return [sum [sum [sum [sum 5 6] 7] 8] [sum 11 22]]}
proc fac {n} {
if {$n==1} {
return 1
} else {
return [expr $n*[fac [expr $n-1]]]
}
}
callGraph z
callGraph {fac 8}which produces output that looks like:
-- z
---- sum 5 6
------ expr 5 + 6
------ expr 5 + 6
------ return 11
------ return 11
---- sum 11 7
------ expr 11 + 7
------ expr 11 + 7
------ return 18
------ return 18
---- sum 18 8
------ expr 18 + 8
------ expr 18 + 8
------ return 26
------ return 26
. . .In preparation for the contest, KBK had developed the following solution:
proc K { x y } { return $x }
proc doit { command } {
uplevel 1 $command
}
proc callgraph { command } {
variable context
variable children
variable did
set context {}
trace add execution doit enterstep enter
trace add execution doit leavestep leave
uplevel 1 [list doit $command]
trace remove execution doit enterstep enter
trace remove execution doit leavestep leave
display uplevel
catch { unset children }
catch { unset did }
return
}
proc enter { commandStr op } {
variable context
variable children
set command [lindex $commandStr 0]
set children([lindex $context end],$command) {}
lappend context $command
return
}
proc leave { commandStr code result op } {
variable context
# There's a Tcl bug where we get extra 'leave' traces. Work around it.
if { [info level] < [llength $context] } {
set context [lreplace [K $context [set context {}]] [info level] end]
}
return
}
proc display { context { level 0 } } {
variable children
variable did
set last [lindex $context end]
if { [info exists did($last)] } {
if { [llength [array names children $context,*]] > 0 } {
puts [format %*s... [expr { 4 * $level}] {}]
}
} else {
set did($last) {}
foreach child [lsort [array names children $context,*]] {
foreach { - childproc } [split $child ,] break
puts [format %*s%s [expr { 4 * $level}] {} $childproc]
display $childproc [expr { $level + 1 }]
}
}
return
}which produces rather more compact output; on Andrej's test case, it shows
% callgraph z
z
return
sum
expr
return
% callgraph {fac 8}
fac
expr
fac
...
if
expr
return