Tcl Source Code

    {"try",		Tcl_TryObjCmd,		TclCompileTryCmd,	TclNRTryObjCmd,	CMD_IS_SAFE},
    {"unset",		Tcl_UnsetObjCmd,	TclCompileUnsetCmd,	NULL,	CMD_IS_SAFE},
    {"uplevel",		Tcl_UplevelObjCmd,	NULL,			TclNRUplevelObjCmd,	CMD_IS_SAFE},
    {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	CMD_IS_SAFE},
    {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	CMD_IS_SAFE},
    {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	CMD_IS_SAFE},
    {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	CMD_IS_SAFE},
    {"yieldto",		NULL,			TclCompileYieldToCmd,	TclNRYieldToObjCmd,	CMD_IS_SAFE},

    /*
     * Commands in the OS-interface. Note that many of these are unsafe.
     */

    {"after",		Tcl_AfterObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"cd",		Tcl_CdObjCmd,		NULL,			NULL,	0},

	Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);

	CompileWord(envPtr, valueTokenPtr, interp, 1);
    }
    OP(		YIELD);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileYieldToCmd --
 *
 *	Procedure called to compile the "yieldto" command.
 *
 * Results:
 *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
 *	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "yieldto" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileYieldToCmd(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
    int i;

    if (parsePtr->numWords < 2) {
	return TCL_ERROR;
    }

    OP(		NS_CURRENT);
    for (i = 1 ; i < parsePtr->numWords ; i++) {
	CompileWord(envPtr, tokenPtr, interp, i);
	tokenPtr = TokenAfter(tokenPtr);
    }
    OP4(	LIST, i);
    OP(		YIELD_TO_INVOKE);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * CompileUnaryOpCmd --
 *
 *	Utility routine to compile the unary operator commands.

	/* Call the following item on the TclOO call chain defined by class
	 * className, passing opnd arguments (min 2, max 255, *includes*
	 * "nextto" and the class name). The result of the invoked method
	 * implementation will be pushed on the stack in place of the
	 * arguments (similar to invokeStk).
	 * Stack:  ... "nextto" className arg3 arg4 -- argN => ... result */

    {"yieldToInvoke",	 1,	0,	  0,	{OPERAND_NONE}},
	/* Makes the current coroutine yield the value at the top of the
	 * stack, invoking the given command/args with resolution in the given
	 * namespace (all packed into a list), and places the list of values
	 * that are the response back on top of the stack when it resumes.
	 * Stack:  ... [list ns cmd arg1 ... argN] => ... resumeList */

    {NULL, 0, 0, 0, {OPERAND_NONE}}
};

/*
 * Prototypes for procedures defined later in this file:
 */

#define INST_STR_REPLACE		177

#define INST_ORIGIN_COMMAND		178

#define INST_TCLOO_NEXT			179
#define INST_TCLOO_NEXT_CLASS		180

#define INST_YIELD_TO_INVOKE		181

/* The last opcode */
#define LAST_INST_OPCODE		181

/*
 * Table describing the Tcl bytecode instructions: their name (for displaying
 * code), total number of code bytes required (including operand bytes), and a
 * description of the type of each operand. These operand types include signed
 * and unsigned integers of length one and four bytes. The unsigned integers
 * are used for indexes or for, e.g., the count of objects to push in a "push"

	    OBJ_AT_TOS = objResultPtr;
	    Tcl_SetObjResult(interp, objResultPtr);
	}
	cleanup = 1;
	TRACE_APPEND(("\n"));
	goto processExceptionReturn;


    {
	CoroutineData *corPtr;
	int yieldParameter;

    case INST_YIELD:
	corPtr = iPtr->execEnvPtr->corPtr;
	TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
	if (!corPtr) {
	    TRACE_APPEND(("ERROR: yield outside coroutine\n"));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "yield can only be called in a coroutine", -1));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
		    NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    if (traceInstructions) {
		TRACE_APPEND(("YIELD...\n"));
	    } else {
		fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
			Tcl_GetString(OBJ_AT_TOS));
	    }
	    fflush(stdout);
	}
#endif
	yieldParameter = 0;
	Tcl_SetObjResult(interp, OBJ_AT_TOS);
	goto doYield;

    case INST_YIELD_TO_INVOKE:
	corPtr = iPtr->execEnvPtr->corPtr;
	valuePtr = OBJ_AT_TOS;
	if (!corPtr) {
	    TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
		    O2S(valuePtr)));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "yieldto can only be called in a coroutine", -1));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
		    NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG
	if (tclTraceExec >= 2) {
	    if (traceInstructions) {
		TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
	    } else {
		/* FIXME: What is the right thing to trace? */
		fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
			Tcl_GetString(valuePtr));
	    }
	    fflush(stdout);
	}
#endif

	/*
	 * Install a tailcall record in the caller and continue with the
	 * yield. The yield is switched into multi-return mode (via the
	 * 'yieldParameter').
	 */

	Tcl_IncrRefCount(valuePtr);
	iPtr->execEnvPtr = corPtr->callerEEPtr;
	TclSetTailcall(interp, valuePtr);
	iPtr->execEnvPtr = corPtr->eePtr;
	yieldParameter = (PTR2INT(NULL)+1);	/*==CORO_ACTIVATE_YIELDM*/

    doYield:
	/* TIP #280: Record the last piece of info needed by
	 * 'TclGetSrcInfoForPc', and push the frame.
	 */
	
	bcFramePtr->data.tebc.pc = (char *) pc;
	iPtr->cmdFramePtr = bcFramePtr;

	if (iPtr->flags & INTERP_DEBUG_FRAME) {
	    ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
	}

	pc++;
	cleanup = 1;
	TEBC_YIELD();


	TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
		INT2PTR(yieldParameter), NULL, NULL);

	return TCL_OK;
    }

    case INST_TAILCALL: {
	Tcl_Obj *listPtr, *nsObjPtr;

	opnd = TclGetUInt1AtPtr(pc+1);

	if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
	    TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "tailcall can only be called from a proc or lambda", -1));
	    DECACHE_STACK_INFO();
	    Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

#ifdef TCL_COMPILE_DEBUG
	/* FIXME: What is the right thing to trace? */
	{
	    register int i;

	    TRACE(("%d [", opnd));
	    for (i=opnd-1 ; i>=0 ; i--) {
		TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
		if (i > 0) {

			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileWhileCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileYieldCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileYieldToCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileBasic0ArgCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclCompileBasic1ArgCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);