diff options
| author | Miguel Sofer <miguel.sofer@gmail.com> | 2016-01-23 19:46:58 (GMT) |
|---|---|---|
| committer | Miguel Sofer <miguel.sofer@gmail.com> | 2016-01-23 19:46:58 (GMT) |
| commit | 369bd95896b7a34fbcf1780fe3bcae926771ecbf (patch) | |
| tree | fdbc5619d18fd842c01e817086b0c291a5c00ecb | |
| parent | 64d35cac9591025ab8c2423b56e7e180779ef923 (diff) | |
| download | tcl-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.c | 53 | ||||
| -rw-r--r-- | tests/nre.test | 4 |
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 { |