summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c120
1 files changed, 74 insertions, 46 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index c07fa70..e09ea1e 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -258,6 +258,7 @@ static const CmdInfo builtInCmds[] = {
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1},
{"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1},
{"yield", NULL, NULL, TclNRYieldObjCmd, 1},
+ {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
@@ -830,13 +831,9 @@ Tcl_CreateInterp(void)
TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
- Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
- TclNRYieldToObjCmd, NULL, NULL);
- Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL,
- TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL);
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
NRCoroInjectObjCmd, NULL, NULL);
-
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
@@ -3127,8 +3124,8 @@ Tcl_DeleteCommandFromToken(
* from a CmdName Tcl object in some ByteCode code sequence. In that case,
* delay the cleanup until all references are either discarded (when a
* ByteCode is freed) or replaced by a new reference (when a cached
- * CmdName Command reference is found to be invalid and TclNRExecuteByteCode
- * looks up the command in the command hashtable).
+ * CmdName Command reference is found to be invalid and
+ * TclNRExecuteByteCode looks up the command in the command hashtable).
*/
TclCleanupCommandMacro(cmdPtr);
@@ -4317,7 +4314,7 @@ TclNREvalObjv(
return TCL_OK;
} else {
return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
- }
+ }
}
void
@@ -8347,7 +8344,7 @@ TclNRTailcallObjCmd(
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
NRE_callback *tailcallPtr;
-
+
listPtr = Tcl_NewListObj(objc-1, objv+1);
Tcl_IncrRefCount(listPtr);
@@ -8358,7 +8355,8 @@ TclNRTailcallObjCmd(
}
Tcl_IncrRefCount(nsObjPtr);
- TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
+ TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr,
+ NULL, NULL);
tailcallPtr = TOP_CB(interp);
TOP_CB(interp) = tailcallPtr->nextPtr;
iPtr->varFramePtr->tailcallPtr = tailcallPtr;
@@ -8388,7 +8386,7 @@ NRTailcallEval(
* Tailcall execution was preempted, eg by an intervening catch or by
* a now-gone namespace: cleanup and return.
*/
-
+
TailcallCleanup(data, interp, result);
return result;
}
@@ -8471,6 +8469,7 @@ TclNRYieldObjCmd(
Tcl_Obj *const objv[])
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
return TCL_ERROR;
@@ -8511,7 +8510,7 @@ TclNRYieldToObjCmd(
}
if (!corPtr) {
- Tcl_SetResult(interp, "yieldTo can only be called in a coroutine",
+ Tcl_SetResult(interp, "yieldto can only be called in a coroutine",
TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
return TCL_ERROR;
@@ -8529,7 +8528,7 @@ TclNRYieldToObjCmd(
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
- Tcl_Panic("yieldTo failed to find the proper namespace");
+ Tcl_Panic("yieldto failed to find the proper namespace");
}
Tcl_IncrRefCount(nsObjPtr);
@@ -8542,7 +8541,7 @@ TclNRYieldToObjCmd(
NULL);
iPtr->execEnvPtr = corPtr->eePtr;
- return TclNRYieldObjCmd(clientData, interp, 1, objv);
+ return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
static int
@@ -8640,7 +8639,7 @@ NRCoroutineCallerCallback(
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
-
+
if (cmdPtr->flags & CMD_IS_DELETED) {
/*
* The command was deleted while it was running: wind down the
@@ -8702,16 +8701,21 @@ NRCoroutineExitCallback(
return result;
}
-
/*
+ *----------------------------------------------------------------------
+ *
* NRCoroutineActivateCallback --
*
- * This is the workhorse for coroutines: it implements both yield and resume.
+ * This is the workhorse for coroutines: it implements both yield and
+ * resume.
*
- * It is important that both be implemented in the same callback: the
- * detection of the impossibility to suspend due to a busy C-stack relies on
- * the precise position of a local variable in the stack. We do not want the
- * compiler to play tricks on us, either by moving things around or inlining.
+ * It is important that both be implemented in the same callback: the
+ * detection of the impossibility to suspend due to a busy C-stack relies
+ * on the precise position of a local variable in the stack. We do not
+ * want the compiler to play tricks on us, either by moving things around
+ * or inlining.
+ *
+ *----------------------------------------------------------------------
*/
static int
@@ -8728,18 +8732,18 @@ NRCoroutineActivateCallback(
if (!corPtr->stackLevel) {
/*
* -- Coroutine is suspended --
- * Push the callback to restore the caller's context on yield or return
+ * Push the callback to restore the caller's context on yield or
+ * return.
*/
- TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL,
- NULL);
+ TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
+ NULL, NULL, NULL);
/*
* Record the stackLevel at which the resume is happening, then swap
- * the interp's environment to make it suitable to run this
- * coroutine.
+ * the interp's environment to make it suitable to run this coroutine.
*/
-
+
corPtr->stackLevel = stackLevel;
numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = iPtr->numLevels;
@@ -8749,8 +8753,6 @@ NRCoroutineActivateCallback(
RESTORE_CONTEXT(corPtr->running);
iPtr->execEnvPtr = corPtr->eePtr;
iPtr->numLevels += numLevels;
-
- return TCL_OK;
} else {
/*
* Coroutine is active: yield
@@ -8763,15 +8765,15 @@ NRCoroutineActivateCallback(
NULL);
return TCL_ERROR;
}
-
- if (type == CORO_ACTIVATE_YIELD) {
+
+ if (type == CORO_ACTIVATE_YIELD) {
corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
} else if (type == CORO_ACTIVATE_YIELDM) {
corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY;
} else {
Tcl_Panic("Yield received an option which is not implemented");
}
-
+
corPtr->stackLevel = NULL;
numLevels = iPtr->numLevels;
@@ -8779,10 +8781,20 @@ NRCoroutineActivateCallback(
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
iPtr->execEnvPtr = corPtr->callerEEPtr;
- return TCL_OK;
}
+
+ return TCL_OK;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * NRCoroInjectObjCmd --
+ *
+ * Implementation of [::tcl::unsupported::inject] command.
+ *
+ *----------------------------------------------------------------------
+ */
static int
NRCoroInjectObjCmd(
@@ -8794,7 +8806,7 @@ NRCoroInjectObjCmd(
Command *cmdPtr;
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
-
+
/*
* Usage more or less like tailcall:
* inject coroName cmd ?arg1 arg2 ...?
@@ -8807,25 +8819,30 @@ NRCoroInjectObjCmd(
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
if ((!cmdPtr) || (cmdPtr->nreProc != NRInterpCoroutine)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a coroutine", -1));
+ Tcl_AppendResult(interp, "can only inject a command into a coroutine",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+ TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
- corPtr = (CoroutineData *) cmdPtr->objClientData;
+ corPtr = cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a suspended coroutine", -1));
+ Tcl_AppendResult(interp,
+ "can only inject a command into a suspended coroutine", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
return TCL_ERROR;
}
/*
* Add the callback to the coro's execEnv, so that it is the first thing
- * to happen when the coro is resumed
+ * to happen when the coro is resumed.
*/
-
+
iPtr->execEnvPtr = corPtr->eePtr;
- Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
+ TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN);
iPtr->execEnvPtr = savedEEPtr;
-
+
return TCL_OK;
}
@@ -8882,6 +8899,17 @@ NRInterpCoroutine(
return TCL_OK;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNRCoroutineObjCmd --
+ *
+ * Implementation of [coroutine] command; see documentation for
+ * description of what this does.
+ *
+ *----------------------------------------------------------------------
+ */
+
int
TclNRCoroutineObjCmd(
ClientData dummy, /* Not used. */
@@ -8895,7 +8923,7 @@ TclNRCoroutineObjCmd(
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_DString ds;
Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
-
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
return TCL_ERROR;
@@ -8991,16 +9019,16 @@ TclNRCoroutineObjCmd(
corPtr->stackLevel = NULL;
corPtr->auxNumLevels = 0;
iPtr->numLevels--;
-
+
/*
* Create the coro's execEnv, switch to it to push the exit and coro
- * command callbacks, then switch back.
+ * command callbacks, then switch back.
*/
corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE);
corPtr->callerEEPtr = iPtr->execEnvPtr;
corPtr->eePtr->corPtr = corPtr;
-
+
SAVE_CONTEXT(corPtr->caller);
corPtr->callerEEPtr = iPtr->execEnvPtr;
RESTORE_CONTEXT(corPtr->running);
@@ -9015,7 +9043,7 @@ TclNRCoroutineObjCmd(
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
iPtr->execEnvPtr = corPtr->callerEEPtr;
-
+
/*
* Now just resume the coroutine. Take care to insure that the command is
* looked up in the correct namespace.