# Structural code (due to DKF)
proc iota {start end} { 
    for {set i $start} {$i<=$end} {incr i} {yield $i} 
    return -code break 
} 
proc UNIQUE_NAME {} {return cor[incr ::COUNTER]} 
proc makeIota {start end} { 
    set cmd [UNIQUE_NAME] 
    coroutine $cmd apply {args {yield;tailcall {*}$args}} \
            iota $start $end 
    return $cmd 
} 

# Demonstrate usage (due to MS)
set iota_1_5 [makeIota 1 5] 
puts *[info command $iota_1_5]* 
puts --- 
while 1 { 
     set x [$iota_1_5] 
     puts $x 
} 

puts --- 
puts *[info command $iota_1_5]* 

mig@cpq:/home/CVS/tcl_SF_clean/unix$ ./tclsh /tmp/iota.tcl 
*cor1* 
--- 
1 
2 
3 
4 
5 
--- 
** 

# Experiment with coroutines
#
namespace eval ::Coroutines {
    variable vars
}

# __SaveVariables__ --
#    Procedure to save all variables visible in the current
#    procedure under that name
# Arguments:
#    None
# Result:
#    Index of next routine
# Side effect:
#    Sets an entry in the array vars
# Note:
#    Arrays are _not_ considered, they will lead to an error
#
proc ::Coroutines::__SaveVariables__ {} {
    variable vars
    upvar 1 __mode__ mode
    upvar 1 __coroutines__ coroutines

    set name [lindex [info level -1] 0]

    set vNames [uplevel 1 {info vars}]

    set varValues {}
    foreach v $vNames {
        if { ![string match "__*__" $v] } {
            lappend varValues $v [uplevel 1 [list set $v]]
        }
    }
    set vars($name) $varValues

    incr mode
    if { $mode >= [llength $coroutines] } {
        set mode 0
    }
    return $mode
}

# __RestoreVariables__ --
#    Procedure to restore all variables to their saved values in
#    the current procedure
# Arguments:
#    None
# Result:
#    None
# Side effect:
#    Sets an entry in the array vars
# Note:
#    Arrays are _not_ considered, they will lead to an error
#
proc ::Coroutines::__RestoreVariables__ {} {
    variable vars
    set name [lindex [info level -1] 0]

    if { [info exists vars($name)] } {
        foreach {v value} $vars($name) {
            uplevel 1 [list set $v $value]
        }
        uplevel 1 [list set __runthis__ 0]
    } else {
        uplevel 1 [list set __runthis__ 1]
    }
}

# cleanup, resume --
#     These are normally dummy routines
#
proc resume {} {
    # Do nothing
}
proc cleanup {body} {
    uplevel 1 $body
}

# enumFile --
#     Simple enumeration procedure for reading a file
# Arguments:
#     filename          Name of the file to read
#     proc              Name of the procedure to invoke
#                       per line
# Result:
#     None
# Side effects:
#     Whatever the procedure did
#
proc enumFile {filename proc} {

    set infile [open $filename r]

    while {[gets $infile line] >= 0 } {
        $proc $line
        resume   ;#This is the point where we yield control to the coroutines
    }
    cleanup {
        close $infile
    }
}

# A --
#     Procedure that can be used as a coroutine to B and C
# Arguments:
#     __coroutines__    List of procedures that interact
#     __mode__          Mode of working (either: continue-to-last
#                       or stop-at-first, other values private)
# Result:
#     None
# Side effects:
#     Global variables set as a means to communicate,
#     new file written
# Note:
#     All procedures use a loop. The processing continues
#     until either no procedure can do anything anymore
#     (mode=continue-to-last) or until one procedure
#     cannot continue anymore (stop-at-first, the default)
#
proc A {__coroutines__ {__mode__ {stop-at-first}}} {
    if { $__mode__ == "stop-at-first" } {
        set __rout__ 0
        while { $__rout__ != -1 } {
            set __rout__ [[lindex $__coroutines__ $__rout__] $__coroutines__ $__rout__]
        }

        foreach __rout__ $__coroutines__ {
            $__rout__ $__coroutines__ cleanup
            unset ::Coroutines::vars($__rout__)
        }
        return
    }
    if { $__mode__ == "continue-to-last" } {
        set __rout__ 0
        set __org_coroutines__ $__coroutines__
        while { [llength $__coroutines__] > 0 } {
            set __nrout__ [[lindex $__coroutines__ $__rout__] $__coroutines__ $__rout__]
            if { $__nrout__ == -1 } {
                set __coroutines__ [lreplace $__coroutines__ $__rout__ $__rout__]
                if { $__rout__ >= [llength $__coroutines__] } {
                    set __rout__ 0
                }
            } else {
                set __rout__ $__nrout__
            }
        }
        foreach __rout__ $__org_coroutines__ {
            $__rout__ $__org_coroutines__ cleanup
            unset ::Coroutines::vars($__rout__)
        }
        return
    }

    #
    # Ordinary processing
    #
    ::Coroutines::__RestoreVariables__
    if { $__mode__ == "cleanup" } {
        set __runthis__ -1
    }

    #
    # This part is derived from the actual arguments
    #
    if { $__runthis__ == 1 } {
        foreach {filename proc} {"first.txt" weaveText} {break}
    }

    if { $__runthis__ == 1 } {
        set infile [open $filename r]
    }

    #
    # Transforming while blocks is a bit tricky ...
    # I think that as they inspect the _current state_, the condition
    # does not need to change - note that this is not true for
    # for-loops and foreach-loops
    #
    # Well, except for the cleanup condition
    #
    while { $__runthis__ != -1  && [gets $infile line] >= 0 } {
        $proc $line

        # The call to resume is transformed into this:
        # resume   ;#This is the point where we yield control to the coroutines
        set __next__ [::Coroutines::__SaveVariables__]
        return $__next__
    }

    #
    # The call to cleanp is transformed into this:
    #
    if { $__runthis__ == -1 } {
        close $infile
    }
    return -1      ;# This is added
}

# B --
#     The second coroutine: merely adding lines from a file
#
proc B {__coroutines__ {__mode__ {stop-at-first}}} \
    [string map {first.txt second.txt weaveText addText} [info body A]]

# C --
#     The third coroutine: merely adding lines from a file
#
proc C {__coroutines__ {__mode__ {stop-at-first}}} \
    [string map {first.txt third.txt weaveText addText} [info body A]]


# weaveText --
#     Weave the text of various files together
# Arguments:
#     line        Line of text to be added
#
proc weaveText {line} {
    global all_lines
    global linecount

    lappend all_lines $line
    incr linecount
    puts "Line: $linecount"
    puts [join $all_lines \n]
    set all_lines {}
}

# addText --
#     Add a line of text to the "repository"
# Arguments:
#     line        Line of text to be added
#
proc addText {line} {
    global all_lines

    lappend all_lines $line
}

# To test this, call the coroutines in the right order
#
foreach {f c} {first.txt {A B C} second.txt {D F} third.txt {AA BB DD EE FF}} {
    set outfile [open $f w]
    puts $outfile [join $c \n]
    close $outfile
}

# Note the order! A should be executed last
#
set linecount 0
A {B C A}

# Now continuing until the last enumeration has stopped
#
set linecount 0
A {B C A} continue-to-last

while { $__runthis__ != -1  && ($__runtime__ == 0 || ([gets $infile line] >= 0)) } {
    $proc $line

    # The call to resume is transformed into this:
    # resume   ;#This is the point where we yield control to the coroutines
    if { $__runtime__ == 1 } { 
        set __next__ [::Coroutines::__SaveVariables__]
        return $__next__
    }
    set __runtime__ 1 
}