Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.2270
diff -u -r1.2270 ChangeLog
--- ChangeLog	29 Sep 2004 22:37:12 -0000	1.2270
+++ ChangeLog	30 Sep 2004 15:31:10 -0000
@@ -1,3 +1,9 @@
+2004-09-30  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
+
+	* generic/tclProc.c (TclObjGetFrame, Tcl_UplevelObjCmd): 
+	* generic/tclVar.c (Tcl_UpvarObjCmd): Cache stackframe level
+	references in the level object for speed.
+
 2004-09-29  Don Porter  <dgp@users.sourceforge.net>
 
 	* tests/basic.test (49.*):	New tests for TCL_EVAL_GLOBAL.
Index: generic/tclInt.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.decls,v
retrieving revision 1.79
diff -u -r1.79 tclInt.decls
--- generic/tclInt.decls	27 Sep 2004 16:24:24 -0000	1.79
+++ generic/tclInt.decls	30 Sep 2004 15:31:11 -0000
@@ -801,6 +801,10 @@
     int TclCompEvalObj (Tcl_Interp *interp, Tcl_Obj *objPtr)
 }
 
+declare 198 generic {
+    int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
+	    CallFrame **framePtrPtr)
+}
 
 ##############################################################################
 
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.176
diff -u -r1.176 tclInt.h
--- generic/tclInt.h	29 Sep 2004 22:17:31 -0000	1.176
+++ generic/tclInt.h	30 Sep 2004 15:31:12 -0000
@@ -1670,6 +1670,7 @@
 extern Tcl_ObjType	tclWideIntType;
 extern Tcl_ObjType	tclLocalVarNameType;
 extern Tcl_ObjType	tclRegexpType;
+extern Tcl_ObjType	tclLevelReferenceType;
 
 /*
  * Variables denoting the hash key types defined in the core.
Index: generic/tclIntDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIntDecls.h,v
retrieving revision 1.69
diff -u -r1.69 tclIntDecls.h
--- generic/tclIntDecls.h	27 Sep 2004 16:24:24 -0000	1.69
+++ generic/tclIntDecls.h	30 Sep 2004 15:31:12 -0000
@@ -1013,6 +1013,12 @@
 EXTERN int		TclCompEvalObj _ANSI_ARGS_((Tcl_Interp * interp, 
 				Tcl_Obj * objPtr));
 #endif
+#ifndef TclObjGetFrame_TCL_DECLARED
+#define TclObjGetFrame_TCL_DECLARED
+/* 198 */
+EXTERN int		TclObjGetFrame _ANSI_ARGS_((Tcl_Interp * interp, 
+				Tcl_Obj * objPtr, CallFrame ** framePtrPtr));
+#endif
 
 typedef struct TclIntStubs {
     int magic;
@@ -1231,6 +1237,7 @@
     void (*tclFinalizeThreadStorageData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 195 */
     void (*tclFinalizeThreadStorageDataKey) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 196 */
     int (*tclCompEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 197 */
+    int (*tclObjGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); /* 198 */
 } TclIntStubs;
 
 #ifdef __cplusplus
@@ -1910,6 +1917,10 @@
 #define TclCompEvalObj \
 	(tclIntStubsPtr->tclCompEvalObj) /* 197 */
 #endif
+#ifndef TclObjGetFrame
+#define TclObjGetFrame \
+	(tclIntStubsPtr->tclObjGetFrame) /* 198 */
+#endif
 
 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
 
Index: generic/tclObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclObj.c,v
retrieving revision 1.70
diff -u -r1.70 tclObj.c
--- generic/tclObj.c	29 Sep 2004 22:22:50 -0000	1.70
+++ generic/tclObj.c	30 Sep 2004 15:31:12 -0000
@@ -292,6 +292,7 @@
     Tcl_RegisterObjType(&tclCmdNameType);
     Tcl_RegisterObjType(&tclLocalVarNameType);
     Tcl_RegisterObjType(&tclRegexpType);
+    Tcl_RegisterObjType(&tclLevelReferenceType);
 
 #ifdef TCL_COMPILE_STATS
     Tcl_MutexLock(&tclObjMutex);
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.56
diff -u -r1.56 tclProc.c
--- generic/tclProc.c	26 Sep 2004 16:36:04 -0000	1.56
+++ generic/tclProc.c	30 Sep 2004 15:31:12 -0000
@@ -41,6 +41,20 @@
     ProcBodyUpdateString,	/* UpdateString procedure */
     ProcBodySetFromAny		/* SetFromAny procedure */
 };
+
+/*
+ * The [upvar]/[uplevel] level reference type.  Uses the twoPtrValue
+ * field, encoding the type of level reference in ptr1 and the actual
+ * parsed out offset in ptr2.
+ *
+ * Uses the default behaviour throughout, and never disposes of the
+ * string rep; it's just a cache type.
+ */
+
+Tcl_ObjType tclLevelReferenceType = {
+    "levelReference",
+    NULL, NULL, NULL, NULL
+};
 
 /*
  *----------------------------------------------------------------------
@@ -538,9 +552,9 @@
  */
 
 int
-TclGetFrame(interp, string, framePtrPtr)
+TclGetFrame(interp, name, framePtrPtr)
     Tcl_Interp *interp;		/* Interpreter in which to find frame. */
-    CONST char *string;		/* String describing frame. */
+    CONST char *name;		/* String describing frame. */
     CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL
 				 * if global frame indicated). */
 {
@@ -554,18 +568,18 @@
 
     result = 1;
     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
-    if (*string == '#') {
-	if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
+    if (*name== '#') {
+	if (Tcl_GetInt(interp, name+1, &level) != TCL_OK) {
 	    return -1;
 	}
 	if (level < 0) {
 	    levelError:
-	    Tcl_AppendResult(interp, "bad level \"", string, "\"",
+	    Tcl_AppendResult(interp, "bad level \"", name, "\"",
 		    (char *) NULL);
 	    return -1;
 	}
-    } else if (isdigit(UCHAR(*string))) { /* INTL: digit */
-	if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
+    } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
+	if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
 	    return -1;
 	}
 	level = curLevel - level;
@@ -574,11 +588,121 @@
 	result = 0;
     }
 
+    /* Figure out which frame to use, and return it to the caller */
+
+    if (level == 0) {
+	framePtr = NULL;
+    } else {
+	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
+		framePtr = framePtr->callerVarPtr) {
+	    if (framePtr->level == level) {
+		break;
+	    }
+	}
+	if (framePtr == NULL) {
+	    goto levelError;
+	}
+    }
+    *framePtrPtr = framePtr;
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjGetFrame --
+ *
+ *	Given a description of a procedure frame, such as the first
+ *	argument to an "uplevel" or "upvar" command, locate the
+ *	call frame for the appropriate level of procedure.
+ *
+ * Results:
+ *	The return value is -1 if an error occurred in finding the frame
+ *	(in this case an error message is left in the interp's result).
+ *	1 is returned if objPtr was either a number or a number preceded
+ *	by "#" and it specified a valid frame.  0 is returned if objPtr
+ *	isn't one of the two things above (in this case, the lookup
+ *	acts as if objPtr were "1").  The variable pointed to by
+ *	framePtrPtr is filled in with the address of the desired frame
+ *	(unless an error occurs, in which case it isn't modified).
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjGetFrame(interp, objPtr, framePtrPtr)
+    Tcl_Interp *interp;		/* Interpreter in which to find frame. */
+    Tcl_Obj *objPtr;		/* Object describing frame. */
+    CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL
+				 * if global frame indicated). */
+{
+    register Interp *iPtr = (Interp *) interp;
+    int curLevel, level, result;
+    CallFrame *framePtr;
+    CONST char *name = TclGetString(objPtr);
+
     /*
-     * Figure out which frame to use, and modify the interpreter so
-     * its variables come from that frame.
+     * Parse object to figure out which level number to go to.
      */
 
+    result = 1;
+    curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
+    if (objPtr->typePtr == &tclLevelReferenceType) {
+	if ((int) objPtr->internalRep.twoPtrValue.ptr1) {
+	    level = curLevel - (int) objPtr->internalRep.twoPtrValue.ptr2;
+	} else {
+	    level = (int) objPtr->internalRep.twoPtrValue.ptr2;
+	}
+	if (level < 0) {
+	    goto levelError;
+	}
+    } else if (objPtr->typePtr == &tclIntType ||
+	    objPtr->typePtr == &tclWideIntType) {
+	if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
+	    goto levelError;
+	}
+	level = curLevel - level;
+    } else {
+	if (*name == '#') {
+	    if (Tcl_GetInt(interp, name+1, &level) != TCL_OK) {
+		return -1;
+	    }
+	    if (level < 0) {
+		goto levelError;
+	    }
+	    /*
+	     * Cache for future reference.
+	     */
+	    TclFreeIntRep(objPtr);
+	    objPtr->typePtr = &tclLevelReferenceType;
+	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 0;
+	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
+	} else if (isdigit(UCHAR(*name))) { /* INTL: digit */
+	    if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
+		return -1;
+	    }
+	    /*
+	     * Cache for future reference.
+	     */
+	    TclFreeIntRep(objPtr);
+	    objPtr->typePtr = &tclLevelReferenceType;
+	    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 1;
+	    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
+	    level = curLevel - level;
+	} else {
+	    /*
+	     * Don't cache as the object *isn't* a level reference.
+	     */
+	    level = curLevel - 1;
+	    result = 0;
+	}
+    }
+
+    /* Figure out which frame to use, and return it to the caller */
+
     if (level == 0) {
 	framePtr = NULL;
     } else {
@@ -594,6 +718,10 @@
     }
     *framePtrPtr = framePtr;
     return result;
+
+levelError:
+    Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL);
+    return -1;
 }
 
 /*
@@ -622,7 +750,6 @@
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
     register Interp *iPtr = (Interp *) interp;
-    char *optLevel;
     int result;
     CallFrame *savedVarFramePtr, *framePtr;
 
@@ -636,8 +763,7 @@
      * Find the level to use for executing the command.
      */
 
-    optLevel = TclGetString(objv[1]);
-    result = TclGetFrame(interp, optLevel, &framePtr);
+    result = TclObjGetFrame(interp, objv[1], &framePtr);
     if (result == -1) {
 	return TCL_ERROR;
     }
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.103
diff -u -r1.103 tclStubInit.c
--- generic/tclStubInit.c	27 Sep 2004 16:24:26 -0000	1.103
+++ generic/tclStubInit.c	30 Sep 2004 15:31:13 -0000
@@ -282,6 +282,7 @@
     TclFinalizeThreadStorageData, /* 195 */
     TclFinalizeThreadStorageDataKey, /* 196 */
     TclCompEvalObj, /* 197 */
+    TclObjGetFrame, /* 198 */
 };
 
 TclIntPlatStubs tclIntPlatStubs = {
Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.92
diff -u -r1.92 tclVar.c
--- generic/tclVar.c	29 Sep 2004 22:17:28 -0000	1.92
+++ generic/tclVar.c	30 Sep 2004 15:31:14 -0000
@@ -3877,7 +3877,7 @@
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
     CallFrame *framePtr;
-    char *frameSpec, *localName;
+    char *localName;
     int result;
 
     if (objc < 3) {
@@ -3892,8 +3892,7 @@
      * linked to. 
      */
 
-    frameSpec = TclGetString(objv[1]);
-    result = TclGetFrame(interp, frameSpec, &framePtr);
+    result = TclObjGetFrame(interp, objv[1], &framePtr);
     if (result == -1) {
 	return TCL_ERROR;
     }
