Attachment "upvar4.patch" to
ticket [2673163fff]
added by
ferrieux
2009-03-19 04:45:37.
Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.177
diff -u -r1.177 tclVar.c
--- generic/tclVar.c 18 Mar 2009 16:52:20 -0000 1.177
+++ generic/tclVar.c 18 Mar 2009 21:42:23 -0000
@@ -4077,29 +4077,57 @@
Tcl_Obj *const objv[]) /* Argument objects. */
{
CallFrame *framePtr;
- int result;
+ int result,haslevel;
+ Tcl_Obj *lspec;
if (objc < 3) {
- upvarSyntax:
Tcl_WrongNumArgs(interp, 1, objv,
"?level? otherVar localVar ?otherVar localVar ...?");
return TCL_ERROR;
}
+ if ((objc &1) != 0) {
+ /*
+ * Even #args -> default levelspec "1", computed by passing
+ * NULL to TclObjGetFrame
+ */
+ lspec=NULL;
+ haslevel=0;
+ } else {
+ /*
+ * Odd #args -> objv[1] contains the levelspec
+ */
+ lspec=objv[1];
+ haslevel=1;
+ }
+
/*
* Find the call frame containing each of the "other variables" to be
* linked to.
*/
- result = TclObjGetFrame(interp, objv[1], &framePtr);
+ result = TclObjGetFrame(interp, lspec, &framePtr);
if (result == -1) {
return TCL_ERROR;
}
- objc -= result+1;
- if ((objc & 1) != 0) {
- goto upvarSyntax;
+ if ((result == 0) && haslevel) {
+ /*
+ * Here TOGF returned level 1 without a good reason,
+ * so barf about it
+ */
+ Tcl_AppendResult(interp, "bad level \"", TclGetString(lspec), "\"",NULL);
+ return TCL_ERROR;
+ }
+
+ if (haslevel) {
+ /*
+ * Resync with remaining args
+ */
+ objv++;
+ objc--;
}
- objv += result+1;
+ objv++;
+ objc--;
/*
* Iterate over each (other variable, local variable) pair. Divide the
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.170
diff -u -r1.170 tclProc.c
--- generic/tclProc.c 10 Feb 2009 22:50:07 -0000 1.170
+++ generic/tclProc.c 18 Mar 2009 21:42:26 -0000
@@ -787,7 +787,7 @@
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
CallFrame *framePtr;
- const char *name = TclGetString(objPtr);
+ const char *name;
/*
* Parse object to figure out which level number to go to.
@@ -795,6 +795,12 @@
result = 1;
curLevel = iPtr->varFramePtr->level;
+ if (objPtr==NULL) {
+ name="1";
+ goto level1;
+ }
+ name = TclGetString(objPtr);
+
if (objPtr->typePtr == &levelReferenceType) {
if (objPtr->internalRep.ptrAndLongRep.ptr != NULL) {
level = curLevel - objPtr->internalRep.ptrAndLongRep.value;
@@ -849,7 +855,7 @@
/*
* Don't cache as the object *isn't* a level reference.
*/
-
+ level1:
level = curLevel - 1;
result = 0;
}
Index: tests/upvar.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/upvar.test,v
retrieving revision 1.18
diff -u -r1.18 upvar.test
--- tests/upvar.test 14 Oct 2008 18:49:47 -0000 1.18
+++ tests/upvar.test 18 Mar 2009 21:42:26 -0000
@@ -296,10 +296,14 @@
test upvar-8.2 {errors in upvar command} {
list [catch {upvar 1} msg] $msg
} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
+test upvar-8.2b {errors in upvar command} {
+ set 1 foo;proc p1 {} {upvar 1 x;set x}
+ list [catch p1 msg] $msg
+} {0 foo}
test upvar-8.3 {errors in upvar command} {
proc p1 {} {upvar a b c}
list [catch p1 msg] $msg
-} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
+} {1 {bad level "a"}}
test upvar-8.4 {errors in upvar command} {
proc p1 {} {upvar 0 b b}
list [catch p1 msg] $msg
