summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c6
-rw-r--r--generic/tclBasic.c11
-rw-r--r--generic/tclCompCmdsSZ.c44
-rw-r--r--generic/tclCompile.c4
-rw-r--r--generic/tclCompile.h15
-rw-r--r--generic/tclExecute.c49
-rw-r--r--generic/tclInt.h4
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);
generated by cgit v0.12 at 2024-11-01 03:01:30 (GMT)