A page to collect useful Sugar macros.
inlist command macro
Expands
[inlist $list $element]
in
[expr {[lsearch -exact $list $element] != -1}]This one was suggested by Richard Suchenwirth (but the implementation is mine (SS), so even possible bugs):
sugar::macro inlist argv {
if {[llength $argv] != 3} {error "Bad number of arguments"}
list expr \
"\{\[lsearch -exact [lindex $argv 1] [lindex $argv 2]\] != -1\}"
}AMG: See also in, which can be used as a command as well as a math operator in Tcl 8.5.
tailrec_proc transformer
A wrapper to proc able to optimize tail recursive calls. For example the following:
tailrec_proc ack {m n} {
if {$m == 0} {
return [expr {$n + 1}]
} elseif {$n == 0} {
ack [expr {$m - 1}] 1
} else {
ack [expr {$m - 1}] [ack $m [expr {$n - 1}]]
}
}will be equivalent to:
proc ack {m n} {
while 1 {
if {$m == 0} {
return [expr {$n + 1}]
} elseif {$n == 0} {
lassign [list [expr {$m - 1}] 1] m n
continue
} else {
lassign [list [expr {$m - 1}] [ack $m [expr {$n - 1}]]] m n
continue
}
break
}
}This is the example in the page Sugar transformers, but with some bugfix. This new version care a bit more about indentation and does not use temp variables, but foreach to perform multi-assignment (thanks to Richard Suchenwirth for the idea).
proc tailrec_proc {name arglist body} {
# Convert the script into a Tcl list
set l [sugar::scriptToList $body]
# Convert tail calls
set l [tailrec_convert_calls $name $arglist $l]
# Add the final break
lappend l [list {TOK break} {EOL "\n"}]
# Convert it back to script
set body [sugar::listToScript $l]
# Add the surrounding while 1
set body "while 1 {$body}"
# Call [proc]
uplevel proc [list $name $arglist $body]
}
# Convert tail calls. Helper for tailrec_proc.
# Recursively call itself on [if] script arguments.
proc tailrec_convert_calls {name arglist code} {
# Search the last non-null command.
set lastidx -1
for {set j 0} {$j < [llength $code]} {incr j} {
set cmd [lindex $code $j]
if {[sugar::indexbytype $cmd TOK 0] != -1} {
set lastidx $j
set cmdidx [sugar::indexbytype $cmd TOK 0]
}
}
if {$lastidx == -1} {
return $code
}
set cmd [lindex $code $lastidx]
set cmdname [lindex $cmd $cmdidx 1]
if {[lindex $cmd 0 0] eq {SPACE}} {
set space [lindex $cmd 0 1]
} else {
set space " "
}
if {$cmdname eq $name} {
#puts "TAILCALL -> $cmdname"
set recargs [lrange [sugar::tokens $cmd] 1 end]
set t [list [list SPACE $space] [list TOK foreach] [list SPACE " "]]
lappend t [list TOK "\[list "]
foreach a $arglist {
lappend t [list TOK $a] [list SPACE " "]
}
lappend t [list TOK "\] "]
lappend t [list TOK "\[list "]
foreach a $recargs {
lappend t [list TOK $a] [list SPACE " "]
}
lappend t [list TOK "\] "]
lappend t [list TOK break] [list EOL "\n"]
set code [linsert $code $lastidx $t]
incr lastidx
lset code $lastidx [list [list SPACE $space] [list TOK continue] [list EOL "\n"]]
} elseif {$cmdname eq {if}} {
#puts "IF CALL"
for {set j 0} {$j < [llength $cmd]} {incr j} {
if {[lindex $cmd $j 0] ne {TOK}} continue
switch -- [lindex $cmd $j 1] {
if - elseif {
incr j 2
}
else {
incr j 1
}
default {
set script [lindex $code $lastidx $j 1]
#puts "$j -> $script"
set scriptcode [sugar::scriptToList [lindex $script 0]]
set converted [tailrec_convert_calls $name $arglist $scriptcode]
lset code $lastidx $j 1 [list [sugar::listToScript $converted]]
}
}
}
}
return $code
}Math commands as macro
Expands
[+ $a $b $c]
to
[expr {$a+$b+$c}]Performs some pre-calculation of the value at compile time when possible. For example
[+ [* [+ 1 2] 4] 1]
is expanded to
[expr 13]
and so on.
NOTE: this macro requires sugar 0.1 to be used, it's availabe for download from the Sugar page.
package require sugar
sugar::macro {+ - / *} {op args} {
for {set j 0} {$j < [llength $args]} {incr j} {
# Is the operand in the form [expr {<valid-double>}]?
# This can be translated to just <valid-double>
if {[regexp {^\[expr (.*)\]$} [lindex $args $j] => double]} {
if {[string is double -strict $double]} {
lset args $j $double
}
}
if {![string is double -strict [lindex $args $j]]} break
}
if {$j == [llength $args]} {
# The expression can be computed at compile-time?
list expr "[eval expr [join $args $op]]"
} else {
list expr "{[join $args $op]}"
}
}
sugar::proc test {} {
puts [* [+ 5 2] 4]
puts [+ 1]
}
puts [info body test]
testAMG: See tcl::mathfunc and tcl::mathop.
A/AK is using sugar for forward-compatible {*}
A/AK work above had inspired to FM a math expand syntax extension :
# word prefixed by {=} is treated as an expression : ie {=}expression is transformed in [expr {expression}]
sugar::syntaxmacro mathexpand args {
# The first thing we check: is there anything to expand?
if {[lsearch $args {{=}?*}]==-1} {
# and if there is none...
return $args
} else {
set evalCmd []
foreach token $args {
# If the arg is expanded
if {[string match {{=}?*} $token]} {
set whattoexpand [string range $token 3 end]
lappend evalCmd "\[expr {$whattoexpand}\]"
} else {
# we append a one-element [list]
# to the eval's argument list
lappend evalCmd "$token"
}
}
return $evalCmd
}
}
# test
package require Tk
sugar::proc testmathexpand {} {
set A [list {=}([winfo screenwidth .]-[winfo width .])/2 \
{=}([winfo screenheight .]-[winfo height .])/2]
return +[join $A +]
}
proc testexpr {} {
set A [list [expr {([winfo screenwidth .]-[winfo width .])/2}] \
[expr {([winfo screenheight .]-[winfo height .])/2}]]
return +[join $A +]
}
wm geom . [testmathexpand]
wm geom . [testexpr]
time {testmathexpand} 10000 ;# -> 4.7 microseconds per iteration
time {testexpr} 10000; # -> 4.7 microseconds per iterationAMG: The empty script substitution [] produces empty string, but it's not a very common idiom. In fact, this is the first time I have seen it used in practice. Profiling via time shows it to be as fast as the alternatives. In actual code, I've only ever seen "", {}, and sometimes [list] on the theory that it slightly reduces shimmering. (By the way, using [list] to construct an empty list doesn't improve performance.)