summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2009-12-06 18:12:25 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2009-12-06 18:12:25 (GMT)
commit54bc7a4be035ab032c4311c97a7e2240fb08b0cd (patch)
treeea7e42167e177d0f7427ba36cff69c20fe35be60
parent3ae6f1e3cac2201928b801e657042f9dfc0cb481 (diff)
downloadtcl-54bc7a4be035ab032c4311c97a7e2240fb08b0cd.zip
tcl-54bc7a4be035ab032c4311c97a7e2240fb08b0cd.tar.gz
tcl-54bc7a4be035ab032c4311c97a7e2240fb08b0cd.tar.bz2
* generic/tclBasic.c: Small changes for clarity in tailcall
* generic/tclExecute.c: and coroutine code.
-rw-r--r--ChangeLog3
-rw-r--r--generic/tclBasic.c42
-rw-r--r--generic/tclExecute.c17
3 files changed, 45 insertions, 17 deletions
diff --git a/ChangeLog b/ChangeLog
index 3bb7aba..37be2a2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
2009-12-05 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclBasic.c: Small changes for clarity in tailcall
+ * generic/tclExecute.c: and coroutine code.
+
* tests/tailcall.test: remove some old unused crud; improved the
stack depth tests.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index ce330b1..0376a0a 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.411 2009/12/05 21:30:05 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.412 2009/12/06 18:12:26 msofer Exp $
*/
#include "tclInt.h"
@@ -8188,7 +8188,6 @@ TclNRTailcallObjCmd(
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- TEOV_callback *tailcallPtr;
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
@@ -8236,10 +8235,10 @@ TclNRTailcallObjCmd(
}
TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
- tailcallPtr = TOP_CB(interp);
- TOP_CB(interp) = tailcallPtr->nextPtr;
+ iPtr->varFramePtr->tailcallPtr = TOP_CB(interp);
+ TOP_CB(interp) = TOP_CB(interp)->nextPtr;
- TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE), tailcallPtr, NULL, NULL);
+ TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE), NULL, NULL, NULL);
return TCL_OK;
}
@@ -8354,8 +8353,27 @@ static const CorContext NULL_CONTEXT = {NULL, NULL, NULL, NULL};
iPtr->cmdFramePtr = (context).cmdFramePtr; \
iPtr->lineLABCPtr = (context).lineLABCPtr
-#define iPtr ((Interp *) interp)
+#define iPtr ((Interp *) interp)
+
+static int
+YieldCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = data[0];
+ Tcl_Obj *cmdPtr = data[1];
+
+ corPtr->stackLevel = NULL; /* mark suspended */
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+
+ if (cmdPtr) {
+ /* yieldTo: invoke the command, use tailcall tech */
+ }
+ return result;
+}
+
int
TclNRYieldObjCmd(
ClientData clientData,
@@ -8384,6 +8402,7 @@ TclNRYieldObjCmd(
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
+ TclNRAddCallback(interp, YieldCallback, corPtr, NULL, NULL, NULL);
TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
NULL, NULL, NULL);
return TCL_OK;
@@ -8634,7 +8653,8 @@ TclNRCoroutineObjCmd(
const char *procName;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_DString ds;
-
+ int result;
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
return TCL_ERROR;
@@ -8781,11 +8801,13 @@ TclNRCoroutineObjCmd(
iPtr->varFramePtr = iPtr->rootFramePtr;
iPtr->lookupNsPtr = iPtr->framePtr->nsPtr;
corPtr->auxNumLevels = iPtr->numLevels;
-
+
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL,NULL,NULL);
+
iPtr->evalFlags |= TCL_EVAL_REDIRECT;
- return TclNRRunCallbacks(interp,
- TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0), rootPtr, 0);
+ result = TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
+
+ return TclNRRunCallbacks(interp, result, rootPtr, 0);
}
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 404696c..6ad9043 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.448 2009/11/18 21:59:51 nijtmans Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.449 2009/12/06 18:12:26 msofer Exp $
*/
#include "tclInt.h"
@@ -1945,6 +1945,7 @@ TclExecuteByteCode(
int nested = 0;
if (!codePtr) {
+ resumeCoroutine:
/*
* Reawakening a suspended coroutine: the [yield] command
* is returning.
@@ -1989,6 +1990,9 @@ TclExecuteByteCode(
*/
codePtr = param;
+ if (!codePtr) {
+ goto resumeCoroutine;
+ }
break;
case TCL_NR_TAILCALL_TYPE: {
/*
@@ -2001,14 +2005,16 @@ TclExecuteByteCode(
}
#endif
if (catchTop != initCatchTop) {
- TclClearTailcall(interp, param);
+ TEOV_callback *tailcallPtr = iPtr->varFramePtr->tailcallPtr;
+
+ TclClearTailcall(interp, tailcallPtr);
+ iPtr->varFramePtr->tailcallPtr = NULL;
result = TCL_ERROR;
Tcl_SetResult(interp,"Tailcall called from within a catch environment",
TCL_STATIC);
pc--;
goto checkForCatch;
}
- iPtr->varFramePtr->tailcallPtr = param;
goto abnormalReturn;
}
case TCL_NR_YIELD_TYPE: { /*[yield] */
@@ -2036,15 +2042,12 @@ TclExecuteByteCode(
}
/*
- * Save our state, restore the caller's execEnv and return
+ * Save our state and return
*/
NR_DATA_BURY();
esPtr->tosPtr = tosPtr;
- corPtr->stackLevel = NULL; /* mark suspended */
iPtr->execEnvPtr->bottomPtr = bottomPtr;
-
- iPtr->execEnvPtr = corPtr->callerEEPtr;
return TCL_OK;
}
default: