NEM 24June2004 - as a related item, here is a little toy proc for making a foreach loop run asynchronously. Needs work to be really useful, and could benefit from some form of lambda, but somebody might find it useful as a version of the pattern used above:
proc async-foreach {var list body} {
proc async-body [list $var args] [string map [list %BODY $body] {
%BODY
if {[llength $args] > 0} { after idle [linsert $args 0 async-body] }
}]
after idle [linsert $list 0 async-body]
}And a usage example:
async-foreach item {1 2 3 4 5} { puts "Item = $item" }
vwait forever
# Produces:
# item = 1
# item = 2
# item = 3
# item = 4
# item = 5The above implementation has the following limitations:
Extensions are possible, but that needs some work
Lars H: It is perfectly possible to make do without lambdas and unique-name schemes.
proc async-foreach {vars list body {final ""}} {
if {[llength $vars] && [llength $list]} then {
foreach $vars $list {break}
set list [lrange $list [llength $vars] end]
if 1 then $body
after idle [list async-foreach $vars $list $body $final]
} else $final
}(The [if 1 then $body] rather than [eval $body] here is to have $body byte-compiled.) This form adds a second body ($final) which is evaluated after the last iteration. It also supports multiple loop variables. Example:
% async-foreach {item item2} {1 2 3 4 5} { puts "Items = ($item,$item2)" } {puts "That's all, folks!"}
Items = (1,2)
after#28
% Items = (3,4)
Items = (5,)
That's all, folks!Note the slight asynchronicity that the return value from the command (after#28, from the after command) and the following prompt are printed by the command loop between the first and second iteration of the asynch-foreach.
One problem with the above procedure is that you mustn't use the variable names vars, list, body, or final in the body. In a production environment, they should rather be given names like __vars, __list, __body, and __final to avoid unintended overwritings.
Update 2008-08-05: Revisiting this page, I came up with the following braintwister of an implementation that permits arbitrary variable names by having done all substitutions of the special variables vars, list, body, and final before the foreach:
proc async-foreach {vars list body {final ""}} {
if {[llength $vars] && [llength $list]} then {
foreach $vars $list [
set list [lrange $list [llength $vars] end]
list for $body 1 return [
list after idle [
list async-foreach $vars $list $body $final
]
]
]
} else $final
}(The body of the foreach is a for command, and the next script of that for is a return that terminates both loops.) To demonstrate that it works:
% async-foreach {vars list body final} {1 2 3 4 5 6 7} {puts "$vars $list $body $final"} {puts "That's all, folks!"}
1 2 3 4
% 5 6 7
That's all, folks!End update.
NEM Nice improvement. The reason I suggested lambda was precisely to avoid having to have specially named variables. For instance, see the absurd lengths I go to to acheive this at More functional programming. I like the "final" clause - could be useful. Here's another version which handles (I think) all the forms of foreach, allows for cleanup, and allows you to cancel a loop at any time:
namespace eval async { variable id 0; variable data }
# async::foreach --
#
# Usage: async::foreach varlist list ?varlist list...? ?-interval ms|idle? ?-finally script? body
proc async::foreach {varlist list args} {
variable id; variable data
set usage "async::foreach varlist list ?varlist list...? ?-interval ms|idle? ?-finally script? body"
if {[llength $args] < 1 || ([llength $args] % 2) != 1} {
return -code error "wrong # args: should be \"$usage\""
}
set curid [incr id]
set body [lindex $args end]
set data($curid,final) ""
set data($curid,interval) idle
set vars $varlist
set data($curid,lengths) [list [llength $varlist]]
set lists [list $list]
::foreach {key value} [lrange $args 0 end-1] {
if {$key eq "-interval"} {
set data($curid,interval) $value
} elseif {$key eq "-finally"} {
set data($curid,final) $value
} else {
eval lappend vars $key
lappend data($curid,lengths) [llength $key]
lappend lists $value
}
}
# Create a proc for this body
proc body$curid $vars $body
set data($curid,event) [after $data($curid,interval) [list ::async::do $curid $lists]]
return $curid
}
# Proc to actually run the body of the foreach
proc async::do {id lists} {
variable data
set call [list ::async::body$id]; set remainder [list]
for {set i 0} {$i < [llength $data($id,lengths)]} {incr i} {
set clist [lindex $lists $i]; set clen [lindex $data($id,lengths) $i]
eval lappend call [lrange $clist 0 [expr {$clen -1}]]
lappend remainder [lrange $clist $clen end]
}
if {[llength $call] == 1} {
# Finished
cancel $id
} else {
# Evaluate
uplevel 1 $call
set data($id,event) [after $data($id,interval) [list ::async::do $id $remainder]]
}
}
# Cancel a running loop
proc async::cancel {id} {
variable data
after cancel $data($id,event)
set final $data($id,final)
::foreach key [array names data $id,*] { unset data($key) }
rename ::async::body$id {}
# Run -finally script, if any
uplevel 1 $final
}And a usage example:
set id [async::foreach name {Neil Pete Jon} age {23 42 12} -interval 1000 -finally { puts "Done!" } {
puts "Name = $name Age = $age"
}]
after 2100 [list ::async::cancel $id]
vwait async::data($id,final)
# Produces:
# Name = Neil Age = 23
# Name = Pete Age = 42
# Done!
schlenk How about moving this async foreach into the control module of tcllib? Could help in the effort to make POP3/IMAP4/NNTP protocols in tcllib capable of async operation.
NEM OK. I've just spotted a bug though (doesn't handle the foreach a {1 2} b {1} ... case). I'll fix it up and get someone to add it in. async versions of for and while would probably be good too.
schlenk Here is an asynchronous for loop. It evaluates the start, test and next expressions in the namespace given by the -ns option.
proc async::for {start test next args} {
variable id; variable data
set usage "async::for start test next ?-interval ms|idle? ?-ns namespace? ?-finally script? body"
if {[llength $args] < 1 || ([llength $args] %2) != 1} {
return -code error "wrong # args: should be \"$usage\""
}
set curid [incr id]
set body [lindex $args end]
set data($curid,final) ""
set data($curid,interval) idle
set data($curid,test) $test
set data($curid,next) $next
set data($curid,namespace) [uplevel 1 namespace current]
::foreach {key value} [lrange $args 0 end-1] {
if {$key eq "-interval"} {
set data($curid,interval) $value
} elseif {$key eq "-finally"} {
set data($curid,final) $value
} elseif {$key eq "-ns"} {
set data($curid,namespace) $value
} else {
return -code error "wrong # args: should be \"$usage\""
}
}
proc body$curid {} $body
# evaluate start code in global scope
namespace inscope $data($curid,namespace) $start
set data($curid,event) [after $data($curid,interval) [list ::async::dofor $curid]]
return $curid
}
proc async::dofor {id} {
variable data
set call [list ::async::body$id]
set test [namespace inscope $data($id,namespace) expr $data($id,test)]
if {$test} {
namespace inscope $data($id,namespace) $data($id,next)
uplevel 1 $call
set data($id,event) [after $data($id,interval) [list ::async::dofor $id]]
} else {
cancel $id
}
}
proc async::wait {id} {
vwait ::async::data($id,final)
}And a usage example:
namespace eval ::scratch { variable i }
set id [async::for {set i 0} {$i < 100} {incr i} -ns ::scratch -interval 100 -finally {puts Done} \
{upvar 0 ::scratch::i i; puts $i}]
after 2500 [list ::async::cancel $id]
async::wait $id