diff options
| -rw-r--r-- | ChangeLog | 109 | ||||
| -rw-r--r-- | generic/tclProc.c | 14 | ||||
| -rw-r--r-- | generic/tclVar.c | 46 | ||||
| -rw-r--r-- | tests/upvar.test | 113 |
4 files changed, 161 insertions, 121 deletions
@@ -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: |