Tcl2002 programming contest: solutions to problem 3

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

Tcl2002 programming contest: problem 3

The Great Canadian Tcl/Tk Programming Contest, eh?