diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclBasic.c | 18 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | tests/unsupported.test | 88 |
4 files changed, 111 insertions, 6 deletions
@@ -1,3 +1,9 @@ +2008-09-28 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic.c: Fix the numLevels computations on + * generic/tclInt.h: coroutine yield/resume + * tests/unsupported.test: + 2008-09-27 Donal K. Fellows <dkf@users.sf.net> * generic/tclFileName.c (Tcl_GetBlock*FromStat): Made this work diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 42cac49..1467523 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.367 2008/09/17 00:01:48 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.368 2008/09/28 13:46:09 msofer Exp $ */ #include "tclInt.h" @@ -8113,12 +8113,15 @@ TclNRYieldObjCmd( int objc, Tcl_Obj *const objv[]) { + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + int numLevels = iPtr->numLevels; + if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); return TCL_ERROR; } - if (!iPtr->execEnvPtr->corPtr) { + if (!corPtr) { Tcl_SetResult(interp, "yield can only be called in a coroutine", TCL_STATIC); return TCL_ERROR; @@ -8128,6 +8131,9 @@ TclNRYieldObjCmd( Tcl_SetObjResult(interp, objv[1]); } + iPtr->numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; + TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE), NULL, NULL, NULL); return TCL_OK; @@ -8312,7 +8318,8 @@ NRInterpCoroutine( Tcl_Obj *const objv[]) /* Argument objects. */ { CoroutineData *corPtr = clientData; - + int nestNumLevels = corPtr->auxNumLevels; + if ((objc != 1) && (objc != 2)) { Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); return TCL_ERROR; @@ -8339,6 +8346,8 @@ NRInterpCoroutine( SAVE_CONTEXT(corPtr->caller); RESTORE_CONTEXT(corPtr->running); PlugCoroutineChains(corPtr); + corPtr->auxNumLevels = iPtr->numLevels; + iPtr->numLevels += nestNumLevels; TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, NULL); @@ -8472,7 +8481,8 @@ TclNRCoroutineObjCmd( iPtr->varFramePtr = iPtr->rootFramePtr; iPtr->lookupNsPtr = iPtr->framePtr->nsPtr; - + corPtr->auxNumLevels = iPtr->numLevels; + TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL,NULL,NULL); return TclNRRunCallbacks(interp, TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0), rootPtr, 0); diff --git a/generic/tclInt.h b/generic/tclInt.h index 0ed0192..cbb66b7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.399 2008/09/18 16:14:51 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.400 2008/09/28 13:46:11 msofer Exp $ */ #ifndef _TCLINT @@ -1342,6 +1342,9 @@ typedef struct CoroutineData { CorContext running; CorContext base; int *stackLevel; + int auxNumLevels; /* While the coroutine is running the numLevels of the + * create/resume command is stored here; for suspended + * coroutines it holds the nesting numLevels at yield*/ } CoroutineData; typedef struct ExecEnv { diff --git a/tests/unsupported.test b/tests/unsupported.test index 74f91aa..553021b 100644 --- a/tests/unsupported.test +++ b/tests/unsupported.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: unsupported.test,v 1.10 2008/09/05 01:20:01 msofer Exp $ +# RCS: @(#) $Id: unsupported.test,v 1.11 2008/09/28 13:46:12 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -835,6 +835,92 @@ test unsupported-C.4.2 {bug #2093947} -constraints {coroutine} \ unset ::res } -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}} +test unsupported-C.5.1 {right numLevels on coro return} -constraints {coroutine testnrelevels} \ +-setup { + proc nestedYield {{val {}}} { + yield $val + } + proc getNumLevel {} { + # remove the level for this proc's call + expr {[lindex [testnrelevels] 1] - 1} + } + proc relativeLevel base { + # remove the level for this proc's call + expr {[getNumLevel] - $base - 1} + } + proc foo {} { + while 1 { + nestedYield + } + } + set res {} +} -body { + set base [getNumLevel] + lappend res [relativeLevel $base] + eval {coroutine a foo} + + # back to base level + lappend res [relativeLevel $base] + a + lappend res [relativeLevel $base] + eval a + lappend res [relativeLevel $base] + eval {eval a} + lappend res [relativeLevel $base] + rename a {} + lappend res [relativeLevel $base] + set res +} -cleanup { + rename foo {} + rename nestedYield {} + rename getNumLevel {} + rename relativeLevel {} + unset res +} -result {0 0 0 0 0 0} + +test unsupported-C.5.2 {right numLevels within coro} -constraints {coroutine testnrelevels} \ +-setup { + proc nestedYield {{val {}}} { + yield $val + } + proc getNumLevel {} { + # remove the level for this proc's call + expr {[lindex [testnrelevels] 1] - 1} + } + proc relativeLevel base { + # remove the level for this proc's call + expr {[getNumLevel] - $base - 1} + } + proc foo base { + while 1 { + set base [nestedYield [relativeLevel $base]] + } + } + set res {} +} -body { + lappend res [eval {coroutine a foo [getNumLevel]}] + lappend res [a [getNumLevel]] + lappend res [eval {a [getNumLevel]}] + lappend res [eval {eval {a [getNumLevel]}}] + set base [lindex $res 0] + foreach x $res[set res {}] { + # REMARK: the first call is one level deeper due to [coroutine] being + # on the Tcl call stack: the proper result is a leading 0 and a + # sequence of -1s + lappend res [expr {$x-$base}] + } + set res +} -cleanup { + rename a {} + rename foo {} + rename nestedYield {} + rename getNumLevel {} + rename relativeLevel {} + unset res +} -result {0 -1 -1 -1} + + + # cleanup ::tcltest::cleanupTests |