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;
+}
 
 /*
  *----------------------------------------------------------------------
