summaryrefslogtreecommitdiffstats
path: root/generic/tclObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclObj.c')
-rw-r--r--generic/tclObj.c1041
1 files changed, 589 insertions, 452 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c
index fb09a9e..930e1fd 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,28 @@ 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 TclThreadFinalizeContLines(ClientData clientData);
+static ThreadSpecificData *TclGetContLineTable(void);
/*
* Nested Tcl_Obj deletion management support
@@ -153,11 +147,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 +160,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 +177,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; \
}
@@ -209,12 +207,11 @@ static Tcl_ThreadDataKey pendingObjDataKey;
*/
static int ParseBoolean(Tcl_Obj *objPtr);
-static int SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
#endif
@@ -246,56 +243,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 */
+ TclSetBooleanFromAny /* 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 */
+ TclSetBooleanFromAny /* 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 */
+#ifndef TCL_WIDE_INT_IS_LONG
+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 +314,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 */
};
/*
@@ -404,7 +409,7 @@ TclInitObjSubsystem(void)
/* For backward compatibility only ... */
Tcl_RegisterObjType(&oldBooleanType);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_RegisterObjType(&tclWideIntType);
#endif
@@ -414,6 +419,7 @@ TclInitObjSubsystem(void)
tclObjsFreed = 0;
{
int i;
+
for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) {
tclObjsShared[i] = 0;
}
@@ -454,12 +460,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 +527,8 @@ TclFinalizeObjects(void)
*----------------------------------------------------------------------
*/
-static ThreadSpecificData*
-TclGetContLineTable()
+static ThreadSpecificData *
+TclGetContLineTable(void)
{
/*
* Initialize the hashtable tracking invisible continuation lines. For
@@ -533,10 +539,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 +566,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 +595,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 +631,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 +659,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 +675,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 +709,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 +724,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 +748,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 +758,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 +791,8 @@ TclContinuationsGet(Tcl_Obj* objPtr)
*/
static void
-TclThreadFinalizeContLines (ClientData clientData)
+TclThreadFinalizeContLines(
+ ClientData clientData)
{
/*
* Release the hashtable tracking invisible continuation lines.
@@ -793,46 +803,16 @@ TclThreadFinalizeContLines (ClientData clientData)
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &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);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
+ ckfree(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
}
- Tcl_DeleteHashTable (tsdPtr->lineCLPtr);
- ckfree((char *) tsdPtr->lineCLPtr);
+ Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
+ ckfree(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
/*
- *----------------------------------------------------------------------
- *
- * ContLineLocFree --
- *
- * The freProc for continuation line location tables.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Releases memory.
- *
- * TIP #280
- *----------------------------------------------------------------------
- */
-
-static void
-ContLineLocFree (char* clientData)
-{
- ckfree (clientData);
-}
-
-/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
@@ -853,7 +833,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 +920,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 +960,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;
@@ -1075,7 +1055,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. */
@@ -1099,12 +1079,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");
}
@@ -1113,7 +1092,7 @@ TclDbInitNewObj(
* Record the debugging information.
*/
- objData = (ObjData *) ckalloc(sizeof(ObjData));
+ objData = ckalloc(sizeof(ObjData));
objData->objPtr = objPtr;
objData->file = file;
objData->line = line;
@@ -1205,7 +1184,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. */
@@ -1223,7 +1202,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. */
@@ -1272,12 +1251,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.twoPtrValue.ptr1 = (void *) prevPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = prevPtr;
prevPtr = objPtr;
objPtr++;
}
@@ -1314,7 +1293,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...
@@ -1329,7 +1308,7 @@ TclFreeObj(
* and so on, is always a sign of a botch in the caller.
*/
if (objPtr->refCount < -1) {
- Tcl_Panic("Reference count for %lx was negative", objPtr);
+ Tcl_Panic("Reference count for %p was negative", objPtr);
}
/*
* Now, in case we just approved drop from 1 to 0 as acceptable, make
@@ -1338,10 +1317,12 @@ TclFreeObj(
*/
objPtr->refCount = -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' */
-
+ /*
+ * 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;
@@ -1356,19 +1337,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();
}
@@ -1377,22 +1358,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);
+ ckfree(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
}
}
}
@@ -1403,13 +1385,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
@@ -1449,7 +1433,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)) {
@@ -1464,27 +1449,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);
+ ckfree(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
}
}
}
}
-#endif
+#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
@@ -1510,7 +1496,6 @@ TclObjBeingDeleted(
{
return (objPtr->length == -1);
}
-
/*
*----------------------------------------------------------------------
@@ -1541,30 +1526,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);
}
/*
@@ -1597,11 +1599,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;
}
@@ -1636,13 +1656,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;
@@ -1675,7 +1689,6 @@ Tcl_InvalidateStringRep(
{
TclInvalidateStringRep(objPtr);
}
-
/*
*----------------------------------------------------------------------
@@ -1707,7 +1720,7 @@ Tcl_Obj *
Tcl_NewBooleanObj(
register int boolValue) /* Boolean used to initialize new object. */
{
- return Tcl_DbNewLongObj(boolValue!=0, "unknown", 0);
+ return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -1718,7 +1731,7 @@ Tcl_NewBooleanObj(
{
register Tcl_Obj *objPtr;
- TclNewIntObj(objPtr, boolValue!=0);
+ TclNewBooleanObj(objPtr, boolValue);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1755,7 +1768,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. */
@@ -1775,7 +1788,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. */
@@ -1812,7 +1825,7 @@ Tcl_SetBooleanObj(
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
- TclSetIntObj(objPtr, boolValue!=0);
+ TclSetBooleanObj(objPtr, boolValue);
}
/*
@@ -1836,7 +1849,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. */
{
@@ -1858,7 +1871,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;
@@ -1870,7 +1883,7 @@ Tcl_GetBooleanFromObj(
*boolPtr = 1;
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*boolPtr = (objPtr->internalRep.wideValue != 0);
return TCL_OK;
@@ -1884,7 +1897,7 @@ Tcl_GetBooleanFromObj(
/*
*----------------------------------------------------------------------
*
- * SetBooleanFromAny --
+ * TclSetBooleanFromAny --
*
* Attempt to generate a boolean internal form for the Tcl object
* "objPtr".
@@ -1901,8 +1914,8 @@ Tcl_GetBooleanFromObj(
*----------------------------------------------------------------------
*/
-static int
-SetBooleanFromAny(
+int
+TclSetBooleanFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
@@ -1925,7 +1938,7 @@ SetBooleanFromAny(
goto badBoolean;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
goto badBoolean;
}
@@ -1943,13 +1956,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;
}
@@ -1959,10 +1973,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;
}
@@ -1988,6 +2006,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':
@@ -2141,7 +2160,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. */
@@ -2161,7 +2180,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. */
@@ -2222,7 +2241,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. */
{
@@ -2232,6 +2251,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;
}
@@ -2244,11 +2265,12 @@ 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
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
@@ -2318,8 +2340,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;
}
@@ -2353,8 +2375,8 @@ UpdateStringOfDouble(
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
#undef Tcl_NewIntObj
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewIntObj(
@@ -2394,6 +2416,7 @@ Tcl_NewIntObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
@@ -2434,7 +2457,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. */
{
@@ -2448,7 +2471,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);
@@ -2482,6 +2505,7 @@ SetIntFromAny(
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
long l;
+
return TclGetLongFromObj(interp, objPtr, &l);
}
@@ -2513,8 +2537,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;
}
@@ -2611,7 +2635,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. */
@@ -2632,7 +2656,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. */
@@ -2695,7 +2719,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. */
{
@@ -2704,7 +2728,7 @@ Tcl_GetLongFromObj(
*longPtr = objPtr->internalRep.longValue;
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
/*
* We return any integer in the range -ULONG_MAX to ULONG_MAX
@@ -2715,6 +2739,7 @@ Tcl_GetLongFromObj(
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
+
if (w >= -(Tcl_WideInt)(ULONG_MAX)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = Tcl_WideAsLong(w);
@@ -2723,18 +2748,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
@@ -2745,11 +2768,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++;
@@ -2762,11 +2786,11 @@ Tcl_GetLongFromObj(
return TCL_OK;
}
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
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);
@@ -2778,7 +2802,7 @@ Tcl_GetLongFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
@@ -2816,11 +2840,11 @@ 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;
}
-#endif /* !NO_WIDE_TYPE */
+#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -2914,7 +2938,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. */
@@ -2933,7 +2957,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. */
@@ -2975,7 +2999,7 @@ Tcl_SetWideIntObj(
&& (wideValue <= (Tcl_WideInt) LONG_MAX)) {
TclSetLongObj(objPtr, (long) wideValue);
} else {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
TclSetWideIntObj(objPtr, wideValue);
#else
mp_int big;
@@ -3009,13 +3033,13 @@ 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. */
{
do {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
@@ -3025,18 +3049,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.
@@ -3045,7 +3067,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);
@@ -3065,8 +3087,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);
@@ -3077,7 +3099,7 @@ Tcl_GetWideIntFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
@@ -3103,7 +3125,7 @@ SetWideIntFromAny(
Tcl_WideInt w;
return Tcl_GetWideIntFromObj(interp, objPtr, &w);
}
-#endif /* !NO_WIDE_TYPE */
+#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -3126,9 +3148,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;
}
/*
@@ -3190,7 +3213,7 @@ UpdateStringOfBignum(
mp_int bignumVal;
int size;
int status;
- char* stringVal;
+ char *stringVal;
UNPACK_BIGNUM(objPtr, bignumVal);
status = mp_radix_size(&bignumVal, 10, &size);
@@ -3211,13 +3234,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. */
}
/*
@@ -3250,7 +3273,7 @@ Tcl_Obj *
Tcl_NewBignumObj(
mp_int *bignumValue)
{
- Tcl_Obj* objPtr;
+ Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetBignumObj(objPtr, bignumValue);
@@ -3280,7 +3303,7 @@ Tcl_NewBignumObj(
Tcl_Obj *
Tcl_DbNewBignumObj(
mp_int *bignumValue,
- CONST char *file,
+ const char *file,
int line)
{
Tcl_Obj *objPtr;
@@ -3293,7 +3316,7 @@ Tcl_DbNewBignumObj(
Tcl_Obj *
Tcl_DbNewBignumObj(
mp_int *bignumValue,
- CONST char *file,
+ const char *file,
int line)
{
return Tcl_NewBignumObj(bignumValue);
@@ -3332,6 +3355,7 @@ GetBignumFromObj(
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
+
UNPACK_BIGNUM(objPtr, temp);
mp_init_copy(bignumValue, &temp);
} else {
@@ -3349,7 +3373,7 @@ GetBignumFromObj(
TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
TclBNInitBignumFromWideInt(bignumValue,
objPtr->internalRep.wideValue);
@@ -3358,12 +3382,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;
}
@@ -3466,11 +3488,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;
}
@@ -3489,13 +3512,14 @@ Tcl_SetBignumObj(
return;
}
tooLargeForLong:
-#ifndef NO_WIDE_TYPE
- if ((size_t)(bignumValue->used)
+#ifndef TCL_WIDE_INT_IS_LONG
+ 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;
}
@@ -3520,6 +3544,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,
@@ -3530,8 +3572,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;
@@ -3544,14 +3587,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,
@@ -3564,18 +3616,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
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*typePtr = TCL_NUMBER_WIDE;
- *clientDataPtr = &(objPtr->internalRep.wideValue);
+ *clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
#endif
@@ -3583,7 +3635,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;
@@ -3618,7 +3671,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. */
@@ -3638,23 +3691,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;
}
@@ -3683,7 +3734,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. */
@@ -3703,19 +3754,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");
}
/*
@@ -3726,14 +3775,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);
}
@@ -3763,7 +3813,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. */
@@ -3783,22 +3833,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);
@@ -3810,7 +3859,7 @@ Tcl_DbIsShared(
tclObjsShared[0]++;
}
Tcl_MutexUnlock(&tclObjMutex);
-#endif
+#endif /* TCL_COMPILE_STATS */
return ((objPtr)->refCount > 1);
}
@@ -3864,11 +3913,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;
@@ -3897,9 +3945,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;
/*
@@ -3961,7 +4009,7 @@ TclFreeObjEntry(
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
- ckfree((char *) hPtr);
+ ckfree(hPtr);
}
/*
@@ -3987,11 +4035,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
@@ -4001,16 +4048,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;
}
@@ -4045,9 +4113,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
@@ -4065,34 +4130,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 (SetCmdNameFromAny(interp, objPtr) != TCL_OK) {
+ return NULL;
+ }
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}
/*
@@ -4110,7 +4180,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.
*
*----------------------------------------------------------------------
*/
@@ -4127,14 +4197,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;
@@ -4143,7 +4213,7 @@ TclSetCmdNameObj(
if ((*name++ == ':') && (*name == ':')) {
/*
* The name is fully qualified: set the referring namespace to
- * NULL.
+ * NULL.
*/
resPtr->refNsPtr = NULL;
@@ -4153,14 +4223,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;
}
@@ -4191,8 +4261,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) {
/*
@@ -4209,8 +4278,9 @@ FreeCmdNameInternalRep(
*/
Command *cmdPtr = resPtr->cmdPtr;
+
TclCleanupCommandMacro(cmdPtr);
- ckfree((char *) resPtr);
+ ckfree(resPtr);
}
}
objPtr->typePtr = NULL;
@@ -4241,10 +4311,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++;
@@ -4279,7 +4348,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;
@@ -4297,7 +4366,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
@@ -4307,22 +4377,23 @@ SetCmdNameFromAny(
if (cmdPtr) {
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
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;
}
@@ -4330,8 +4401,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;
@@ -4341,7 +4412,7 @@ SetCmdNameFromAny(
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
-
+
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
@@ -4356,9 +4427,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:
*/