summaryrefslogtreecommitdiffstats
path: root/generic/tclVar.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclVar.c')
-rw-r--r--generic/tclVar.c281
1 files changed, 84 insertions, 197 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c
index af1a563..5574f30 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -215,9 +215,9 @@ static Tcl_SetFromAnyProc PanicOnSetVarName;
* Types of Tcl_Objs used to cache variable lookups.
*
* localVarName - INTERNALREP DEFINITION:
- * ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache
+ * twoPtrValue.ptr1: pointer to name obj in varFramePtr->localCache
* or NULL if it is this same obj
- * ptrAndLongRep.value: index into locals table
+ * twoPtrValue.ptr2: index into locals table
*
* nsVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1: pointer to the namespace containing the reference
@@ -235,25 +235,6 @@ static const Tcl_ObjType localVarNameType = {
FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName
};
-/*
- * Caching of namespace variables disabled: no simple way was found to avoid
- * interfering with the resolver's idea of variable existence. A cached
- * varName may keep a variable's name in the namespace's hash table, which is
- * the resolver's criterion for existence (see test namespace-17.10).
- */
-
-#define ENABLE_NS_VARNAME_CACHING 0
-
-#if ENABLE_NS_VARNAME_CACHING
-static Tcl_FreeInternalRepProc FreeNsVarName;
-static Tcl_DupInternalRepProc DupNsVarName;
-
-static const Tcl_ObjType tclNsVarNameType = {
- "namespaceVarName",
- FreeNsVarName, DupNsVarName, PanicOnUpdateVarName, PanicOnSetVarName
-};
-#endif
-
static const Tcl_ObjType tclParsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
@@ -554,32 +535,15 @@ TclObjLookupVarEx(
const Tcl_ObjType *typePtr = part1Ptr->typePtr;
const char *errMsg = NULL;
CallFrame *varFramePtr = iPtr->varFramePtr;
-#if ENABLE_NS_VARNAME_CACHING
- Namespace *nsPtr;
-#endif
const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
char *newPart2 = NULL;
-
*arrayPtrPtr = NULL;
-#if ENABLE_NS_VARNAME_CACHING
- if (varFramePtr) {
- nsPtr = varFramePtr->nsPtr;
- } else {
- /*
- * Some variables in the global ns have to be initialized before the
- * root call frame is in place.
- */
-
- nsPtr = NULL;
- }
-#endif
-
if (typePtr == &localVarNameType) {
int localIndex;
localVarNameTypeHandling:
- localIndex = (int) part1Ptr->internalRep.ptrAndLongRep.value;
+ localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2);
if (HasLocalVars(varFramePtr)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
@@ -587,7 +551,7 @@ TclObjLookupVarEx(
* Use the cached index if the names coincide.
*/
- Tcl_Obj *namePtr = part1Ptr->internalRep.ptrAndLongRep.ptr;
+ Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1;
Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex);
if ((!namePtr && (checkNamePtr == part1Ptr)) ||
@@ -597,44 +561,6 @@ TclObjLookupVarEx(
}
}
goto doneParsing;
-#if ENABLE_NS_VARNAME_CACHING
- } else if (typePtr == &tclNsVarNameType) {
- int useGlobal, useReference;
- Namespace *cachedNsPtr = part1Ptr->internalRep.twoPtrValue.ptr1;
- varPtr = part1Ptr->internalRep.twoPtrValue.ptr2;
-
- useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && (
- (flags & TCL_GLOBAL_ONLY) ||
- (part1[0]==':' && part1[1]==':') ||
- (!HasLocalVars(varFramePtr) && (nsPtr==iPtr->globalNsPtr)));
-
- useReference = useGlobal || ((cachedNsPtr == nsPtr) && (
- (flags & TCL_NAMESPACE_ONLY) ||
- (!HasLocalVars(varFramePtr) && !(flags & TCL_GLOBAL_ONLY) &&
- /*
- * Careful: an undefined ns variable could be hiding a valid
- * global reference.
- */
- !TclIsVarUndefined(varPtr))));
-
- if (useReference && !TclIsVarDeadHash(varPtr)) {
- /*
- * A straight global or namespace reference, use it. It isn't so
- * simple to deal with 'implicit' namespace references, i.e.,
- * those where the reference could be to either a namespace or a
- * global variable. Those we lookup again.
- *
- * If TclIsVarDeadHash(varPtr), this might be a reference to a
- * variable in a deleted namespace, kept alive by e.g. part1Ptr.
- * We could conceivably be so unlucky that a new namespace was
- * created at the same address as the deleted one, so to be safe
- * we test for a valid hPtr.
- */
-
- goto donePart1;
- }
- goto doneParsing;
-#endif
}
/*
@@ -674,7 +600,7 @@ TclObjLookupVarEx(
}
part1 = TclGetStringFromObj(part1Ptr, &len1);
- if (!parsed && (*(part1 + len1 - 1) == ')')) {
+ if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) {
/*
* part1Ptr is possibly an unparsed array element.
*/
@@ -771,31 +697,20 @@ TclObjLookupVarEx(
/*
* An indexed local variable.
*/
+ Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index);
part1Ptr->typePtr = &localVarNameType;
- if (part1Ptr != localName(iPtr->varFramePtr, index)) {
- part1Ptr->internalRep.ptrAndLongRep.ptr =
- localName(iPtr->varFramePtr, index);
- Tcl_IncrRefCount((Tcl_Obj *)
- part1Ptr->internalRep.ptrAndLongRep.ptr);
+ if (part1Ptr != cachedNamePtr) {
+ part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr;
+ Tcl_IncrRefCount(cachedNamePtr);
+ if (cachedNamePtr->typePtr != &localVarNameType
+ || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) {
+ TclFreeIntRep(cachedNamePtr);
+ }
} else {
- part1Ptr->internalRep.ptrAndLongRep.ptr = NULL;
+ part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
}
- part1Ptr->internalRep.ptrAndLongRep.value = (long) index;
-#if ENABLE_NS_VARNAME_CACHING
- } else if (index > -3) {
- /*
- * A cacheable namespace or global variable.
- */
-
- Namespace *nsPtr;
-
- nsPtr = ((index == -1) ? iPtr->globalNsPtr : varFramePtr->nsPtr);
- varPtr->refCount++;
- part1Ptr->typePtr = &tclNsVarNameType;
- part1Ptr->internalRep.twoPtrValue.ptr1 = nsPtr;
- part1Ptr->internalRep.twoPtrValue.ptr2 = varPtr;
-#endif
+ part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index);
} else {
/*
* At least mark part1Ptr as already parsed.
@@ -807,18 +722,6 @@ TclObjLookupVarEx(
}
donePart1:
-#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */
- if (varPtr == NULL) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- part1 = TclGetString(part1Ptr);
- TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
- "cached variable reference is NULL.", -1);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
- TclGetString(part1Ptr), NULL);
- }
- return NULL;
- }
-#endif
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -1605,7 +1508,7 @@ Tcl_SetVar(
Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(varNamePtr);
- varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL,
Tcl_NewStringObj(newValue, -1), flags);
Tcl_DecrRefCount(varNamePtr);
@@ -1912,17 +1815,6 @@ TclPtrSetVar(
varPtr->value.objPtr = NULL;
}
if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
-#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */
- /*
- * Can't happen now!
- */
-
- if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
- TclDecrRefCount(oldValuePtr); /* Discard old value. */
- varPtr->value.objPtr = NULL;
- oldValuePtr = NULL;
- }
-#endif
if (flags & TCL_LIST_ELEMENT) { /* Append list element. */
if (oldValuePtr == NULL) {
TclNewObj(oldValuePtr);
@@ -1958,6 +1850,9 @@ TclPtrSetVar(
Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
}
Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
}
}
} else if (newValuePtr != oldValuePtr) {
@@ -2146,7 +2041,7 @@ TclPtrIncrObjVar(
if (Tcl_IsShared(varValuePtr)) {
/* Copy on write */
varValuePtr = Tcl_DuplicateObj(varValuePtr);
-
+
if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
varValuePtr, flags, index);
@@ -2385,18 +2280,6 @@ TclPtrUnsetVar(
}
}
-#if ENABLE_NS_VARNAME_CACHING
- /*
- * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType
- * keeping a reference. This removes some additional exteriorisations of
- * [Bug 736729], but may be a good thing independently of the bug.
- */
-
- if (part1Ptr->typePtr == &tclNsVarNameType) {
- TclFreeIntRep(part1Ptr);
- }
-#endif
-
/*
* Finally, if the variable is truly not in use then free up its Var
* structure and remove it from its hash table, if any. The ref count of
@@ -2514,8 +2397,8 @@ UnsetVarStruct(
tracePtr = NULL;
if (TclIsVarTraced(&dummyVar)) {
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar);
- tracePtr = Tcl_GetHashValue(tPtr);
if (tPtr) {
+ tracePtr = Tcl_GetHashValue(tPtr);
Tcl_DeleteHashEntry(tPtr);
}
}
@@ -3850,6 +3733,53 @@ ArrayNamesCmd(
/*
*----------------------------------------------------------------------
*
+ * TclFindArrayPtrElements --
+ *
+ * Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry
+ * for each existing element of the given array. The provided hash table
+ * is assumed to be initially empty.
+ *
+ * Result:
+ * none
+ *
+ * Side effects:
+ * The keys of the array gain an extra reference. The supplied hash table
+ * has elements added to it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFindArrayPtrElements(
+ Var *arrayPtr,
+ Tcl_HashTable *tablePtr)
+{
+ Var *varPtr;
+ Tcl_HashSearch search;
+
+ if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr)
+ || TclIsVarUndefined(arrayPtr)) {
+ return;
+ }
+
+ for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search);
+ varPtr!=NULL ; varPtr=VarHashNextVar(&search)) {
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *nameObj;
+ int dummy;
+
+ if (TclIsVarUndefined(varPtr)) {
+ continue;
+ }
+ nameObj = VarHashGetKey(varPtr);
+ hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy);
+ Tcl_SetHashValue(hPtr, nameObj);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ArraySetCmd --
*
* This object-based function is invoked to process the "array set" Tcl
@@ -4355,8 +4285,8 @@ ObjMakeUpvar(
|| !HasLocalVars(varFramePtr)
|| (strstr(TclGetString(myNamePtr), "::") != NULL))) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
- "bad variable name \"%s\": upvar won't create "
- "namespace variable that refers to procedure variable",
+ "bad variable name \"%s\": can't create namespace "
+ "variable that refers to procedure variable",
TclGetString(myNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
@@ -4413,7 +4343,7 @@ TclPtrMakeUpvar(
}
/* Callers must Incr myNamePtr if they plan to Decr it. */
-
+
int
TclPtrObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
@@ -4456,9 +4386,8 @@ TclPtrObjMakeUpvar(
*/
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
- "bad variable name \"%s\": upvar won't create a"
- " scalar variable that looks like an array element",
- myName));
+ "bad variable name \"%s\": can't create a scalar "
+ "variable that looks like an array element", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT",
NULL);
return TCL_ERROR;
@@ -4697,7 +4626,7 @@ Tcl_GetVariableFullName(
} else if (iPtr->varFramePtr->procPtr) {
int index = varPtr - iPtr->varFramePtr->compiledLocals;
- if (index < iPtr->varFramePtr->numCompiledLocals) {
+ if (index >= 0 && index < iPtr->varFramePtr->numCompiledLocals) {
namePtr = localName(iPtr->varFramePtr, index);
Tcl_AppendObjToObj(objPtr, namePtr);
}
@@ -5614,16 +5543,16 @@ PanicOnSetVarName(
* localVarName -
*
* INTERNALREP DEFINITION:
- * ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache
+ * twoPtrValue.ptr1: pointer to name obj in varFramePtr->localCache
* or NULL if it is this same obj
- * ptrAndLongRep.value: index into locals table
+ * twoPtrValue.ptr2: index into locals table
*/
static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *namePtr = objPtr->internalRep.ptrAndLongRep.ptr;
+ Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (namePtr) {
Tcl_DecrRefCount(namePtr);
@@ -5636,60 +5565,19 @@ DupLocalVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- Tcl_Obj *namePtr = srcPtr->internalRep.ptrAndLongRep.ptr;
+ Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1;
if (!namePtr) {
namePtr = srcPtr;
}
- dupPtr->internalRep.ptrAndLongRep.ptr = namePtr;
+ dupPtr->internalRep.twoPtrValue.ptr1 = namePtr;
Tcl_IncrRefCount(namePtr);
- dupPtr->internalRep.ptrAndLongRep.value =
- srcPtr->internalRep.ptrAndLongRep.value;
+ dupPtr->internalRep.twoPtrValue.ptr2 =
+ srcPtr->internalRep.twoPtrValue.ptr2;
dupPtr->typePtr = &localVarNameType;
}
-#if ENABLE_NS_VARNAME_CACHING
-/*
- * nsVarName -
- *
- * INTERNALREP DEFINITION:
- * twoPtrValue.ptr1: pointer to the namespace containing the reference.
- * twoPtrValue.ptr2: pointer to the corresponding Var
- */
-
-static void
-FreeNsVarName(
- Tcl_Obj *objPtr)
-{
- register Var *varPtr = objPtr->internalRep.twoPtrValue.ptr2;
-
- if (TclIsVarInHash(varPtr)) {
- varPtr->refCount--;
- if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) {
- CleanupVar(varPtr, NULL);
- }
- }
- objPtr->typePtr = NULL;
-}
-
-static void
-DupNsVarName(
- Tcl_Obj *srcPtr,
- Tcl_Obj *dupPtr)
-{
- Namespace *nsPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- register Var *varPtr = srcPtr->internalRep.twoPtrValue.ptr2;
-
- dupPtr->internalRep.twoPtrValue.ptr1 = nsPtr;
- dupPtr->internalRep.twoPtrValue.ptr2 = varPtr;
- if (TclIsVarInHash(varPtr)) {
- varPtr->refCount++;
- }
- dupPtr->typePtr = &tclNsVarNameType;
-}
-#endif
-
/*
* parsedVarName -
*
@@ -6479,11 +6367,10 @@ CompareVarKeys(
/*
* If the object pointers are the same then they match.
- */
+ * OPT: this comparison was moved to the caller
- if (objPtr1 == objPtr2) {
- return 1;
- }
+ if (objPtr1 == objPtr2) return 1;
+ */
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a