diff options
-rw-r--r-- | jim.c | 49 | ||||
-rw-r--r-- | jim.h | 2 | ||||
-rw-r--r-- | test.tcl | 98 |
3 files changed, 133 insertions, 16 deletions
@@ -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 */ @@ -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); @@ -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 |