diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 36 | ||||
| -rw-r--r-- | tests/coroutine.test | 37 |
3 files changed, 55 insertions, 27 deletions
@@ -1,3 +1,9 @@ +2010-04-30 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclBasic.c (NRInterpCoroutine): Corrected handling of + * tests/coroutine.test (coroutine-6.4): arguments to deal with + trickier cases. + 2010-04-30 Miguel Sofer <msofer@users.sf.net> * tests/coroutine.test: testing coroutine arguments after [yield]: @@ -5,6 +11,9 @@ 2010-04-30 Donal K. Fellows <dkf@users.sf.net> + * generic/tclBasic.c (NRInterpCoroutine): Corrected handling of + arguments to deal with trickier cases. + * generic/tclCompCmds.c (TclCompileVariableCmd): Slightly tighter issuing of instructions. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 98dd87a..7ded8f7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.454 2010/04/30 07:56:31 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.455 2010/04/30 12:38:46 dkf Exp $ */ #include "tclInt.h" @@ -8494,7 +8494,7 @@ TclNRYieldObjCmd( iPtr->numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; + corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE), NULL, NULL, NULL); @@ -8511,8 +8511,15 @@ TclNRYieldmObjCmd( CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; int result; + if (!corPtr) { + Tcl_SetResult(interp, "yieldm can only be called in a coroutine", + TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); + return TCL_ERROR; + } + result = TclNRYieldObjCmd(clientData, interp, objc, objv); - corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; + corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; return result; } @@ -8524,7 +8531,6 @@ TclNRYieldToObjCmd( Tcl_Obj *const objv[]) { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; Tcl_Namespace *ns1Ptr; @@ -8558,7 +8564,7 @@ TclNRYieldToObjCmd( Tcl_IncrRefCount(nsObjPtr); /* - * Add the callback in the caller's env, then instruct TEBC to yield + * Add the callback in the caller's env, then instruct TEBC to yield. */ iPtr->execEnvPtr = corPtr->callerEEPtr; @@ -8578,10 +8584,12 @@ YieldToCallback( /* CoroutineData *corPtr = data[0];*/ Tcl_Obj *listPtr = data[1]; ClientData nsPtr = data[2]; - - /* yieldTo: invoke the command using tailcall tech */ TEOV_callback *cbPtr; + /* + * yieldTo: invoke the command using tailcall tech. + */ + TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL); cbPtr = TOP_CB(interp); TOP_CB(interp) = cbPtr->nextPtr; @@ -8745,15 +8753,17 @@ NRInterpCoroutine( return TCL_ERROR; } + /* + * Parse all the arguments to work out what to feed as the result of the + * [yield]. TRICKY POINT: objc==0 happens here! It occurs when a coroutine + * is deleted! + */ + switch (corPtr->nargs) { case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - switch (objc) { - case 1: + if (objc == 2) { Tcl_SetObjResult(interp, objv[1]); - /* fallthrough */ - case 0: - break; - default: + } else if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); return TCL_ERROR; } diff --git a/tests/coroutine.test b/tests/coroutine.test index 448ce4d..d563aa4 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: coroutine.test,v 1.12 2010/04/30 12:30:07 msofer Exp $ +# RCS: @(#) $Id: coroutine.test,v 1.13 2010/04/30 12:38:46 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -515,35 +515,44 @@ test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \ rename relativeLevel {} unset res } -result {0 0 0 0} - -test coroutine-6.1 {coroutine nargs} \ --body { +test coroutine-6.1 {coroutine nargs} -body { coroutine a ::apply $lambda a } -cleanup { rename a {} } -result 0 - -test coroutine-6.2 {coroutine nargs} \ --body { +test coroutine-6.2 {coroutine nargs} -body { coroutine a ::apply $lambda a a } -cleanup { rename a {} } -result 0 - -test coroutine-6.3 {coroutine nargs} \ --body { +test coroutine-6.3 {coroutine nargs} -body { coroutine a ::apply $lambda a a a } -cleanup { rename a {} -} -returnCodes error - -unset lambda - +} -returnCodes error -result {wrong # args: should be "a ?arg?"} +test coroutine-6.4 {unsupported: multi-argument yield} -body { + proc corobody {} { + set a 1 + while 1 { + set a [yield $a] + set a [::tcl::unsupported::yieldm $a] + lappend a [llength $a] + } + } + coroutine a corobody + coroutine b corobody + list [a x] [a y z] [a \{p] [a \{q r] [a] [a] [rename a {}] \ + [b ok] [rename b {}] +} -cleanup { + rename corobody {} +} -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}} + # cleanup +unset lambda ::tcltest::cleanupTests return |