diff options
Diffstat (limited to 'generic/tclVar.c')
| -rw-r--r-- | generic/tclVar.c | 257 |
1 files changed, 71 insertions, 186 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c index af1a563..fa217ef 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. */ @@ -774,28 +700,14 @@ TclObjLookupVarEx( part1Ptr->typePtr = &localVarNameType; if (part1Ptr != localName(iPtr->varFramePtr, index)) { - part1Ptr->internalRep.ptrAndLongRep.ptr = + part1Ptr->internalRep.twoPtrValue.ptr1 = localName(iPtr->varFramePtr, index); Tcl_IncrRefCount((Tcl_Obj *) - part1Ptr->internalRep.ptrAndLongRep.ptr); + part1Ptr->internalRep.twoPtrValue.ptr1); } 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 +719,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; } @@ -1912,17 +1812,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 +1847,9 @@ TclPtrSetVar( Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ } Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } } } } else if (newValuePtr != oldValuePtr) { @@ -2385,18 +2277,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 @@ -3850,6 +3730,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 +4282,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; @@ -4456,9 +4383,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 +4623,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 +5540,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 +5562,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 - * |