added tests covering bug [fa6bf38d07]

2 files changed, 57 insertions, 4 deletions

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 473368c..5e807d4 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -220,6 +220,9 @@ static void		SpecialFree(char *blockPtr);
 static int		StaticInitProc(Tcl_Interp *interp);
 static int		TestasyncCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, const char **argv);
+static int		TestbumpinterpepochObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 static int		TestpurebytesobjObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -584,6 +587,8 @@ Tcltest_Init(
     Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
 	    TestGetIndexFromObjStructObjCmd, NULL, NULL);
     Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testbumpinterpepoch",
+	    TestbumpinterpepochObjCmd, NULL, NULL);
     Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
 	    NULL, NULL);
     Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
@@ -1022,6 +1027,22 @@ AsyncThreadProc(
 }
 #endif
 
+static int
+TestbumpinterpepochObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    Interp *iPtr = (Interp *)interp;
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "");
+	return TCL_ERROR;
+    }
+    iPtr->compileEpoch++;
+    return TCL_OK;
+}
+
 /*
  *----------------------------------------------------------------------
  *
diff --git a/tests/execute.test b/tests/execute.test
index e9668a9..bc9dfcf 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -37,6 +37,11 @@ testConstraint testobj [expr {
 testConstraint longIs32bit [expr {int(0x80000000) < 0}]
 testConstraint testexprlongobj [llength [info commands testexprlongobj]]
 
+
+if {[namespace which -command testbumpinterpepoch] eq ""} {
+  proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
+}
+
 # Tests for the omnibus TclExecuteByteCode function:
 
 # INST_DONE not tested
@@ -933,8 +938,7 @@ test execute-8.3 {Stack restoration} -setup {
     proc f {args} "f $arglst"
     proc run {} {
 	# bump the interp's epoch
-	rename ::set ::dummy
-	rename ::dummy ::set
+	testbumpinterpepoch
 	catch f msg
 	set msg
     }
@@ -948,8 +952,7 @@ test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
     }
     proc FOO {} {
 	catch {error bar} m o
-	rename ::set ::dummy
-	rename ::dummy ::set
+	testbumpinterpepoch
 	return -options $o $m
     }
 } -body {
@@ -978,6 +981,35 @@ test execute-8.5 {Bug 2038069} -setup {
     invoked from within
 "catch \[list error FOO\] m o"} -errorline 2}
 
+test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
+    interp create slave
+    slave eval {
+	package require tcltest
+	catch [list package require -exact Tcltest [info patchlevel]]
+	::tcltest::loadTestedCommands
+	if {[namespace which -command testbumpinterpepoch] eq ""} {
+	  proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
+	}
+    }
+} -body {
+    slave eval {
+	lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
+    }
+    slave eval {
+	set i 0; while {[incr i] < 3} {
+	    lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
+	}
+    }
+    slave eval {
+	set i 0; while {[incr i] < 3} {
+	    lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
+	}
+    }
+    slave eval {set res}
+} -cleanup {
+    interp delete slave
+} -result [lrepeat 3 A B]
+
 test execute-9.1 {Interp result resetting [Bug 1522803]} {
     set c 0
     catch {