From 41c09d7b4d37c2b2fc7cec61aaaa3ca59a56a7c5 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Thu, 10 Jan 2013 18:17:33 +0000
Subject: fix off-by-one error introduced in bd7d7a2061

---
 generic/tclExecute.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 8759ec9..ade71f6 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1089,7 +1089,7 @@ GrowEvaluationStack(
     if (move) {
 	moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
     }
-    needed = growth + moveWords + WALLOCALIGN - 1;
+    needed = growth + moveWords + WALLOCALIGN;
 
     
     /*
-- 
cgit v0.12


From e89dea9b9b819e7b5ddc8d171127b749e237af35 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Thu, 10 Jan 2013 21:18:52 +0000
Subject: tailcall now running in a simpler model, with no eval-flags and no
 nre-stack rewriting; yieldto also requires one fewer bounce. Mostly from
 mig-nre-mods

---
 generic/tclBasic.c      | 142 +++++++++++++++++++++++-------------------------
 generic/tclCompCmdsSZ.c |   4 +-
 generic/tclEnsemble.c   |   4 +-
 generic/tclExecute.c    |  20 +++----
 generic/tclInt.h        |  36 +-----------
 generic/tclInterp.c     |   4 +-
 generic/tclNamesp.c     |   4 +-
 7 files changed, 87 insertions(+), 127 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 562cca6..55014ec 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -160,10 +160,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;
@@ -4161,7 +4158,8 @@ TclNREvalObjv(
     int result;
     Namespace *lookupNsPtr = iPtr->lookupNsPtr;
     Command **cmdPtrPtr;
-
+    NRE_callback *callbackPtr;
+    
     iPtr->lookupNsPtr = NULL;
 
     /*
@@ -4174,15 +4172,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);
@@ -4368,6 +4368,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?
@@ -4625,9 +4633,9 @@ TEOV_NotFound(
 	savedNsPtr = varFramePtr->nsPtr;
 	varFramePtr->nsPtr = lookupNsPtr;
     }
-    TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
+    TclDeferCallbacks(interp, 1);
+    TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
 	    newObjv, savedNsPtr, NULL);
-    iPtr->evalFlags |= TCL_EVAL_REDIRECT;
     return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
 }
 
@@ -6012,7 +6020,8 @@ TclNREvalObjEx(
 	    iPtr->cmdFramePtr = eoFramePtr;
 	}
 
-	TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
+	TclDeferCallbacks(interp, 0);
+        TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
 		NULL, NULL);
 
 	ListObjGetElements(listPtr, objc, objv);
@@ -8269,29 +8278,43 @@ Tcl_NRCmdSwap(
  */
 
 void
-TclSpliceTailcall(
+TclDeferCallbacks(
     Tcl_Interp *interp,
-    NRE_callback *tailcallPtr)
+    int skipTailcalls)
+{
+    Interp *iPtr = (Interp *) interp;
+
+    if (iPtr->deferredCallbacks == NULL) {
+	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(skipTailcalls != 0),
+                NULL, NULL);
+        iPtr->deferredCallbacks = TOP_CB(interp);
+    } else if (skipTailcalls) {
+        iPtr->deferredCallbacks->data[1] = INT2PTR(skipTailcalls != 0);
+    }
+}
+
+void
+TclSetTailcall(
+    Tcl_Interp *interp,
+    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
@@ -8321,7 +8344,7 @@ TclNRTailcallObjCmd(
      */
 
     if (iPtr->varFramePtr->tailcallPtr) {
-        ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+        Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
         iPtr->varFramePtr->tailcallPtr = NULL;
     }
 
@@ -8336,23 +8359,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;
 }
@@ -8364,12 +8384,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);
     }
@@ -8388,10 +8410,10 @@ TclNRTailcallEval(
      * Perform the tailcall
      */
 
-    TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
+    TclDeferCallbacks(interp, 0);
+    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
@@ -8401,19 +8423,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(
@@ -8515,50 +8527,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..2753876 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;
+	TclDeferCallbacks(interp, /* skip tailcalls */ 1);
 	return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
     }
 
@@ -2122,7 +2122,7 @@ EnsembleUnknownCallback(
      */
 
     Tcl_Preserve(ensemblePtr);
-    ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
+    TclDeferCallbacks (interp, /*skip tailcalls */ 1);
     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 ade71f6..af60a95 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2399,7 +2399,6 @@ TEBCresume(
 
     case INST_TAILCALL: {
 	Tcl_Obj *listPtr, *nsObjPtr;
-        NRE_callback *tailcallPtr;
 
 	opnd = TclGetUInt1AtPtr(pc+1);
 
@@ -2433,18 +2432,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;
@@ -3054,8 +3047,9 @@ TEBCresume(
 	DECACHE_STACK_INFO();
 	pc += 6;
 	TEBC_YIELD();
+
 	TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
-	iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+	TclDeferCallbacks(interp, /*skip tailcalls */ 1);
 	return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
 
     /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 537afb3..6cf594e 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;
 
@@ -2250,7 +2250,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:
@@ -2805,8 +2804,8 @@ 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  TclDeferCallbacks(Tcl_Interp *interp, int skipTailcall);
 
 /*
  * This structure holds the data for the various iteration callbacks used to
@@ -4808,35 +4807,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/tclInterp.c b/generic/tclInterp.c
index 0b0f652..2e90caf 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;
+    TclDeferCallbacks(interp, /* skip tailcalls */ 1);
     return Tcl_NREvalObj(interp, listPtr, flags);
 }
 
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 8da4b42..ee8aaa6 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;
+    TclDeferCallbacks(interp, /* skip tailcalls */ 1);
     return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
 }
 
-- 
cgit v0.12


From 0c2d5031a205445ac91209816f31a8a943b3921a Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 11 Jan 2013 12:42:14 +0000
Subject: Name functions according to 'what' instead of 'how' in the [tailcall]
 machinery, in view of making public some parts of it.

---
 generic/tclBasic.c    | 41 ++++++++++++++++++++++++-----------------
 generic/tclEnsemble.c |  4 ++--
 generic/tclExecute.c  |  2 +-
 generic/tclInt.h      |  7 +++++--
 generic/tclInterp.c   |  2 +-
 generic/tclNamesp.c   |  2 +-
 6 files changed, 34 insertions(+), 24 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 55014ec..b511d07 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -4309,14 +4309,6 @@ TclNREvalObjv(
     }
 }
 
-void
-TclPushTailcallPoint(
-    Tcl_Interp *interp)
-{
-    TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
-    ((Interp *) interp)->numLevels++;
-}
-
 int
 TclNRRunCallbacks(
     Tcl_Interp *interp,
@@ -4633,7 +4625,7 @@ TEOV_NotFound(
 	savedNsPtr = varFramePtr->nsPtr;
 	varFramePtr->nsPtr = lookupNsPtr;
     }
-    TclDeferCallbacks(interp, 1);
+    TclSkipTailcall(interp);
     TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
 	    newObjv, savedNsPtr, NULL);
     return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
@@ -6020,7 +6012,7 @@ TclNREvalObjEx(
 	    iPtr->cmdFramePtr = eoFramePtr;
 	}
 
-	TclDeferCallbacks(interp, 0);
+	TclMarkTailcall(interp);
         TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
 		NULL, NULL);
 
@@ -8278,22 +8270,37 @@ Tcl_NRCmdSwap(
  */
 
 void
-TclDeferCallbacks(
-    Tcl_Interp *interp,
-    int skipTailcalls)
+TclMarkTailcall(
+    Tcl_Interp *interp)
 {
     Interp *iPtr = (Interp *) interp;
 
     if (iPtr->deferredCallbacks == NULL) {
-	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(skipTailcalls != 0),
+	TclNRAddCallback(interp, NRCommand, NULL, NULL,
                 NULL, NULL);
         iPtr->deferredCallbacks = TOP_CB(interp);
-    } else if (skipTailcalls) {
-        iPtr->deferredCallbacks->data[1] = INT2PTR(skipTailcalls != 0);
     }
 }
 
 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,
     Tcl_Obj *listPtr)
@@ -8410,7 +8417,7 @@ TclNRTailcallEval(
      * Perform the tailcall
      */
 
-    TclDeferCallbacks(interp, 0);
+    TclMarkTailcall(interp);
     TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL);
     iPtr->lookupNsPtr = (Namespace *) nsPtr;
     return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 2753876..058590a 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -1914,7 +1914,7 @@ NsEnsembleImplementationCmdNR(
 	 * Hand off to the target command.
 	 */
 
-	TclDeferCallbacks(interp, /* skip tailcalls */ 1);
+	TclSkipTailcall(interp);
 	return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
     }
 
@@ -2122,7 +2122,7 @@ EnsembleUnknownCallback(
      */
 
     Tcl_Preserve(ensemblePtr);
-    TclDeferCallbacks (interp, /*skip tailcalls */ 1);
+    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 af60a95..303bafd 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3049,7 +3049,7 @@ TEBCresume(
 	TEBC_YIELD();
 
 	TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
-	TclDeferCallbacks(interp, /*skip tailcalls */ 1);
+	TclSkipTailcall(interp);
 	return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
 
     /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6cf594e..18768d9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2805,7 +2805,11 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
 
 MODULE_SCOPE void  TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
-MODULE_SCOPE void  TclDeferCallbacks(Tcl_Interp *interp, int skipTailcall);
+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
@@ -2880,7 +2884,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,
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 2e90caf..d5d43ed 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1800,7 +1800,7 @@ AliasNRCmd(
     if (isRootEnsemble) {
 	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
     }
-    TclDeferCallbacks(interp, /* skip tailcalls */ 1);
+    TclSkipTailcall(interp);
     return Tcl_NREvalObj(interp, listPtr, flags);
 }
 
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index ee8aaa6..304487b 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1945,7 +1945,7 @@ InvokeImportedNRCmd(
     ImportedCmdData *dataPtr = clientData;
     Command *realCmdPtr = dataPtr->realCmdPtr;
 
-    TclDeferCallbacks(interp, /* skip tailcalls */ 1);
+    TclSkipTailcall(interp);
     return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
 }
 
-- 
cgit v0.12


From 1092d1065d97d23b48062e4390604b39ff939aca Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 11 Jan 2013 17:27:38 +0000
Subject: Test for Bug 1884496 (not buggy on trunk).

---
 tests/parse.test | 9 +++++++++
 1 file changed, 9 insertions(+)

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
 }
 
-- 
cgit v0.12


From 84b9c7728c8f168edce68d529ddac68a5056e766 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Sat, 12 Jan 2013 21:57:24 +0000
Subject: Put back TclBackgroundException in internal stub table, so extensions
 using this, compiled against 8.5 headers still run in Tcl 8.6.

---
 ChangeLog             |  6 ++++++
 generic/tclInt.decls  |  6 +++---
 generic/tclIntDecls.h | 10 +++++++---
 generic/tclStubInit.c |  3 ++-
 4 files changed, 18 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 1655e15..5db7896 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2013-01-12  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclInt.decls: Put back TclBackgroundException in
+	internal stub table, so extensions using this, compiled
+	against 8.5 headers still run in Tcl 8.6.
+
 2013-01-09  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* library/http/http.tcl: [Bug 3599395]: http assumes status line
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index f215d32..948cc01 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -941,9 +941,9 @@ declare 235 {
 
 
 # TIP 337 made this one public
-#declare 236 {
-#    void TclBackgroundException(Tcl_Interp *interp, int code)
-#}
+declare 236 {
+    void TclBackgroundException(Tcl_Interp *interp, int code)
+}
 
 # TIP #285: Script cancellation support.
 declare 237 {
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index df5ac97..6cf0beb 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -557,7 +557,8 @@ EXTERN Var *		TclVarHashCreateVar(TclVarHashTable *tablePtr,
 /* 235 */
 EXTERN void		TclInitVarHashTable(TclVarHashTable *tablePtr,
 				Namespace *nsPtr);
-/* Slot 236 is reserved */
+/* 236 */
+EXTERN void		TclBackgroundException(Tcl_Interp *interp, int code);
 /* 237 */
 EXTERN int		TclResetCancellation(Tcl_Interp *interp, int force);
 /* 238 */
@@ -842,7 +843,7 @@ typedef struct TclIntStubs {
     void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
     Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
     void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
-    void (*reserved236)(void);
+    void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
     int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
     int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
     int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
@@ -1252,7 +1253,8 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclVarHashCreateVar) /* 234 */
 #define TclInitVarHashTable \
 	(tclIntStubsPtr->tclInitVarHashTable) /* 235 */
-/* Slot 236 is reserved */
+#define TclBackgroundException \
+	(tclIntStubsPtr->tclBackgroundException) /* 236 */
 #define TclResetCancellation \
 	(tclIntStubsPtr->tclResetCancellation) /* 237 */
 #define TclNRInterpProc \
@@ -1289,4 +1291,6 @@ extern const TclIntStubs *tclIntStubsPtr;
 #undef TCL_STORAGE_CLASS
 #define TCL_STORAGE_CLASS DLLIMPORT
 
+#undef TclBackgroundException
+
 #endif /* _TCLINTDECLS */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 88ada19..14c838f 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -41,6 +41,7 @@
 #undef Tcl_FindExecutable
 #undef TclpGetPid
 #undef TclSockMinimumBuffers
+#define TclBackgroundException Tcl_BackgroundException
 
 /* See bug 510001: TclSockMinimumBuffers needs plat imp */
 #ifdef _WIN64
@@ -425,7 +426,7 @@ static const TclIntStubs tclIntStubs = {
     TclGetSrcInfoForPc, /* 233 */
     TclVarHashCreateVar, /* 234 */
     TclInitVarHashTable, /* 235 */
-    0, /* 236 */
+    TclBackgroundException, /* 236 */
     TclResetCancellation, /* 237 */
     TclNRInterpProc, /* 238 */
     TclNRInterpProcCore, /* 239 */
-- 
cgit v0.12