Added compilation of [tailcall]. Not a particularly efficient compilation though; it does not detect tailcall-of-self as a special case.

7 files changed, 117 insertions, 16 deletions

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index eacaafe..f5f2469 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -514,9 +514,9 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_STR_MAP,						/* 143 */
     INST_STR_FIND,						/* 144 */
     INST_COROUTINE_NAME,					/* 147 */
-    INST_NS_CURRENT,						/* 148 */
-    INST_INFO_LEVEL_NUM,					/* 149 */
-    INST_RESOLVE_COMMAND					/* 151 */
+    INST_NS_CURRENT,						/* 149 */
+    INST_INFO_LEVEL_NUM,					/* 150 */
+    INST_RESOLVE_COMMAND					/* 152 */
 };
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6e60aee..bce6479 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -136,7 +136,6 @@ static Tcl_NRPostProc	NRCoroutineExitCallback;
 static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
 
 static Tcl_NRPostProc	NRRunObjProc;
-static Tcl_NRPostProc	NRTailcallEval;
 static Tcl_ObjCmdProc	OldMathFuncProc;
 static void		OldMathFuncDeleteProc(ClientData clientData);
 static void		ProcessUnexpectedResult(Tcl_Interp *interp,
@@ -248,7 +247,7 @@ static const CmdInfo builtInCmds[] = {
     {"split",		Tcl_SplitObjCmd,	NULL,			NULL,	1},
     {"subst",		Tcl_SubstObjCmd,	TclCompileSubstCmd,	TclNRSubstObjCmd,	1},
     {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	TclNRSwitchObjCmd, 1},
-    {"tailcall",	NULL,			NULL,			TclNRTailcallObjCmd,	1},
+    {"tailcall",	NULL,			TclCompileTailcallCmd,	TclNRTailcallObjCmd,	1},
     {"throw",		Tcl_ThrowObjCmd,	TclCompileThrowCmd,	NULL,	1},
     {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	1},
     {"try",		Tcl_TryObjCmd,		TclCompileTryCmd,	TclNRTryObjCmd,	1},
@@ -8322,7 +8321,7 @@ TclNRTailcallObjCmd(
 	return TCL_ERROR;
     }
 
-    if (!iPtr->varFramePtr->isProcCallFrame) {	/* or is upleveled */
+    if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {	/* or is upleveled */
         Tcl_SetObjResult(interp, Tcl_NewStringObj(
                 "tailcall can only be called from a proc or lambda", -1));
         Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
@@ -8362,7 +8361,7 @@ TclNRTailcallObjCmd(
         }
         Tcl_IncrRefCount(nsObjPtr);
 
-        TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr,
+        TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
                 NULL, NULL);
         tailcallPtr = TOP_CB(interp);
         TOP_CB(interp) = tailcallPtr->nextPtr;
@@ -8372,7 +8371,7 @@ TclNRTailcallObjCmd(
 }
 
 int
-NRTailcallEval(
+TclNRTailcallEval(
     ClientData data[],
     Tcl_Interp *interp,
     int result)
@@ -8566,7 +8565,7 @@ YieldToCallback(
      * yieldTo: invoke the command using tailcall tech.
      */
 
-    TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL);
+    TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL);
     cbPtr = TOP_CB(interp);
     TOP_CB(interp) = cbPtr->nextPtr;
 
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 12396fe..57cb992 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -1987,6 +1987,50 @@ PrintJumptableInfo(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileTailcallCmd --
+ *
+ *	Procedure called to compile the "tailcall" 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 "tailcall" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileTailcallCmd(
+    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 = parsePtr->tokenPtr;
+    int i;
+
+    if (parsePtr->numWords < 2 || parsePtr->numWords > 256
+	    || envPtr->procPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    for (i=1 ; i<parsePtr->numWords ; i++) {
+	tokenPtr = TokenAfter(tokenPtr);
+	CompileWord(envPtr, tokenPtr, interp, i);
+    }
+    TclEmitInstInt1(	INST_TAILCALL, parsePtr->numWords-1,	envPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileThrowCmd --
  *
  *	Procedure called to compile the "throw" command.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index f979fa3..ee8511c 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -464,6 +464,10 @@ InstructionDesc const tclInstructionTable[] = {
     {"coroName",         1,    +1,	  0,	{OPERAND_NONE}},
 	/* Push the name of the interpreter's current coroutine as an object
 	 * on the stack. */
+    {"tailcall",	 2,    INT_MIN,	  1,	{OPERAND_UINT1}},
+	/* Do a tailcall with the opnd items on the stack as the thing to
+	 * tailcall to; opnd must be greater than 0 for the semantics to work
+	 * right. */
 
     {"currentNamespace", 1,    +1,	  0,	{OPERAND_NONE}},
 	/* Push the name of the interpreter's current namespace as an object
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 85d282f..08d59fd 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -688,19 +688,20 @@ typedef struct ByteCode {
 #define INST_STR_FIND			144
 #define INST_STR_RANGE_IMM		145
 
-/* For operations to do with coroutines */
+/* For operations to do with coroutines and other NRE-manipulators */
 #define INST_YIELD			146
 #define INST_COROUTINE_NAME		147
+#define INST_TAILCALL			148
 
 /* For compilation of basic information operations */
-#define INST_NS_CURRENT			148
-#define INST_INFO_LEVEL_NUM		149
-#define INST_INFO_LEVEL_ARGS		150
-#define INST_RESOLVE_COMMAND		151
-#define INST_TCLOO_SELF			152
+#define INST_NS_CURRENT			149
+#define INST_INFO_LEVEL_NUM		150
+#define INST_INFO_LEVEL_ARGS		151
+#define INST_RESOLVE_COMMAND		152
+#define INST_TCLOO_SELF			153
 
 /* The last opcode */
-#define LAST_INST_OPCODE		152
+#define LAST_INST_OPCODE		153
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index bbee81d..1e24cb3 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2374,6 +2374,55 @@ TEBCresume(
 	return TCL_OK;
     }
 
+    case INST_TAILCALL: {
+	Tcl_Obj *listPtr, *nsObjPtr;
+        NRE_callback *tailcallPtr;
+
+	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));
+	    Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+	    goto gotError;
+	}
+
+#ifdef TCL_COMPILE_DEBUG
+	TRACE(("%d [", opnd));
+	for (i=opnd-1 ; i>=0 ; i++) {
+	    TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
+	    if (i > 0) {
+		TRACE_APPEND((" "));
+	    }
+	}
+	TRACE_APPEND(("] => RETURN..."));
+#endif
+
+	/*
+	 * Push the evaluation of the called command into the NR callback
+	 * stack.
+	 */
+
+	listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
+	nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
+	Tcl_IncrRefCount(listPtr);
+	Tcl_IncrRefCount(nsObjPtr);
+	TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
+		NULL, NULL);
+
+	/*
+	 * Unstitch ourselves and do a [return].
+	 */
+
+	tailcallPtr = TOP_CB(interp);
+	TOP_CB(interp) = tailcallPtr->nextPtr;
+	iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+	result = TCL_RETURN;
+	cleanup = opnd;
+	goto processExceptionReturn;
+    }
+
     case INST_DONE:
 	if (tosPtr > initTosPtr) {
 	    /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 49298b3..1fffa1f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2799,6 +2799,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
 MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
+MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
@@ -3664,6 +3665,9 @@ MODULE_SCOPE int	TclCompileSubstCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileSwitchCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileTailcallCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileThrowCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);