summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2013-01-12 22:23:29 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2013-01-12 22:23:29 (GMT)
commit2eb2362fbf11bf4747a0e1b3e1d75d55c83ba1a9 (patch)
tree62ad7f6aef771789dcbd53f0de65dc646ca1586d
parent9c8f288cd88461a952b3310b899cb40a1e81b194 (diff)
parent84b9c7728c8f168edce68d529ddac68a5056e766 (diff)
downloadtcl-2eb2362fbf11bf4747a0e1b3e1d75d55c83ba1a9.zip
tcl-2eb2362fbf11bf4747a0e1b3e1d75d55c83ba1a9.tar.gz
tcl-2eb2362fbf11bf4747a0e1b3e1d75d55c83ba1a9.tar.bz2
merge trunk
Remove various double-defined (both in public and private stub tables) functions from private stub table
-rw-r--r--generic/tclBasic.c165
-rw-r--r--generic/tclCompCmdsSZ.c4
-rw-r--r--generic/tclEnsemble.c4
-rw-r--r--generic/tclExecute.c22
-rw-r--r--generic/tclInt.decls100
-rw-r--r--generic/tclInt.h41
-rw-r--r--generic/tclIntDecls.h122
-rw-r--r--generic/tclInterp.c4
-rw-r--r--generic/tclNamesp.c4
-rw-r--r--generic/tclStubInit.c24
-rw-r--r--tests/parse.test9
11 files changed, 220 insertions, 279 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 4f70cee..465fd35 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -146,10 +146,7 @@ static Tcl_NRPostProc TEOV_Exception;
static Tcl_NRPostProc TEOV_NotFoundCallback;
static Tcl_NRPostProc TEOV_RestoreVarFrame;
static Tcl_NRPostProc TEOV_RunLeaveTraces;
-static Tcl_NRPostProc YieldToCallback;
-static void ClearTailcall(Tcl_Interp *interp,
- struct NRE_callback *tailcallPtr);
static Tcl_ObjCmdProc NRCoroInjectObjCmd;
MODULE_SCOPE const TclStubs tclStubs;
@@ -3770,7 +3767,8 @@ TclNREvalObjv(
int result;
Namespace *lookupNsPtr = iPtr->lookupNsPtr;
Command **cmdPtrPtr;
-
+ NRE_callback *callbackPtr;
+
iPtr->lookupNsPtr = NULL;
/*
@@ -3783,15 +3781,17 @@ TclNREvalObjv(
* finishes the source command and not just the target.
*/
- if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
- TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv);
- iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
+ if (iPtr->deferredCallbacks) {
+ callbackPtr = iPtr->deferredCallbacks;
+ iPtr->deferredCallbacks = NULL;
} else {
- TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+ callbackPtr = TOP_CB(interp);
}
- cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
+ cmdPtrPtr = (Command **) &(callbackPtr->data[0]);
- TclNRSpliceDeferred(interp);
+ callbackPtr->data[2] = INT2PTR(objc);
+ callbackPtr->data[3] = (ClientData) objv;
iPtr->numLevels++;
result = TclInterpReady(interp);
@@ -3918,14 +3918,6 @@ TclNREvalObjv(
}
}
-void
-TclPushTailcallPoint(
- Tcl_Interp *interp)
-{
- TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
- ((Interp *) interp)->numLevels++;
-}
-
int
TclNRRunCallbacks(
Tcl_Interp *interp,
@@ -3962,6 +3954,14 @@ NRCommand(
}
((Interp *)interp)->numLevels--;
+ /*
+ * If there is a tailcall, schedule it
+ */
+
+ if (data[1] && (data[1] != INT2PTR(1))) {
+ TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
+ }
+
/* OPT ??
* Do not interrupt a series of cleanups with async or limit checks:
* just check at the end?
@@ -4219,9 +4219,9 @@ TEOV_NotFound(
savedNsPtr = varFramePtr->nsPtr;
varFramePtr->nsPtr = lookupNsPtr;
}
- TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
+ TclSkipTailcall(interp);
+ TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
newObjv, savedNsPtr, NULL);
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
}
@@ -5541,7 +5541,8 @@ TclNREvalObjEx(
iPtr->cmdFramePtr = eoFramePtr;
}
- TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
NULL, NULL);
ListObjGetElements(listPtr, objc, objv);
@@ -7650,29 +7651,58 @@ Tcl_NRCmdSwap(
*/
void
-TclSpliceTailcall(
+TclMarkTailcall(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->deferredCallbacks == NULL) {
+ TclNRAddCallback(interp, NRCommand, NULL, NULL,
+ NULL, NULL);
+ iPtr->deferredCallbacks = TOP_CB(interp);
+ }
+}
+
+void
+TclSkipTailcall(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ TclMarkTailcall(interp);
+ iPtr->deferredCallbacks->data[1] = INT2PTR(1);
+}
+
+void
+TclPushTailcallPoint(
+ Tcl_Interp *interp)
+{
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+ ((Interp *) interp)->numLevels++;
+}
+
+void
+TclSetTailcall(
Tcl_Interp *interp,
- NRE_callback *tailcallPtr)
+ Tcl_Obj *listPtr)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
- * being tailcalled. Note that we skip NRCommands marked in data[1]
+ * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1]
* (used by command redirectors).
*/
NRE_callback *runPtr;
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
- if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
+ if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
break;
}
}
if (!runPtr) {
Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
}
-
- tailcallPtr->nextPtr = runPtr->nextPtr;
- runPtr->nextPtr = tailcallPtr;
+ runPtr->data[1] = listPtr;
}
int
@@ -7702,7 +7732,7 @@ TclNRTailcallObjCmd(
*/
if (iPtr->varFramePtr->tailcallPtr) {
- ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+ Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
iPtr->varFramePtr->tailcallPtr = NULL;
}
@@ -7717,23 +7747,20 @@ TclNRTailcallObjCmd(
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
- NRE_callback *tailcallPtr;
- listPtr = Tcl_NewListObj(objc-1, objv+1);
- Tcl_IncrRefCount(listPtr);
+ /* The tailcall data is in a Tcl list: the first element is the
+ * namespace, the rest the command to be tailcalled. */
+
+ listPtr = Tcl_NewListObj(objc, objv);
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, TclNRTailcallEval, listPtr, nsObjPtr,
- NULL, NULL);
- tailcallPtr = TOP_CB(interp);
- TOP_CB(interp) = tailcallPtr->nextPtr;
- iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+
+ iPtr->varFramePtr->tailcallPtr = listPtr;
}
return TCL_RETURN;
}
@@ -7745,12 +7772,14 @@ TclNRTailcallEval(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *listPtr = data[0];
- Tcl_Obj *nsObjPtr = data[1];
+ Tcl_Obj *listPtr = data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
+ Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
+ nsObjPtr = objv[0];
+
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
}
@@ -7769,10 +7798,10 @@ TclNRTailcallEval(
* Perform the tailcall
*/
- TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL);
iPtr->lookupNsPtr = (Namespace *) nsPtr;
- ListObjGetElements(listPtr, objc, objv);
- return TclNREvalObjv(interp, objc, objv, 0, NULL);
+ return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
static int
@@ -7782,19 +7811,9 @@ TailcallCleanup(
int result)
{
Tcl_DecrRefCount((Tcl_Obj *) data[0]);
- Tcl_DecrRefCount((Tcl_Obj *) data[1]);
return result;
}
-static void
-ClearTailcall(
- Tcl_Interp *interp,
- NRE_callback *tailcallPtr)
-{
- TailcallCleanup(tailcallPtr->data, interp, TCL_OK);
- TCLNR_FREE(interp, tailcallPtr);
-}
-
void
Tcl_NRAddCallback(
@@ -7896,50 +7915,32 @@ TclNRYieldToObjCmd(
* This is essentially code from TclNRTailcallObjCmd
*/
- listPtr = Tcl_NewListObj(objc-1, objv+1);
- Tcl_IncrRefCount(listPtr);
+ /*
+ * Add the tailcall in the caller env, then just yield.
+ *
+ * This is essentially code from TclNRTailcallObjCmd
+ */
+
+ listPtr = Tcl_NewListObj(objc, objv);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("yieldto failed to find the proper namespace");
}
- Tcl_IncrRefCount(nsObjPtr);
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+
/*
* Add the callback in the caller's env, then instruct TEBC to yield.
*/
iPtr->execEnvPtr = corPtr->callerEEPtr;
- TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr,
- NULL);
+ TclSetTailcall(interp, listPtr);
iPtr->execEnvPtr = corPtr->eePtr;
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
-
-static int
-YieldToCallback(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- /* CoroutineData *corPtr = data[0];*/
- Tcl_Obj *listPtr = data[1];
- ClientData nsPtr = data[2];
- NRE_callback *cbPtr;
-
- /*
- * yieldTo: invoke the command using tailcall tech.
- */
-
- TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL);
- cbPtr = TOP_CB(interp);
- TOP_CB(interp) = cbPtr->nextPtr;
-
- TclSpliceTailcall(interp, cbPtr);
- return TCL_OK;
-}
static int
RewindCoroutineCallback(
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 1d04d8b..6e31481 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -1953,11 +1953,13 @@ TclCompileTailcallCmd(
return TCL_ERROR;
}
+ /* make room for the nsObjPtr */
+ CompileWord(envPtr, tokenPtr, interp, 0);
for (i=1 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
- TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords-1, envPtr);
+ TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr);
return TCL_OK;
}
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 9a2d598..058590a 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -1914,7 +1914,7 @@ NsEnsembleImplementationCmdNR(
* Hand off to the target command.
*/
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
}
@@ -2122,7 +2122,7 @@ EnsembleUnknownCallback(
*/
Tcl_Preserve(ensemblePtr);
- ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
if (!Tcl_InterpDeleted(interp)) {
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 687ac09..4c20b25 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1032,7 +1032,7 @@ GrowEvaluationStack(
if (move) {
moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
}
- needed = growth + moveWords + WALLOCALIGN - 1;
+ needed = growth + moveWords + WALLOCALIGN;
/*
@@ -2342,7 +2342,6 @@ TEBCresume(
case INST_TAILCALL: {
Tcl_Obj *listPtr, *nsObjPtr;
- NRE_callback *tailcallPtr;
opnd = TclGetUInt1AtPtr(pc+1);
@@ -2376,18 +2375,12 @@ TEBCresume(
listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
- Tcl_IncrRefCount(listPtr);
- Tcl_IncrRefCount(nsObjPtr);
- TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
- NULL, NULL);
-
- /*
- * Unstitch ourselves and do a [return].
- */
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+ if (iPtr->varFramePtr->tailcallPtr) {
+ Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
+ }
+ iPtr->varFramePtr->tailcallPtr = listPtr;
- tailcallPtr = TOP_CB(interp);
- TOP_CB(interp) = tailcallPtr->nextPtr;
- iPtr->varFramePtr->tailcallPtr = tailcallPtr;
result = TCL_RETURN;
cleanup = opnd;
goto processExceptionReturn;
@@ -2922,8 +2915,9 @@ TEBCresume(
DECACHE_STACK_INFO();
pc += 6;
TEBC_YIELD();
+
TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
/*
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index d23d61a..b840d04 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -457,29 +457,35 @@ declare 111 {
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
-declare 112 {
- int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- Tcl_Obj *objPtr)
-}
-declare 113 {
- Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
- ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
-}
-declare 114 {
- void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
-}
-declare 115 {
- int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- const char *pattern, int resetListFirst)
-}
-declare 116 {
- Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
- Tcl_Namespace *contextNsPtr, int flags)
-}
-declare 117 {
- Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
- Tcl_Namespace *contextNsPtr, int flags)
-}
+# Removed in 9.0:
+#declare 112 {
+# int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+# Tcl_Obj *objPtr)
+#}
+# Removed in 9.0:
+#declare 113 {
+# Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
+# ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
+#}
+# Removed in 9.0:
+#declare 114 {
+# void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
+#}
+# Removed in 9.0:
+#declare 115 {
+# int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+# const char *pattern, int resetListFirst)
+#}
+# Removed in 9.0:
+#declare 116 {
+# Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+# Tcl_Namespace *contextNsPtr, int flags)
+#}
+# Removed in 9.0:
+#declare 117 {
+# Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
+# Tcl_Namespace *contextNsPtr, int flags)
+#}
declare 118 {
int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolverInfo *resInfo)
@@ -492,31 +498,37 @@ declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
-declare 121 {
- int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- const char *pattern)
-}
-declare 122 {
- Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
-}
-declare 123 {
- void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
- Tcl_Obj *objPtr)
-}
-declare 124 {
- Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
-}
-declare 125 {
- Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
-}
+# Removed in 9.0:
+#declare 121 {
+# int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+# const char *pattern)
+#}
+# Removed in 9.0:
+#declare 122 {
+# Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+#}
+# Removed in 9.0:
+#declare 123 {
+# void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
+# Tcl_Obj *objPtr)
+#}
+# Removed in 9.0:
+#declare 124 {
+# Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
+#}
+# Removed in 9.0:
+#declare 125 {
+# Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
+#}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
-declare 127 {
- int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- const char *pattern, int allowOverwrite)
-}
+# Removed in 9.0:
+#declare 127 {
+# int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+# const char *pattern, int allowOverwrite)
+#}
declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index eb16dd5..df1507d 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1154,7 +1154,7 @@ typedef struct CallFrame {
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
- struct NRE_callback *tailcallPtr;
+ Tcl_Obj *tailcallPtr;
/* NULL if no tailcall is scheduled */
} CallFrame;
@@ -2223,7 +2223,6 @@ typedef struct InterpList {
#define TCL_ALLOW_EXCEPTIONS 4
#define TCL_EVAL_FILE 2
#define TCL_EVAL_CTX 8
-#define TCL_EVAL_REDIRECT 16
/*
* Flag bits for Interp structures:
@@ -2768,8 +2767,12 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
-MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
- struct NRE_callback *tailcallPtr);
+MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
+MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
+
+/* These two can be considered for the public api */
+MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp);
+MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp);
/*
* This structure holds the data for the various iteration callbacks used to
@@ -2844,7 +2847,6 @@ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, int len);
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
-MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next,
int loc);
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
@@ -4772,35 +4774,6 @@ typedef struct NRE_callback {
TOP_CB(interp) = callbackPtr; \
} while (0)
-#define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) \
- do { \
- NRE_callback *callbackPtr; \
- TCLNR_ALLOC((interp), (callbackPtr)); \
- callbackPtr->procPtr = (postProcPtr); \
- callbackPtr->data[0] = (ClientData)(data0); \
- callbackPtr->data[1] = (ClientData)(data1); \
- callbackPtr->data[2] = (ClientData)(data2); \
- callbackPtr->data[3] = (ClientData)(data3); \
- callbackPtr->nextPtr = ((Interp *)interp)->deferredCallbacks; \
- ((Interp *)interp)->deferredCallbacks = callbackPtr; \
- } while (0)
-
-#define TclNRSpliceCallbacks(interp, topPtr) \
- do { \
- NRE_callback *bottomPtr = topPtr; \
- while (bottomPtr->nextPtr) { \
- bottomPtr = bottomPtr->nextPtr; \
- } \
- bottomPtr->nextPtr = TOP_CB(interp); \
- TOP_CB(interp) = topPtr; \
- } while (0)
-
-#define TclNRSpliceDeferred(interp) \
- if (((Interp *)interp)->deferredCallbacks) { \
- TclNRSpliceCallbacks(interp, ((Interp *)interp)->deferredCallbacks); \
- ((Interp *)interp)->deferredCallbacks = NULL; \
- }
-
#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 65b1888..26b168f 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -17,21 +17,6 @@
#include "tclPort.h"
-/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */
-#undef Tcl_AppendExportList
-#undef Tcl_CreateNamespace
-#undef Tcl_DeleteNamespace
-#undef Tcl_Export
-#undef Tcl_FindCommand
-#undef Tcl_FindNamespace
-#undef Tcl_FindNamespaceVar
-#undef Tcl_ForgetImport
-#undef Tcl_GetCommandFromObj
-#undef Tcl_GetCommandFullName
-#undef Tcl_GetCurrentNamespace
-#undef Tcl_GetGlobalNamespace
-#undef Tcl_Import
-
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
@@ -262,25 +247,12 @@ TCLAPI void Tcl_AddInterpResolvers(Tcl_Interp *interp,
Tcl_ResolveCmdProc *cmdProc,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
-/* 112 */
-TCLAPI int Tcl_AppendExportList(Tcl_Interp *interp,
- Tcl_Namespace *nsPtr, Tcl_Obj *objPtr);
-/* 113 */
-TCLAPI Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
- const char *name, ClientData clientData,
- Tcl_NamespaceDeleteProc *deleteProc);
-/* 114 */
-TCLAPI void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
-/* 115 */
-TCLAPI int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- const char *pattern, int resetListFirst);
-/* 116 */
-TCLAPI Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
- Tcl_Namespace *contextNsPtr, int flags);
-/* 117 */
-TCLAPI Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *contextNsPtr, int flags);
+/* Slot 112 is reserved */
+/* Slot 113 is reserved */
+/* Slot 114 is reserved */
+/* Slot 115 is reserved */
+/* Slot 116 is reserved */
+/* Slot 117 is reserved */
/* 118 */
TCLAPI int Tcl_GetInterpResolvers(Tcl_Interp *interp,
const char *name, Tcl_ResolverInfo *resInfo);
@@ -292,25 +264,15 @@ TCLAPI int Tcl_GetNamespaceResolvers(
TCLAPI Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
-/* 121 */
-TCLAPI int Tcl_ForgetImport(Tcl_Interp *interp,
- Tcl_Namespace *nsPtr, const char *pattern);
-/* 122 */
-TCLAPI Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
-/* 123 */
-TCLAPI void Tcl_GetCommandFullName(Tcl_Interp *interp,
- Tcl_Command command, Tcl_Obj *objPtr);
-/* 124 */
-TCLAPI Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp);
-/* 125 */
-TCLAPI Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp);
+/* Slot 121 is reserved */
+/* Slot 122 is reserved */
+/* Slot 123 is reserved */
+/* Slot 124 is reserved */
+/* Slot 125 is reserved */
/* 126 */
TCLAPI void Tcl_GetVariableFullName(Tcl_Interp *interp,
Tcl_Var variable, Tcl_Obj *objPtr);
-/* 127 */
-TCLAPI int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- const char *pattern, int allowOverwrite);
+/* Slot 127 is reserved */
/* 128 */
TCLAPI void Tcl_PopCallFrame(Tcl_Interp *interp);
/* 129 */
@@ -697,22 +659,22 @@ typedef struct TclIntStubs {
int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */
int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */
void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */
- int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
- Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
- void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
- int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
- Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
- Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
+ void (*reserved112)(void);
+ void (*reserved113)(void);
+ void (*reserved114)(void);
+ void (*reserved115)(void);
+ void (*reserved116)(void);
+ void (*reserved117)(void);
int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */
int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */
Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */
- int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
- Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
- void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
- Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */
- Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */
+ void (*reserved121)(void);
+ void (*reserved122)(void);
+ void (*reserved123)(void);
+ void (*reserved124)(void);
+ void (*reserved125)(void);
void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */
- int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
+ void (*reserved127)(void);
void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */
int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */
int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */
@@ -1022,38 +984,26 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */
#define Tcl_AddInterpResolvers \
(tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
-#define Tcl_AppendExportList \
- (tclIntStubsPtr->tcl_AppendExportList) /* 112 */
-#define Tcl_CreateNamespace \
- (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
-#define Tcl_DeleteNamespace \
- (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
-#define Tcl_Export \
- (tclIntStubsPtr->tcl_Export) /* 115 */
-#define Tcl_FindCommand \
- (tclIntStubsPtr->tcl_FindCommand) /* 116 */
-#define Tcl_FindNamespace \
- (tclIntStubsPtr->tcl_FindNamespace) /* 117 */
+/* Slot 112 is reserved */
+/* Slot 113 is reserved */
+/* Slot 114 is reserved */
+/* Slot 115 is reserved */
+/* Slot 116 is reserved */
+/* Slot 117 is reserved */
#define Tcl_GetInterpResolvers \
(tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
#define Tcl_GetNamespaceResolvers \
(tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
#define Tcl_FindNamespaceVar \
(tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
-#define Tcl_ForgetImport \
- (tclIntStubsPtr->tcl_ForgetImport) /* 121 */
-#define Tcl_GetCommandFromObj \
- (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
-#define Tcl_GetCommandFullName \
- (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
-#define Tcl_GetCurrentNamespace \
- (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
-#define Tcl_GetGlobalNamespace \
- (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
+/* Slot 121 is reserved */
+/* Slot 122 is reserved */
+/* Slot 123 is reserved */
+/* Slot 124 is reserved */
+/* Slot 125 is reserved */
#define Tcl_GetVariableFullName \
(tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
-#define Tcl_Import \
- (tclIntStubsPtr->tcl_Import) /* 127 */
+/* Slot 127 is reserved */
#define Tcl_PopCallFrame \
(tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
#define Tcl_PushCallFrame \
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index b817b52..2b93ab0 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1798,9 +1798,9 @@ AliasNRCmd(
*/
if (isRootEnsemble) {
- TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return Tcl_NREvalObj(interp, listPtr, flags);
}
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5adc016..03e34bd 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -423,7 +423,7 @@ Tcl_PopCallFrame(
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
- TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ TclSetTailcall(interp, framePtr->tailcallPtr);
}
}
@@ -1945,7 +1945,7 @@ InvokeImportedNRCmd(
ImportedCmdData *dataPtr = clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
- ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 66dadb8..3dd0b48 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -302,22 +302,22 @@ static const TclIntStubs tclIntStubs = {
TclUpdateReturnInfo, /* 109 */
TclSockMinimumBuffers, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
- Tcl_AppendExportList, /* 112 */
- Tcl_CreateNamespace, /* 113 */
- Tcl_DeleteNamespace, /* 114 */
- Tcl_Export, /* 115 */
- Tcl_FindCommand, /* 116 */
- Tcl_FindNamespace, /* 117 */
+ 0, /* 112 */
+ 0, /* 113 */
+ 0, /* 114 */
+ 0, /* 115 */
+ 0, /* 116 */
+ 0, /* 117 */
Tcl_GetInterpResolvers, /* 118 */
Tcl_GetNamespaceResolvers, /* 119 */
Tcl_FindNamespaceVar, /* 120 */
- Tcl_ForgetImport, /* 121 */
- Tcl_GetCommandFromObj, /* 122 */
- Tcl_GetCommandFullName, /* 123 */
- Tcl_GetCurrentNamespace, /* 124 */
- Tcl_GetGlobalNamespace, /* 125 */
+ 0, /* 121 */
+ 0, /* 122 */
+ 0, /* 123 */
+ 0, /* 124 */
+ 0, /* 125 */
Tcl_GetVariableFullName, /* 126 */
- Tcl_Import, /* 127 */
+ 0, /* 127 */
Tcl_PopCallFrame, /* 128 */
Tcl_PushCallFrame, /* 129 */
Tcl_RemoveInterpResolvers, /* 130 */
diff --git a/tests/parse.test b/tests/parse.test
index 0f76d64..bc4107d 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -26,6 +26,7 @@ testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
+testConstraint testevent [llength [info commands testevent]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -1090,6 +1091,14 @@ test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
+test parse-21.0 {Bug 1884496} testevent {
+ set ::script {set a [p]; return -level 0 $a}
+ proc ::p {} {string first s $::script}
+ testevent queue a head $::script
+ update
+} {}
+
+
cleanupTests
}