summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog.20002
-rw-r--r--ChangeLog.20026
-rw-r--r--ChangeLog.20034
-rw-r--r--ChangeLog.20042
-rw-r--r--generic/regcustom.h1
-rw-r--r--generic/regguts.h13
-rw-r--r--generic/tcl.h4
-rw-r--r--generic/tclBasic.c22
-rw-r--r--generic/tclBinary.c174
-rw-r--r--generic/tclCkalloc.c55
-rw-r--r--generic/tclCmdIL.c2
-rw-r--r--generic/tclCmdMZ.c65
-rw-r--r--generic/tclDictObj.c18
-rw-r--r--generic/tclExecute.c6
-rw-r--r--generic/tclIO.c2
-rw-r--r--generic/tclInt.decls2
-rw-r--r--generic/tclInt.h8
-rw-r--r--generic/tclIntDecls.h5
-rw-r--r--generic/tclLoad.c14
-rw-r--r--generic/tclRegexp.h2
-rw-r--r--generic/tclStringObj.c206
-rw-r--r--generic/tclStringRep.h10
-rw-r--r--generic/tclTestObj.c2
-rw-r--r--generic/tclVar.c2
-rw-r--r--library/http/http.tcl2
-rw-r--r--tests/cmdMZ.test2
-rw-r--r--unix/tcl.m42
-rw-r--r--win/makefile.vc4
-rw-r--r--win/tclWinFCmd.c14
-rwxr-xr-xwin/tclWinFile.c24
-rw-r--r--win/tclWinTime.c2
31 files changed, 450 insertions, 227 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 1f00bf4..c4dbc73 100644
--- a/generic/regcustom.h
+++ b/generic/regcustom.h
@@ -36,7 +36,6 @@
* Overrides for regguts.h definitions, if any.
*/
-#define FUNCPTR(name, args) (*name)args
#define MALLOC(n) (void*)(attemptckalloc(n))
#define FREE(p) ckfree((void*)(p))
#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n))
diff --git a/generic/regguts.h b/generic/regguts.h
index 9461136..ad9d5b9 100644
--- a/generic/regguts.h
+++ b/generic/regguts.h
@@ -49,15 +49,6 @@
#include <assert.h>
#endif
-/* function-pointer declarator */
-#ifndef FUNCPTR
-#if __STDC__ >= 1
-#define FUNCPTR(name, args) (*name)args
-#else
-#define FUNCPTR(name, args) (*name)()
-#endif
-#endif
-
/* memory allocation */
#ifndef MALLOC
#define MALLOC(n) malloc(n)
@@ -391,7 +382,7 @@ struct subre {
*/
struct fns {
- void FUNCPTR(free, (regex_t *));
+ void (*free) (regex_t *);
};
/*
@@ -408,7 +399,7 @@ struct guts {
struct cnfa search; /* for fast preliminary search */
int ntree; /* number of subre's, plus one */
struct colormap cmap;
- int FUNCPTR(compare, (const chr *, const chr *, size_t));
+ int (*compare) (const chr *, const chr *, size_t);
struct subre *lacons; /* lookahead-constraint vector */
int nlacons; /* size of lacons */
};
diff --git a/generic/tcl.h b/generic/tcl.h
index 7984005..a8c68a6 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -1320,9 +1320,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
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index c1dd52d..81b3513 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -3024,13 +3024,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
@@ -3052,6 +3045,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;
}
@@ -3154,6 +3155,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 9a5771e..4d063b2 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 ByteArray {
#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);
}
@@ -450,29 +531,35 @@ SetByteArrayFromAny(
Tcl_Interp *interp, /* Not used. */
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
- int length;
+ int length, improper = 0;
const char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
Tcl_UniChar ch;
- if (objPtr->typePtr != &tclByteArrayType) {
- src = TclGetStringFromObj(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 = TclGetStringFromObj(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;
}
@@ -535,7 +622,7 @@ DupByteArrayInternalRep(
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
SET_BYTEARRAY(copyPtr, copyArrayPtr);
- copyPtr->typePtr = &tclByteArrayType;
+ copyPtr->typePtr = srcPtr->typePtr;
}
/*
@@ -642,7 +729,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 70e64f0..d42536e 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -34,14 +34,14 @@
*/
typedef struct MemTag {
- 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). */
@@ -52,14 +52,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
@@ -251,10 +251,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");
}
@@ -273,11 +273,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");
}
@@ -359,10 +359,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);
}
@@ -458,8 +458,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)) {
@@ -547,8 +547,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)) {
@@ -612,8 +612,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) {
@@ -623,7 +623,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++;
@@ -631,8 +631,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);
}
}
@@ -675,7 +674,7 @@ Tcl_DbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -689,7 +688,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);
@@ -706,7 +705,7 @@ Tcl_AttemptDbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -720,7 +719,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/tclCmdIL.c b/generic/tclCmdIL.c
index cca4069..ec85741 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1737,7 +1737,7 @@ InfoLoadedCmd(
} else { /* Get pkgs just in specified interp. */
packageName = TclGetString(objv[2]);
}
- return TclGetLoadedPackages(interp, interpName, packageName);
+ return TclGetLoadedPackagesEx(interp, interpName, packageName);
}
/*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 7f2a2f3..c06b197 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -2140,9 +2140,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) {
@@ -2160,70 +2158,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/tclDictObj.c b/generic/tclDictObj.c
index 9686c6f..1115999 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -142,7 +142,7 @@ typedef struct Dict {
* the entries in the order that they are
* created. */
int epoch; /* Epoch counter */
- int refcount; /* Reference counter (see above) */
+ size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
@@ -392,7 +392,7 @@ DupDictInternalRep(
newDict->epoch = 0;
newDict->chain = NULL;
- newDict->refcount = 1;
+ newDict->refCount = 1;
/*
* Store in the object.
@@ -427,8 +427,7 @@ FreeDictInternalRep(
{
Dict *dict = DICT(dictPtr);
- dict->refcount--;
- if (dict->refcount <= 0) {
+ if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
dictPtr->typePtr = NULL;
@@ -713,7 +712,7 @@ SetDictFromAny(
TclFreeIntRep(objPtr);
dict->epoch = 0;
dict->chain = NULL;
- dict->refcount = 1;
+ dict->refCount = 1;
DICT(objPtr) = dict;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclDictType;
@@ -1117,7 +1116,7 @@ Tcl_DictObjFirst(
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
searchPtr->next = cPtr->nextPtr;
- dict->refcount++;
+ dict->refCount++;
if (keyPtrPtr != NULL) {
*keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
}
@@ -1231,8 +1230,7 @@ Tcl_DictObjDone(
if (searchPtr->epoch != -1) {
searchPtr->epoch = -1;
dict = (Dict *) searchPtr->dictionaryPtr;
- dict->refcount--;
- if (dict->refcount <= 0) {
+ if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
}
@@ -1384,7 +1382,7 @@ Tcl_NewDictObj(void)
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
- dict->refcount = 1;
+ dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
@@ -1434,7 +1432,7 @@ Tcl_DbNewDictObj(
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
- dict->refcount = 1;
+ dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1f78ead..074b1d5 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -9459,9 +9459,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/tclIO.c b/generic/tclIO.c
index 80f6fa4..ffd2430 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -7129,7 +7129,7 @@ Tcl_Tell(
*
* Tcl_SeekOld, Tcl_TellOld --
*
- * Backward-compatability versions of the seek/tell interface that do not
+ * Backward-compatibility versions of the seek/tell interface that do not
* support 64-bit offsets. This interface is not documented or expected
* to be supported indefinitely.
*
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 5730624..8314925 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -165,7 +165,7 @@ declare 34 {
# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
#}
declare 37 {
- int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName, const char *packageName)
+ int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
}
declare 38 {
int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9422a03..37908bc 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2974,6 +2974,9 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr,
unsigned int *sizePtr);
+MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp,
+ const char *targetName,
+ const char *packageName);
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData *types);
@@ -3149,6 +3152,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);
@@ -4427,8 +4432,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 7f853b2..dfa5727 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -135,8 +135,7 @@ EXTERN int TclGetIntForIndex(Tcl_Interp *interp,
/* Slot 36 is reserved */
/* 37 */
EXTERN int TclGetLoadedPackages(Tcl_Interp *interp,
- const char *targetName,
- const char *packageName);
+ const char *targetName);
/* 38 */
EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp,
const char *qualName, Namespace *cxtNsPtr,
@@ -660,7 +659,7 @@ typedef struct TclIntStubs {
int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
void (*reserved35)(void);
void (*reserved36)(void);
- int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName, const char *packageName); /* 37 */
+ int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 2d8ed5f..aabe3bb 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -1012,7 +1012,7 @@ Tcl_StaticPackage(
/*
*----------------------------------------------------------------------
*
- * TclGetLoadedPackages --
+ * TclGetLoadedPackages, TclGetLoadedPackagesEx --
*
* This function returns information about all of the files that are
* loaded (either in a particular interpreter, or for all interpreters).
@@ -1034,6 +1034,18 @@ int
TclGetLoadedPackages(
Tcl_Interp *interp, /* Interpreter in which to return information
* or error message. */
+ const char *targetName) /* Name of target interpreter or NULL. If
+ * NULL, return info about all interps;
+ * otherwise, just return info about this
+ * interpreter. */
+{
+ return TclGetLoadedPackagesEx(interp, targetName, NULL);
+}
+
+int
+TclGetLoadedPackagesEx(
+ Tcl_Interp *interp, /* Interpreter in which to return information
+ * or error message. */
const char *targetName, /* Name of target interpreter or NULL. If
* NULL, return info about all interps;
* otherwise, just return info about this
diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h
index 3b2433e..eac0aaa 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
+ unsigned int refCount; /* Count of number of references to this
* compiled regexp. */
} TclRegexp;
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index f7791fe..9471381 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2472,6 +2472,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 +2504,9 @@ 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 '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--) {
diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h
index db6f7e4..1ef1957 100644
--- a/generic/tclStringRep.h
+++ b/generic/tclStringRep.h
@@ -72,17 +72,17 @@ typedef struct {
do { \
if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \
Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
- STRING_MAXCHARS); \
+ (int)STRING_MAXCHARS); \
} \
} while (0)
#define stringAttemptAlloc(numChars) \
- (String *) attemptckalloc((unsigned) STRING_SIZE(numChars))
+ (String *) attemptckalloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
- (String *) ckalloc((unsigned) STRING_SIZE(numChars))
+ (String *) ckalloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \
- (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
+ (String *) ckrealloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
- (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
+ (String *) attemptckrealloc((ptr), STRING_SIZE(numChars))
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 06f8e5f..5627608 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -1101,7 +1101,7 @@ TestobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(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/tclVar.c b/generic/tclVar.c
index 48e09f6..5ab6e8b 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -2754,7 +2754,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/unix/tcl.m4 b/unix/tcl.m4
index f5aa84e..3189960 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/win/makefile.vc b/win/makefile.vc
index c10b196..d6de5e1 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/tclWinFCmd.c b/win/tclWinFCmd.c
index 8904a05..01af950 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -1525,8 +1525,8 @@ GetWinFileAttributes(
* We test for, and fix that case, here.
*/
- int len;
- const char *str = TclGetStringFromObj(fileName,&len);
+ const char *str = TclGetString(fileName);
+ size_t len = fileName->length;
if (len < 4) {
if (len == 0) {
@@ -1611,11 +1611,12 @@ ConvertFileNameFormat(
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
- int pathLen;
+ size_t pathLen;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
- pathv = TclGetStringFromObj(elt, &pathLen);
+ pathv = TclGetString(elt);
+ pathLen = elt->length;
if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':'))
|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
/*
@@ -1639,7 +1640,6 @@ ConvertFileNameFormat(
Tcl_DString dsTemp;
const TCHAR *nativeName;
const char *tempString;
- int tempLen;
WIN32_FIND_DATA data;
HANDLE handle;
DWORD attr;
@@ -1653,8 +1653,8 @@ ConvertFileNameFormat(
*/
Tcl_DStringInit(&ds);
- tempString = TclGetStringFromObj(tempPath,&tempLen);
- nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
+ tempString = TclGetString(tempPath);
+ nativeName = Tcl_WinUtfToTChar(tempString, tempPath->length, &ds);
Tcl_DecrRefCount(tempPath);
handle = FindFirstFile(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 9458933..e61d619 100755
--- 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,10 +933,9 @@ TclpMatchInDirectory(
* Match a single file directly.
*/
- int len;
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
- const char *str = TclGetStringFromObj(norm,&len);
+ const char *str = TclGetString(norm);
native = Tcl_FSGetNativePath(pathPtr);
@@ -946,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);
}
}
@@ -957,7 +956,7 @@ TclpMatchInDirectory(
WIN32_FIND_DATA data;
const char *dirName; /* UTF-8 dir name, later with pattern
* appended. */
- int dirLength;
+ size_t dirLength;
int matchSpecialDots;
Tcl_DString ds; /* Native encoding of dir, also used
* temporarily for other things. */
@@ -996,7 +995,8 @@ TclpMatchInDirectory(
*/
Tcl_DStringInit(&dsOrig);
- dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
+ dirName = TclGetString(fileNamePtr);
+ dirLength = fileNamePtr->length;
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
lastChar = dirName[dirLength -1];
@@ -1174,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;
@@ -2705,15 +2705,14 @@ TclpObjNormalizePath(
* Not the end of the string.
*/
- int len;
char *path;
Tcl_Obj *tmpPathPtr;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
- path = TclGetStringFromObj(tmpPathPtr, &len);
- Tcl_SetStringObj(pathPtr, path, len);
+ path = TclGetString(tmpPathPtr);
+ Tcl_SetStringObj(pathPtr, path, tmpPathPtr->length);
Tcl_DecrRefCount(tmpPathPtr);
} else {
/*
@@ -2796,9 +2795,8 @@ TclWinVolumeRelativeNormalize(
* also on drive C.
*/
- int cwdLen;
- const char *drive =
- TclGetStringFromObj(useThisCwd, &cwdLen);
+ const char *drive = TclGetString(useThisCwd);
+ size_t cwdLen = useThisCwd->length;
char drive_cur = path[0];
if (drive_cur >= 'a') {
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
index f4e08fa..71a0366 100644
--- a/win/tclWinTime.c
+++ b/win/tclWinTime.c
@@ -353,7 +353,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;
generated by cgit v0.12 at 2025-02-16 22:03:48 (GMT)