summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tcl.h4
-rw-r--r--generic/tclDictObj.c18
-rw-r--r--generic/tclExecute.c4
-rw-r--r--generic/tclHash.c13
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclOO.c5
-rw-r--r--generic/tclProc.c96
-rw-r--r--tests/string.test26
-rw-r--r--tests/utf.test4
9 files changed, 83 insertions, 89 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 183cc1c..7e95061 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -1289,8 +1289,8 @@ typedef struct Tcl_HashSearch {
typedef struct {
void *next; /* Search position for underlying hash
* table. */
- int epoch; /* Epoch marker for dictionary being searched,
- * or -1 if search has terminated. */
+ unsigned int epoch; /* Epoch marker for dictionary being searched,
+ * or 0 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 1c74c5f..b1962e6 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -141,7 +141,7 @@ typedef struct Dict {
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
- int epoch; /* Epoch counter */
+ unsigned int epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
@@ -390,7 +390,7 @@ DupDictInternalRep(
* Initialise other fields.
*/
- newDict->epoch = 0;
+ newDict->epoch = 1;
newDict->chain = NULL;
newDict->refCount = 1;
@@ -710,7 +710,7 @@ SetDictFromAny(
*/
TclFreeIntRep(objPtr);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(objPtr) = dict;
@@ -1109,7 +1109,7 @@ Tcl_DictObjFirst(
dict = DICT(dictPtr);
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
- searchPtr->epoch = -1;
+ searchPtr->epoch = 0;
*donePtr = 1;
} else {
*donePtr = 0;
@@ -1170,7 +1170,7 @@ Tcl_DictObjNext(
* If the searh is done; we do no work.
*/
- if (searchPtr->epoch == -1) {
+ if (!searchPtr->epoch) {
*donePtr = 1;
return;
}
@@ -1227,8 +1227,8 @@ Tcl_DictObjDone(
{
Dict *dict;
- if (searchPtr->epoch != -1) {
- searchPtr->epoch = -1;
+ if (searchPtr->epoch) {
+ searchPtr->epoch = 0;
dict = (Dict *) searchPtr->dictionaryPtr;
if (dict->refCount-- <= 1) {
DeleteDict(dict);
@@ -1380,7 +1380,7 @@ Tcl_NewDictObj(void)
TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(dictPtr) = dict;
@@ -1430,7 +1430,7 @@ Tcl_DbNewDictObj(
TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(dictPtr) = dict;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d43ddfd..3eba833 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1333,12 +1333,12 @@ TclStackAlloc(
int numBytes)
{
Interp *iPtr = (Interp *) interp;
- int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
+ int numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) ckalloc(numBytes);
}
-
+ numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
return (void *) StackAllocWords(interp, numWords);
}
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 3c820c0..32c9aec 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -985,12 +985,18 @@ static void
RebuildTable(
register Tcl_HashTable *tablePtr) /* Table to enlarge. */
{
- int oldSize, count, index;
- Tcl_HashEntry **oldBuckets;
+ int count, index, oldSize = tablePtr->numBuckets;
+ Tcl_HashEntry **oldBuckets = tablePtr->buckets;
register Tcl_HashEntry **oldChainPtr, **newChainPtr;
register Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
+ /* Avoid outgrowing capability of the memory allocators */
+ if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) {
+ tablePtr->rebuildSize = INT_MAX;
+ return;
+ }
+
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
@@ -1002,9 +1008,6 @@ RebuildTable(
typePtr = &tclArrayHashKeyType;
}
- oldSize = tablePtr->numBuckets;
- oldBuckets = tablePtr->buckets;
-
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 5b06e5a..f22e4ad 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4446,7 +4446,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
/*
*----------------------------------------------------------------
- * Macro used by the Tcl core to increment a namespace's export export epoch
+ * Macro used by the Tcl core to increment a namespace's export epoch
* counter. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr);
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 51731d3..e48158c 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -538,7 +538,8 @@ KillFoundation(
* AllocObject --
*
* Allocate an object of basic type. Does not splice the object into its
- * class's instance list.
+ * class's instance list. The caller must set the classPtr on the object,
+ * either to a class or to NULL.
*
* ----------------------------------------------------------------------
*/
@@ -1701,6 +1702,8 @@ Tcl_NewObjectInstance(
AllocClass(interp, oPtr);
oPtr->selfCls = classPtr;
TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ } else {
+ oPtr->classPtr = NULL;
}
/*
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 96bdcf3..8fc6dcb 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -393,13 +393,13 @@ TclCreateProc(
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
- const char **argArray = NULL;
register Proc *procPtr;
- int i, length, result, numArgs;
- const char *args, *bytes, *p;
+ int i, result, numArgs, plen;
+ const char *bytes, *argname, *argnamei;
+ char argnamelast;
register CompiledLocal *localPtr = NULL;
- Tcl_Obj *defPtr;
+ Tcl_Obj *defPtr, *errorObj, **argArray;
int precompiled = 0;
if (bodyPtr->typePtr == &tclProcBodyType) {
@@ -436,6 +436,7 @@ TclCreateProc(
*/
if (Tcl_IsShared(bodyPtr)) {
+ int length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
@@ -473,12 +474,9 @@ TclCreateProc(
* argument specifier. If the body is precompiled, processing is limited
* to checking that the parsed argument is consistent with the one stored
* in the Proc.
- *
- * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS.
*/
- args = TclGetStringFromObj(argsPtr, &length);
- result = Tcl_SplitList(interp, args, &numArgs, &argArray);
+ result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray);
if (result != TCL_OK) {
goto procError;
}
@@ -502,28 +500,28 @@ TclCreateProc(
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength;
size_t valueLength;
- const char **fieldValues;
+ Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
- result = Tcl_SplitList(interp, argArray[i], &fieldCount,
+ result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
- ckfree(fieldValues);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "too many fields in argument specifier \"%s\"",
- argArray[i]));
+ errorObj = Tcl_NewStringObj(
+ "too many fields in argument specifier \"", -1);
+ Tcl_AppendObjToObj(errorObj, argArray[i]);
+ Tcl_AppendToObj(errorObj, "\"", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
- ckfree(fieldValues);
+ if ((fieldCount == 0) || (fieldValues[0]->length == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
@@ -531,9 +529,10 @@ TclCreateProc(
goto procError;
}
- nameLength = strlen(fieldValues[0]);
+ nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length);
if (fieldCount == 2) {
- valueLength = strlen(fieldValues[1]);
+ valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]),
+ fieldValues[1]->length);
} else {
valueLength = 0;
}
@@ -542,33 +541,29 @@ TclCreateProc(
* Check that the formal parameter name is a scalar.
*/
- p = fieldValues[0];
- while (*p != '\0') {
- if (*p == '(') {
- const char *q = p;
- do {
- q++;
- } while (*q != '\0');
- q--;
- if (*q == ')') { /* We have an array element. */
+ argname = Tcl_GetStringFromObj(fieldValues[0], &plen);
+ argnamei = argname;
+ argnamelast = argname[plen-1];
+ while (plen--) {
+ if (argnamei[0] == '(') {
+ if (argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
- fieldValues[0]));
- ckfree(fieldValues);
+ Tcl_GetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- } else if ((*p == ':') && (*(p+1) == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "formal parameter \"%s\" is not a simple name",
- fieldValues[0]));
- ckfree(fieldValues);
+ } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) {
+ errorObj = Tcl_NewStringObj("formal parameter \"", -1);
+ Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+ Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- p++;
+ argnamei = Tcl_UtfNext(argnamei);
}
if (precompiled) {
@@ -584,7 +579,7 @@ TclCreateProc(
*/
if ((localPtr->nameLength != nameLength)
- || (strcmp(localPtr->name, fieldValues[0]))
+ || (Tcl_UtfNcmp(localPtr->name, argname, nameLength))
|| (localPtr->frameIndex != i)
|| !(localPtr->flags & VAR_ARGUMENT)
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
@@ -592,7 +587,6 @@ TclCreateProc(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": formal parameter %d is "
"inconsistent with precompiled body", procName, i));
- ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
@@ -607,12 +601,13 @@ TclCreateProc(
size_t tmpLength = localPtr->defValuePtr->length;
if ((valueLength != tmpLength) ||
- strncmp(fieldValues[1], tmpPtr, tmpLength)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "procedure \"%s\": formal parameter \"%s\" has "
- "default value inconsistent with precompiled body",
- procName, fieldValues[0]));
- ckfree(fieldValues);
+ Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) {
+ errorObj = Tcl_ObjPrintf(
+ "procedure \"%s\": formal parameter \"" ,procName);
+ Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+ Tcl_AppendToObj(errorObj, "\" has "
+ "default value inconsistent with precompiled body", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
@@ -632,7 +627,7 @@ TclCreateProc(
* local variables for the argument.
*/
- localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1);
+ localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -640,19 +635,18 @@ TclCreateProc(
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
- localPtr->nameLength = nameLength;
+ localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length);
localPtr->frameIndex = i;
localPtr->flags = VAR_ARGUMENT;
localPtr->resolveInfo = NULL;
if (fieldCount == 2) {
- localPtr->defValuePtr =
- Tcl_NewStringObj(fieldValues[1], valueLength);
+ localPtr->defValuePtr = fieldValues[1];
Tcl_IncrRefCount(localPtr->defValuePtr);
} else {
localPtr->defValuePtr = NULL;
}
- memcpy(localPtr->name, fieldValues[0], nameLength + 1);
+ memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
if ((i == numArgs - 1)
&& (localPtr->nameLength == 4)
&& (localPtr->name[0] == 'a')
@@ -660,12 +654,9 @@ TclCreateProc(
localPtr->flags |= VAR_IS_ARGS;
}
}
-
- ckfree(fieldValues);
}
*procPtrPtr = procPtr;
- ckfree(argArray);
return TCL_OK;
procError:
@@ -686,9 +677,6 @@ TclCreateProc(
}
ckfree(procPtr);
}
- if (argArray != NULL) {
- ckfree(argArray);
- }
return TCL_ERROR;
}
diff --git a/tests/string.test b/tests/string.test
index 83ad2d2..e36ebae 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -1697,40 +1697,40 @@ test string-24.4 {string reverse command - unshared string} {
string reverse $x$y
} edcba
test string-24.5 {string reverse command - shared unicode string} {
- set x abcde\udead
+ set x abcde\ud0ad
string reverse $x
-} \udeadedcba
+} \ud0adedcba
test string-24.6 {string reverse command - unshared string} {
set x abc
- set y de\udead
+ set y de\ud0ad
string reverse $x$y
-} \udeadedcba
+} \ud0adedcba
test string-24.7 {string reverse command - simple case} {
string reverse a
} a
test string-24.8 {string reverse command - simple case} {
- string reverse \udead
-} \udead
+ string reverse \ud0ad
+} \ud0ad
test string-24.9 {string reverse command - simple case} {
string reverse {}
} {}
test string-24.10 {string reverse command - corner case} {
- set x \ubeef\udead
+ set x \ubeef\ud0ad
string reverse $x
-} \udead\ubeef
+} \ud0ad\ubeef
test string-24.11 {string reverse command - corner case} {
set x \ubeef
- set y \udead
+ set y \ud0ad
string reverse $x$y
-} \udead\ubeef
+} \ud0ad\ubeef
test string-24.12 {string reverse command - corner case} {
set x \ubeef
- set y \udead
+ set y \ud0ad
string is ascii [string reverse $x$y]
} 0
test string-24.13 {string reverse command - pure Unicode string} {
- string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5]
-} \udead\ubeef\udead\ubeef\udead
+ string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5]
+} \ud0ad\ubeef\ud0ad\ubeef\ud0ad
test string-24.14 {string reverse command - pure bytearray} {
binary scan [string reverse [binary format H* 010203]] H* x
set x
diff --git a/tests/utf.test b/tests/utf.test
index 422ab08..45f9c0c 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -68,10 +68,10 @@ test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestrin
} {1}
test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
string length [testbytestring "\xF0\x90\x80\x80"]
-} -result {1}
+} -result {2}
test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
string length [testbytestring "\xF4\x8F\xBF\xBF"]
-} -result {1}
+} -result {2}
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
string length [testbytestring "\xF0\x8F\xBF\xBF"]
} {4}
generated by cgit v0.12 at 2025-09-05 14:51:54 (GMT)