Sarnold: The following snippet defines a xbody command, which takes a code body as argument, and transforms it, putting math expressions inside expr calls.
For example:
xbody {puts ={$x+1}}returns:
{puts [expr {$x+1}]}The if, while, foreach and for bodies are treated as nested bodies, and substitutions occur inside them. (see TESTS at the bottom of this page)
You may extend Tcl's syntax by using this command and xbody::register.
See also expr shorthand for Tcl9.
xbody::xbody string
Returns the body string in which brace expressions prefixed by some prefixes are processed.
xbody::register prefix command ?immediate?
When "prefix" is followed by a braced expression (like "{$x+1}"),
the whole expression is replaced with an invokation of "command" upon the braced expression.
For example, ={$x+1} is replaced with [expr {$x+1}].
When "immediate" is "true", the hook "command" is invoked immediately upon the braced expression.
Each name can be bound to exactly one hook.namespace eval xbody {
namespace export xbody
variable hooks {}
proc register {name cmd {immediate no}} {
dict set ::xbody::hooks $name [list $cmd $immediate]
}
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 trimright $chunk] ne ""} {
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 xbody {body} {
# eol safety
set body [string map {\r \n} [string map {\r\n \n} $body]]
# list of commands for the result
set commands {}
# current command (temp)
set line {}
# the dictionary of hooks
variable hooks
foreach cmd [cmdSplit $body] {
set line ""
foreach word [wordSplit $cmd] {
foreach {name hook} $hooks {
if {[string first $name\{ $word]==0} {
set word [hook $hook [string range $word [string length $name] end]]
}
}
lappend line $word
}
if {[lindex $line 0] in {if while for foreach}} {
# process bodies embedded
set line [xcontrol_[lindex $cmd 0] {*}[lrange $cmd 1 end]]
}
lappend commands [join $line]
}
join $commands \n
}
proc hook {hook arg} {
lassign $hook cmd immediate
if {$immediate} {return [$cmd $arg]}
return "\[$cmd $arg\]"
}
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 xcontrol_foreach {args} {linsert [lreplace $args end [_body [lindex $args end]]] 0 foreach}
proc _body body {
if {[string index $body 0] eq "\{"} {set body [string range $body 1 end-1]}
return "{[xbody $body]}"
}
}
xbody::register = expr
puts [xbody {
if {$x< 3} {
puts ={$y+4}
if {$y > 4} {
set l [lrange $l ={$y+1} end]
}
} elseif {$y} {$x add ={log($y)}} else break
}]jbr - 2010-03-18 06:42:30
Sugar provides an extensible framework for this type of syntax adjustment.