summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2006-11-28 22:19:57 (GMT)
committerandreas_kupries <akupries@shaw.ca>2006-11-28 22:19:57 (GMT)
commitbf08959966d3a565773dbddb52b0be2e0747ec3a (patch)
treedfdbbd337f6bf772d6f99a7a6ea50aaaab685d00 /generic/tclCmdIL.c
parent78afab8ec5cb163b94f8fed86fb67d9e339d9268 (diff)
downloadtcl-bf08959966d3a565773dbddb52b0be2e0747ec3a.zip
tcl-bf08959966d3a565773dbddb52b0be2e0747ec3a.tar.gz
tcl-bf08959966d3a565773dbddb52b0be2e0747ec3a.tar.bz2
* generic/tclBasic.c: TIP #280 implementation, conditional on the define TCL_TIP280.
* generic/tclCmdAH.c: * generic/tclCmdIL.c: * generic/tclCmdMZ.c: * generic/tclCompCmds.c: * generic/tclCompExpr.c: * generic/tclCompile.c: * generic/tclCompile.h: * generic/tclExecute.c: * generic/tclIOUtil.c: * generic/tclInt.h: * generic/tclInterp.c: * generic/tclNamesp.c: * generic/tclObj.c: * generic/tclProc.c: * tests/compile.test: * tests/info.test: * tests/platform.test: * tests/safe.test:
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c297
1 files changed, 291 insertions, 6 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index a867272..d44ba7a 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -15,7 +15,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.47.2.9 2005/12/09 14:39:25 dkf Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.10 2006/11/28 22:20:00 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -109,6 +109,12 @@ static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+#ifdef TCL_TIP280
+/* TIP #280 - New 'info' subcommand 'frame' */
+static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+#endif
static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
@@ -188,6 +194,9 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int thenScriptIndex = 0; /* then script to be evaled after syntax check */
+#ifdef TCL_TIP280
+ Interp* iPtr = (Interp*) interp;
+#endif
int i, result, value;
char *clause;
i = 1;
@@ -240,7 +249,13 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
i++;
if (i >= objc) {
if (thenScriptIndex) {
+#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
+#else
+ /* TIP #280. Make invoking context available to branch */
+ return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
+ iPtr->cmdFramePtr,thenScriptIndex);
+#endif
}
return TCL_OK;
}
@@ -274,9 +289,19 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
if (thenScriptIndex) {
+#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
+#else
+ /* TIP #280. Make invoking context available to branch/else */
+ return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
+ iPtr->cmdFramePtr,thenScriptIndex);
+#endif
}
+#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[i], 0);
+#else
+ return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i);
+#endif
}
/*
@@ -397,16 +422,24 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
- "args", "body", "cmdcount", "commands",
- "complete", "default", "exists", "functions", "globals",
- "hostname", "level", "library", "loaded",
+ "args", "body", "cmdcount", "commands",
+ "complete", "default", "exists",
+#ifdef TCL_TIP280
+ "frame",
+#endif
+ "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,
+#ifdef TCL_TIP280
+ IFrameIdx,
+#endif
+ IFunctionsIdx,
+ IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
};
@@ -445,6 +478,12 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
case IExistsIdx:
result = InfoExistsCmd(clientData, interp, objc, objv);
break;
+#ifdef TCL_TIP280
+ case IFrameIdx:
+ /* TIP #280 - New method 'frame' */
+ result = InfoFrameCmd(clientData, interp, objc, objv);
+ break;
+#endif
case IFunctionsIdx:
result = InfoFunctionsCmd(clientData, interp, objc, objv);
break;
@@ -997,6 +1036,243 @@ InfoExistsCmd(dummy, interp, objc, objv)
return TCL_OK;
}
+#ifdef TCL_TIP280
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ 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);
+ }
+ 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;
+}
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -3993,3 +4269,12 @@ DictionaryCompare(left, right)
}
return diff;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
+