diff options
62 files changed, 776 insertions, 524 deletions
diff --git a/ChangeLog.2000 b/ChangeLog.2000 index 0d20eaf..5b62351 100644 --- a/ChangeLog.2000 +++ b/ChangeLog.2000 @@ -414,7 +414,7 @@ Tcl_IsChannelExisting, and Tcl_ClearChannelHandlers to conform to the new stacked channel implementation. Their stub slots were also moved to give preference to the new 8.3.2 stub functions. This will cause an - incompatability with 8.4a1 only. + incompatibility with 8.4a1 only. (StopCopy): fixed a bug introduced by a partial fix in 8.3.2 that didn't set nonBlocking correctly when resetting the flags for the write side. [Bug: 6261] diff --git a/ChangeLog.2002 b/ChangeLog.2002 index 30b8b17..9931657 100644 --- a/ChangeLog.2002 +++ b/ChangeLog.2002 @@ -847,7 +847,7 @@ exit. * tests/exec.test: marked exec-18.1 unixOnly until the Windows - incompatability (in the test, not the core) can be resolved. + incompatibility (in the test, not the core) can be resolved. * tests/http.test (http-3.11): added close $fp that was causing an error on Windows because the file was not closed before deleting. @@ -3642,7 +3642,7 @@ * compat/strtoll.c (strtoll): * compat/strtoull.c (strtoull): * unix/tclUnixPort.h: - * win/tclWinPort.h: Const-ing 64-bit compatability declarations. Note + * win/tclWinPort.h: Const-ing 64-bit compatibility declarations. Note that the return pointer is non-const because it is entirely legal for the functions to be called from somewhere that owns the string being passed. Fixes problem reported by Larry Virden. @@ -3779,7 +3779,7 @@ There are a lot of changes from this TIP, so please see http://purl.org/tcl/tip/72.html for discussion of - backward-compatability issues, but the main ones modifications are in: + backward-compatibility issues, but the main ones modifications are in: * generic/tcl.h: New types. * generic/tcl.decls: New public functions. diff --git a/ChangeLog.2003 b/ChangeLog.2003 index c586ba9..3c3ee11 100644 --- a/ChangeLog.2003 +++ b/ChangeLog.2003 @@ -947,7 +947,7 @@ declarations match and will end up using the declarations in the public code from now on because of #include ordering. Keeping the old declarations in tclInt.decls; there's no need to gratuitously break - compatability for those extensions which are already clients of the + compatibility for those extensions which are already clients of the namespace code. 2003-08-23 Zoran Vasiljevic <zoran@archiwrae.com> @@ -1278,7 +1278,7 @@ * generic/tclVar.c (Tcl_ArrayObjCmd, TclArraySet): Made [array get] and [array set] work with dictionaries, producing them and consuming - them. Note that for compatability reasons, you will never get a dict + them. Note that for compatibility reasons, you will never get a dict from feeding a string literal to [array set] since that alters the trace behaviour of "multi-key" sets. [Bug 759935] diff --git a/ChangeLog.2004 b/ChangeLog.2004 index 82acd5c..daf124f 100644 --- a/ChangeLog.2004 +++ b/ChangeLog.2004 @@ -1356,7 +1356,7 @@ 2004-10-07 Donal K. Fellows <donal.k.fellows@man.ac.uk> * *.3: Convert CONST to const and VOID to void so we document how - people should actually use the Tcl API and not the compatability hacks + people should actually use the Tcl API and not the compatibility hacks that it has to have. * doc/man.macros, *.3: Update .AS macro so it can know how wide to diff --git a/generic/regcustom.h b/generic/regcustom.h index 647b423..c4dbc73 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -36,9 +36,9 @@ * Overrides for regguts.h definitions, if any. */ -#define MALLOC(n) ((void*)(attemptckalloc(n))) +#define MALLOC(n) (void*)(attemptckalloc(n)) #define FREE(p) ckfree((void*)(p)) -#define REALLOC(p,n) ((void*)(attemptckrealloc((void*)(p),n))) +#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n)) /* * Do not insert extras between the "begin" and "end" lines - this chunk is diff --git a/generic/regguts.h b/generic/regguts.h index 0e38745..b3dbaa4 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -54,10 +54,10 @@ #define MALLOC(n) malloc(n) #endif #ifndef REALLOC -#define REALLOC(p, n) realloc((void*)(p), n) +#define REALLOC(p, n) realloc(p, n) #endif #ifndef FREE -#define FREE(p) free((void*)(p)) +#define FREE(p) free(p) #endif /* want size of a char in bits, and max value in bounded quantifiers */ @@ -70,7 +70,6 @@ */ #define NOTREACHED 0 -#define xxx 1 #define DUPMAX _POSIX2_RE_DUP_MAX #define DUPINF (DUPMAX+1) @@ -382,7 +381,7 @@ struct subre { */ struct fns { - void (*free)(regex_t *); + void (*free) (regex_t *); }; /* diff --git a/generic/tcl.h b/generic/tcl.h index 37e0b19..f63b14b 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -960,10 +960,8 @@ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ - void *hash; /* Hash value, stored as pointer to ensure - * that the offsets of the fields in this - * structure are not changed. */ - ClientData clientData; /* Application stores something here with + size_t hash; /* Hash value. */ + void *clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ char *oneWordValue; /* One-word value for key. */ @@ -1057,10 +1055,10 @@ struct Tcl_HashTable { * table. */ size_t rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ + size_t mask; /* Mask value used in hashing function. */ int downShift; /* Shift count used in hashing function. * Designed to use high-order bits of * randomized keys. */ - int mask; /* Mask value used in hashing function. */ int keyType; /* Type of keys used in this table. It's * either TCL_CUSTOM_KEYS, TCL_STRING_KEYS, * TCL_ONE_WORD_KEYS, or an integer giving the @@ -1099,9 +1097,9 @@ typedef struct Tcl_HashSearch { * TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the * pointer is stored in the entry. * - * While maintaining binary compatability the above have to be distinct values + * While maintaining binary compatibility the above have to be distinct values * as they are used to differentiate between old versions of the hash table - * which don't have a typePtr and new ones which do. Once binary compatability + * which don't have a typePtr and new ones which do. Once binary compatibility * is discarded in favour of making more wide spread changes TCL_STRING_KEYS * can be the same as TCL_CUSTOM_TYPE_KEYS, and TCL_ONE_WORD_KEYS can be the * same as TCL_CUSTOM_PTR_KEYS because they simply determine how the key is @@ -2354,7 +2352,7 @@ TCLAPI void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); */ #define Tcl_GetHashValue(h) ((h)->clientData) -#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) +#define Tcl_SetHashValue(h, value) ((h)->clientData = (void *) (value)) #define Tcl_GetHashKey(tablePtr, h) \ ((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \ (tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \ diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index cda1f38..3319c06 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -274,8 +274,8 @@ TclpAlloc( if (numBytes >= MAXMALLOC - OVERHEAD) { if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + OVERHEAD + numBytes), 0); + bigBlockPtr = (struct block *) TclpSysAlloc( + sizeof(struct block) + OVERHEAD + numBytes); } if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); @@ -405,8 +405,8 @@ MoreCore( numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + amount), 1); + blockPtr = (struct block *) TclpSysAlloc( + sizeof(struct block) + amount); /* no more room! */ if (blockPtr == NULL) { return; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d7e9fb3..7ef671a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -569,7 +569,7 @@ Tcl_CreateInterp(void) iPtr->cmdCount = 0; TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 0; + iPtr->compileEpoch = 1; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; @@ -2969,13 +2969,6 @@ Tcl_DeleteCommandFromToken( Tcl_Command importCmd; /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; - - /* * The code here is tricky. We can't delete the hash table entry before * invoking the deletion callback because there are cases where the * deletion callback needs to invoke the command (e.g. object systems such @@ -2997,6 +2990,14 @@ Tcl_DeleteCommandFromToken( Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + return 0; } @@ -3099,6 +3100,13 @@ Tcl_DeleteCommandFromToken( if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; } /* diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 24a9aa5..b599875 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -155,35 +155,108 @@ static const EnsembleImplMap decodeMap[] = { }; /* - * The following object type represents an array of bytes. An array of bytes - * is not equivalent to an internationalized string. Conceptually, a string is - * an array of 16-bit quantities organized as a sequence of properly formed - * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. - * Accessor functions are provided to convert a ByteArray to a String or a - * String to a ByteArray. Two or more consecutive bytes in an array of bytes - * may look like a single UTF-8 character if the array is casually treated as - * a string. But obtaining the String from a ByteArray is guaranteed to - * produced properly formed UTF-8 sequences so that there is a one-to-one map - * between bytes and characters. - * - * Converting a ByteArray to a String proceeds by casting each byte in the - * array to a 16-bit quantity, treating that number as a Unicode character, - * and storing the UTF-8 version of that Unicode character in the String. For - * ByteArrays consisting entirely of values 1..127, the corresponding String - * representation is the same as the ByteArray representation. - * - * Converting a String to a ByteArray proceeds by getting the Unicode - * representation of each character in the String, casting it to a byte by - * truncating the upper 8 bits, and then storing the byte in the ByteArray. - * Converting from ByteArray to String and back to ByteArray is not lossy, but - * converting an arbitrary String to a ByteArray may be. + * The following object types represent an array of bytes. The intent is + * to allow arbitrary binary data to pass through Tcl as a Tcl value + * without loss or damage. Such values are useful for things like + * encoded strings or Tk images to name just two. + * + * It's strange to have two Tcl_ObjTypes in place for this task when + * one would do, so a bit of detail and history how we got to this point + * and where we might go from here. + * + * A bytearray is an ordered sequence of bytes. Each byte is an integer + * value in the range [0-255]. To be a Tcl value type, we need a way to + * encode each value in the value set as a Tcl string. The simplest + * encoding is to represent each byte value as the same codepoint value. + * A bytearray of N bytes is encoded into a Tcl string of N characters + * where the codepoint of each character is the value of corresponding byte. + * This approach creates a one-to-one map between all bytearray values + * and a subset of Tcl string values. + * + * When converting a Tcl string value to the bytearray internal rep, the + * question arises what to do with strings outside that subset? That is, + * those Tcl strings containing at least one codepoint greater than 255? + * The obviously correct answer is to raise an error! That string value + * does not represent any valid bytearray value. Full Stop. The + * setFromAnyProc signature has a completion code return value for just + * this reason, to reject invalid inputs. + * + * Unfortunately this was not the path taken by the authors of the + * original tclByteArrayType. They chose to accept all Tcl string values + * as acceptable string encodings of the bytearray values that result + * from masking away the high bits of any codepoint value at all. This + * meant that every bytearray value had multiple accepted string + * representations. + * + * The implications of this choice are truly ugly. When a Tcl value has + * a string representation, we are required to accept that as the true + * value. Bytearray values that possess a string representation cannot + * be processed as bytearrays because we cannot know which true value + * that bytearray represents. The consequence is that we drag around + * an internal rep that we cannot make any use of. This painful price + * is extracted at any point after a string rep happens to be generated + * for the value. This happens even when the troublesome codepoints + * outside the byte range never show up. This happens rather routinely + * in normal Tcl operations unless we burden the script writer with the + * cognitive burden of avoiding it. The price is also paid by callers + * of the C interface. The routine + * + * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) + * + * has a guarantee to always return a non-NULL value, but that value + * points to a byte sequence that cannot be used by the caller to + * process the Tcl value absent some sideband testing that objPtr + * is "pure". Tcl offers no public interface to perform this test, + * so callers either break encapsulation or are unavoidably buggy. Tcl + * has defined a public interface that cannot be used correctly. The + * Tcl source code itself suffers the same problem, and has been buggy, + * but progressively less so as more and more portions of the code have + * been retrofitted with the required "purity testing". The set of values + * able to pass the purity test can be increased via the introduction of + * a "canonical" flag marker, but the only way the broken interface itself + * can be discarded is to start over and define the Tcl_ObjType properly. + * Bytearrays should simply be usable as bytearrays without a kabuki + * dance of testing. + * + * The Tcl_ObjType "properByteArrayType" is (nearly) a correct + * implementation of bytearrays. Any Tcl value with the type + * properByteArrayType can have its bytearray value fetched and + * used with confidence that acting on that value is equivalent to + * acting on the true Tcl string value. This still implies a side + * testing burden -- past mistakes will not let us avoid that + * immediately, but it is at least a conventional test of type, and + * can be implemented entirely by examining the objPtr fields, with + * no need to query the intrep, as a canonical flag would require. + * + * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can + * be revised to admit the possibility of returning NULL when the true + * value is not a valid bytearray, we need a mechanism to retain + * compatibility with the deployed callers of the broken interface. + * That's what the retained "tclByteArrayType" provides. In those + * unusual circumstances where we convert an invalid bytearray value + * to a bytearray type, it is to this legacy type. Essentially any + * time this legacy type gets used, it's a signal of a bug being ignored. + * A TIP should be drafted to remove this connection to the broken past + * so that Tcl 9 will no longer have any trace of it. Prescribing a + * migration path will be the key element of that work. The internal + * changes now in place are the limit of what can be done short of + * interface repair. They provide a great expansion of the histories + * over which bytearray values can be useful in the meanwhile. */ -const Tcl_ObjType tclByteArrayType = { +static const Tcl_ObjType properByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, UpdateStringOfByteArray, + NULL +}; + +const Tcl_ObjType tclByteArrayType = { + "bytearray", + FreeByteArrayInternalRep, + DupByteArrayInternalRep, + NULL, SetByteArrayFromAny }; @@ -211,6 +284,12 @@ typedef struct { #define SET_BYTEARRAY(objPtr, baPtr) \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) +int +TclIsPureByteArray( + Tcl_Obj * objPtr) +{ + return (objPtr->typePtr == &properByteArrayType); +} /* *---------------------------------------------------------------------- @@ -341,7 +420,7 @@ Tcl_SetByteArrayObj( if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; + objPtr->typePtr = &properByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } @@ -371,7 +450,8 @@ Tcl_GetByteArrayFromObj( { ByteArray *baPtr; - if (objPtr->typePtr != &tclByteArrayType) { + if ((objPtr->typePtr != &properByteArrayType) + && (objPtr->typePtr != &tclByteArrayType)) { SetByteArrayFromAny(NULL, objPtr); } baPtr = GET_BYTEARRAY(objPtr); @@ -414,7 +494,8 @@ Tcl_SetByteArrayLength( if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if (objPtr->typePtr != &tclByteArrayType) { + if ((objPtr->typePtr != &properByteArrayType) + && (objPtr->typePtr != &tclByteArrayType)) { SetByteArrayFromAny(NULL, objPtr); } @@ -451,29 +532,36 @@ SetByteArrayFromAny( Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { size_t length; + int improper = 0; const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; Tcl_UniChar ch; - if (objPtr->typePtr != &tclByteArrayType) { - src = TclGetString(objPtr); - length = objPtr->length; - srcEnd = src + length; - - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += Tcl_UtfToUniChar(src, &ch); - *dst++ = UCHAR(ch); - } + if (objPtr->typePtr == &properByteArrayType) { + return TCL_OK; + } + if (objPtr->typePtr == &tclByteArrayType) { + return TCL_OK; + } - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; + src = TclGetString(objPtr); + length = objPtr->length; + srcEnd = src + length; - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += Tcl_UtfToUniChar(src, &ch); + improper = improper || (ch > 255); + *dst++ = UCHAR(ch); } + + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; + + TclFreeIntRep(objPtr); + objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); return TCL_OK; } @@ -536,7 +624,7 @@ DupByteArrayInternalRep( memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); SET_BYTEARRAY(copyPtr, copyArrayPtr); - copyPtr->typePtr = &tclByteArrayType; + copyPtr->typePtr = srcPtr->typePtr; } /* @@ -586,7 +674,7 @@ UpdateStringOfByteArray( } } if (size == (size_t)-1) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + Tcl_Panic("max size for a Tcl value exceeded"); } dst = ckalloc(size + 1); @@ -643,7 +731,8 @@ TclAppendBytesToByteArray( /* Append zero bytes is a no-op. */ return; } - if (objPtr->typePtr != &tclByteArrayType) { + if ((objPtr->typePtr != &properByteArrayType) + && (objPtr->typePtr != &tclByteArrayType)) { SetByteArrayFromAny(NULL, objPtr); } byteArrayPtr = GET_BYTEARRAY(objPtr); diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 800e272..b56df6d 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -32,14 +32,14 @@ */ typedef struct { - int refCount; /* Number of mem_headers referencing this + size_t refCount; /* Number of mem_headers referencing this * tag. */ char string[1]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString)) +#define TAG_SIZE(bytesInString) ((TclOffset(MemTag, string) + 1) + bytesInString) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ @@ -50,14 +50,14 @@ static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * to help detect chunk under-runs. */ -#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ const char *file; - long length; + size_t length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus @@ -249,10 +249,10 @@ ValidateMemory( } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "low guard failed at %lx, %s %d\n", - (long unsigned) memHeaderP->body, file, line); + fprintf(stderr, "low guard failed at %p, %s %d\n", + memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, + fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n", (Tcl_WideInt) memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } @@ -271,11 +271,11 @@ ValidateMemory( if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "high guard failed at %lx, %s %d\n", - (long unsigned) memHeaderP->body, file, line); + fprintf(stderr, "high guard failed at %p, %s %d\n", + memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", - memHeaderP->length, memHeaderP->file, + fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n", + (Tcl_WideInt)memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } @@ -357,10 +357,10 @@ Tcl_DumpActiveMemory( Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body[0]; - fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", - (long unsigned) address, - (long unsigned) address + memScanP->length - 1, - memScanP->length, memScanP->file, memScanP->line, + fprintf(fileP, "%8" TCL_LL_MODIFIER "x - %8" TCL_LL_MODIFIER "x %7" TCL_LL_MODIFIER "d @ %s %d %s", + (Tcl_WideInt)(size_t)address, + (Tcl_WideInt)((size_t)address + memScanP->length - 1), + (Tcl_WideInt)memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } @@ -456,8 +456,8 @@ Tcl_DbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", - (long unsigned int) result->body, size, file, line); + fprintf(stderr,"ckalloc %p %u %s %d\n", + result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { @@ -545,8 +545,8 @@ Tcl_AttemptDbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", - (long unsigned int) result->body, size, file, line); + fprintf(stderr,"ckalloc %p %u %s %d\n", + result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { @@ -610,8 +610,8 @@ Tcl_DbCkfree( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "ckfree %lx %ld %s %d\n", - (long unsigned int) memp->body, memp->length, file, line); + fprintf(stderr, "ckfree %p %" TCL_LL_MODIFIER "d %s %d\n", + memp->body, (Tcl_WideInt) memp->length, file, line); } if (validate_memory) { @@ -621,7 +621,7 @@ Tcl_DbCkfree( Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { - memset(ptr, GUARD_VALUE, (size_t) memp->length); + memset(ptr, GUARD_VALUE, memp->length); } total_frees++; @@ -629,8 +629,7 @@ Tcl_DbCkfree( current_bytes_malloced -= memp->length; if (memp->tagPtr != NULL) { - memp->tagPtr->refCount--; - if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { + if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) { TclpFree((char *) memp->tagPtr); } } @@ -673,7 +672,7 @@ Tcl_DbCkrealloc( int line) { char *newPtr; - unsigned int copySize; + size_t copySize; struct mem_header *memp; if (ptr == NULL) { @@ -687,7 +686,7 @@ Tcl_DbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > (unsigned int) memp->length) { + if (copySize > memp->length) { copySize = memp->length; } newPtr = Tcl_DbCkalloc(size, file, line); @@ -704,7 +703,7 @@ Tcl_AttemptDbCkrealloc( int line) { char *newPtr; - unsigned int copySize; + size_t copySize; struct mem_header *memp; if (ptr == NULL) { @@ -718,7 +717,7 @@ Tcl_AttemptDbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > (unsigned int) memp->length) { + if (copySize > memp->length) { copySize = memp->length; } newPtr = Tcl_AttemptDbCkalloc(size, file, line); diff --git a/generic/tclClock.c b/generic/tclClock.c index 73f3416..e9d3347 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -92,7 +92,7 @@ static const char *const literals[] = { */ typedef struct { - int refCount; /* Number of live references. */ + size_t refCount; /* Number of live references. */ Tcl_Obj **literals; /* Pool of object literals. */ } ClockClientData; @@ -2060,8 +2060,7 @@ ClockDeleteCmdProc( ClockClientData *data = clientData; int i; - data->refCount--; - if (data->refCount == 0) { + if (data->refCount-- <= 1) { for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(data->literals[i]); } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index bb60697..ccf5429 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1199,7 +1199,7 @@ StringFirstCmd( return TCL_OK; } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFind(objv[1], + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclStringFind(objv[1], objv[2], start))); return TCL_OK; } @@ -2118,9 +2118,7 @@ StringReptCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *string1; - char *string2; - int count, index, length1, length2; + int count; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2138,70 +2136,15 @@ StringReptCmd( if (count == 1) { Tcl_SetObjResult(interp, objv[1]); - goto done; + return TCL_OK; } else if (count < 1) { - goto done; - } - string1 = TclGetStringFromObj(objv[1], &length1); - if (length1 <= 0) { - goto done; - } - - /* - * Only build up a string that has data. Instead of building it up with - * repeated appends, we just allocate the necessary space once and copy - * the string value in. - * - * We have to worry about overflow [Bugs 714106, 2561746]. - * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX. - * We need to keep 2 <= length2 <= INT_MAX. - */ - - if (count > INT_MAX/length1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "result exceeds max size for a Tcl value (%d bytes)", - INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; + return TCL_OK; } - length2 = length1 * count; - - /* - * Include space for the NUL. - */ - - string2 = attemptckalloc((unsigned) length2 + 1); - if (string2 == NULL) { - /* - * Alloc failed. Note that in this case we try to do an error message - * since this is a case that's most likely when the alloc is large and - * that's easy to do with this API. Note that if we fail allocating a - * short string, this will likely keel over too (and fatally). - */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "string size overflow, out of memory allocating %u bytes", - length2 + 1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + if (TCL_OK != TclStringRepeat(interp, objv[1], count, &resultPtr)) { return TCL_ERROR; } - for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, (size_t) length1); - } - string2[length2] = '\0'; - - /* - * We have to directly assign this instead of using Tcl_SetStringObj (and - * indirectly TclInitStringRep) because that makes another copy of the - * data. - */ - - TclNewObj(resultPtr); - resultPtr->bytes = string2; - resultPtr->length = length2; Tcl_SetObjResult(interp, resultPtr); - - done: return TCL_OK; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 0681097..915e1e7 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1096,7 +1096,7 @@ MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - size_t length, TCL_HASH_TYPE hash, int *newPtr, + size_t length, size_t hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1110,7 +1110,7 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); -MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, size_t index); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index f1e6218..7f467a4 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3782,13 +3782,4 @@ extern const TclStubs *tclStubsPtr; Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) #endif /* !TCL_NO_DEPRECATED */ -#if defined(USE_TCL_STUBS) && !defined(TCL_COMPAT_8) -# undef Tcl_GetString -# define Tcl_GetString(obj) \ - ((obj)?((obj)->bytes?(obj)->bytes:tclStubsPtr->tcl_GetString(obj)):(char *)(obj)) -# undef Tcl_GetStringFromObj -# define Tcl_GetStringFromObj(obj, lengthPtr) \ - ((obj)?(Tcl_GetString(obj),(*(lengthPtr)=(obj)->length),(obj)->bytes):((*(lengthPtr)=0),(char *)(obj))) -#endif - #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 2b8f42a..7481543 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -235,7 +235,7 @@ AllocChainEntry( cPtr = ckalloc(sizeof(ChainEntry)); cPtr->entry.key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); - cPtr->entry.clientData = NULL; + Tcl_SetHashValue(&cPtr->entry, NULL); cPtr->prevPtr = cPtr->nextPtr = NULL; return &cPtr->entry; @@ -492,7 +492,7 @@ UpdateStringOfDict( Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - int i, length, bytesNeeded = 0; + size_t i, length, bytesNeeded = 0; const char *elem; char *dst; @@ -501,7 +501,7 @@ UpdateStringOfDict( * is not exposed by any API function... */ - int numElems = dict->table.numEntries * 2; + size_t numElems = dict->table.numEntries * 2; /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { @@ -527,22 +527,15 @@ UpdateStringOfDict( flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); - elem = TclGetStringFromObj(keyPtr, &length); + elem = TclGetString(keyPtr); + length = keyPtr->length; bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } flagPtr[i+1] = TCL_DONT_QUOTE_HASH; valuePtr = Tcl_GetHashValue(&cPtr->entry); - elem = TclGetStringFromObj(valuePtr, &length); + elem = TclGetString(valuePtr); + length = valuePtr->length; bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); - if (bytesNeeded < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - } - if (bytesNeeded > INT_MAX - numElems + 1) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; @@ -556,13 +549,15 @@ UpdateStringOfDict( for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); - elem = TclGetStringFromObj(keyPtr, &length); + elem = TclGetString(keyPtr); + length = keyPtr->length; dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; flagPtr[i+1] |= TCL_DONT_QUOTE_HASH; valuePtr = Tcl_GetHashValue(&cPtr->entry); - elem = TclGetStringFromObj(valuePtr, &length); + elem = TclGetString(valuePtr); + length = valuePtr->length; dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index ff0351a..64306f3 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -273,8 +273,8 @@ DisassembleByteCodeObj( sprintf(ptrBuf2, "%p", iPtr); Tcl_AppendPrintfToObj(bufferObj, "ByteCode 0x%s, refCt %" TCL_LL_MODIFIER "u, epoch %" TCL_LL_MODIFIER "u, interp 0x%s (epoch %" TCL_LL_MODIFIER "u)\n", - ptrBuf1, (Tcl_WideInt)codePtr->refCount, (Tcl_WideInt)codePtr->compileEpoch, ptrBuf2, - (Tcl_WideInt)iPtr->compileEpoch); + ptrBuf1, (Tcl_WideUInt)codePtr->refCount, (Tcl_WideUInt)codePtr->compileEpoch, ptrBuf2, + (Tcl_WideUInt)iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); @@ -318,8 +318,8 @@ DisassembleByteCodeObj( sprintf(ptrBuf1, "%p", procPtr); Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, + " Proc 0x%s, refCt %" TCL_LL_MODIFIER "d, args %d, compiled locals %d\n", + ptrBuf1, (Tcl_WideUInt)procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d4b6cf1..3dd471d 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -46,7 +46,7 @@ typedef struct { * nullSize is 2, this is a function that * returns the number of bytes in a 0x0000 * terminated string. */ - int refCount; /* Number of uses of this structure. */ + size_t refCount; /* Number of uses of this structure. */ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ } Encoding; @@ -782,11 +782,7 @@ FreeEncoding( if (encodingPtr == NULL) { return; } - if (encodingPtr->refCount<=0) { - Tcl_Panic("FreeEncoding: refcount problem !!!"); - } - encodingPtr->refCount--; - if (encodingPtr->refCount == 0) { + if (encodingPtr->refCount-- <= 1) { if (encodingPtr->freeProc != NULL) { encodingPtr->freeProc(encodingPtr->clientData); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index f240c0e..1eb1211 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1661,7 +1661,7 @@ NsEnsembleImplementationCmdNR( int reparseCount = 0; /* Number of reparses. */ Tcl_Obj *errorObj; /* Used for building error messages. */ Tcl_Obj *subObj; - int subIdx; + size_t subIdx; /* * Must recheck objc, since numParameters might have changed. Cf. test @@ -1670,7 +1670,7 @@ NsEnsembleImplementationCmdNR( restartEnsembleParse: subIdx = 1 + ensemblePtr->numParameters; - if (objc < subIdx + 1) { + if ((size_t)objc < subIdx + 1) { /* * We don't have a subcommand argument. Make error message. */ @@ -1767,15 +1767,16 @@ NsEnsembleImplementationCmdNR( * it (will be an error for a non-unique * prefix). */ char *fullName = NULL; /* Full name of the subcommand. */ - int stringLength, i; - int tableLength = ensemblePtr->subcommandTable.numEntries; + size_t stringLength, i; + size_t tableLength = ensemblePtr->subcommandTable.numEntries; Tcl_Obj *fix; - subcmdName = TclGetStringFromObj(subObj, &stringLength); + subcmdName = TclGetString(subObj); + stringLength = subObj->length; for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], - (unsigned) stringLength); + stringLength); if (cmp == 0) { if (fullName != NULL) { @@ -1976,8 +1977,8 @@ TclClearRootEnsemble( int TclInitRewriteEnsemble( Tcl_Interp *interp, - int numRemoved, - int numInserted, + size_t numRemoved, + size_t numInserted, Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; @@ -1989,7 +1990,7 @@ TclInitRewriteEnsemble( iPtr->ensembleRewrite.numRemovedObjs = numRemoved; iPtr->ensembleRewrite.numInsertedObjs = numInserted; } else { - int numIns = iPtr->ensembleRewrite.numInsertedObjs; + size_t numIns = iPtr->ensembleRewrite.numInsertedObjs; if (numIns < numRemoved) { iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns; @@ -2068,7 +2069,7 @@ TclSpellFix( Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, - int badIdx, + size_t badIdx, Tcl_Obj *bad, Tcl_Obj *fix) { @@ -2502,7 +2503,8 @@ BuildEnsembleConfig( Tcl_HashSearch search; /* Used for scanning the set of commands in * the namespace that backs up this * ensemble. */ - int i, j, isNew; + size_t i, j; + int isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; @@ -2535,7 +2537,7 @@ BuildEnsembleConfig( TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, &subcmdv); - for (i=0 ; i<subcmdc ; i++) { + for (i=0 ; (int)i<subcmdc ; i++) { const char *name = TclGetString(subcmdv[i]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); @@ -2700,7 +2702,7 @@ BuildEnsembleConfig( hPtr = Tcl_NextHashEntry(&search); } if (hash->numEntries > 1) { - qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries, + qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries, sizeof(char *), NsEnsembleStringOrder); } } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5f6d907..622bd68 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -73,7 +73,7 @@ int tclTraceExec = 0; * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is - * disjoint for backward-compatability reasons. + * disjoint for backward-compatibility reasons. */ static const char *const operatorStrings[] = { @@ -9319,9 +9319,9 @@ PrintByteCodeInfo( Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, - iPtr->compileEpoch); + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_LL_MODIFIER "u, epoch %" TCL_LL_MODIFIER "u, interp 0x%p (epoch %" TCL_LL_MODIFIER "u)\n", + codePtr, (Tcl_WideInt)codePtr->refCount, (Tcl_WideInt)codePtr->compileEpoch, iPtr, + (Tcl_WideInt)iPtr->compileEpoch); fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); diff --git a/generic/tclHash.c b/generic/tclHash.c index c077f89..5f7908e 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -243,8 +243,7 @@ CreateHashEntry( { register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; - unsigned int hash; - int index; + size_t hash, index; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -265,7 +264,7 @@ CreateHashEntry( index = hash & tablePtr->mask; } } else { - hash = PTR2UINT(key); + hash = (size_t) key; index = RANDOM_INDEX(tablePtr, hash); } @@ -278,7 +277,7 @@ CreateHashEntry( for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != PTR2UINT(hPtr->hash)) { + if (hash != hPtr->hash) { continue; } if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) { @@ -291,7 +290,7 @@ CreateHashEntry( } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != PTR2UINT(hPtr->hash)) { + if (hash != hPtr->hash) { continue; } if (key == hPtr->key.oneWordValue) { @@ -317,11 +316,11 @@ CreateHashEntry( } else { hPtr = ckalloc(sizeof(Tcl_HashEntry)); hPtr->key.oneWordValue = (char *) key; - hPtr->clientData = 0; + Tcl_SetHashValue(hPtr, NULL); } hPtr->tablePtr = tablePtr; - hPtr->hash = UINT2PTR(hash); + hPtr->hash = hash; hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; tablePtr->numEntries++; @@ -363,7 +362,7 @@ Tcl_DeleteHashEntry( const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; - int index; + size_t index; tablePtr = entryPtr->tablePtr; @@ -380,9 +379,9 @@ Tcl_DeleteHashEntry( if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash)); + index = RANDOM_INDEX(tablePtr, entryPtr->hash); } else { - index = PTR2UINT(entryPtr->hash) & tablePtr->mask; + index = entryPtr->hash & tablePtr->mask; } bucketPtr = &tablePtr->buckets[index]; @@ -616,17 +615,16 @@ Tcl_HashStats( */ result = ckalloc((NUM_COUNTERS * 60) + 300); - sprintf(result, "%" TCL_LL_MODIFIER "d entries in table, %" - TCL_LL_MODIFIER "d buckets\n", - (Tcl_WideInt) tablePtr->numEntries, (Tcl_WideInt)tablePtr->numBuckets); + sprintf(result, "%" TCL_LL_MODIFIER "d entries in table, %" TCL_LL_MODIFIER "d buckets\n", + (Tcl_WideInt)tablePtr->numEntries, (Tcl_WideInt)tablePtr->numBuckets); p = result + strlen(result); for (i = 0; i < NUM_COUNTERS; i++) { - sprintf(p, "number of buckets with %" TCL_LL_MODIFIER "d entries: %" TCL_LL_MODIFIER "d\n", - (Tcl_WideInt) i, (Tcl_WideInt) count[i]); + sprintf(p, "number of buckets with %d entries: %" TCL_LL_MODIFIER "d\n", + (int)i, (Tcl_WideInt)count[i]); p += strlen(p); } - sprintf(p, "number of buckets with %" TCL_LL_MODIFIER "d or more entries: %" TCL_LL_MODIFIER "d\n", - (Tcl_WideInt) NUM_COUNTERS, (Tcl_WideInt) overflow); + sprintf(p, "number of buckets with %d or more entries: %d\n", + NUM_COUNTERS, (int)overflow); p += strlen(p); sprintf(p, "average search distance for entry: %.1f", average); return result; @@ -671,7 +669,7 @@ AllocArrayEntry( count > 0; count--, iPtr1++, iPtr2++) { *iPtr2 = *iPtr1; } - hPtr->clientData = 0; + Tcl_SetHashValue(hPtr, NULL); return hPtr; } @@ -779,7 +777,7 @@ AllocStringEntry( } hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize); memcpy(hPtr->key.string, string, size); - hPtr->clientData = 0; + Tcl_SetHashValue(hPtr, NULL); return hPtr; } @@ -882,7 +880,7 @@ HashStringKey( * * BogusFind -- * - * This function is invoked when an Tcl_FindHashEntry is called on a + * This function is invoked when Tcl_FindHashEntry is called on a * table that has been deleted. * * Results: @@ -909,7 +907,7 @@ BogusFind( * * BogusCreate -- * - * This function is invoked when an Tcl_CreateHashEntry is called on a + * This function is invoked when Tcl_CreateHashEntry is called on a * table that has been deleted. * * Results: @@ -956,7 +954,7 @@ static void RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - int oldSize, count, index; + size_t oldSize, count, index; Tcl_HashEntry **oldBuckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; @@ -983,8 +981,8 @@ RebuildTable( tablePtr->numBuckets *= 4; if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { - tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned) - (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0); + tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc( + tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); } else { tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); @@ -1006,9 +1004,9 @@ RebuildTable( *oldChainPtr = hPtr->nextPtr; if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash)); + index = RANDOM_INDEX(tablePtr, hPtr->hash); } else { - index = PTR2UINT(hPtr->hash) & tablePtr->mask; + index = hPtr->hash & tablePtr->mask; } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; diff --git a/generic/tclIO.c b/generic/tclIO.c index b2196f7..4aaf399 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -321,7 +321,7 @@ static int WillRead(Channel *chanPtr); typedef struct ResolvedChanName { ChannelState *statePtr; /* The saved lookup result */ Tcl_Interp *interp; /* The interp in which the lookup was done. */ - int epoch; /* The epoch of the channel when the lookup + size_t epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ int refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; @@ -3044,7 +3044,7 @@ CloseChannel( if (chanPtr == statePtr->bottomChanPtr) { if (statePtr->channelName != NULL) { - ckfree((char *)statePtr->channelName); + ckfree(statePtr->channelName); statePtr->channelName = NULL; } diff --git a/generic/tclIO.h b/generic/tclIO.h index ffbfa31..07c54fa 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -214,7 +214,7 @@ typedef struct ChannelState { * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ - int epoch; /* Used to test validity of stored channelname + size_t epoch; /* Used to test validity of stored channelname * lookup results. */ } ChannelState; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 0c136b7..5e1478d 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -812,7 +812,7 @@ Tcl_WrongNumArgs( * NULL. */ { Tcl_Obj *objPtr; - int i, len, elemLen; + size_t i, len, elemLen; char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; @@ -832,8 +832,8 @@ Tcl_WrongNumArgs( */ if (iPtr->ensembleRewrite.sourceObjs != NULL) { - int toSkip = iPtr->ensembleRewrite.numInsertedObjs; - int toPrint = iPtr->ensembleRewrite.numRemovedObjs; + size_t toSkip = iPtr->ensembleRewrite.numInsertedObjs; + size_t toPrint = iPtr->ensembleRewrite.numRemovedObjs; Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; /* @@ -851,7 +851,7 @@ Tcl_WrongNumArgs( * confusing error message... */ - if (objc < toSkip) { + if ((size_t)objc < toSkip) { goto addNormalArgumentsToMessage; } @@ -878,7 +878,8 @@ Tcl_WrongNumArgs( elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); } else { - elementStr = TclGetStringFromObj(origObjv[i], &elemLen); + elementStr = TclGetString(origObjv[i]); + elemLen = origObjv[i]->length; } flags = 0; len = TclScanElement(elementStr, elemLen, &flags); @@ -912,7 +913,7 @@ Tcl_WrongNumArgs( */ addNormalArgumentsToMessage: - for (i = 0; i < objc; i++) { + for (i = 0; i < (size_t)objc; i++) { /* * If the object is an index type use the index table which allows for * the correct error message even if the subcommand was abbreviated. @@ -928,13 +929,14 @@ Tcl_WrongNumArgs( * Quote the argument if it contains spaces (Bug 942757). */ - elementStr = TclGetStringFromObj(objv[i], &elemLen); + elementStr = TclGetString(objv[i]); + elemLen = objv[i]->length; flags = 0; len = TclScanElement(elementStr, elemLen, &flags); if (len != elemLen) { char *quotedElementStr = TclStackAlloc(interp, - (unsigned) len + 1); + len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); @@ -950,7 +952,7 @@ Tcl_WrongNumArgs( * (either another element from objv, or the message string). */ - if (i<objc-1 || message!=NULL) { + if (i<(size_t)(objc-1) || message!=NULL) { Tcl_AppendStringsToObj(objPtr, " ", NULL); } } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 73e1279..99636a4 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1000,8 +1000,8 @@ declare 245 { Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr) } declare 246 { - int TclInitRewriteEnsemble(Tcl_Interp *interp, int numRemoved, - int numInserted, Tcl_Obj *const *objv) + int TclInitRewriteEnsemble(Tcl_Interp *interp, size_t numRemoved, + size_t numInserted, Tcl_Obj *const *objv) } declare 247 { void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble) diff --git a/generic/tclInt.h b/generic/tclInt.h index ecdfd21..780a3bf 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -282,11 +282,11 @@ typedef struct Namespace { * commands; however, no namespace qualifiers * are allowed. NULL if no export patterns are * registered. */ - int numExportPatterns; /* Number of export patterns currently + size_t numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ - int maxExportPatterns; /* Mumber of export patterns for which space + size_t maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - size_t cmdRefEpoch; /* Incremented if a newly added command + size_t cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to @@ -532,7 +532,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - int refCount; /* Used to ensure this structure is not + size_t refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -605,7 +605,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - int refCount; /* Counts number of active uses of this + size_t refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -937,7 +937,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - int refCount; /* Reference count: 1 if still present in + size_t refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -1054,7 +1054,7 @@ typedef struct AssocData { */ typedef struct LocalCache { - int refCount; + size_t refCount; int numVars; Tcl_Obj *varName0; } LocalCache; @@ -1216,7 +1216,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - int refCount; /* Number of times the word is on the + size_t refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1497,13 +1497,13 @@ typedef struct LiteralTable { LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ - int numBuckets; /* Total number of buckets allocated at + size_t numBuckets; /* Total number of buckets allocated at * **buckets. */ - int numEntries; /* Total number of entries present in + size_t numEntries; /* Total number of entries present in * table. */ - int rebuildSize; /* Enlarge table when numEntries gets to be + size_t rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - int mask; /* Mask value used in hashing function. */ + size_t mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -1964,9 +1964,9 @@ typedef struct Interp { * *root* ensemble command? (Nested ensembles * don't rewrite this.) NULL if we're not * processing an ensemble. */ - int numRemovedObjs; /* How many arguments have been stripped off + size_t numRemovedObjs; /* How many arguments have been stripped off * because of ensemble processing. */ - int numInsertedObjs; /* How many of the current arguments were + size_t numInsertedObjs; /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; @@ -3071,7 +3071,7 @@ MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, - Tcl_Obj *const *objv, int objc, int subIdx, + Tcl_Obj *const *objv, int objc, size_t subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); @@ -3087,6 +3087,8 @@ MODULE_SCOPE int TclStringMatch(const char *str, int strLen, MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); +MODULE_SCOPE int TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, + int count, Tcl_Obj **objPtrPtr); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, int numBytes, int flags, int line, struct CompileEnv *envPtr); @@ -4367,8 +4369,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, *---------------------------------------------------------------- */ -#define TclIsPureByteArray(objPtr) \ - (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) +MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); /* *---------------------------------------------------------------- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index d76f6b2..e082b09 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -531,7 +531,7 @@ TCLAPI Tcl_HashTable * TclGetNamespaceChildTable(Tcl_Namespace *nsPtr); TCLAPI Tcl_HashTable * TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr); /* 246 */ TCLAPI int TclInitRewriteEnsemble(Tcl_Interp *interp, - int numRemoved, int numInserted, + size_t numRemoved, size_t numInserted, Tcl_Obj *const *objv); /* 247 */ TCLAPI void TclResetRewriteEnsemble(Tcl_Interp *interp, @@ -800,7 +800,7 @@ typedef struct TclIntStubs { void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */ Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */ - int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */ + int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, size_t numRemoved, size_t numInserted, Tcl_Obj *const *objv); /* 246 */ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 0c86651..3f338e5 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -410,6 +410,7 @@ Tcl_Init( " {file join $grandParentDir lib tcl[info tclversion]} \\\n" " {file join $parentDir library} \\\n" " {file join $grandParentDir library} \\\n" +" {file join $grandParentDir tcl[info tclversion] library} \\\n" " {file join $grandParentDir tcl[info patchlevel] library} \\\n" " {\n" "file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 8420987..2dfce59 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -31,7 +31,7 @@ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static unsigned HashString(const char *string, int length); +static size_t HashString(const char *string, size_t length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -104,7 +104,7 @@ TclDeleteLiteralTable( { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; - int i; + size_t i; /* * Release remaining literals in the table. Note that releasing a literal @@ -174,10 +174,10 @@ TclDeleteLiteralTable( Tcl_Obj * TclCreateLiteral( Interp *iPtr, - const char *bytes, /* The start of the string. Note that this is + const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ - size_t length, /* Number of bytes in the string. */ - TCL_HASH_TYPE hash, /* The string's hash. If -1, it will be + size_t length, /* Number of bytes in the string. */ + size_t hash, /* The string's hash. If -1, it will be * computed here. */ int *newPtr, Namespace *nsPtr, @@ -186,14 +186,14 @@ TclCreateLiteral( { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - TCL_HASH_TYPE globalHash; + size_t globalHash; Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ - if (hash == (TCL_HASH_TYPE) -1) { + if (hash == (size_t) -1) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); @@ -285,7 +285,8 @@ TclCreateLiteral( TclVerifyGlobalLiteralTable(iPtr); { LiteralEntry *entryPtr; - int found, i; + int found; + size_t i; found = 0; for (i=0 ; i<globalTablePtr->numBuckets ; i++) { @@ -298,7 +299,7 @@ TclCreateLiteral( } if (!found) { Tcl_Panic("%s: literal \"%.*s\" wasn't global", - "TclRegisterLiteral", (length>60? 60 : length), bytes); + "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -335,10 +336,10 @@ Tcl_Obj * TclFetchLiteral( CompileEnv *envPtr, /* Points to the CompileEnv from which to * fetch the registered literal value. */ - unsigned int index) /* Index of the desired literal, as returned + size_t index) /* Index of the desired literal, as returned * by prior call to TclRegisterLiteral() */ { - if (index >= (unsigned int) envPtr->literalArrayNext) { + if (index >= (size_t) envPtr->literalArrayNext) { return NULL; } return envPtr->literalArrayPtr[index].objPtr; @@ -392,8 +393,8 @@ TclRegisterLiteral( LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; - unsigned hash; - int localHash, objIndex, new; + size_t hash, localHash, objIndex; + int new; Namespace *nsPtr; if (length == (size_t)-1) { @@ -410,7 +411,7 @@ TclRegisterLiteral( for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL; localPtr = localPtr->nextPtr) { objPtr = localPtr->objPtr; - if ((objPtr->length == length) && ((length == 0) + if (((size_t)objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, length) == 0)))) { if ((flags & LITERAL_ON_HEAP)) { @@ -454,7 +455,7 @@ TclRegisterLiteral( #ifdef TCL_COMPILE_DEBUG if (globalPtr != NULL && globalPtr->refCount < 1) { Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", - "TclRegisterLiteral", (length>60? 60 : length), bytes, + "TclRegisterLiteral", (length>60? 60 : (int)length), bytes, globalPtr->refCount); } TclVerifyLocalLiteralTable(envPtr); @@ -492,10 +493,10 @@ LookupLiteralEntry( LiteralTable *globalTablePtr = &iPtr->literalTable; register LiteralEntry *entryPtr; const char *bytes; - int length, globalHash; + size_t globalHash; - bytes = TclGetStringFromObj(objPtr, &length); - globalHash = (HashString(bytes, length) & globalTablePtr->mask); + bytes = TclGetString(objPtr); + globalHash = (HashString(bytes, objPtr->length) & globalTablePtr->mask); for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL; entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { @@ -537,7 +538,8 @@ TclHideLiteral( { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - int localHash, length; + size_t localHash; + size_t length; const char *bytes; Tcl_Obj *newObjPtr; @@ -555,7 +557,8 @@ TclHideLiteral( TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; - bytes = TclGetStringFromObj(newObjPtr, &length); + bytes = TclGetString(newObjPtr); + length = newObjPtr->length; localHash = (HashString(bytes, length) & localTablePtr->mask); nextPtrPtr = &localTablePtr->buckets[localHash]; @@ -674,7 +677,8 @@ AddLocalLiteralEntry( TclVerifyLocalLiteralTable(envPtr); { char *bytes; - int length, found, i; + int found; + size_t length, i; found = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { @@ -687,9 +691,10 @@ AddLocalLiteralEntry( } if (!found) { - bytes = TclGetStringFromObj(objPtr, &length); + bytes = TclGetString(objPtr); + length = objPtr->length; Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", - "AddLocalLiteralEntry", (length>60? 60 : length), bytes); + "AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -728,16 +733,16 @@ ExpandLocalLiteralArray( */ LiteralTable *localTablePtr = &envPtr->localLitTable; - int currElems = envPtr->literalArrayNext; + size_t currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; LiteralEntry *newArrayPtr; - int i; - unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; + size_t i; + size_t newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; if (currBytes == newSize) { - Tcl_Panic("max size of Tcl literal array (%d literals) exceeded", - currElems); + Tcl_Panic("max size of Tcl literal array (%" TCL_LL_MODIFIER "d literals) exceeded", + (Tcl_WideInt)currElems); } if (envPtr->mallocedLiteralArray) { @@ -809,15 +814,16 @@ TclReleaseLiteral( LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; - int length, index; + size_t length, index; if (iPtr == NULL) { goto done; } globalTablePtr = &iPtr->literalTable; - bytes = TclGetStringFromObj(objPtr, &length); - index = (HashString(bytes, length) & globalTablePtr->mask); + bytes = TclGetString(objPtr); + length = objPtr->length; + index = HashString(bytes, length) & globalTablePtr->mask; /* * Check to see if the object is in the global literal table and remove @@ -880,12 +886,12 @@ TclReleaseLiteral( *---------------------------------------------------------------------- */ -static unsigned +static size_t HashString( register const char *string, /* String for which to compute hash value. */ - int length) /* Number of bytes in the string. */ + size_t length) /* Number of bytes in the string. */ { - register unsigned int result = 0; + register size_t result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -954,8 +960,7 @@ RebuildLiteralTable( register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; - unsigned int oldSize; - int count, index, length; + size_t oldSize, count, index, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -990,7 +995,8 @@ RebuildLiteralTable( for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) { for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) { - bytes = TclGetStringFromObj(entryPtr->objPtr, &length); + bytes = TclGetString(entryPtr->objPtr); + length = entryPtr->objPtr->length; index = (HashString(bytes, length) & tablePtr->mask); *oldChainPtr = entryPtr->nextPtr; @@ -1113,8 +1119,8 @@ TclLiteralStats( */ result = ckalloc(NUM_COUNTERS*60 + 300); - sprintf(result, "%d entries in table, %d buckets\n", - tablePtr->numEntries, tablePtr->numBuckets); + sprintf(result, "%" TCL_LL_MODIFIER "d entries in table, %" TCL_LL_MODIFIER "d buckets\n", + (Tcl_WideInt)tablePtr->numEntries, (Tcl_WideInt)tablePtr->numBuckets); p = result + strlen(result); for (i=0 ; i<NUM_COUNTERS ; i++) { sprintf(p, "number of buckets with %d entries: %d\n", @@ -1154,19 +1160,18 @@ TclVerifyLocalLiteralTable( register LiteralTable *localTablePtr = &envPtr->localLitTable; register LiteralEntry *localPtr; char *bytes; - register int i; - int length, count; + size_t i, length, count = 0; - count = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; localPtr=localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { - bytes = TclGetStringFromObj(localPtr->objPtr, &length); + bytes = TclGetString(localPtr->objPtr); + length = localPtr->objPtr->length; Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes, localPtr->refCount); + (length>60? 60 : (int) length), bytes, localPtr->refCount); } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", @@ -1205,19 +1210,18 @@ TclVerifyGlobalLiteralTable( register LiteralTable *globalTablePtr = &iPtr->literalTable; register LiteralEntry *globalPtr; char *bytes; - register int i; - int length, count; + size_t i, length, count = 0; - count = 0; for (i=0 ; i<globalTablePtr->numBuckets ; i++) { for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL; globalPtr=globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { - bytes = TclGetStringFromObj(globalPtr->objPtr, &length); + bytes = TclGetString(globalPtr->objPtr); + length = globalPtr->objPtr->length; Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", - (length>60? 60 : length), bytes, globalPtr->refCount); + (length>60? 60 : (int)length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index abac951..8a7f4a4 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -404,7 +404,7 @@ Tcl_PopCallFrame( nsPtr = framePtr->nsPtr; nsPtr->activationCount--; if ((nsPtr->flags & NS_DYING) - && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { + && (nsPtr->activationCount == (nsPtr == iPtr->globalNsPtr))) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; @@ -997,7 +997,7 @@ Tcl_DeleteNamespace( * refCount reaches 0. */ - if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { + if (nsPtr->activationCount > (nsPtr == globalNsPtr)) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { entryPtr = Tcl_FindHashEntry( @@ -1099,7 +1099,7 @@ TclTeardownNamespace( Interp *iPtr = (Interp *) nsPtr->interp; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - int i; + size_t i; /* * Start by destroying the namespace's variable table, since variables @@ -1120,7 +1120,7 @@ TclTeardownNamespace( */ while (nsPtr->cmdTable.numEntries > 0) { - int length = nsPtr->cmdTable.numEntries; + size_t length = nsPtr->cmdTable.numEntries; Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Command *) * length); @@ -1192,7 +1192,7 @@ TclTeardownNamespace( #ifndef BREAK_NAMESPACE_COMPAT while (nsPtr->childTable.numEntries > 0) { - int length = nsPtr->childTable.numEntries; + size_t length = nsPtr->childTable.numEntries; Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Namespace *) * length); @@ -1365,7 +1365,7 @@ Tcl_Export( Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); const char *simplePattern; char *patternCpy; - int neededElems, len, i; + size_t neededElems, len, i; /* * If the specified namespace is NULL, use the current namespace. @@ -1492,7 +1492,8 @@ Tcl_AppendExportList( * export pattern list is appended. */ { Namespace *nsPtr; - int i, result; + size_t i; + int result; /* * If the specified namespace is NULL, use the current namespace. @@ -1694,7 +1695,7 @@ DoImport( Namespace *importNsPtr, int allowOverwrite) { - int i = 0, exported = 0; + size_t i = 0, exported = 0; Tcl_HashEntry *found; /* diff --git a/generic/tclOO.h b/generic/tclOO.h index 06a39fb..eff31f2 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -90,7 +90,7 @@ typedef struct { /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking - * binary compatability. + * binary compatibility. */ #define TCL_OO_METHOD_VERSION_CURRENT 1 @@ -117,7 +117,7 @@ typedef struct { /* * The correct value for the version field of the Tcl_ObjectMetadataType * structure. This allows new versions of the structure to be introduced - * without breaking binary compatability. + * without breaking binary compatibility. */ #define TCL_OO_METADATA_VERSION_CURRENT 1 diff --git a/generic/tclObj.c b/generic/tclObj.c index 8da146f..b9dc4f4 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3936,7 +3936,7 @@ AllocObjEntry( hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); - hPtr->clientData = NULL; + Tcl_SetHashValue(hPtr, NULL); return hPtr; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 4f4db81..3036896 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -90,7 +90,7 @@ typedef struct { * below. */ ClientData nativePathPtr; /* Native representation of this path, which * is filesystem dependent. */ - int filesystemEpoch; /* Used to ensure the path representation was + size_t filesystemEpoch; /* Used to ensure the path representation was * generated during the correct filesystem * epoch. The epoch changes when * filesystem-mounts are changed. */ diff --git a/generic/tclProc.c b/generic/tclProc.c index a9862d9..982b4f2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1346,7 +1346,7 @@ InitLocalCache( *namePtr = NULL; } else { *namePtr = TclCreateLiteral(iPtr, localPtr->name, - localPtr->nameLength, /* hash */ (unsigned int) -1, + localPtr->nameLength, /* hash */ -1, &new, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index e912ba4..be2cb4d 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -502,9 +502,16 @@ Tcl_RegExpMatchObj( { Tcl_RegExp re; - re = Tcl_GetRegExpFromObj(interp, patternObj, - TCL_REG_ADVANCED | TCL_REG_NOSUB); - if (re == NULL) { + /* + * For performance reasons, first try compiling the RE without support for + * subexpressions. On failure, try again without TCL_REG_NOSUB in case the + * RE has backreferences in it. Closely related to [Bug 1366683]. If this + * still fails, an error message will be left in the interpreter. + */ + + if (!(re = Tcl_GetRegExpFromObj(interp, patternObj, + TCL_REG_ADVANCED | TCL_REG_NOSUB)) + && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) { return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h index 3b2433e..a263dfd 100644 --- a/generic/tclRegexp.h +++ b/generic/tclRegexp.h @@ -37,7 +37,7 @@ typedef struct TclRegexp { * of subexpressions. */ rm_detail_t details; /* Detailed information on match (currently * used only for REG_EXPECT). */ - int refCount; /* Count of number of references to this + size_t refCount; /* Count of number of references to this * compiled regexp. */ } TclRegexp; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0087c34..77a613c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -54,7 +54,7 @@ static void AppendUtfToUtfRep(Tcl_Obj *objPtr, const char *bytes, size_t numBytes); static void DupStringInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static int ExtendStringRepWithUnicode(Tcl_Obj *objPtr, +static size_t ExtendStringRepWithUnicode(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr, const char *bytes, size_t numBytes, @@ -141,7 +141,7 @@ GrowStringBuffer( } if (flag == 0 || stringPtr->allocated > 0) { attempt = 2 * needed; - if ((int)attempt >= 0) { + if (attempt <= STRING_MAXCHARS) { ptr = attemptckrealloc(objPtr->bytes, attempt + 1); } if (ptr == NULL) { @@ -314,9 +314,9 @@ Tcl_Obj * Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - size_t length, /* The number of bytes to copy from "bytes" + size_t length, /* The number of bytes to copy from "bytes" * when initializing the new object. If - * negative, use bytes up to the first NUL + * (size_t)-1, use bytes up to the first NUL * byte. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -325,7 +325,7 @@ Tcl_DbNewStringObj( { Tcl_Obj *objPtr; - if (length != (size_t)-1) { + if (length == (size_t)-1) { length = (bytes? strlen(bytes) : 0); } TclDbNewObj(objPtr, file, line); @@ -337,9 +337,9 @@ Tcl_Obj * Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - size_t length, /* The number of bytes to copy from "bytes" + size_t length, /* The number of bytes to copy from "bytes" * when initializing the new object. If - * negative, use bytes up to the first NUL + * (size_t)-1, use bytes up to the first NUL * byte. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -427,7 +427,7 @@ Tcl_GetCharLength( int length; (void) Tcl_GetByteArrayFromObj(objPtr, &length); - return (size_t)length; + return length; } /* @@ -501,7 +501,7 @@ Tcl_GetUniChar( if (stringPtr->numChars == (size_t)-1) { TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } - if (stringPtr->numChars == objPtr->length) { + if (stringPtr->numChars == (size_t)objPtr->length) { return (Tcl_UniChar) objPtr->bytes[index]; } FillUnicodeRep(objPtr); @@ -635,7 +635,7 @@ Tcl_GetRange( if (stringPtr->numChars == (size_t)-1) { TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } - if (stringPtr->numChars == objPtr->length) { + if (stringPtr->numChars == (size_t)objPtr->length) { newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); /* @@ -680,8 +680,8 @@ Tcl_SetStringObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ const char *bytes, /* Points to the first of the length bytes * used to initialize the object. */ - size_t length) /* The number of bytes to copy from "bytes" - * when initializing the object. If negative, + size_t length) /* The number of bytes to copy from "bytes" + * when initializing the object. If (size_t)-1, * use bytes up to the first NUL byte.*/ { if (Tcl_IsShared(objPtr)) { @@ -733,21 +733,12 @@ void Tcl_SetObjLength( Tcl_Obj *objPtr, /* Pointer to object. This object must not * currently be shared. */ - size_t length) /* Number of bytes desired for string + size_t length) /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { String *stringPtr; - if (length == (size_t)-1) { - /* - * Setting to a negative length is nonsense. This is probably the - * result of overflowing the signed integer range. - */ - - Tcl_Panic("Tcl_SetObjLength: negative length requested: " - "%d (integer overflow?)", (int)length); - } if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetObjLength"); } @@ -790,7 +781,7 @@ Tcl_SetObjLength( */ stringCheckLimits(length); - if (length > stringPtr->maxChars) { + if ((size_t)length > stringPtr->maxChars) { stringPtr = stringRealloc(stringPtr, length); SET_STRING(objPtr, stringPtr); stringPtr->maxChars = length; @@ -838,20 +829,12 @@ int Tcl_AttemptSetObjLength( Tcl_Obj *objPtr, /* Pointer to object. This object must not * currently be shared. */ - size_t length) /* Number of bytes desired for string + size_t length) /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { String *stringPtr; - if (length == (size_t)-1) { - /* - * Setting to a negative length is nonsense. This is probably the - * result of overflowing the signed integer range. - */ - - return 0; - } if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength"); } @@ -965,7 +948,7 @@ UnicodeLength( size_t numChars = 0; if (unicode) { - while (numChars <= STRING_MAXCHARS && unicode[numChars] != 0) { + while (numChars != (size_t)-1 && unicode[numChars] != 0) { numChars++; } } @@ -1029,10 +1012,10 @@ Tcl_AppendLimitedToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* Points to the bytes to append to the * object. */ - size_t length, /* The number of bytes available to be - * appended from "bytes". If < 0, then all - * bytes up to a NUL byte are available. */ - size_t limit, /* The maximum number of bytes to append to + size_t length, /* The number of bytes available to be + * appended from "bytes". If (size_t)-1, then + * all bytes up to a NUL byte are available. */ + size_t limit, /* The maximum number of bytes to append to * the object. */ const char *ellipsis) /* Ellipsis marker string, appended to the * object to indicate not all available bytes @@ -1045,7 +1028,7 @@ Tcl_AppendLimitedToObj( Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj"); } - if (length== (size_t)-1) { + if (length == (size_t)-1) { length = (bytes ? strlen(bytes) : 0); } if (length == 0) { @@ -1111,11 +1094,11 @@ Tcl_AppendToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* Points to the bytes to append to the * object. */ - size_t length) /* The number of bytes to append from "bytes". - * If < 0, then append all bytes up to NUL + size_t length) /* The number of bytes to append from "bytes". + * If (size_t)-1, then append all bytes up to NUL * byte. */ { - Tcl_AppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL); + Tcl_AppendLimitedToObj(objPtr, bytes, length, (size_t)-1, NULL); } /* @@ -1140,7 +1123,7 @@ Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The unicode string to append to the * object. */ - size_t length) /* Number of chars in "unicode". */ + size_t length) /* Number of chars in "unicode". */ { String *stringPtr; @@ -1194,7 +1177,8 @@ Tcl_AppendObjToObj( Tcl_Obj *appendObjPtr) /* Object to append. */ { String *stringPtr; - int length, numChars, appendNumChars = -1; + int length, numChars; + size_t appendNumChars = (size_t)-1; const char *bytes; /* @@ -1503,13 +1487,10 @@ AppendUtfToUtfRep( } oldLength = objPtr->length; newLength = numBytes + oldLength; - if ((int)newLength < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } stringPtr = GET_STRING(objPtr); if (newLength > stringPtr->allocated) { - int offset = -1; + size_t offset = (size_t)-1; /* * Protect against case where unicode points into the existing @@ -1533,7 +1514,7 @@ AppendUtfToUtfRep( * Relocate bytes if needed; see above. */ - if (offset >= 0) { + if (offset != (size_t)-1) { bytes = objPtr->bytes + offset; } } @@ -1865,6 +1846,14 @@ Tcl_AppendFormatToObj( useWide = 1; #endif } + } else if ((ch == 'I') && (format[1] == '6') && (format[2] == '4')) { + format += (step + 2); + step = Tcl_UtfToUniChar(format, &ch); + useBig = 1; + } else if (ch == 'L') { + format += step; + step = Tcl_UtfToUniChar(format, &ch); + useBig = 1; } format += step; @@ -2472,6 +2461,10 @@ AppendPrintfToObjVA( Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( va_arg(argList, long))); break; + case 2: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( + va_arg(argList, Tcl_WideInt))); + break; } break; case 'e': @@ -2500,9 +2493,20 @@ AppendPrintfToObjVA( gotPrecision = 1; p++; break; - /* TODO: support for wide (and bignum?) arguments */ + /* TODO: support for bignum arguments */ case 'l': - size = 1; + ++size; + p++; + break; + case 'L': + size = 2; + p++; + break; + case 'I': + if (p[1]=='6' && p[2]=='4') { + p += 2; + size = 2; + } p++; break; case 'h': @@ -2613,6 +2617,147 @@ TclGetStringStorage( /* *--------------------------------------------------------------------------- * + * TclStringRepeat -- + * + * Performs the [string repeat] function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Writes to *objPtrPtr the address of Tcl_Obj that is concatenation + * of count copies of the value in objPtr. + * + *--------------------------------------------------------------------------- + */ + +int +TclStringRepeat( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int count, + Tcl_Obj **objPtrPtr) +{ + Tcl_Obj *objResultPtr; + int length = 0, unichar = 0, done = 1; + int binary = TclIsPureByteArray(objPtr); + + /* assert (count >= 2) */ + + /* + * Analyze to determine what representation result should be. + * GOALS: Avoid shimmering & string rep generation. + * Produce pure bytearray when possible. + * Error on overflow. + */ + + if (!binary) { + if (objPtr->typePtr == &tclStringType) { + String *stringPtr = GET_STRING(objPtr); + if (stringPtr->hasUnicode) { + unichar = 1; + } + } + } + + if (binary) { + /* Result will be pure byte array. Pre-size it */ + Tcl_GetByteArrayFromObj(objPtr, &length); + } else if (unichar) { + /* Result will be pure Tcl_UniChar array. Pre-size it. */ + Tcl_GetUnicodeFromObj(objPtr, &length); + } else { + /* Result will be concat of string reps. Pre-size it. */ + Tcl_GetStringFromObj(objPtr, &length); + } + + if (length == 0) { + /* Any repeats of empty is empty. */ + *objPtrPtr = objPtr; + return TCL_OK; + } + + if (count > INT_MAX/length) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + + if (binary) { + /* Efficiently produce a pure byte array result */ + objResultPtr = Tcl_IsShared(objPtr) ? Tcl_DuplicateObj(objPtr) + : objPtr; + + Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ + Tcl_SetByteArrayLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + TclAppendBytesToByteArray(objResultPtr, + Tcl_GetByteArrayFromObj(objResultPtr, NULL), + (count - done) * length); + } else if (unichar) { + /* Efficiently produce a pure Tcl_UniChar array result */ + if (Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); + } else { + TclInvalidateStringRep(objPtr); + objResultPtr = objPtr; + } + + if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow: unable to alloc %" + TCL_LL_MODIFIER "u bytes", + (Tcl_WideUInt)STRING_SIZE(count*length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + Tcl_SetObjLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + (count - done) * length); + } else { + /* Efficiently concatenate string reps */ + if (Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); + } else { + TclFreeIntRep(objPtr); + objResultPtr = objPtr; + } + if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow: unable to alloc %u bytes", + count*length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + Tcl_SetObjLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), + (count - done) * length); + } + *objPtrPtr = objResultPtr; + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * * TclStringCatObjv -- * * Performs the [string cat] function. @@ -2691,7 +2836,7 @@ TclStringCatObjv( if (objPtr->bytes == NULL) { int numBytes; - Tcl_GetByteArrayFromObj(objPtr, &numBytes); + Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ if (length == 0) { first = objc - oc - 1; } @@ -2707,7 +2852,7 @@ TclStringCatObjv( if ((objPtr->bytes == NULL) || (objPtr->length)) { int numChars; - Tcl_GetUnicodeFromObj(objPtr, &numChars); + Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ if (length == 0) { first = objc - oc - 1; } @@ -2722,7 +2867,7 @@ TclStringCatObjv( objPtr = *ov++; - Tcl_GetStringFromObj(objPtr, &numBytes); + Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ if ((length == 0) && numBytes) { first = objc - oc - 1; } @@ -2751,6 +2896,11 @@ TclStringCatObjv( /* Efficiently produce a pure byte array result */ unsigned char *dst; + /* + * Broken interface! Byte array value routines offer no way + * to handle failure to allocate enough space. Following + * stanza may panic. + */ if (inPlace && !Tcl_IsShared(*objv)) { int start; @@ -2783,14 +2933,32 @@ TclStringCatObjv( /* Ugly interface! Force resize of the unicode array. */ Tcl_GetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); - Tcl_SetObjLength(objResultPtr, length); + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %" + TCL_LL_MODIFIER "u bytes", + (Tcl_WideUInt)STRING_SIZE(length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } dst = Tcl_GetUnicode(objResultPtr) + start; } else { Tcl_UniChar ch = 0; /* Ugly interface! No scheme to init array size. */ - objResultPtr = Tcl_NewUnicodeObj(&ch, 0); - Tcl_SetObjLength(objResultPtr, length); + objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %" + TCL_LL_MODIFIER "u bytes", + (Tcl_WideUInt)STRING_SIZE(length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } dst = Tcl_GetUnicode(objResultPtr); } while (objc--) { @@ -2813,14 +2981,30 @@ TclStringCatObjv( objResultPtr = *objv++; objc--; Tcl_GetStringFromObj(objResultPtr, &start); - Tcl_SetObjLength(objResultPtr, length); + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %u bytes", + length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } dst = Tcl_GetString(objResultPtr) + start; if (length > start) { TclFreeIntRep(objResultPtr); } } else { - objResultPtr = Tcl_NewObj(); - Tcl_SetObjLength(objResultPtr, length); + objResultPtr = Tcl_NewObj(); /* PANIC? */ + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %u bytes", + length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } dst = Tcl_GetString(objResultPtr); } while (objc--) { @@ -3407,7 +3591,7 @@ UpdateStringOfString( } } -static int +static size_t ExtendStringRepWithUnicode( Tcl_Obj *objPtr, const Tcl_UniChar *unicode, @@ -3438,17 +3622,14 @@ ExtendStringRepWithUnicode( * Quick cheap check in case we have more than enough room. */ - if (numChars <= (size_t)((INT_MAX - size)/TCL_UTF_MAX) + if (numChars <= (INT_MAX - size)/TCL_UTF_MAX && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) { goto copyBytes; } - for (i = 0; i < numChars && size >= 0; i++) { + for (i = 0; i < numChars; i++) { size += TclUtfCount(unicode[i]); } - if ((int)size < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } /* * Grow space if needed. diff --git a/generic/tclTest.c b/generic/tclTest.c index 4d59e03..bd64748 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -305,6 +305,9 @@ static int TestparsevarnameObjCmd(ClientData dummy, static int TestpreferstableObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestprintObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestregexpObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -630,6 +633,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, @@ -3653,6 +3658,43 @@ TestpreferstableObjCmd( /* *---------------------------------------------------------------------- * + * TestprintObjCmd -- + * + * This procedure implements the "testprint" command. It is + * used for being able to test the Tcl_ObjPrintf() function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestprintObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt argv1 = 0; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); + } + + if (objc > 1) { + Tcl_GetWideIntFromObj(interp, objv[2], &argv1); + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 7f7a076..6c4a1ed 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1102,7 +1102,7 @@ TestobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(varPtr[varIndex]->refCount)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); } else if (strcmp(subCmd, "type") == 0) { if (objc != 3) { goto wrongNumArgs; diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 2797f35..d02e470 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -220,7 +220,7 @@ GetCache(void) cachePtr = TclpGetAllocCache(); if (cachePtr == NULL) { - cachePtr = TclpSysAlloc(sizeof(Cache), 0); + cachePtr = TclpSysAlloc(sizeof(Cache)); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } @@ -346,7 +346,7 @@ TclpAlloc( #endif if (size > MAXALLOC) { bucket = NBUCKETS; - blockPtr = TclpSysAlloc(size, 0); + blockPtr = TclpSysAlloc(size); if (blockPtr != NULL) { cachePtr->totalAssigned += reqSize; } @@ -572,7 +572,7 @@ TclThreadAllocObj(void) Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); + newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } @@ -1041,7 +1041,7 @@ GetBlocks( if (blockPtr == NULL) { size = MAXALLOC; - blockPtr = TclpSysAlloc(size, 0); + blockPtr = TclpSysAlloc(size); if (blockPtr == NULL) { return 0; } diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index 9035b1a..31776e2 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -85,14 +85,14 @@ TSDTableCreate(void) TSDTable *tsdTablePtr; sig_atomic_t i; - tsdTablePtr = TclpSysAlloc(sizeof(TSDTable), 0); + tsdTablePtr = TclpSysAlloc(sizeof(TSDTable)); if (tsdTablePtr == NULL) { Tcl_Panic("unable to allocate TSDTable"); } tsdTablePtr->allocated = 8; tsdTablePtr->tablePtr = - TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0); + TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated); if (tsdTablePtr->tablePtr == NULL) { Tcl_Panic("unable to allocate TSDTable"); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index f230094..41e5555 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1549,7 +1549,8 @@ Tcl_Merge( { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE]; - int i, bytesNeeded = 0; + int i; + size_t bytesNeeded = 0; char *result, *dst, *flagPtr = NULL; /* @@ -1575,12 +1576,6 @@ Tcl_Merge( for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); - if (bytesNeeded < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - } - if (bytesNeeded > INT_MAX - argc + 1) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += argc; diff --git a/generic/tclVar.c b/generic/tclVar.c index 44325f8..9a04d8b 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -2633,7 +2633,7 @@ TclArraySet( } else { /* * Not a dictionary, so assume (and convert to, for backward- - * -compatability reasons) a list. + * -compatibility reasons) a list. */ int elemLen; diff --git a/library/http/http.tcl b/library/http/http.tcl index d105886..ccd4cd1 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1447,7 +1447,7 @@ proc http::mapReply {string} { set converted [string map $formMap $string] if {[string match "*\[\u0100-\uffff\]*" $converted]} { regexp "\[\u0100-\uffff\]" $converted badChar - # Return this error message for maximum compatability... :^/ + # Return this error message for maximum compatibility... :^/ return -code error \ "can't read \"formMap($badChar)\": no such element in array" } diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 2d68138..a5f3009 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -234,7 +234,7 @@ test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { unixOrPc } -returnCodes error -body { - source a b + source a b c d e f } -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { set file [makeFile { diff --git a/tests/fCmd.test b/tests/fCmd.test index 5623d49..bc5f0e8 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -23,7 +23,7 @@ cd [temporaryDirectory] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testchmod [llength [info commands testchmod]] testConstraint winVista 0 -testConstraint win2000orXP 0 +testConstraint winXP 0 # Don't know how to determine this constraint correctly testConstraint notNetworkFilesystem 0 testConstraint reg 0 @@ -66,12 +66,10 @@ if {[testConstraint unix]} { # Also used in winFCmd... if {[testConstraint win]} { set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { - if {$major > 5} { - testConstraint winVista 1 - } elseif {$major == 5} { - testConstraint win2000orXP 1 - } + if {$major > 5} { + testConstraint winVista 1 + } else { + testConstraint winXP 1 } } @@ -792,7 +790,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup { } -result {{tf3 tf4} 1 0} test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup { cleanup -} -constraints {win win2000orXP testchmod} -body { +} -constraints {win testchmod} -body { file mkdir td1 td2 testchmod 0o555 td2 file rename td1 td3 @@ -824,7 +822,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup { } -result {tf1 tf2 1 0} test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { cleanup -} -constraints {win win2000orXP testchmod} -body { +} -constraints {win winXP testchmod} -body { file mkdir td1 file mkdir td2 testchmod 0o555 td2 diff --git a/tests/registry.test b/tests/registry.test index 2072559..fec4cc0 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -283,7 +283,7 @@ test registry-4.7 {GetKeyNames: Unicode} {win reg english} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "baz\u00c7bar blat" -test registry-4.8 {GetKeyNames: Unicode} {win reg nt} { +test registry-4.8 {GetKeyNames: Unicode} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar registry set HKEY_CURRENT_USER\\TclFoobar\\blat @@ -487,7 +487,7 @@ test registry-6.17 {GetValue: Unicode value names} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } foobar -test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} { +test registry-6.18 {GetValue: values with Unicode strings} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar val1] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -505,7 +505,7 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "foo ba r baz" -test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} { +test registry-6.21 {GetValue: very long value names and values} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -604,7 +604,7 @@ test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body { test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body { registry values \\\\\\ } -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} -test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english nt} -body { +test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body { registry values \\\\\\HKEY_CLASSES_ROOT } -returnCodes error -result {unable to open key: The network address is invalid.} test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body { diff --git a/tests/set-old.test b/tests/set-old.test index 93169f1..309abaf 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -652,6 +652,13 @@ test set-old-8.52 {array command, array names -regexp on regexp pattern} { set a(11) 1 list [catch {lsort [array names a -regexp ^1]} msg] $msg } {0 {1*2 11 12}} +test set-old-8.52.1 {array command, array names -regexp, backrefs} { + catch {unset a} + set a(1*2) 1 + set a(12) 1 + set a(11) 1 + list [catch {lsort [array names a -regexp {^(.)\1}]} msg] $msg +} {0 11} test set-old-8.53 {array command, array names -regexp} { catch {unset a} set a(-glob) 1 diff --git a/tests/trace.test b/tests/trace.test index 3b69d38..720c870 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -1265,7 +1265,7 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} { } 1110 test trace-18.5 {Bug 7f02ff1efa} -setup { proc constant {name value} { - upvar 1 $name c + upvar 1 $name c set c $value trace variable c wu [list reset $value] } diff --git a/tests/util.test b/tests/util.test index 2ac11bf..1a3eecb 100644 --- a/tests/util.test +++ b/tests/util.test @@ -20,6 +20,7 @@ testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] +testConstraint testprint [llength [info commands testprint]] # Big test for correct ordering of data in [expr] @@ -4017,6 +4018,30 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { 0x4400000000000000 0xc400000000000000 }] +test util-18.1 {Tcl_ObjPrintf} {testprint} { + testprint %lld [expr 2**63-1] +} {9223372036854775807} + +test util-18.2 {Tcl_ObjPrintf} {testprint} { + testprint %I64d [expr 2**63-1] +} {9223372036854775807} + +test util-18.3 {Tcl_ObjPrintf} {testprint} { + testprint %Ld [expr 2**63-1] +} {9223372036854775807} + +test util-18.4 {Tcl_ObjPrintf} {testprint} { + testprint %lld [expr -2**63] +} {-9223372036854775808} + +test util-18.5 {Tcl_ObjPrintf} {testprint} { + testprint %I64d [expr -2**63] +} {-9223372036854775808} + +test util-18.6 {Tcl_ObjPrintf} {testprint} { + testprint %Ld [expr -2**63] +} {-9223372036854775808} + set ::tcl_precision $saved_precision # cleanup diff --git a/tests/winFCmd.test b/tests/winFCmd.test index a808c82..294745c 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -21,8 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Initialise the test constraints testConstraint winVista 0 -testConstraint win2000orXP 0 -testConstraint winOlderThan2000 0 +testConstraint winXP 0 testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testfile [llength [info commands testfile]] testConstraint testchmod [llength [info commands testchmod]] @@ -56,16 +55,12 @@ proc cleanup {args} { } } -if {[testConstraint winOnly]} { +if {[testConstraint win]} { set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { - if {$major > 5} { - testConstraint winVista 1 - } elseif {$major == 5} { - testConstraint win2000orXP 1 - } - } else { - testConstraint winOlderThan2000 1 + if {$major > 5} { + testConstraint winVista 1 + } elseif {$major == 5} { + testConstraint winXP 1 } } @@ -205,17 +200,12 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} -setup { } -returnCodes error -result EACCES test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { cleanup -} -constraints {win win2000orXP testfile} -body { +} -constraints {win winXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL -test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EACCES test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { createfile tf1 testfile mv tf1 nul } -returnCodes error -result EEXIST @@ -238,19 +228,12 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} -setup { } -returnCodes error -result ENOENT test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup { cleanup -} -constraints {win win2000orXP testfile} -body { +} -constraints {win winXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL -test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EACCES test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup -} -constraints {win nt testfile} -body { - # under 95, this would actually succeed and move the current dir out from - # under the current process! +} -constraints {win testfile} -body { file delete /tf1 testfile mv [pwd] /tf1 } -returnCodes error -result EACCES @@ -458,14 +441,9 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup { } -returnCodes error -result ENOENT test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup { cleanup -} -constraints {win win2000orXP testfile} -body { +} -constraints {win winXP testfile} -body { testfile cp nul tf1 } -returnCodes error -result EINVAL -test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result EACCES test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { @@ -623,7 +601,7 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body { testfile mkdir $cdrom/dummy~~.dir -} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES +} -constraints {win cdrom testfile} -returnCodes error -result EACCES test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { @@ -721,7 +699,7 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { } -result {td1 EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { testfile rmdir / # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. @@ -819,7 +797,7 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup { } -result {tf1} test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body { testfile rmdir $cdrom/ -} -constraints {win nt cdrom testfile} -returnCodes error -match glob \ +} -constraints {win cdrom testfile} -returnCodes error -match glob \ -result {* EACCES} test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \ {win emptyTest} { @@ -857,7 +835,7 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup { } -result {tf1} test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { file mkdir td1 testfile cpdir td1 / } -cleanup { @@ -1072,7 +1050,7 @@ test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body { } -constraints {win} -result {/ /} test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup { catch {file delete -force -- c:/td1} -} -constraints {win win2000orXP} -body { +} -constraints {win winXP} -body { createfile c:/td1 {} string tolower [file attributes c:/td1 -longname] } -cleanup { @@ -1350,13 +1328,13 @@ test winFCmd-18.8 {Windows reserved path names} -constraints win -body { file normalize cOm1: } -result COM1 -test winFCmd-19.1 {Windows extended path names} -constraints nt -body { +test winFCmd-19.1 {Windows extended path names} -constraints win -body { file normalize //?/c:/windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.2 {Windows extended path names} -constraints nt -body { +test winFCmd-19.2 {Windows extended path names} -constraints win -body { file normalize //?/c:/windows/../windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.3 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile [file normalize $tmpfile] } -body { @@ -1367,7 +1345,7 @@ test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.4 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.4 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1378,7 +1356,7 @@ test winFCmd-19.4 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.5 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile [file normalize $tmpfile] } -body { @@ -1389,7 +1367,7 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.6 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1400,7 +1378,7 @@ test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.7 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.7 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile [file normalize $tmpfile] } -body { @@ -1411,7 +1389,7 @@ test winFCmd-19.7 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {} [list tcl[pid].tmp]] -test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.8 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1423,7 +1401,7 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { catch {file delete $tmpfile} } -result [list 0 {} [list "tcl[pid].tmp "]] -test winFCmd-19.9 {Windows devices path names} -constraints nt -body { +test winFCmd-19.9 {Windows devices path names} -constraints win -body { file normalize //./com1 } -result //./com1 diff --git a/tests/winFile.test b/tests/winFile.test index 2c47f5f..b2cdfa1 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -21,23 +21,19 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 -testConstraint win2000 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] } -if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { - testConstraint win2000 1 -} test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} -test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { +test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { # The administrator account should always exist. glob ~administrator } -match glob -result * -test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { +test winFile-1.4 {TclpGetUserHome} {win nonPortable} { catch {glob ~stanton@workgroup} } {0} @@ -154,7 +150,7 @@ if {[testConstraint win]} { test winFile-4.0 { Enhanced NTFS user/group permissions: test no acccess } -constraints { - win nt notNTFS win2000 + win notNTFS } -setup { set owner [getuser $fname] set user $::env(USERDOMAIN)\\$::env(USERNAME) @@ -169,7 +165,7 @@ test winFile-4.0 { test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -180,7 +176,7 @@ test winFile-4.1 { test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -192,7 +188,7 @@ test winFile-4.2 { test winFile-4.3 { Enhanced NTFS user/group permissions: test read+write } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -205,7 +201,7 @@ test winFile-4.3 { test winFile-4.4 { Enhanced NTFS user/group permissions: test full access } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { diff --git a/tests/winPipe.test b/tests/winPipe.test index 8128fe2..53e46fc 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -74,11 +74,11 @@ test winpipe-1.2 {32 bit comprehensive tests: from big file} {win exec cat32} { exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win nt exec cat32} { +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win exec cat32} { exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} -test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} { +test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win exec cat32} { exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" @@ -171,7 +171,7 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ set r } "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { +test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} { proc readResults {f} { global x result if { [eof $f] } { diff --git a/unix/tcl.m4 b/unix/tcl.m4 index e0b7771..c1d7a7d 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2706,7 +2706,7 @@ AC_DEFUN([SC_TCL_CFG_ENCODING], [ # advancedTest - the advanced test to run if the function is present # # Results: -# Might cause compatability versions of the function to be used. +# Might cause compatibility versions of the function to be used. # Might affect the following vars: # USE_COMPAT (implicit) # diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index 2728957..047a415 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -672,9 +672,9 @@ typedef int socklen_t; *--------------------------------------------------------------------------- */ -#define TclpSysAlloc(size, isBin) malloc((size_t)(size)) +#define TclpSysAlloc(size) malloc(size) #define TclpSysFree(ptr) free((char *)(ptr)) -#define TclpSysRealloc(ptr, size) realloc((char *)(ptr), (size_t)(size)) +#define TclpSysRealloc(ptr, size) realloc(ptr, size) /* *--------------------------------------------------------------------------- diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 44c5607..989e2af 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -708,7 +708,7 @@ TclpThreadCreateKey(void) { pthread_key_t *ptkeyPtr; - ptkeyPtr = TclpSysAlloc(sizeof *ptkeyPtr, 0); + ptkeyPtr = TclpSysAlloc(sizeof *ptkeyPtr); if (NULL == ptkeyPtr) { Tcl_Panic("unable to allocate thread key!"); } diff --git a/win/Makefile.in b/win/Makefile.in index 4ae4dd0..067d1b8 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -621,7 +621,7 @@ install-libraries: libraries install-tzdata install-msgs else true; \ fi; \ done; - @for i in http1.0 opt0.4 encoding ../tcl9 ../tcl9/9.0; \ + @for i in http1.0 opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ diff --git a/win/makefile.vc b/win/makefile.vc index 6340e45..3a60369 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -113,12 +113,12 @@ the build instructions. # memdbg = Enables the debugging memory allocator.
#
# CHECKS=64bit,fullwarn,nodep,none
-# Sets special macros for checking compatability.
+# Sets special macros for checking compatibility.
#
# 64bit = Enable 64bit portability warnings (if available)
# fullwarn = Builds with full compiler and link warnings enabled.
# Very verbose.
-# nodep = Turns off compatability macros to ensure the core
+# nodep = Turns off compatibility macros to ensure the core
# isn't being built with deprecated functions.
#
# MACHINE=(ALPHA|AMD64|IA64|IX86)
diff --git a/win/tclWinFile.c b/win/tclWinFile.c index ce15867..e2b6d1e 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -169,7 +169,7 @@ static int NativeWriteReparse(const TCHAR *LinkDirectory, REPARSE_DATA_BUFFER *buffer); static int NativeMatchType(int isDrive, DWORD attr, const TCHAR *nativeName, Tcl_GlobTypeData *types); -static int WinIsDrive(const char *name, int nameLen); +static int WinIsDrive(const char *name, size_t nameLen); static int WinIsReserved(const char *path); static Tcl_Obj * WinReadLink(const TCHAR *LinkSource); static Tcl_Obj * WinReadLinkDirectory(const TCHAR *LinkDirectory); @@ -933,12 +933,10 @@ TclpMatchInDirectory( * Match a single file directly. */ - size_t len; DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; const char *str = TclGetString(norm); - len = norm->length; native = Tcl_FSGetNativePath(pathPtr); if (GetFileAttributesEx(native, @@ -947,7 +945,7 @@ TclpMatchInDirectory( } attr = data.dwFileAttributes; - if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) { + if (NativeMatchType(WinIsDrive(str,norm->length), attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } } @@ -1176,7 +1174,7 @@ TclpMatchInDirectory( static int WinIsDrive( const char *name, /* Name (UTF-8) */ - int len) /* Length of name */ + size_t len) /* Length of name */ { int remove = 0; @@ -2797,9 +2795,8 @@ TclWinVolumeRelativeNormalize( * also on drive C. */ - size_t cwdLen; - const char *drive = - TclGetString(useThisCwd); + const char *drive = TclGetString(useThisCwd); + size_t cwdLen = useThisCwd->length; char drive_cur = path[0]; cwdLen = useThisCwd->length; diff --git a/win/tclWinPort.h b/win/tclWinPort.h index b6e59b4..5bbce97 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -533,7 +533,7 @@ typedef DWORD_PTR * PDWORD_PTR; * use by tclAlloc.c. */ -#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \ +#define TclpSysAlloc(size) ((void*)HeapAlloc(GetProcessHeap(), \ (DWORD)0, (DWORD)size)) #define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \ (DWORD)0, (HGLOBAL)ptr)) diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 8c130a7..c1ab58f 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -1037,7 +1037,7 @@ TclpThreadCreateKey(void) { DWORD *key; - key = TclpSysAlloc(sizeof *key, 0); + key = TclpSysAlloc(sizeof *key); if (key == NULL) { Tcl_Panic("unable to allocate thread key!"); } diff --git a/win/tclWinTime.c b/win/tclWinTime.c index c869036..7504952 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -329,7 +329,7 @@ NativeGetTime( || ((regs[0] & 0x00F00000) /* Extended family */ && (regs[3] & 0x10000000))) /* Hyperthread */ && (((regs[1]&0x00FF0000) >> 16)/* CPU count */ - == systemInfo.dwNumberOfProcessors)) { + == (int)systemInfo.dwNumberOfProcessors)) { timeInfo.perfCounterAvailable = TRUE; } else { timeInfo.perfCounterAvailable = FALSE; |