diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 120 |
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. |