Sarnold: The following snippet defines a xbody command, which takes a code body as argument, and transforms it, putting directly math expressions inside expr calls.
For example:
xbody {puts $x+1}returns:
{puts [expr {$x+1}]}
How does it work? It just parse commands (with cmdSplit) and each word of each command is matched against some syntax rules:
Then, the word is put inside a expr call.
The if, while and for bodies are recognized as nested bodies, and substitutions of expr calls occur inside them.
namespace eval xbody {
namespace export xbody
proc cmdSplit {body} {
set commands {}
set chunk ""
foreach line [split $body "\n"] {
append chunk $line
if {[info complete "$chunk\n"]} {
# $chunk ends in a complete Tcl command, and none of the
# newlines within it end a complete Tcl command. If there
# are multiple Tcl commands in $chunk, they must be
# separated by semi-colons.
set cmd ""
foreach part [split $chunk ";"] {
append cmd $part
if {[info complete "$cmd\n"]} {
set cmd [string trimleft $cmd]
# Drop empty commands and comments
if {![string match {} $cmd] \
&& ![string match \#* $cmd]} {
lappend commands $cmd
}
if {[string match \#* $cmd]} {
set cmd "\#;"
} else {
set cmd ""
}
} else {
# No complete command yet.
# Replace semicolon and continue
append cmd ";"
}
}
set chunk ""
} else {
# No end of command yet. Put the newline back and continue
append chunk "\n"
}
}
if {![string match {} [string trimright $chunk]]} {
return -code error "Can't parse body into a\
sequence of commands.\n\tIncomplete\
command:\n-----\n$chunk\n-----"
}
return $commands
}
proc wordSplit {command} {
if {![info complete $command]} {error "non complete command"}
set res ""; # the list of words
set chunk ""
foreach word [split $command " \t"] {
# testing each word until the word being tested makes the
# command up to it complete
# example:
# set "a b"
# set -> complete, 1 word
# set "a -> not complete
# set "a b" -> complete, 2 words
append chunk $word
if {[info complete "$res $chunk"]} {
lappend res $chunk
set chunk ""
} else {
append chunk " "
}
}
set res
}
proc getNumber {word} {
if {[regexp {^[+\-]?[0-9]+\.?[0-9]*([eE][+\-]?[0-9]*)?} $word -> var]} {return $var}
return ""
}
proc isVarExpr {word} {isPattern $word {^\$(\\{[a-zA-Z0-9_]+\\}|[a-zA-Z0-9_]+)}}
proc isPattern {word pat} {
if {![regexp $pat $word -> var]} {return false}
regsub $pat $word "" word
expr {$word ne "" && ![regexp $pat $word]}
}
proc isExpr {word} {
set num [getNumber $word]
set var [isVarExpr $word]
expr {($num ne "" && $num ne $word) || $var}
}
proc xcontrol_if {cond body args} {
lappend result if $cond [_body $body]
while {[llength $args]>=3} {
set args [lassign $args word cond body]
lappend result $word $cond [_body $body]
}
if {[llength $args] != 2} {return $result}
lassign $args word body
lappend result $word [_body $body]
}
proc xcontrol_while {cond body} {list while $cond [_body $body]}
proc xcontrol_for {initial cond step body} {list for [_body $initial] $cond [_body $step] [_body $body]}
proc _body body {
if {[string index $body 0] eq "\{"} {set body [string range $body 1 end-1]}
return "{[xbody $body]}"
}
proc xbody {body} {
puts xbody,$body
set outBody ""
foreach cmd [cmdSplit $body] {
set outCmd ""
set cmd [wordSplit $cmd]
if {[lindex $cmd 0] in {if while for}} {set cmd [xcontrol_[lindex $cmd 0] {*}[lrange $cmd 1 end]]}
foreach word $cmd {
if {[isExpr $word]} {
lappend outCmd "\[expr \{$word\}\]"
} else {
lappend outCmd $word
}
}
append outBody [join $outCmd]\n
}
string trimright $outBody \n
}
}
proc t {body} {puts "$body\n-->[xbody::xbody $body]"}
t {if {$x>0} {puts $x+1} else {puts $y-1}}
t {if {$x>0} {puts $x+1} elseif {$h<3} {puts $y-1}}