summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2003-04-07 10:11:54 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2003-04-07 10:11:54 (GMT)
commitd0a21c54ad4d13296bcc9f3294c4ebb63327734a (patch)
treee6b32f05316cada8391cc6f99afcce0742888c2d
parenteffa89fcecf29f38482d867654036429013977f6 (diff)
downloadtcl-d0a21c54ad4d13296bcc9f3294c4ebb63327734a.zip
tcl-d0a21c54ad4d13296bcc9f3294c4ebb63327734a.tar.gz
tcl-d0a21c54ad4d13296bcc9f3294c4ebb63327734a.tar.bz2
Fixed bugs 715751 and 713562 so dict code should build everywhere and wide ints
be defined (though not necessarily useful) everywhere.
-rw-r--r--ChangeLog15
-rw-r--r--generic/tclDictObj.c51
-rw-r--r--generic/tclObj.c15
-rw-r--r--tests/dict.test10
4 files changed, 64 insertions, 27 deletions
diff --git a/ChangeLog b/ChangeLog
index b643b60..c9098b7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2003-04-07 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ * tests/dict.test (dict-2.6):
+ * generic/tclDictObj.c (Tcl_NewDictObj, Tcl_DbNewDictObj): Oops!
+ Failed to fully initialise the Dict structure.
+ (DictIncrCmd): Moved valueAlreadyInDictionary label to stop
+ compiler complaints. [Bug 715751]
+
+ * generic/tclDictObj.c (DictIncrCmd): Followed style in the rest of
+ the core by commenting out wide-specific operations on platforms
+ where wides are longs, and used longs more thoroughly than ints
+ through [dict incr] anyway to forestall further bugs.
+ * generic/tclObj.c: Made sure there's always a tclWideIntType
+ implementation available, not that it is always useful. [Bug 713562]
+
2003-04-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclDictObj.c: Removed commented out notes on
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index b4c1225..ee8d5c4 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDictObj.c,v 1.3 2003/04/05 07:32:32 dgp Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.4 2003/04/07 10:12:09 dkf Exp $
*/
#include "tclInt.h"
@@ -185,7 +185,7 @@ FreeDictInternalRep(dictPtr)
Dict *dict = (Dict *) dictPtr->internalRep.otherValuePtr;
--dict->refcount;
- if (dict->refcount == 0) {
+ if (dict->refcount <= 0) {
DeleteDict(dict);
}
@@ -977,7 +977,7 @@ Tcl_DictObjDone(searchPtr)
searchPtr->epoch = -1;
dict = (Dict *) searchPtr->dictionaryPtr;
dict->refcount--;
- if (dict->refcount == 0) {
+ if (dict->refcount <= 0) {
DeleteDict(dict);
}
}
@@ -1093,7 +1093,7 @@ Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv)
/*
*----------------------------------------------------------------------
*
- * Tcl_NewListObj --
+ * Tcl_NewDictObj --
*
* This procedure is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new dict object
@@ -1128,6 +1128,7 @@ Tcl_NewDictObj()
Tcl_InitObjHashTable(&dict->table);
dict->epoch = 0;
dict->chain = NULL;
+ dict->refcount = 1;
dictPtr->internalRep.otherValuePtr = (VOID *) dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
@@ -1137,7 +1138,7 @@ Tcl_NewDictObj()
/*
*----------------------------------------------------------------------
*
- * Tcl_DbNewListObj --
+ * Tcl_DbNewDictObj --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new dict objects. It is the
@@ -1176,6 +1177,7 @@ Tcl_DbNewDictObj(file, line)
Tcl_InitObjHashTable(&dict->table);
dict->epoch = 0;
dict->chain = NULL;
+ dict->refcount = 1;
dictPtr->internalRep.otherValuePtr = (VOID *) dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
@@ -1676,7 +1678,8 @@ DictIncrCmd(interp, objc, objv)
Tcl_Obj *CONST *objv;
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
- int result, incrValue;
+ int result;
+ long incrValue;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?");
@@ -1684,7 +1687,7 @@ DictIncrCmd(interp, objc, objv)
}
if (objc == 5) {
- result = Tcl_GetIntFromObj(interp, objv[4], &incrValue);
+ result = Tcl_GetLongFromObj(interp, objv[4], &incrValue);
if (result != TCL_OK) {
return result;
}
@@ -1695,9 +1698,9 @@ DictIncrCmd(interp, objc, objv)
dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
if (dictPtr == NULL) {
dictPtr = Tcl_NewDictObj();
- Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewIntObj(incrValue));
+ Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewLongObj(incrValue));
} else {
- int iValue;
+ long lValue;
Tcl_WideInt wValue;
if (Tcl_IsShared(dictPtr)) {
@@ -1708,7 +1711,8 @@ DictIncrCmd(interp, objc, objv)
return TCL_ERROR;
}
if (valuePtr == NULL) {
- valuePtr = Tcl_NewIntObj(incrValue);
+ valuePtr = Tcl_NewLongObj(incrValue);
+#ifndef TCL_WIDE_INT_IS_LONG
} else if (valuePtr->typePtr == &tclWideIntType) {
Tcl_GetWideIntFromObj(NULL, valuePtr, &wValue);
if (Tcl_IsShared(valuePtr)) {
@@ -1720,38 +1724,45 @@ DictIncrCmd(interp, objc, objv)
}
goto valueAlreadyInDictionary;
}
+#endif /* !TCL_WIDE_INT_IS_LONG */
} else if (valuePtr->typePtr == &tclIntType) {
- Tcl_GetIntFromObj(NULL, valuePtr, &iValue);
+ Tcl_GetLongFromObj(NULL, valuePtr, &lValue);
if (Tcl_IsShared(valuePtr)) {
- valuePtr = Tcl_NewIntObj(iValue + incrValue);
+ valuePtr = Tcl_NewLongObj(lValue + incrValue);
} else {
- Tcl_SetIntObj(valuePtr, iValue + incrValue);
+ Tcl_SetLongObj(valuePtr, lValue + incrValue);
if (dictPtr->bytes != NULL) {
Tcl_InvalidateStringRep(dictPtr);
}
goto valueAlreadyInDictionary;
}
} else {
+ /*
+ * Note that these operations on wide ints should work
+ * fine where they are the same as normal longs, though
+ * the compiler might complain about trivially satisifed
+ * tests.
+ */
result = Tcl_GetWideIntFromObj(interp, valuePtr, &wValue);
if (result != TCL_OK) {
return result;
}
/*
- * Determine if we should have got a standard int instead.
+ * Determine if we should have got a standard long instead.
*/
if (Tcl_IsShared(valuePtr)) {
- if (wValue >= INT_MIN && wValue <= INT_MAX) {
+ if (wValue >= LONG_MIN && wValue <= LONG_MAX) {
/*
* Convert the type...
*/
- Tcl_GetIntFromObj(NULL, valuePtr, &iValue);
- valuePtr = Tcl_NewIntObj(iValue + incrValue);
+ Tcl_GetLongFromObj(NULL, valuePtr, &lValue);
+ valuePtr = Tcl_NewLongObj(lValue + incrValue);
} else {
valuePtr = Tcl_NewWideIntObj(wValue + incrValue);
}
} else {
- if (wValue >= INT_MIN && wValue <= INT_MAX) {
- Tcl_SetIntObj(valuePtr,
+ if (wValue >= LONG_MIN && wValue <= LONG_MAX) {
+ Tcl_SetLongObj(valuePtr,
Tcl_WideAsLong(wValue) + incrValue);
} else {
Tcl_SetWideIntObj(valuePtr, wValue + incrValue);
@@ -1766,8 +1777,8 @@ DictIncrCmd(interp, objc, objv)
Tcl_DecrRefCount(valuePtr);
return TCL_ERROR;
}
- valueAlreadyInDictionary:
}
+ valueAlreadyInDictionary:
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
if (resultPtr == NULL) {
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 1a9307e..a5e34e6 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.43 2003/04/05 01:41:23 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.44 2003/04/07 10:12:10 dkf Exp $
*/
#include "tclInt.h"
@@ -126,15 +126,18 @@ Tcl_ObjType tclIntType = {
SetIntFromAny /* setFromAnyProc */
};
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_ObjType tclWideIntType = {
"wideInt", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
+#ifdef TCL_WIDE_INT_IS_LONG
+ UpdateStringOfInt, /* updateStringProc */
+ SetIntFromAny /* setFromAnyProc */
+#else /* !TCL_WIDE_INT_IS_LONG */
UpdateStringOfWideInt, /* updateStringProc */
SetWideIntFromAny /* setFromAnyProc */
+#endif /* TCL_WIDE_INT_IS_LONG */
};
-#endif
/*
* The structure below defines the Tcl obj hash key type.
@@ -233,9 +236,7 @@ TclInitObjSubsystem()
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_RegisterObjType(&tclWideIntType);
-#endif
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
@@ -1108,8 +1109,10 @@ SetBooleanFromAny(interp, objPtr)
newBool = (objPtr->internalRep.longValue != 0);
} else if (objPtr->typePtr == &tclDoubleType) {
newBool = (objPtr->internalRep.doubleValue != 0.0);
-#ifndef TCL_WIDE_INT_IS_LONG
} else if (objPtr->typePtr == &tclWideIntType) {
+#ifdef TCL_WIDE_INT_IS_LONG
+ newBool = (objPtr->internalRep.longValue != 0);
+#else /* !TCL_WIDE_INT_IS_LONG */
newBool = (objPtr->internalRep.wideValue != Tcl_LongAsWide(0));
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
diff --git a/tests/dict.test b/tests/dict.test
index 6d27533..d139c54 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: dict.test,v 1.1 2003/04/05 01:03:21 dkf Exp $
+# RCS: @(#) $Id: dict.test,v 1.2 2003/04/07 10:12:12 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -62,6 +62,14 @@ test dict-2.4 {dict create command} {
test dict-2.5 {dict create command} {
list [catch {dict create a b c} msg] $msg
} {1 {wrong # args: should be "dict create ?key value ...?"}}
+test dict-2.6 {dict create command - initialse refcount field!} {
+ # Bug 715751 will show up in memory debuggers like purify
+ for {set i 0} {$i<10} {incr i} {
+ set dictv [dict create a 0]
+ set share [dict values $dictv]
+ list [dict incr dictv a]
+ }
+} {}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b