summaryrefslogtreecommitdiffstats
path: root/generic/tclObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclObj.c')
-rw-r--r--generic/tclObj.c969
1 files changed, 569 insertions, 400 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5c17df2..74cb29e 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -16,7 +16,6 @@
#include "tclInt.h"
#include "tommath.h"
-#include <float.h>
#include <math.h>
/*
@@ -51,17 +50,17 @@ Tcl_Mutex tclObjMutex;
char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;
-
+
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
- * Structure for tracking the source file and line number where a given Tcl_Obj
- * was allocated. We also track the pointer to the Tcl_Obj itself, for sanity
- * checking purposes.
+ * Structure for tracking the source file and line number where a given
+ * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself,
+ * for sanity checking purposes.
*/
typedef struct ObjData {
Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */
- CONST char *file; /* The name of the source file calling this
+ const char *file; /* The name of the source file calling this
* function; used for debugging. */
int line; /* Line number in the source file; used for
* debugging. */
@@ -78,33 +77,29 @@ typedef struct ObjData {
*/
typedef struct ThreadSpecificData {
- Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj
- * generated by a call to the function
- * TclSubstTokens() from a literal text
- * where bs+nl sequences occured in it, if
- * any. I.e. this table keeps track of
- * invisible/stripped continuation lines. Its
- * keys are Tcl_Obj pointers, the values are
- * ContLineLoc pointers. See the file
- * tclCompile.h for the definition of this
- * structure, and for references to all related
- * places in the core.
- */
+ Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
+ * generated by a call to the function
+ * TclSubstTokens() from a literal text
+ * where bs+nl sequences occured in it, if
+ * any. I.e. this table keeps track of
+ * invisible and stripped continuation lines.
+ * Its keys are Tcl_Obj pointers, the values
+ * are ContLineLoc pointers. See the file
+ * tclCompile.h for the definition of this
+ * structure, and for references to all
+ * related places in the core. */
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
- /*
- * Thread local table that is used to check that a Tcl_Obj was not
- * allocated by some other thread.
- */
-
- Tcl_HashTable *objThreadMap;
+ Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
+ * that a Tcl_Obj was not allocated by some
+ * other thread. */
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
-static void ContLineLocFree (char* clientData);
-static void TclThreadFinalizeContLines (ClientData clientData);
-static ThreadSpecificData* TclGetContLineTable (void);
+static void ContLineLocFree(char *clientData);
+static void TclThreadFinalizeContLines(ClientData clientData);
+static ThreadSpecificData *TclGetContLineTable(void);
/*
* Nested Tcl_Obj deletion management support
@@ -153,11 +148,11 @@ typedef struct PendingObjData {
#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL)
#define PushObjToDelete(contextPtr,objPtr) \
/* The string rep is already invalidated so we can use the bytes value \
- * for our pointer chain: push onto the head of the stack. */ \
- (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
+ * for our pointer chain: push onto the head of the stack. */ \
+ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
(contextPtr)->deletionStack = (objPtr)
#define PopObjToDelete(contextPtr,objPtrVar) \
- (objPtrVar) = (contextPtr)->deletionStack; \
+ (objPtrVar) = (contextPtr)->deletionStack; \
(contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
/*
@@ -166,11 +161,15 @@ typedef struct PendingObjData {
#ifndef TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
- PendingObjData *CONST contextPtr = &pendingObjData
+ PendingObjData *const contextPtr = &pendingObjData
+#elif HAVE_FAST_TSD
+static __thread PendingObjData pendingObjData;
+#define ObjInitDeletionContext(contextPtr) \
+ PendingObjData *const contextPtr = &pendingObjData
#else
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
- PendingObjData *CONST contextPtr = (PendingObjData *) \
+ PendingObjData *const contextPtr = \
Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
@@ -179,27 +178,27 @@ static Tcl_ThreadDataKey pendingObjDataKey;
*/
#define PACK_BIGNUM(bignum, objPtr) \
- if ((bignum).used > 0x7fff) { \
- mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
- *temp = bignum; \
- (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \
+ if ((bignum).used > 0x7fff) { \
+ mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
+ *temp = bignum; \
+ (objPtr)->internalRep.ptrAndLongRep.ptr = temp; \
(objPtr)->internalRep.ptrAndLongRep.value = (unsigned long)(-1); \
- } else { \
- if ((bignum).alloc > 0x7fff) { \
- mp_shrink(&(bignum)); \
- } \
- (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \
+ } else { \
+ if ((bignum).alloc > 0x7fff) { \
+ mp_shrink(&(bignum)); \
+ } \
+ (objPtr)->internalRep.ptrAndLongRep.ptr = (void *) (bignum).dp; \
(objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \
- | ((bignum).alloc << 15) | ((bignum).used)); \
+ | ((bignum).alloc << 15) | ((bignum).used)); \
}
#define UNPACK_BIGNUM(objPtr, bignum) \
if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \
(bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \
- } else { \
- (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \
+ } else { \
+ (bignum).dp = (objPtr)->internalRep.ptrAndLongRep.ptr; \
(bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \
- (bignum).alloc = \
+ (bignum).alloc = \
((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \
(bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \
}
@@ -246,56 +245,56 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* implementations.
*/
-static Tcl_ObjType oldBooleanType = {
- "boolean", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- NULL, /* updateStringProc */
- SetBooleanFromAny /* setFromAnyProc */
+static const Tcl_ObjType oldBooleanType = {
+ "boolean", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetBooleanFromAny /* setFromAnyProc */
};
-Tcl_ObjType tclBooleanType = {
- "booleanString", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- NULL, /* updateStringProc */
- SetBooleanFromAny /* setFromAnyProc */
+const Tcl_ObjType tclBooleanType = {
+ "booleanString", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetBooleanFromAny /* setFromAnyProc */
};
-Tcl_ObjType tclDoubleType = {
- "double", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- UpdateStringOfDouble, /* updateStringProc */
- SetDoubleFromAny /* setFromAnyProc */
+const Tcl_ObjType tclDoubleType = {
+ "double", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfDouble, /* updateStringProc */
+ SetDoubleFromAny /* setFromAnyProc */
};
-Tcl_ObjType tclIntType = {
- "int", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- UpdateStringOfInt, /* updateStringProc */
- SetIntFromAny /* setFromAnyProc */
+const Tcl_ObjType tclIntType = {
+ "int", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfInt, /* updateStringProc */
+ SetIntFromAny /* setFromAnyProc */
};
#ifndef NO_WIDE_TYPE
-Tcl_ObjType tclWideIntType = {
- "wideInt", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- UpdateStringOfWideInt, /* updateStringProc */
- SetWideIntFromAny /* setFromAnyProc */
+const Tcl_ObjType tclWideIntType = {
+ "wideInt", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfWideInt, /* updateStringProc */
+ SetWideIntFromAny /* setFromAnyProc */
};
#endif
-Tcl_ObjType tclBignumType = {
- "bignum", /* name */
- FreeBignum, /* freeIntRepProc */
- DupBignum, /* dupIntRepProc */
- UpdateStringOfBignum, /* updateStringProc */
- NULL /* setFromAnyProc */
+const Tcl_ObjType tclBignumType = {
+ "bignum", /* name */
+ FreeBignum, /* freeIntRepProc */
+ DupBignum, /* dupIntRepProc */
+ UpdateStringOfBignum, /* updateStringProc */
+ NULL /* setFromAnyProc */
};
/*
* The structure below defines the Tcl obj hash key type.
*/
-Tcl_HashKeyType tclObjHashKeyType = {
+const Tcl_HashKeyType tclObjHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
TclHashObjKey, /* hashKeyProc */
@@ -317,14 +316,22 @@ Tcl_HashKeyType tclObjHashKeyType = {
* ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions
* use the second internal pointer field of the twoPtrValue field for their
* own purposes.
+ *
+ * TRICKY POINT! Some extensions update this structure! (Notably, these
+ * include TclBlend and TCom). This is highly ill-advised on their part, but
+ * does allow them to delete a command when references to it are gone, which
+ * is fragile but useful given their somewhat-OO style. Because of this, this
+ * structure MUST NOT be const so that the C compiler puts the data in
+ * writable memory. [Bug 2558422]
+ * TODO: Provide a better API for those extensions so that they can coexist...
*/
-static Tcl_ObjType tclCmdNameType = {
- "cmdName", /* name */
- FreeCmdNameInternalRep, /* freeIntRepProc */
- DupCmdNameInternalRep, /* dupIntRepProc */
- NULL, /* updateStringProc */
- SetCmdNameFromAny /* setFromAnyProc */
+Tcl_ObjType tclCmdNameType = {
+ "cmdName", /* name */
+ FreeCmdNameInternalRep, /* freeIntRepProc */
+ DupCmdNameInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetCmdNameFromAny /* setFromAnyProc */
};
/*
@@ -414,6 +421,7 @@ TclInitObjSubsystem(void)
tclObjsFreed = 0;
{
int i;
+
for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) {
tclObjsShared[i] = 0;
}
@@ -454,12 +462,12 @@ TclFinalizeThreadObjects(void)
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
- ckfree((char *) objData);
+ ckfree(objData);
}
}
Tcl_DeleteHashTable(tablePtr);
- ckfree((char *) tablePtr);
+ ckfree(tablePtr);
tsdPtr->objThreadMap = NULL;
}
#endif
@@ -521,8 +529,8 @@ TclFinalizeObjects(void)
*----------------------------------------------------------------------
*/
-static ThreadSpecificData*
-TclGetContLineTable()
+static ThreadSpecificData *
+TclGetContLineTable(void)
{
/*
* Initialize the hashtable tracking invisible continuation lines. For
@@ -533,10 +541,11 @@ TclGetContLineTable()
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
if (!tsdPtr->lineCLPtr) {
- tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
+ tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
- Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL);
+ Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
}
return tsdPtr;
}
@@ -559,18 +568,17 @@ TclGetContLineTable()
*----------------------------------------------------------------------
*/
-ContLineLoc*
-TclContinuationsEnter(Tcl_Obj* objPtr,
- int num,
- int* loc)
+ContLineLoc *
+TclContinuationsEnter(
+ Tcl_Obj *objPtr,
+ int num,
+ int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
- Tcl_HashEntry* hPtr =
- Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry);
-
- ContLineLoc* clLocPtr =
- (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int));
+ Tcl_HashEntry *hPtr =
+ Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
+ ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
if (!newEntry) {
/*
@@ -589,18 +597,18 @@ TclContinuationsEnter(Tcl_Obj* objPtr,
* incoming num/loc data even so. Because we are called from
* TclContinuationsEnterDerived for this case, which modified the
* stored locations (Rebased to the proper relative offset). Just
- * returning the stored entry and data would rebase them a second
- * time, or more, hosing the data. It is easier to simply replace, as
- * we are doing.
+ * returning the stored entry would rebase them a second time, or
+ * more, hosing the data. It is easier to simply replace, as we are
+ * doing.
*/
- ckfree((char *) Tcl_GetHashValue(hPtr));
+ ckfree(Tcl_GetHashValue(hPtr));
}
clLocPtr->num = num;
- memcpy (&clLocPtr->loc, loc, num*sizeof(int));
- clLocPtr->loc[num] = CLL_END; /* Sentinel */
- Tcl_SetHashValue (hPtr, clLocPtr);
+ memcpy(&clLocPtr->loc, loc, num*sizeof(int));
+ clLocPtr->loc[num] = CLL_END; /* Sentinel */
+ Tcl_SetHashValue(hPtr, clLocPtr);
return clLocPtr;
}
@@ -625,8 +633,14 @@ TclContinuationsEnter(Tcl_Obj* objPtr,
*/
void
-TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
+TclContinuationsEnterDerived(
+ Tcl_Obj *objPtr,
+ int start,
+ int *clNext)
{
+ int length, end, num;
+ int *wordCLLast = clNext;
+
/*
* We have to handle invisible continuations lines here as well, despite
* the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If
@@ -647,20 +661,15 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
*/
/*
- * First compute the range of the word within the script.
+ * First compute the range of the word within the script. (Is there a
+ * better way which doesn't shimmer?)
*/
- int length, end, num;
- int* wordCLLast = clNext;
-
Tcl_GetStringFromObj(objPtr, &length);
- /* Is there a better way which doesn't shimmer ? */
-
- end = start + length; /* first char after the word */
+ end = start + length; /* First char after the word */
/*
- * Then compute the table slice covering the range of
- * the word.
+ * Then compute the table slice covering the range of the word.
*/
while (*wordCLLast >= 0 && *wordCLLast < end) {
@@ -668,21 +677,19 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
}
/*
- * And generate the table from the slice, if it was
- * not empty.
+ * And generate the table from the slice, if it was not empty.
*/
num = wordCLLast - clNext;
if (num) {
int i;
- ContLineLoc* clLocPtr =
- TclContinuationsEnter(objPtr, num, clNext);
+ ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext);
/*
* Re-base the locations.
*/
- for (i=0;i<num;i++) {
+ for (i=0 ; i<num ; i++) {
clLocPtr->loc[i] -= start;
/*
@@ -704,9 +711,9 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
* TclContinuationsCopy --
*
* This procedure is a helper which copies the continuation line
- * information associated with a Tcl_Obj* to another Tcl_Obj*.
- * It is assumed that both contain the same string/script. Use
- * this when a script is duplicated because it was shared.
+ * information associated with a Tcl_Obj* to another Tcl_Obj*. It is
+ * assumed that both contain the same string/script. Use this when a
+ * script is duplicated because it was shared.
*
* Results:
* None.
@@ -719,13 +726,16 @@ TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
*/
void
-TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
+TclContinuationsCopy(
+ Tcl_Obj *objPtr,
+ Tcl_Obj *originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr);
+ Tcl_HashEntry *hPtr =
+ Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
- ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr);
+ ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
}
@@ -740,8 +750,8 @@ TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
* information associated with a Tcl_Obj*, if it has any.
*
* Results:
- * A reference to the continuation line location table, or NULL
- * if the Tcl_Obj* has no such information associated with it.
+ * A reference to the continuation line location table, or NULL if the
+ * Tcl_Obj* has no such information associated with it.
*
* Side effects:
* None.
@@ -750,17 +760,18 @@ TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
*----------------------------------------------------------------------
*/
-ContLineLoc*
-TclContinuationsGet(Tcl_Obj* objPtr)
+ContLineLoc *
+TclContinuationsGet(
+ Tcl_Obj *objPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr);
+ Tcl_HashEntry *hPtr =
+ Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
- if (hPtr) {
- return (ContLineLoc*) Tcl_GetHashValue (hPtr);
- } else {
- return NULL;
+ if (!hPtr) {
+ return NULL;
}
+ return Tcl_GetHashValue(hPtr);
}
/*
@@ -782,7 +793,8 @@ TclContinuationsGet(Tcl_Obj* objPtr)
*/
static void
-TclThreadFinalizeContLines (ClientData clientData)
+TclThreadFinalizeContLines(
+ ClientData clientData)
{
/*
* Release the hashtable tracking invisible continuation lines.
@@ -793,19 +805,19 @@ TclThreadFinalizeContLines (ClientData clientData)
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
/*
* We are not using Tcl_EventuallyFree (as in TclFreeObj()) because
* here we can be sure that the compiler will not hold references to
* the data in the hashtable, and using TEF might bork the
* finalization sequence.
*/
- ContLineLocFree (Tcl_GetHashValue (hPtr));
- Tcl_DeleteHashEntry (hPtr);
+
+ ContLineLocFree(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
}
- Tcl_DeleteHashTable (tsdPtr->lineCLPtr);
- ckfree((char *) tsdPtr->lineCLPtr);
+ Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
+ ckfree(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
@@ -827,9 +839,10 @@ TclThreadFinalizeContLines (ClientData clientData)
*/
static void
-ContLineLocFree (char* clientData)
+ContLineLocFree(
+ char *clientData)
{
- ckfree (clientData);
+ ckfree(clientData);
}
/*
@@ -853,7 +866,7 @@ ContLineLocFree (char* clientData)
void
Tcl_RegisterObjType(
- Tcl_ObjType *typePtr) /* Information about object type; storage must
+ const Tcl_ObjType *typePtr) /* Information about object type; storage must
* be statically allocated (must live
* forever). */
{
@@ -940,17 +953,17 @@ Tcl_AppendAllObjTypes(
*----------------------------------------------------------------------
*/
-Tcl_ObjType *
+const Tcl_ObjType *
Tcl_GetObjType(
- CONST char *typeName) /* Name of Tcl object type to look up. */
+ const char *typeName) /* Name of Tcl object type to look up. */
{
register Tcl_HashEntry *hPtr;
- Tcl_ObjType *typePtr = NULL;
+ const Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != NULL) {
- typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
+ typePtr = Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
@@ -980,7 +993,7 @@ int
Tcl_ConvertToType(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object to convert. */
- Tcl_ObjType *typePtr) /* The target type. */
+ const Tcl_ObjType *typePtr) /* The target type. */
{
if (objPtr->typePtr == typePtr) {
return TCL_OK;
@@ -1070,7 +1083,7 @@ TclDbDumpActiveObjects(
void
TclDbInitNewObj(
register Tcl_Obj *objPtr,
- register CONST char *file, /* The name of the source file calling this
+ register const char *file, /* The name of the source file calling this
* function; used for debugging. */
register int line) /* Line number in the source file; used for
* debugging. */
@@ -1094,12 +1107,11 @@ TclDbInitNewObj(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
- tsdPtr->objThreadMap = (Tcl_HashTable *)
- ckalloc(sizeof(Tcl_HashTable));
+ tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
}
tablePtr = tsdPtr->objThreadMap;
- hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew);
+ hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew);
if (!isNew) {
Tcl_Panic("expected to create new entry for object map");
}
@@ -1108,7 +1120,7 @@ TclDbInitNewObj(
* Record the debugging information.
*/
- objData = (ObjData *) ckalloc(sizeof(ObjData));
+ objData = ckalloc(sizeof(ObjData));
objData->objPtr = objPtr;
objData->file = file;
objData->line = line;
@@ -1200,7 +1212,7 @@ Tcl_NewObj(void)
Tcl_Obj *
Tcl_DbNewObj(
- register CONST char *file, /* The name of the source file calling this
+ register const char *file, /* The name of the source file calling this
* function; used for debugging. */
register int line) /* Line number in the source file; used for
* debugging. */
@@ -1218,7 +1230,7 @@ Tcl_DbNewObj(
Tcl_Obj *
Tcl_DbNewObj(
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -1267,12 +1279,12 @@ TclAllocateFreeObjects(void)
* Purify apparently can't figure that out, and fires a false alarm.
*/
- basePtr = (char *) ckalloc(bytesToAlloc);
+ basePtr = ckalloc(bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
- objPtr->internalRep.otherValuePtr = (void *) prevPtr;
+ objPtr->internalRep.otherValuePtr = prevPtr;
prevPtr = objPtr;
objPtr++;
}
@@ -1309,7 +1321,7 @@ void
TclFreeObj(
register Tcl_Obj *objPtr) /* The object to be freed. */
{
- register Tcl_ObjType *typePtr = objPtr->typePtr;
+ register const Tcl_ObjType *typePtr = objPtr->typePtr;
/*
* This macro declares a variable, so must come here...
@@ -1318,13 +1330,15 @@ TclFreeObj(
ObjInitDeletionContext(context);
if (objPtr->refCount < -1) {
- Tcl_Panic("Reference count for %lx was negative", objPtr);
+ Tcl_Panic("Reference count for %p was negative", objPtr);
}
- /* Invalidate the string rep first so we can use the bytes value
- * for our pointer chain, and signal an obj deletion (as opposed
- * to shimmering) with 'length == -1' */
-
+ /*
+ * Invalidate the string rep first so we can use the bytes value for our
+ * pointer chain, and signal an obj deletion (as opposed to shimmering)
+ * with 'length == -1'.
+ */
+
TclInvalidateStringRep(objPtr);
objPtr->length = -1;
@@ -1339,19 +1353,19 @@ TclFreeObj(
}
Tcl_MutexLock(&tclObjMutex);
- ckfree((char *) objPtr);
+ ckfree(objPtr);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
ObjDeletionLock(context);
while (ObjOnStack(context)) {
Tcl_Obj *objToFree;
- PopObjToDelete(context,objToFree);
+ PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
TclFreeIntRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
- ckfree((char *) objToFree);
+ ckfree(objToFree);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
}
@@ -1360,22 +1374,23 @@ TclFreeObj(
/*
* We cannot use TclGetContinuationTable() here, because that may
- * re-initialize the thread-data for calls coming after the
- * finalization. We have to access it using the low-level call and then
- * check for validity. This function can be called after
- * TclFinalizeThreadData() has already killed the thread-global data
- * structures. Performing TCL_TSD_INIT will leave us with an
- * un-initialized memory block upon which we crash (if we where to access
- * the uninitialized hashtable).
+ * re-initialize the thread-data for calls coming after the finalization.
+ * We have to access it using the low-level call and then check for
+ * validity. This function can be called after TclFinalizeThreadData() has
+ * already killed the thread-global data structures. Performing
+ * TCL_TSD_INIT will leave us with an un-initialized memory block upon
+ * which we crash (if we where to access the uninitialized hashtable).
*/
{
- ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_HashEntry *hPtr;
+
if (tsdPtr->lineCLPtr) {
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
- Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree);
- Tcl_DeleteHashEntry (hPtr);
+ Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
+ Tcl_DeleteHashEntry(hPtr);
}
}
}
@@ -1386,13 +1401,15 @@ void
TclFreeObj(
register Tcl_Obj *objPtr) /* The object to be freed. */
{
- /* Invalidate the string rep first so we can use the bytes value
- * for our pointer chain, and signal an obj deletion (as opposed
- * to shimmering) with 'length == -1' */
+ /*
+ * Invalidate the string rep first so we can use the bytes value for our
+ * pointer chain, and signal an obj deletion (as opposed to shimmering)
+ * with 'length == -1'.
+ */
TclInvalidateStringRep(objPtr);
objPtr->length = -1;
-
+
if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
/*
* objPtr can be freed safely, as it will not attempt to free any
@@ -1432,7 +1449,8 @@ TclFreeObj(
ObjDeletionLock(context);
while (ObjOnStack(context)) {
Tcl_Obj *objToFree;
- PopObjToDelete(context,objToFree);
+
+ PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
if ((objToFree->typePtr != NULL)
&& (objToFree->typePtr->freeIntRepProc != NULL)) {
@@ -1447,27 +1465,28 @@ TclFreeObj(
/*
* We cannot use TclGetContinuationTable() here, because that may
- * re-initialize the thread-data for calls coming after the
- * finalization. We have to access it using the low-level call and then
- * check for validity. This function can be called after
- * TclFinalizeThreadData() has already killed the thread-global data
- * structures. Performing TCL_TSD_INIT will leave us with an
- * un-initialized memory block upon which we crash (if we where to access
- * the uninitialized hashtable).
+ * re-initialize the thread-data for calls coming after the finalization.
+ * We have to access it using the low-level call and then check for
+ * validity. This function can be called after TclFinalizeThreadData() has
+ * already killed the thread-global data structures. Performing
+ * TCL_TSD_INIT will leave us with an un-initialized memory block upon
+ * which we crash (if we where to access the uninitialized hashtable).
*/
{
- ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_HashEntry *hPtr;
+
if (tsdPtr->lineCLPtr) {
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
- Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree);
- Tcl_DeleteHashEntry (hPtr);
+ Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
+ Tcl_DeleteHashEntry(hPtr);
}
}
}
}
-#endif
+#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
@@ -1493,7 +1512,6 @@ TclObjBeingDeleted(
{
return (objPtr->length == -1);
}
-
/*
*----------------------------------------------------------------------
@@ -1524,30 +1542,47 @@ TclObjBeingDeleted(
*----------------------------------------------------------------------
*/
+#define SetDuplicateObj(dupPtr, objPtr) \
+ { \
+ const Tcl_ObjType *typePtr = (objPtr)->typePtr; \
+ const char *bytes = (objPtr)->bytes; \
+ if (bytes) { \
+ TclInitStringRep((dupPtr), bytes, (objPtr)->length); \
+ } else { \
+ (dupPtr)->bytes = NULL; \
+ } \
+ if (typePtr) { \
+ if (typePtr->dupIntRepProc) { \
+ typePtr->dupIntRepProc((objPtr), (dupPtr)); \
+ } else { \
+ (dupPtr)->internalRep = (objPtr)->internalRep; \
+ (dupPtr)->typePtr = typePtr; \
+ } \
+ } \
+ }
+
Tcl_Obj *
Tcl_DuplicateObj(
- register Tcl_Obj *objPtr) /* The object to duplicate. */
+ Tcl_Obj *objPtr) /* The object to duplicate. */
{
- register Tcl_ObjType *typePtr = objPtr->typePtr;
- register Tcl_Obj *dupPtr;
+ Tcl_Obj *dupPtr;
TclNewObj(dupPtr);
+ SetDuplicateObj(dupPtr, objPtr);
+ return dupPtr;
+}
- if (objPtr->bytes == NULL) {
- dupPtr->bytes = NULL;
- } else if (objPtr->bytes != tclEmptyStringRep) {
- TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
- }
-
- if (typePtr != NULL) {
- if (typePtr->dupIntRepProc == NULL) {
- dupPtr->internalRep = objPtr->internalRep;
- dupPtr->typePtr = typePtr;
- } else {
- (*typePtr->dupIntRepProc)(objPtr, dupPtr);
- }
+void
+TclSetDuplicateObj(
+ Tcl_Obj *dupPtr,
+ Tcl_Obj *objPtr)
+{
+ if (Tcl_IsShared(dupPtr)) {
+ Tcl_Panic("%s called with shared object", "TclSetDuplicateObj");
}
- return dupPtr;
+ TclInvalidateStringRep(dupPtr);
+ TclFreeIntRep(dupPtr);
+ SetDuplicateObj(dupPtr, objPtr);
}
/*
@@ -1580,11 +1615,29 @@ Tcl_GetString(
return objPtr->bytes;
}
+ /*
+ * Note we do not check for objPtr->typePtr == NULL. An invariant of
+ * a properly maintained Tcl_Obj is that at least one of objPtr->bytes
+ * and objPtr->typePtr must not be NULL. If broken extensions fail to
+ * maintain that invariant, we can crash here.
+ */
+
if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an updateStringProc
+ * must be written in such a way that (objPtr->bytes) never becomes
+ * NULL. This panic was added in Tcl 8.1.
+ */
+
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
- (*objPtr->typePtr->updateStringProc)(objPtr);
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes == NULL || objPtr->length < 0
+ || objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep", objPtr->typePtr->name);
+ }
return objPtr->bytes;
}
@@ -1619,13 +1672,7 @@ Tcl_GetStringFromObj(
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
- if (objPtr->bytes == NULL) {
- if (objPtr->typePtr->updateStringProc == NULL) {
- Tcl_Panic("UpdateStringProc should not be invoked for type %s",
- objPtr->typePtr->name);
- }
- (*objPtr->typePtr->updateStringProc)(objPtr);
- }
+ (void) TclGetString(objPtr);
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
@@ -1658,7 +1705,6 @@ Tcl_InvalidateStringRep(
{
TclInvalidateStringRep(objPtr);
}
-
/*
*----------------------------------------------------------------------
@@ -1737,7 +1783,7 @@ Tcl_NewBooleanObj(
Tcl_Obj *
Tcl_DbNewBooleanObj(
register int boolValue, /* Boolean used to initialize new object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -1757,7 +1803,7 @@ Tcl_DbNewBooleanObj(
Tcl_Obj *
Tcl_DbNewBooleanObj(
register int boolValue, /* Boolean used to initialize new object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -1817,7 +1863,7 @@ Tcl_SetBooleanObj(
int
Tcl_GetBooleanFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object from which to get boolean. */
register int *boolPtr) /* Place to store resulting boolean. */
{
@@ -1839,7 +1885,7 @@ Tcl_GetBooleanFromObj(
* sets the proper error message for us.
*/
- double d;
+ double d;
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
@@ -1924,13 +1970,14 @@ SetBooleanFromAny(
badBoolean:
if (interp != NULL) {
int length;
- char *str = Tcl_GetStringFromObj(objPtr, &length);
+ const char *str = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
Tcl_AppendLimitedToObj(msg, str, length, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL);
}
return TCL_ERROR;
}
@@ -1940,10 +1987,14 @@ ParseBoolean(
register Tcl_Obj *objPtr) /* The object to parse/convert. */
{
int i, length, newBool;
- char lowerCase[6], *str = TclGetStringFromObj(objPtr, &length);
+ char lowerCase[6];
+ const char *str = TclGetStringFromObj(objPtr, &length);
if ((length == 0) || (length > 5)) {
- /* longest valid boolean string rep. is "false" */
+ /*
+ * Longest valid boolean string rep. is "false".
+ */
+
return TCL_ERROR;
}
@@ -1969,6 +2020,7 @@ ParseBoolean(
for (i=0; i < length; i++) {
char c = str[i];
+
switch (c) {
case 'A': case 'E': case 'F': case 'L': case 'N':
case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y':
@@ -2122,7 +2174,7 @@ Tcl_NewDoubleObj(
Tcl_Obj *
Tcl_DbNewDoubleObj(
register double dblValue, /* Double used to initialize the object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2142,7 +2194,7 @@ Tcl_DbNewDoubleObj(
Tcl_Obj *
Tcl_DbNewDoubleObj(
register double dblValue, /* Double used to initialize the object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2203,7 +2255,7 @@ Tcl_SetDoubleObj(
int
Tcl_GetDoubleFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object from which to get a double. */
register double *dblPtr) /* Place to store resulting double. */
{
@@ -2213,6 +2265,8 @@ Tcl_GetDoubleFromObj(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
+ NULL);
}
return TCL_ERROR;
}
@@ -2225,8 +2279,9 @@ Tcl_GetDoubleFromObj(
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
- UNPACK_BIGNUM( objPtr, big );
- *dblPtr = TclBignumToDouble( &big );
+
+ UNPACK_BIGNUM(objPtr, big);
+ *dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
#ifndef NO_WIDE_TYPE
@@ -2299,8 +2354,8 @@ UpdateStringOfDouble(
Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer);
len = strlen(buffer);
- objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
- strcpy(objPtr->bytes, buffer);
+ objPtr->bytes = ckalloc(len + 1);
+ memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
objPtr->length = len;
}
@@ -2415,7 +2470,7 @@ Tcl_SetIntObj(
int
Tcl_GetIntFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object from which to get a int. */
register int *intPtr) /* Place to store resulting int. */
{
@@ -2429,7 +2484,7 @@ Tcl_GetIntFromObj(
}
if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) {
if (interp != NULL) {
- CONST char *s =
+ const char *s =
"integer value too large to represent as non-long integer";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
@@ -2463,6 +2518,7 @@ SetIntFromAny(
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
long l;
+
return TclGetLongFromObj(interp, objPtr, &l);
}
@@ -2494,8 +2550,8 @@ UpdateStringOfInt(
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
- objPtr->bytes = ckalloc((unsigned) len + 1);
- strcpy(objPtr->bytes, buffer);
+ objPtr->bytes = ckalloc(len + 1);
+ memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
objPtr->length = len;
}
@@ -2592,7 +2648,7 @@ Tcl_Obj *
Tcl_DbNewLongObj(
register long longValue, /* Long integer used to initialize the new
* object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2613,7 +2669,7 @@ Tcl_Obj *
Tcl_DbNewLongObj(
register long longValue, /* Long integer used to initialize the new
* object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2676,7 +2732,7 @@ Tcl_SetLongObj(
int
Tcl_GetLongFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object from which to get a long. */
register long *longPtr) /* Place to store resulting long. */
{
@@ -2696,6 +2752,7 @@ Tcl_GetLongFromObj(
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
+
if (w >= -(Tcl_WideInt)(ULONG_MAX)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = Tcl_WideAsLong(w);
@@ -2704,18 +2761,16 @@ Tcl_GetLongFromObj(
goto tooLarge;
}
#endif
- if (objPtr->typePtr == &tclDoubleType) {
- if (interp != NULL) {
- Tcl_Obj *msg;
-
- TclNewLiteralStringObj(msg, "expected integer but got \"");
- Tcl_AppendObjToObj(msg, objPtr);
- Tcl_AppendToObj(msg, "\"", -1);
- Tcl_SetObjResult(interp, msg);
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer but got \"%s\"",
+ Tcl_GetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
- if (objPtr->typePtr == &tclBignumType) {
+ if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a long, even
* when auto-narrowing is enabled. Only those values in the signed
@@ -2726,11 +2781,12 @@ Tcl_GetLongFromObj(
mp_int big;
UNPACK_BIGNUM(objPtr, big);
- if ((size_t)(big.used) <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
+ if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
/ DIGIT_BIT) {
unsigned long value = 0, numBytes = sizeof(long);
long scratch;
- unsigned char *bytes = (unsigned char *)&scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
@@ -2747,7 +2803,7 @@ Tcl_GetLongFromObj(
tooLarge:
#endif
if (interp != NULL) {
- char *s = "integer value too large to represent";
+ const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
@@ -2797,7 +2853,7 @@ UpdateStringOfWideInt(
sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
len = strlen(buffer);
- objPtr->bytes = ckalloc((unsigned) len + 1);
+ objPtr->bytes = ckalloc(len + 1);
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
@@ -2895,7 +2951,7 @@ Tcl_DbNewWideIntObj(
register Tcl_WideInt wideValue,
/* Wide integer used to initialize the new
* object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2914,7 +2970,7 @@ Tcl_DbNewWideIntObj(
register Tcl_WideInt wideValue,
/* Long integer used to initialize the new
* object. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -2990,7 +3046,7 @@ Tcl_SetWideIntObj(
int
Tcl_GetWideIntFromObj(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* Object from which to get a wide int. */
register Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
@@ -3006,18 +3062,16 @@ Tcl_GetWideIntFromObj(
*wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclDoubleType) {
- if (interp != NULL) {
- Tcl_Obj *msg;
-
- TclNewLiteralStringObj(msg, "expected integer but got \"");
- Tcl_AppendObjToObj(msg, objPtr);
- Tcl_AppendToObj(msg, "\"", -1);
- Tcl_SetObjResult(interp, msg);
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer but got \"%s\"",
+ Tcl_GetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
- if (objPtr->typePtr == &tclBignumType) {
+ if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideInt, even when auto-narrowing is enabled.
@@ -3026,7 +3080,7 @@ Tcl_GetWideIntFromObj(
mp_int big;
UNPACK_BIGNUM(objPtr, big);
- if ((size_t)(big.used) <= (CHAR_BIT * sizeof(Tcl_WideInt)
+ if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt)
+ DIGIT_BIT - 1) / DIGIT_BIT) {
Tcl_WideUInt value = 0;
unsigned long numBytes = sizeof(Tcl_WideInt);
@@ -3046,8 +3100,8 @@ Tcl_GetWideIntFromObj(
}
}
if (interp != NULL) {
- char *s = "integer value too large to represent";
- Tcl_Obj* msg = Tcl_NewStringObj(s, -1);
+ const char *s = "integer value too large to represent";
+ Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
@@ -3107,9 +3161,10 @@ FreeBignum(
UNPACK_BIGNUM(objPtr, toFree);
mp_clear(&toFree);
- if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) {
- ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr);
+ if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) {
+ ckfree(objPtr->internalRep.ptrAndLongRep.ptr);
}
+ objPtr->typePtr = NULL;
}
/*
@@ -3171,7 +3226,7 @@ UpdateStringOfBignum(
mp_int bignumVal;
int size;
int status;
- char* stringVal;
+ char *stringVal;
UNPACK_BIGNUM(objPtr, bignumVal);
status = mp_radix_size(&bignumVal, 10, &size);
@@ -3192,13 +3247,13 @@ UpdateStringOfBignum(
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
- stringVal = ckalloc((size_t) size);
+ stringVal = ckalloc(size);
status = mp_toradix_n(&bignumVal, stringVal, 10, size);
if (status != MP_OKAY) {
Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
objPtr->bytes = stringVal;
- objPtr->length = size - 1; /* size includes a trailing null byte */
+ objPtr->length = size - 1; /* size includes a trailing NUL byte. */
}
/*
@@ -3231,7 +3286,7 @@ Tcl_Obj *
Tcl_NewBignumObj(
mp_int *bignumValue)
{
- Tcl_Obj* objPtr;
+ Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetBignumObj(objPtr, bignumValue);
@@ -3261,7 +3316,7 @@ Tcl_NewBignumObj(
Tcl_Obj *
Tcl_DbNewBignumObj(
mp_int *bignumValue,
- CONST char *file,
+ const char *file,
int line)
{
Tcl_Obj *objPtr;
@@ -3274,7 +3329,7 @@ Tcl_DbNewBignumObj(
Tcl_Obj *
Tcl_DbNewBignumObj(
mp_int *bignumValue,
- CONST char *file,
+ const char *file,
int line)
{
return Tcl_NewBignumObj(bignumValue);
@@ -3313,6 +3368,7 @@ GetBignumFromObj(
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
+
UNPACK_BIGNUM(objPtr, temp);
mp_init_copy(bignumValue, &temp);
} else {
@@ -3339,12 +3395,10 @@ GetBignumFromObj(
#endif
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
- Tcl_Obj *msg;
-
- TclNewLiteralStringObj(msg, "expected integer but got \"");
- Tcl_AppendObjToObj(msg, objPtr);
- Tcl_AppendToObj(msg, "\"", -1);
- Tcl_SetObjResult(interp, msg);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer but got \"%s\"",
+ Tcl_GetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
@@ -3447,11 +3501,12 @@ Tcl_SetBignumObj(
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
}
- if ((size_t)(bignumValue->used)
+ if ((size_t) bignumValue->used
<= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) {
unsigned long value = 0, numBytes = sizeof(long);
long scratch;
- unsigned char *bytes = (unsigned char *)&scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
goto tooLargeForLong;
}
@@ -3471,12 +3526,13 @@ Tcl_SetBignumObj(
}
tooLargeForLong:
#ifndef NO_WIDE_TYPE
- if ((size_t)(bignumValue->used)
+ if ((size_t) bignumValue->used
<= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
Tcl_WideUInt value = 0;
unsigned long numBytes = sizeof(Tcl_WideInt);
Tcl_WideInt scratch;
unsigned char *bytes = (unsigned char *)&scratch;
+
if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
goto tooLargeForWide;
}
@@ -3501,6 +3557,24 @@ Tcl_SetBignumObj(
TclSetBignumIntRep(objPtr, bignumValue);
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetBignumIntRep --
+ *
+ * Install a bignum into the internal representation of an object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Object internal representation is updated and object type is set. The
+ * bignum value is cleared, since ownership has transferred to the
+ * object.
+ *
+ *----------------------------------------------------------------------
+ */
+
void
TclSetBignumIntRep(
Tcl_Obj *objPtr,
@@ -3511,8 +3585,9 @@ TclSetBignumIntRep(
/*
* Clear the mp_int value.
- * Don't call mp_clear() because it would free the digit array
- * we just packed into the Tcl_Obj.
+ *
+ * Don't call mp_clear() because it would free the digit array we just
+ * packed into the Tcl_Obj.
*/
bignumValue->dp = NULL;
@@ -3525,14 +3600,23 @@ TclSetBignumIntRep(
*
* TclGetNumberFromObj --
*
+ * Extracts a number (of any possible numeric type) from an object.
+ *
* Results:
+ * Whether the extraction worked. The type is stored in the variable
+ * referred to by the typePtr argument, and a pointer to the
+ * representation is stored in the variable referred to by the
+ * clientDataPtr.
*
* Side effects:
+ * Can allocate thread-specific data for handling the copy-out space for
+ * bignums; this space is shared within a thread.
*
*----------------------------------------------------------------------
*/
-int TclGetNumberFromObj(
+int
+TclGetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
ClientData *clientDataPtr,
@@ -3545,18 +3629,18 @@ int TclGetNumberFromObj(
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
- *clientDataPtr = &(objPtr->internalRep.doubleValue);
+ *clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_LONG;
- *clientDataPtr = &(objPtr->internalRep.longValue);
+ *clientDataPtr = &objPtr->internalRep.longValue;
return TCL_OK;
}
#ifndef NO_WIDE_TYPE
if (objPtr->typePtr == &tclWideIntType) {
*typePtr = TCL_NUMBER_WIDE;
- *clientDataPtr = &(objPtr->internalRep.wideValue);
+ *clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
#endif
@@ -3564,7 +3648,8 @@ int TclGetNumberFromObj(
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = Tcl_GetThreadData(&bignumKey,
(int) sizeof(mp_int));
- UNPACK_BIGNUM( objPtr, *bigPtr );
+
+ UNPACK_BIGNUM(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
@@ -3599,7 +3684,7 @@ void
Tcl_DbIncrRefCount(
register Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -3619,23 +3704,21 @@ Tcl_DbIncrRefCount(
*/
if (!TclInExit()) {
- Tcl_HashTable *tablePtr;
- Tcl_HashEntry *hPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
+ Tcl_HashEntry *hPtr;
- tablePtr = tsdPtr->objThreadMap;
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
- hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
- Tcl_Panic("%s%s",
- "Trying to incr ref count of "
- "Tcl_Obj allocated in another thread");
+ Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
+ "incr ref count");
}
}
-# endif
-#endif
+# endif /* TCL_THREADS */
+#endif /* TCL_MEM_DEBUG */
++(objPtr)->refCount;
}
@@ -3664,7 +3747,7 @@ void
Tcl_DbDecrRefCount(
register Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -3684,19 +3767,17 @@ Tcl_DbDecrRefCount(
*/
if (!TclInExit()) {
- Tcl_HashTable *tablePtr;
- Tcl_HashEntry *hPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
+ Tcl_HashEntry *hPtr;
- tablePtr = tsdPtr->objThreadMap;
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
- hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
- Tcl_Panic("%s%s",
- "Trying to decr ref count of "
- "Tcl_Obj allocated in another thread");
+ Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
+ "decr ref count");
}
/*
@@ -3707,14 +3788,15 @@ Tcl_DbDecrRefCount(
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
- ckfree((char *) objData);
+ ckfree(objData);
}
Tcl_DeleteHashEntry(hPtr);
}
}
-# endif
-#endif
+# endif /* TCL_THREADS */
+#endif /* TCL_MEM_DEBUG */
+
if (--(objPtr)->refCount <= 0) {
TclFreeObj(objPtr);
}
@@ -3744,7 +3826,7 @@ Tcl_DbDecrRefCount(
int
Tcl_DbIsShared(
register Tcl_Obj *objPtr, /* The object to test for being shared. */
- CONST char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
@@ -3764,22 +3846,21 @@ Tcl_DbIsShared(
*/
if (!TclInExit()) {
- Tcl_HashTable *tablePtr;
- Tcl_HashEntry *hPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- tablePtr = tsdPtr->objThreadMap;
+ Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
+ Tcl_HashEntry *hPtr;
+
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
- hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
- Tcl_Panic("%s%s",
- "Trying to check shared status of"
- "Tcl_Obj allocated in another thread");
+ Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
+ "check shared status");
}
}
-# endif
-#endif
+# endif /* TCL_THREADS */
+#endif /* TCL_MEM_DEBUG */
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
@@ -3791,7 +3872,7 @@ Tcl_DbIsShared(
tclObjsShared[0]++;
}
Tcl_MutexUnlock(&tclObjMutex);
-#endif
+#endif /* TCL_COMPILE_STATS */
return ((objPtr)->refCount > 1);
}
@@ -3845,11 +3926,10 @@ AllocObjEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
- Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
- Tcl_HashEntry *hPtr;
+ Tcl_Obj *objPtr = keyPtr;
+ Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry));
- hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
- hPtr->key.oneWordValue = (char *) objPtr;
+ hPtr->key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
hPtr->clientData = NULL;
@@ -3878,9 +3958,9 @@ TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
+ Tcl_Obj *objPtr1 = keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
- register CONST char *p1, *p2;
+ register const char *p1, *p2;
register int l1, l2;
/*
@@ -3942,7 +4022,7 @@ TclFreeObjEntry(
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
- ckfree((char *) hPtr);
+ ckfree(hPtr);
}
/*
@@ -3968,11 +4048,10 @@ TclHashObjKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
- Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
- CONST char *string = TclGetString(objPtr);
- int length = objPtr->length;
+ Tcl_Obj *objPtr = keyPtr;
+ int length;
+ const char *string = TclGetStringFromObj(objPtr, &length);
unsigned int result = 0;
- int i;
/*
* I tried a zillion different hash functions and asked many other people
@@ -3982,16 +4061,37 @@ TclHashObjKey(
* following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings, and
- * multiplying by 9 is just about as good.
+ * multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
- * character's bits hang around in the low-order bits of the hash value
- * for ever, plus they spread fairly rapidly up to the high-order bits
- * to fill out the hash value. This seems works well both for decimal
- * and *non-decimal strings.
+ * character's bits hang around in the low-order bits of the hash value
+ * for ever, plus they spread fairly rapidly up to the high-order bits
+ * to fill out the hash value. This seems works well both for decimal
+ * and non-decimal strings.
+ *
+ * Note that this function is very weak against malicious strings; it's
+ * very easy to generate multiple keys that have the same hashcode. On the
+ * other hand, that hardly ever actually occurs and this function *is*
+ * very cheap, even by comparison with industry-standard hashes like FNV.
+ * If real strength of hash is required though, use a custom hash based on
+ * Bob Jenkins's lookup3(), but be aware that it's significantly slower.
+ * Tcl does not use that level of strength because it typically does not
+ * need it (and some of the aspects of that strength are genuinely
+ * unnecessary given the rest of Tcl's hash machinery, and the fact that
+ * we do not either transfer hashes to another machine, use them as a true
+ * substitute for equality, or attempt to minimize work in rebuilding the
+ * hash table).
+ *
+ * See also HashStringKey in tclHash.c.
+ * See also HashString in tclLiteral.c.
+ *
+ * See [tcl-Feature Request #2958832]
*/
- for (i=0 ; i<length ; i++) {
- result += (result << 3) + string[i];
+ if (length > 0) {
+ result = UCHAR(*string);
+ while (--length) {
+ result += (result << 3) + UCHAR(*++string);
+ }
}
return result;
}
@@ -4026,9 +4126,6 @@ Tcl_GetCommandFromObj(
* global namespace. */
{
register ResolvedCmdName *resPtr;
- register Command *cmdPtr;
- Namespace *refNsPtr;
- int result;
/*
* Get the internal representation, converting to a command type if
@@ -4046,34 +4143,39 @@ Tcl_GetCommandFromObj(
* is not deleted.
*
* If any check fails, then force another conversion to the command type,
- * to discard the old rep and create a new one.
+ * to discard the old rep and create a new one.
*/
- resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr != &tclCmdNameType)
- || (resPtr == NULL)
- || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch)
- || (cmdPtr->flags & CMD_IS_DELETED)
- || (interp != cmdPtr->nsPtr->interp)
- || (cmdPtr->nsPtr->flags & NS_DYING)
- || ((resPtr->refNsPtr != NULL) &&
- (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp))
- != resPtr->refNsPtr)
- || (resPtr->refNsId != refNsPtr->nsId)
- || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch)))
- ) {
-
- result = tclCmdNameType.setFromAnyProc(interp, objPtr);
-
- resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
- if ((result == TCL_OK) && resPtr) {
- cmdPtr = resPtr->cmdPtr;
- } else {
- cmdPtr = NULL;
- }
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
+ register Command *cmdPtr = resPtr->cmdPtr;
+
+ if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
+ && !(cmdPtr->flags & CMD_IS_DELETED)
+ && (interp == cmdPtr->nsPtr->interp)
+ && !(cmdPtr->nsPtr->flags & NS_DYING)) {
+ register Namespace *refNsPtr = (Namespace *)
+ TclGetCurrentNamespace(interp);
+
+ if ((resPtr->refNsPtr == NULL)
+ || ((refNsPtr == resPtr->refNsPtr)
+ && (resPtr->refNsId == refNsPtr->nsId)
+ && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) {
+ return (Tcl_Command) cmdPtr;
+ }
+ }
}
-
- return (Tcl_Command) cmdPtr;
+
+ /*
+ * OK, must create a new internal representation (or fail) as any cache we
+ * had is invalid one way or another.
+ */
+
+ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
+ return NULL;
+ }
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}
/*
@@ -4091,7 +4193,7 @@ Tcl_GetCommandFromObj(
* The object's old internal rep is freed. It's string rep is not
* changed. The refcount in the Command structure is incremented to keep
* it from being freed if the command is later deleted until
- * TclExecuteByteCode has a chance to recognize that it was deleted.
+ * TclNRExecuteByteCode has a chance to recognize that it was deleted.
*
*----------------------------------------------------------------------
*/
@@ -4108,14 +4210,14 @@ TclSetCmdNameObj(
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
register Namespace *currNsPtr;
- char *name;
+ const char *name;
if (objPtr->typePtr == &tclCmdNameType) {
return;
}
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
@@ -4124,7 +4226,7 @@ TclSetCmdNameObj(
if ((*name++ == ':') && (*name == ':')) {
/*
* The name is fully qualified: set the referring namespace to
- * NULL.
+ * NULL.
*/
resPtr->refNsPtr = NULL;
@@ -4134,14 +4236,14 @@ TclSetCmdNameObj(
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
-
+
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
}
TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
@@ -4172,8 +4274,7 @@ FreeCmdNameInternalRep(
register Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
- register ResolvedCmdName *resPtr =
- (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
+ register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL) {
/*
@@ -4190,8 +4291,9 @@ FreeCmdNameInternalRep(
*/
Command *cmdPtr = resPtr->cmdPtr;
+
TclCleanupCommandMacro(cmdPtr);
- ckfree((char *) resPtr);
+ ckfree(resPtr);
}
}
objPtr->typePtr = NULL;
@@ -4222,10 +4324,9 @@ DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- register ResolvedCmdName *resPtr = (ResolvedCmdName *)
- srcPtr->internalRep.twoPtrValue.ptr1;
+ register ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
@@ -4260,7 +4361,7 @@ SetCmdNameFromAny(
register Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
- char *name;
+ const char *name;
register Command *cmdPtr;
Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
@@ -4278,7 +4379,8 @@ SetCmdNameFromAny(
*/
name = TclGetString(objPtr);
- cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
+ cmdPtr = (Command *)
+ Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
* Free the old internalRep before setting the new one. Do this after
@@ -4288,22 +4390,23 @@ SetCmdNameFromAny(
if (cmdPtr) {
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
+ resPtr = objPtr->internalRep.otherValuePtr;
if ((objPtr->typePtr == &tclCmdNameType)
&& resPtr && (resPtr->refCount == 1)) {
/*
* Reuse the old ResolvedCmdName struct instead of freeing it
*/
-
+
Command *oldCmdPtr = resPtr->cmdPtr;
+
if (--oldCmdPtr->refCount == 0) {
TclCleanupCommandMacro(oldCmdPtr);
}
} else {
TclFreeIntRep(objPtr);
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
@@ -4311,8 +4414,8 @@ SetCmdNameFromAny(
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
if ((*name++ == ':') && (*name == ':')) {
/*
- * The name is fully qualified: set the referring namespace to
- * NULL.
+ * The name is fully qualified: set the referring namespace to
+ * NULL.
*/
resPtr->refNsPtr = NULL;
@@ -4322,7 +4425,7 @@ SetCmdNameFromAny(
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
-
+
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
@@ -4337,9 +4440,75 @@ SetCmdNameFromAny(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RepresentationCmd --
+ *
+ * Implementation of the "tcl::unsupported::representation" command.
+ *
+ * Results:
+ * Reports the current representation (Tcl_Obj type) of its argument.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RepresentationCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ char ptrBuffer[2*TCL_INTEGER_SPACE+6];
+ Tcl_Obj *descObj;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "value");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Value is a bignum with a refcount of 14, object pointer at 0x12345678,
+ * internal representation 0x45671234:0x98765432, string representation
+ * "1872361827361287"
+ */
+
+ sprintf(ptrBuffer, "%p", (void *) objv[1]);
+ descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d,"
+ " object pointer at %s",
+ objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
+ objv[1]->refCount, ptrBuffer);
+
+ if (objv[1]->typePtr) {
+ sprintf(ptrBuffer, "%p:%p",
+ (void *) objv[1]->internalRep.twoPtrValue.ptr1,
+ (void *) objv[1]->internalRep.twoPtrValue.ptr2);
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %s",
+ ptrBuffer);
+ }
+
+ if (objv[1]->bytes) {
+ Tcl_AppendToObj(descObj, ", string representation \"", -1);
+ Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
+ 16, "...");
+ Tcl_AppendToObj(descObj, "\"", -1);
+ } else {
+ Tcl_AppendToObj(descObj, ", no string representation", -1);
+ }
+
+ Tcl_SetObjResult(interp, descObj);
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/