summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog109
-rw-r--r--generic/tclProc.c14
-rw-r--r--generic/tclVar.c46
-rw-r--r--tests/upvar.test113
4 files changed, 161 insertions, 121 deletions
diff --git a/ChangeLog b/ChangeLog
index 2ae03aa..c857492 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,51 +1,57 @@
+2009-03-24 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclVar.c (Tcl_UpvarObjCmd): [Bug 2673163] (ferrieux)
+ * generic/tclProc.c (TclObjGetFrame): Make the upvar command more able
+ to handle its officially documented syntax.
+
2009-03-22 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: NR-enable the handling of unknown commands
- [Bug 2502037].
-
+ * generic/tclBasic.c: [Bug 2502037]: NR-enable the handling of unknown
+ commands.
+
2009-03-21 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: fixed "leaks" in aliases, imports and
- * generic/tclInt.h: ensembles. Only remaining known leak
- * generic/tclInterp.c: is in ensemble unknown dispatch (as it
- * generic/tclNamesp.c: not NR-enabled)
+ * generic/tclBasic.c: Fixed "leaks" in aliases, imports and
+ * generic/tclInt.h: ensembles. Only remaining known leak is in
+ * generic/tclInterp.c: ensemble unknown dispatch (as it not
+ * generic/tclNamesp.c: NR-enabled)
* tests/tailcall.test:
-
+
* tclInt.h: comments
- * tests/tailcall.test: added tests to show that [tailcall] does
- not currently always execute in constant space: interp-alias,
- ns-imports and ensembles "leak" as of this commit.
-
- * tests/nre.test: [foreach] has been NR-enabled for a while, the
- test was marked 'knownBug': unmark it.
-
+ * tests/tailcall.test: Added tests to show that [tailcall] does not
+ currently always execute in constant space: interp-alias, ns-imports
+ and ensembles "leak" as of this commit.
+
+ * tests/nre.test: [foreach] has been NR-enabled for a while, the test
+ was marked 'knownBug': unmark it.
+
* generic/tclBasic.c: Fix for (among others) [Bug 2699087]
- * generic/tclCmdAH.c: Tailcalls now perform properly even from
+ * generic/tclCmdAH.c: Tailcalls now perform properly even from
* generic/tclExecute.c: within [eval]ed scripts.
* generic/tclInt.h: More tests missing, as well as proper
- exploration and testing of the interaction with "redirectors" like
+ exploration and testing of the interaction with "redirectors" like
interp-alias (suspect that it does not happen in constant space)
and pure-eval commands.
- * generic/tclExecute.c: proper fix for [Bug 2415422]. Reenabled
- * tests/nre.test: the failing assertion that was disabled on
+ * generic/tclExecute.c: Proper fix for [Bug 2415422]. Reenabled
+ * tests/nre.test: the failing assertion that was disabled on
2008-12-18: the assertion is correct, the fault was in the
- management of expansions.
-
- * generic/tclExecute.c: fix both test and code for tailcall
+ management of expansions.
+
+ * generic/tclExecute.c: Fix both test and code for tailcall
* tests/tailcall.test: from within a compiled [eval] body.
- * tests/tailcall.test: slightly improved tests
+ * tests/tailcall.test: Slightly improved tests
2009-03-20 Don Porter <dgp@users.sourceforge.net>
- * tests/stringObj.test: Test stringObj-6.9 checks that
- Tcl_AppendStringsToObj() no longer crashes when operating on a
- pure unicode value. [Bug 2597185]
+ * tests/stringObj.test: [Bug 2597185]: Test stringObj-6.9
+ checks that Tcl_AppendStringsToObj() no longer crashes when operating
+ on a pure unicode value.
- * generic/tclExecute.c (INST_CONCAT1): Panic when appends overflow
- the max length of a Tcl value. [Bug 2669109]
+ * generic/tclExecute.c (INST_CONCAT1): [Bug 2669109]: Panic when
+ appends overflow the max length of a Tcl value.
2009-03-19 Miguel Sofer <msofer@users.sf.net>
@@ -54,27 +60,28 @@
* generic/tclBasic.c:
* generic/tclExecute.c:
* generic/tclNamesp.c (Tcl_PopCallFrame): Rewritten tailcall
- implementation, ::unsupported::atProcExit is (temporarily?)
- gone. The new approach is much simpler, and also closer to being
- correct. This commit fixes [Bug 2649975] and [Bug 2695587].
+ implementation, ::unsupported::atProcExit is (temporarily?) gone. The
+ new approach is much simpler, and also closer to being correct. This
+ commit fixes [Bug 2649975] and [Bug 2695587].
- * tests/coroutine.test: Moved the tests to their own files,
+ * tests/coroutine.test: Moved the tests to their own files,
* tests/tailcall.test: removed the unsupported.test. Added
* tests/unsupported.test: tests for the fixed bugs.
-
+
2009-03-19 Donal K. Fellows <dkf@users.sf.net>
* doc/tailcall.n: Added documentation for tailcall command.
2009-03-18 Don Porter <dgp@users.sourceforge.net>
- * win/tclWinFile.c (TclpObjNormalizePath): Corrected Tcl_Obj leak.
- Thanks to Joe Mistachkin for detection and patch. [Bug 2688184].
+ * win/tclWinFile.c (TclpObjNormalizePath): [Bug 2688184]:
+ Corrected Tcl_Obj leak. Thanks to Joe Mistachkin for detection and
+ patch.
- * generic/tclVar.c (TclLookupSimpleVar): Shift all calls to
- Tcl_SetErrorCode() out of TclLookupSimpleVar and onto its callers,
- where control with TCL_LEAVE_ERR_MSG flag is more easily handled.
- [Bug 2689307]
+ * generic/tclVar.c (TclLookupSimpleVar): [Bug 2689307]: Shift
+ all calls to Tcl_SetErrorCode() out of TclLookupSimpleVar and onto its
+ callers, where control with TCL_LEAVE_ERR_MSG flag is more easily
+ handled.
2009-03-16 Donal K. Fellows <dkf@users.sf.net>
@@ -106,7 +113,7 @@
2009-03-11 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c (TclNRCoroutineObjCmd): fix Tcl_Obj leak.
+ * generic/tclBasic.c (TclNRCoroutineObjCmd): fix Tcl_Obj leak.
Diagnosis and fix thanks to GPS.
2009-03-09 Donal K. Fellows <dkf@users.sf.net>
@@ -123,7 +130,7 @@
2009-02-27 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tcl.decls: [Bug 218977] Tcl_DbCkfree needs a return value
+ * generic/tcl.decls: [Bug 218977]: Tcl_DbCkfree needs return value
* generic/tclCkalloc.c
* generic/tclDecls.h (regenerated)
* generic/tclInt.decls: don't use CONST84/CONST86 here
@@ -133,11 +140,11 @@
2009-02-25 Don Porter <dgp@users.sourceforge.net>
- * generic/tclUtil.c (TclStringMatchObj): Revised the branching
- on the strObj->typePtr so that untyped values get converted to the
- "string" type and pass through the Unicode matcher. [Bug 2613766]
- Also added checks to only perform "bytearray" optimization on pure
- bytearray values. [Bug 2637173].
+ * generic/tclUtil.c (TclStringMatchObj): [Bug 2637173]: Revised
+ the branching on the strObj->typePtr so that untyped values get
+ converted to the "string" type and pass through the Unicode matcher.
+ [Bug 2613766]: Also added checks to only perform "bytearray"
+ optimization on pure bytearray values.
* generic/tclCmdMZ.c: Since Tcl_GetCharLength() has its own
* generic/tclExecute.c: optimizations for the tclByteArrayType, stop
@@ -230,7 +237,7 @@
2009-02-16 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclZlib.c: hack needed for official zlib1.dll build.
+ * generic/tclZlib.c: hack needed for official zlib1.dll build.
* win/configure.in: fix [Feature Request 2605263] use official
* win/Makefile.in: zlib build.
* win/configure: (regenerated)
@@ -299,7 +306,7 @@
replacement for a full Tcl_NumUtfChars() call when the string has all
single-byte characters.
- * generic/tclStringObj.c: Simplified Tcl_GetCharLength by
+ * generic/tclStringObj.c: Simplified Tcl_GetCharLength by
* generic/tclTestObj.c: removing code that did nothing.
Added early returns from Tcl_*SetObjLength when the desired length
is already present; adapted test command to the change.
@@ -539,7 +546,7 @@
* win/tclWinSock.c: Fix [Bug 2446662]: resync Win behavior on RST
with that of unix (EOF).
-
+
2009-01-26 Donal K. Fellows <dkf@users.sf.net>
* generic/tclZlib.c (ChanClose): Only generate error messages in the
@@ -717,7 +724,7 @@
in the case where [clock add] is presented with a bad switch.
* tests/clock.test (clock-65.1) Added a test case for the above
problem [Bug 2481670].
-
+
2009-01-02 Donal K. Fellows <dkf@users.sf.net>
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Force the use of the compatibility
@@ -820,7 +827,7 @@
I couldn't figure out how to sort this out
any other way.
* win/configure: Autoconf 2.59
-
+
2008-12-20 Donal K. Fellows <dkf@users.sf.net>
* win/Makefile.in: Minor updates to make building work better with
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 611ae45..2062672 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.170 2009/02/10 22:50:07 nijtmans Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.171 2009/03/24 09:30:07 dkf Exp $
*/
#include "tclInt.h"
@@ -787,7 +787,7 @@ TclObjGetFrame(
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 @@ TclObjGetFrame(
result = 1;
curLevel = iPtr->varFramePtr->level;
+ if (objPtr == NULL) {
+ name = "1";
+ goto haveLevel1;
+ }
+
+ name = TclGetString(objPtr);
if (objPtr->typePtr == &levelReferenceType) {
if (objPtr->internalRep.ptrAndLongRep.ptr != NULL) {
level = curLevel - objPtr->internalRep.ptrAndLongRep.value;
@@ -847,9 +853,11 @@ TclObjGetFrame(
level = curLevel - level;
} else {
/*
- * Don't cache as the object *isn't* a level reference.
+ * Don't cache as the object *isn't* a level reference (might even be
+ * NULL...)
*/
+ haveLevel1:
level = curLevel - 1;
result = 0;
}
diff --git a/generic/tclVar.c b/generic/tclVar.c
index e61e06e..d87cdf9 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.177 2009/03/18 16:52:20 dgp Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.178 2009/03/24 09:30:07 dkf Exp $
*/
#include "tclInt.h"
@@ -4077,29 +4077,59 @@ Tcl_UpvarObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
CallFrame *framePtr;
- int result;
+ int result, hasLevel;
+ Tcl_Obj *levelObj;
if (objc < 3) {
- upvarSyntax:
Tcl_WrongNumArgs(interp, 1, objv,
"?level? otherVar localVar ?otherVar localVar ...?");
return TCL_ERROR;
}
+ if (objc & 1) {
+ /*
+ * Even number of arguments, so use the default level of "1" by
+ * passing NULL to TclObjGetFrame.
+ */
+
+ levelObj = NULL;
+ hasLevel = 0;
+ } else {
+ /*
+ * Odd number of arguments, so objv[1] must contain the level.
+ */
+
+ levelObj = 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, levelObj, &framePtr);
if (result == -1) {
return TCL_ERROR;
}
- objc -= result+1;
- if ((objc & 1) != 0) {
- goto upvarSyntax;
+ if ((result == 0) && hasLevel) {
+ /*
+ * Synthesize an error message since TclObjGetFrame doesn't do this
+ * for this particular case.
+ */
+
+ Tcl_AppendResult(interp, "bad level \"", TclGetString(levelObj), "\"",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL);
+ return TCL_ERROR;
}
- objv += result+1;
+
+ /*
+ * We've now finished with parsing levels; skip to the variable names.
+ */
+
+ objc -= hasLevel+1;
+ objv += hasLevel+1;
/*
* Iterate over each (other variable, local variable) pair. Divide the
diff --git a/tests/upvar.test b/tests/upvar.test
index 9e1b2d9..86a5a20 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -1,17 +1,17 @@
# Commands covered: 'upvar', 'namespace upvar'
#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
+# This file contains a collection of tests for one or more of the Tcl built-in
+# commands. Sourcing this file into Tcl runs the tests and generates output
+# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: upvar.test,v 1.18 2008/10/14 18:49:47 dgp Exp $
+# RCS: @(#) $Id: upvar.test,v 1.19 2009/03/24 09:30:07 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
testConstraint testupvar [llength [info commands testupvar]]
-
+
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
@@ -290,58 +290,64 @@ test upvar-7.5 {potential memory leak when deleting variable table} {
leak
} {}
-test upvar-8.1 {errors in upvar command} {
- list [catch upvar msg] $msg
-} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
-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.3 {errors in upvar command} {
+test upvar-8.1 {errors in upvar command} -returnCodes error -body {
+ upvar
+} -result {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}
+test upvar-8.2 {errors in upvar command} -returnCodes error -body {
+ upvar 1
+} -result {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}
+test upvar-8.2.1 {upvar with numeric first argument} {
+ apply {{} {set 0 ok; apply {{} {upvar 0 x; return $x}}}}
+} ok
+test upvar-8.3 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar a b c}
- list [catch p1 msg] $msg
-} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
-test upvar-8.4 {errors in upvar command} {
+ p1
+} -result {bad level "a"}
+test upvar-8.4 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 b b}
- list [catch p1 msg] $msg
-} {1 {can't upvar from variable to itself}}
-test upvar-8.5 {errors in upvar command} {
+ p1
+} -result {can't upvar from variable to itself}
+test upvar-8.5 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 a b; upvar 0 b a}
- list [catch p1 msg] $msg
-} {1 {can't upvar from variable to itself}}
-test upvar-8.6 {errors in upvar command} {
+ p1
+} -result {can't upvar from variable to itself}
+test upvar-8.6 {errors in upvar command} -returnCodes error -body {
proc p1 {} {set a 33; upvar b a}
- list [catch p1 msg] $msg
-} {1 {variable "a" already exists}}
-test upvar-8.7 {errors in upvar command} {
+ p1
+} -result {variable "a" already exists}
+test upvar-8.7 {errors in upvar command} -returnCodes error -body {
proc p1 {} {trace variable a w foo; upvar b a}
- list [catch p1 msg] $msg
-} {1 {variable "a" has traces: can't use for upvar}}
+ p1
+} -result {variable "a" has traces: can't use for upvar}
test upvar-8.8 {create nested array with upvar} -body {
proc p1 {} {upvar x(a) b; set b(2) 44}
catch {unset x}
- list [catch p1 msg] $msg
-} -cleanup {
+ p1
+} -returnCodes error -cleanup {
unset x
-} -result {1 {can't set "b(2)": variable isn't array}}
-test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} {
+} -result {can't set "b(2)": variable isn't array}
+test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename MakeLink ""}
namespace eval ::test_ns_1 {}
+} -returnCodes error -body {
proc MakeLink {a} {
- namespace eval ::test_ns_1 {
+ namespace eval ::test_ns_1 {
upvar a a
- }
- unset ::test_ns_1::a
+ }
+ unset ::test_ns_1::a
}
- list [catch {MakeLink 1} msg] $msg
-} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}}
-test upvar-8.10 {upvar will create element alias for new array element} {
+ MakeLink 1
+} -result {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}
+test upvar-8.10 {upvar will create element alias for new array element} -setup {
catch {unset upvarArray}
+} -body {
array set upvarArray {}
catch {upvar 0 upvarArray(elem) upvarArrayElemAlias}
-} {0}
-test upvar-8.11 {upvar will not create a variable that looks like an array} -body {
+} -result {0}
+test upvar-8.11 {upvar will not create a variable that looks like an array} -setup {
catch {unset upvarArray}
+} -body {
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
@@ -407,23 +413,19 @@ test upvar-9.7 {Tcl_UpVar procedure} testupvar {
} {1234}
catch {unset a}
-
#
# Tests for 'namespace upvar'. As the implementation is essentially the same as
-# for 'upvar', we only test that the variables are linked correctly. Ie, we
-# assume that the behaviour of variables once the link is established has
+# for 'upvar', we only test that the variables are linked correctly, i.e., we
+# assume that the behaviour of variables once the link is established has
# already been tested above.
#
-#
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
-
namespace eval test_ns_0 {
variable x test_ns_0
}
-
-set x test_global
+set ::x test_global
test upvar-NS-1.1 {nsupvar links to correct variable} \
-body {
@@ -434,7 +436,6 @@ test upvar-NS-1.1 {nsupvar links to correct variable} \
} \
-result {test_ns_0} \
-cleanup {namespace delete test_ns_1}
-
test upvar-NS-1.2 {nsupvar links to correct variable} \
-body {
namespace eval test_ns_1 {
@@ -447,7 +448,6 @@ test upvar-NS-1.2 {nsupvar links to correct variable} \
} \
-result {test_ns_0} \
-cleanup {namespace delete test_ns_1}
-
test upvar-NS-1.3 {nsupvar links to correct variable} \
-body {
namespace eval test_ns_1 {
@@ -458,7 +458,6 @@ test upvar-NS-1.3 {nsupvar links to correct variable} \
-result {namespace "test_ns_0" not found in "::test_ns_1"} \
-returnCodes error \
-cleanup {namespace delete test_ns_1}
-
test upvar-NS-1.4 {nsupvar links to correct variable} \
-body {
namespace eval test_ns_1 {
@@ -472,7 +471,6 @@ test upvar-NS-1.4 {nsupvar links to correct variable} \
-result {namespace "test_ns_0" not found in "::test_ns_1"} \
-returnCodes error \
-cleanup {namespace delete test_ns_1}
-
test upvar-NS-1.5 {nsupvar links to correct variable} \
-body {
namespace eval test_ns_1 {
@@ -484,7 +482,6 @@ test upvar-NS-1.5 {nsupvar links to correct variable} \
-result {can't read "w": no such variable} \
-returnCodes error \
-cleanup {namespace delete test_ns_1}
-
test upvar-NS-1.6 {nsupvar links to correct variable} \
-body {
namespace eval test_ns_1 {
@@ -499,7 +496,6 @@ test upvar-NS-1.6 {nsupvar links to correct variable} \
-result {can't read "w": no such variable} \
-returnCodes error \
-cleanup {namespace delete test_ns_1}
-
test upvar-NS-1.7 {nsupvar links to correct variable} \
-body {
namespace eval test_ns_1 {
@@ -512,7 +508,6 @@ test upvar-NS-1.7 {nsupvar links to correct variable} \
} \
-result {test_ns_1::test_ns_0} \
-cleanup {namespace delete test_ns_1}
-
test upvar-NS-1.8 {nsupvar links to correct variable} \
-body {
namespace eval test_ns_1 {
@@ -528,7 +523,6 @@ test upvar-NS-1.8 {nsupvar links to correct variable} \
} \
-result {test_ns_1::test_ns_0} \
-cleanup {namespace delete test_ns_1}
-
test upvar-NS-1.9 {nsupvar links to correct variable} \
-body {
namespace eval test_ns_1 {
@@ -547,7 +541,6 @@ test upvar-NS-1.9 {nsupvar links to correct variable} \
test upvar-NS-2.1 {TIP 323} -returnCodes error -body {
namespace upvar
} -result {wrong # args: should be "namespace upvar ns ?otherVar myVar ...?"}
-
test upvar-NS-2.2 {TIP 323} -setup {
namespace eval test_ns_1 {}
} -body {
@@ -555,9 +548,11 @@ test upvar-NS-2.2 {TIP 323} -setup {
} -cleanup {
namespace delete test_ns_1
} -result {}
-
-
-
+
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End: