diff options
author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2021-06-23 12:20:59 (GMT) |
---|---|---|
committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2021-06-23 12:20:59 (GMT) |
commit | 814c9b57aaf622f67d64bf335061ceedf51a5c40 (patch) | |
tree | 8c01ed8f3d937c1fcb96f0ffc87b0bea69ba7c34 | |
parent | d7d411426de72cbced551fa007a4e99c84d2fd0a (diff) | |
parent | 6f34bcda8f5613edbb17c22b97774e0c4317a951 (diff) | |
download | tcl-814c9b57aaf622f67d64bf335061ceedf51a5c40.zip tcl-814c9b57aaf622f67d64bf335061ceedf51a5c40.tar.gz tcl-814c9b57aaf622f67d64bf335061ceedf51a5c40.tar.bz2 |
Now really merge [bug-f9800d52bd61f240] (previous commit contains test-cases only)
-rw-r--r-- | changes | 2 | ||||
-rw-r--r-- | generic/tclBasic.c | 24 | ||||
-rw-r--r-- | generic/tclExecute.c | 1 | ||||
-rw-r--r-- | generic/tclInt.h | 5 | ||||
-rw-r--r-- | tests/coroutine.test | 12 |
5 files changed, 36 insertions, 8 deletions
@@ -9303,7 +9303,7 @@ in this changeset (new minor version) rather than bug fixes: 2020-12-07 [TIP 590] Recommend lowercase Package Names -2021-01-06 Bump to tcltest 2.5.4 +2021-01-06 Bump to tcltest 2.5.4 2021-01-15 [TIP 481] `Tcl_GetStringFromObj()` with `size_t` length parameter diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 86d7960..69194f8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4866,6 +4866,7 @@ NRCommand( int result) { Interp *iPtr = (Interp *) interp; + Tcl_Obj *listPtr; iPtr->numLevels--; @@ -4874,7 +4875,10 @@ NRCommand( */ if (data[1] && (data[1] != INT2PTR(1))) { - TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); + listPtr = (Tcl_Obj *)data[1]; + data[1] = NULL; + + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, NULL, NULL, NULL); } /* OPT ?? @@ -9449,6 +9453,7 @@ TclNRYieldToObjCmd( iPtr->execEnvPtr = corPtr->callerEEPtr; TclSetTailcall(interp, listPtr); + corPtr->yieldPtr = listPtr; iPtr->execEnvPtr = corPtr->eePtr; return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); @@ -9646,6 +9651,22 @@ TclNRCoroutineActivateCallback( */ if (corPtr->stackLevel != stackLevel) { + NRE_callback *runPtr; + + iPtr->execEnvPtr = corPtr->callerEEPtr; + if (corPtr->yieldPtr) { + for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { + if (runPtr->data[1] == corPtr->yieldPtr) { + runPtr->data[1] = NULL; + Tcl_DecrRefCount(corPtr->yieldPtr); + corPtr->yieldPtr = NULL; + break; + } + } + } + iPtr->execEnvPtr = corPtr->eePtr; + + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot yield: C stack busy", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", @@ -9661,6 +9682,7 @@ TclNRCoroutineActivateCallback( Tcl_Panic("Yield received an option which is not implemented"); } + corPtr->yieldPtr = NULL; corPtr->stackLevel = NULL; numLevels = iPtr->numLevels; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f9c2954..7e51c0d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2506,6 +2506,7 @@ TEBCresume( Tcl_IncrRefCount(valuePtr); iPtr->execEnvPtr = corPtr->callerEEPtr; TclSetTailcall(interp, valuePtr); + corPtr->yieldPtr = valuePtr; iPtr->execEnvPtr = corPtr->eePtr; yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ diff --git a/generic/tclInt.h b/generic/tclInt.h index ad9a5c1..05167b7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1496,6 +1496,11 @@ typedef struct CoroutineData { int nargs; /* Number of args required for resuming this * coroutine; -2 means "0 or 1" (default), -1 * means "any" */ + Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in + * order to reset splice point in + * TclNRCoroutineActivateCallback if the + * coroutine is busy. + */ } CoroutineData; typedef struct ExecEnv { diff --git a/tests/coroutine.test b/tests/coroutine.test index 91ca8a5..c3023f7 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -765,7 +765,7 @@ test coroutine-7.13 { variable done yield yieldto c1 - after 0 c2 + after 0 c2 vwait [namespace current]::done } [namespace current]] @@ -777,19 +777,19 @@ test coroutine-7.13 { coroutine c2 apply [list {} { variable done yield - yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]] - yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]] + yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]] + yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]] set done 1 } [namespace current]] after 0 [list [namespace which c0]] vwait [namespace current]::done return $done -} -result 1 +} -result 1 test coroutine-7.14 { - issue 5106fddd4400e5b9 + issue 5106fddd4400e5b9 failure to yieldto is not the same thing as not calling yieldto in the first place @@ -823,7 +823,7 @@ test coroutine-7.14 { rename c1 {} } return [list $done0 $done1] -} -result {failure failure} +} -result {failure failure} test coroutine-8.0.0 {coro inject executed} -body { |