summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclBasic.c141
-rw-r--r--generic/tclCmdAH.c4
-rw-r--r--generic/tclCmdMZ.c6
-rw-r--r--generic/tclExecute.c21
-rw-r--r--generic/tclInt.h16
-rw-r--r--generic/tclNamesp.c19
-rw-r--r--tests/tailcall.test100
8 files changed, 136 insertions, 180 deletions
diff --git a/ChangeLog b/ChangeLog
index 3bc7ec7..8205243 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2010-08-30 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclBasic.c: New implementation for [tailcall]:
+ * generic/tclCmdAH.c: it now schedules the command and returns
+ * generic/tclCmdMZ.c: TCL_RETURN. This fixes all issues with
+ * generic/tclExecute.c: [catch] and [try] - [Bug 3046594],
+ * generic/tclInt.h: [Bug 3047235] and [Bug 3048771]. Thanks
+ * generic/tclNamesp.c: dgp for exploring the dark corners.
+ * tests/tailcall.test: More thorough testing is required.
+
2010-08-30 Jan Nijtmans <nijtmans@users.sf.net>
* win/Makefile.in: [Freq 2965056]: Windows build with -DUNICODE
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5216f96..6769211 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.463 2010/08/22 18:53:26 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.464 2010/08/30 14:02:09 msofer Exp $
*/
#include "tclInt.h"
@@ -167,10 +167,6 @@ static Tcl_NRPostProc YieldToCallback;
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 @@ Tcl_NRCmdSwap(
* 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 @@ SpliceTailcall(
* (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 @@ TclNRTailcallObjCmd(
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 @@ TclNRTailcallObjCmd(
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);
- if (SpliceTailcall(interp, tailcallPtr, 1) == TCL_ERROR) {
- return TCL_ERROR;
+ 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);
+
+ 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 @@ ClearTailcall(
TCLNR_FREE(interp, tailcallPtr);
}
-int
-TclNRBlockTailcall(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- return result;
-}
-
void
Tcl_NRAddCallback(
@@ -8661,7 +8601,7 @@ YieldToCallback(
cbPtr = TOP_CB(interp);
TOP_CB(interp) = cbPtr->nextPtr;
- SpliceTailcall(interp, cbPtr, 0);
+ TclSpliceTailcall(interp, cbPtr);
return TCL_OK;
}
@@ -9042,7 +8982,6 @@ TclNRCoroutineObjCmd(
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
iPtr->lookupNsPtr = nsPtr;
TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index e8a249f..7ef3bec 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.125 2010/08/18 15:44:12 msofer Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.126 2010/08/30 14:02:09 msofer Exp $
*/
#include "tclInt.h"
@@ -292,8 +292,6 @@ TclNRCatchObjCmd(
TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
varNamePtr, optionVarNamePtr, NULL);
- TclNRAddCallback(interp, TclNRBlockTailcall, NULL, NULL, NULL,
- NULL);
/*
* TIP #280. Make invoking context available to caught script.
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index b844dae..7690649 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -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: tclCmdMZ.c,v 1.213 2010/08/18 15:54:06 msofer Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.214 2010/08/30 14:02:09 msofer Exp $
*/
#include "tclInt.h"
@@ -4274,13 +4274,11 @@ TclNRTryObjCmd(
}
/*
- * 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);
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 4970443..2664558 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.492 2010/08/22 18:53:26 nijtmans Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.493 2010/08/30 14:02:09 msofer Exp $
*/
#include "tclInt.h"
@@ -2901,25 +2901,6 @@ TclExecuteByteCode(
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;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 881dec4..1fb8869 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.481 2010/08/18 22:33:27 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.482 2010/08/30 14:02:10 msofer Exp $
*/
#ifndef _TCLINT
@@ -1152,10 +1152,8 @@ typedef struct CallFrame {
* 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 @@ typedef struct CallFrame {
* 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 TclNRYieldObjCmd;
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
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5bd3c24..6961fd5 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.211 2010/08/18 22:33:27 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.212 2010/08/30 14:02:10 msofer Exp $
*/
#include "tclInt.h"
@@ -313,18 +313,7 @@ Tcl_PushCallFrame(
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_PopCallFrame(
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
+
+ if (framePtr->tailcallPtr) {
+ TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ }
}
/*
diff --git a/tests/tailcall.test b/tests/tailcall.test
index efb5fa4..46e2471 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -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: tailcall.test,v 1.13 2010/08/18 15:44:13 msofer Exp $
+# RCS: @(#) $Id: tailcall.test,v 1.14 2010/08/30 14:02:10 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -384,6 +384,20 @@ test tailcall-11b {tailcall and uplevel} -setup {
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,47 +559,77 @@ test tailcall-12.2 {[Bug 2649975]} -setup {
1: exiting from foo's alpha
}
-test tailcall-12.3a {[Bug 2695587]} {
+test tailcall-12.3a0 {[Bug 2695587]} -body {
apply {{} {
- list [catch [list tailcall foo] msg opt] $msg [errorcode $opt]
+ 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.3b {[Bug 2695587]} {
+test tailcall-12.3a1 {[Bug 2695587]} -body {
apply {{} {
- list [catch {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.3c {[Bug 3046594]} {
+test tailcall-12.3a2 {[Bug 2695587]} -body {
apply {{} {
- list [[subst 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.3d {[Bug 3046594]} {
+test tailcall-12.3a3 {[Bug 2695587]} -body {
+ set x 0
apply {{} {
- list [[subst catch] [list 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-13.1 {tailcall and coroutine} -setup {
- set lambda {i {
- if {$i == 1} {
- depthDiff
- }
- if {[incr i] > 10} {
- return [depthDiff]
- }
- tailcall coroutine foo ::apply $::lambda $i
+test tailcall-12.3b0 {[Bug 2695587]} -body {
+ apply {{} {
+ set catch catch
+ $catch [list tailcall foo]
}}
-} -body {
- coroutine moo ::apply $::lambda 0
+} -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 lambda
-} -result {0 0 0 0 0 0}
+ 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-14.1 {directly tailcalling the tailcall command is ok} {
+test tailcall-13.1 {directly tailcalling the tailcall command is ok} {
list [catch {
apply {{} {
apply {{} {
@@ -596,7 +640,7 @@ test tailcall-14.1 {directly tailcalling the tailcall command is ok} {
}}
} msg opt] $msg [errorcode $opt]
} {0 ok NONE}
-test tailcall-14.2 {indirectly tailcalling the tailcall command is ok} {
+test tailcall-13.2 {indirectly tailcalling the tailcall command is ok} {
list [catch {
apply {{} {
apply {{} {