Version 14 of Coroutines for cooperative multitasking

Here are some worked examples taken pretty directly from the Lua paper on coroutines.

Just to express my appreciation -- having this stuff in Tcl is sweet -- Thanks JBR.

The main feature missing here is a graceful way to exit the multitasking control structure. For now I return and catch an error from the coroutine, I welcome any improvements along the return -code lines.

 #!/home/john/bin/tclsh8.6a2
 #

 namespace path ::tcl::unsupported

A list of the procs that will be cooperativly multitasked

 set Tasks {}

A proc to create the coroutines and place them on the Tasks list

 proc Task { tag proc args } {
    lappend ::Tasks $tag
    coroutine $tag $proc {*}$args
 }

A proc to get them off when they exit.

 proc Drop { task } {
    set here [lsearch $::Tasks $task]
    set ::Tasks [lreplace $::Tasks $here $here]
 }

Here is our first control structure. Simply run the tasks in order as independent tasks. There is no communication between them. Tasks can add new tasks or exit. When all tasks exit RoundRobin exits.

 proc RoundRobin {} {
    while { [llength $::Tasks] } {
        foreach task $::Tasks {
            if { [catch { $task } reply] } {
                Drop $task
            }
        }
    }
 }

 proc proc-outp { args } {
    yield
    foreach item $args {
        puts $item
        yield
    }
    error "Task done"
 }

 Task A proc-outp 1 2 3 4
 Task B proc-outp A B C D

 RoundRobin

ZB Just checked, that without that first "yield" in "proc-outp" there will be execution immediately after "tagging" ("coroutine A ..."). Why is that? Is it a bug in implementation? Or perhaps coroutine A proc-outp 1 2 3 4 counts as first call, not just "tagging" (in the sense of some kind of "declaration"); is it right?

Does there exist more detailed docs? Nothing about this in b1 documentation.

NEM I'm not sure where the man-page is hiding. The TIP [L1 ] describes the behaviour:

coroutine evaluates the Tcl command

uplevel #0 [list cmd ?arg ...?]

until it returns or a yield is encountered. If yield is found then a command named coroCmdName will be created with special behaviour as described below.

So yes, the call to coroutine does indeed immediately start it. You should consider it to be roughly equivalent to uplevel #0 with the special yield behaviour.

Now we chain the tasks together in order. The yield value of the previous task is passed to the next. This allows "pipeline" type control. The yeild values are transformed as they pass through the chain of procs.

 proc Pipeline {} {
    while { [llength $::Tasks] } {
        set reply {}
        foreach task $::Tasks {
            if { [catch { set reply [$task $reply] } reply] } {
                set ::Tasks {}
                break
            }
        }
    }
 }

 proc proc-enum { args } {
    yield
    foreach item $args {
        yield $item
    }
    error "Task done"
 }
 proc proc-pair { args } {
    set input [yield]
    foreach item $args {
        set input [yield [list $item $input]]
    }
 }
 proc proc-puts { prefix } {
    while { 1 } { puts "$prefix [yield]" }
 }

 Task A proc-enum 1 2 3 4
 Task B proc-pair A B C D
 Task C proc-puts "Result :"

 Pipeline

ZB What exactly is the meaning of expressions: "set input [yield\]" and "set input [yield [list $item $input\]\]"?

Finally we have a set of cooperating procs. They all know about each other and pass control explicitly among themselves. This is done using the coroutine names as tags, as described in the Lua coroutine paper (cite??) and passing a list as the value of yield.

 proc Cooperate {} {
    set next  [lindex $::Tasks 0]
    set arg  {}
    while { 1 } {
        if { [catch {
            foreach { next arg } [$next $arg] {}
        } reply] } {
                set ::Tasks {}
                break
        }
    }
 }

 proc proc-tag-pick { args } {
    yield
    foreach item $args {
        if { $item % 2 } { yield [list Odd  $item]
        } else           { yield [list Even $item] }
    }
    error "Task done"
 }
 proc proc-tag-cati { args } {
    set input [yield]
    while { 1 } {
        set input [yield [list D [list $args $input]]]
    }
 }
 proc proc-tag-puts { prefix } {
    set input [yield]
    while { 1 } {
        puts "$prefix $input"
        set input [yield A]
    }
 }

 Task A   proc-tag-pick 1 2 3 4
 Task Even proc-tag-cati Even
 Task Odd  proc-tag-cati Odd
 Task D    proc-tag-puts "Result :"

 Cooperate

DKF: We can conflate the definition and the task creation like this:

 proc Task {name arguments body args} {
    lappend ::Tasks $name
    set ns [uplevel 1 namespace current]
    coroutine $name apply [list $arguments $body $ns] {*}$args
 }

which allows us to do something like this (with the Cooperate from above):

 Task A { args } {
    yield
    foreach item $args {
        if { $item % 2 } {
           yield [list Odd  $item]
        } else {
           yield [list Even $item]
        }
    }
    error "Task done"
 } 1 2 3 4
 Task Even { args } {
    set input [yield]
    while { 1 } {
        set input [yield [list D [list $args $input]]]
    }
 } Even
 Task Odd { args } {
    set input [yield]
    while { 1 } {
        set input [yield [list D [list $args $input]]]
    }
 } Odd
 Task D { prefix } {
    set input [yield]
    while { 1 } {
        puts "$prefix $input"
        set input [yield A]
    }
 } "Result :"

 Cooperate