From 369bd95896b7a34fbcf1780fe3bcae926771ecbf Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Sat, 23 Jan 2016 19:46:58 +0000
Subject: add a test to insure that callbacks run at the correct C-stack depth
 while unwinding the NRE stack.

---
 generic/tclTest.c | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/nre.test    |  4 ++++
 2 files changed, 57 insertions(+)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 5468c56..2ea3016 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -412,6 +412,12 @@ static int		TestNumUtfCharsCmd(ClientData clientData,
 static int		TestHashSystemHashCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+
+static int              NREUnwind_callback(ClientData data[], Tcl_Interp *interp,
+                            int result);
+static int		TestNREUnwind(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 static int		TestNRELevels(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -697,6 +703,8 @@ Tcltest_Init(
 	    NULL);
 #endif /* TCL_NO_DEPRECATED */
 
+    Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
+	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
@@ -6846,6 +6854,51 @@ TestgetintCmd(
 }
 
 static int
+NREUnwind_callback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    int none;
+
+    if (data[0] == INT2PTR(-1)) {
+        TclNRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
+                INT2PTR(-1), NULL);
+    } else if (data[1] == INT2PTR(-1)) {
+        TclNRAddCallback(interp, NREUnwind_callback, data[0], &none,
+                INT2PTR(-1), NULL);
+    } else if (data[2] == INT2PTR(-1)) {
+        TclNRAddCallback(interp, NREUnwind_callback, data[0], data[1],
+                &none, NULL);
+    } else {
+        Tcl_Obj *idata[3];
+        idata[0] = Tcl_NewIntObj((int) (data[1] - data[0]));
+        idata[1] = Tcl_NewIntObj((int) (data[2] - data[0]));
+        idata[2] = Tcl_NewIntObj((int) ((void *) &none   - data[0]));
+        Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
+    }
+    return TCL_OK;
+}
+
+static int
+TestNREUnwind(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    /*
+     * Insure that callbacks effectively run at the proper level during the
+     * unwinding of the NRE stack.
+     */
+    
+    TclNRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1),
+            INT2PTR(-1), NULL);
+    return TCL_OK;
+}
+
+
+static int
 TestNRELevels(
     ClientData clientData,
     Tcl_Interp *interp,
diff --git a/tests/nre.test b/tests/nre.test
index e512eac..9df5eb1 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -64,6 +64,10 @@ if {[testConstraint testnrelevels]} {
     namespace import testnre::*
 }
 
+test nre-0.1 {levels while unwinding} {
+    testnreunwind
+} {0 0 0}
+
 test nre-1.1 {self-recursive procs} -setup {
     proc a i [makebody {a $i}]
 } -body {
-- 
cgit v0.12