Attachment "zaplevel.patch" to
ticket [1998273fff]
added by
ferrieux
2008-06-20 04:55:14.
Index: tclCmdIL.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdIL.c,v
retrieving revision 1.139
diff -b -u -r1.139 tclCmdIL.c
--- tclCmdIL.c 30 May 2008 22:54:27 -0000 1.139
+++ tclCmdIL.c 14 Jun 2008 23:05:28 -0000
@@ -125,6 +125,8 @@
int objc, Tcl_Obj *const objv[]);
static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+static int InfoZapLevelCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,
@@ -167,6 +169,7 @@
{"globals", TclInfoGlobalsCmd, NULL},
{"hostname", InfoHostnameCmd, NULL},
{"level", InfoLevelCmd, NULL},
+ {"zaplevel", InfoZapLevelCmd, NULL},
{"library", InfoLibraryCmd, NULL},
{"loaded", InfoLoadedCmd, NULL},
{"locals", TclInfoLocalsCmd, NULL},
@@ -1461,6 +1464,72 @@
NULL);
return TCL_ERROR;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoZapLevelCmd --
+ *
+ * Called to implement the "info zaplevel" command that replaces by a
+ * reference to an empty string the references to the current frame's args
+ * (those in [lrange [info level 0] 1 end]). This has the nice property of
+ * allowing to pass unshared values through procs, enabling in-place
+ * optimizations in some primitives. The idiom for this is:
+ *
+ * proc f x {...;info zaplevel;lrange $x[unset]x 1 end}
+ *
+ * (notice the use of the K-free K: $s[unset x] removes a second reference,
+ * that of the local variable (and formal parameter) x)
+ *
+ * Handles the following syntax:
+ *
+ * info zaplevel
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a empty result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoZapLevelCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *nil;
+ int i;
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr;
+
+ if (objc != 1) { /* Just "info level" */
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ framePtr=iPtr->varFramePtr ;
+
+ if (framePtr == rootFramePtr) {
+ goto levelError;
+ }
+
+ nil=Tcl_NewObj();
+ for(i=1 /* keep func name */;i<framePtr->objc;i++)
+ {
+ Tcl_DecrRefCount(framePtr->objv[i]);
+ ((Tcl_Obj **)framePtr->objv)[i]=nil;
+ Tcl_IncrRefCount(framePtr->objv[i]);
+ }
+ return TCL_OK;
+
+ levelError:
+ Tcl_AppendResult(interp, "cannot zap toplevel",NULL);
+ return TCL_ERROR;
+}
/*
*----------------------------------------------------------------------
