* generic/tclBasic.c: TIP #280 implementation.

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