summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2008-09-28 13:46:07 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2008-09-28 13:46:07 (GMT)
commitf382ac98486d875787dc6b708fc22216a0246c48 (patch)
tree7a8011640225ca882d24e02ebed95a70dbb5b3fb
parent0f26317d580254d922cc16f4e5586bce2c2d0a31 (diff)
downloadtcl-f382ac98486d875787dc6b708fc22216a0246c48.zip
tcl-f382ac98486d875787dc6b708fc22216a0246c48.tar.gz
tcl-f382ac98486d875787dc6b708fc22216a0246c48.tar.bz2
* generic/tclBasic.c: Fix the numLevels computations on
* generic/tclInt.h: coroutine yield/resume * tests/unsupported.test:
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclBasic.c18
-rw-r--r--generic/tclInt.h5
-rw-r--r--tests/unsupported.test88
4 files changed, 111 insertions, 6 deletions
diff --git a/ChangeLog b/ChangeLog
index 4c2e048..9684e95 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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