Implementation of TIP #396

4 files changed, 111 insertions, 37 deletions

diff --git a/ChangeLog b/ChangeLog
index 3f90c0e..72d3507 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,20 +1,28 @@
+2012-04-02  Donal K. Fellows  <dkf@users.sf.net>
+
+	IMPLEMENTATION OF TIP#396.
+
+	* generic/tclBasic.c (builtInCmds, TclNRYieldToObjCmd): Convert the
+	formerly-unsupported yieldm and yieldTo commands into [yieldto].
+
 2012-04-02  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclInt.decls:      [Bug 3508771] load tclreg.dll in cygwin tclsh
-	* generic/tclIntPlatDecls.h: Implement TclWinGetTclInstance, TclpGetTZName,
-	* generic/tclStubInit.c:     and various more win32-specific internal functions for
-	Cygwin, so win32 extensions using those can be loaded in the cygwin version of tclsh.
+	* generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin tclsh
+	* generic/tclIntPlatDecls.h: Implement TclWinGetTclInstance,
+	* generic/tclStubInit.c:     TclpGetTZName, and various more
+	win32-specific internal functions for Cygwin, so win32 extensions
+	using those can be loaded in the cygwin version of tclsh.
 
 2012-03-30  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* unix/tcl.m4:        [Bug 3511806] Compiler checks too early
-	* unix/configure.in:  This change allows to build the cygwin
-	* unix/tclUnixPort.h: and mingw32 ports of Tcl/Tk to build
-	* win/tcl.m4:         out-of-the-box using a native or cross-
-	* win/configure.in:   compiler.
-	* win/tclWinPort.h:   (autoconf still to be run!)
-	* win/README          Document how to build win32 or win64
-	executables with Linux, Cygwin or Darwin.
+	* unix/tcl.m4:        [Bug 3511806]: Compiler checks too early
+	* unix/configure.in:  This change allows to build the cygwin and
+	* unix/tclUnixPort.h: mingw32 ports of Tcl/Tk to build out-of-the-box
+	* win/tcl.m4:         using a native or cross-compiler.
+	* win/configure.in:
+	* win/tclWinPort.h:
+	* win/README          Document how to build win32 or win64 executables
+	with Linux, Cygwin or Darwin.
 
 2012-03-29  Jan Nijtmans  <nijtmans@users.sf.net>
 
diff --git a/doc/coroutine.n b/doc/coroutine.n
index f4b5d5b..035d58a 100644
--- a/doc/coroutine.n
+++ b/doc/coroutine.n
@@ -9,12 +9,15 @@
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
-coroutine, yield \- Create and produce values from coroutines
+coroutine, yield, yieldto \- Create and produce values from coroutines
 .SH SYNOPSIS
 .nf
 \fBcoroutine \fIname command\fR ?\fIarg...\fR?
 \fByield\fR ?\fIvalue\fR?
-\fIname\fR ?\fIvalue\fR?
+.VS TIP396
+\fByieldto\fR \fIcommand\fR ?\fIarg...\fR?
+\fIname\fR ?\fIvalue...\fR?
+.VE TIP396
 .fi
 .BE
 .SH DESCRIPTION
@@ -30,11 +33,37 @@ Within the context, values may be generated as results by using the
 When that is called, the context will suspend execution and the
 \fBcoroutine\fR command will return the argument to \fByield\fR. The execution
 of the context can then be resumed by calling the context command, optionally
-passing in the value to use as the result of the \fByield\fR call that caused
+passing in the \fIsingle\fR value to use as the result of the \fByield\fR call
+that caused
 the context to be suspended. If the coroutine context never yields and instead
 returns conventionally, the result of the \fBcoroutine\fR command will be the
 result of the evaluation of the context.
 .PP
+.VS TIP396
+The coroutine may also suspend its execution by use of the \fByieldto\fR
+command, which instead of returning, cedes execution to some command called
+\fIcommand\fR (resolved in the context of the coroutine) and to which \fIany
+number\fR of arguments may be passed. Since every coroutine has a context
+command, \fByieldto\fR can be used to transfer control directly from one
+coroutine to another (this is only advisable if the two coroutines are
+expecting this to happen) but \fIany\fR command may be the target. If a
+coroutine is suspended by this mechanism, the coroutine processing can be
+resumed by calling the context command optionally passing in an arbitrary
+number of arguments. The return value of the \fByieldto\fR call will be the
+list of arguments passed to the context command; it is up to the caller to
+decide what to do with those values.
+.PP
+The recommended way of writing a version of \fByield\fR that allows resumption
+with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR
+command, like this:
+.PP
+.CS
+proc yieldm {value} {
+    \fByieldto\fR return -level 0 $value
+}
+.CE
+.VE TIP396
+.PP
 The coroutine can also be deleted by destroying the command \fIname\fR, and
 the name of the current coroutine can be retrieved by using
 \fBinfo coroutine\fR.
@@ -108,6 +137,27 @@ for {set i 1} {$i <= 20} {incr i} {
     puts "prime#$i = [\fIeratosthenes\fR]"
 }
 .CE
+.PP
+.VS TIP396
+This example shows how a value can be passed around a group of three
+coroutines that yield to each other:
+.PP
+.CS
+proc juggler {name target {value ""}} {
+    if {$value eq ""} {
+        set value [\fByield\fR [info coroutine]]
+    }
+    while {$value ne ""} {
+        puts "$name : $value"
+        set value [string range $value 0 end-1]
+        lassign [\fByieldto\fR $target $value] value
+    }
+}
+\fBcoroutine\fR j1 juggler Larry [
+    \fBcoroutine\fR j2 juggler Curly [
+        \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!"
+.CE
+.VE TIP396
 .SS "DETAILED SEMANTICS"
 .PP
 This example demonstrates that coroutines start from the global namespace, and
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index c07fa70..280290c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -258,6 +258,7 @@ static const CmdInfo builtInCmds[] = {
     {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	1},
     {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	1},
     {"yield",		NULL,			NULL,			TclNRYieldObjCmd,	1},
+    {"yieldto",		NULL,			NULL,			TclNRYieldToObjCmd,	1},
 
     /*
      * Commands in the OS-interface. Note that many of these are unsafe.
@@ -830,10 +831,6 @@ Tcl_CreateInterp(void)
             TclNRAssembleObjCmd, NULL, NULL);
     cmdPtr->compileProc = &TclCompileAssembleCmd;
 
-    Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
-	    TclNRYieldToObjCmd, NULL, NULL);
-    Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL,
-	    TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL);
     Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
 	    NRCoroInjectObjCmd, NULL, NULL);
     
@@ -8511,7 +8508,7 @@ TclNRYieldToObjCmd(
     }
 
     if (!corPtr) {
-	Tcl_SetResult(interp, "yieldTo can only be called in a coroutine",
+	Tcl_SetResult(interp, "yieldto can only be called in a coroutine",
 		TCL_STATIC);
 	Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
 	return TCL_ERROR;
@@ -8529,7 +8526,7 @@ TclNRYieldToObjCmd(
     nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
     if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
 	    || (nsPtr != ns1Ptr)) {
-	Tcl_Panic("yieldTo failed to find the proper namespace");
+	Tcl_Panic("yieldto failed to find the proper namespace");
     }
     Tcl_IncrRefCount(nsObjPtr);
 
@@ -8542,7 +8539,7 @@ TclNRYieldToObjCmd(
 	    NULL);
     iPtr->execEnvPtr = corPtr->eePtr;
 
-    return TclNRYieldObjCmd(clientData, interp, 1, objv);
+    return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
 }
 
 static int
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 7d5169b..7f40a7b 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -557,12 +557,25 @@ test coroutine-6.3 {coroutine nargs} -body {
 } -cleanup {
     rename a {}
 } -returnCodes error -result {wrong # args: should be "a ?arg?"}
-test coroutine-6.4 {unsupported: multi-argument yield} -body {
+
+test coroutine-7.1 {yieldto} -body {
+    coroutine c apply {{} {
+	yield
+	yieldto return -level 0 -code 1 quux
+	return quuy
+    }}
+    set res [list [catch c msg] $msg]
+    lappend res [catch c msg] $msg
+    lappend res [catch c msg] $msg
+} -cleanup {
+    unset res
+} -result [list 1 quux 0 quuy 1 {invalid command name "c"}]
+test coroutine-7.2 {multi-argument yielding with yieldto} -body {
     proc corobody {} {
 	set a 1
 	while 1 {
 	    set a [yield $a]
-	    set a [::tcl::unsupported::yieldm $a]
+	    set a [yieldto return -level 0 $a]
 	    lappend a [llength $a]
 	}
     }
@@ -573,20 +586,26 @@ test coroutine-6.4 {unsupported: multi-argument yield} -body {
 } -cleanup {
     rename corobody {}
 } -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}}
-
-test coroutine-7.1 {yieldTo} -body {
-    coroutine c apply {{} {
-	yield
-	tcl::unsupported::yieldTo return -level 0 -code 1 quux
-	return quuy
-    }}
-    set res [list [catch c msg] $msg]
-    lappend res [catch c msg] $msg
-    lappend res [catch c msg] $msg
+test coroutine-7.3 {yielding between coroutines} -body {
+    proc juggler {target {value ""}} {
+	if {$value eq ""} {
+	    set value [yield [info coroutine]]
+	}
+	while {[llength $value]} {
+	    lappend ::result $value [info coroutine]
+	    set value [lrange $value 0 end-1]
+	    lassign [yieldto $target $value] value
+	}
+	# Clear nested collection of coroutines
+	catch $target
+    }
+    set result ""
+    coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\
+	{a b c d e}
+    list $result [info command j1] [info command j2] [info command j3]
 } -cleanup {
-    unset res
-} -result [list 1 quux 0 quuy 1 {invalid command name "c"}]
-
+    catch {rename juggler ""}
+} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
 
 # cleanup
 unset lambda