summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2008-08-03 17:33:10 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2008-08-03 17:33:10 (GMT)
commit245ab4ae255929317069b92446f66b83c901b8f8 (patch)
treeafb13d0a8600f288efd20fab3dfb00080fedb57c /generic/tclBasic.c
parent4e05e9902f3b5f40de10d672ed0c5e1a106dc8ae (diff)
downloadtcl-245ab4ae255929317069b92446f66b83c901b8f8.zip
tcl-245ab4ae255929317069b92446f66b83c901b8f8.tar.gz
tcl-245ab4ae255929317069b92446f66b83c901b8f8.tar.bz2
* generic/tclBasic.c: new unsupported command atProcExit
* generic/tclCompile.h: that shares the implementation with * generic/tclExecute.c: tailcall. Fixed a segfault in * generic/tclInt.h: tailcalls. Tests added. * generic/tclInterp.c: * generic/tclNamesp.c: * tests/unsupported.test:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c69
1 files changed, 21 insertions, 48 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9509848..7c9da84 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.347 2008/08/01 17:07:47 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.348 2008/08/03 17:33:10 msofer Exp $
*/
#include "tclInt.h"
@@ -133,26 +133,7 @@ static Tcl_NRPostProc TEOEx_ByteCodeCallback;
static Tcl_NRPostProc NRCommand;
static Tcl_NRPostProc NRRunObjProc;
-static Tcl_NRPostProc TailcallEval;
-static Tcl_NRPostProc TailcallCleanup;
-
-#define NR_IS_COMMAND(callbackPtr) \
- (callbackPtr \
- && (callbackPtr->procPtr == NRCommand) \
- && (PTR2INT(callbackPtr->data[1])))
-
-#define NR_CLEAR_COMMAND(interp) \
- { \
- TEOV_callback *callbackPtr = TOP_CB(interp); \
- \
- while (!NR_IS_COMMAND(callbackPtr)) { \
- callbackPtr = callbackPtr->nextPtr; \
- } \
- if (callbackPtr) { \
- callbackPtr->data[1] = INT2PTR(0); \
- }\
- }
-
+static Tcl_NRPostProc AtProcExitCleanup;
/*
* The following structure define the commands in the Tcl core.
@@ -790,11 +771,13 @@ Tcl_CreateInterp(void)
Tcl_DisassembleObjCmd, NULL, NULL);
/*
- * Create an unsupported command for tailcalls
+ * Create unsupported commands for atProcExit and tailcall
*/
+ Tcl_NRCreateCommand(interp, "::tcl::unsupported::atProcExit",
+ /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(0), NULL);
Tcl_NRCreateCommand(interp, "::tcl::unsupported::tailcall",
- /*objProc*/ NULL, TclTailcallObjCmd, NULL, NULL);
+ /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(1), NULL);
#ifdef USE_DTRACE
/*
@@ -4032,8 +4015,7 @@ TclNREvalObjv(
* finishes the source command and not just the target.
*/
- TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1),
- NULL, NULL);
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
TclResetCancellation(interp, 0);
@@ -4190,15 +4172,15 @@ TclNRRunCallbacks(
if (tebcCall && (callbackPtr->procPtr == NRRunBytecode)) {
return TCL_OK;
- } else if (callbackPtr->procPtr == NRDoTailcall) {
+ } else if (callbackPtr->procPtr == NRAtProcExit) {
if (tebcCall == 1) {
return TCL_OK;
} else if (tebcCall == 2) {
Tcl_SetResult(interp,
- "tailcall cannot be invoked recursively", TCL_STATIC);
+ "atProcExit/tailcall cannot be invoked recursively", TCL_STATIC);
} else {
Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda", TCL_STATIC);
+ "atProcExit/tailcall can only be called from a proc or lambda", TCL_STATIC);
}
TOP_CB(interp) = callbackPtr->nextPtr;
result = TCL_ERROR;
@@ -4289,7 +4271,7 @@ NRRunBytecode(
}
int
-NRDoTailcall(
+NRAtProcExit(
ClientData data[],
Tcl_Interp *interp,
int result)
@@ -7827,12 +7809,6 @@ Tcl_NREvalObjv(
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
-void
-TclNRClearCommandFlag(
- Tcl_Interp *interp)
-{
- NR_CLEAR_COMMAND(interp);
-}
int
Tcl_NRCmdSwap(
@@ -7842,11 +7818,7 @@ Tcl_NRCmdSwap(
Tcl_Obj *const objv[],
int flags)
{
- int result;
-
- result = TclNREvalObjv(interp, objc, objv, flags, (Command *)cmd);
- NR_CLEAR_COMMAND(interp);
- return result;
+ return TclNREvalObjv(interp, objc, objv, flags, (Command *)cmd);
}
/*****************************************************************************
@@ -7874,7 +7846,7 @@ Tcl_NRCmdSwap(
*/
int
-TclTailcallObjCmd(
+TclNRAtProcExitObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -7886,12 +7858,13 @@ TclTailcallObjCmd(
if (objc < 2) {
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 */
Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda", TCL_STATIC);
+ "atProcExit/tailcall can only be called from a proc or lambda", TCL_STATIC);
return TCL_ERROR;
}
@@ -7905,14 +7878,14 @@ TclTailcallObjCmd(
* proper place.
*/
- TclNRAddCallback(interp, TailcallEval, listPtr, nsPtr, NULL, NULL);
- TclNRAddCallback(interp, NRDoTailcall, NULL, NULL, NULL, NULL);
+ TclNRAddCallback(interp, NRAtProcExitEval, listPtr, nsPtr, NULL, NULL);
+ TclNRAddCallback(interp, NRAtProcExit, clientData, NULL, NULL, NULL);
return TCL_OK;
}
-static int
-TailcallEval(
+int
+NRAtProcExitEval(
ClientData data[],
Tcl_Interp *interp,
int result)
@@ -7923,7 +7896,7 @@ TailcallEval(
int objc;
Tcl_Obj **objv;
- TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL, NULL);
+ TclNRAddCallback(interp, AtProcExitCleanup, listPtr, NULL, NULL, NULL);
if (result == TCL_OK) {
iPtr->lookupNsPtr = nsPtr;
ListObjGetElements(listPtr, objc, objv);
@@ -7944,7 +7917,7 @@ TailcallEval(
}
static int
-TailcallCleanup(
+AtProcExitCleanup(
ClientData data[],
Tcl_Interp *interp,
int result)