summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c47
-rw-r--r--generic/tclCmdAH.c23
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclExecute.c39
-rw-r--r--generic/tclInt.h7
-rw-r--r--generic/tclNamesp.c6
6 files changed, 45 insertions, 82 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5fd559d..5b767fe 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.460 2010/08/11 23:13:50 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.461 2010/08/18 15:44:10 msofer Exp $
*/
#include "tclInt.h"
@@ -4398,13 +4398,6 @@ NRCallTEBC(
switch (type) {
case TCL_NR_BC_TYPE:
return TclExecuteByteCode(interp, data[1]);
- case TCL_NR_TAILCALL_TYPE:
- /* For tailcalls */
- Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
- return TCL_ERROR;
case TCL_NR_YIELD_TYPE:
if (iPtr->execEnvPtr->corPtr) {
Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC);
@@ -8294,14 +8287,12 @@ Tcl_NRCmdSwap(
void
TclSpliceTailcall(
Tcl_Interp *interp,
- TEOV_callback *tailcallPtr,
- int skip)
+ TEOV_callback *tailcallPtr)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
* being tailcalled. Note that we skip NRCommands marked in data[1]
- * (used by command redirectors), and we skip the first command that we
- * find if requested to do so: it corresponds to [tailcall] itself.
+ * (used by command redirectors).
*/
Interp *iPtr = (Interp *) interp;
@@ -8311,10 +8302,7 @@ TclSpliceTailcall(
restart:
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
- if (!skip) {
- break;
- }
- skip = 0;
+ break;
}
}
if (!runPtr) {
@@ -8393,9 +8381,8 @@ TclNRTailcallObjCmd(
TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
tailcallPtr = TOP_CB(interp);
TOP_CB(interp) = tailcallPtr->nextPtr;
-
- TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE),
- tailcallPtr, NULL, NULL);
+ iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+
return TCL_OK;
}
@@ -8444,6 +8431,26 @@ TclClearTailcall(
TCLNR_FREE(interp, tailcallPtr);
}
+int
+TclNRBlockTailcall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->varFramePtr->tailcallPtr) {
+ TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+ iPtr->varFramePtr->tailcallPtr = NULL;
+ result = TCL_ERROR;
+ Tcl_SetResult(interp,"tailcall called from within a catch environment",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
+ NULL);
+ }
+ return result;
+}
+
void
Tcl_NRAddCallback(
@@ -8612,7 +8619,7 @@ YieldToCallback(
cbPtr = TOP_CB(interp);
TOP_CB(interp) = cbPtr->nextPtr;
- TclSpliceTailcall(interp, cbPtr, 0);
+ TclSpliceTailcall(interp, cbPtr);
return TCL_OK;
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 6456bd5..e8a249f 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.124 2010/03/05 14:34:03 dkf Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.125 2010/08/18 15:44:12 msofer Exp $
*/
#include "tclInt.h"
@@ -290,13 +290,15 @@ TclNRCatchObjCmd(
optionVarNamePtr = objv[3];
}
+ TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
+ varNamePtr, optionVarNamePtr, NULL);
+ TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
+ NULL);
+
/*
* TIP #280. Make invoking context available to caught script.
*/
- TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
- varNamePtr, optionVarNamePtr, NULL);
-
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
}
@@ -313,19 +315,6 @@ CatchObjCmdCallback(
int rewind = iPtr->execEnvPtr->rewind;
/*
- * catch has to disable any tailcall
- */
-
- if (iPtr->varFramePtr->tailcallPtr) {
- TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
- iPtr->varFramePtr->tailcallPtr = NULL;
- result = TCL_ERROR;
- Tcl_SetResult(interp,"Tailcall called from within a catch environment",
- TCL_STATIC);
- }
-
-
- /*
* We disable catch in interpreters where the limit has been exceeded.
*/
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index e73ce73..686f508 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.125 2010/04/29 23:39:32 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.126 2010/08/18 15:44:12 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -869,8 +869,7 @@ MODULE_SCOPE Tcl_ObjCmdProc NRInterpCoroutine;
#define TCL_NR_BC_TYPE 0
#define TCL_NR_ATEXIT_TYPE 1
-#define TCL_NR_TAILCALL_TYPE 2
-#define TCL_NR_YIELD_TYPE 3
+#define TCL_NR_YIELD_TYPE 2
/*
*----------------------------------------------------------------
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 249d748..c3201a5 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.489 2010/07/19 14:10:43 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.490 2010/08/18 15:44:12 msofer Exp $
*/
#include "tclInt.h"
@@ -2851,33 +2851,6 @@ TclExecuteByteCode(
OBP = BP;
goto resumeCoroutine;
}
- case TCL_NR_TAILCALL_TYPE:
- /*
- * A request to perform a tailcall: just drop this bytecode.
- */
-
-#ifdef TCL_COMPILE_DEBUG
- if (TAUX.traceInstructions) {
- fprintf(stdout, " Tailcall request received\n");
- }
-#endif /* TCL_COMPILE_DEBUG */
- iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
-
- if (catchTop != initCatchTop) {
- TclClearTailcall(interp, param);
- iPtr->varFramePtr->tailcallPtr = NULL;
- Tcl_SetResult(interp,
- "tailcall called from within a catch environment",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
- NULL);
- pc--;
- goto gotError;
- }
- iPtr->varFramePtr->tailcallPtr = param;
- TclSpliceTailcall(interp, param, 1);
- goto abnormalReturn;
case TCL_NR_YIELD_TYPE: { /* [yield] */
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
@@ -6592,7 +6565,6 @@ TclExecuteByteCode(
returnToCaller:
if (OBP) {
BP = OBP; /* back to old bc */
- rerunCallbacks:
TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1);
NR_DATA_DIG();
@@ -6618,15 +6590,6 @@ TclExecuteByteCode(
*/
goto nonRecursiveCallSetup;
- case TCL_NR_TAILCALL_TYPE:
- TOP_CB(iPtr) = callbackPtr->nextPtr;
- TCLNR_FREE(interp, callbackPtr);
-
- Tcl_SetResult(interp,
- "tailcall cannot be invoked recursively", TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "REENTRY", NULL);
- TRESULT = TCL_ERROR;
- goto rerunCallbacks;
default:
Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3d30581..2f18375 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.479 2010/08/14 17:13:02 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.480 2010/08/18 15:44:12 msofer Exp $
*/
#ifndef _TCLINT
@@ -2759,8 +2759,9 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp,
struct TEOV_callback *tailcallPtr);
MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
- struct TEOV_callback *tailcallPtr,
- int skip);
+ struct TEOV_callback *tailcallPtr);
+MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall;
+
/*
* This structure holds the data for the various iteration callbacks used to
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 12fb46e..401eea4 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.209 2010/06/08 12:54:38 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.210 2010/08/18 15:44:13 msofer Exp $
*/
#include "tclInt.h"
@@ -391,6 +391,10 @@ Tcl_PopCallFrame(
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
+
+ if (framePtr->tailcallPtr) {
+ TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ }
}
/*
generated by cgit v0.12 at 2024-11-18 02:48:20 (GMT)