Attachment "VarReform.diff.8.5" to
ticket [1750051fff]
added by
msofer
2007-07-10 18:55:38.
? VarReform-showFlags.tcl
? VarReform.diff.1
? VarReform.diff.2
? VarReform.diff.2.1
? VarReform.diff.2.2
? VarReform.diff.2.3
? VarReform.diff.2.4
? VarReform.diff.2.5
? VarReform.diff.3
? VarReform.diff.3.1
? VarReform.diff.3.2
? VarReform.diff.3.3
? VarReform.diff.4.1
? VarReform.diff.4.2
? VarReform.diff.4.3
? VarReform.diff.5.1
? VarReform.diff.5.2
? VarReform.diff.5.3
? VarReform.diff.5.4
? VarReform.diff.5.5
? VarReform.diff.5.6
? VarReform.diff.7
? VarReform.diff.7.1
? VarReform.diff.7.2
? VarReform.diff.7.3
? VarReform.diff.7.4
? VarReform.diff.7.5
? VarReform.diff.7.6
? VarReform.diff.7.tmp
? VarReform.diff.8.0
? VarReform.diff.8.1
? VarReform.diff.8.2
? VarReform.diff.8.3
? VarReform.diff.8.4
? VarReform.diff.8.5
? VarReform_old
? lit
? refCount
? generic/VarReform.descr
? generic/VarReform.txt
? generic/VarReform2.txt
? generic/tclInt.h.7.5
? generic/tclInt.h.7.6
? generic/tclInt.h.8.0
? generic/tclInt.h.NEW
? generic/tclVar.c.7.5
? generic/tclVar.c.7.6
? generic/tclVar.c.CVS
? generic/tclVar.c.MOD
? generic/tclVar.c.OK
? unix/0valgrind
? unix/ERR
? unix/dltest.marker
? unix/httpd_17847
? unix/httpd_19974
? unix/httpd_25368
? unix/httpd_3272
? unix/searchPtr
? unix/tracePtr
? unix/value.objPtr
? unix/vgcore.20181
? unix/vgcore.20192
? unix/vgcore.20211
? unix/vgcore.25705
? unix/vgcore.25709
? unix/vgcore.3642
? unix/vgcore.3646
? unix/vgcore.3647
? unix/vgcore.3661
? unix/vgcore.3662
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.233
diff -u -r1.233 tcl.h
--- generic/tcl.h 2 Jul 2007 21:10:51 -0000 1.233
+++ generic/tcl.h 10 Jul 2007 11:53:10 -0000
@@ -870,6 +870,7 @@
int dummy9;
char *dummy10;
char *dummy11;
+ char *dummy12;
} Tcl_CallFrame;
/*
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.262
diff -u -r1.262 tclBasic.c
--- generic/tclBasic.c 29 Jun 2007 03:16:01 -0000 1.262
+++ generic/tclBasic.c 10 Jul 2007 11:53:13 -0000
@@ -302,6 +302,19 @@
{ "eq", TclSortingOpCmd, TclCompileStreqOpCmd, 0, NULL },
{ NULL, NULL, NULL, 0, NULL }
};
+
+/*
+ * Hash key type for the interp's var trace and search tables
+ */
+
+static Tcl_HashKeyType PtrHashKeyType = {
+ TCL_HASH_KEY_TYPE_VERSION, /* version */
+ TCL_HASH_KEY_RANDOMIZE_HASH, /* flags */
+ NULL, /* hashKeyProc */
+ NULL, /* compareKeysProc */
+ NULL, /* allocEntryProc */
+ NULL /* freeEntryProc */
+};
/*
*----------------------------------------------------------------------
@@ -438,6 +451,17 @@
iPtr->resultSpace[0] = 0;
iPtr->threadId = Tcl_GetCurrentThread();
+ /*
+ * Initialise the tables for variable traces and searches *before*
+ * creating the global ns - so that the trace on errorInfo can be
+ * recorded.
+ */
+
+ Tcl_InitCustomHashTable(&iPtr->varTraces,
+ TCL_CUSTOM_PTR_KEYS, &PtrHashKeyType);
+ Tcl_InitCustomHashTable(&iPtr->varSearches,
+ TCL_CUSTOM_PTR_KEYS, &PtrHashKeyType);
+
iPtr->globalNsPtr = NULL; /* Force creation of global ns below */
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
(ClientData) NULL, NULL);
@@ -1332,6 +1356,10 @@
ckfree((char *) iPtr->lineBCPtr);
iPtr->lineBCPtr = NULL;
}
+
+ Tcl_DeleteHashTable(&iPtr->varTraces);
+ Tcl_DeleteHashTable(&iPtr->varSearches);
+
ckfree((char *) iPtr);
}
Index: generic/tclCmdIL.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdIL.c,v
retrieving revision 1.121
diff -u -r1.121 tclCmdIL.c
--- generic/tclCmdIL.c 1 Jul 2007 14:49:43 -0000 1.121
+++ generic/tclCmdIL.c 10 Jul 2007 11:53:15 -0000
@@ -1033,8 +1033,8 @@
varName = TclGetString(objv[1]);
varPtr = TclVarTraceExists(interp, varName);
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
- ((varPtr != NULL) && !TclIsVarUndefined(varPtr))));
+ Tcl_SetObjResult(interp,
+ Tcl_NewBooleanObj(varPtr && varPtr->value.objPtr));
return TCL_OK;
}
@@ -1417,7 +1417,7 @@
listPtr = Tcl_NewListObj(0, NULL);
if (pattern != NULL && TclMatchIsTrivial(pattern)) {
- entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
+ entryPtr = Tcl_FindHashEntry((Tcl_HashTable *)&globalNsPtr->varTable, pattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)) {
@@ -1426,14 +1426,14 @@
}
}
} else {
- for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
+ for (entryPtr = Tcl_FirstHashEntry((Tcl_HashTable *)&globalNsPtr->varTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (TclIsVarUndefined(varPtr)) {
continue;
}
- varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
+ varName = Tcl_GetHashKey((Tcl_HashTable *) &globalNsPtr->varTable, entryPtr);
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
@@ -1732,7 +1732,7 @@
CompiledLocal *localPtr;
Var *varPtr;
int i, localVarCt;
- const char *varName;
+ char *varName, **varNames;
Tcl_HashTable *localVarTablePtr;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
@@ -1740,8 +1740,9 @@
localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
localVarCt = iPtr->varFramePtr->numCompiledLocals;
varPtr = iPtr->varFramePtr->compiledLocals;
- localVarTablePtr = iPtr->varFramePtr->varTablePtr;
-
+ localVarTablePtr = (Tcl_HashTable *) iPtr->varFramePtr->varTablePtr;
+ varNames = localVarNames(iPtr->varFramePtr);
+
for (i = 0; i < localVarCt; i++) {
/*
* Skip nameless (temporary) variables and undefined variables.
@@ -1749,7 +1750,7 @@
if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
- varName = varPtr->name;
+ varName = varNames[i];
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
@@ -2304,7 +2305,7 @@
* If we can just do hash lookups, that simplifies things a lot.
*/
- entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
+ entryPtr = Tcl_FindHashEntry((Tcl_HashTable *) &nsPtr->varTable, simplePattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
@@ -2319,7 +2320,7 @@
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
} else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable,
+ entryPtr = Tcl_FindHashEntry((Tcl_HashTable *) &globalNsPtr->varTable,
simplePattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
@@ -2335,12 +2336,12 @@
* Have to scan the tables of variables.
*/
- entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
+ entryPtr = Tcl_FirstHashEntry((Tcl_HashTable *) &nsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| TclIsVarNamespaceVar(varPtr)) {
- varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
+ varName = Tcl_GetHashKey((Tcl_HashTable *) &nsPtr->varTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (specificNsInPattern) {
@@ -2366,16 +2367,16 @@
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable,&search);
+ entryPtr = Tcl_FirstHashEntry((Tcl_HashTable *) &globalNsPtr->varTable,&search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| TclIsVarNamespaceVar(varPtr)) {
- varName = Tcl_GetHashKey(&globalNsPtr->varTable,
+ varName = Tcl_GetHashKey((Tcl_HashTable *) &globalNsPtr->varTable,
entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
- if (Tcl_FindHashEntry(&nsPtr->varTable,
+ if (Tcl_FindHashEntry((Tcl_HashTable *) &nsPtr->varTable,
varName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
Index: generic/tclCompCmds.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompCmds.c,v
retrieving revision 1.112
diff -u -r1.112 tclCompCmds.c
--- generic/tclCompCmds.c 28 Jun 2007 21:10:38 -0000 1.112
+++ generic/tclCompCmds.c 10 Jul 2007 11:53:18 -0000
@@ -403,8 +403,7 @@
return TCL_ERROR;
}
resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
- resultNameTokenPtr[1].size, /*create*/ 1, VAR_SCALAR,
- envPtr->procPtr);
+ resultNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
/* DKF */
if (parsePtr->numWords == 4) {
@@ -418,8 +417,7 @@
return TCL_ERROR;
}
optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
- optsNameTokenPtr[1].size, /*create*/ 1, VAR_SCALAR,
- envPtr->procPtr);
+ optsNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
}
}
@@ -658,8 +656,7 @@
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
- procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
for (i=1 ; i<numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
@@ -705,8 +702,7 @@
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
- procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
CompileWord(envPtr, keyTokenPtr, interp, 3);
TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
@@ -770,15 +766,13 @@
ckfree((char *) argv);
return TCL_ERROR;
}
- keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, VAR_SCALAR,
- procPtr);
+ keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, procPtr);
nameChars = strlen(argv[1]);
if (!TclIsLocalScalar(argv[1], nameChars)) {
ckfree((char *) argv);
return TCL_ERROR;
}
- valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, VAR_SCALAR,
- procPtr);
+ valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, procPtr);
ckfree((char *) argv);
/*
@@ -788,7 +782,7 @@
* unset (at which point it should also have been finished with).
*/
- infoIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr);
+ infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr);
/*
* Preparation complete; issue instructions. Note that this code
@@ -934,8 +928,7 @@
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
- procPtr);
+ dictIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
duiPtr = (DictUpdateInfo *)
ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
@@ -958,8 +951,8 @@
TclStackFree(interp, keyTokenPtrs);
return TCL_ERROR;
}
- duiPtr->varIndices[i] = TclFindCompiledLocal(name, nameChars, 1,
- VAR_SCALAR, procPtr);
+ duiPtr->varIndices[i] =
+ TclFindCompiledLocal(name, nameChars, 1, procPtr);
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
@@ -969,7 +962,7 @@
}
bodyTokenPtr = tokenPtr;
- keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr);
+ keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr);
/*
* The list of variables to bind is stored in auxiliary data so that
@@ -1040,8 +1033,7 @@
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
- procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
for (i=1 ; i<numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
@@ -1070,8 +1062,7 @@
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
- procPtr);
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
CompileWord(envPtr, keyTokenPtr, interp, 3);
CompileWord(envPtr, valueTokenPtr, interp, 4);
TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
@@ -1514,13 +1505,13 @@
firstValueTemp = -1;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, VAR_SCALAR, procPtr);
+ /*create*/ 1, procPtr);
if (loopIndex == 0) {
firstValueTemp = tempVar;
}
}
loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, VAR_SCALAR, procPtr);
+ /*create*/ 1, procPtr);
/*
* Create and initialize the ForeachInfo and ForeachVarList data
@@ -1544,7 +1535,7 @@
int nameChars = strlen(varName);
varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
- nameChars, /*create*/ 1, VAR_SCALAR, procPtr);
+ nameChars, /*create*/ 1, procPtr);
}
infoPtr->varLists[loopIndex] = varListPtr;
}
@@ -4657,7 +4648,6 @@
if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
localIndex = TclFindCompiledLocal(name, nameChars,
/*create*/ flags & TCL_CREATE_VAR,
- /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
envPtr->procPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/*
@@ -4873,8 +4863,7 @@
return TCL_ERROR;
} else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR,
- envPtr->procPtr);
+ int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr);
int words;
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -5328,7 +5317,6 @@
localIndex = TclFindCompiledLocal(tailName, len,
/*create*/ TCL_CREATE_VAR,
- /*flags*/ 0,
envPtr->procPtr);
Tcl_DecrRefCount(tailPtr);
return localIndex;
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.123
diff -u -r1.123 tclCompile.c
--- generic/tclCompile.c 21 Jun 2007 18:41:16 -0000 1.123
+++ generic/tclCompile.c 10 Jul 2007 11:53:21 -0000
@@ -724,8 +724,9 @@
* A single heap object holds the ByteCode structure and its code, object,
* command location, and auxiliary data arrays. This means we only need to
* 1) decrement the ref counts of the LiteralEntry's in its literal array,
- * 2) call the free procs for the auxiliary data items, and 3) free the
- * ByteCode structure's heap object.
+ * 2) call the free procs for the auxiliary data items, 3) free the
+ * localCache if it is unused, and finally 4) free the ByteCode
+ * structure's heap object.
*
* The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like
* those generated from tbcload) is special, as they doesn't make use of
@@ -806,6 +807,10 @@
}
}
+ if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
+ ckfree((char *) codePtr->localCachePtr);
+ }
+
TclHandleRelease(codePtr->interpHandle);
ckfree((char *) codePtr);
}
@@ -1650,7 +1655,7 @@
localVar = -1;
if (localVarName != -1) {
localVar = TclFindCompiledLocal(name, nameBytes, localVarName,
- /*flags*/ 0, envPtr->procPtr);
+ envPtr->procPtr);
}
if (localVar < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
@@ -2059,6 +2064,8 @@
Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr,
&new), envPtr->extCmdMapPtr);
envPtr->extCmdMapPtr = NULL;
+
+ codePtr->localCachePtr = NULL;
}
/*
@@ -2094,9 +2101,6 @@
int nameBytes, /* Number of bytes in the name. */
int create, /* If 1, allocate a local frame entry for the
* variable if it is new. */
- int flags, /* Flag bits for the compiled local if
- * created. Only VAR_SCALAR, VAR_ARRAY, and
- * VAR_LINK make sense. */
register Proc *procPtr) /* Points to structure describing procedure
* containing the variable reference. */
{
@@ -2144,7 +2148,7 @@
localPtr->nextPtr = NULL;
localPtr->nameLength = nameBytes;
localPtr->frameIndex = localVar;
- localPtr->flags = flags | VAR_UNDEFINED;
+ localPtr->flags = 0;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
@@ -3310,7 +3314,7 @@
CompiledLocal *localPtr = procPtr->firstLocalPtr;
for (i = 0; i < numCompiledLocals; i++) {
fprintf(stdout, " slot %d%s%s%s%s%s%s", i,
- (localPtr->flags & VAR_SCALAR) ? ", scalar" : "",
+ (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
(localPtr->flags & VAR_ARRAY) ? ", array" : "",
(localPtr->flags & VAR_LINK) ? ", link" : "",
(localPtr->flags & VAR_ARGUMENT) ? ", arg" : "",
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.74
diff -u -r1.74 tclCompile.h
--- generic/tclCompile.h 21 Jun 2007 12:43:18 -0000 1.74
+++ generic/tclCompile.h 10 Jul 2007 11:53:22 -0000
@@ -416,6 +416,9 @@
* code deltas. Source lengths are always
* positive. This sequence is just after the
* last byte in the source delta sequence. */
+ LocalCache *localCachePtr; /* Pointer to the start of the cached variable
+ * names and initialisation data for local
+ * variables. */
#ifdef TCL_COMPILE_STATS
Tcl_Time createTime; /* Absolute time when the ByteCode was
* created. */
@@ -859,7 +862,7 @@
ByteCode *codePtr);
MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void);
MODULE_SCOPE int TclFindCompiledLocal(CONST char *name, int nameChars,
- int create, int flags, Proc *procPtr);
+ int create, Proc *procPtr);
MODULE_SCOPE LiteralEntry * TclLookupLiteralEntry(Tcl_Interp *interp,
Tcl_Obj *objPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.305
diff -u -r1.305 tclExecute.c
--- generic/tclExecute.c 28 Jun 2007 21:24:56 -0000 1.305
+++ generic/tclExecute.c 10 Jul 2007 11:53:25 -0000
@@ -410,6 +410,7 @@
NULL, NULL, NULL, NULL
};
+
/*
* Declarations for local procedures to this file:
*/
@@ -597,6 +598,7 @@
TclDecrRefCount(eePtr->constants[0]);
TclDecrRefCount(eePtr->constants[1]);
+
ckfree((char *) eePtr);
}
@@ -1403,6 +1405,7 @@
Tcl_Obj **initTosPtr; /* Stack top at start of execution. */
ptrdiff_t *initCatchTop; /* Catch stack top at start of execution. */
Var *compiledLocals;
+ char **varNames;
Namespace *namespacePtr;
CmdFrame *bcFramePtr; /* TIP #280: Structure for tracking lines. */
Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];
@@ -1497,6 +1500,15 @@
namespacePtr = iPtr->varFramePtr->nsPtr;
compiledLocals = iPtr->varFramePtr->compiledLocals;
+ if (iPtr->varFramePtr->procPtr) {
+ varNames = localVarNames(iPtr->varFramePtr);
+ } else {
+ /*
+ * If there is no proc pointer, there should be no local variables either
+ */
+
+ varNames = NULL;
+ }
/*
* Loop executing instructions until a "done" instruction, a TCL_RETURN,
@@ -2256,14 +2268,13 @@
*/
{
int opnd, pcAdjustment;
- char *part1, *part2;
+ const char *part1, *part2;
Var *varPtr, *arrayPtr;
Tcl_Obj *objPtr;
case INST_LOAD_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
varPtr = &(compiledLocals[opnd]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -2280,13 +2291,13 @@
pcAdjustment = 2;
cleanup = 0;
arrayPtr = NULL;
+ part1 = varNames[opnd];
part2 = NULL;
goto doCallPtrGetVar;
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
varPtr = &(compiledLocals[opnd]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -2303,6 +2314,7 @@
pcAdjustment = 5;
cleanup = 0;
arrayPtr = NULL;
+ part1 = varNames[opnd];
part2 = NULL;
goto doCallPtrGetVar;
@@ -2326,7 +2338,7 @@
"read", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr) {
if (TclIsVarDirectReadable(varPtr)
- && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
+ && ((arrayPtr == NULL) || !TclIsVarTraced(arrayPtr))) {
/*
* No errors, no traces: just get the value.
*/
@@ -2354,16 +2366,16 @@
doLoadArray:
part2 = TclGetString(OBJ_AT_TOS);
arrayPtr = &(compiledLocals[opnd]);
- part1 = arrayPtr->name;
+ part1 = varNames[opnd];
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" => ", opnd, part2));
if (!TclIsVarUndefined(arrayPtr)
&& TclIsVarArray(arrayPtr)
- && TclIsVarUntraced(arrayPtr)) {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr,
- part2);
+ && !TclIsVarTraced(arrayPtr)) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(
+ (Tcl_HashTable *) arrayPtr->value.tablePtr,part2);
if (hPtr) {
varPtr = (Var *) Tcl_GetHashValue(hPtr);
} else {
@@ -2381,7 +2393,7 @@
}
}
if (TclIsVarDirectReadable(varPtr)
- && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
+ && ((arrayPtr == NULL) || !TclIsVarTraced(arrayPtr))) {
/*
* No errors, no traces: just get the value.
*/
@@ -2429,7 +2441,7 @@
{
int opnd, pcAdjustment, storeFlags;
- char *part1, *part2;
+ const char *part1, *part2;
Var *varPtr, *arrayPtr;
Tcl_Obj *objPtr, *valuePtr;
@@ -2535,7 +2547,7 @@
valuePtr = OBJ_AT_TOS;
part2 = TclGetString(OBJ_UNDER_TOS);
arrayPtr = &(compiledLocals[opnd]);
- part1 = arrayPtr->name;
+ part1 = varNames[opnd];
cleanup = 2;
TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, part2, O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
@@ -2543,11 +2555,11 @@
}
if (!TclIsVarUndefined(arrayPtr)
&& TclIsVarArray(arrayPtr)
- && TclIsVarUntraced(arrayPtr)) {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr,
- part2);
+ && !TclIsVarTraced(arrayPtr)) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(
+ (Tcl_HashTable *) arrayPtr->value.tablePtr, part2);
if (hPtr) {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
+ varPtr = Tcl_GetHashValue(hPtr);
goto doCallPtrSetVar;
}
}
@@ -2601,19 +2613,19 @@
doStoreScalar:
valuePtr = OBJ_AT_TOS;
varPtr = &(compiledLocals[opnd]);
- part1 = varPtr->name;
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
cleanup = 1;
arrayPtr = NULL;
+ part1 = varNames[opnd];
part2 = NULL;
doCallPtrSetVar:
if ((storeFlags == TCL_LEAVE_ERR_MSG)
&& TclIsVarDirectWritable(varPtr)
- && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
+ && ((arrayPtr == NULL) || !TclIsVarTraced(arrayPtr))) {
/*
* No traces, no errors, plain 'set': we can safely inline. The
* value *will* be set to what's requested, so that the stack top
@@ -2685,7 +2697,7 @@
Tcl_WideInt w;
#endif
long i;
- char *part1, *part2;
+ const char *part1, *part2;
Var *varPtr, *arrayPtr;
case INST_INCR_SCALAR1:
@@ -2753,7 +2765,7 @@
doIncrArray:
part2 = TclGetString(OBJ_AT_TOS);
arrayPtr = &(compiledLocals[opnd]);
- part1 = arrayPtr->name;
+ part1 = varNames[opnd];
cleanup = 1;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
@@ -2780,7 +2792,7 @@
varPtr = varPtr->value.linkPtr;
}
- if (TclIsVarDirectReadable(varPtr)) {
+ if (TclIsVarDirectReadable(varPtr) && TclIsVarDirectWritable(varPtr)) {
ClientData ptr;
int type;
@@ -2898,7 +2910,7 @@
doIncrScalar:
varPtr = &(compiledLocals[opnd]);
- part1 = varPtr->name;
+ part1 = varNames[opnd];
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -2908,8 +2920,8 @@
TRACE(("%u %ld => ", opnd, i));
doIncrVar:
- if (TclIsVarDirectReadable(varPtr)
- && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
+ if (TclIsVarDirectReadable(varPtr) && TclIsVarDirectWritable(varPtr)
+ && ((arrayPtr == NULL) || !TclIsVarTraced(arrayPtr))) {
objPtr = varPtr->value.objPtr;
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
@@ -2998,7 +3010,7 @@
if (!TclIsVarNamespaceVar(otherPtr)) {
TclSetVarNamespaceVar(otherPtr);
- otherPtr->refCount++;
+ VarHashRefCount(otherPtr)++;
}
result = TCL_OK;
goto doLinkVars;
@@ -3051,7 +3063,7 @@
opnd = TclGetInt4AtPtr(pc+1);;
varPtr = &(compiledLocals[opnd]);
- if ((varPtr != otherPtr) && (varPtr->tracePtr == NULL)
+ if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr)
&& (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) {
if (!TclIsVarUndefined(varPtr)) {
/* Then it is a defined link */
@@ -3059,15 +3071,19 @@
if (linkPtr == otherPtr) {
goto doLinkVarsDone;
}
- linkPtr->refCount--;
- if (TclIsVarUndefined(linkPtr)) {
- TclCleanupVar(linkPtr, NULL);
+ if (TclIsVarInHash(linkPtr)) {
+ VarHashRefCount(linkPtr)--;
+ if (TclIsVarUndefined(linkPtr)) {
+ TclCleanupVar(linkPtr, NULL);
+ }
}
}
TclSetVarLink(varPtr);
TclClearVarUndefined(varPtr);
varPtr->value.linkPtr = otherPtr;
- otherPtr->refCount++;
+ if (TclIsVarInHash(otherPtr)) {
+ VarHashRefCount(otherPtr)++;
+ }
} else {
result = TclPtrMakeUpvar(interp, otherPtr, NULL, 0, opnd);
if (result != TCL_OK) {
@@ -5712,7 +5728,7 @@
int iterNum, listTmpIndex, listLen, numVars;
int varIndex, valIndex, continueLoop, j;
long i;
- char *part1;
+ const char *part1;
opnd = TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
@@ -5782,7 +5798,6 @@
varIndex = varListPtr->varIndexes[j];
varPtr = &(compiledLocals[varIndex]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -5799,6 +5814,7 @@
Tcl_IncrRefCount(valuePtr);
}
} else {
+ part1 = varNames[varIndex];
DECACHE_STACK_INFO();
value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
@@ -5887,7 +5903,7 @@
int opnd, opnd2, allocateDict;
Tcl_Obj *dictPtr, *valPtr;
Var *varPtr;
- char *part1;
+ const char *part1;
case INST_DICT_GET:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -5932,7 +5948,6 @@
opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd2]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -5940,6 +5955,7 @@
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
+ part1 = varNames[opnd2];
DECACHE_STACK_INFO();
dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
CACHE_STACK_INFO();
@@ -6019,6 +6035,7 @@
objResultPtr = dictPtr;
} else {
Tcl_IncrRefCount(dictPtr);
+ part1 = varNames[opnd2];
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
dictPtr, TCL_LEAVE_ERR_MSG);
@@ -6045,7 +6062,6 @@
cleanup = 2;
varPtr = &(compiledLocals[opnd]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6053,6 +6069,7 @@
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
+ part1 = varNames[opnd];
DECACHE_STACK_INFO();
dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
CACHE_STACK_INFO();
@@ -6141,6 +6158,7 @@
objResultPtr = dictPtr;
} else {
Tcl_IncrRefCount(dictPtr);
+ part1 = varNames[opnd];
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
dictPtr, TCL_LEAVE_ERR_MSG);
@@ -6184,7 +6202,7 @@
statePtr->typePtr = &dictIteratorType;
statePtr->internalRep.twoPtrValue.ptr1 = (void *) searchPtr;
statePtr->internalRep.twoPtrValue.ptr2 = (void *) dictPtr;
- varPtr = compiledLocals + opnd;
+ varPtr = (compiledLocals + opnd);
if (varPtr->value.objPtr == NULL) {
TclSetVarScalar(compiledLocals + opnd);
TclClearVarUndefined(compiledLocals + opnd);
@@ -6261,14 +6279,13 @@
Tcl_Obj **keyPtrPtr, *dictPtr;
DictUpdateInfo *duiPtr;
Var *varPtr;
- char *part1;
+ const char *part1;
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd]);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6276,6 +6293,7 @@
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
+ part1 = varNames[opnd];
DECACHE_STACK_INFO();
dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL,
TCL_LEAVE_ERR_MSG);
@@ -6299,7 +6317,7 @@
goto dictUpdateStartFailed;
}
varPtr = &(compiledLocals[duiPtr->varIndices[i]]);
- part1 = varPtr->name;
+ part1 = varNames[duiPtr->varIndices[i]];
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6323,7 +6341,6 @@
opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd]);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6331,6 +6348,7 @@
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
+ part1 = varNames[opnd];
DECACHE_STACK_INFO();
dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
CACHE_STACK_INFO();
@@ -6355,13 +6373,13 @@
char *part1a;
var2Ptr = &(compiledLocals[duiPtr->varIndices[i]]);
- part1a = var2Ptr->name;
while (TclIsVarLink(var2Ptr)) {
var2Ptr = var2Ptr->value.linkPtr;
}
if (TclIsVarDirectReadable(var2Ptr)) {
valPtr = var2Ptr->value.objPtr;
} else {
+ part1a = varNames[duiPtr->varIndices[i]];
DECACHE_STACK_INFO();
valPtr = TclPtrGetVar(interp, var2Ptr, NULL, part1a, NULL, 0);
CACHE_STACK_INFO();
@@ -6377,6 +6395,7 @@
Tcl_DecrRefCount(varPtr->value.objPtr);
varPtr->value.objPtr = dictPtr;
} else {
+ part1 = varNames[opnd];
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
dictPtr, TCL_LEAVE_ERR_MSG);
Index: generic/tclHash.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclHash.c,v
retrieving revision 1.31
diff -u -r1.31 tclHash.c
--- generic/tclHash.c 2 Jul 2007 21:10:52 -0000 1.31
+++ generic/tclHash.c 10 Jul 2007 11:53:26 -0000
@@ -343,6 +343,7 @@
} else {
hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry));
hPtr->key.oneWordValue = (char *) key;
+ hPtr->clientData = 0;
}
hPtr->tablePtr = tablePtr;
@@ -355,7 +356,6 @@
hPtr->nextPtr = *hPtr->bucketPtr;
*hPtr->bucketPtr = hPtr;
#endif
- hPtr->clientData = 0;
tablePtr->numEntries++;
/*
Index: generic/tclInt.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.decls,v
retrieving revision 1.110
diff -u -r1.110 tclInt.decls
--- generic/tclInt.decls 20 Jun 2007 18:46:13 -0000 1.110
+++ generic/tclInt.decls 10 Jul 2007 11:53:26 -0000
@@ -73,7 +73,7 @@
void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr)
}
declare 12 generic {
- void TclDeleteVars(Interp *iPtr, Tcl_HashTable *tablePtr)
+ void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr)
}
# Removed in 8.5
#declare 13 generic {
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.323
diff -u -r1.323 tclInt.h
--- generic/tclInt.h 2 Jul 2007 17:32:09 -0000 1.323
+++ generic/tclInt.h 10 Jul 2007 11:53:28 -0000
@@ -191,6 +191,19 @@
typedef struct NamespacePathEntry NamespacePathEntry;
/*
+ * Special hashtable for variables: this is just a Tcl_HashTable with an nsPtr
+ * field added at the end: in this way variables can find their namespace
+ * without having to copy a pointer in their struct: they can access it via
+ * their hPtr->tablePtr.
+ */
+
+typedef struct TclVarHashTable {
+ Tcl_HashTable table;
+ struct Namespace *nsPtr;
+} TclVarHashTable;
+
+
+/*
* The structure below defines a namespace.
* Note: the first five fields must match exactly the fields in a
* Tcl_Namespace structure (see tcl.h). If you change one, be sure to change
@@ -234,7 +247,7 @@
* ImportedCmdRef structure) to the Command
* structure in the source namespace's command
* table. */
- Tcl_HashTable varTable; /* Contains all the (global) variables
+ TclVarHashTable varTable; /* Contains all the (global) variables
* currently in this namespace. Indexed by
* strings; values have type (Var *). */
char **exportArrayPtr; /* Points to an array of string patterns
@@ -497,10 +510,12 @@
*/
typedef struct Var {
+ int flags; /* Miscellaneous bits of information about
+ * variable. See below for definitions. */
union {
Tcl_Obj *objPtr; /* The variable's object value. Used for
* scalar variables and array elements. */
- Tcl_HashTable *tablePtr;/* For array variables, this points to
+ TclVarHashTable *tablePtr;/* For array variables, this points to
* information about the hash table used to
* implement the associative array. Points to
* ckalloc-ed data. */
@@ -509,48 +524,30 @@
* "upvar", this field points to the
* referenced variable's Var struct. */
} value;
- char *name; /* NULL if the variable is in a hashtable,
- * otherwise points to the variable's name. It
- * is used, e.g., by TclLookupVar and "info
- * locals". The storage for the characters of
- * the name is not owned by the Var and must
- * not be freed when freeing the Var. */
- Namespace *nsPtr; /* Points to the namespace that contains this
- * variable or NULL if the variable is a local
- * variable in a Tcl procedure. */
- Tcl_HashEntry *hPtr; /* If variable is in a hashtable, either the
- * hash table entry that refers to this
- * variable or NULL if the variable has been
- * detached from its hash table (e.g. an array
- * is deleted, but some of its elements are
- * still referred to in upvars). NULL if the
- * variable is not in a hashtable. This is
- * used to delete an variable from its
- * hashtable if it is no longer needed. */
- int refCount; /* Counts number of active uses of this
- * variable, not including its entry in the
- * call frame or the hash table: 1 for each
- * additional variable whose linkPtr points
- * here, 1 for each nested trace active on
- * variable, and 1 if the variable is a
- * namespace variable. This record can't be
- * deleted until refCount becomes 0. */
- VarTrace *tracePtr; /* First in list of all traces set for this
- * variable. */
- ArraySearch *searchPtr; /* First in list of all searches active for
- * this variable, or NULL if none. */
- int flags; /* Miscellaneous bits of information about
- * variable. See below for definitions. */
} Var;
-/*
- * Flag bits for variables. The first three (VAR_SCALAR, VAR_ARRAY, and
- * VAR_LINK) are mutually exclusive and give the "type" of the variable.
- * VAR_UNDEFINED is independent of the variable's type.
- *
- * VAR_SCALAR - 1 means this is a scalar variable and not an
- * array or link. The "objPtr" field points to
- * the variable's value, a Tcl object.
+typedef struct VarInHash {
+ Var var;
+ int refCount; /* Counts number of active uses of this
+ * variable: 1 for the entry in the hash
+ * table, 1 for each additional variable whose
+ * linkPtr points here, 1 for each nested
+ * trace active on variable, and 1 if the
+ * variable is a namespace variable. This
+ * record can't be deleted until refCount
+ * becomes 0. */
+ Tcl_HashEntry entry; /* The hash table entry that refers to this
+ * variable. This is used to find the name of
+ * the variable and to delete it from its
+ * hashtable if it is no longer needed. It
+ * also holds the variable's name. */
+} VarInHash;
+
+/*
+ * Flag bits for variables. The first two (VAR_ARRAY and VAR_LINK) are
+ * mutually exclusive and give the "type" of the variable. If none is set,
+ * this is a scalar variable.
+ *
* VAR_ARRAY - 1 means this is an array variable rather than
* a scalar variable or link. The "tablePtr"
* field points to the array's hashtable for its
@@ -562,21 +559,17 @@
* through "upvar" and "global" commands, or
* through references to variables in enclosing
* namespaces.
- * VAR_UNDEFINED - 1 means that the variable is in the process of
- * being deleted. An undefined variable logically
- * does not exist and survives only while it has
- * a trace, or if it is a global variable
- * currently being used by some procedure.
+ *
+ * Flags that indicate the type and status of storage; none is set for
+ * compiled local variables (Var structs).
+ *
* VAR_IN_HASHTABLE - 1 means this variable is in a hashtable and
* the Var structure is malloced. 0 if it is a
* local variable that was assigned a slot in a
* procedure frame by the compiler so the Var
* storage is part of the call frame.
- * VAR_TRACE_ACTIVE - 1 means that trace processing is currently
- * underway for a read or write access, so new
- * read or write accesses should not cause trace
- * procedures to be called and the variable can't
- * be deleted.
+ * VAR_DEAD_HASH 1 means that this var's entry in the hashtable
+ * has already been deleted.
* VAR_ARRAY_ELEMENT - 1 means that this variable is an array
* element, so it is not legal for it to be an
* array itself (the VAR_ARRAY flag had better
@@ -590,6 +583,19 @@
* incremented to reflect the "reference" from
* its namespace.
*
+ * Flag values relating to the variable's trace and search status.
+ *
+ * VAR_TRACED_READ
+ * VAR_TRACED_WRITE
+ * VAR_TRACED_UNSET
+ * VAR_TRACED_ARRAY
+ * VAR_TRACE_ACTIVE - 1 means that trace processing is currently
+ * underway for a read or write access, so new
+ * read or write accesses should not cause trace
+ * procedures to be called and the variable can't
+ * be deleted.
+ * VAR_SEARCH_ACTIVE
+ *
* The following additional flags are used with the CompiledLocal type defined
* below:
*
@@ -600,21 +606,49 @@
* name.
* VAR_RESOLVED - 1 if name resolution has been done for this
* variable.
+ * VAR_IS_ARGS 1 if this variable is the last argument and is
+ * named "args".
+ */
+
+/* FLAGS RENUMBERED: everything breaks already, make things simpler.
+ *
+ * IMPORTANT: skip the values 0x10, 0x20, 0x40, 0x800 corresponding to
+ * TCL_TRACE_(READS/WRITES/UNSETS/ARRAY): makes code simpler in tclTrace.c
+ *
+ * Keep the flag values for VAR_ARGUMENT and VAR_TEMPORARY so that old values
+ * in precompiled scripts keep working.
*/
-#define VAR_SCALAR 0x1
-#define VAR_ARRAY 0x2
-#define VAR_LINK 0x4
-#define VAR_UNDEFINED 0x8
-#define VAR_IN_HASHTABLE 0x10
-#define VAR_TRACE_ACTIVE 0x20
-#define VAR_ARRAY_ELEMENT 0x40
-#define VAR_NAMESPACE_VAR 0x80
-
-#define VAR_ARGUMENT 0x100
-#define VAR_TEMPORARY 0x200
-#define VAR_RESOLVED 0x400
-#define VAR_IS_ARGS 0x800
+
+/* Type of value (0 is scalar) */
+#define VAR_ARRAY 0x1
+#define VAR_LINK 0x2
+
+/* Type of storage (0 is compiled local) */
+#define VAR_IN_HASHTABLE 0x4
+#define VAR_DEAD_HASH 0x8
+#define VAR_ARRAY_ELEMENT 0x1000
+#define VAR_NAMESPACE_VAR 0x2000
+
+#define VAR_ALL_HASH (VAR_IN_HASHTABLE|VAR_DEAD_HASH|VAR_NAMESPACE_VAR|VAR_ARRAY_ELEMENT)
+
+/* Trace and search state */
+
+#define VAR_TRACED_READ 0x10 /* TCL_TRACE_READS */
+#define VAR_TRACED_WRITE 0x20 /* TCL_TRACE_WRITES */
+#define VAR_TRACED_UNSET 0x40 /* TCL_TRACE_UNSETS */
+#define VAR_TRACED_ARRAY 0x800 /* TCL_TRACE_ARRAY */
+#define VAR_TRACE_ACTIVE 0x80
+#define VAR_SEARCH_ACTIVE 0x4000
+#define VAR_ALL_TRACES \
+ (VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_ARRAY|VAR_TRACED_UNSET)
+
+
+/* Special handling on initialisation (only CompiledLocal) */
+#define VAR_ARGUMENT 0x100 /* KEEP OLD VALUE! See tclProc.c */
+#define VAR_TEMPORARY 0x200 /* KEEP OLD VALUE! See tclProc.c */
+#define VAR_IS_ARGS 0x400
+#define VAR_RESOLVED 0x8000
/*
* Macros to ensure that various flag bits are set properly for variables.
@@ -629,22 +663,22 @@
*/
#define TclSetVarScalar(varPtr) \
- (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_SCALAR
+ (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK)
#define TclSetVarArray(varPtr) \
- (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_LINK)) | VAR_ARRAY
+ (varPtr)->flags = ((varPtr)->flags & ~VAR_LINK) | VAR_ARRAY
#define TclSetVarLink(varPtr) \
- (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_ARRAY)) | VAR_LINK
+ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_LINK
#define TclSetVarArrayElement(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT
#define TclSetVarUndefined(varPtr) \
- (varPtr)->flags |= VAR_UNDEFINED
+ (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK);\
+ (varPtr)->value.objPtr = NULL
-#define TclClearVarUndefined(varPtr) \
- (varPtr)->flags &= ~VAR_UNDEFINED
+#define TclClearVarUndefined(varPtr)
#define TclSetVarTraceActive(varPtr) \
(varPtr)->flags |= VAR_TRACE_ACTIVE
@@ -673,7 +707,7 @@
*/
#define TclIsVarScalar(varPtr) \
- ((varPtr)->flags & VAR_SCALAR)
+ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK))
#define TclIsVarLink(varPtr) \
((varPtr)->flags & VAR_LINK)
@@ -682,7 +716,7 @@
((varPtr)->flags & VAR_ARRAY)
#define TclIsVarUndefined(varPtr) \
- ((varPtr)->flags & VAR_UNDEFINED)
+ ((varPtr)->value.objPtr == NULL)
#define TclIsVarArrayElement(varPtr) \
((varPtr)->flags & VAR_ARRAY_ELEMENT)
@@ -702,24 +736,34 @@
#define TclIsVarTraceActive(varPtr) \
((varPtr)->flags & VAR_TRACE_ACTIVE)
-#define TclIsVarUntraced(varPtr) \
- ((varPtr)->tracePtr == NULL)
+#define TclIsVarTraced(varPtr) \
+ ((varPtr)->flags & VAR_ALL_TRACES)
+
+#define TclIsVarInHash(varPtr) \
+ ((varPtr)->flags & VAR_IN_HASHTABLE)
+
+#define TclIsVarDeadHash(varPtr) \
+ (((varPtr)->flags & VAR_IN_HASHTABLE) && ((varPtr)->flags & VAR_DEAD_HASH))
+
+#define TclGetVarNsPtr(varPtr) \
+ (TclIsVarInHash(varPtr) \
+ ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \
+ : NULL)
+
+#define VarHashRefCount(varPtr) \
+ ((VarInHash *) (varPtr))->refCount
/*
* Macros for direct variable access by TEBC
*/
#define TclIsVarDirectReadable(varPtr) \
- (TclIsVarScalar(varPtr) \
- && !TclIsVarUndefined(varPtr) \
- && TclIsVarUntraced(varPtr))
+ ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ)) \
+ && (varPtr)->value.objPtr)
#define TclIsVarDirectWritable(varPtr) \
- ( !(((varPtr)->flags & VAR_IN_HASHTABLE) \
- && ((varPtr)->hPtr == NULL)) \
- && TclIsVarUntraced(varPtr) \
- && (TclIsVarScalar(varPtr) \
- || TclIsVarUndefined(varPtr)))
+ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH))
+
/*
*----------------------------------------------------------------
@@ -900,6 +944,19 @@
* Tcl_CallFrame structure in tcl.h. If you change one, change the other.
*/
+/*
+ * Will be grown to contain: pointers to the varnames (allocated at the end),
+ * plus the init values for each variable (suitable to be memcopied on init)
+ */
+
+typedef struct LocalCache {
+ int refCount;
+ char *varName0;
+} LocalCache;
+
+#define localVarNames(framePtr) \
+ (&(framePtr)->localCachePtr->varName0)
+
typedef struct CallFrame {
Namespace *nsPtr; /* Points to the namespace used to resolve
* commands and global variables. */
@@ -933,7 +990,8 @@
* the number of compiled local variables
* (local variables assigned entries ["slots"]
* in the compiledLocals array below). */
- Tcl_HashTable *varTablePtr; /* Hash table containing local variables not
+ TclVarHashTable *varTablePtr;
+ /* Hash table containing local variables not
* recognized by the compiler, or created at
* execution time through, e.g., upvar.
* Initially NULL and created if needed. */
@@ -952,6 +1010,7 @@
* have some means of discovering what the
* meaning of the value is, which we do not
* specify. */
+ LocalCache *localCachePtr;
} CallFrame;
#define FRAME_IS_PROC 0x1
@@ -1736,6 +1795,14 @@
int packagePrefer; /* Current package selection mode. */
/*
+ * Hashtables for variable traces and searches
+ */
+
+ Tcl_HashTable varTraces; /* Hashtable holding the start of a variable's
+ * active trace list; varPtr is the key. */
+ Tcl_HashTable varSearches; /* Hashtable holding the start of a variable's
+ * active searches list; varPtr is the key */
+ /*
* Statistical information about the bytecode compiler and interpreter's
* operation.
*/
@@ -2307,6 +2374,8 @@
MODULE_SCOPE void TclInitNamespaceSubsystem(void);
MODULE_SCOPE void TclInitNotifier(void);
MODULE_SCOPE void TclInitObjSubsystem(void);
+MODULE_SCOPE void TclInitVarHashTable(TclVarHashTable *tablePtr,
+ Namespace *nsPtr);
MODULE_SCOPE void TclInitSubsystems(void);
MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp);
MODULE_SCOPE int TclIsLocalScalar(CONST char *src, int len);
Index: generic/tclIntDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIntDecls.h,v
retrieving revision 1.101
diff -u -r1.101 tclIntDecls.h
--- generic/tclIntDecls.h 20 Jun 2007 18:46:13 -0000 1.101
+++ generic/tclIntDecls.h 10 Jul 2007 11:53:30 -0000
@@ -123,7 +123,7 @@
#define TclDeleteVars_TCL_DECLARED
/* 12 */
EXTERN void TclDeleteVars (Interp * iPtr,
- Tcl_HashTable * tablePtr);
+ TclVarHashTable * tablePtr);
#endif
/* Slot 13 is reserved */
#ifndef TclDumpMemoryInfo_TCL_DECLARED
@@ -1066,7 +1066,7 @@
#endif /* __WIN32__ */
int (*tclCreateProc) (Tcl_Interp * interp, Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr); /* 10 */
void (*tclDeleteCompiledLocalVars) (Interp * iPtr, CallFrame * framePtr); /* 11 */
- void (*tclDeleteVars) (Interp * iPtr, Tcl_HashTable * tablePtr); /* 12 */
+ void (*tclDeleteVars) (Interp * iPtr, TclVarHashTable * tablePtr); /* 12 */
void *reserved13;
void (*tclDumpMemoryInfo) (FILE * outFile); /* 14 */
void *reserved15;
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.146
diff -u -r1.146 tclNamesp.c
--- generic/tclNamesp.c 5 Jul 2007 12:03:27 -0000 1.146
+++ generic/tclNamesp.c 10 Jul 2007 11:53:33 -0000
@@ -404,7 +404,8 @@
framePtr->numCompiledLocals = 0;
framePtr->compiledLocals = NULL;
framePtr->clientData = NULL;
-
+ framePtr->localCachePtr = NULL;
+
/*
* Push the new call frame onto the interpreter's stack of procedure call
* frames making it the current frame.
@@ -725,7 +726,7 @@
Tcl_DString *namePtr, *buffPtr;
int newEntry, nameLen;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
+
/*
* If there is no active namespace, the interpreter is being initialized.
*/
@@ -793,7 +794,7 @@
nsPtr->activationCount = 0;
nsPtr->refCount = 0;
Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
- Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
+ TclInitVarHashTable(&nsPtr->varTable, nsPtr);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
@@ -1056,7 +1057,7 @@
*/
TclDeleteNamespaceVars(nsPtr);
- Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
+ TclInitVarHashTable(&nsPtr->varTable, nsPtr);
/*
* Delete all commands in this namespace. Be careful when traversing the
@@ -2490,129 +2491,6 @@
/*
*----------------------------------------------------------------------
*
- * Tcl_FindNamespaceVar --
- *
- * Searches for a namespace variable, a variable not local to a
- * procedure. The variable can be either a scalar or an array, but may
- * not be an element of an array.
- *
- * Results:
- * Returns a token for the variable if it is found. Otherwise, if it
- * can't be found or there is an error, returns NULL and leaves an error
- * message in the interpreter's result object if "flags" contains
- * TCL_LEAVE_ERR_MSG.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Var
-Tcl_FindNamespaceVar(
- Tcl_Interp *interp, /* The interpreter in which to find the
- * variable. */
- const char *name, /* Variable's name. If it starts with "::",
- * will be looked up in global namespace.
- * Else, looked up first in contextNsPtr
- * (current namespace if contextNsPtr is
- * NULL), then in global namespace. */
- Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set.
- * Otherwise, points to namespace in which to
- * resolve name. If NULL, look up name in the
- * current namespace. */
- int flags) /* An OR'd combination of flags:
- * TCL_GLOBAL_ONLY (look up name only in
- * global namespace), TCL_NAMESPACE_ONLY (look
- * up only in contextNsPtr, or the current
- * namespace if contextNsPtr is NULL), and
- * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
- * and TCL_NAMESPACE_ONLY are given,
- * TCL_GLOBAL_ONLY is ignored. */
-{
- Interp *iPtr = (Interp *) interp;
- ResolverScheme *resPtr;
- Namespace *nsPtr[2], *cxtNsPtr;
- const char *simpleName;
- Tcl_HashEntry *entryPtr;
- Var *varPtr;
- register int search;
- int result;
- Tcl_Var var;
-
- /*
- * If this namespace has a variable resolver, then give it first crack at
- * the variable resolution. It may return a Tcl_Var value, it may signal
- * to continue onward, or it may signal an error.
- */
-
- if ((flags & TCL_GLOBAL_ONLY) != 0) {
- cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
- } else if (contextNsPtr != NULL) {
- cxtNsPtr = (Namespace *) contextNsPtr;
- } else {
- cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- }
-
- if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
- resPtr = iPtr->resolverPtr;
-
- if (cxtNsPtr->varResProc) {
- result = (*cxtNsPtr->varResProc)(interp, name,
- (Tcl_Namespace *) cxtNsPtr, flags, &var);
- } else {
- result = TCL_CONTINUE;
- }
-
- while (result == TCL_CONTINUE && resPtr) {
- if (resPtr->varResProc) {
- result = (*resPtr->varResProc)(interp, name,
- (Tcl_Namespace *) cxtNsPtr, flags, &var);
- }
- resPtr = resPtr->nextPtr;
- }
-
- if (result == TCL_OK) {
- return var;
- } else if (result != TCL_CONTINUE) {
- return (Tcl_Var) NULL;
- }
- }
-
- /*
- * Find the namespace(s) that contain the variable.
- */
-
- TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
- flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
-
- /*
- * Look for the variable in the variable table of its namespace. Be sure
- * to check both possible search paths: from the specified namespace
- * context and from the global namespace.
- */
-
- varPtr = NULL;
- for (search = 0; (search < 2) && (varPtr == NULL); search++) {
- if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
- entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, simpleName);
- if (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- }
- }
- }
- if (varPtr != NULL) {
- return (Tcl_Var) varPtr;
- } else if (flags & TCL_LEAVE_ERR_MSG) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL);
- }
- return (Tcl_Var) NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclResetShadowedCmdRefs --
*
* Called when a command is added to a namespace to check for existing
@@ -6996,25 +6874,30 @@
varPtr = TclObjLookupVar(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
NULL, 0, 0, &arrayPtr);
- if ((varPtr == NULL) || (varPtr->tracePtr == NULL)) {
+ if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
/*
* Should not happen.
*/
return;
- }
- if (varPtr->tracePtr->traceProc != EstablishErrorInfoTraces) {
- /*
- * The most recent trace set on ::errorInfo is not the one the core
- * itself puts on last. This means some other code is tracing the
- * variable, and the additional trace(s) might be write traces that
- * expect the timing of writes to ::errorInfo that existed Tcl
- * releases before 8.5. To satisfy that compatibility need, we write
- * the current -errorinfo value to the ::errorInfo variable.
- */
+ } else {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+ (char *) varPtr);
+ VarTrace *tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
- Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
- iPtr->errorInfo, TCL_GLOBAL_ONLY);
+ if (tracePtr->traceProc != EstablishErrorInfoTraces) {
+ /*
+ * The most recent trace set on ::errorInfo is not the one the core
+ * itself puts on last. This means some other code is tracing the
+ * variable, and the additional trace(s) might be write traces that
+ * expect the timing of writes to ::errorInfo that existed Tcl
+ * releases before 8.5. To satisfy that compatibility need, we write
+ * the current -errorinfo value to the ::errorInfo variable.
+ */
+
+ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
+ iPtr->errorInfo, TCL_GLOBAL_ONLY);
+ }
}
}
Index: generic/tclObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclObj.c,v
retrieving revision 1.130
diff -u -r1.130 tclObj.c
--- generic/tclObj.c 5 Jul 2007 12:03:27 -0000 1.130
+++ generic/tclObj.c 10 Jul 2007 11:53:34 -0000
@@ -3288,7 +3288,8 @@
hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
hPtr->key.oneWordValue = (char *) objPtr;
Tcl_IncrRefCount(objPtr);
-
+ hPtr->clientData = NULL;
+
return hPtr;
}
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.125
diff -u -r1.125 tclProc.c
--- generic/tclProc.c 20 Jun 2007 18:46:14 -0000 1.125
+++ generic/tclProc.c 10 Jul 2007 11:53:41 -0000
@@ -527,13 +527,17 @@
* we and out VAR_UNDEFINED to support bridging precompiled <= 8.3
* code in 8.4 where this is now used as an optimization
* indicator. Yes, this is a hack. -- hobbs
+ *
+ * FIXME! Is this right? It does depend on VAR_ARGUMENT not
+ * changing. Note that a change of VAR_TEMPORARY would not be so
+ * important, as there are no variable names in precompiled
+ * bytecodes anyway - right?
*/
if ((localPtr->nameLength != nameLength)
|| (strcmp(localPtr->name, fieldValues[0]))
|| (localPtr->frameIndex != i)
- || ((localPtr->flags & ~VAR_UNDEFINED)
- != (VAR_SCALAR | VAR_ARGUMENT))
+ || !(localPtr->flags & VAR_ARGUMENT) /* /// CHECK HERE! */
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
|| (localPtr->defValuePtr != NULL && fieldCount != 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -588,7 +592,7 @@
localPtr->nextPtr = NULL;
localPtr->nameLength = nameLength;
localPtr->frameIndex = i;
- localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
+ localPtr->flags = VAR_ARGUMENT;
localPtr->resolveInfo = NULL;
if (fieldCount == 2) {
@@ -1050,12 +1054,66 @@
const char *final;
/*
+ * Make sure that the local cache of variable names and initial values has
+ * been initialised properly .
+ */
+
+ localCt = procPtr->numCompiledLocals;
+ if (localCt == 0) {
+ framePtr->localCachePtr = NULL;
+ } else if (codePtr->localCachePtr) {
+ framePtr->localCachePtr = codePtr->localCachePtr;
+ framePtr->localCachePtr->refCount++;
+ } else {
+ /*
+ * Cache the names and initial values of local variables; store the
+ * cache in both the framePtr for this execution and in the codePtr
+ * for future calls.
+ */
+
+ char *name, **namePtr;
+ LocalCache *localCachePtr;
+ int stringLen = 0;
+
+ localPtr = codePtr->procPtr->firstLocalPtr;
+ while (localPtr) {
+ stringLen += (localPtr->nameLength + 1);
+ localPtr = localPtr->nextPtr;
+ }
+
+ localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache)
+ + (localCt-1)*sizeof(char *)
+ + localCt*sizeof(Var)
+ + stringLen*sizeof(char));
+
+ namePtr = &localCachePtr->varName0;
+ varPtr = (Var *) (namePtr + localCt);
+ name = (char *) (varPtr + localCt);
+
+ localPtr = codePtr->procPtr->firstLocalPtr;
+ while (localPtr) {
+ *namePtr = name;
+ varPtr->flags = (localPtr->flags & VAR_TEMPORARY);
+ varPtr->value.objPtr = localPtr->defValuePtr;
+ strncpy(name, localPtr->name, localPtr->nameLength);
+ name += localPtr->nameLength;
+
+ *name++ = '\0';
+ namePtr++;
+ varPtr++;
+ localPtr=localPtr->nextPtr;
+ }
+ codePtr->localCachePtr = localCachePtr;
+ framePtr->localCachePtr = localCachePtr;
+ localCachePtr->refCount = 2;
+ }
+
+ /*
* Create the "compiledLocals" array. Make sure it is large enough to hold
* all the procedure's compiled local variables, including its formal
* parameters.
*/
- localCt = procPtr->numCompiledLocals;
compiledLocals = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
framePtr->numCompiledLocals = localCt;
framePtr->compiledLocals = compiledLocals;
@@ -1089,15 +1147,9 @@
Tcl_Obj *objPtr = argObjs[i];
+ varPtr->flags = 0;
varPtr->value.objPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- varPtr->name = localPtr->name;
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = localPtr->flags;
varPtr++;
localPtr = localPtr->nextPtr;
}
@@ -1110,15 +1162,9 @@
if (localPtr->defValuePtr != NULL) {
Tcl_Obj *objPtr = localPtr->defValuePtr;
+ varPtr->flags = 0;
varPtr->value.objPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- varPtr->name = localPtr->name;
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = localPtr->flags;
varPtr++;
localPtr = localPtr->nextPtr;
} else {
@@ -1150,13 +1196,7 @@
goto incorrectArgs;
}
- varPtr->name = localPtr->name;
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = localPtr->flags;
+ varPtr->flags = 0;
localPtr = localPtr->nextPtr;
varPtr++;
@@ -1255,7 +1295,14 @@
Interp *iPtr = (Interp *) interp;
int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr);
CompiledLocal *firstLocalPtr;
+
+ /*
+ //FIXME: old bytecompiled code: drop whatever flags are coming in (except
+ //maybe for VAR_TEMPORARY? Who cares really?) A job for tbcload, not us.
+ // memcpy from the cache ... or drop that from the cache, unused.
+ */
+
if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) {
/*
* Initialize the array of local variables stored in the call frame.
@@ -1267,30 +1314,16 @@
doInitCompiledLocals:
if (!haveResolvers) {
for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
- varPtr->value.objPtr = NULL;
- varPtr->name = localPtr->name; /* Will be just '\0' if temp
- * var. */
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
varPtr->flags = localPtr->flags;
+ varPtr->value.objPtr = NULL;
}
return;
} else {
Tcl_ResolvedVarInfo *resVarInfo;
for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
- varPtr->value.objPtr = NULL;
- varPtr->name = localPtr->name; /* Will be just '\0' if temp
- * var. */
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
varPtr->flags = localPtr->flags;
+ varPtr->value.objPtr = NULL;
/*
* Now invoke the resolvers to determine the exact variables
@@ -1302,9 +1335,9 @@
Var *resolvedVarPtr = (Var *)
(*resVarInfo->fetchProc)(interp, resVarInfo);
if (resolvedVarPtr) {
- resolvedVarPtr->refCount++;
- varPtr->value.linkPtr = resolvedVarPtr;
+ VarHashRefCount(resolvedVarPtr)++;
varPtr->flags = VAR_LINK;
+ varPtr->value.linkPtr = resolvedVarPtr;
}
}
}
@@ -1437,7 +1470,8 @@
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
int result;
-
+ ByteCode *codePtr;
+
/*
* If necessary (i.e. if we haven't got a suitable compilation already
* cached) compile the procedure's body. The compiler will allocate frame
@@ -1448,7 +1482,6 @@
if (procPtr->bodyPtr->typePtr == &tclByteCodeType) {
Interp *iPtr = (Interp *) interp;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
/*
* When we've got bytecode, this is the check for validity. That is,
@@ -1459,6 +1492,7 @@
* commands and/or resolver changes are considered).
*/
+ codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1494,7 +1528,9 @@
framePtr->objc = objc;
framePtr->objv = objv;
framePtr->procPtr = procPtr;
-
+
+ codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+
return TCL_OK;
}
@@ -1566,6 +1602,8 @@
register Proc *procPtr = ((Interp *)interp)->varFramePtr->procPtr;
int result;
CallFrame *freePtr;
+ register ByteCode *codePtr =
+ procPtr->bodyPtr->internalRep.otherValuePtr;
result = InitArgsAndLocals(interp, procNameObj, skip);
if (result != TCL_OK) {
@@ -1601,9 +1639,6 @@
if (TclInterpReady(interp) == TCL_ERROR) {
result = TCL_ERROR;
} else {
- register ByteCode *codePtr =
- procPtr->bodyPtr->internalRep.otherValuePtr;
-
codePtr->refCount++;
result = TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;
@@ -1674,15 +1709,23 @@
procDone:
/*
- * Free the stack-allocated compiled locals and CallFrame. It is important
- * to pop the call frame without freeing it first: the compiledLocals
- * cannot be freed before the frame is popped, as the local variables must
- * be deleted. But the compiledLocals must be freed first, as they were
- * allocated later on the stack.
+ * Free the stack-allocated compiled locals and CallFrame. The order of
+ * these operations is important:
+ * 1. Pop the call frame. This deletes the local variables, so that they
+ * cannot be freed before this. As traces may access the local names,
+ * the localCache has to be valid too. It can be freed immediately
+ * after popping. The proc cannot go before that, as the localCache
+ * refers to its localVars.
+ * 2. Free the compiledLocals and the framePtr in reverse order of their
+ * allocation.
*/
freePtr = ((Interp *)interp)->framePtr;
Tcl_PopCallFrame(interp); /* Pop but do not free. */
+ if (freePtr->localCachePtr && (--freePtr->localCachePtr->refCount == 0)) {
+ ckfree ((char *) freePtr->localCachePtr);
+ }
+
TclStackFree(interp, freePtr->compiledLocals);
/* Free compiledLocals. */
TclStackFree(interp, freePtr); /* Free CallFrame. */
Index: generic/tclThreadStorage.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclThreadStorage.c,v
retrieving revision 1.12
diff -u -r1.12 tclThreadStorage.c
--- generic/tclThreadStorage.c 13 Nov 2006 22:39:56 -0000 1.12
+++ generic/tclThreadStorage.c 10 Jul 2007 11:53:41 -0000
@@ -136,7 +136,8 @@
hPtr = (Tcl_HashEntry *) TclpSysAlloc(sizeof(Tcl_HashEntry), 0);
hPtr->key.oneWordValue = keyPtr;
-
+ hPtr->clientData = NULL;
+
return hPtr;
}
Index: generic/tclTrace.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTrace.c,v
retrieving revision 1.41
diff -u -r1.41 tclTrace.c
--- generic/tclTrace.c 28 Jun 2007 21:10:38 -0000 1.41
+++ generic/tclTrace.c 10 Jul 2007 11:53:41 -0000
@@ -2441,8 +2441,8 @@
return NULL;
}
- if ((varPtr->tracePtr != NULL)
- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
+ if ((varPtr->flags & VAR_TRACED_READ)
+ || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) {
TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
TCL_TRACE_READS, /* leaveErrMsg */ 0);
}
@@ -2508,7 +2508,9 @@
int code = TCL_OK;
int disposeFlags = 0;
Tcl_InterpState state = NULL;
-
+ Tcl_HashEntry *hPtr;
+ int traceflags = flags & VAR_ALL_TRACES;
+
/*
* If there are already similar trace functions active for the variable,
* don't call them again.
@@ -2518,9 +2520,11 @@
return code;
}
TclSetVarTraceActive(varPtr);
- varPtr->refCount++;
- if (arrayPtr != NULL) {
- arrayPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)++;
}
/*
@@ -2572,10 +2576,12 @@
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
Tcl_Preserve((ClientData) iPtr);
- if (arrayPtr != NULL && !TclIsVarTraceActive(arrayPtr)) {
+ if (arrayPtr && !TclIsVarTraceActive(arrayPtr) && (arrayPtr->flags & traceflags)) {
+ hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+ (char *) arrayPtr);
active.varPtr = arrayPtr;
- for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
- tracePtr = active.nextTracePtr) {
+ for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
+ tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
@@ -2616,36 +2622,40 @@
flags |= TCL_TRACE_DESTROYED;
}
active.varPtr = varPtr;
- for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
- tracePtr = active.nextTracePtr) {
- active.nextTracePtr = tracePtr->nextPtr;
- if (!(tracePtr->flags & flags)) {
- continue;
- }
- Tcl_Preserve((ClientData) tracePtr);
- if (state == NULL) {
- state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
- }
- if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
- flags |= TCL_INTERP_DESTROYED;
- }
- result = (*tracePtr->traceProc)(tracePtr->clientData,
- (Tcl_Interp *) iPtr, part1, part2, flags);
- if (result != NULL) {
- if (flags & TCL_TRACE_UNSETS) {
- /*
- * Ignore errors in unset traces.
- */
-
- DisposeTraceResult(tracePtr->flags, result);
- } else {
- disposeFlags = tracePtr->flags;
- code = TCL_ERROR;
+ if (varPtr->flags & traceflags) {
+ hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+ (char *) varPtr);
+ for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
+ tracePtr != NULL; tracePtr = active.nextTracePtr) {
+ active.nextTracePtr = tracePtr->nextPtr;
+ if (!(tracePtr->flags & flags)) {
+ continue;
+ }
+ Tcl_Preserve((ClientData) tracePtr);
+ if (state == NULL) {
+ state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
+ }
+ if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
+ flags |= TCL_INTERP_DESTROYED;
+ }
+ result = (*tracePtr->traceProc)(tracePtr->clientData,
+ (Tcl_Interp *) iPtr, part1, part2, flags);
+ if (result != NULL) {
+ if (flags & TCL_TRACE_UNSETS) {
+ /*
+ * Ignore errors in unset traces.
+ */
+
+ DisposeTraceResult(tracePtr->flags, result);
+ } else {
+ disposeFlags = tracePtr->flags;
+ code = TCL_ERROR;
+ }
+ }
+ Tcl_Release((ClientData) tracePtr);
+ if (code == TCL_ERROR) {
+ goto done;
}
- }
- Tcl_Release((ClientData) tracePtr);
- if (code == TCL_ERROR) {
- goto done;
}
}
@@ -2718,14 +2728,16 @@
}
}
- if (arrayPtr != NULL) {
- arrayPtr->refCount--;
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)--;
}
if (copiedName) {
Tcl_DStringFree(&nameCopy);
}
TclClearVarTraceActive(varPtr);
- varPtr->refCount--;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
iPtr->activeVarTracePtr = active.nextPtr;
Tcl_Release((ClientData) iPtr);
return code;
@@ -2827,11 +2839,12 @@
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
register VarTrace *tracePtr;
- VarTrace *prevPtr;
+ VarTrace *prevPtr, *nextPtr;
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
ActiveVarTrace *activePtr;
- int flagMask;
+ int flagMask, allFlags = 0;
+ Tcl_HashEntry *hPtr;
/*
* Set up a mask to mask out the parts of the flags that we are not
@@ -2856,15 +2869,19 @@
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
flags &= flagMask;
- for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
+
+ hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+ (char *) varPtr);
+ for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
- return;
+ goto updateFlags;
}
if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
&& (tracePtr->clientData == clientData)) {
break;
}
+ allFlags |= tracePtr->flags;
}
/*
@@ -2879,19 +2896,32 @@
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
+ nextPtr = tracePtr->nextPtr;
if (prevPtr == NULL) {
- varPtr->tracePtr = tracePtr->nextPtr;
+ if (nextPtr) {
+ Tcl_SetHashValue(hPtr, nextPtr);
+ } else {
+ Tcl_DeleteHashEntry(hPtr);
+ }
} else {
- prevPtr->nextPtr = tracePtr->nextPtr;
+ prevPtr->nextPtr = nextPtr;
}
Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
- /*
- * If this is the last trace on the variable, and the variable is unset
- * and unused, then free up the variable.
- */
-
- if (TclIsVarUndefined(varPtr)) {
+ for (tracePtr = nextPtr; tracePtr != NULL;
+ tracePtr = tracePtr->nextPtr) {
+ allFlags |= tracePtr->flags;
+ }
+
+ updateFlags:
+ varPtr->flags &= ~VAR_ALL_TRACES;
+ if (allFlags & VAR_ALL_TRACES) {
+ varPtr->flags |= (allFlags & VAR_ALL_TRACES);
+ } else if (TclIsVarUndefined(varPtr)) {
+ /*
+ * If this is the last trace on the variable, and the variable is
+ * unset and unused, then free up the variable.
+ */
TclCleanupVar(varPtr, NULL);
}
}
@@ -2968,8 +2998,10 @@
* next trace after that one. If NULL, this
* call will return the first trace. */
{
+ Interp *iPtr = (Interp *) interp;
register VarTrace *tracePtr;
Var *varPtr, *arrayPtr;
+ Tcl_HashEntry *hPtr;
varPtr = TclLookupVar(interp, part1, part2,
flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ NULL,
@@ -2982,19 +3014,25 @@
* Find the relevant trace, if any, and return its clientData.
*/
- tracePtr = varPtr->tracePtr;
- if (prevClientData != NULL) {
- for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
- if ((tracePtr->clientData == prevClientData)
- && (tracePtr->traceProc == proc)) {
- tracePtr = tracePtr->nextPtr;
- break;
+ hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+ (char *) varPtr);
+
+ if (hPtr) {
+ tracePtr = Tcl_GetHashValue(hPtr);
+
+ if (prevClientData != NULL) {
+ for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
+ if ((tracePtr->clientData == prevClientData)
+ && (tracePtr->traceProc == proc)) {
+ tracePtr = tracePtr->nextPtr;
+ break;
+ }
}
}
- }
- for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) {
- if (tracePtr->traceProc == proc) {
- return tracePtr->clientData;
+ for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) {
+ if (tracePtr->traceProc == proc) {
+ return tracePtr->clientData;
+ }
}
}
return NULL;
@@ -3016,6 +3054,7 @@
* A trace is set up on the variable given by varName, such that future
* references to the variable will be intermediated by proc. See the
* manual entry for complete details on the calling sequence for proc.
+ * The variable's flags are updated.
*
*----------------------------------------------------------------------
*/
@@ -3053,7 +3092,7 @@
* A trace is set up on the variable given by part1 and part2, such that
* future references to the variable will be intermediated by proc. See
* the manual entry for complete details on the calling sequence for
- * proc.
+ * proc. The variable's flags are updated.
*
*----------------------------------------------------------------------
*/
@@ -3126,8 +3165,11 @@
* caller to free if this function returns
* TCL_ERROR. */
{
+ Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
int flagMask;
+ Tcl_HashEntry *hPtr;
+ int new;
/*
* We strip 'flags' down to just the parts which are relevant to
@@ -3164,8 +3206,18 @@
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
tracePtr->flags = tracePtr->flags & flagMask;
- tracePtr->nextPtr = varPtr->tracePtr;
- varPtr->tracePtr = tracePtr;
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->varTraces,
+ (char *) varPtr, &new);
+ if (new) {
+ tracePtr->nextPtr = NULL;
+ } else {
+ tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr);
+ }
+ Tcl_SetHashValue(hPtr, (char *) tracePtr);
+
+ varPtr->flags |= (tracePtr->flags & VAR_ALL_TRACES);
+
return TCL_OK;
}
Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.144
diff -u -r1.144 tclVar.c
--- generic/tclVar.c 28 Jun 2007 13:56:21 -0000 1.144
+++ generic/tclVar.c 10 Jul 2007 11:53:41 -0000
@@ -11,6 +11,7 @@
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2007 Miguel Sofer
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -20,6 +21,85 @@
#include "tclInt.h"
+ /*
+ * Prototypes for the variable hash key methods.
+ */
+
+static Tcl_HashEntry * AllocVarEntry(Tcl_HashTable *tablePtr,
+ VOID *keyPtr);
+static void FreeVarEntry(Tcl_HashEntry *hPtr);
+static int CompareVarKeys(VOID *keyPtr, Tcl_HashEntry *hPtr);
+static unsigned int HashVarKey(Tcl_HashTable *tablePtr, VOID *keyPtr);
+
+Tcl_HashKeyType tclVarHashKeyType = {
+ TCL_HASH_KEY_TYPE_VERSION, /* version */
+ 0, /* flags */
+ HashVarKey, /* hashKeyProc */
+ CompareVarKeys, /* compareKeysProc */
+ AllocVarEntry, /* allocEntryProc */
+ FreeVarEntry /* freeEntryProc */
+};
+
+static Var *
+VarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr)
+{
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, key, newPtr);
+ if (hPtr) {
+ return (Var *) Tcl_GetHashValue(hPtr);
+ } else {
+ return (Var *) NULL;
+ }
+}
+
+#define VarHashFindVar(tablePtr, key) \
+ VarHashCreateVar((tablePtr), (key), NULL)
+
+#define VarHashInvalidateEntry(varPtr) \
+ ((varPtr)->flags |= VAR_DEAD_HASH)
+
+#define VarHashDeleteEntry(varPtr) \
+ Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry))
+
+static Var *
+VarHashFirstVar(TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr)
+{
+ Tcl_HashEntry *hPtr = Tcl_FirstHashEntry((Tcl_HashTable *)tablePtr, searchPtr);
+ if (hPtr) {
+ return (Var *) Tcl_GetHashValue(hPtr);
+ } else {
+ return (Var *) NULL;
+ }
+}
+
+static Var *
+VarHashNextVar(Tcl_HashSearch *searchPtr)
+{
+ Tcl_HashEntry *hPtr = Tcl_NextHashEntry(searchPtr);
+ if (hPtr) {
+ return (Var *) Tcl_GetHashValue(hPtr);
+ } else {
+ return (Var *) NULL;
+ }
+}
+
+#define VarHashGetKey(varPtr) \
+ ((char *) Tcl_GetHashKey(\
+ (Tcl_HashTable *)((((VarInHash *) (varPtr))->entry.tablePtr)), \
+ &((VarInHash *) (varPtr))->entry))
+
+#define VarHashDeleteTable(tablePtr) \
+ Tcl_DeleteHashTable((Tcl_HashTable *) (tablePtr))
+
+#define VarHashGetValue(hPtr) \
+ Tcl_GetHashValue((hPtr))
+
+#define VarHashFirstEntry(tablePtr, searchPtr) \
+ Tcl_FirstHashEntry((Tcl_HashTable *) (tablePtr), (searchPtr))
+
+#define VarHashNextEntry(searchPtr) \
+ Tcl_NextHashEntry((searchPtr))
+
+
/*
* The strings below are used to indicate what went wrong when a variable
* access is denied.
@@ -37,7 +117,8 @@
static const char *missingName = "missing variable name";
static const char *isArrayElement =
"name refers to an element in an array";
-
+
+
/*
* A test to see if we are in a call frame that has local variables. This is
* true if we are inside a procedure body.
@@ -49,19 +130,18 @@
* Forward references to functions defined later in this file:
*/
-static void DeleteSearches(Var *arrayVarPtr);
+static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
static void DeleteArray(Interp *iPtr, const char *arrayName,
Var *varPtr, int flags);
static int ObjMakeUpvar(Tcl_Interp *interp,
CallFrame *framePtr, Tcl_Obj *otherP1Ptr,
const char *otherP2, const int otherFlags,
const char *myName, int myFlags, int index);
-static Var * NewVar(void);
static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
const char *varName, Tcl_Obj *handleObj);
static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
Interp *iPtr, const char *part1,
- const char *part2, int flags, int reachable);
+ const char *part2, int flags);
static int SetArraySearchObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
/*
@@ -145,6 +225,7 @@
"array search",
NULL, NULL, NULL, SetArraySearchObj
};
+
/*
*----------------------------------------------------------------------
@@ -404,16 +485,17 @@
if (typePtr == &localVarNameType) {
int localIndex = (int) part1Ptr->internalRep.longValue;
-
+
if (HasLocalVars(varFramePtr)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
/*
* use the cached index if the names coincide.
*/
+ char *name = localVarNames(iPtr->varFramePtr)[localIndex];
- varPtr = &(varFramePtr->compiledLocals[localIndex]);
- if ((varPtr->name != NULL) && (strcmp(part1, varPtr->name) == 0)) {
+ if (name && (strcmp(part1, name) == 0)) {
+ varPtr = (Var *) &(varFramePtr->compiledLocals[localIndex]);
goto donePart1;
}
}
@@ -438,14 +520,14 @@
*/
!TclIsVarUndefined(varPtr))));
- if (useReference && (varPtr->hPtr != NULL)) {
+ 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 (varPtr->hPtr == NULL), this might be a reference to a
+ * 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
@@ -676,14 +758,13 @@
* variables are currently in use. Same as the
* current procedure's frame, if any, unless
* an "uplevel" is executing. */
- Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which
+ TclVarHashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
- Tcl_HashEntry *hPtr;
int new, i, result;
varPtr = NULL;
@@ -771,13 +852,9 @@
* otherwise generate our own error!
*/
- var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
+ varPtr = (Var *) Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
flags & ~TCL_LEAVE_ERR_MSG);
- if (var != (Tcl_Var) NULL) {
- varPtr = (Var *) var;
- }
-
if (varPtr == NULL) {
if (create) { /* var wasn't found so create it */
TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
@@ -790,11 +867,7 @@
*errMsgPtr = missingName;
return NULL;
}
- hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = varNsPtr;
+ varPtr = VarHashCreateVar(&varNsPtr->varTable, tail, &new);
if (lookGlobal) {
/*
* The variable was created starting from the global
@@ -815,49 +888,36 @@
Proc *procPtr = varFramePtr->procPtr;
int localCt = procPtr->numCompiledLocals;
CompiledLocal *localPtr = procPtr->firstLocalPtr;
- Var *localVarPtr = varFramePtr->compiledLocals;
int varNameLen = strlen(varName);
for (i=0 ; i<localCt ; i++) {
if (!TclIsVarTemporary(localPtr)) {
- register char *localName = localVarPtr->name;
+ char *localName = localPtr->name;
if ((varName[0] == localName[0])
&& (varNameLen == localPtr->nameLength)
&& (strcmp(varName, localName) == 0)) {
*indexPtr = i;
- return localVarPtr;
+ return (Var *) &varFramePtr->compiledLocals[i];
}
}
- localVarPtr++;
localPtr = localPtr->nextPtr;
}
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
- tablePtr = (Tcl_HashTable *)
- ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
+ tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable));
+ TclInitVarHashTable(tablePtr, NULL);
varFramePtr->varTablePtr = tablePtr;
}
- hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
- if (new) {
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = NULL; /* a local variable */
- } else {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- }
+ varPtr = VarHashCreateVar(tablePtr, varName, &new);
} else {
- hPtr = NULL;
+ varPtr = NULL;
if (tablePtr != NULL) {
- hPtr = Tcl_FindHashEntry(tablePtr, varName);
+ varPtr = VarHashFindVar(tablePtr, varName);
}
- if (hPtr == NULL) {
+ if (varPtr == NULL) {
*errMsgPtr = noSuchVar;
- return NULL;
}
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
}
return varPtr;
@@ -918,10 +978,11 @@
* return error if it doesn't exist. */
Var *arrayPtr) /* Pointer to the array's Var structure. */
{
- Tcl_HashEntry *hPtr;
int new;
Var *varPtr;
-
+ TclVarHashTable *tablePtr;
+ Namespace *nsPtr;
+
/*
* We're dealing with an array element. Make sure the variable is an array
* and look up the element (create the element if desired).
@@ -940,7 +1001,7 @@
* deleted namespace!
*/
- if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
+ if (TclIsVarDeadHash(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclVarErrMsg(interp, arrayName, elName, msg, danglingVar);
}
@@ -949,9 +1010,15 @@
TclSetVarArray(arrayPtr);
TclClearVarUndefined(arrayPtr);
- arrayPtr->value.tablePtr = (Tcl_HashTable *)
- ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
+ tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable));
+ arrayPtr->value.tablePtr = tablePtr;
+
+ if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) {
+ nsPtr = TclGetVarNsPtr(arrayPtr);
+ } else {
+ nsPtr = NULL;
+ }
+ TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr);
} else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclVarErrMsg(interp, arrayName, elName, msg, needArray);
@@ -960,29 +1027,24 @@
}
if (createElem) {
- hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new);
+ varPtr = VarHashCreateVar(arrayPtr->value.tablePtr, elName, &new);
if (new) {
- if (arrayPtr->searchPtr != NULL) {
- DeleteSearches(arrayPtr);
+ if (arrayPtr->flags & VAR_SEARCH_ACTIVE) {
+ DeleteSearches((Interp *) interp, arrayPtr);
}
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = arrayPtr->nsPtr;
TclSetVarArrayElement(varPtr);
}
} else {
- hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName);
- if (hPtr == NULL) {
+ varPtr = VarHashFindVar(arrayPtr->value.tablePtr, elName);
+ if (varPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclVarErrMsg(interp, arrayName, elName, msg, noSuchElement);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", elName,
NULL);
}
- return NULL;
}
}
- return (Var *) Tcl_GetHashValue(hPtr);
+ return varPtr;
}
/*
@@ -1203,11 +1265,11 @@
const char *msg;
/*
- * Invoke any traces that have been set for the variable.
+ * Invoke any read traces that have been set for the variable.
*/
- if ((varPtr->tracePtr != NULL)
- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
+ if ((varPtr->flags & VAR_TRACED_READ)
+ || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) {
if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
(flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
| TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
@@ -1224,7 +1286,7 @@
}
if (flags & TCL_LEAVE_ERR_MSG) {
- if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL)
+ if (TclIsVarUndefined(varPtr) && arrayPtr
&& !TclIsVarUndefined(arrayPtr)) {
msg = noSuchElement;
} else if (TclIsVarArray(varPtr)) {
@@ -1577,7 +1639,7 @@
* allocation and is meaningless anyway).
*/
- if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
+ if (TclIsVarDeadHash(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArrayElement(varPtr)) {
TclVarErrMsg(interp, part1, part2, "set", danglingElement);
@@ -1605,8 +1667,8 @@
* instructions.
*/
- if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL)
- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
+ if ((flags & TCL_TRACE_READS) && ((varPtr->flags & VAR_TRACED_READ)
+ || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ)))) {
if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
goto earlyError;
@@ -1620,10 +1682,10 @@
* otherwise we must create a new copy to modify: this is "copy on write".
*/
+ oldValuePtr = varPtr->value.objPtr;
if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) {
- TclSetVarUndefined(varPtr);
+ varPtr->value.objPtr = NULL;
}
- oldValuePtr = varPtr->value.objPtr;
if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
TclDecrRefCount(oldValuePtr); /* discard old value */
@@ -1682,20 +1744,16 @@
}
}
TclSetVarScalar(varPtr);
- TclClearVarUndefined(varPtr);
- if (arrayPtr != NULL) {
- TclClearVarUndefined(arrayPtr);
- }
-
+
/*
* Invoke any write traces for the variable.
*/
- if ((varPtr->tracePtr != NULL)
- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
+ if ((varPtr->flags & VAR_TRACED_WRITE)
+ || (arrayPtr && (arrayPtr->flags & VAR_TRACED_WRITE))) {
if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
- | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))|TCL_TRACE_WRITES,
+ (flags & TCL_LEAVE_ERR_MSG))) {
goto cleanup;
}
}
@@ -1843,9 +1901,13 @@
register Tcl_Obj *varValuePtr, *newValuePtr = NULL;
int duplicated, code;
- varPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
- varPtr->refCount--;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
if (varValuePtr == NULL) {
varValuePtr = Tcl_NewIntObj(0);
}
@@ -1996,9 +2058,11 @@
* the variable's name.
*/
- varPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
- UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags, 1);
+ UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags);
/*
* It's an error to unset an undefined variable.
@@ -2030,8 +2094,10 @@
* its value object, if any, was decremented above.
*/
- varPtr->refCount--;
- TclCleanupVar(varPtr, arrayPtr);
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ TclCleanupVar(varPtr, arrayPtr);
+ }
return result;
}
@@ -2062,20 +2128,19 @@
const char *part1, /* NULL if it is to be computed on demand, only for
* variables in a hashtable */
const char *part2,
- int flags,
- int reachable) /* indicates if the variable is accessible by name */
+ int flags)
{
Var dummyVar;
- Var *dummyVarPtr;
- ActiveVarTrace *activePtr;
- Tcl_Obj *part1Ptr = NULL;
- int traced = !TclIsVarUntraced(varPtr)
- || (arrayPtr && !TclIsVarUntraced(arrayPtr));
-
- if (arrayPtr && arrayPtr->searchPtr) {
- DeleteSearches(arrayPtr);
+ int traced = TclIsVarTraced(varPtr)
+ || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET));
+
+ if (arrayPtr && (arrayPtr->flags & VAR_SEARCH_ACTIVE)) {
+ DeleteSearches(iPtr, arrayPtr);
+ } else if (varPtr->flags & VAR_SEARCH_ACTIVE) {
+ DeleteSearches(iPtr, varPtr);
}
+
/*
* The code below is tricky, because of the possibility that a trace
* function might try to access a variable being deleted. To handle this
@@ -2088,18 +2153,10 @@
* gotten recreated by a trace).
*/
- if (reachable && (traced || TclIsVarArray(varPtr))) {
- dummyVar = *varPtr;
- dummyVarPtr = &dummyVar;
- TclSetVarUndefined(varPtr);
- TclSetVarScalar(varPtr);
- varPtr->value.objPtr = NULL; /* dummyVar points to any value object */
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- } else {
- dummyVarPtr = varPtr;
- }
-
+ dummyVar = *varPtr;
+ dummyVar.flags &= ~VAR_ALL_HASH;
+ TclSetVarUndefined(varPtr);
+
/*
* Call trace functions for the variable being deleted. Then delete its
* traces. Be sure to abort any other traces for the variable that are
@@ -2111,65 +2168,85 @@
*/
if (traced) {
- /*
- * Get the variable's name if NULL was passed;
- */
+ VarTrace *tracePtr = NULL;
+ Tcl_HashEntry *tPtr = NULL;
- if (part1 == NULL) {
- Tcl_Interp *interp = (Tcl_Interp *) iPtr;
- TclNewObj(part1Ptr);
- Tcl_IncrRefCount(part1Ptr);
- Tcl_GetVariableFullName(interp, (Tcl_Var) dummyVarPtr, part1Ptr);
- part1 = TclGetString(part1Ptr);
+ if (TclIsVarTraced(&dummyVar)) {
+ /*
+ * Transfer any existing traces on var, IF there are unset
+ * traces. Otherwise just delete them.
+ */
+
+ int new;
+ Tcl_HashEntry *tPtr =
+ Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
+
+ tracePtr = Tcl_GetHashValue(tPtr);
+ varPtr->flags &= ~VAR_ALL_TRACES;
+ Tcl_DeleteHashEntry(tPtr);
+ if (dummyVar.flags & VAR_TRACED_UNSET) {
+ tPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) &dummyVar, &new);
+ Tcl_SetHashValue(tPtr, tracePtr);
+ } else {
+ tPtr = NULL;
+ }
}
+
+ if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr->flags & VAR_TRACED_UNSET)) {
+ Tcl_Obj *part1Ptr = NULL;
+
+ if (part1 == NULL) {
+ /*
+ * Get the variable's name
+ */
+
+ Tcl_Interp *interp = (Tcl_Interp *) iPtr;
+ TclNewObj(part1Ptr);
+ Tcl_IncrRefCount(part1Ptr);
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, part1Ptr);
+ part1 = TclGetString(part1Ptr);
+ }
- dummyVarPtr->flags &= ~VAR_TRACE_ACTIVE;
- TclCallVarTraces(iPtr, arrayPtr, dummyVarPtr, part1, part2, (flags
- & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
- | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
- while (dummyVarPtr->tracePtr != NULL) {
- VarTrace *tracePtr = dummyVarPtr->tracePtr;
- dummyVarPtr->tracePtr = tracePtr->nextPtr;
- Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
- }
- for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
- activePtr = activePtr->nextPtr) {
- if (activePtr->varPtr == varPtr) {
- activePtr->nextTracePtr = NULL;
+ dummyVar.flags &= ~VAR_TRACE_ACTIVE;
+ TclCallVarTraces(iPtr, arrayPtr, (Var *) &dummyVar, part1, part2,
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))| TCL_TRACE_UNSETS,
+ /* leaveErrMsg */ 0);
+
+ if (part1Ptr) {
+ Tcl_DecrRefCount(part1Ptr);
+ part1 = NULL;
+ }
+ if (tPtr) {
+ Tcl_DeleteHashEntry(tPtr);
}
}
- if (part1Ptr) {
- Tcl_DecrRefCount(part1Ptr);
- part1 = NULL;
+
+ if (tracePtr) {
+ ActiveVarTrace *activePtr;
+
+ while (tracePtr) {
+ VarTrace *prevPtr = tracePtr;
+ tracePtr = tracePtr->nextPtr;
+ Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC);
+ }
+ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
+ activePtr = activePtr->nextPtr) {
+ if (activePtr->varPtr == varPtr) {
+ activePtr->nextTracePtr = NULL;
+ }
+ }
}
}
+
- if (TclIsVarScalar(dummyVarPtr)
- && (dummyVarPtr->value.objPtr != NULL)) {
+ if (TclIsVarScalar(&dummyVar) && (dummyVar.value.objPtr != NULL)) {
/*
* Decrement the ref count of the var's value
*/
- Tcl_Obj *objPtr = dummyVarPtr->value.objPtr;
+ Tcl_Obj *objPtr = dummyVar.value.objPtr;
TclDecrRefCount(objPtr);
- dummyVarPtr->value.objPtr = NULL;
- } else if (TclIsVarLink(varPtr)) {
- /*
- * For global/upvar variables referenced in procedures, decrement the
- * reference count on the variable referred to, and free the
- * referenced variable if it's no longer needed.
- */
- Var *linkPtr = varPtr->value.linkPtr;
- linkPtr->refCount--;
- if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
- && (linkPtr->tracePtr == NULL)
- && (linkPtr->flags & VAR_IN_HASHTABLE)) {
- if (linkPtr->hPtr != NULL) {
- Tcl_DeleteHashEntry(linkPtr->hPtr);
- }
- ckfree((char *) linkPtr);
- }
- } else if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) {
+ } else if (TclIsVarArray(&dummyVar) && !TclIsVarUndefined(&dummyVar)) {
/*
* If the variable is an array, delete all of its elements. This must
* be done after calling and deleting the traces on the array, above
@@ -2178,16 +2255,22 @@
* computed at DeleteArray.
*/
- DeleteArray(iPtr, part1, dummyVarPtr, (flags
+ DeleteArray(iPtr, part1, (Var *) &dummyVar, (flags
& (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_UNSETS);
+ } else if (TclIsVarLink(&dummyVar)) {
+ /*
+ * For global/upvar variables referenced in procedures, decrement the
+ * reference count on the variable referred to, and free the
+ * referenced variable if it's no longer needed.
+ */
+ Var *linkPtr = dummyVar.value.linkPtr;
+ if (TclIsVarInHash(linkPtr)) {
+ VarHashRefCount(linkPtr)--;
+ TclCleanupVar(linkPtr, NULL);
+ }
}
- if (dummyVarPtr == varPtr) {
- TclSetVarUndefined(varPtr);
- TclSetVarScalar(varPtr);
- }
-
/*
* If the variable was a namespace variable, decrement its reference
* count.
@@ -2195,7 +2278,7 @@
if (TclIsVarNamespaceVar(varPtr)) {
TclClearVarNamespaceVar(varPtr);
- varPtr->refCount--;
+ VarHashRefCount(varPtr)--;
}
}
@@ -2414,16 +2497,20 @@
if (varPtr == NULL) {
return TCL_ERROR;
}
- varPtr->refCount++;
- if (arrayPtr != NULL) {
- arrayPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)++;
}
part1 = TclGetString(objv[1]);
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL,
TCL_LEAVE_ERR_MSG);
- varPtr->refCount--;
- if (arrayPtr != NULL) {
- arrayPtr->refCount--;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)--;
}
if (varValuePtr == NULL) {
@@ -2546,7 +2633,7 @@
* array get, etc.
*/
- if (varPtr != NULL && varPtr->tracePtr != NULL
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, varName,
NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
@@ -2586,7 +2673,7 @@
Var *varPtr2;
if (searchPtr->nextEntry != NULL) {
- varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
+ varPtr2 = VarHashGetValue(searchPtr->nextEntry);
if (!TclIsVarUndefined(varPtr2)) {
break;
}
@@ -2614,10 +2701,16 @@
if (searchPtr == NULL) {
return TCL_ERROR;
}
- if (varPtr->searchPtr == searchPtr) {
- varPtr->searchPtr = searchPtr->nextPtr;
+ hPtr = Tcl_FindHashEntry(&iPtr->varSearches,(char *) varPtr);
+ if (searchPtr == Tcl_GetHashValue(hPtr)) {
+ if (searchPtr->nextPtr) {
+ Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
+ } else {
+ varPtr->flags &= ~VAR_SEARCH_ACTIVE;
+ Tcl_DeleteHashEntry(hPtr);
+ }
} else {
- for (prevPtr=varPtr->searchPtr ;; prevPtr=prevPtr->nextPtr) {
+ for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
if (prevPtr->nextPtr == searchPtr) {
prevPtr->nextPtr = searchPtr->nextPtr;
break;
@@ -2630,6 +2723,7 @@
case ARRAY_NEXTELEMENT: {
ArraySearch *searchPtr;
Tcl_HashEntry *hPtr;
+ Var *varPtr2;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
@@ -2643,8 +2737,6 @@
return TCL_ERROR;
}
while (1) {
- Var *varPtr2;
-
hPtr = searchPtr->nextEntry;
if (hPtr == NULL) {
hPtr = Tcl_NextHashEntry(&searchPtr->search);
@@ -2654,17 +2746,18 @@
} else {
searchPtr->nextEntry = NULL;
}
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ varPtr2 = VarHashGetValue(hPtr);
if (!TclIsVarUndefined(varPtr2)) {
break;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1));
+ VarHashGetKey(varPtr2), -1));
break;
}
case ARRAY_STARTSEARCH: {
ArraySearch *searchPtr;
+ int new;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
@@ -2674,21 +2767,25 @@
goto error;
}
searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
- if (varPtr->searchPtr == NULL) {
+ hPtr = Tcl_CreateHashEntry(&iPtr->varSearches,
+ (char *) varPtr, &new);
+ if (new) {
searchPtr->id = 1;
Tcl_AppendResult(interp, "s-1-", varName, NULL);
+ varPtr->flags |= VAR_SEARCH_ACTIVE;
+ searchPtr->nextPtr = NULL;
} else {
char string[TCL_INTEGER_SPACE];
- searchPtr->id = varPtr->searchPtr->id + 1;
+ searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
TclFormatInt(string, searchPtr->id);
Tcl_AppendResult(interp, "s-", string, "-", varName, NULL);
+ searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
}
searchPtr->varPtr = varPtr;
- searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
+ searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
&searchPtr->search);
- searchPtr->nextPtr = varPtr->searchPtr;
- varPtr->searchPtr = searchPtr;
+ Tcl_SetHashValue(hPtr, searchPtr);
break;
}
@@ -2725,11 +2822,10 @@
TclNewObj(nameLstPtr);
Tcl_IncrRefCount(nameLstPtr);
if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
- hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern);
- if (hPtr == NULL) {
+ varPtr2 = VarHashFindVar(varPtr->value.tablePtr, pattern);
+ if (varPtr2 == NULL) {
goto searchDone;
}
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
if (TclIsVarUndefined(varPtr2)) {
goto searchDone;
}
@@ -2741,13 +2837,12 @@
}
goto searchDone;
}
- for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
+ varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
if (TclIsVarUndefined(varPtr2)) {
continue;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
+ name = VarHashGetKey(varPtr2);
if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
continue; /* element name doesn't match pattern */
}
@@ -2767,7 +2862,9 @@
* while we're working.
*/
- varPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
/*
* Get the array values corresponding to each element name
@@ -2808,13 +2905,17 @@
goto errorInArrayGet;
}
}
- varPtr->refCount--;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
Tcl_SetObjResult(interp, tmpResPtr);
TclDecrRefCount(nameLstPtr);
break;
errorInArrayGet:
- varPtr->refCount--;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
TclDecrRefCount(nameLstPtr);
TclDecrRefCount(tmpResPtr); /* free unneeded temp result */
return result;
@@ -2852,9 +2953,9 @@
TclNewObj(resultPtr);
if (((enum options) mode)==OPT_GLOB && pattern!=NULL &&
TclMatchIsTrivial(pattern)) {
- hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern);
- if ((hPtr != NULL) &&
- !TclIsVarUndefined((Var *) Tcl_GetHashValue(hPtr))) {
+ varPtr2 = VarHashFindVar(varPtr->value.tablePtr, pattern);
+ if ((varPtr2 != NULL) &&
+ !TclIsVarUndefined(varPtr2)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(pattern, -1));
if (result != TCL_OK) {
@@ -2865,13 +2966,12 @@
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
- for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
+ varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
if (TclIsVarUndefined(varPtr2)) {
continue;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
+ name = VarHashGetKey(varPtr2);
if (objc > 3) {
switch ((enum options) mode) {
case OPT_EXACT:
@@ -2934,20 +3034,19 @@
} else {
pattern = TclGetString(objv[3]);
if (TclMatchIsTrivial(pattern)) {
- hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern);
- if (hPtr != NULL &&
- !TclIsVarUndefined((Var *)Tcl_GetHashValue(hPtr))){
+ varPtr2 = VarHashFindVar(varPtr->value.tablePtr, pattern);
+ if (varPtr2 != NULL &&
+ !TclIsVarUndefined(varPtr2)) {
return TclObjUnsetVar2(interp, varNamePtr, pattern, 0);
}
return TCL_OK;
}
- for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
+ varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
if (TclIsVarUndefined(varPtr2)) {
continue;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
+ name = VarHashGetKey(varPtr2);
if (Tcl_StringMatch(name, pattern) &&
TclObjUnsetVar2(interp, varNamePtr, name,
0) != TCL_OK) {
@@ -2975,9 +3074,8 @@
*/
if (!notArray) {
- for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
+ varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
if (TclIsVarUndefined(varPtr2)) {
continue;
}
@@ -2995,7 +3093,7 @@
goto error;
}
- stats = Tcl_HashStats(varPtr->value.tablePtr);
+ stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
if (stats != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
ckfree((void *)stats);
@@ -3180,9 +3278,9 @@
}
TclSetVarArray(varPtr);
TclClearVarUndefined(varPtr);
- varPtr->value.tablePtr = (Tcl_HashTable *)
- ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
+ varPtr->value.tablePtr = (TclVarHashTable *)
+ ckalloc(sizeof(TclVarHashTable));
+ TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
return TCL_OK;
}
@@ -3259,7 +3357,9 @@
*/
if (index < 0) {
- if (((arrayPtr ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
+ if (((arrayPtr
+ ? (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr))
+ : (TclIsVarInHash(otherPtr) && TclGetVarNsPtr(otherPtr))) == 0)
&& ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
|| (varFramePtr == NULL)
|| !HasLocalVars(varFramePtr)
@@ -3316,8 +3416,8 @@
if (!HasLocalVars(varFramePtr)) {
Tcl_Panic("ObjMakeUpvar called with an index outside from a proc");
}
- varPtr = &(varFramePtr->compiledLocals[index]);
- myName = varPtr->name;
+ varPtr = (Var *) &(varFramePtr->compiledLocals[index]);
+ myName = localVarNames(iPtr->varFramePtr)[index];
} else {
/*
* Do not permit the new variable to look like an array reference, as
@@ -3364,7 +3464,7 @@
return TCL_ERROR;
}
- if (varPtr->tracePtr != NULL) {
+ if (TclIsVarTraced(varPtr)) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
"\" has traces: can't use for upvar", NULL);
return TCL_ERROR;
@@ -3381,9 +3481,11 @@
if (linkPtr == otherPtr) {
return TCL_OK;
}
- linkPtr->refCount--;
- if (TclIsVarUndefined(linkPtr)) {
- TclCleanupVar(linkPtr, NULL);
+ if (TclIsVarInHash(linkPtr)) {
+ VarHashRefCount(linkPtr)--;
+ if (TclIsVarUndefined(linkPtr)) {
+ TclCleanupVar(linkPtr, NULL);
+ }
}
} else {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
@@ -3394,7 +3496,9 @@
TclSetVarLink(varPtr);
TclClearVarUndefined(varPtr);
varPtr->value.linkPtr = otherPtr;
- otherPtr->refCount++;
+ if (TclIsVarInHash(otherPtr)) {
+ VarHashRefCount(otherPtr)++;
+ }
return TCL_OK;
}
@@ -3514,24 +3618,31 @@
Interp *iPtr = (Interp *) interp;
register Var *varPtr = (Var *) variable;
char *name;
+ Namespace *nsPtr;
/*
* Add the full name of the containing namespace (if any), followed by the
* "::" separator, then the variable name.
*/
- if (varPtr != NULL) {
+ if (varPtr) {
if (!TclIsVarArrayElement(varPtr)) {
- if (varPtr->nsPtr != NULL) {
- Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1);
- if (varPtr->nsPtr != iPtr->globalNsPtr) {
+ nsPtr = TclGetVarNsPtr(varPtr);
+ if (nsPtr) {
+ Tcl_AppendToObj(objPtr, nsPtr->fullName, -1);
+ if (nsPtr != iPtr->globalNsPtr) {
Tcl_AppendToObj(objPtr, "::", 2);
}
}
- if (varPtr->name != NULL) {
- Tcl_AppendToObj(objPtr, varPtr->name, -1);
- } else if (varPtr->hPtr != NULL) {
- name = Tcl_GetHashKey(varPtr->hPtr->tablePtr, varPtr->hPtr);
+ if (TclIsVarInHash(varPtr)) {
+ if (!TclIsVarDeadHash(varPtr)) {
+ name = VarHashGetKey(varPtr);
+ Tcl_AppendToObj(objPtr, name, -1);
+ }
+ } else if (iPtr->varFramePtr->procPtr) {
+ int index = varPtr - iPtr->varFramePtr->compiledLocals;
+
+ name = localVarNames(iPtr->varFramePtr)[index];;
Tcl_AppendToObj(objPtr, name, -1);
}
}
@@ -3705,7 +3816,7 @@
if (!TclIsVarNamespaceVar(varPtr)) {
TclSetVarNamespaceVar(varPtr);
- varPtr->refCount++;
+ VarHashRefCount(varPtr)++;
}
/*
@@ -3832,44 +3943,6 @@
/*
*----------------------------------------------------------------------
*
- * NewVar --
- *
- * Create a new heap-allocated variable that will eventually be entered
- * into a hashtable.
- *
- * Results:
- * The return value is a pointer to the new variable structure. It is
- * marked as a scalar variable (and not a link or array variable). Its
- * value initially is NULL. The variable is not part of any hash table
- * yet. Since it will be in a hashtable and not in a call frame, its name
- * field is set NULL. It is initially marked as undefined.
- *
- * Side effects:
- * Storage gets allocated.
- *
- *----------------------------------------------------------------------
- */
-
-static Var *
-NewVar(void)
-{
- register Var *varPtr;
-
- varPtr = (Var *) ckalloc(sizeof(Var));
- varPtr->value.objPtr = NULL;
- varPtr->name = NULL;
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);
- return varPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* SetArraySearchObj --
*
* This function converts the given tcl object into one that has the
@@ -3966,10 +4039,12 @@
* decimal number and "var" is a variable
* name. */
{
+ Interp *iPtr = (Interp *) interp;
register char *string;
register size_t offset;
int id;
ArraySearch *searchPtr;
+
/*
* Parse the id.
@@ -4012,10 +4087,15 @@
* this list every time.
*/
- for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
- searchPtr = searchPtr->nextPtr) {
- if (searchPtr->id == id) {
- return searchPtr;
+ if (varPtr->flags & VAR_SEARCH_ACTIVE) {
+ Tcl_HashEntry *hPtr =
+ Tcl_FindHashEntry(&iPtr->varSearches,(char *) varPtr);
+
+ for (searchPtr = (ArraySearch *) Tcl_GetHashValue(hPtr);
+ searchPtr != NULL; searchPtr = searchPtr->nextPtr) {
+ if (searchPtr->id == id) {
+ return searchPtr;
+ }
}
}
Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL);
@@ -4042,16 +4122,23 @@
static void
DeleteSearches(
+ Interp *iPtr,
register Var *arrayVarPtr) /* Variable whose searches are to be
* deleted. */
{
- ArraySearch *searchPtr;
+ ArraySearch *searchPtr, *nextPtr;
+ Tcl_HashEntry *sPtr;
- while (arrayVarPtr->searchPtr != NULL) {
- searchPtr = arrayVarPtr->searchPtr;
- arrayVarPtr->searchPtr = searchPtr->nextPtr;
- ckfree((char *) searchPtr);
- }
+ if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
+ sPtr = Tcl_FindHashEntry(&iPtr->varSearches, (char *) arrayVarPtr);
+ for (searchPtr = (ArraySearch *) Tcl_GetHashValue(sPtr);
+ searchPtr != NULL; searchPtr = nextPtr) {
+ nextPtr = searchPtr->nextPtr;
+ ckfree((char *) searchPtr);
+ }
+ arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
+ Tcl_DeleteHashEntry(sPtr);
+ }
}
/*
@@ -4076,12 +4163,12 @@
TclDeleteNamespaceVars(
Namespace *nsPtr)
{
- Tcl_HashTable *tablePtr = &nsPtr->varTable;
+ TclVarHashTable *tablePtr = &nsPtr->varTable;
Tcl_Interp *interp = nsPtr->interp;
Interp *iPtr = (Interp *)interp;
Tcl_HashSearch search;
- Tcl_HashEntry *hPtr;
int flags = 0;
+ Var *varPtr;
/*
* Determine what flags to pass to the trace callback functions.
@@ -4093,30 +4180,36 @@
flags = TCL_NAMESPACE_ONLY;
}
- for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
- hPtr = Tcl_FirstHashEntry(tablePtr, &search)) {
- register Var *varPtr = (Var *) Tcl_GetHashValue(hPtr);
- varPtr->refCount++; /* Make sure we get to remove from hash */
- UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ NULL, NULL, flags, 1);
- varPtr->refCount--;
+ for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
+ varPtr = VarHashFirstVar(tablePtr, &search)) {
+ VarHashRefCount(varPtr)++; /* Make sure we get to remove from hash */
+ UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ NULL, NULL, flags);
/*
* Remove the variable from the table and force it undefined in case
* an unset trace brought it back from the dead.
*/
- Tcl_DeleteHashEntry(hPtr);
- varPtr->hPtr = NULL;
+ VarHashDeleteEntry(varPtr);
TclSetVarUndefined(varPtr);
TclSetVarScalar(varPtr);
- while (varPtr->tracePtr != NULL) {
- VarTrace *tracePtr = varPtr->tracePtr;
- varPtr->tracePtr = tracePtr->nextPtr;
- Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
+ if (TclIsVarTraced(varPtr)) {
+ Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+ (char *) varPtr);
+ VarTrace *tracePtr = (VarTrace *) Tcl_GetHashValue(tPtr);
+ while (tracePtr) {
+ VarTrace *prevPtr = tracePtr;
+
+ tracePtr = tracePtr->nextPtr;
+ Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC);
+ }
+ Tcl_DeleteHashEntry(tPtr);
+ varPtr->flags &= ~VAR_ALL_TRACES;
}
+ VarHashRefCount(varPtr)--;
TclCleanupVar(varPtr, NULL);
}
- Tcl_DeleteHashTable(tablePtr);
+ VarHashDeleteTable(tablePtr);
}
/*
@@ -4142,12 +4235,11 @@
void
TclDeleteVars(
Interp *iPtr, /* Interpreter to which variables belong. */
- Tcl_HashTable *tablePtr) /* Hash table containing variables to
+ TclVarHashTable *tablePtr) /* Hash table containing variables to
* delete. */
{
Tcl_Interp *interp = (Tcl_Interp *) iPtr;
Tcl_HashSearch search;
- Tcl_HashEntry *hPtr;
register Var *varPtr;
int flags;
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
@@ -4163,24 +4255,17 @@
flags |= TCL_NAMESPACE_ONLY;
}
- for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&search)) {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
-
- UnsetVarStruct(varPtr, NULL, iPtr, NULL, NULL, flags, 0);
- varPtr->hPtr = NULL;
-
+ for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
+ varPtr = VarHashNextVar(&search)) {
/*
- * Recycle the variable's memory space if there aren't any upvar's
- * pointing to it. If there are upvars to this variable, then the
- * variable will get freed when the last upvar goes away.
+ * Lie about the validity of the hashtable entry. In this way the
+ * variables will be deleted by VarHashDeleteTable.
*/
-
- if (varPtr->refCount == 0) {
- ckfree((char *) varPtr); /* this Var must be VAR_IN_HASHTABLE */
- }
+
+ VarHashInvalidateEntry(varPtr);
+ UnsetVarStruct(varPtr, NULL, iPtr, NULL, NULL, flags);
}
- Tcl_DeleteHashTable(tablePtr);
+ VarHashDeleteTable(tablePtr);
}
/*
@@ -4213,77 +4298,15 @@
{
register Var *varPtr;
int numLocals, i;
-
+ char *name;
+
numLocals = framePtr->numCompiledLocals;
varPtr = framePtr->compiledLocals;
+ name = localVarNames(framePtr)[0];
for (i=0 ; i<numLocals ; i++) {
-#if 1
- UnsetVarStruct(varPtr, NULL, iPtr, varPtr->name, NULL, TCL_TRACE_UNSETS, 0);
+ UnsetVarStruct(varPtr, NULL, iPtr, name, NULL, TCL_TRACE_UNSETS);
varPtr++;
-#else
- if (!TclIsVarUntraced(varPtr)) {
- ActiveVarTrace *activePtr;
-
- varPtr->flags &= ~VAR_TRACE_ACTIVE;
- TclCallVarTraces(iPtr, NULL, varPtr, varPtr->name, NULL,
- TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
- while (varPtr->tracePtr != NULL) {
- VarTrace *tracePtr = varPtr->tracePtr;
- varPtr->tracePtr = tracePtr->nextPtr;
- Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
- }
- for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
- activePtr = activePtr->nextPtr) {
- if (activePtr->varPtr == varPtr) {
- activePtr->nextTracePtr = NULL;
- }
- }
- }
-
- if (TclIsVarScalar(varPtr)
- && (varPtr->value.objPtr != NULL)) {
- /*
- * Decrement the ref count of the var's value
- */
-
- Tcl_Obj *objPtr = varPtr->value.objPtr;
- TclDecrRefCount(objPtr);
- varPtr->value.objPtr = NULL;
- } else if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
- /*
- * If the variable is an array, delete all of its elements. This must
- * be done after calling the traces on the array, above (that's the
- * way traces are defined). If the array is traced, its name is
- * already in part1. If not, and the name is required for some
- * element, it will be computed at DeleteArray.
- */
-
- DeleteArray(iPtr, varPtr->name, varPtr, TCL_TRACE_UNSETS);
- } else if (TclIsVarLink(varPtr)) {
- /*
- * For global/upvar variables referenced in procedures, decrement the
- * reference count on the variable referred to, and free the
- * referenced variable if it's no longer needed.
- */
- Var *linkPtr = varPtr->value.linkPtr;
- linkPtr->refCount--;
- if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
- && (linkPtr->tracePtr == NULL)
- && (linkPtr->flags & VAR_IN_HASHTABLE)) {
- if (linkPtr->hPtr != NULL) {
- Tcl_DeleteHashEntry(linkPtr->hPtr);
- }
- ckfree((char *) linkPtr);
- }
- }
-
- TclSetVarUndefined(varPtr);
- TclSetVarScalar(varPtr);
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
-
- varPtr++;
-#endif
+ name++;
}
}
@@ -4319,44 +4342,57 @@
* TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */
{
Tcl_HashSearch search;
- register Tcl_HashEntry *hPtr;
+ Tcl_HashEntry *tPtr;
register Var *elPtr;
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr, *arrayNamePtr = NULL;
+ VarTrace *tracePtr;
- DeleteSearches(varPtr);
- for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- elPtr = (Var *) Tcl_GetHashValue(hPtr);
+ if (varPtr->flags & VAR_SEARCH_ACTIVE) {
+ DeleteSearches(iPtr, varPtr);
+ }
+ for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search);
+ elPtr != NULL; elPtr = VarHashNextVar(&search)) {
if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
objPtr = elPtr->value.objPtr;
TclDecrRefCount(objPtr);
elPtr->value.objPtr = NULL;
}
- elPtr->hPtr = NULL;
- if (elPtr->tracePtr != NULL) {
+
+ /*
+ * Lie about the validity of the hashtable entry. In this way the
+ * variables will be deleted by VarHashDeleteTable.
+ */
+
+ VarHashInvalidateEntry(elPtr);
+ if (TclIsVarTraced(elPtr)) {
/*
* Compute the array name if it was not supplied
*/
- if (arrayName == NULL) {
- Tcl_Interp *interp = varPtr->nsPtr->interp;
- TclNewObj(arrayNamePtr);
- Tcl_IncrRefCount(arrayNamePtr);
- Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, arrayNamePtr);
- arrayName = TclGetString(arrayNamePtr);
- }
-
- elPtr->flags &= ~VAR_TRACE_ACTIVE;
- TclCallVarTraces(iPtr, NULL, elPtr, arrayName,
- Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
- /* leaveErrMsg */ 0);
- while (elPtr->tracePtr != NULL) {
- VarTrace *tracePtr = elPtr->tracePtr;
+ if (elPtr->flags & VAR_TRACED_UNSET) {
+ elPtr->flags &= ~VAR_TRACE_ACTIVE;
+ if (arrayName == NULL) {
+ Tcl_Interp *interp = (Tcl_Interp *) iPtr;;
+ TclNewObj(arrayNamePtr);
+ Tcl_IncrRefCount(arrayNamePtr);
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, arrayNamePtr);
+ arrayName = TclGetString(arrayNamePtr);
+ }
+ TclCallVarTraces(iPtr, NULL, elPtr, arrayName,
+ VarHashGetKey(elPtr), flags,
+ /* leaveErrMsg */ 0);
+ }
+ tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) elPtr);
+ tracePtr = (VarTrace *) Tcl_GetHashValue(tPtr);
+ while (tracePtr) {
+ VarTrace *prevPtr = tracePtr;
- elPtr->tracePtr = tracePtr->nextPtr;
- Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
+ tracePtr = tracePtr->nextPtr;
+ Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC);
}
+ Tcl_DeleteHashEntry(tPtr);
+ elPtr->flags &= ~VAR_ALL_TRACES;
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == elPtr) {
@@ -4376,16 +4412,13 @@
if (TclIsVarNamespaceVar(elPtr)) {
TclClearVarNamespaceVar(elPtr);
- elPtr->refCount--;
- }
- if (elPtr->refCount == 0) {
- ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */
+ VarHashRefCount(elPtr)--;
}
}
if (arrayNamePtr) {
Tcl_DecrRefCount(arrayNamePtr);
}
- Tcl_DeleteHashTable(varPtr->value.tablePtr);
+ VarHashDeleteTable(varPtr->value.tablePtr);
ckfree((char *) varPtr->value.tablePtr);
}
@@ -4418,25 +4451,28 @@
Var *arrayPtr) /* Array that contains the variable, or NULL
* if this variable isn't an array element. */
{
- if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)
- && (varPtr->tracePtr == NULL)
- && (varPtr->flags & VAR_IN_HASHTABLE)) {
- if (varPtr->hPtr != NULL) {
- Tcl_DeleteHashEntry(varPtr->hPtr);
+ if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
+ && !TclIsVarTraced(varPtr)
+ && (VarHashRefCount(varPtr) == (TclIsVarDeadHash(varPtr) == 0))) {
+ if (VarHashRefCount(varPtr) == 0) {
+ ckfree((char *) varPtr);
+ } else {
+ VarHashDeleteEntry(varPtr);
}
- ckfree((char *) varPtr);
}
if (arrayPtr != NULL) {
- if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0)
- && (arrayPtr->tracePtr == NULL)
- && (arrayPtr->flags & VAR_IN_HASHTABLE)) {
- if (arrayPtr->hPtr != NULL) {
- Tcl_DeleteHashEntry(arrayPtr->hPtr);
+ if (TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr)
+ && !TclIsVarTraced(arrayPtr)
+ && (VarHashRefCount(arrayPtr) == (TclIsVarDeadHash(arrayPtr) == 0))) {
+ if (VarHashRefCount(arrayPtr) == 0) {
+ ckfree((char *) arrayPtr);
+ } else {
+ VarHashDeleteEntry(arrayPtr);
}
- ckfree((char *) arrayPtr);
}
}
}
+
/*
*----------------------------------------------------------------------
*
@@ -4534,9 +4570,11 @@
{
register Var *varPtr = objPtr->internalRep.twoPtrValue.ptr2;
- varPtr->refCount--;
- if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) {
- TclCleanupVar(varPtr, NULL);
+ if (TclIsVarInHash(varPtr)) {
+ varPtr->refCount--;
+ if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) {
+ TclCleanupVar(varPtr, NULL);
+ }
}
}
@@ -4550,7 +4588,9 @@
dupPtr->internalRep.twoPtrValue.ptr1 = nsPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = varPtr;
- varPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ varPtr->refCount++;
+ }
dupPtr->typePtr = &tclNsVarNameType;
}
#endif
@@ -4636,6 +4676,223 @@
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FindNamespaceVar -- MOVED OVER from tclNamesp.c
+ *
+ * Searches for a namespace variable, a variable not local to a
+ * procedure. The variable can be either a scalar or an array, but may
+ * not be an element of an array.
+ *
+ * Results:
+ * Returns a token for the variable if it is found. Otherwise, if it
+ * can't be found or there is an error, returns NULL and leaves an error
+ * message in the interpreter's result object if "flags" contains
+ * TCL_LEAVE_ERR_MSG.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Var
+Tcl_FindNamespaceVar(
+ Tcl_Interp *interp, /* The interpreter in which to find the
+ * variable. */
+ const char *name, /* Variable's name. If it starts with "::",
+ * will be looked up in global namespace.
+ * Else, looked up first in contextNsPtr
+ * (current namespace if contextNsPtr is
+ * NULL), then in global namespace. */
+ Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set.
+ * Otherwise, points to namespace in which to
+ * resolve name. If NULL, look up name in the
+ * current namespace. */
+ int flags) /* An OR'd combination of flags:
+ * TCL_GLOBAL_ONLY (look up name only in
+ * global namespace), TCL_NAMESPACE_ONLY (look
+ * up only in contextNsPtr, or the current
+ * namespace if contextNsPtr is NULL), and
+ * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
+ * and TCL_NAMESPACE_ONLY are given,
+ * TCL_GLOBAL_ONLY is ignored. */
+{
+ Interp *iPtr = (Interp *) interp;
+ ResolverScheme *resPtr;
+ Namespace *nsPtr[2], *cxtNsPtr;
+ const char *simpleName;
+ Var *varPtr;
+ register int search;
+ int result;
+ Tcl_Var var;
+
+ /*
+ * If this namespace has a variable resolver, then give it first crack at
+ * the variable resolution. It may return a Tcl_Var value, it may signal
+ * to continue onward, or it may signal an error.
+ */
+
+ if ((flags & TCL_GLOBAL_ONLY) != 0) {
+ cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
+ } else if (contextNsPtr != NULL) {
+ cxtNsPtr = (Namespace *) contextNsPtr;
+ } else {
+ cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ }
+
+ if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
+ resPtr = iPtr->resolverPtr;
+
+ if (cxtNsPtr->varResProc) {
+ result = (*cxtNsPtr->varResProc)(interp, name,
+ (Tcl_Namespace *) cxtNsPtr, flags, &var);
+ } else {
+ result = TCL_CONTINUE;
+ }
+
+ while (result == TCL_CONTINUE && resPtr) {
+ if (resPtr->varResProc) {
+ result = (*resPtr->varResProc)(interp, name,
+ (Tcl_Namespace *) cxtNsPtr, flags, &var);
+ }
+ resPtr = resPtr->nextPtr;
+ }
+
+ if (result == TCL_OK) {
+ return var;
+ } else if (result != TCL_CONTINUE) {
+ return (Tcl_Var) NULL;
+ }
+ }
+
+ /*
+ * Find the namespace(s) that contain the variable.
+ */
+
+ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
+ flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
+
+ /*
+ * Look for the variable in the variable table of its namespace. Be sure
+ * to check both possible search paths: from the specified namespace
+ * context and from the global namespace.
+ */
+
+ varPtr = NULL;
+ for (search = 0; (search < 2) && (varPtr == NULL); search++) {
+ if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
+ varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleName);
+ }
+ }
+ if (varPtr != NULL) {
+ return (Tcl_Var) varPtr;
+ } else if (flags & TCL_LEAVE_ERR_MSG) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL);
+ }
+ return (Tcl_Var) NULL;
+}
+
+/*
+ * Hash table implementation - first, just copy string key stuff
+ */
+
+void
+TclInitVarHashTable(
+ TclVarHashTable *tablePtr,
+ Namespace *nsPtr)
+{
+ Tcl_InitCustomHashTable(&tablePtr->table,
+ TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType);
+ tablePtr->nsPtr = nsPtr;
+}
+
+static Tcl_HashEntry *
+AllocVarEntry(
+ Tcl_HashTable *tablePtr, /* Hash table. */
+ VOID *keyPtr) /* Key to store in the hash table entry. */
+{
+ const char *string = (const char *) keyPtr;
+ Tcl_HashEntry *hPtr;
+ unsigned int size;
+ Var *varPtr;
+
+ size = sizeof(VarInHash) + strlen(string) - 3; /* add \0, remove 4 already in */
+ if (size < sizeof(VarInHash)) {
+ size = sizeof(VarInHash);
+ }
+ varPtr = (Var *) ckalloc(size);
+ varPtr->flags = VAR_IN_HASHTABLE;
+ varPtr->value.objPtr = NULL;
+ VarHashRefCount(varPtr) = 1;
+ hPtr = &(((VarInHash *)varPtr)->entry);
+ Tcl_SetHashValue(hPtr, varPtr);
+ strcpy(hPtr->key.string, string);
+
+ return hPtr;
+}
+
+static void
+FreeVarEntry(Tcl_HashEntry *hPtr)
+{
+ Var *varPtr = VarHashGetValue(hPtr);
+
+ if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr)
+ && (VarHashRefCount(varPtr) == 1)) {
+ ckfree((char *) varPtr);
+ } else {
+ VarHashInvalidateEntry(varPtr);
+ VarHashRefCount(varPtr)--;
+ }
+}
+
+static int
+CompareVarKeys(
+ VOID *keyPtr, /* New key to compare. */
+ Tcl_HashEntry *hPtr) /* Existing key to compare. */
+{
+ register const char *p1 = (const char *) keyPtr;
+ register const char *p2 = (const char *) hPtr->key.string;
+
+ return !strcmp(p1, p2);
+}
+
+static unsigned int
+HashVarKey(
+ Tcl_HashTable *tablePtr, /* Hash table. */
+ VOID *keyPtr) /* Key from which to compute hash value. */
+{
+ register const char *string = (const char *) keyPtr;
+ register unsigned int result;
+ register int c;
+
+ /*
+ * I tried a zillion different hash functions and asked many other people
+ * for advice. Many people had their own favorite functions, all
+ * different, but no-one had much idea why they were good ones. I chose
+ * the one below (multiply by 9 and add new character) because of the
+ * following reasons:
+ *
+ * 1. Multiplying by 10 is perfect for keys that are decimal strings, and
+ * 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, but isn't strong against maliciously-chosen
+ * keys.
+ */
+
+ result = 0;
+
+ for (c=*string++ ; c ; c=*string++) {
+ result += (result<<3) + c;
+ }
+ return result;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
