summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2016-01-23 19:46:58 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2016-01-23 19:46:58 (GMT)
commit369bd95896b7a34fbcf1780fe3bcae926771ecbf (patch)
treefdbc5619d18fd842c01e817086b0c291a5c00ecb
parent64d35cac9591025ab8c2423b56e7e180779ef923 (diff)
downloadtcl-369bd95896b7a34fbcf1780fe3bcae926771ecbf.zip
tcl-369bd95896b7a34fbcf1780fe3bcae926771ecbf.tar.gz
tcl-369bd95896b7a34fbcf1780fe3bcae926771ecbf.tar.bz2
add a test to insure that callbacks run at the correct C-stack depth while unwinding the NRE stack.
-rw-r--r--generic/tclTest.c53
-rw-r--r--tests/nre.test4
2 files changed, 57 insertions, 0 deletions
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 {