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