summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c278
1 files changed, 270 insertions, 8 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 8519de8..712cbc0 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.95 2006/11/15 20:08:43 dgp Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.96 2006/11/28 22:20:28 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -114,6 +114,10 @@ static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
static int InfoExistsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
+/* TIP #280 - New 'info' subcommand 'frame' */
+static int InfoFrameCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]);
static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
static int InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
@@ -182,6 +186,7 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
{
int thenScriptIndex = 0; /* "then" script to be evaled after
* syntax check */
+ Interp* iPtr = (Interp*) interp;
int i, result, value;
char *clause;
i = 1;
@@ -233,7 +238,9 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
i++;
if (i >= objc) {
if (thenScriptIndex) {
- return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
+ /* TIP #280. Make invoking context available to branch */
+ return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
+ iPtr->cmdFramePtr,thenScriptIndex);
}
return TCL_OK;
}
@@ -267,9 +274,11 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
if (thenScriptIndex) {
- return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
+ /* TIP #280. Make invoking context available to branch/else */
+ return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
+ iPtr->cmdFramePtr,thenScriptIndex);
}
- return Tcl_EvalObjEx(interp, objv[i], 0);
+ return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i);
}
/*
@@ -358,15 +367,15 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
{
static CONST char *subCmds[] = {
"args", "body", "cmdcount", "commands",
- "complete", "default", "exists", "functions", "globals",
- "hostname", "level", "library", "loaded",
+ "complete", "default", "exists", "frame", "functions",
+ "globals", "hostname", "level", "library", "loaded",
"locals", "nameofexecutable", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
- ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx,
- IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
+ ICompleteIdx, IDefaultIdx, IExistsIdx, IFrameIdx, IFunctionsIdx,
+ IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
};
@@ -405,6 +414,10 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
case IExistsIdx:
result = InfoExistsCmd(clientData, interp, objc, objv);
break;
+ case IFrameIdx:
+ /* TIP #280 - New method 'frame' */
+ result = InfoFrameCmd(clientData, interp, objc, objv);
+ break;
case IFunctionsIdx:
result = InfoFunctionsCmd(clientData, interp, objc, objv);
break;
@@ -1073,6 +1086,255 @@ InfoExistsCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * InfoFrameCmd --
+ * TIP #280
+ *
+ * Called to implement the "info frame" command that returns the
+ * location of either the currently executing command, or its caller.
+ * Handles the following syntax:
+ *
+ * info frame ?number?
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoFrameCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (objc == 2) {
+ /* just "info frame" */
+ int levels = (iPtr->cmdFramePtr == NULL
+ ? 0
+ : iPtr->cmdFramePtr->level);
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), levels);
+ return TCL_OK;
+
+ } else if (objc == 3) {
+ /* "info frame level" */
+ int level;
+ CmdFrame *framePtr;
+
+ if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level <= 0) {
+ /* Relative adressing */
+
+ if (iPtr->cmdFramePtr == NULL) {
+ levelError:
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad level \"",
+ Tcl_GetString(objv[2]),
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ /* Convert to absolute. */
+
+ level += iPtr->cmdFramePtr->level;
+ }
+ for (framePtr = iPtr->cmdFramePtr;
+ framePtr != NULL;
+ framePtr = framePtr->nextPtr) {
+
+ if (framePtr->level == level) {
+ break;
+ }
+ }
+ if (framePtr == NULL) {
+ goto levelError;
+ }
+
+ /*
+ * Pull the information and construct the dictionary to return, as
+ * list. Regarding use of the CmdFrame fields see tclInt.h, and its
+ * definition.
+ */
+
+ {
+ Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */
+ int lc = 0;
+
+ /* This array is indexed by the TCL_LOCATION_... values, except
+ * for _LAST.
+ */
+
+ static CONST char* typeString [TCL_LOCATION_LAST] = {
+ "eval", "eval", "eval", "precompiled", "source", "proc"
+ };
+
+ switch (framePtr->type) {
+ case TCL_LOCATION_EVAL:
+ /* Evaluation, dynamic script. Type, line, cmd, the latter
+ * through str. */
+
+ lv [lc ++] = Tcl_NewStringObj ("type",-1);
+ lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
+ lv [lc ++] = Tcl_NewStringObj ("line",-1);
+ lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
+ lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
+ lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
+ framePtr->cmd.str.len);
+ break;
+
+ case TCL_LOCATION_EVAL_LIST:
+ /* List optimized evaluation. Type, line, cmd, the latter
+ * through listPtr, possibly a frame. */
+
+ lv [lc ++] = Tcl_NewStringObj ("type",-1);
+ lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
+ lv [lc ++] = Tcl_NewStringObj ("line",-1);
+ lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
+
+ /* We put a duplicate of the command list obj into the result
+ * to ensure that the 'pure List'-property of the command
+ * itself is not destroyed. Otherwise the query here would
+ * disable the list optimization path in Tcl_EvalObjEx.
+ */
+
+ lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
+ lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr);
+ break;
+
+ case TCL_LOCATION_PREBC:
+ /* Precompiled. Result contains the type as signal, nothing
+ * else */
+
+ lv [lc ++] = Tcl_NewStringObj ("type",-1);
+ lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
+ break;
+
+ case TCL_LOCATION_BC: {
+ /* Execution of bytecode. Talk to the BC engine to fill out
+ * the frame. */
+
+ CmdFrame f = *framePtr;
+ Proc* procPtr = f.framePtr ? f.framePtr->procPtr : NULL;
+
+ /* Note: Type BC => f.data.eval.path is not used.
+ * f.data.tebc.codePtr is used instead.
+ */
+
+ TclGetSrcInfoForPc (&f);
+ /* Now filled: cmd.str.(cmd,len), line */
+ /* Possibly modified: type, path! */
+
+ lv [lc ++] = Tcl_NewStringObj ("type",-1);
+ lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1);
+ lv [lc ++] = Tcl_NewStringObj ("line",-1);
+ lv [lc ++] = Tcl_NewIntObj (f.line[0]);
+
+ if (f.type == TCL_LOCATION_SOURCE) {
+ lv [lc ++] = Tcl_NewStringObj ("file",-1);
+ lv [lc ++] = f.data.eval.path;
+ /* Death of reference by TclGetSrcInfoForPc */
+ Tcl_DecrRefCount (f.data.eval.path);
+ }
+
+ lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
+ lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len);
+
+ if (procPtr != NULL) {
+ Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr;
+
+ if (namePtr) {
+ /* Regular command. */
+ char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr);
+ char* nsName = procPtr->cmdPtr->nsPtr->fullName;
+
+ lv [lc ++] = Tcl_NewStringObj ("proc",-1);
+ lv [lc ++] = Tcl_NewStringObj (nsName,-1);
+
+ if (strcmp (nsName, "::") != 0) {
+ Tcl_AppendToObj (lv [lc-1], "::", -1);
+ }
+ Tcl_AppendToObj (lv [lc-1], procName, -1);
+ } else {
+ /* Lambda execution. The lambda in question is stored
+ * in the clientData of the cmdPtr. See the #280 HACK
+ * in Tcl_ApplyObjCmd. There is no separate namespace
+ * to consider, if any is used it is part of the
+ * lambda term.
+ */
+
+ lv [lc ++] = Tcl_NewStringObj ("lambda",-1);
+ lv [lc ++] = ((Tcl_Obj*) procPtr->cmdPtr->clientData);
+ }
+ }
+ break;
+ }
+
+ case TCL_LOCATION_SOURCE:
+ /* Evaluation of a script file */
+
+ lv [lc ++] = Tcl_NewStringObj ("type",-1);
+ lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
+ lv [lc ++] = Tcl_NewStringObj ("line",-1);
+ lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
+ lv [lc ++] = Tcl_NewStringObj ("file",-1);
+ lv [lc ++] = framePtr->data.eval.path;
+ /* Refcount framePtr->data.eval.path goes up when lv
+ * is converted into the result list object.
+ */
+ lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
+ lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
+ framePtr->cmd.str.len);
+ break;
+
+ case TCL_LOCATION_PROC:
+ Tcl_Panic ("TCL_LOCATION_PROC found in standard frame");
+ break;
+ }
+
+
+ /* 'level'. Common to all frame types. Conditional on having an
+ * associated _visible_ CallFrame */
+
+ if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
+ CallFrame* current = framePtr->framePtr;
+ CallFrame* top = iPtr->varFramePtr;
+ CallFrame* idx;
+
+ for (idx = top;
+ idx != NULL;
+ idx = idx->callerVarPtr) {
+ if (idx == current) {
+ int c = framePtr->framePtr->level;
+ int t = iPtr->varFramePtr->level;
+
+ lv [lc ++] = Tcl_NewStringObj ("level",-1);
+ lv [lc ++] = Tcl_NewIntObj (t - c);
+ break;
+ }
+ }
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv));
+ return TCL_OK;
+ }
+ }
+
+ Tcl_WrongNumArgs(interp, 2, objv, "?number?");
+
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* InfoFunctionsCmd --
*
* Called to implement the "info functions" command that returns the list