Attachment "3048771.patch" to
ticket [3048771fff]
added by
dgp
2010-08-22 00:13:18.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.462
diff -u -r1.462 tclBasic.c
--- generic/tclBasic.c 18 Aug 2010 22:33:26 -0000 1.462
+++ generic/tclBasic.c 21 Aug 2010 17:12:16 -0000
@@ -167,10 +167,6 @@
static void ClearTailcall(Tcl_Interp *interp,
struct TEOV_callback *tailcallPtr);
-static int SpliceTailcall(Tcl_Interp *interp,
- struct TEOV_callback *tailcallPtr,
- int skip);
-
MODULE_SCOPE const TclStubs tclStubs;
@@ -8291,30 +8287,10 @@
* FIXME NRE!
*/
-void TclRemoveTailcall(
- Tcl_Interp *interp)
-{
- TEOV_callback *runPtr, *tailcallPtr;
-
- for (runPtr = TOP_CB(interp); runPtr->nextPtr; runPtr = runPtr->nextPtr) {
- if (runPtr->nextPtr->procPtr == NRTailcallEval) {
- break;
- }
- }
- if (!runPtr->nextPtr) {
- Tcl_Panic("TclRemoveTailcall did not find a tailcall");
- }
-
- tailcallPtr = runPtr->nextPtr;
- runPtr->nextPtr = tailcallPtr->nextPtr;
- ClearTailcall(interp, tailcallPtr);
-}
-
-static int
-SpliceTailcall(
+void
+TclSpliceTailcall(
Tcl_Interp *interp,
- TEOV_callback *tailcallPtr,
- int skip)
+ TEOV_callback *tailcallPtr)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
@@ -8322,53 +8298,19 @@
* (used by command redirectors).
*/
- Interp *iPtr = (Interp *) interp;
TEOV_callback *runPtr;
- runPtr = TOP_CB(interp);
- if (skip) {
- while (runPtr && (runPtr != iPtr->varFramePtr->wherePtr)) {
- if ((runPtr->procPtr) == TclNRBlockTailcall) {
- ClearTailcall(interp, tailcallPtr);
- Tcl_SetResult(interp,"tailcall called from within a catch environment",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
- NULL);
- return TCL_ERROR;
- }
- runPtr = runPtr->nextPtr;
- }
- }
-
- restart:
- for (; runPtr; runPtr = runPtr->nextPtr) {
+ for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
break;
}
}
if (!runPtr) {
- /*
- * If we are tailcalling out of a coroutine, the splicing spot is in
- * the caller's execEnv: go find it!
- */
-
- CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
-
- if (corPtr) {
- runPtr = corPtr->callerEEPtr->callbackPtr;
- goto restart;
- }
-
- Tcl_SetResult(interp,
- "tailcall cannot find the right splicing spot: should not happen!",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "UNKNOWN", NULL);
- return TCL_ERROR;
+ Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
}
tailcallPtr->nextPtr = runPtr->nextPtr;
runPtr->nextPtr = tailcallPtr;
- return TCL_OK;
}
int
@@ -8379,18 +8321,13 @@
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *listPtr, *nsObjPtr;
- Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- Tcl_Namespace *ns1Ptr;
- TEOV_callback *tailcallPtr;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?");
return TCL_ERROR;
}
- if (!iPtr->varFramePtr->isProcCallFrame || /* is not a body */
- (iPtr->framePtr != iPtr->varFramePtr)) { /* or is upleveled */
+ if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */
Tcl_SetResult(interp,
"tailcall can only be called from a proc or lambda",
TCL_STATIC);
@@ -8398,33 +8335,45 @@
return TCL_ERROR;
}
- listPtr = Tcl_NewListObj(objc-1, objv+1);
- Tcl_IncrRefCount(listPtr);
+ /*
+ * Invocation without args just clears a scheduled tailcall; invocation
+ * with an argument replaces any previously scheduled tailcall.
+ */
- nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
- if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
- || (nsPtr != ns1Ptr)) {
- Tcl_Panic("Tailcall failed to find the proper namespace");
+ if (iPtr->varFramePtr->tailcallPtr) {
+ ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+ iPtr->varFramePtr->tailcallPtr = NULL;
}
- Tcl_IncrRefCount(nsObjPtr);
-
+
/*
* Create the callback to actually evaluate the tailcalled
- * command, then pass it to tebc so that it is stashed at the proper
- * place. Being lazy: exploit the TclNRAddCallBack macro to build the
- * callback.
+ * command, then set it in the varFrame so that PopCallFrame can use it
+ * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to
+ * build the callback.
*/
- TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
- tailcallPtr = TOP_CB(interp);
- TOP_CB(interp) = tailcallPtr->nextPtr;
+ if (objc > 1) {
+ Tcl_Obj *listPtr, *nsObjPtr;
+ Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+ Tcl_Namespace *ns1Ptr;
+ TEOV_callback *tailcallPtr;
+
+ listPtr = Tcl_NewListObj(objc-1, objv+1);
+ Tcl_IncrRefCount(listPtr);
+
+ nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
+ if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
+ || (nsPtr != ns1Ptr)) {
+ Tcl_Panic("Tailcall failed to find the proper namespace");
+ }
+ Tcl_IncrRefCount(nsObjPtr);
- if (SpliceTailcall(interp, tailcallPtr, 1) == TCL_ERROR) {
- return TCL_ERROR;
+ TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
+ tailcallPtr = TOP_CB(interp);
+ TOP_CB(interp) = tailcallPtr->nextPtr;
+ iPtr->varFramePtr->tailcallPtr = tailcallPtr;
}
-
- iPtr->varFramePtr->isProcCallFrame |= FRAME_TAILCALLING;
- return TCL_OK;
+ return TCL_RETURN;
}
int
@@ -8484,15 +8433,6 @@
TCLNR_FREE(interp, tailcallPtr);
}
-int
-TclNRBlockTailcall(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- return result;
-}
-
void
Tcl_NRAddCallback(
@@ -8661,7 +8601,7 @@
cbPtr = TOP_CB(interp);
TOP_CB(interp) = cbPtr->nextPtr;
- SpliceTailcall(interp, cbPtr, 0);
+ TclSpliceTailcall(interp, cbPtr);
return TCL_OK;
}
@@ -9042,7 +8982,6 @@
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
iPtr->lookupNsPtr = nsPtr;
TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.125
diff -u -r1.125 tclCmdAH.c
--- generic/tclCmdAH.c 18 Aug 2010 15:44:12 -0000 1.125
+++ generic/tclCmdAH.c 21 Aug 2010 17:12:16 -0000
@@ -292,8 +292,6 @@
TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
varNamePtr, optionVarNamePtr, NULL);
- TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
- NULL);
/*
* TIP #280. Make invoking context available to caught script.
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.213
diff -u -r1.213 tclCmdMZ.c
--- generic/tclCmdMZ.c 18 Aug 2010 15:54:06 -0000 1.213
+++ generic/tclCmdMZ.c 21 Aug 2010 17:12:16 -0000
@@ -4274,13 +4274,11 @@
}
/*
- * Execute the body; block tailcalling out of it.
+ * Execute the body.
*/
Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj,
(ClientData)objv, INT2PTR(objc));
- TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
- NULL);
return TclNREvalObjEx(interp, bodyObj, 0,
((Interp *) interp)->cmdFramePtr, 1);
}
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.491
diff -u -r1.491 tclExecute.c
--- generic/tclExecute.c 18 Aug 2010 22:33:27 -0000 1.491
+++ generic/tclExecute.c 21 Aug 2010 17:12:17 -0000
@@ -2901,25 +2901,6 @@
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
- /*
- * If the CallFrame is marked as tailcalling, keep tailcalling
- */
-
- if (iPtr->varFramePtr->isProcCallFrame & FRAME_TAILCALLING) {
- if (catchTop == initCatchTop) {
- goto abnormalReturn;
- }
-
- iPtr->varFramePtr->isProcCallFrame &= ~FRAME_TAILCALLING;
- TclRemoveTailcall(interp);
- Tcl_SetResult(interp,
- "tailcall called from within a catch environment",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
- pc--;
- goto gotError;
- }
-
if (iPtr->execEnvPtr->rewind) {
TRESULT = TCL_ERROR;
goto abnormalReturn;
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.481
diff -u -r1.481 tclInt.h
--- generic/tclInt.h 18 Aug 2010 22:33:27 -0000 1.481
+++ generic/tclInt.h 21 Aug 2010 17:12:17 -0000
@@ -1152,10 +1152,8 @@
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
- struct TEOV_callback *wherePtr;
- /* The top of the callback stack when this
- * frame was pushed; used to find the spot
- * where to tailcall to. */
+ struct TEOV_callback *tailcallPtr;
+ /* NULL if no tailcall is scheduled */
} CallFrame;
#define FRAME_IS_PROC 0x1
@@ -1168,8 +1166,6 @@
* field contains an Object reference that has
* been confirmed to refer to a class. Part of
* TIP#257. */
-#define FRAME_TAILCALLING 0x10 /* Flag is set while the CallFrame is winding
- * down to process a tailcall */
/*
* TIP #280
@@ -2758,10 +2754,8 @@
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
-MODULE_SCOPE void TclRemoveTailcall(Tcl_Interp *interp);
-
-MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall;
-
+MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
+ struct TEOV_callback *tailcallPtr);
/*
* This structure holds the data for the various iteration callbacks used to
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.211
diff -u -r1.211 tclNamesp.c
--- generic/tclNamesp.c 18 Aug 2010 22:33:27 -0000 1.211
+++ generic/tclNamesp.c 21 Aug 2010 17:12:18 -0000
@@ -313,18 +313,7 @@
framePtr->compiledLocals = NULL;
framePtr->clientData = NULL;
framePtr->localCachePtr = NULL;
-
- /*
- * Record the top of the callback stack, so that tailcall can identify
- * the spot where to splice the new command.
- */
-
- if (iPtr->execEnvPtr) {
- framePtr->wherePtr = TOP_CB(interp);
- } else {
- framePtr->wherePtr = NULL;
- }
-
+ framePtr->tailcallPtr = NULL;
/*
* Push the new call frame onto the interpreter's stack of procedure call
@@ -403,6 +392,10 @@
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
+
+ if (framePtr->tailcallPtr) {
+ TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ }
}
/*
Index: tests/tailcall.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/tailcall.test,v
retrieving revision 1.13
diff -u -r1.13 tailcall.test
--- tests/tailcall.test 18 Aug 2010 15:44:13 -0000 1.13
+++ tests/tailcall.test 21 Aug 2010 17:12:18 -0000
@@ -384,6 +384,20 @@
unset -nocomplain ::x
} -match glob -result *tailcall* -returnCodes error
+test tailcall-11c {tailcall and uplevel} -setup {
+ proc a {} {
+ uplevel 1 {tailcall lappend ::x 2}
+ set ::x 1
+ }
+ proc b {} {set ::x 0; a; lappend ::x 3}
+} -body {
+ list [b] $::x
+} -cleanup {
+ rename a {}
+ rename b {}
+ unset -nocomplain ::x
+} -result {{0 3 2} {0 3 2}}
+
test tailcall-12.1 {[Bug 2649975]} -setup {
proc dump {{text {}}} {
set text [uplevel 1 [list subst $text]]
@@ -545,29 +559,75 @@
1: exiting from foo's alpha
}
-test tailcall-12.3a {[Bug 2695587]} {
+test tailcall-12.3a0 {[Bug 2695587]} -body {
+ apply {{} {
+ catch [list tailcall foo]
+ }}
+} -returnCodes 1 -result {invalid command name "foo"}
+
+test tailcall-12.3a1 {[Bug 2695587]} -body {
apply {{} {
- list [catch [list tailcall foo] msg opt] $msg [errorcode $opt]
+ catch [list tailcall foo]
+ tailcall
}}
-} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+} -result {}
-test tailcall-12.3b {[Bug 2695587]} {
+test tailcall-12.3a2 {[Bug 2695587]} -body {
apply {{} {
- list [catch {tailcall foo} msg opt] $msg [errorcode $opt]
+ catch [list tailcall foo]
+ tailcall moo
}}
-} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+} -returnCodes 1 -result {invalid command name "moo"}
-test tailcall-12.3c {[Bug 3046594]} {
+test tailcall-12.3a3 {[Bug 2695587]} -body {
+ set x 0
apply {{} {
- list [[subst catch] {tailcall foo} msg opt] $msg [errorcode $opt]
+ catch [list tailcall foo]
+ tailcall lappend x 1
}}
-} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+ set x
+} -cleanup {
+ unset x
+} -result {0 1}
-test tailcall-12.3d {[Bug 3046594]} {
+test tailcall-12.3b0 {[Bug 2695587]} -body {
apply {{} {
- list [[subst catch] [list tailcall foo] msg opt] $msg [errorcode $opt]
+ set catch catch
+ $catch [list tailcall foo]
}}
-} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
+} -returnCodes 1 -result {invalid command name "foo"}
+
+test tailcall-12.3b1 {[Bug 2695587]} -body {
+ apply {{} {
+ set catch catch
+ $catch [list tailcall foo]
+ tailcall
+ }}
+} -result {}
+
+test tailcall-12.3b2 {[Bug 2695587]} -body {
+ apply {{} {
+ set catch catch
+ $catch [list tailcall foo]
+ tailcall moo
+ }}
+} -returnCodes 1 -result {invalid command name "moo"}
+
+test tailcall-12.3b3 {[Bug 2695587]} -body {
+ set x 0
+ apply {{} {
+ set catch catch
+ $catch [list tailcall foo]
+ tailcall lappend x 1
+ }}
+ set x
+} -cleanup {
+ unset x
+} -result {0 1}
+
+# MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed)
+# catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that
+# standard catch behaviour is required.
test tailcall-13.1 {tailcall and coroutine} -setup {
set lambda {i {
@@ -582,8 +642,8 @@
} -body {
coroutine moo ::apply $::lambda 0
} -cleanup {
- unset lambda
-} -result {0 0 0 0 0 0}
+ unset lambda
+} -result {0 0 0 0 0 0}
test tailcall-14.1 {directly tailcalling the tailcall command is ok} {
list [catch {
