* 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:

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:
+ */
+