summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2008-07-31 03:42:15 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2008-07-31 03:42:15 (GMT)
commit8b4bd2bb9a913d76dbb65ca98921a537bce251fd (patch)
treefe3e1dc019de2b19bc6f516f0efa54335ced46e3
parent49b3a0638d14782cab0d6f55302277572a7b9d89 (diff)
downloadtcl-8b4bd2bb9a913d76dbb65ca98921a537bce251fd.zip
tcl-8b4bd2bb9a913d76dbb65ca98921a537bce251fd.tar.gz
tcl-8b4bd2bb9a913d76dbb65ca98921a537bce251fd.tar.bz2
restricting usage and avoiding panics in [tailcall]
-rw-r--r--generic/tclBasic.c82
-rw-r--r--generic/tclExecute.c26
-rw-r--r--tests/NRE.test95
3 files changed, 48 insertions, 155 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b6cb2fd..b9d7efe 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.340 2008/07/31 00:55:15 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.341 2008/07/31 03:42:15 msofer Exp $
*/
#include "tclInt.h"
@@ -4158,8 +4158,12 @@ int
TclNRRunCallbacks(
Tcl_Interp *interp,
int result,
- struct TEOV_callback *rootPtr,
- int tebcCall)
+ struct TEOV_callback *rootPtr, /* All callbacks down to rootPtr not
+ * inclusive are to be run */
+ int tebcCall) /* Normal callers set this to 0; TEBC sets
+ * it to 1 when executing a bytecode, to
+ * 2 when cleaning up after a bytecode
+ * returns. */
{
Interp *iPtr = (Interp *) interp;
TEOV_callback *callbackPtr = TOP_CB(interp);
@@ -4181,26 +4185,22 @@ TclNRRunCallbacks(
while (TOP_CB(interp) != rootPtr) {
callbackPtr = TOP_CB(interp);
- if (tebcCall) {
- if ((callbackPtr->procPtr == NRRunBytecode) ||
- (callbackPtr->procPtr == NRDoTailcall)) {
- /*
- * TEBC pass thru: let the caller tebc handle and get rid of
- * this callback.
- */
-
+ if (tebcCall && (callbackPtr->procPtr == NRRunBytecode)) {
return TCL_OK;
+ } else if (callbackPtr->procPtr == NRDoTailcall) {
+ if (tebcCall == 1) {
+ return TCL_OK;
+ } else if (tebcCall == 2) {
+ Tcl_SetResult(interp,
+ "tailcall cannot be invoked recursively", TCL_STATIC);
+ } else {
+ Tcl_SetResult(interp,
+ "tailcall can only be called from a proc or lambda", TCL_STATIC);
}
- }
-
- if (callbackPtr->procPtr == NRDoTailcall) {
- /*
- * It is an error to schedule a tailcall in this situation.
- */
-
- Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda", TCL_STATIC);
+ TOP_CB(interp) = callbackPtr->nextPtr;
result = TCL_ERROR;
+ TCLNR_FREE(interp, callbackPtr);
+ continue;
}
/*
@@ -7873,9 +7873,7 @@ TclTailcallObjCmd(
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- TEOV_callback *rootPtr = TOP_CB(interp);
- TEOV_callback *tailPtr;
- Tcl_Obj *scriptPtr;
+ Tcl_Obj *listPtr;
Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
int count;
@@ -7883,35 +7881,16 @@ TclTailcallObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
}
- /*
- * Add a callback to perform the tailcall as LAST item in the CALLER's
- * callback stack.
- * Find the first record for the caller:
- * 1. find the SECOND callback that contains a cmdPtr below the top (note
- * that the FIRST one correspond to this TclTailcallObjCmd call)
- * 2. set the callback for the tailcalled command below that
- */
-
- tailPtr = rootPtr;
- count = NR_IS_COMMAND(tailPtr);
- while (tailPtr && tailPtr->nextPtr && (count < 2)) {
- tailPtr = tailPtr->nextPtr;
- count += NR_IS_COMMAND(tailPtr);
- }
-
- if (!iPtr->varFramePtr->isProcCallFrame) {
+ if (!iPtr->varFramePtr->isProcCallFrame || /* is not a body ... */
+ (iPtr->framePtr != iPtr->varFramePtr)) { /* or is upleveled */
Tcl_SetResult(interp,
"tailcall can only be called from a proc or lambda", TCL_STATIC);
return TCL_ERROR;
}
nsPtr->activationCount++;
- if (objc == 2) {
- scriptPtr = objv[1];
- } else {
- scriptPtr = Tcl_NewListObj(objc-1, objv+1);
- }
- Tcl_IncrRefCount(scriptPtr);
+ listPtr = Tcl_NewListObj(objc-1, objv+1);
+ Tcl_IncrRefCount(listPtr);
/*
* Add two callbacks: first the one to actually evaluate the tailcalled
@@ -7919,7 +7898,7 @@ TclTailcallObjCmd(
* proper place.
*/
- TclNRAddCallback(interp, TailcallEval, scriptPtr, nsPtr, NULL, NULL);
+ TclNRAddCallback(interp, TailcallEval, listPtr, nsPtr, NULL, NULL);
TclNRAddCallback(interp, NRDoTailcall, NULL, NULL, NULL, NULL);
return TCL_OK;
@@ -7932,13 +7911,16 @@ TailcallEval(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *scriptPtr = data[0];
+ Tcl_Obj *listPtr = data[0];
Namespace *nsPtr = data[1];
+ int objc;
+ Tcl_Obj **objv;
- TclNRAddCallback(interp, TailcallCleanup, scriptPtr, NULL, NULL, NULL);
+ TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL, NULL);
if (result == TCL_OK) {
iPtr->lookupNsPtr = nsPtr;
- result = TclNREvalObjEx(interp, scriptPtr, 0, NULL, 0);
+ ListObjGetElements(listPtr, objc, objv);
+ result = TclNREvalObjv(interp, objc, objv, 0, NULL);
}
nsPtr->activationCount--;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2a1d232..9ee7ec0 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.391 2008/07/31 00:43:09 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.392 2008/07/31 03:42:15 msofer Exp $
*/
#include "tclInt.h"
@@ -7686,7 +7686,7 @@ TclExecuteByteCode(
*/
bottomPtr = oldBottomPtr; /* back to old bc */
- result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1);
+ result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 2);
NR_DATA_DIG();
DECACHE_STACK_INFO();
@@ -7701,23 +7701,15 @@ TclExecuteByteCode(
Tcl_DecrRefCount(objPtr);
}
goto nonRecursiveCallReturn;
- } else {
+ } else if (TOP_CB(interp)->procPtr == NRRunBytecode) {
/*
- * One of the callbacks requested a new execution: a tailcall!
- * Start the new bytecode.
- */
-
- if (TOP_CB(interp)->procPtr == NRDoTailcall) {
-#if 1
- Tcl_Panic("'tailcall tailcall' not yet implemented");//
-#endif
- Tcl_SetResult(interp,"'tailcall tailcall' not yet implemented",
- TCL_STATIC);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- goto nonRecursiveCallStart;
+ * One of the callbacks requested a new execution: a tailcall!
+ * Start the new bytecode.
+ */
+
+ goto nonRecursiveCallStart;
}
+ Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle! (2)");
}
return result;
}
diff --git a/tests/NRE.test b/tests/NRE.test
index dc306c7..b80eed8 100644
--- a/tests/NRE.test
+++ b/tests/NRE.test
@@ -8,7 +8,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: NRE.test,v 1.7 2008/07/31 00:43:10 msofer Exp $
+# RCS: @(#) $Id: NRE.test,v 1.8 2008/07/31 03:42:17 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -512,20 +512,14 @@ test NRE-T.7 {tailcall does return} -constraints {tailcall} -setup {
b
append res c
}
- proc d {} {
- variable res
- append res d
- c
- append res d
- }
}
} -body {
- namespace eval ::foo d
+ namespace eval ::foo c
} -cleanup {
namespace delete ::foo
-} -result dcbabcd
+} -result cbabc
-test NRE-T.8 {tailcall tailcall} -constraints {tailcall knownbug} -setup {
+test NRE-T.8 {tailcall tailcall} -constraints {tailcall} -setup {
namespace eval ::foo {
variable res {}
proc a {} {
@@ -546,89 +540,14 @@ test NRE-T.8 {tailcall tailcall} -constraints {tailcall knownbug} -setup {
b
append res c
}
- proc d {} {
- variable res
- append res d
- c
- append res d
- }
}
} -body {
- namespace eval ::foo d
+ namespace eval ::foo c
} -cleanup {
namespace delete ::foo
-} -result dcbacd
-
-test NRE-T.9 {tailcall does return} -constraints {tailcall} -setup {
- namespace eval ::foo {
- variable res {}
- proc a {} {
- variable res
- append res a
- tailcall {set x 1}
- append res a
- }
- proc b {} {
- variable res
- append res b
- a
- append res b
- }
- proc c {} {
- variable res
- append res c
- b
- append res c
- }
- proc d {} {
- variable res
- append res d
- c
- append res d
- }
- }
-} -body {
- namespace eval ::foo d
-} -cleanup {
- namespace delete ::foo
-} -result dcbabcd
-
-test NRE-T.10 {tailcall tailcall} -constraints {tailcall knownbug} -setup {
- namespace eval ::foo {
- variable res {}
- proc a {} {
- variable res
- append res a
- tailcall {tailcall set x 1}
- append res a
- }
- proc b {} {
- variable res
- append res b
- a
- append res b
- }
- proc c {} {
- variable res
- append res c
- b
- append res c
- }
- proc d {} {
- variable res
- append res d
- c
- append res d
- }
- }
-} -body {
- namespace eval ::foo d
-} -cleanup {
- namespace delete ::foo
-} -result dcbacd
-
+} -match glob -result *tailcall* -returnCodes error
-test NRE-T.11 {tailcall factorial} -constraints {tailcall} -setup {
+test NRE-T.9 {tailcall factorial} -constraints {tailcall} -setup {
proc fact {n {b 1}} {
if {$n == 1} {
return $b