Working towards a BCCed [yield]; this doesn't work right now.

7 files changed, 104 insertions, 22 deletions

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 27720c7..5ff96fd 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -370,6 +370,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"bitxor",		ASSEM_1BYTE,	INST_BITXOR,		2,	1},
     {"concat",		ASSEM_CONCAT1,	INST_CONCAT1,		INT_MIN,1},
     {"coroName",	ASSEM_1BYTE,	INST_COROUTINE_NAME,	0,	1},
+    {"currentNamespace",ASSEM_1BYTE,	INST_NS_CURRENT,	0,	1},
     {"dictAppend",	ASSEM_LVT4,	INST_DICT_APPEND,	2,	1},
     {"dictExpand",	ASSEM_1BYTE,	INST_DICT_EXPAND,	3,	1},
     {"dictGet",		ASSEM_DICT_GET, INST_DICT_GET,		INT_MIN,1},
@@ -452,7 +453,6 @@ static const TalInstDesc TalInstructionTable[] = {
     {"neq",		ASSEM_1BYTE,	INST_NEQ,		2,	1},
     {"nop",		ASSEM_1BYTE,	INST_NOP,		0,	0},
     {"not",		ASSEM_1BYTE,	INST_LNOT,		1,	1},
-    {"nscurrent",	ASSEM_1BYTE,	INST_NS_CURRENT,	0,	1},
     {"nsupvar",		ASSEM_LVT4,	INST_NSUPVAR,		2,	1},
     {"over",		ASSEM_OVER,	INST_OVER,		INT_MIN,-1-1},
     {"pop",		ASSEM_1BYTE,	INST_POP,		1,	0},
@@ -487,6 +487,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"uplus",		ASSEM_1BYTE,	INST_UPLUS,		1,	1},
     {"upvar",		ASSEM_LVT4,	INST_UPVAR,		2,	1},
     {"variable",	ASSEM_LVT4,	INST_VARIABLE,		1,	0},
+    {"yield",		ASSEM_1BYTE,	INST_YIELD,		1,	1},
     {NULL,		0,		0,			0,	0}
 };
 
@@ -506,10 +507,10 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_PUSH_RETURN_OPTIONS,					/* 108 */
     INST_REVERSE,						/* 126 */
     INST_NOP,							/* 132 */
-    INST_NS_CURRENT,						/* 141 */
     INST_COROUTINE_NAME,					/* 142 */
-    INST_INFO_LEVEL_NUM,					/* 143 */
-    INST_RESOLVE_COMMAND					/* 145 */
+    INST_NS_CURRENT,						/* 143 */
+    INST_INFO_LEVEL_NUM,					/* 144 */
+    INST_RESOLVE_COMMAND					/* 146 */
 };
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3848d5b..ab087e6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -131,7 +131,6 @@ static Tcl_Obj *	GetCommandSource(Interp *iPtr, int objc,
 			    Tcl_Obj *const objv[], int lookup);
 static void		MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
 			    int actual, Tcl_Obj *const *objv);
-static Tcl_NRPostProc	NRCoroutineActivateCallback;
 static Tcl_NRPostProc	NRCoroutineCallerCallback;
 static Tcl_NRPostProc	NRCoroutineExitCallback;
 static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
@@ -258,7 +257,7 @@ static const CmdInfo builtInCmds[] = {
     {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	1},
     {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	1},
     {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	1},
-    {"yield",		NULL,			NULL,			TclNRYieldObjCmd,	1},
+    {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	1},
     {"yieldto",		NULL,			NULL,			TclNRYieldToObjCmd,	1},
 
     /*
@@ -8495,7 +8494,7 @@ TclNRYieldObjCmd(
     }
 
     NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
-    TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+    TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
             clientData, NULL, NULL);
     return TCL_OK;
 }
@@ -8712,7 +8711,7 @@ NRCoroutineExitCallback(
 /*
  *----------------------------------------------------------------------
  *
- * NRCoroutineActivateCallback --
+ * TclNRCoroutineActivateCallback --
  *
  *      This is the workhorse for coroutines: it implements both yield and
  *      resume.
@@ -8726,8 +8725,8 @@ NRCoroutineExitCallback(
  *----------------------------------------------------------------------
  */
 
-static int
-NRCoroutineActivateCallback(
+int
+TclNRCoroutineActivateCallback(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -8902,7 +8901,7 @@ TclNRInterpCoroutine(
         break;
     }
 
-    TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+    TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
             NULL, NULL, NULL);
     return TCL_OK;
 }
@@ -9059,7 +9058,7 @@ TclNRCoroutineObjCmd(
      * Now just resume the coroutine.
      */
 
-    TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+    TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
             NULL, NULL, NULL);
     return TCL_OK;
 }
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 8ed3a95..d7dd58e 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -2752,6 +2752,49 @@ TclCompileWhileCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileYieldCmd --
+ *
+ *	Procedure called to compile the "yield" 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 "yield" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileYieldCmd(
+    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. */
+{
+    if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
+	return TCL_ERROR;
+    }
+
+    if (parsePtr->numWords == 1) {
+	PushLiteral(envPtr, "", 0);
+    } else {
+	DefineLineInformation;	/* TIP #280 */
+	Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+	CompileWord(envPtr, valueTokenPtr, interp, 1);
+    }
+    TclEmitOpcode(INST_YIELD, envPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * PushVarName --
  *
  *	Procedure used in the compiling where pushing a variable name is
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index b331551..1924334 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -435,12 +435,18 @@ InstructionDesc const tclInstructionTable[] = {
          * indicated by the LVT index. Part of [dict with].
 	 * Stack:  ... path keyList => ... */
 
-    {"nscurrent",	 1,    +1,	  0,	{OPERAND_NONE}},
-	/* Push the name of the interpreter's current namespace as an object
-	 * on the stack. */
+    {"yield",		 1,	0,	  0,	{OPERAND_NONE}},
+	/* Makes the current coroutine yield the value at the top of the
+	 * stack, and places the response back on top of the stack when it
+	 * resumes.
+	 * Stack:  ... valueToYield => ... resumeValue */
     {"coroName",         1,    +1,	  0,	{OPERAND_NONE}},
 	/* Push the name of the interpreter's current coroutine as an object
 	 * on the stack. */
+
+    {"currentNamespace", 1,    +1,	  0,	{OPERAND_NONE}},
+	/* Push the name of the interpreter's current namespace as an object
+	 * on the stack. */
     {"infoLevelNumber",  1,    +1,	  0,	{OPERAND_NONE}},
 	/* Push the stack depth (i.e., [info level]) of the interpreter as an
 	 * object on the stack. */
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 86a0f77..fcff46c 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -681,16 +681,19 @@ typedef struct ByteCode {
 #define INST_DICT_RECOMBINE_STK		139
 #define INST_DICT_RECOMBINE_IMM		140
 
-/* For compilation of basic information operations */
-#define INST_NS_CURRENT			141
+/* For operations to do with coroutines */
+#define INST_YIELD			141
 #define INST_COROUTINE_NAME		142
-#define INST_INFO_LEVEL_NUM		143
-#define INST_INFO_LEVEL_ARGS		144
-#define INST_RESOLVE_COMMAND		145
-#define INST_TCLOO_SELF			146
+
+/* For compilation of basic information operations */
+#define INST_NS_CURRENT			143
+#define INST_INFO_LEVEL_NUM		144
+#define INST_INFO_LEVEL_ARGS		145
+#define INST_RESOLVE_COMMAND		146
+#define INST_TCLOO_SELF			147
 
 /* The last opcode */
-#define LAST_INST_OPCODE		146
+#define LAST_INST_OPCODE		147
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a24c806..30f8d77 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2332,6 +2332,32 @@ TEBCresume(
 	cleanup = 1;
 	goto processExceptionReturn;
 
+    case INST_YIELD: {
+	CoroutineData *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));
+	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+		    NULL);
+	    goto gotError;
+	}
+
+	Tcl_SetObjResult(interp, OBJ_AT_TOS);
+	TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
+		INT2PTR(0), NULL, NULL);
+
+#ifdef TCL_COMPILE_DEBUG
+	TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
+	if (traceInstructions) {
+	    fprintf(stdout, "\n");
+	}
+#endif
+	goto checkForCatch;
+    }
+
     case INST_DONE:
 	if (tosPtr > initTosPtr) {
 	    /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 448a7cd..865378e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2797,6 +2797,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
+MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
@@ -3654,6 +3655,9 @@ MODULE_SCOPE int	TclCompileVariableCmd(Tcl_Interp *interp,
 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	TclInvertOpCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,