summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2009-03-21 09:42:06 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2009-03-21 09:42:06 (GMT)
commit61861981e390fd931fe6af2bb3fa9b2d984eb307 (patch)
treee8e1c28643010bdcc4334464e09bcae493800483
parent0a098f986c82c3df2107386ae53a6e40da726c27 (diff)
downloadtcl-61861981e390fd931fe6af2bb3fa9b2d984eb307.zip
tcl-61861981e390fd931fe6af2bb3fa9b2d984eb307.tar.gz
tcl-61861981e390fd931fe6af2bb3fa9b2d984eb307.tar.bz2
* generic/tclBasic.c: Fix for (among others) [Bug 2699087]
* generic/tclCmdAH.c: Tailcalls now perform properly even from * generic/tclExecute.c: within [eval]ed scripts. * generic/tclInt.h: More tests missing, as well as proper exploration and testing of the interaction with "redirectors" like interp-alias (suspect that it does not happen in constant space) and pure-eval commands.
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclBasic.c56
-rw-r--r--generic/tclCmdAH.c16
-rw-r--r--generic/tclExecute.c31
-rw-r--r--generic/tclInt.h6
-rw-r--r--tests/tailcall.test16
6 files changed, 99 insertions, 34 deletions
diff --git a/ChangeLog b/ChangeLog
index 72138dc..1cb2ce0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,13 @@
2009-03-21 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclBasic.c: Fix for (among others) [Bug 2699087]
+ * generic/tclCmdAH.c: Tailcalls now perform properly even from
+ * generic/tclExecute.c: within [eval]ed scripts.
+ * generic/tclInt.h: More tests missing, as well as proper
+ exploration and testing of the interaction with "redirectors" like
+ interp-alias (suspect that it does not happen in constant space)
+ and pure-eval commands.
+
* generic/tclExecute.c: proper fix for [Bug 2415422]. Reenabled
* tests/nre.test: the failing assertion that was disabled on
2008-12-18: the assertion is correct, the fault was in the
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 739732f..c40cd49 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.388 2009/03/19 23:31:37 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.389 2009/03/21 09:42:06 msofer Exp $
*/
#include "tclInt.h"
@@ -7988,8 +7988,9 @@ TclNRTailcallObjCmd(
{
Interp *iPtr = (Interp *) interp;
TEOV_callback *tailcallPtr;
- Tcl_Obj *listPtr;
- Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
+ Tcl_Obj *listPtr, *nsObjPtr;
+ Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+ Tcl_Namespace *ns1Ptr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
@@ -8004,10 +8005,16 @@ TclNRTailcallObjCmd(
return TCL_ERROR;
}
- nsPtr->activationCount++;
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);
+
/*
* Add two callbacks: first the one to actually evaluate the tailcalled
* command, then the one that signals TEBC to stash the first at its
@@ -8017,7 +8024,7 @@ TclNRTailcallObjCmd(
* TclNRAddCallBack macro to build the callback)
*/
- TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL);
+ TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
tailcallPtr = TOP_CB(interp);
TOP_CB(interp) = tailcallPtr->nextPtr;
@@ -8033,27 +8040,19 @@ NRTailcallEval(
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = data[0];
- Namespace *nsPtr = data[1];
- int omit = PTR2INT(data[2]);
+ Tcl_Obj *nsObjPtr = data[1];
+ Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
- TclNRDeferCallback(interp, TailcallCleanup, listPtr, NULL, NULL, NULL);
- if (!omit && (result == TCL_OK)) {
- iPtr->lookupNsPtr = nsPtr;
- ListObjGetElements(listPtr, objc, objv);
- result = TclNREvalObjv(interp, objc, objv, 0, NULL);
- }
-
- nsPtr->activationCount--;
- if ((nsPtr->flags & NS_DYING)
- && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
- /*
- * FIXME NRE tailcall: is this the proper way to manage this? This is
- * like what CallFrames do.
- */
-
- Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
+ TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL, NULL);
+ if (result == TCL_OK) {
+ result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+ if (result == TCL_OK) {
+ iPtr->lookupNsPtr = (Namespace *) nsPtr;
+ ListObjGetElements(listPtr, objc, objv);
+ result = TclNREvalObjv(interp, objc, objv, 0, NULL);
+ }
}
return result;
}
@@ -8065,8 +8064,19 @@ TailcallCleanup(
int result)
{
Tcl_DecrRefCount((Tcl_Obj *) data[0]);
+ Tcl_DecrRefCount((Tcl_Obj *) data[1]);
return result;
}
+
+void
+TclClearTailcall(
+ Tcl_Interp *interp,
+ TEOV_callback *tailcallPtr)
+{
+ TailcallCleanup(tailcallPtr->data, interp, TCL_OK);
+ TCLNR_FREE(interp, tailcallPtr);
+}
+
void
Tcl_NRAddCallback(
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index c8829f8..a00fff8 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.115 2009/02/03 23:34:33 nijtmans Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.116 2009/03/21 09:42:06 msofer Exp $
*/
#include "tclInt.h"
@@ -302,12 +302,26 @@ CatchObjCmdCallback(
Tcl_Interp *interp,
int result)
{
+ Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj *varNamePtr = data[1];
Tcl_Obj *optionVarNamePtr = data[2];
int rewind = ((Interp *) interp)->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/tclExecute.c b/generic/tclExecute.c
index 99bf84e..b00848a 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.432 2009/03/21 06:55:31 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.433 2009/03/21 09:42:07 msofer Exp $
*/
#include "tclInt.h"
@@ -1871,18 +1871,15 @@ TclExecuteByteCode(
fprintf(stdout, " Tailcall request received\n");
}
#endif
- TEOV_callback *tailcallPtr = param;
-
- iPtr->varFramePtr->tailcallPtr = tailcallPtr;
-
if (catchTop != initCatchTop) {
- tailcallPtr->data[2] = INT2PTR(1);
+ TclClearTailcall(interp, param);
result = TCL_ERROR;
Tcl_SetResult(interp,"Tailcall called from within a catch environment",
TCL_STATIC);
pc--;
goto checkForCatch;
}
+ iPtr->varFramePtr->tailcallPtr = param;
goto abnormalReturn;
}
case TCL_NR_YIELD_TYPE: { /*[yield] */
@@ -1995,6 +1992,15 @@ TclExecuteByteCode(
*/
if (iPtr->varFramePtr->tailcallPtr) {
+ if (catchTop != initCatchTop) {
+ TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+ iPtr->varFramePtr->tailcallPtr = NULL;
+ result = TCL_ERROR;
+ Tcl_SetResult(interp,"Tailcall called from within a catch environment",
+ TCL_STATIC);
+ pc--;
+ goto checkForCatch;
+ }
goto abnormalReturn;
}
@@ -7759,6 +7765,19 @@ TclExecuteByteCode(
abnormalReturn:
TCL_DTRACE_INST_LAST();
+
+ /*
+ * Winding down: insure that all pending cleanups are done before
+ * dropping out of this bytecode.
+ */
+ if (TOP_CB(interp) != bottomPtr->rootPtr) {
+ result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1);
+
+ if (TOP_CB(interp) != bottomPtr->rootPtr) {
+ Tcl_Panic("Abnormal return with busy callback stack");
+ }
+ }
+
/*
* Clear all expansions and same-level NR calls.
*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 48473bd..3c45cc1 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.419 2009/03/19 23:31:37 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.420 2009/03/21 09:42:07 msofer Exp $
*/
#ifndef _TCLINT
@@ -2603,6 +2603,10 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
+MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp,
+ struct TEOV_callback *tailcallPtr);
+
+
/*
*----------------------------------------------------------------
* Procedures shared among Tcl modules but not used by the outside world:
diff --git a/tests/tailcall.test b/tests/tailcall.test
index fb6d662..4cfbebf 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.3 2009/03/21 03:43:53 msofer Exp $
+# RCS: @(#) $Id: tailcall.test,v 1.4 2009/03/21 09:42:07 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -221,7 +221,7 @@ test tailcall-9 {tailcall factorial} -setup {
rename fact {}
} -result {1 120 3628800 1307674368000}
-test tailcall-10a {tailcall and eval} -constraints {knownBug} -setup {
+test tailcall-10a {tailcall and eval} -setup {
set ::x 0
proc a {} {
eval [list tailcall lappend ::x 2]
@@ -432,7 +432,17 @@ test tailcall-12.2 {[Bug 2649975]} -setup {
1: exiting from foo's alpha
}
-test tailcall-12.3 {[Bug 2695587]} -setup {
+test tailcall-12.3a {[Bug 2695587]} -setup {
+ proc a {} {
+ list [catch [list tailcall foo] msg] $msg
+ }
+} -body {
+ a
+} -cleanup {
+ rename a {}
+} -result {1 {Tailcall called from within a catch environment}}
+
+test tailcall-12.3b {[Bug 2695587]} -setup {
proc a {} {
list [catch {tailcall foo} msg] $msg
}