summaryrefslogtreecommitdiffstats
path: root/generic/tclObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclObj.c')
-rw-r--r--generic/tclObj.c235
1 files changed, 126 insertions, 109 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 0aed0c2..74cb29e 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -12,8 +12,6 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclObj.c,v 1.175 2010/09/27 19:42:38 msofer Exp $
*/
#include "tclInt.h"
@@ -55,9 +53,9 @@ 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 {
@@ -81,7 +79,7 @@ typedef struct ObjData {
typedef struct ThreadSpecificData {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
* generated by a call to the function
- * EvalTokensStandard() from a literal text
+ * 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.
@@ -164,6 +162,10 @@ typedef struct PendingObjData {
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
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) \
@@ -460,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
@@ -541,7 +543,7 @@ TclGetContLineTable(void)
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);
}
@@ -576,8 +578,7 @@ TclContinuationsEnter(
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
- ContLineLoc *clLocPtr = (ContLineLoc *)
- ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
+ ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
if (!newEntry) {
/*
@@ -816,7 +817,7 @@ TclThreadFinalizeContLines(
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
- ckfree((char *) tsdPtr->lineCLPtr);
+ ckfree(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
@@ -1106,8 +1107,7 @@ 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;
@@ -1120,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;
@@ -1279,7 +1279,7 @@ 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;
@@ -1330,7 +1330,7 @@ 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);
}
/*
@@ -1353,7 +1353,7 @@ TclFreeObj(
}
Tcl_MutexLock(&tclObjMutex);
- ckfree((char *) objPtr);
+ ckfree(objPtr);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
ObjDeletionLock(context);
@@ -1365,7 +1365,7 @@ TclFreeObj(
TclFreeIntRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
- ckfree((char *) objToFree);
+ ckfree(objToFree);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
}
@@ -1486,7 +1486,7 @@ TclFreeObj(
}
}
}
-#endif
+#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
@@ -1512,7 +1512,6 @@ TclObjBeingDeleted(
{
return (objPtr->length == -1);
}
-
/*
*----------------------------------------------------------------------
@@ -1706,7 +1705,6 @@ Tcl_InvalidateStringRep(
{
TclInvalidateStringRep(objPtr);
}
-
/*
*----------------------------------------------------------------------
@@ -2267,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;
}
@@ -2354,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;
}
@@ -2550,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;
}
@@ -2763,12 +2763,9 @@ Tcl_GetLongFromObj(
#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;
@@ -2856,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;
}
@@ -3067,12 +3064,9 @@ Tcl_GetWideIntFromObj(
}
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;
@@ -3168,7 +3162,7 @@ FreeBignum(
UNPACK_BIGNUM(objPtr, toFree);
mp_clear(&toFree);
if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) {
- ckfree((char *) objPtr->internalRep.ptrAndLongRep.ptr);
+ ckfree(objPtr->internalRep.ptrAndLongRep.ptr);
}
objPtr->typePtr = NULL;
}
@@ -3253,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. */
}
/*
@@ -3401,12 +3395,9 @@ 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;
@@ -3566,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,
@@ -3576,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;
@@ -3590,9 +3600,17 @@ 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.
*
*----------------------------------------------------------------------
*/
@@ -3611,18 +3629,18 @@ 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
@@ -3686,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, 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;
}
@@ -3751,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, 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");
}
/*
@@ -3774,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);
}
@@ -3831,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, 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);
@@ -3858,7 +3872,7 @@ Tcl_DbIsShared(
tclObjsShared[0]++;
}
Tcl_MutexUnlock(&tclObjMutex);
-#endif
+#endif /* TCL_COMPILE_STATS */
return ((objPtr)->refCount > 1);
}
@@ -3912,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;
@@ -4009,7 +4022,7 @@ TclFreeObjEntry(
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
- ckfree((char *) hPtr);
+ ckfree(hPtr);
}
/*
@@ -4204,7 +4217,7 @@ TclSetCmdNameObj(
}
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
@@ -4280,7 +4293,7 @@ FreeCmdNameInternalRep(
Command *cmdPtr = resPtr->cmdPtr;
TclCleanupCommandMacro(cmdPtr);
- ckfree((char *) resPtr);
+ ckfree(resPtr);
}
}
objPtr->typePtr = NULL;
@@ -4353,6 +4366,10 @@ SetCmdNameFromAny(
Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
+ if (interp == NULL) {
+ return TCL_ERROR;
+ }
+
/*
* Find the Command structure, if any, that describes the command called
* "name". Build a ResolvedCmdName that holds a cached pointer to this
@@ -4373,7 +4390,7 @@ SetCmdNameFromAny(
if (cmdPtr) {
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
+ resPtr = objPtr->internalRep.otherValuePtr;
if ((objPtr->typePtr == &tclCmdNameType)
&& resPtr && (resPtr->refCount == 1)) {
/*
@@ -4387,7 +4404,7 @@ SetCmdNameFromAny(
}
} else {
TclFreeIntRep(objPtr);
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr = ckalloc(sizeof(ResolvedCmdName));
resPtr->refCount = 1;
objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
@@ -4445,11 +4462,8 @@ Tcl_RepresentationCmd(
int objc,
Tcl_Obj *const objv[])
{
- char refcountBuffer[TCL_INTEGER_SPACE+1];
- char objPtrBuffer[TCL_INTEGER_SPACE+3];
- char internalRepBuffer[2*(TCL_INTEGER_SPACE+2)+2];
-#define TCLOBJ_TRUNCATE_STRINGREP 16
- char stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP+1];
+ char ptrBuffer[2*TCL_INTEGER_SPACE+6];
+ Tcl_Obj *descObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
@@ -4462,27 +4476,30 @@ Tcl_RepresentationCmd(
* "1872361827361287"
*/
- sprintf(refcountBuffer, "%d", objv[1]->refCount);
- sprintf(objPtrBuffer, "%p", (void *)objv[1]);
- Tcl_AppendResult(interp, "value is a ", objv[1]->typePtr ?
- objv[1]->typePtr->name : "pure string", " with a refcount of ",
- refcountBuffer, ", object pointer at ", objPtrBuffer, NULL);
+ 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(internalRepBuffer, "%p:%p",
- (void *)objv[1]->internalRep.twoPtrValue.ptr1,
- (void *)objv[1]->internalRep.twoPtrValue.ptr2);
- Tcl_AppendResult(interp, ", internal representation ",
- internalRepBuffer, NULL);
+ 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) {
- strncpy(stringRepBuffer, objv[1]->bytes, TCLOBJ_TRUNCATE_STRINGREP);
- stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP] = 0;
- Tcl_AppendResult(interp, ", string representation \"",
- stringRepBuffer, objv[1]->length > TCLOBJ_TRUNCATE_STRINGREP ?
- "\"..." : "\".", NULL);
+ Tcl_AppendToObj(descObj, ", string representation \"", -1);
+ Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
+ 16, "...");
+ Tcl_AppendToObj(descObj, "\"", -1);
} else {
- Tcl_AppendResult(interp, ", no string representation.", NULL);
+ Tcl_AppendToObj(descObj, ", no string representation", -1);
}
+
+ Tcl_SetObjResult(interp, descObj);
return TCL_OK;
}
generated by cgit v0.12 at 2024-07-15 14:00:10 (GMT)