diff options
Diffstat (limited to 'generic/tclCmdIL.c')
| -rw-r--r-- | generic/tclCmdIL.c | 297 |
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: + */ + |