summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclProc.c118
-rw-r--r--tests/uplevel.test99
2 files changed, 145 insertions, 72 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index ac65bde..9770d26 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -808,94 +808,68 @@ TclObjGetFrame(
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
CallFrame *framePtr;
- const char *name;
+ const char *name = NULL;
/*
* Parse object to figure out which level number to go to.
*/
- result = 1;
+ result = 0;
curLevel = iPtr->varFramePtr->level;
- if (objPtr == NULL) {
- name = "1";
- goto haveLevel1;
- }
- name = TclGetString(objPtr);
- if (objPtr->typePtr == &levelReferenceType) {
- if (objPtr->internalRep.twoPtrValue.ptr1) {
- level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
- } else {
- level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
- }
- if (level < 0) {
- goto levelError;
- }
- /* TODO: Consider skipping the typePtr checks */
- } else if (objPtr->typePtr == &tclIntType
-#ifndef TCL_WIDE_INT_IS_LONG
- || objPtr->typePtr == &tclWideIntType
-#endif
- ) {
- if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
- goto levelError;
- }
- level = curLevel - level;
- } else if (*name == '#') {
- if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
- goto levelError;
- }
-
- /*
- * Cache for future reference.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0;
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
- } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
- if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
- return -1;
- }
-
- /*
- * Cache for future reference.
- */
+ /*
+ * Check for integer first, since that has potential to spare us
+ * a generation of a stringrep.
+ */
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1;
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
+ if (objPtr == NULL) {
+ /* Do nothing */
+ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)
+ && (level >= 0)) {
level = curLevel - level;
+ result = 1;
+ } else if (objPtr->typePtr == &levelReferenceType) {
+ level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr1);
+ result = 1;
} else {
- /*
- * Don't cache as the object *isn't* a level reference (might even be
- * NULL...)
- */
+ name = TclGetString(objPtr);
+ if (name[0] == '#') {
+ if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) {
+ TclFreeIntRep(objPtr);
+ objPtr->typePtr = &levelReferenceType;
+ objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(level);
+ result = 1;
+ } else {
+ result = -1;
+ }
+ } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */
+ /*
+ * If this were an integer, we'd have succeeded already.
+ * Docs say we have to treat this as a 'bad level' error.
+ */
+ result = -1;
+ }
+ }
- haveLevel1:
+ if (result == 0) {
level = curLevel - 1;
- result = 0;
+ name = "1";
}
-
- /*
- * Figure out which frame to use, and return it to the caller.
- */
-
- for (framePtr = iPtr->varFramePtr; framePtr != NULL;
- framePtr = framePtr->callerVarPtr) {
- if (framePtr->level == level) {
- break;
+ if (result != -1) {
+ if (level >= 0) {
+ for (framePtr = iPtr->varFramePtr; framePtr != NULL;
+ framePtr = framePtr->callerVarPtr) {
+ if (framePtr->level == level) {
+ *framePtrPtr = framePtr;
+ return result;
+ }
+ }
+ }
+ if (name == NULL) {
+ name = TclGetString(objPtr);
}
}
- if (framePtr == NULL) {
- goto levelError;
- }
- *framePtrPtr = framePtr;
- return result;
- levelError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
diff --git a/tests/uplevel.test b/tests/uplevel.test
index 0410469..9ecc0d5 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -101,6 +101,105 @@ test uplevel-4.4 {error: not enough args} -returnCodes error -body {
uplevel 1
}}
} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"}
+test uplevel-4.5 {level parsing} {
+ apply {{} {uplevel 0 {}}}
+} {}
+test uplevel-4.6 {level parsing} {
+ apply {{} {uplevel #0 {}}}
+} {}
+test uplevel-4.7 {level parsing} {
+ apply {{} {uplevel [expr 0] {}}}
+} {}
+test uplevel-4.8 {level parsing} {
+ apply {{} {uplevel #[expr 0] {}}}
+} {}
+test uplevel-4.9 {level parsing} {
+ apply {{} {uplevel -0 {}}}
+} {}
+test uplevel-4.10 {level parsing} {
+ apply {{} {uplevel #-0 {}}}
+} {}
+test uplevel-4.11 {level parsing} {
+ apply {{} {uplevel [expr -0] {}}}
+} {}
+test uplevel-4.12 {level parsing} {
+ apply {{} {uplevel #[expr -0] {}}}
+} {}
+test uplevel-4.13 {level parsing} {
+ apply {{} {uplevel 1 {}}}
+} {}
+test uplevel-4.14 {level parsing} {
+ apply {{} {uplevel #1 {}}}
+} {}
+test uplevel-4.15 {level parsing} {
+ apply {{} {uplevel [expr 1] {}}}
+} {}
+test uplevel-4.16 {level parsing} {
+ apply {{} {uplevel #[expr 1] {}}}
+} {}
+test uplevel-4.17 {level parsing} {
+ apply {{} {uplevel -0xffffffff {}}}
+} {}
+test uplevel-4.18 {level parsing} {
+ apply {{} {uplevel #-0xffffffff {}}}
+} {}
+test uplevel-4.19 {level parsing} {
+ apply {{} {uplevel [expr -0xffffffff] {}}}
+} {}
+test uplevel-4.20 {level parsing} {
+ apply {{} {uplevel #[expr -0xffffffff] {}}}
+} {}
+test uplevel-4.21 {level parsing} -body {
+ apply {{} {uplevel -1 {}}}
+} -returnCodes error -result {invalid command name "-1"}
+test uplevel-4.22 {level parsing} -body {
+ apply {{} {uplevel #-1 {}}}
+} -returnCodes error -result {bad level "#-1"}
+test uplevel-4.23 {level parsing} -body {
+ apply {{} {uplevel [expr -1] {}}}
+} -returnCodes error -result {invalid command name "-1"}
+test uplevel-4.24 {level parsing} -body {
+ apply {{} {uplevel #[expr -1] {}}}
+} -returnCodes error -result {bad level "#-1"}
+test uplevel-4.25 {level parsing} -body {
+ apply {{} {uplevel 0xffffffff {}}}
+} -returnCodes error -result {bad level "0xffffffff"}
+test uplevel-4.26 {level parsing} -body {
+ apply {{} {uplevel #0xffffffff {}}}
+} -returnCodes error -result {bad level "#0xffffffff"}
+test uplevel-4.27 {level parsing} -body {
+ apply {{} {uplevel [expr 0xffffffff] {}}}
+} -returnCodes error -result {bad level "4294967295"}
+test uplevel-4.28 {level parsing} -body {
+ apply {{} {uplevel #[expr 0xffffffff] {}}}
+} -returnCodes error -result {bad level "#4294967295"}
+test uplevel-4.29 {level parsing} -body {
+ apply {{} {uplevel 0.2 {}}}
+} -returnCodes error -result {bad level "0.2"}
+test uplevel-4.30 {level parsing} -body {
+ apply {{} {uplevel #0.2 {}}}
+} -returnCodes error -result {bad level "#0.2"}
+test uplevel-4.31 {level parsing} -body {
+ apply {{} {uplevel [expr 0.2] {}}}
+} -returnCodes error -result {bad level "0.2"}
+test uplevel-4.32 {level parsing} -body {
+ apply {{} {uplevel #[expr 0.2] {}}}
+} -returnCodes error -result {bad level "#0.2"}
+test uplevel-4.33 {level parsing} -body {
+ apply {{} {uplevel .2 {}}}
+} -returnCodes error -result {invalid command name ".2"}
+test uplevel-4.34 {level parsing} -body {
+ apply {{} {uplevel #.2 {}}}
+} -returnCodes error -result {bad level "#.2"}
+test uplevel-4.35 {level parsing} -body {
+ apply {{} {uplevel [expr .2] {}}}
+} -returnCodes error -result {bad level "0.2"}
+test uplevel-4.36 {level parsing} -body {
+ apply {{} {uplevel #[expr .2] {}}}
+} -returnCodes error -result {bad level "#0.2"}
+
+
+
proc a2 {} {
uplevel a3
generated by cgit v0.12 at 2024-11-18 13:23:28 (GMT)