merge 8.6 (apply SF fix)

1 files changed, 83 insertions, 1 deletions

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:
  */
+