summaryrefslogtreecommitdiffstats
path: root/generic/tclObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclObj.c')
-rw-r--r--generic/tclObj.c262
1 files changed, 126 insertions, 136 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 15ea91f..f4b81f2 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -49,7 +49,6 @@ Tcl_Mutex tclObjMutex;
*/
char tclEmptyString = '\0';
-char *tclEmptyStringRep = &tclEmptyString;
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
@@ -76,7 +75,7 @@ typedef struct ObjData {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
* generated by a call to the function
* TclSubstTokens() from a literal text
@@ -320,7 +319,7 @@ const Tcl_HashKeyType tclObjHashKeyType = {
* 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]
+ * writable memory. [Bug 2558422] [Bug 07d13d99b0a9]
* TODO: Provide a better API for those extensions so that they can coexist...
*/
@@ -345,23 +344,23 @@ typedef struct ResolvedCmdName {
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
- long refNsId; /* refNsPtr's unique namespace id. Used to
+ size_t refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid (e.g.,
* it's possible that the cmd's containing
* namespace was deleted and a new one created
* at the same address). */
- int refNsCmdEpoch; /* Value of the referencing namespace's
+ size_t refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
- int cmdEpoch; /* Value of the command's cmdEpoch when this
+ size_t cmdEpoch; /* Value of the command's cmdEpoch when this
* pointer was cached. Before using the cached
* pointer, we check if the cmd's epoch was
* incremented; if so, the cmd was renamed,
* deleted, hidden, or exposed, and so the
* pointer is invalid. */
- int refCount; /* Reference count: 1 for each cmdName object
+ size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -402,7 +401,6 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
- Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
@@ -663,7 +661,7 @@ TclContinuationsEnterDerived(
* better way which doesn't shimmer?)
*/
- Tcl_GetStringFromObj(objPtr, &length);
+ TclGetStringFromObj(objPtr, &length);
end = start + length; /* First char after the word */
/*
@@ -1061,7 +1059,7 @@ TclDbInitNewObj(
* debugging. */
{
objPtr->refCount = 0;
- objPtr->bytes = tclEmptyStringRep;
+ objPtr->bytes = &tclEmptyString;
objPtr->length = 0;
objPtr->typePtr = NULL;
@@ -1734,7 +1732,7 @@ Tcl_InvalidateStringRep(
* is coerced to 1.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
- * of calling the debugging version Tcl_DbNewBooleanObj.
+ * of calling the debugging version Tcl_DbNewLongObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
@@ -1753,7 +1751,7 @@ Tcl_Obj *
Tcl_NewBooleanObj(
register int boolValue) /* Boolean used to initialize new object. */
{
- return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
+ return Tcl_DbNewLongObj(boolValue!=0, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -1764,7 +1762,7 @@ Tcl_NewBooleanObj(
{
register Tcl_Obj *objPtr;
- TclNewBooleanObj(objPtr, boolValue);
+ TclNewLongObj(objPtr, boolValue!=0);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1795,6 +1793,7 @@ Tcl_NewBooleanObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
@@ -1811,7 +1810,7 @@ Tcl_DbNewBooleanObj(
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = (boolValue? 1 : 0);
+ objPtr->internalRep.longValue = (boolValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -1858,8 +1857,9 @@ Tcl_SetBooleanObj(
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
- TclSetBooleanObj(objPtr, boolValue);
+ TclSetLongObj(objPtr, boolValue!=0);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1989,7 +1989,7 @@ TclSetBooleanFromAny(
badBoolean:
if (interp != NULL) {
int length;
- const char *str = Tcl_GetStringFromObj(objPtr, &length);
+ const char *str = TclGetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
@@ -2005,9 +2005,10 @@ static int
ParseBoolean(
register Tcl_Obj *objPtr) /* The object to parse/convert. */
{
- int i, length, newBool;
+ int newBool;
char lowerCase[6];
- const char *str = TclGetStringFromObj(objPtr, &length);
+ const char *str = TclGetString(objPtr);
+ size_t i, length = objPtr->length;
if ((length == 0) || (length > 5)) {
/*
@@ -2059,25 +2060,25 @@ ParseBoolean(
/*
* Checking the 'y' is redundant, but makes the code clearer.
*/
- if (strncmp(lowerCase, "yes", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "yes", length) == 0) {
newBool = 1;
goto goodBoolean;
}
return TCL_ERROR;
case 'n':
- if (strncmp(lowerCase, "no", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "no", length) == 0) {
newBool = 0;
goto goodBoolean;
}
return TCL_ERROR;
case 't':
- if (strncmp(lowerCase, "true", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "true", length) == 0) {
newBool = 1;
goto goodBoolean;
}
return TCL_ERROR;
case 'f':
- if (strncmp(lowerCase, "false", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "false", length) == 0) {
newBool = 0;
goto goodBoolean;
}
@@ -2086,10 +2087,10 @@ ParseBoolean(
if (length < 2) {
return TCL_ERROR;
}
- if (strncmp(lowerCase, "on", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "on", length) == 0) {
newBool = 1;
goto goodBoolean;
- } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
+ } else if (strncmp(lowerCase, "off", length) == 0) {
newBool = 0;
goto goodBoolean;
}
@@ -2426,7 +2427,7 @@ Tcl_NewIntObj(
{
register Tcl_Obj *objPtr;
- TclNewIntObj(objPtr, intValue);
+ TclNewLongObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2459,7 +2460,7 @@ Tcl_SetIntObj(
Tcl_Panic("%s called with shared object", "Tcl_SetIntObj");
}
- TclSetIntObj(objPtr, intValue);
+ TclSetLongObj(objPtr, intValue);
}
/*
@@ -2785,7 +2786,7 @@ Tcl_GetLongFromObj(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
- Tcl_GetString(objPtr)));
+ TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
@@ -3086,7 +3087,7 @@ Tcl_GetWideIntFromObj(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
- Tcl_GetString(objPtr)));
+ TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
@@ -3253,13 +3254,11 @@ UpdateStringOfBignum(
if (status != MP_OKAY) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
- if (size == 3) {
+ if (size < 2) {
/*
- * mp_radix_size() returns 3 when more than INT_MAX bytes would be
+ * mp_radix_size() returns < 2 when more than INT_MAX bytes would be
* needed to hold the string rep (because mp_radix_size ignores
- * integer overflow issues). When we know the string rep will be more
- * than 3, we can conclude the string rep would overflow our string
- * length limits.
+ * integer overflow issues).
*
* Note that so long as we enforce our bignums to the size that fits
* in a packed bignum, this branch will never be taken.
@@ -3397,7 +3396,7 @@ GetBignumFromObj(
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
if (objPtr->bytes == NULL) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, &tclEmptyString, 0);
}
}
return TCL_OK;
@@ -3417,7 +3416,7 @@ GetBignumFromObj(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
- Tcl_GetString(objPtr)));
+ TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
@@ -3967,15 +3966,15 @@ TclCompareObjKeys(
Tcl_Obj *objPtr1 = keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
register const char *p1, *p2;
- register int l1, l2;
+ register size_t l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
-
+
if (objPtr1 == objPtr2) return 1;
*/
-
+
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
* in a register.
@@ -4048,7 +4047,7 @@ TclFreeObjEntry(
*----------------------------------------------------------------------
*/
-unsigned int
+TCL_HASH_TYPE
TclHashObjKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
@@ -4098,7 +4097,7 @@ TclHashObjKey(
result += (result << 3) + UCHAR(*++string);
}
}
- return result;
+ return (TCL_HASH_TYPE) result;
}
/*
@@ -4152,11 +4151,10 @@ Tcl_GetCommandFromObj(
*/
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
+ if (objPtr->typePtr == &tclCmdNameType) {
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 *)
@@ -4176,7 +4174,8 @@ Tcl_GetCommandFromObj(
* had is invalid one way or another.
*/
- if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) {
+ /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
+ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
return NULL;
}
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
@@ -4203,54 +4202,78 @@ Tcl_GetCommandFromObj(
*----------------------------------------------------------------------
*/
-void
-TclSetCmdNameObj(
- Tcl_Interp *interp, /* Points to interpreter containing command
- * that should be cached in objPtr. */
- register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
- * CmdName object. */
- Command *cmdPtr) /* Points to Command structure that the
- * CmdName object should refer to. */
+static void
+SetCmdNameObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Command *cmdPtr,
+ ResolvedCmdName *resPtr)
{
Interp *iPtr = (Interp *) interp;
- register ResolvedCmdName *resPtr;
- register Namespace *currNsPtr;
- const char *name;
+ ResolvedCmdName *fillPtr;
+ const char *name = TclGetString(objPtr);
- if (objPtr->typePtr == &tclCmdNameType) {
- return;
+ if (resPtr) {
+ fillPtr = resPtr;
+ } else {
+ fillPtr = ckalloc(sizeof(ResolvedCmdName));
+ fillPtr->refCount = 1;
}
+ fillPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
- resPtr = ckalloc(sizeof(ResolvedCmdName));
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
+ fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
- name = TclGetString(objPtr);
- if ((*name++ == ':') && (*name == ':')) {
+ /* NOTE: relying on NULL termination here. */
+ if ((name[0] == ':') && (name[1] == ':')) {
/*
- * The name is fully qualified: set the referring namespace to
- * NULL.
+ * Fully qualified names always resolve to same thing. No need
+ * to record resolution context information.
*/
- resPtr->refNsPtr = NULL;
+ fillPtr->refNsPtr = NULL;
+ fillPtr->refNsId = 0; /* Will not be read */
+ fillPtr->refNsCmdEpoch = 0; /* Will not be read */
} else {
/*
- * Get the current namespace.
+ * Record current state of current namespace as the resolution
+ * context of this command name lookup.
*/
+ Namespace *currNsPtr = iPtr->varFramePtr->nsPtr;
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ fillPtr->refNsPtr = currNsPtr;
+ fillPtr->refNsId = currNsPtr->nsId;
+ fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ }
+
+ if (resPtr == NULL) {
+ TclFreeIntRep(objPtr);
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ objPtr->internalRep.twoPtrValue.ptr1 = fillPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
}
+}
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+void
+TclSetCmdNameObj(
+ Tcl_Interp *interp, /* Points to interpreter containing command
+ * that should be cached in objPtr. */
+ register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
+ * CmdName object. */
+ Command *cmdPtr) /* Points to Command structure that the
+ * CmdName object should refer to. */
+{
+ register ResolvedCmdName *resPtr;
+
+ if (objPtr->typePtr == &tclCmdNameType) {
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
+ return;
+ }
+ }
+
+ SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}
/*
@@ -4281,13 +4304,12 @@ FreeCmdNameInternalRep(
{
register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
*/
- if (resPtr->refCount-- == 1) {
+ if (resPtr->refCount-- <= 1) {
/*
* Now free the cached command, unless it is still in its hash
* table or if there are other references to it from other cmdName
@@ -4299,7 +4321,6 @@ FreeCmdNameInternalRep(
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
- }
objPtr->typePtr = NULL;
}
@@ -4332,9 +4353,7 @@ DupCmdNameInternalRep(
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- if (resPtr != NULL) {
resPtr->refCount++;
- }
copyPtr->typePtr = &tclCmdNameType;
}
@@ -4364,10 +4383,8 @@ SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
- Interp *iPtr = (Interp *) interp;
const char *name;
register Command *cmdPtr;
- Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
if (interp == NULL) {
@@ -4387,59 +4404,31 @@ SetCmdNameFromAny(
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
- * Free the old internalRep before setting the new one. Do this after
- * getting the string rep to allow the conversion code (in particular,
- * Tcl_GetStringFromObj) to use that old internalRep.
+ * Stop shimmering and caching nothing when we found nothing. Just
+ * report the failure to find the command as an error.
*/
- if (cmdPtr) {
- cmdPtr->refCount++;
- 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 = ckalloc(sizeof(ResolvedCmdName));
- resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
- }
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- if ((*name++ == ':') && (*name == ':')) {
- /*
- * The name is fully qualified: set the referring namespace to
- * NULL.
- */
+ if (cmdPtr == NULL) {
+ return TCL_ERROR;
+ }
- resPtr->refNsPtr = NULL;
- } else {
- /*
- * Get the current namespace.
- */
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
+ /*
+ * Re-use existing ResolvedCmdName struct when possible.
+ * Cleanup the old fields that need it.
+ */
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ Command *oldCmdPtr = resPtr->cmdPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ if (oldCmdPtr->refCount-- <= 1) {
+ TclCleanupCommandMacro(oldCmdPtr);
}
} else {
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = NULL;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+ resPtr = NULL;
}
+
+ SetCmdNameObj(interp, objPtr, cmdPtr, resPtr);
return TCL_OK;
}
@@ -4466,7 +4455,6 @@ Tcl_RepresentationCmd(
int objc,
Tcl_Obj *const objv[])
{
- char ptrBuffer[2*TCL_INTEGER_SPACE+6];
Tcl_Obj *descObj;
if (objc != 2) {
@@ -4480,18 +4468,20 @@ Tcl_RepresentationCmd(
* "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);
+ " object pointer at %p",
+ objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
+ objv[1]->refCount, objv[1]);
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]->typePtr == &tclDoubleType) {
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
+ objv[1]->internalRep.doubleValue);
+ } else {
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
+ (void *) objv[1]->internalRep.twoPtrValue.ptr1,
+ (void *) objv[1]->internalRep.twoPtrValue.ptr2);
+ }
}
if (objv[1]->bytes) {
generated by cgit v0.12 at 2024-11-21 14:13:10 (GMT)