More test and fixes to pass this tests, mainly about upvar.

3 files changed, 133 insertions, 16 deletions

diff --git a/jim.c b/jim.c
index 51488f9..8240575 100644
--- a/jim.c
+++ b/jim.c
@@ -3545,25 +3545,26 @@ void Jim_FreeInterp(Jim_Interp *i)
  * levelObjPtr into *framePtrPtr. If levelObjPtr == NULL, the
  * level is assumed to be '1'. */
 int Jim_GetCallFrameByLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr,
-		Jim_CallFrame **framePtrPtr)
+		Jim_CallFrame **framePtrPtr, int *newLevelPtr)
 {
 	long level;
 	char *str;
 	Jim_CallFrame *framePtr;
 
+	if (newLevelPtr) *newLevelPtr = interp->numLevels;
 	if (levelObjPtr) {
 		str = Jim_GetString(levelObjPtr, NULL);
 		if (str[0] == '#') {
 			char *endptr;
 			/* speedup for the toplevel (level #0) */
 			if (str[1] == '0' && str[2] == '\0') {
+				if (newLevelPtr) *newLevelPtr = 0;
 				*framePtrPtr = interp->topFramePtr;
 				return JIM_OK;
 			}
 
-			str++;
-			level = strtol(str, &endptr, 0);
-			if (str[0] == '\0' || endptr[0] != '\0' || level < 0)
+			level = strtol(str+1, &endptr, 0);
+			if (str[1] == '\0' || endptr[0] != '\0' || level < 0)
 				goto badlevel;
 			/* An 'absolute' level is converted into the
 			 * 'number of levels to go back' format. */
@@ -3575,10 +3576,12 @@ int Jim_GetCallFrameByLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr,
 				goto badlevel;
 		}
 	} else {
+		str = "1"; /* Needed to format the error message. */
 		level = 1;
 	}
 	/* Lookup */
 	framePtr = interp->framePtr;
+	if (newLevelPtr) *newLevelPtr = (*newLevelPtr)-level;
 	while (level--) {
 		framePtr = framePtr->parentCallFrame;
 		if (framePtr == NULL) goto badlevel;
@@ -3586,7 +3589,9 @@ int Jim_GetCallFrameByLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr,
 	*framePtrPtr = framePtr;
 	return JIM_OK;
 badlevel:
-	Jim_SetResultString(interp, "Bad level", -1);
+	Jim_SetResult(interp, Jim_NewEmptyStringObj(interp));
+	Jim_AppendStrings(interp, Jim_GetResult(interp),
+			"bad level \"", str, "\"", NULL);
 	return JIM_ERR;
 }
 
@@ -6784,12 +6789,15 @@ static int Jim_InfoLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr,
 {
 	Jim_CallFrame *targetCallFrame;
 
-	if (Jim_GetCallFrameByLevel(interp, levelObjPtr, &targetCallFrame)
+	if (Jim_GetCallFrameByLevel(interp, levelObjPtr, &targetCallFrame, NULL)
 			!= JIM_OK)
 		return JIM_ERR;
 	/* No proc call at toplevel callframe */
 	if (targetCallFrame == interp->topFramePtr) {
-		Jim_SetResultString(interp, "Bad level", -1);
+		Jim_SetResult(interp, Jim_NewEmptyStringObj(interp));
+		Jim_AppendStrings(interp, Jim_GetResult(interp),
+				"bad level \"",
+				Jim_GetString(levelObjPtr, NULL), "\"", NULL);
 		return JIM_ERR;
 	}
 	*objPtrPtr = Jim_NewListObj(interp,
@@ -7413,7 +7421,7 @@ int Jim_EvalCoreCommand(Jim_Interp *interp, int argc, Jim_Obj **argv)
 int Jim_UplevelCoreCommand(Jim_Interp *interp, int argc, Jim_Obj **argv)
 {
 	if (argc >= 2) {
-		int retcode;
+		int retcode, newLevel, oldLevel;
 		Jim_CallFrame *savedCallFrame, *targetCallFrame;
 		Jim_Obj *objPtr;
 		char *str;
@@ -7423,21 +7431,31 @@ int Jim_UplevelCoreCommand(Jim_Interp *interp, int argc, Jim_Obj **argv)
 
 		/* Lookup the target frame pointer */
 		str = Jim_GetString(argv[1], NULL);
-		if (argc >= 3 && 
-		    ((str[0] >= '0' && str[0] <= '9') || str[0] == '#'))
+		if ((str[0] >= '0' && str[0] <= '9') || str[0] == '#')
 		{
 			if (Jim_GetCallFrameByLevel(interp, argv[1],
-						&targetCallFrame) != JIM_OK)
+						&targetCallFrame,
+						&newLevel) != JIM_OK)
 				return JIM_ERR;
 			argc--;
 			argv++;
 		} else {
 			if (Jim_GetCallFrameByLevel(interp, NULL,
-						&targetCallFrame) != JIM_OK)
+						&targetCallFrame,
+						&newLevel) != JIM_OK)
 				return JIM_ERR;
 		}
+		if (argc < 2) {
+			argc++;
+			argv--;
+			Jim_WrongNumArgs(interp, 1, argv,
+					"?level? command ?arg ...?");
+			return JIM_ERR;
+		}
 		/* Eval the code in the target callframe. */
 		interp->framePtr = targetCallFrame;
+		oldLevel = interp->numLevels;
+		interp->numLevels = newLevel;
 		if (argc == 2) {
 			retcode = Jim_EvalObj(interp, argv[1]);
 		} else {
@@ -7446,10 +7464,11 @@ int Jim_UplevelCoreCommand(Jim_Interp *interp, int argc, Jim_Obj **argv)
 			retcode = Jim_EvalObj(interp, objPtr);
 			Jim_DecrRefCount(interp, objPtr);
 		}
+		interp->numLevels = oldLevel;
 		interp->framePtr = savedCallFrame;
 		return retcode;
 	} else {
-		Jim_WrongNumArgs(interp, 1, argv, "?level? script ?...?");
+		Jim_WrongNumArgs(interp, 1, argv, "?level? command ?arg ...?");
 		return JIM_ERR;
 	}
 }
@@ -7572,13 +7591,13 @@ int Jim_UpvarCoreCommand(Jim_Interp *interp, int argc, Jim_Obj **argv)
 	    ((str[0] >= '0' && str[0] <= '9') || str[0] == '#'))
 	{
 		if (Jim_GetCallFrameByLevel(interp, argv[1],
-					&targetCallFrame) != JIM_OK)
+					&targetCallFrame, NULL) != JIM_OK)
 			return JIM_ERR;
 		argc--;
 		argv++;
 	} else {
 		if (Jim_GetCallFrameByLevel(interp, NULL,
-					&targetCallFrame) != JIM_OK)
+					&targetCallFrame, NULL) != JIM_OK)
 			return JIM_ERR;
 	}
 	/* Check for arity */
diff --git a/jim.h b/jim.h
index a41658b..101367c 100644
--- a/jim.h
+++ b/jim.h
@@ -502,7 +502,7 @@ int JIM_API(Jim_UnsetVariable) (Jim_Interp *interp, Jim_Obj *nameObjPtr,
 
 /* call frame */
 int JIM_API(Jim_GetCallFrameByLevel) (Jim_Interp *interp, Jim_Obj *levelObjPtr,
-                Jim_CallFrame **framePtrPtr);
+                Jim_CallFrame **framePtrPtr, int *newLevelPtr);
 
 /* garbage collection */
 int JIM_API(Jim_Collect) (Jim_Interp *interp);
diff --git a/test.tcl b/test.tcl
index ed776f0..1c0dbec 100644
--- a/test.tcl
+++ b/test.tcl
@@ -1031,3 +1031,101 @@ test append-6.1 {lappend errors} {
 #    set x ""
 #    list [catch {lappend x(0) 44} msg] $msg
 #} {1 {can't set "x(0)": variable isn't array}}
+
+################################################################################
+# UPLEVEL
+################################################################################
+
+proc a {x y} {
+    newset z [expr $x+$y]
+    return $z
+}
+proc newset {name value} {
+    uplevel set $name $value
+    uplevel 1 {uplevel 1 {set xyz 22}}
+}
+
+test uplevel-1.1 {simple operation} {
+    set xyz 0
+    a 22 33
+} 55
+test uplevel-1.2 {command is another uplevel command} {
+    set xyz 0
+    a 22 33
+    set xyz
+} 22
+
+proc a1 {} {
+    b1
+    global a a1
+    set a $x
+    set a1 $y
+}
+proc b1 {} {
+    c1
+    global b b1
+    set b $x
+    set b1 $y
+}
+proc c1 {} {
+    uplevel 1 set x 111
+    uplevel #2 set y 222
+    uplevel 2 set x 333
+    uplevel #1 set y 444
+    uplevel 3 set x 555
+    uplevel #0 set y 666
+}
+a1
+test uplevel-2.1 {relative and absolute uplevel} {set a} 333
+test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
+test uplevel-2.3 {relative and absolute uplevel} {set b} 111
+test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
+test uplevel-2.5 {relative and absolute uplevel} {set x} 555
+test uplevel-2.6 {relative and absolute uplevel} {set y} 666
+
+test uplevel-3.1 {uplevel to same level} {
+    set x 33
+    uplevel #0 set x 44
+    set x
+} 44
+test uplevel-3.2 {uplevel to same level} {
+    set x 33
+    uplevel 0 set x
+} 33
+test uplevel-3.3 {uplevel to same level} {
+    set y xxx
+    proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
+    a1
+} 66
+test uplevel-3.4 {uplevel to same level} {
+    set y zzz
+    proc a1 {} {set y 55; uplevel #1 set y}
+    a1
+} 55
+
+test uplevel-4.1 {error: non-existent level} {
+    list [catch c1 msg] $msg
+} {1 {bad level "#2"}}
+test uplevel-4.2 {error: non-existent level} {
+    proc c2 {} {uplevel 3 {set a b}}
+    list [catch c2 msg] $msg
+} {1 {bad level "3"}}
+test uplevel-4.3 {error: not enough args} {
+    list [catch uplevel msg] $msg
+} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
+test uplevel-4.4 {error: not enough args} {
+    proc upBug {} {uplevel 1}
+    list [catch upBug msg] $msg
+} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
+
+#proc a2 {} {
+#    uplevel a3
+#}
+#proc a3 {} {
+#    global x y
+#    set x [info level]
+#    set y [info level 1]
+#}
+#a2
+#test uplevel-5.1 {info level} {set x} 1
+#test uplevel-5.2 {info level} {set y} a3