Attachment "call.patch" to
ticket [1590790fff]
added by
msofer
2006-11-05 19:32:54.
Index: doc/info.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/info.n,v
retrieving revision 1.17
diff -u -r1.17 info.n
--- doc/info.n 30 May 2005 00:04:45 -0000 1.17
+++ doc/info.n 5 Nov 2006 12:18:52 -0000
@@ -34,6 +34,23 @@
Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be
the name of a Tcl command procedure.
.TP
+\fBinfo call\fR ?\fInumber\fR?
+If \fInumber\fR is not specified, this command returns a number
+giving the stack level of the invoking procedure, or 0 if the
+command is invoked at top-level. If \fInumber\fR is specified,
+then the result is a list consisting of the name and arguments for the
+procedure call at level \fInumber\fR on the stack as seen in the source.
+If there were aliases or ensembles involved in the call, this will differ
+from the actual arguments of the procedure call, which can bve retrieved
+with \fbinfo level \fR. The sequence [uplevel 1 [info call 0]] reproduces
+the current call.
+If \fInumber\fR
+is positive then it selects a particular stack level (1 refers
+to the top-most active procedure, 2 to the procedure it called, and
+so on); otherwise it gives a level relative to the current level
+(0 refers to the current procedure, -1 to its caller, and so on).
+See the \fBuplevel\fR command for more information on what stack
+levels mean.
\fBinfo cmdcount\fR
Returns a count of the total number of commands that have been invoked
in this interpreter.
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.226
diff -u -r1.226 tcl.h
--- generic/tcl.h 31 Oct 2006 15:23:40 -0000 1.226
+++ generic/tcl.h 5 Nov 2006 12:18:54 -0000
@@ -954,6 +954,8 @@
int dummy9;
char *dummy10;
char *dummy11;
+ int dummy12;
+ char *dummy13;
} Tcl_CallFrame;
/*
Index: generic/tclCmdIL.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdIL.c,v
retrieving revision 1.92
diff -u -r1.92 tclCmdIL.c
--- generic/tclCmdIL.c 2 Nov 2006 15:58:05 -0000 1.92
+++ generic/tclCmdIL.c 5 Nov 2006 12:18:58 -0000
@@ -121,7 +121,7 @@
static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *CONST objv[], int isCall);
static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,
@@ -357,14 +357,14 @@
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
- "args", "body", "cmdcount", "commands",
+ "args", "body", "call", "cmdcount", "commands",
"complete", "default", "exists", "functions", "globals",
"hostname", "level", "library", "loaded",
"locals", "nameofexecutable", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
- IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
+ IArgsIdx, IBodyIdx, ICallIdx, ICmdCountIdx, ICommandsIdx,
ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx,
IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
@@ -390,6 +390,9 @@
case IBodyIdx:
result = InfoBodyCmd(clientData, interp, objc, objv);
break;
+ case ICallIdx:
+ result = InfoLevelCmd(clientData, interp, objc, objv, 1);
+ break;
case ICmdCountIdx:
result = InfoCmdCountCmd(clientData, interp, objc, objv);
break;
@@ -415,7 +418,7 @@
result = InfoHostnameCmd(clientData, interp, objc, objv);
break;
case ILevelIdx:
- result = InfoLevelCmd(clientData, interp, objc, objv);
+ result = InfoLevelCmd(clientData, interp, objc, objv, 0);
break;
case ILibraryIdx:
result = InfoLibraryCmd(clientData, interp, objc, objv);
@@ -1254,10 +1257,11 @@
*
* InfoLevelCmd --
*
- * Called to implement the "info level" command that returns information
- * about the call stack. Handles the following syntax:
+ * Called to implement the "info level" and "info call" commands that
+ * return information about the call stack. Handles the following syntax:
*
* info level ?number?
+ * info call ?number?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
@@ -1270,11 +1274,12 @@
*/
static int
-InfoLevelCmd(dummy, interp, objc, objv)
+InfoLevelCmd(dummy, interp, objc, objv, isCall)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
+ int isCall; /* 0 for info level, 1 for info call */
{
Interp *iPtr = (Interp *) interp;
int level;
@@ -1307,7 +1312,12 @@
goto levelError;
}
- listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
+ if (isCall && (framePtr->isProcCallFrame & FRAME_IS_EXTENDED)
+ && framePtr->callObjv) {
+ listPtr = Tcl_NewListObj(framePtr->callObjc, framePtr->callObjv);
+ } else {
+ listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
+ }
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.292
diff -u -r1.292 tclInt.h
--- generic/tclInt.h 2 Nov 2006 16:57:54 -0000 1.292
+++ generic/tclInt.h 5 Nov 2006 12:19:05 -0000
@@ -857,13 +857,21 @@
typedef struct CallFrame {
Namespace *nsPtr; /* Points to the namespace used to resolve
* commands and global variables. */
- int isProcCallFrame; /* If 0, the frame was pushed to execute a
- * namespace command and var references are
- * treated as references to namespace vars;
- * varTablePtr and compiledLocals are ignored.
- * If FRAME_IS_PROC is set, the frame was
+ int isProcCallFrame; /* If FRAME_IS_PROC is set, the frame was
* pushed to execute a Tcl procedure and may
- * have local vars. */
+ * have local vars. Otherwise, the frame was
+ * pushed to execute a namespace command and
+ * var references are treated as references to
+ * namespace vars; varTablePtr and
+ * compiledLocals are ignored.
+ * If FRAME_IS_EXTENDED is not set, the
+ * allocated struct is shorter than this
+ * definition; this is provided to permit
+ * binary compatibility with extensions
+ * compiled against 8.4 headers.
+ * This field should be called "flags"; the
+ * old name is retained to permit source
+ * compat with older extensions. */
int objc; /* This and objv below describe the arguments
* for this procedure call. */
Tcl_Obj *CONST *objv; /* Array of argument objects. */
@@ -897,6 +905,11 @@
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
+ /*
+ * This is the end of the struct if FRAME_IS_EXTENDED is not set in
+ * isProcCallFrame.
+ */
+
ClientData clientData; /* Pointer to some context that is used by
* object systems. The meaning of the contents
* of this field is defined by the code that
@@ -906,9 +919,14 @@
* have some means of discovering what the
* meaning of the value is, which we do not
* specify. */
+ int callObjc; /* This and below describe the source
+ * arguments that led to this frame being
+ * pushed, prior to any ensemble rewriting */
+ Tcl_Obj *CONST *callObjv;
} CallFrame;
-#define FRAME_IS_PROC 0x1
+#define FRAME_IS_PROC 0x1
+#define FRAME_IS_EXTENDED 0x2
/*
*----------------------------------------------------------------
@@ -1518,6 +1536,7 @@
*/
struct {
+ int numSourceObjs;
Tcl_Obj *CONST *sourceObjs;
/* What arguments were actually input into the
* *root* ensemble command? (Nested ensembles
Index: generic/tclInterp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInterp.c,v
retrieving revision 1.69
diff -u -r1.69 tclInterp.c
--- generic/tclInterp.c 2 Nov 2006 16:39:06 -0000 1.69
+++ generic/tclInterp.c 5 Nov 2006 12:19:05 -0000
@@ -1729,6 +1729,7 @@
*/
if (isRootEnsemble) {
+ tPtr->ensembleRewrite.numSourceObjs = objc;
tPtr->ensembleRewrite.sourceObjs = objv;
tPtr->ensembleRewrite.numRemovedObjs = 1;
tPtr->ensembleRewrite.numInsertedObjs = prefc;
@@ -1757,6 +1758,7 @@
*/
if (isRootEnsemble) {
+ tPtr->ensembleRewrite.numSourceObjs = 0;
tPtr->ensembleRewrite.sourceObjs = NULL;
tPtr->ensembleRewrite.numRemovedObjs = 0;
tPtr->ensembleRewrite.numInsertedObjs = 0;
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.117
diff -u -r1.117 tclNamesp.c
--- generic/tclNamesp.c 2 Nov 2006 16:57:54 -0000 1.117
+++ generic/tclNamesp.c 5 Nov 2006 12:19:13 -0000
@@ -549,9 +549,21 @@
* treated as references to namespace
* variables. */
{
- *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame));
- return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
- isProcCallFrame);
+ Interp *iPtr = (Interp *) interp;
+ int result;
+ CallFrame *framePtr;
+
+ framePtr = (CallFrame *) TclStackAlloc(interp, sizeof(CallFrame));
+ *framePtrPtr = (Tcl_CallFrame *) framePtr;
+ result = Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
+ (isProcCallFrame|FRAME_IS_EXTENDED));
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ framePtr->callObjc = iPtr->ensembleRewrite.numSourceObjs;
+ framePtr->callObjv = iPtr->ensembleRewrite.sourceObjs;
+ return TCL_OK;
}
void
@@ -6265,6 +6277,7 @@
Tcl_ListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv);
if (isRootEnsemble) {
+ iPtr->ensembleRewrite.numSourceObjs = objc;
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = 2;
iPtr->ensembleRewrite.numInsertedObjs = prefixObjc;
@@ -6286,6 +6299,7 @@
Tcl_DecrRefCount(prefixObj);
TclStackFree(interp);
if (isRootEnsemble) {
+ iPtr->ensembleRewrite.numSourceObjs = 0;
iPtr->ensembleRewrite.sourceObjs = NULL;
iPtr->ensembleRewrite.numRemovedObjs = 0;
iPtr->ensembleRewrite.numInsertedObjs = 0;
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.105
diff -u -r1.105 tclProc.c
--- generic/tclProc.c 2 Nov 2006 16:39:07 -0000 1.105
+++ generic/tclProc.c 5 Nov 2006 12:19:14 -0000
@@ -2220,6 +2220,7 @@
isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
if (isRootEnsemble) {
+ iPtr->ensembleRewrite.numSourceObjs = objc;
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = 1;
iPtr->ensembleRewrite.numInsertedObjs = 0;
@@ -2231,6 +2232,7 @@
&MakeLambdaError);
if (isRootEnsemble) {
+ iPtr->ensembleRewrite.numSourceObjs = 0;
iPtr->ensembleRewrite.sourceObjs = NULL;
iPtr->ensembleRewrite.numRemovedObjs = 0;
iPtr->ensembleRewrite.numInsertedObjs = 0;
Index: tests/info.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/info.test,v
retrieving revision 1.39
diff -u -r1.39 info.test
--- tests/info.test 31 Oct 2006 13:46:33 -0000 1.39
+++ tests/info.test 5 Nov 2006 12:19:15 -0000
@@ -664,16 +664,16 @@
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
test info-21.2 {miscellaneous error conditions} {
list [catch {info gorp} msg] $msg
-} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {bad option "gorp": must be args, body, call, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3 {miscellaneous error conditions} {
list [catch {info c} msg] $msg
-} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "c": must be args, body, call, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4 {miscellaneous error conditions} {
list [catch {info l} msg] $msg
-} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "l": must be args, body, call, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5 {miscellaneous error conditions} {
list [catch {info s} msg] $msg
-} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "s": must be args, body, call, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
