summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2010-04-30 12:38:46 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2010-04-30 12:38:46 (GMT)
commitd2d4b3a013a2e128e8f977d132e913770c62db64 (patch)
treeefaacdc6f06b38464783989ab7e86c5c3f2fdf71
parent3e01004a237b5bdd39420d316a5be37c2c8215b8 (diff)
downloadtcl-d2d4b3a013a2e128e8f977d132e913770c62db64.zip
tcl-d2d4b3a013a2e128e8f977d132e913770c62db64.tar.gz
tcl-d2d4b3a013a2e128e8f977d132e913770c62db64.tar.bz2
Fix the problems I introduced inadvertently:
* generic/tclBasic.c (NRInterpCoroutine): Corrected handling of * tests/coroutine.test (coroutine-6.4): arguments to deal with trickier cases.
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclBasic.c36
-rw-r--r--tests/coroutine.test37
3 files changed, 55 insertions, 27 deletions
diff --git a/ChangeLog b/ChangeLog
index 5c99f01..a358a5d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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