merge 8.6 (apply SF fix)

3 files changed, 109 insertions, 3 deletions

diff --git a/generic/tclProc.c b/generic/tclProc.c
index 17635e7..311ea4e 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -1587,12 +1587,15 @@ TclPushProcCallFrame(
 	 * is up-to-date), the namespace must match (so variable handling
 	 * is right) and the resolverEpoch must match (so that new shadowed
 	 * commands and/or resolver changes are considered).
+	 * Ensure the ByteCode's procPtr is the same (or it's precompiled).
 	 */
 
 	if (((Interp *) *codePtr->interpHandle != iPtr)
 		|| (codePtr->compileEpoch != iPtr->compileEpoch)
 		|| (codePtr->nsPtr != nsPtr)
-		|| (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
+		|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
+		|| ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes)
+	) {
 	    goto doCompilation;
 	}
     } else {
@@ -1932,6 +1935,7 @@ TclProcCompileProc(
      * procPtr->numCompiledLocals if new local variables are found while
      * compiling.
      *
+     * Ensure the ByteCode's procPtr is the same (or it is pure precompiled).
      * Precompiled procedure bodies, however, are immutable and therefore they
      * are not recompiled, even if things have changed.
      */
@@ -1940,7 +1944,9 @@ TclProcCompileProc(
 	if (((Interp *) *codePtr->interpHandle == iPtr)
 		&& (codePtr->compileEpoch == iPtr->compileEpoch)
 		&& (codePtr->nsPtr == nsPtr)
-		&& (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
+		&& (codePtr->nsEpoch == nsPtr->resolverEpoch)
+		&& ((codePtr->procPtr == procPtr) || !bodyPtr->bytes)
+	) {
 	    return TCL_OK;
 	}
 
@@ -2155,6 +2161,13 @@ TclProcCleanupProc(
     Interp *iPtr = procPtr->iPtr;
 
     if (bodyPtr != NULL) {
+	/* procPtr is stored in body's ByteCode, so ensure to reset it. */
+	if (bodyPtr->typePtr == &tclByteCodeType) {
+	    ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
+	    if (codePtr->procPtr == procPtr) {
+		codePtr->procPtr = NULL;
+	    }
+	}
 	Tcl_DecrRefCount(bodyPtr);
     }
     for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index e3c6663..77540e2 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -342,6 +342,7 @@ static Tcl_ObjCmdProc	TestInterpResolverCmd;
 #if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
 static Tcl_ObjCmdProc	TestcpuidCmd;
 #endif
+static Tcl_ObjCmdProc	TestApplyLambdaObjCmd;
 
 static const Tcl_Filesystem testReportingFilesystem = {
     "reporting",
@@ -715,6 +716,8 @@ Tcltest_Init(
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd,
 	    NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd,
+	    NULL, NULL);
 
     if (TclObjTest_Init(interp) != TCL_OK) {
 	return TCL_ERROR;
@@ -8120,7 +8123,85 @@ TestInterpResolverCmd(
     }
     return TCL_OK;
 }
-
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TestApplyLambdaObjCmd --
+ *
+ *	Implements the Tcl command testapplylambda. This tests the apply
+ *	implementation handling of a lambda where the lambda has a list
+ *	internal representation where the second element's internal
+ *	representation is already a byte code object.
+ *
+ * Results:
+ *	TCL_OK    - Success. Caller should check result is 42
+ *	TCL_ERROR - Error.
+ *
+ * Side effects:
+ *	In the presence of the apply bug, may panic. Otherwise
+ *	Interpreter result holds result or error message.
+ *
+ *------------------------------------------------------------------------
+ */
+int TestApplyLambdaObjCmd (
+    ClientData notUsed,
+    Tcl_Interp *interp,    /* Current interpreter. */
+    int objc,              /* Number of arguments. */
+    Tcl_Obj *const objv[]) /* Argument objects. */
+{
+    Tcl_Obj *lambdaObjs[2];
+    Tcl_Obj *evalObjs[2];
+    Tcl_Obj *lambdaObj;
+    int result;
+
+    /* Create a lambda {{} {set a 42}} */
+    lambdaObjs[0] = Tcl_NewObj(); /* No parameters */
+    lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */
+    lambdaObj = Tcl_NewListObj(2, lambdaObjs);
+    Tcl_IncrRefCount(lambdaObj);
+
+    /* Create the command "apply {{} {set a 42}" */
+    evalObjs[0] = Tcl_NewStringObj("apply", -1);
+    Tcl_IncrRefCount(evalObjs[0]);
+    /*
+     * NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because
+     * it will get shimmered to a Lambda internal representation but we
+     * want to hold on to our list representation.
+     */
+    evalObjs[1] = Tcl_DuplicateObj(lambdaObj);
+    Tcl_IncrRefCount(evalObjs[1]);
+
+    /* Evaluate it */
+    result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
+    if (result != TCL_OK) {
+	Tcl_DecrRefCount(evalObjs[0]);
+	Tcl_DecrRefCount(evalObjs[1]);
+	return result;
+    }
+    /*
+     * So far so good. At this point,
+     * - evalObjs[1] has an internal representation of Lambda
+     * - lambdaObj[1] ({set a 42}) has been shimmered to
+     * an internal representation of ByteCode.
+     */
+    Tcl_DecrRefCount(evalObjs[1]); /* Don't need this anymore */
+    /*
+     * The bug trigger. Repeating the command but:
+     *  - we are calling apply with a lambda that is a list (as BEFORE),
+     *    BUT
+     *  - The body of the lambda (lambdaObjs[1]) ALREADY has internal
+     *    representation of ByteCode and thus will not be compiled again
+     */
+    evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so
+     				no need for IncrRef */
+    result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
+    Tcl_DecrRefCount(evalObjs[0]);
+    Tcl_DecrRefCount(lambdaObj);
+
+    return result;
+}
+
 /*
  * Local Variables:
  * mode: c
@@ -8130,3 +8211,4 @@ TestInterpResolverCmd(
  * indent-tabs-mode: nil
  * End:
  */
+
diff --git a/tests/apply.test b/tests/apply.test
index e2be172..a5f1f8f 100644
--- a/tests/apply.test
+++ b/tests/apply.test
@@ -16,12 +16,16 @@ if {"::tcltest" ni [namespace children]} {
     package require tcltest 2.5
     namespace import -force ::tcltest::*
 }
+::tcltest::loadTestedCommands
+catch [list package require -exact tcl::test [info patchlevel]]
 
 if {[info commands ::apply] eq {}} {
     return
 }
 
 testConstraint memory [llength [info commands memory]]
+testConstraint applylambda [llength [info commands testapplylambda]]
+
 
 # Tests for wrong number of arguments
 
@@ -306,6 +310,13 @@ test apply-9.3 {leaking internal rep} -setup {
     unset -nocomplain end i x tmp leakedBytes
 } -result 0
 
+# Tests for specific bugs
+test apply-10.1 {Test for precompiled bytecode body} -constraints {
+    applylambda
+} -body {
+    testapplylambda
+} -result 42
+
 # Tests for the avoidance of recompilation
 
 # cleanup