summaryrefslogtreecommitdiffstats
path: root/generic/tclTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r--generic/tclTest.c38
1 files changed, 37 insertions, 1 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 3052cc9..4ce4277 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.118 2008/07/28 21:31:19 nijtmans Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.119 2008/07/29 05:30:38 msofer Exp $
*/
#define TCL_TEST
@@ -402,6 +402,9 @@ static int TestNumUtfCharsCmd(ClientData clientData,
static int TestHashSystemHashCmd(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[]);
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
@@ -658,6 +661,10 @@ Tcltest_Init(
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
(ClientData) 0);
+ Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
+ (ClientData) NULL, NULL);
+
+
#ifdef TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
@@ -6527,6 +6534,35 @@ TestgetintCmd(
}
}
+static int
+TestNRELevels(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ static ptrdiff_t *refDepth = NULL;
+ ptrdiff_t depth;
+ Tcl_Obj *levels[5];
+
+ if (refDepth == NULL) {
+ refDepth = &depth;
+ }
+
+ depth = (refDepth - &depth);
+
+ levels[0] = Tcl_NewIntObj(depth);
+ levels[1] = Tcl_NewIntObj(((Interp *)interp)->numLevels);
+ levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level);
+ levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
+ levels[4] = Tcl_NewIntObj((iPtr->execEnvPtr->execStackPtr->tosPtr
+ - iPtr->execEnvPtr->execStackPtr->stackWords));
+
+ Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels));
+ return TCL_OK;
+}
+
/*
* Local Variables:
* mode: c