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. (see TESTS at the bottom of this page)
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} {
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
}
}# SOME TESTS
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}}