Attachment "VarReform.diff.9.3" to
ticket [1750051fff]
added by
msofer
2007-07-24 02:16:46.
? 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.8.0
? VarReform.diff.8.1
? VarReform.diff.8.2
? VarReform.diff.8.3
? VarReform.diff.8.4
? VarReform.diff.8.5
? VarReform.diff.8.6
? VarReform.diff.8.7
? VarReform.diff.8.8
? VarReform.diff.8.9
? VarReform.diff.8.b
? VarReform.diff.9.0
? VarReform.diff.9.1
? VarReform.diff.9.2
? VarReform.diff.9.3
? VarReform_old
? lit
? 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
? generic/tclVar.c.WIP2
? unix/0valgrind
? unix/ERR
? unix/dltest.marker
? unix/httpd_17847
? unix/httpd_19974
? unix/httpd_22406
? unix/httpd_23230
? unix/httpd_25368
? unix/httpd_3272
? unix/httpd_4074
? unix/searchPtr
? unix/tclsh1
? 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 23 Jul 2007 19:14:08 -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 23 Jul 2007 19:14:09 -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 23 Jul 2007 19:14:11 -0000
@@ -97,8 +97,6 @@
* Forward declarations for procedures defined in this file:
*/
-static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
- CONST char *pattern, int includeLinks);
static int DictionaryCompare(char *left, char *right);
static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
@@ -119,8 +117,6 @@
int objc, Tcl_Obj *CONST objv[]);
static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
-static int InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
@@ -129,8 +125,6 @@
int objc, Tcl_Obj *CONST objv[]);
static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
-static int InfoLocalsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
static int InfoNameOfExecutableCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
@@ -144,8 +138,6 @@
int objc, Tcl_Obj *CONST objv[]);
static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
-static int InfoVarsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]);
static SortElement * MergeSort(SortElement *headPt, SortInfo *infoPtr);
static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
SortInfo *infoPtr);
@@ -172,19 +164,19 @@
{"exists", InfoExistsCmd},
{"frame", InfoFrameCmd},
{"functions", InfoFunctionsCmd},
- {"globals", InfoGlobalsCmd},
+ {"globals", TclInfoGlobalsCmd},
{"hostname", InfoHostnameCmd},
{"level", InfoLevelCmd},
{"library", InfoLibraryCmd},
{"loaded", InfoLoadedCmd},
- {"locals", InfoLocalsCmd},
+ {"locals", TclInfoLocalsCmd},
{"nameofexecutable",InfoNameOfExecutableCmd},
{"patchlevel", InfoPatchLevelCmd},
{"procs", InfoProcsCmd},
{"script", InfoScriptCmd},
{"sharedlibextension", InfoSharedlibCmd},
{"tclversion", InfoTclVersionCmd},
- {"vars", InfoVarsCmd},
+ {"vars", TclInfoVarsCmd},
{NULL, NULL}
};
@@ -1033,8 +1025,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;
}
@@ -1359,94 +1351,6 @@
/*
*----------------------------------------------------------------------
*
- * InfoGlobalsCmd --
- *
- * Called to implement the "info globals" command that returns the list
- * of global variables matching an optional pattern. Handles the
- * following syntax:
- *
- * info globals ?pattern?
- *
- * Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
- *
- * Side effects:
- * Returns a result in the interpreter's result object. If there is an
- * error, the result is an error message.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-InfoGlobalsCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
-{
- char *varName, *pattern;
- Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
- register Tcl_HashEntry *entryPtr;
- Tcl_HashSearch search;
- Var *varPtr;
- Tcl_Obj *listPtr;
-
- if (objc == 1) {
- pattern = NULL;
- } else if (objc == 2) {
- pattern = TclGetString(objv[1]);
-
- /*
- * Strip leading global-namespace qualifiers. [Bug 1057461]
- */
-
- if (pattern[0] == ':' && pattern[1] == ':') {
- while (*pattern == ':') {
- pattern++;
- }
- }
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
- return TCL_ERROR;
- }
-
- /*
- * Scan through the global :: namespace's variable table and create a list
- * of all global variables that match the pattern.
- */
-
- listPtr = Tcl_NewListObj(0, NULL);
- if (pattern != NULL && TclMatchIsTrivial(pattern)) {
- entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
- if (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(pattern, -1));
- }
- }
- } else {
- for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (TclIsVarUndefined(varPtr)) {
- continue;
- }
- varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
- if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
- }
- }
- }
- Tcl_SetObjResult(interp, listPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* InfoHostnameCmd --
*
* Called to implement the "info hostname" command that returns the host
@@ -1650,162 +1554,6 @@
/*
*----------------------------------------------------------------------
*
- * InfoLocalsCmd --
- *
- * Called to implement the "info locals" command to return a list of
- * local variables that match an optional pattern. Handles the following
- * syntax:
- *
- * info locals ?pattern?
- *
- * Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
- *
- * Side effects:
- * Returns a result in the interpreter's result object. If there is an
- * error, the result is an error message.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-InfoLocalsCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
-{
- Interp *iPtr = (Interp *) interp;
- char *pattern;
- Tcl_Obj *listPtr;
-
- if (objc == 1) {
- pattern = NULL;
- } else if (objc == 2) {
- pattern = TclGetString(objv[1]);
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
- return TCL_ERROR;
- }
-
- if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) {
- return TCL_OK;
- }
-
- /*
- * Return a list containing names of first the compiled locals (i.e. the
- * ones stored in the call frame), then the variables in the local hash
- * table (if one exists).
- */
-
- listPtr = Tcl_NewListObj(0, NULL);
- AppendLocals(interp, listPtr, pattern, 0);
- Tcl_SetObjResult(interp, listPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AppendLocals --
- *
- * Append the local variables for the current frame to the specified list
- * object.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AppendLocals(
- Tcl_Interp *interp, /* Current interpreter. */
- Tcl_Obj *listPtr, /* List object to append names to. */
- CONST char *pattern, /* Pattern to match against. */
- int includeLinks) /* 1 if upvars should be included, else 0. */
-{
- Interp *iPtr = (Interp *) interp;
- CompiledLocal *localPtr;
- Var *varPtr;
- int i, localVarCt;
- const char *varName;
- Tcl_HashTable *localVarTablePtr;
- register Tcl_HashEntry *entryPtr;
- Tcl_HashSearch search;
-
- localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
- localVarCt = iPtr->varFramePtr->numCompiledLocals;
- varPtr = iPtr->varFramePtr->compiledLocals;
- localVarTablePtr = iPtr->varFramePtr->varTablePtr;
-
- for (i = 0; i < localVarCt; i++) {
- /*
- * Skip nameless (temporary) variables and undefined variables.
- */
-
- if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
- && (includeLinks || !TclIsVarLink(varPtr))) {
- varName = varPtr->name;
- if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
- }
- }
- varPtr++;
- localPtr = localPtr->nextPtr;
- }
-
- /*
- * Do nothing if no local variables.
- */
-
- if (localVarTablePtr == NULL) {
- return;
- }
-
- /*
- * Check for the simple and fast case.
- */
-
- if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
- entryPtr = Tcl_FindHashEntry(localVarTablePtr, pattern);
- if (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- && (includeLinks || !TclIsVarLink(varPtr))) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(pattern, -1));
- }
- }
- return;
- }
-
- /*
- * Scan over and process all local variables.
- */
-
- for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- && (includeLinks || !TclIsVarLink(varPtr))) {
- varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
- if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
- }
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
* InfoNameOfExecutableCmd --
*
* Called to implement the "info nameofexecutable" command that returns
@@ -2206,197 +1954,6 @@
/*
*----------------------------------------------------------------------
*
- * InfoVarsCmd --
- *
- * Called to implement the "info vars" command that returns the list of
- * variables in the interpreter that match an optional pattern. The
- * pattern, if any, consists of an optional sequence of namespace names
- * separated by "::" qualifiers, which is followed by a glob-style
- * pattern that restricts which variables are returned. Handles the
- * following syntax:
- *
- * info vars ?pattern?
- *
- * Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
- *
- * Side effects:
- * Returns a result in the interpreter's result object. If there is an
- * error, the result is an error message.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-InfoVarsCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
-{
- Interp *iPtr = (Interp *) interp;
- char *varName, *pattern;
- CONST char *simplePattern;
- register Tcl_HashEntry *entryPtr;
- Tcl_HashSearch search;
- Var *varPtr;
- Namespace *nsPtr;
- Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
- Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
- Tcl_Obj *listPtr, *elemObjPtr;
- int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
-
- /*
- * Get the pattern and find the "effective namespace" in which to list
- * variables. We only use this effective namespace if there's no active
- * Tcl procedure frame.
- */
-
- if (objc == 1) {
- simplePattern = NULL;
- nsPtr = currNsPtr;
- specificNsInPattern = 0;
- } else if (objc == 2) {
- /*
- * From the pattern, get the effective namespace and the simple
- * pattern (no namespace qualifiers or ::'s) at the end. If an error
- * was found while parsing the pattern, return it. Otherwise, if the
- * namespace wasn't found, just leave nsPtr NULL: we will return an
- * empty list since no variables there can be found.
- */
-
- Namespace *dummy1NsPtr, *dummy2NsPtr;
-
- pattern = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
- /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
- &simplePattern);
-
- if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
- specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
- }
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
- return TCL_ERROR;
- }
-
- /*
- * If the namespace specified in the pattern wasn't found, just return.
- */
-
- if (nsPtr == NULL) {
- return TCL_OK;
- }
-
- listPtr = Tcl_NewListObj(0, NULL);
-
- if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)
- || specificNsInPattern) {
- /*
- * There is no frame pointer, the frame pointer was pushed only to
- * activate a namespace, or we are in a procedure call frame but a
- * specific namespace was specified. Create a list containing only the
- * variables in the effective namespace's variable table.
- */
-
- if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
- /*
- * If we can just do hash lookups, that simplifies things a lot.
- */
-
- entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
- if (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || TclIsVarNamespaceVar(varPtr)) {
- if (specificNsInPattern) {
- elemObjPtr = Tcl_NewObj();
- Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
- elemObjPtr);
- } else {
- elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
- }
- Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
- }
- } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable,
- simplePattern);
- if (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || TclIsVarNamespaceVar(varPtr)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(simplePattern, -1));
- }
- }
- }
- } else {
- /*
- * Have to scan the tables of variables.
- */
-
- entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
- while (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || TclIsVarNamespaceVar(varPtr)) {
- varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
- if ((simplePattern == NULL)
- || Tcl_StringMatch(varName, simplePattern)) {
- if (specificNsInPattern) {
- elemObjPtr = Tcl_NewObj();
- Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
- elemObjPtr);
- } else {
- elemObjPtr = Tcl_NewStringObj(varName, -1);
- }
- Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
- }
- }
- entryPtr = Tcl_NextHashEntry(&search);
- }
-
- /*
- * If the effective namespace isn't the global :: namespace, and a
- * specific namespace wasn't requested in the pattern (i.e., the
- * pattern only specifies variable names), then add in all global
- * :: variables that match the simple pattern. Of course, add in
- * only those variables that aren't hidden by a variable in the
- * effective namespace.
- */
-
- if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable,&search);
- while (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || TclIsVarNamespaceVar(varPtr)) {
- varName = Tcl_GetHashKey(&globalNsPtr->varTable,
- entryPtr);
- if ((simplePattern == NULL)
- || Tcl_StringMatch(varName, simplePattern)) {
- if (Tcl_FindHashEntry(&nsPtr->varTable,
- varName) == NULL) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
- }
- }
- }
- entryPtr = Tcl_NextHashEntry(&search);
- }
- }
- }
- } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
- AppendLocals(interp, listPtr, simplePattern, 1);
- }
-
- Tcl_SetObjResult(interp, listPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command. See the
Index: generic/tclCompCmds.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompCmds.c,v
retrieving revision 1.113
diff -u -r1.113 tclCompCmds.c
--- generic/tclCompCmds.c 11 Jul 2007 21:27:28 -0000 1.113
+++ generic/tclCompCmds.c 23 Jul 2007 19:14:12 -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;
}
@@ -4663,7 +4654,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)) {
/*
@@ -4879,8 +4869,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);
@@ -5334,7 +5323,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.124
diff -u -r1.124 tclCompile.c
--- generic/tclCompile.c 11 Jul 2007 21:27:28 -0000 1.124
+++ generic/tclCompile.c 23 Jul 2007 19:14:12 -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)) {
+ TclFreeLocalCache(interp, codePtr->localCachePtr);
+ }
+
TclHandleRelease(codePtr->interpHandle);
ckfree((char *) codePtr);
}
@@ -1657,7 +1662,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),
@@ -2066,6 +2071,8 @@
Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr,
&new), envPtr->extCmdMapPtr);
envPtr->extCmdMapPtr = NULL;
+
+ codePtr->localCachePtr = NULL;
}
/*
@@ -2101,9 +2108,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. */
{
@@ -2151,7 +2155,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;
}
@@ -3317,7 +3321,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 23 Jul 2007 19:14:12 -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. */
@@ -847,6 +850,10 @@
MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type,
CompileEnv *envPtr);
MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes,
+ int length, unsigned int hash, int *newPtr,
+ Namespace *nsPtr, int flags,
+ LiteralEntry **globalPtrPtr);
MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
@@ -859,7 +866,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 23 Jul 2007 19:14:13 -0000
@@ -177,6 +177,27 @@
#endif
/*
+ * These variable-access macros have to coincide with those in tclVar.c
+ */
+
+#define VarHashGetValue(hPtr) \
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
+
+static inline Var *
+VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr)
+{
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, (char *) key, newPtr);
+ if (hPtr) {
+ return VarHashGetValue(hPtr);
+ } else {
+ return NULL;
+ }
+}
+
+#define VarHashFindVar(tablePtr, key) \
+ VarHashCreateVar((tablePtr), (key), NULL)
+
+/*
* The new macro for ending an instruction; note that a reasonable C-optimiser
* will resolve all branches at compile time. (result) is always a constant;
* the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved
@@ -410,6 +431,7 @@
NULL, NULL, NULL, NULL
};
+
/*
* Declarations for local procedures to this file:
*/
@@ -597,6 +619,7 @@
TclDecrRefCount(eePtr->constants[0]);
TclDecrRefCount(eePtr->constants[1]);
+
ckfree((char *) eePtr);
}
@@ -2256,14 +2279,13 @@
*/
{
int opnd, pcAdjustment;
- char *part1, *part2;
+ Tcl_Obj *part1Ptr, *part2Ptr;
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 +2302,12 @@
pcAdjustment = 2;
cleanup = 0;
arrayPtr = NULL;
- part2 = NULL;
+ part1Ptr = part2Ptr = 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,30 +2324,71 @@
pcAdjustment = 5;
cleanup = 0;
arrayPtr = NULL;
- part2 = NULL;
+ part1Ptr = part2Ptr = NULL;
+ goto doCallPtrGetVar;
+
+ case INST_LOAD_ARRAY4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ goto doLoadArray;
+
+ case INST_LOAD_ARRAY1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+
+ doLoadArray:
+ part1Ptr = NULL;
+ part2Ptr = OBJ_AT_TOS;
+ arrayPtr = &(compiledLocals[opnd]);
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ TRACE(("%u \"%.30s\" => ", opnd, part2));
+ if (TclIsVarArray(arrayPtr) && !(arrayPtr->flags & VAR_TRACED_READ)) {
+ varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
+ if (varPtr) {
+ if (TclIsVarDirectReadable(varPtr)) {
+ /*
+ * No errors, no traces: just get the value.
+ */
+
+ objResultPtr = varPtr->value.objPtr;
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(pcAdjustment, 1, 1);
+ }
+ }
+ }
+ varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n",
+ O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ cleanup = 1;
goto doCallPtrGetVar;
case INST_LOAD_ARRAY_STK:
cleanup = 2;
- part2 = Tcl_GetString(OBJ_AT_TOS); /* element name */
- objPtr = OBJ_UNDER_TOS; /* array name */
+ part2Ptr = OBJ_AT_TOS; /* element name */
+ objPtr = OBJ_UNDER_TOS; /* array name */
TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
goto doLoadStk;
case INST_LOAD_STK:
case INST_LOAD_SCALAR_STK:
cleanup = 1;
- part2 = NULL;
+ part2Ptr = NULL;
objPtr = OBJ_AT_TOS; /* variable name */
TRACE(("\"%.30s\" => ", O2S(objPtr)));
doLoadStk:
- part1 = TclGetString(objPtr);
- varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG,
+ part1Ptr = objPtr;
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG,
"read", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr) {
- if (TclIsVarDirectReadable(varPtr)
- && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
+ if (TclIsVarDirectReadable2(varPtr, arrayPtr)) {
/*
* No errors, no traces: just get the value.
*/
@@ -2335,6 +2397,7 @@
NEXT_INST_V(1, cleanup, 1);
}
pcAdjustment = 1;
+ opnd = -1;
goto doCallPtrGetVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
@@ -2342,57 +2405,6 @@
goto checkForCatch;
}
- case INST_LOAD_ARRAY4:
- opnd = TclGetUInt4AtPtr(pc+1);
- pcAdjustment = 5;
- goto doLoadArray;
-
- case INST_LOAD_ARRAY1:
- opnd = TclGetUInt1AtPtr(pc+1);
- pcAdjustment = 2;
-
- doLoadArray:
- part2 = TclGetString(OBJ_AT_TOS);
- arrayPtr = &(compiledLocals[opnd]);
- part1 = arrayPtr->name;
- 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);
- if (hPtr) {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- } else {
- goto doLoadArrayNextBranch;
- }
- } else {
- doLoadArrayNextBranch:
- varPtr = TclLookupArrayElement(interp, part1, part2,
- TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
- if (varPtr == NULL) {
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
- }
- }
- if (TclIsVarDirectReadable(varPtr)
- && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
- /*
- * No errors, no traces: just get the value.
- */
-
- objResultPtr = varPtr->value.objPtr;
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_F(pcAdjustment, 1, 1);
- }
- cleanup = 1;
- goto doCallPtrGetVar;
-
doCallPtrGetVar:
/*
* There are either errors or the variable is traced: call
@@ -2400,8 +2412,8 @@
*/
DECACHE_STACK_INFO();
- objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2,
- TCL_LEAVE_ERR_MSG);
+ objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (objResultPtr) {
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
@@ -2429,64 +2441,143 @@
{
int opnd, pcAdjustment, storeFlags;
- char *part1, *part2;
+ Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
Tcl_Obj *objPtr, *valuePtr;
+ case INST_STORE_ARRAY4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ goto doStoreArrayDirect;
+
+ case INST_STORE_ARRAY1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+
+ doStoreArrayDirect:
+ valuePtr = OBJ_AT_TOS;
+ part2Ptr = OBJ_UNDER_TOS;
+ arrayPtr = &(compiledLocals[opnd]);
+ TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, part2, O2S(valuePtr)));
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ if (TclIsVarArray(arrayPtr) && !(arrayPtr->flags & VAR_TRACED_WRITE)) {
+ varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
+ if (varPtr) {
+ if (TclIsVarDirectWritable(varPtr)) {
+ tosPtr--;
+ Tcl_DecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = valuePtr;
+ goto doStoreVarDirect;
+ }
+ }
+ }
+ cleanup = 2;
+ storeFlags = TCL_LEAVE_ERR_MSG;
+ part1Ptr = NULL;
+ goto doStoreArrayDirectFailed;
+
+ case INST_STORE_SCALAR4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ goto doStoreScalarDirect;
+
+ case INST_STORE_SCALAR1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+
+ doStoreScalarDirect:
+ valuePtr = OBJ_AT_TOS;
+ varPtr = &(compiledLocals[opnd]);
+ TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ if (TclIsVarDirectWritable(varPtr)) {
+ doStoreVarDirect:
+ /*
+ * No traces, no errors, plain 'set': we can safely inline. The
+ * value *will* be set to what's requested, so that the stack top
+ * remains pointing to the same Tcl_Obj.
+ */
+
+ valuePtr = varPtr->value.objPtr;
+ if (valuePtr != NULL) {
+ TclDecrRefCount(valuePtr);
+ }
+ objResultPtr = OBJ_AT_TOS;
+ varPtr->value.objPtr = objResultPtr;
+#ifndef TCL_COMPILE_DEBUG
+ if (*(pc+pcAdjustment) == INST_POP) {
+ tosPtr--;
+ NEXT_INST_F((pcAdjustment+1), 0, 0);
+ }
+#else
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+#endif
+ Tcl_IncrRefCount(objResultPtr);
+ NEXT_INST_F(pcAdjustment, 0, 0);
+ }
+ storeFlags = TCL_LEAVE_ERR_MSG;
+ part1Ptr = NULL;
+ goto doStoreScalar;
+
case INST_LAPPEND_STK:
valuePtr = OBJ_AT_TOS; /* value to append */
- part2 = NULL;
+ part2Ptr = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreStk;
case INST_LAPPEND_ARRAY_STK:
valuePtr = OBJ_AT_TOS; /* value to append */
- part2 = TclGetString(OBJ_UNDER_TOS);
+ part2Ptr = OBJ_UNDER_TOS;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreStk;
case INST_APPEND_STK:
valuePtr = OBJ_AT_TOS; /* value to append */
- part2 = NULL;
+ part2Ptr = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreStk;
case INST_APPEND_ARRAY_STK:
valuePtr = OBJ_AT_TOS; /* value to append */
- part2 = TclGetString(OBJ_UNDER_TOS);
+ part2Ptr = OBJ_UNDER_TOS;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreStk;
case INST_STORE_ARRAY_STK:
valuePtr = OBJ_AT_TOS;
- part2 = TclGetString(OBJ_UNDER_TOS);
+ part2Ptr = OBJ_UNDER_TOS;
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreStk;
case INST_STORE_STK:
case INST_STORE_SCALAR_STK:
valuePtr = OBJ_AT_TOS;
- part2 = NULL;
+ part2Ptr = NULL;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreStk:
- objPtr = OBJ_AT_DEPTH(1 + (part2 != NULL)); /* variable name */
- part1 = TclGetString(objPtr);
+ objPtr = OBJ_AT_DEPTH(1 + (part2Ptr != NULL)); /* variable name */
+ part1Ptr = objPtr;
#ifdef TCL_COMPILE_DEBUG
- if (part2 == NULL) {
+ if (part2Ptr == NULL) {
TRACE(("\"%.30s\" <- \"%.30s\" =>", part1, O2S(valuePtr)));
} else {
TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
part1, part2, O2S(valuePtr)));
}
#endif
- varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG,
+ varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr) {
- cleanup = ((part2 == NULL)? 2 : 3);
+ cleanup = ((part2Ptr == NULL)? 2 : 3);
pcAdjustment = 1;
+ opnd = -1;
goto doCallPtrSetVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
@@ -2520,40 +2611,28 @@
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
- case INST_STORE_ARRAY4:
- opnd = TclGetUInt4AtPtr(pc+1);
- pcAdjustment = 5;
- storeFlags = TCL_LEAVE_ERR_MSG;
- goto doStoreArray;
-
- case INST_STORE_ARRAY1:
- opnd = TclGetUInt1AtPtr(pc+1);
- pcAdjustment = 2;
- storeFlags = TCL_LEAVE_ERR_MSG;
-
doStoreArray:
valuePtr = OBJ_AT_TOS;
- part2 = TclGetString(OBJ_UNDER_TOS);
+ part2Ptr = OBJ_UNDER_TOS;
arrayPtr = &(compiledLocals[opnd]);
- part1 = arrayPtr->name;
- cleanup = 2;
TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, part2, O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
- if (!TclIsVarUndefined(arrayPtr)
- && TclIsVarArray(arrayPtr)
- && TclIsVarUntraced(arrayPtr)) {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr,
- part2);
- if (hPtr) {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- goto doCallPtrSetVar;
- }
- }
- varPtr = TclLookupArrayElement(interp, part1, part2,
- TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
+ cleanup = 2;
+ part1Ptr = NULL;
+
+ doStoreArrayDirectFailed:
+ varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
if (varPtr) {
+ if ((storeFlags == TCL_LEAVE_ERR_MSG) && TclIsVarDirectWritable(varPtr)) {
+ tosPtr--;
+ Tcl_DecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = valuePtr;
+ goto doStoreVarDirect;
+ }
+ part1Ptr = NULL;
goto doCallPtrSetVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
@@ -2586,79 +2665,36 @@
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
-
- case INST_STORE_SCALAR4:
- opnd = TclGetUInt4AtPtr(pc+1);
- pcAdjustment = 5;
- storeFlags = TCL_LEAVE_ERR_MSG;
- goto doStoreScalar;
-
- case INST_STORE_SCALAR1:
- opnd = TclGetUInt1AtPtr(pc+1);
- pcAdjustment = 2;
- storeFlags = TCL_LEAVE_ERR_MSG;
-
+
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;
- part2 = NULL;
+ part1Ptr = part2Ptr = NULL;
doCallPtrSetVar:
- if ((storeFlags == TCL_LEAVE_ERR_MSG)
- && TclIsVarDirectWritable(varPtr)
- && ((arrayPtr == NULL) || TclIsVarUntraced(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
- * remains pointing to the same Tcl_Obj.
- */
-
- valuePtr = varPtr->value.objPtr;
- objResultPtr = OBJ_AT_TOS;
- if (valuePtr != objResultPtr) {
- if (valuePtr != NULL) {
- TclDecrRefCount(valuePtr);
- } else {
- TclSetVarScalar(varPtr);
- TclClearVarUndefined(varPtr);
- }
- varPtr->value.objPtr = objResultPtr;
- Tcl_IncrRefCount(objResultPtr);
- }
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
+ part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
+ CACHE_STACK_INFO();
+ if (objResultPtr) {
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
-#else
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
} else {
- DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
- part1, part2, valuePtr, storeFlags);
- CACHE_STACK_INFO();
- if (objResultPtr) {
-#ifndef TCL_COMPILE_DEBUG
- if (*(pc+pcAdjustment) == INST_POP) {
- NEXT_INST_V((pcAdjustment+1), cleanup, 0);
- }
-#endif
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(pcAdjustment, cleanup, 1);
- } else {
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
- }
+ TRACE_APPEND(("ERROR: %.30s\n",
+ O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
}
}
@@ -2685,7 +2721,7 @@
Tcl_WideInt w;
#endif
long i;
- char *part1, *part2;
+ Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
case INST_INCR_SCALAR1:
@@ -2718,21 +2754,21 @@
doIncrStk:
if ((*pc == INST_INCR_ARRAY_STK_IMM)
|| (*pc == INST_INCR_ARRAY_STK)) {
- part2 = TclGetString(OBJ_AT_TOS);
+ part2Ptr = OBJ_AT_TOS;
objPtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
O2S(objPtr), part2, i));
} else {
- part2 = NULL;
+ part2Ptr = NULL;
objPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
}
- part1 = TclGetString(objPtr);
-
- varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG,
+ part1Ptr = objPtr;
+ opnd = -1;
+ varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG,
"read", 1, 1, &arrayPtr);
if (varPtr) {
- cleanup = ((part2 == NULL)? 1 : 2);
+ cleanup = ((part2Ptr == NULL)? 1 : 2);
goto doIncrVar;
} else {
Tcl_AddObjErrorInfo(interp,
@@ -2751,16 +2787,16 @@
pcAdjustment = 3;
doIncrArray:
- part2 = TclGetString(OBJ_AT_TOS);
+ part1Ptr = NULL;
+ part2Ptr = OBJ_AT_TOS;
arrayPtr = &(compiledLocals[opnd]);
- part1 = arrayPtr->name;
cleanup = 1;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" (by %ld) => ", opnd, part2, i));
- varPtr = TclLookupArrayElement(interp, part1, part2,
- TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr);
+ varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd);
if (varPtr) {
goto doIncrVar;
} else {
@@ -2780,7 +2816,7 @@
varPtr = varPtr->value.linkPtr;
}
- if (TclIsVarDirectReadable(varPtr)) {
+ if (TclIsVarDirectModifyable(varPtr)) {
ClientData ptr;
int type;
@@ -2898,18 +2934,16 @@
doIncrScalar:
varPtr = &(compiledLocals[opnd]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
- part2 = NULL;
+ part1Ptr = part2Ptr = NULL;
cleanup = 0;
TRACE(("%u %ld => ", opnd, i));
doIncrVar:
- if (TclIsVarDirectReadable(varPtr)
- && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
+ if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
objPtr = varPtr->value.objPtr;
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
@@ -2931,7 +2965,7 @@
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr,
- part1, part2, incrPtr, TCL_LEAVE_ERR_MSG);
+ part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
Tcl_DecrRefCount(incrPtr);
if (objResultPtr == NULL) {
@@ -2973,7 +3007,7 @@
savedFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = framePtr;
- otherPtr = TclObjLookupVar(interp, OBJ_AT_TOS, NULL,
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
(TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
iPtr->varFramePtr = savedFramePtr;
@@ -2988,7 +3022,7 @@
case INST_VARIABLE:
TRACE(("variable "));
- otherPtr = TclObjLookupVar(interp, OBJ_AT_TOS, NULL,
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
if (otherPtr) {
@@ -2996,10 +3030,7 @@
* Do the [variable] magic
*/
- if (!TclIsVarNamespaceVar(otherPtr)) {
- TclSetVarNamespaceVar(otherPtr);
- otherPtr->refCount++;
- }
+ TclSetVarNamespaceVar(otherPtr);
result = TCL_OK;
goto doLinkVars;
}
@@ -3020,7 +3051,7 @@
savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
- otherPtr = TclObjLookupVar(interp, OBJ_AT_TOS, NULL,
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
@@ -3051,7 +3082,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,17 +3090,20 @@
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);
+ result = TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd);
if (result != TCL_OK) {
goto checkForCatch;
}
@@ -5681,8 +5715,6 @@
} else {
TclSetLongObj(oldValuePtr, -1);
}
- TclSetVarScalar(iterVarPtr);
- TclClearVarUndefined(iterVarPtr);
TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));
#ifndef TCL_COMPILE_DEBUG
@@ -5712,7 +5744,6 @@
int iterNum, listTmpIndex, listLen, numVars;
int varIndex, valIndex, continueLoop, j;
long i;
- char *part1;
opnd = TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
@@ -5782,7 +5813,6 @@
varIndex = varListPtr->varIndexes[j];
varPtr = &(compiledLocals[varIndex]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -5791,17 +5821,14 @@
if (valuePtr != value2Ptr) {
if (value2Ptr != NULL) {
TclDecrRefCount(value2Ptr);
- } else {
- TclSetVarScalar(varPtr);
- TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = valuePtr;
Tcl_IncrRefCount(valuePtr);
}
} else {
DECACHE_STACK_INFO();
- value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
- NULL, valuePtr, TCL_LEAVE_ERR_MSG);
+ value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL,
+ NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ((
@@ -5887,7 +5914,6 @@
int opnd, opnd2, allocateDict;
Tcl_Obj *dictPtr, *valPtr;
Var *varPtr;
- char *part1;
case INST_DICT_GET:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -5932,7 +5958,6 @@
opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd2]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -5941,7 +5966,7 @@
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
+ dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd2);
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
@@ -6010,9 +6035,6 @@
Tcl_IncrRefCount(dictPtr);
if (oldValuePtr != NULL) {
Tcl_DecrRefCount(oldValuePtr);
- } else {
- TclSetVarScalar(varPtr);
- TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = dictPtr;
}
@@ -6020,8 +6042,8 @@
} else {
Tcl_IncrRefCount(dictPtr);
DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
- dictPtr, TCL_LEAVE_ERR_MSG);
+ objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ dictPtr, TCL_LEAVE_ERR_MSG, opnd2);
CACHE_STACK_INFO();
Tcl_DecrRefCount(dictPtr);
if (objResultPtr == NULL) {
@@ -6045,7 +6067,6 @@
cleanup = 2;
varPtr = &(compiledLocals[opnd]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6054,7 +6075,7 @@
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
+ dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
@@ -6132,9 +6153,6 @@
Tcl_IncrRefCount(dictPtr);
if (oldValuePtr != NULL) {
Tcl_DecrRefCount(oldValuePtr);
- } else {
- TclSetVarScalar(varPtr);
- TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = dictPtr;
}
@@ -6142,8 +6160,8 @@
} else {
Tcl_IncrRefCount(dictPtr);
DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
- dictPtr, TCL_LEAVE_ERR_MSG);
+ objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ dictPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
Tcl_DecrRefCount(dictPtr);
if (objResultPtr == NULL) {
@@ -6184,14 +6202,13 @@
statePtr->typePtr = &dictIteratorType;
statePtr->internalRep.twoPtrValue.ptr1 = (void *) searchPtr;
statePtr->internalRep.twoPtrValue.ptr2 = (void *) dictPtr;
- varPtr = compiledLocals + opnd;
- if (varPtr->value.objPtr == NULL) {
- TclSetVarScalar(compiledLocals + opnd);
- TclClearVarUndefined(compiledLocals + opnd);
- } else if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
- Tcl_Panic("mis-issued dictFirst!");
- } else {
- Tcl_DecrRefCount(varPtr->value.objPtr);
+ varPtr = (compiledLocals + opnd);
+ if (varPtr->value.objPtr) {
+ if (varPtr->value.objPtr->typePtr != &dictIteratorType) {
+ Tcl_DecrRefCount(varPtr->value.objPtr);
+ } else {
+ Tcl_Panic("mis-issued dictFirst!");
+ }
}
varPtr->value.objPtr = statePtr;
Tcl_IncrRefCount(statePtr);
@@ -6261,14 +6278,12 @@
Tcl_Obj **keyPtrPtr, *dictPtr;
DictUpdateInfo *duiPtr;
Var *varPtr;
- 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;
}
@@ -6277,8 +6292,8 @@
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL,
- TCL_LEAVE_ERR_MSG);
+ dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL,
+ TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (dictPtr == NULL) {
goto dictUpdateStartFailed;
@@ -6299,15 +6314,17 @@
goto dictUpdateStartFailed;
}
varPtr = &(compiledLocals[duiPtr->varIndices[i]]);
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
DECACHE_STACK_INFO();
if (valPtr == NULL) {
- Tcl_UnsetVar(interp, part1, 0);
- } else if (TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
- valPtr, TCL_LEAVE_ERR_MSG) == NULL) {
+ TclObjUnsetVar2(interp,
+ localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
+ NULL, 0);
+ } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ valPtr, TCL_LEAVE_ERR_MSG,
+ duiPtr->varIndices[i]) == NULL) {
CACHE_STACK_INFO();
dictUpdateStartFailed:
cleanup = 1;
@@ -6323,7 +6340,6 @@
opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = &(compiledLocals[opnd]);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
- part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6332,7 +6348,7 @@
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0);
+ dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
@@ -6352,10 +6368,8 @@
for (i=0 ; i<length ; i++) {
Tcl_Obj *valPtr;
Var *var2Ptr;
- char *part1a;
var2Ptr = &(compiledLocals[duiPtr->varIndices[i]]);
- part1a = var2Ptr->name;
while (TclIsVarLink(var2Ptr)) {
var2Ptr = var2Ptr->value.linkPtr;
}
@@ -6363,7 +6377,8 @@
valPtr = var2Ptr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- valPtr = TclPtrGetVar(interp, var2Ptr, NULL, part1a, NULL, 0);
+ valPtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0,
+ duiPtr->varIndices[i]);
CACHE_STACK_INFO();
}
if (valPtr == NULL) {
@@ -6378,8 +6393,8 @@
varPtr->value.objPtr = dictPtr;
} else {
DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL,
- dictPtr, TCL_LEAVE_ERR_MSG);
+ objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ dictPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
if (allocdict) {
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 23 Jul 2007 19:14:13 -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 23 Jul 2007 19:14:13 -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 23 Jul 2007 19:14:14 -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
@@ -653,10 +687,16 @@
(varPtr)->flags &= ~VAR_TRACE_ACTIVE
#define TclSetVarNamespaceVar(varPtr) \
- (varPtr)->flags |= VAR_NAMESPACE_VAR
+ if (TclIsVarInHash(varPtr) && ! TclIsVarNamespaceVar(varPtr)) {\
+ (varPtr)->flags |= VAR_NAMESPACE_VAR;\
+ ((VarInHash *)(varPtr))->refCount++;\
+ }
#define TclClearVarNamespaceVar(varPtr) \
- (varPtr)->flags &= ~VAR_NAMESPACE_VAR
+ if (TclIsVarNamespaceVar(varPtr)) {\
+ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\
+ ((VarInHash *)(varPtr))->refCount--;\
+ }
/*
* Macros to read various flag bits of variables.
@@ -673,7 +713,7 @@
*/
#define TclIsVarScalar(varPtr) \
- ((varPtr)->flags & VAR_SCALAR)
+ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK))
#define TclIsVarLink(varPtr) \
((varPtr)->flags & VAR_LINK)
@@ -682,7 +722,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 +742,50 @@
#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_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))
+
+#define TclIsVarDirectModifyable(varPtr) \
+ ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \
+ && (varPtr)->value.objPtr)
+
+#define TclIsVarDirectReadable2(varPtr, arrayPtr) \
+ (TclIsVarDirectReadable(varPtr) &&\
+ (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_READ)))
+
+#define TclIsVarDirectWritable2(varPtr, arrayPtr) \
+ (TclIsVarDirectWritable(varPtr) &&\
+ (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_WRITE)))
+
+#define TclIsVarDirectModifyable2(varPtr, arrayPtr) \
+ (TclIsVarDirectModifyable(varPtr) &&\
+ (!(arrayPtr) || !((arrayPtr)->flags & (VAR_TRACED_READ|VAR_TRACED_WRITE))))
+
/*
*----------------------------------------------------------------
@@ -900,6 +966,22 @@
* 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;
+ int numVars;
+ Tcl_Obj *varName0;
+} LocalCache;
+
+#define localName(framePtr, i) \
+ ((&((framePtr)->localCachePtr->varName0))[(i)])
+
+MODULE_SCOPE void TclFreeLocalCache(Tcl_Interp *interp, LocalCache *localCachePtr);
+
typedef struct CallFrame {
Namespace *nsPtr; /* Points to the namespace used to resolve
* commands and global variables. */
@@ -933,7 +1015,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 +1035,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 +1820,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.
*/
@@ -2296,6 +2388,12 @@
Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
+MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE void TclInitAlloc(void);
MODULE_SCOPE void TclInitDbCkalloc(void);
MODULE_SCOPE void TclInitDoubleConversion(void);
@@ -2307,6 +2405,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);
@@ -2338,9 +2438,14 @@
Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr,
int *codePtr, int *levelPtr);
MODULE_SCOPE int TclNokia770Doubles();
+MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, const char *operation,
+ const char *reason, int index);
MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[],
Tcl_Namespace *nsPtr, int flags);
+MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp,
+ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags);
MODULE_SCOPE int TclParseBackslash(CONST char *src,
int numBytes, int *readPtr, char *dst);
MODULE_SCOPE int TclParseHex(CONST char *src, int numBytes,
@@ -2903,25 +3008,43 @@
* the public interface.
*/
+MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp,
+ Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
+ int flags, CONST char * msg,
+ CONST int createPart1, CONST int createPart2,
+ Var ** arrayPtrPtr);
MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp,
- CONST char *arrayName, CONST char *elName,
+ Tcl_Obj *arrayNamePtr, Tcl_Obj *elNamePtr,
CONST int flags, CONST char *msg,
CONST int createPart1, CONST int createPart2,
- Var *arrayPtr);
+ Var *arrayPtr, int index);
MODULE_SCOPE Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp,
- Var *varPtr, Var *arrayPtr, CONST char *part1,
- CONST char *part2, CONST int flags);
+ Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, CONST int flags, int index);
MODULE_SCOPE Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp,
- Var *varPtr, Var *arrayPtr, CONST char *part1,
- CONST char *part2, Tcl_Obj *newValuePtr,
- CONST int flags);
+ Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr,
+ CONST int flags, int index);
MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar (Tcl_Interp *interp,
- Var *varPtr, Var *arrayPtr, CONST char *part1,
- CONST char *part2, Tcl_Obj *incrPtr,
- CONST int flags);
+ Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr,
+ CONST int flags, int index);
+MODULE_SCOPE int TclPtrObjMakeUpvar(Tcl_Interp *interp, Var *otherPtr,
+ Tcl_Obj *myNamePtr, int myFlags, int index);
MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr);
/*
+ * The new extended interface to the variable traces
+ */
+
+MODULE_SCOPE int TclObjCallVarTraces (Interp * iPtr, Var * arrayPtr,
+ Var * varPtr, Tcl_Obj * part1Ptr,
+ Tcl_Obj * part2Ptr, int flags,
+ int leaveErrMsg, int index);
+
+
+
+/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
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 23 Jul 2007 19:14:14 -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/tclLiteral.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclLiteral.c,v
retrieving revision 1.30
diff -u -r1.30 tclLiteral.c
--- generic/tclLiteral.c 21 Mar 2007 16:25:28 -0000 1.30
+++ generic/tclLiteral.c 23 Jul 2007 19:14:14 -0000
@@ -31,7 +31,7 @@
*/
static int AddLocalLiteralEntry(CompileEnv *envPtr,
- LiteralEntry *globalPtr, int localHash);
+ Tcl_Obj *objPtr, int localHash);
static void ExpandLocalLiteralArray(CompileEnv *envPtr);
static unsigned int HashString(const char *bytes, int length);
static void RebuildLiteralTable(LiteralTable *tablePtr);
@@ -216,21 +216,20 @@
/*
*----------------------------------------------------------------------
*
- * TclRegisterLiteral --
+ * TclCreateLiteral --
*
- * Find, or if necessary create, an object in a CompileEnv literal array
- * that has a string representation matching the argument string.
+ * Find, or if necessary create, an object in the interpreter's literal
+ * table that has a string representation matching the argument
+ * string. If nsPtr!=NULL then only literals stored for the namespace are
+ * considered.
*
* Results:
- * The index in the CompileEnv's literal array that references a shared
- * literal matching the string. The object is created if necessary.
+ * The literal object. If it was created in this call *newPtr is set to
+ * 1, else 0. NULL is returned if newPtr==NULL and no literal is found.
*
* Side effects:
- * To maximize sharing, we look up the string in the interpreter's global
- * literal table. If not found, we create a new shared literal in the
- * global table. We then add a reference to the shared literal in the
- * CompileEnv's literal array.
- *
+ * Increments the ref count of the global LiteralEntry since the caller
+ * now holds a reference.
* If LITERAL_ON_HEAP is set in flags, this function is given ownership
* of the string: if an object is created then its string representation
* is set directly from string, otherwise the string is freed. Typically,
@@ -240,77 +239,29 @@
*----------------------------------------------------------------------
*/
-int
-TclRegisterLiteral(
- CompileEnv *envPtr, /* Points to the CompileEnv in whose object
- * array an object is found or created. */
- register char *bytes, /* Points to string for which to find or
- * create an object in CompileEnv's object
- * array. */
- int length, /* Number of bytes in the string. If < 0, the
- * string consists of all bytes up to the
- * first null character. */
- int flags) /* If LITERAL_ON_HEAP then the caller already
- * malloc'd bytes and ownership is passed to
- * this function. If LITERAL_NS_SCOPE then
- * the literal shouldnot be shared accross
- * namespaces. */
+Tcl_Obj *
+TclCreateLiteral(
+ Interp *iPtr,
+ char *bytes,
+ int length,
+ unsigned int hash, /* The string's hash. If -1, it will be computed here */
+ int *newPtr,
+ Namespace *nsPtr,
+ int flags,
+ LiteralEntry **globalPtrPtr)
{
- Interp *iPtr = envPtr->iPtr;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
- LiteralTable *localTablePtr = &(envPtr->localLitTable);
- register LiteralEntry *globalPtr, *localPtr;
- register Tcl_Obj *objPtr;
- unsigned int hash;
- int localHash, globalHash, objIndex;
- Namespace *nsPtr;
-
- if (length < 0) {
- length = (bytes ? strlen(bytes) : 0);
- }
- hash = HashString(bytes, length);
-
- /*
- * Is the literal already in the CompileEnv's local literal array? If so,
- * just return its index.
- */
-
- localHash = (hash & localTablePtr->mask);
- for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL;
- localPtr = localPtr->nextPtr) {
- objPtr = localPtr->objPtr;
- if ((objPtr->length == length) && ((length == 0)
- || ((objPtr->bytes[0] == bytes[0])
- && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
- if (flags & LITERAL_ON_HEAP) {
- ckfree(bytes);
- }
- objIndex = (localPtr - envPtr->literalArrayPtr);
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyLocalLiteralTable(envPtr);
-#endif /*TCL_COMPILE_DEBUG*/
-
- return objIndex;
- }
- }
-
- /*
- * The literal is new to this CompileEnv. Should it be shared accross
- * namespaces? If it is a fully qualified name, the namespace
- * specification is not needed to avoid sharing.
- */
-
- if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr
- && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) {
- nsPtr = iPtr->varFramePtr->nsPtr;
- } else {
- nsPtr = NULL;
- }
-
+ LiteralEntry *globalPtr;
+ int globalHash;
+ Tcl_Obj *objPtr;
+
/*
* Is it in the interpreter's global literal table?
*/
+ if (hash == (unsigned int) -1) {
+ hash = HashString(bytes, length);
+ }
globalHash = (hash & globalTablePtr->mask);
for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL;
globalPtr = globalPtr->nextPtr) {
@@ -320,29 +271,32 @@
|| ((objPtr->bytes[0] == bytes[0])
&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
/*
- * A global literal was found. Add an entry to the CompileEnv's
- * local literal array.
+ * A literal was found: return it
*/
+ if (newPtr) {
+ *newPtr = 0;
+ }
+ if (globalPtrPtr) {
+ *globalPtrPtr = globalPtr;
+ }
if (flags & LITERAL_ON_HEAP) {
ckfree(bytes);
}
- objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
-#ifdef TCL_COMPILE_DEBUG
- if (globalPtr->refCount < 1) {
- Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
- (length>60? 60 : length), bytes, globalPtr->refCount);
- }
- TclVerifyLocalLiteralTable(envPtr);
-#endif /*TCL_COMPILE_DEBUG*/
- return objIndex;
+ globalPtr->refCount++;
+ return objPtr;
}
}
+ if (!newPtr) {
+ if (flags & LITERAL_ON_HEAP) {
+ ckfree(bytes);
+ }
+ return NULL;
+ }
/*
* The literal is new to the interpreter. Add it to the global literal
- * table then add an entry to the CompileEnv's local literal array.
- * Convert the object to an integer object if possible.
+ * table.
*/
TclNewObj(objPtr);
@@ -363,7 +317,7 @@
globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
globalPtr->objPtr = objPtr;
- globalPtr->refCount = 0;
+ globalPtr->refCount = 1;
globalPtr->nsPtr = nsPtr;
globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
globalTablePtr->buckets[globalHash] = globalPtr;
@@ -377,11 +331,9 @@
if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
RebuildLiteralTable(globalTablePtr);
}
- objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable(iPtr);
- TclVerifyLocalLiteralTable(envPtr);
{
LiteralEntry *entryPtr;
int found, i;
@@ -409,6 +361,121 @@
iPtr->stats.literalCount[TclLog2(length)]++;
#endif /*TCL_COMPILE_STATS*/
+ if (globalPtrPtr) {
+ *globalPtrPtr = globalPtr;
+ }
+ *newPtr = 1;
+ return objPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRegisterLiteral --
+ *
+ * Find, or if necessary create, an object in a CompileEnv literal array
+ * that has a string representation matching the argument string.
+ *
+ * Results:
+ * The index in the CompileEnv's literal array that references a shared
+ * literal matching the string. The object is created if necessary.
+ *
+ * Side effects:
+ * To maximize sharing, we look up the string in the interpreter's global
+ * literal table. If not found, we create a new shared literal in the
+ * global table. We then add a reference to the shared literal in the
+ * CompileEnv's literal array.
+ *
+ * If LITERAL_ON_HEAP is set in flags, this function is given ownership
+ * of the string: if an object is created then its string representation
+ * is set directly from string, otherwise the string is freed. Typically,
+ * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
+ * buffer holding the result of backslash substitutions.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclRegisterLiteral(
+ CompileEnv *envPtr, /* Points to the CompileEnv in whose object
+ * array an object is found or created. */
+ register char *bytes, /* Points to string for which to find or
+ * create an object in CompileEnv's object
+ * array. */
+ int length, /* Number of bytes in the string. If < 0, the
+ * string consists of all bytes up to the
+ * first null character. */
+ int flags) /* If LITERAL_ON_HEAP then the caller already
+ * malloc'd bytes and ownership is passed to
+ * this function. If LITERAL_NS_SCOPE then
+ * the literal shouldnot be shared accross
+ * namespaces. */
+{
+ Interp *iPtr = envPtr->iPtr;
+ LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ LiteralEntry *globalPtr, *localPtr;
+ Tcl_Obj *objPtr;
+ unsigned int hash;
+ int localHash, objIndex, new;
+ Namespace *nsPtr;
+
+ if (length < 0) {
+ length = (bytes ? strlen(bytes) : 0);
+ }
+ hash = HashString(bytes, length);
+
+ /*
+ * Is the literal already in the CompileEnv's local literal array? If so,
+ * just return its index.
+ */
+
+ localHash = (hash & localTablePtr->mask);
+ for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL;
+ localPtr = localPtr->nextPtr) {
+ objPtr = localPtr->objPtr;
+ if ((objPtr->length == length) && ((length == 0)
+ || ((objPtr->bytes[0] == bytes[0])
+ && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
+ if (flags & LITERAL_ON_HEAP) {
+ ckfree(bytes);
+ }
+ objIndex = (localPtr - envPtr->literalArrayPtr);
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyLocalLiteralTable(envPtr);
+#endif /*TCL_COMPILE_DEBUG*/
+
+ return objIndex;
+ }
+ }
+
+ /*
+ * The literal is new to this CompileEnv. Should it be shared accross
+ * namespaces? If it is a fully qualified name, the namespace
+ * specification is not needed to avoid sharing.
+ */
+
+ if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr
+ && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) {
+ nsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ nsPtr = NULL;
+ }
+
+ /*
+ * Is it in the interpreter's global literal table? If not, create it.
+ */
+
+ objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr,
+ flags, &globalPtr);
+ objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
+
+#ifdef TCL_COMPILE_DEBUG
+ if (globalPtr->refCount < 1) {
+ Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
+ (length>60? 60 : length), bytes, globalPtr->refCount);
+ }
+ TclVerifyLocalLiteralTable(envPtr);
+#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
}
@@ -582,10 +649,8 @@
* literal.
*
* Side effects:
- * Increments the ref count of the global LiteralEntry since the
- * CompileEnv now refers to the literal. Expands the literal array if
- * necessary. May rebuild the hash bucket array of the CompileEnv's
- * literal array if it becomes too large.
+ * Expands the literal array if necessary. May rebuild the hash bucket
+ * array of the CompileEnv's literal array if it becomes too large.
*
*----------------------------------------------------------------------
*/
@@ -594,15 +659,14 @@
AddLocalLiteralEntry(
register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
* the object is to be inserted. */
- LiteralEntry *globalPtr, /* Points to the global LiteralEntry for the
- * literal to add to the CompileEnv. */
+ Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */
int localHash) /* Hash value for the literal's string. */
{
register LiteralTable *localTablePtr = &(envPtr->localLitTable);
LiteralEntry *localPtr;
int objIndex;
- objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);
+ objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr);
/*
* Add the literal to the local table.
@@ -612,8 +676,6 @@
localTablePtr->buckets[localHash] = localPtr;
localTablePtr->numEntries++;
- globalPtr->refCount++;
-
/*
* If the CompileEnv's local literal table has exceeded a decent size,
* rebuild it with more buckets.
@@ -633,14 +695,14 @@
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ;
localPtr=localPtr->nextPtr) {
- if (localPtr->objPtr == globalPtr->objPtr) {
+ if (localPtr->objPtr == objPtr) {
found = 1;
}
}
}
if (!found) {
- bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
(length>60? 60 : length), bytes);
}
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 23 Jul 2007 19:14:16 -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.
@@ -462,6 +463,10 @@
}
if (framePtr->numCompiledLocals > 0) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
+ if (--framePtr->localCachePtr->refCount == 0) {
+ TclFreeLocalCache(interp, framePtr->localCachePtr);
+ }
+ framePtr->localCachePtr = NULL;
}
/*
@@ -725,7 +730,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 +798,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 +1061,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 +2495,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
@@ -2796,7 +2678,7 @@
* to discard the old rep and create a new one.
*/
- resPtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
+ resPtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr != &tclNsNameType)
|| (resPtr == NULL)
|| (resPtr->refNsPtr &&
@@ -2807,7 +2689,7 @@
result = tclNsNameType.setFromAnyProc(interp, objPtr);
- resPtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
+ resPtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
if ((result == TCL_OK) && resPtr) {
nsPtr = resPtr->nsPtr;
if (nsPtr && (nsPtr->flags & NS_DEAD)) {
@@ -4596,7 +4478,7 @@
savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
- otherPtr = TclObjLookupVar(interp, objv[0], NULL,
+ otherPtr = TclObjLookupVarEx(interp, objv[0], NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
@@ -4722,7 +4604,7 @@
* to free */
{
register ResolvedNsName *resNamePtr = (ResolvedNsName *)
- objPtr->internalRep.otherValuePtr;
+ objPtr->internalRep.twoPtrValue.ptr1;
Namespace *nsPtr;
/*
@@ -4775,9 +4657,9 @@
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
register ResolvedNsName *resNamePtr = (ResolvedNsName *)
- srcPtr->internalRep.otherValuePtr;
+ srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->internalRep.otherValuePtr = (void *) resNamePtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resNamePtr;
if (resNamePtr != NULL) {
resNamePtr->refCount++;
}
@@ -4840,7 +4722,7 @@
if (nsPtr) {
nsPtr->refCount++;
- resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
+ resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclNsNameType)
&& resNamePtr && (resNamePtr->refCount == 1)) {
/*
@@ -4855,7 +4737,7 @@
TclFreeIntRep(objPtr);
resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
resNamePtr->refCount = 1;
- objPtr->internalRep.otherValuePtr = (void *) resNamePtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = (void *) resNamePtr;
objPtr->typePtr = &tclNsNameType;
}
resNamePtr->nsPtr = nsPtr;
@@ -4868,7 +4750,7 @@
}
} else {
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = (void *) NULL;
+ objPtr->internalRep.twoPtrValue.ptr1 = (void *) NULL;
objPtr->typePtr = &tclNsNameType;
}
return TCL_OK;
@@ -6994,27 +6876,32 @@
? "while executing" : "invoked from within"),
(overflow ? limit : length), command, (overflow ? "..." : "")));
- varPtr = TclObjLookupVar(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
+ varPtr = TclObjLookupVarEx(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 23 Jul 2007 19:14:16 -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 23 Jul 2007 19:14:16 -0000
@@ -27,13 +27,15 @@
static int InitArgsAndLocals(Tcl_Interp *interp,
Tcl_Obj *procNameObj, int skip);
static void InitCompiledLocals(Tcl_Interp *interp,
- ByteCode *codePtr, CompiledLocal *localPtr,
- Var *varPtr, Namespace *nsPtr);
+ ByteCode *codePtr, Var *defPtr,
+ Namespace *nsPtr);
+static void InitLocalCache(Proc *procPtr);
static int PushProcCallFrame(ClientData clientData,
register Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[], int isLambda);
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
+static int ProcWrongNumArgs(Tcl_Interp *interp, int skip);
static void MakeProcError(Tcl_Interp *interp,
Tcl_Obj *procNameObj);
static void MakeLambdaError(Tcl_Interp *interp,
@@ -527,13 +529,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 +594,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) {
@@ -1031,161 +1037,21 @@
*/
static int
-InitArgsAndLocals(
- register Tcl_Interp *interp,/* Interpreter in which procedure was
- * invoked. */
- Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
- int skip) /* Number of initial arguments to be skipped,
- * i.e., words in the "command name". */
+ProcWrongNumArgs(
+ Tcl_Interp *interp, int skip)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
- register Var *varPtr;
- register CompiledLocal *localPtr;
- int localCt, numArgs, argCt, i, imax;
- Var *compiledLocals;
- Tcl_Obj *const *argObjs;
+ register Var *defPtr;
+ int localCt = procPtr->numCompiledLocals, numArgs, i;
Tcl_Obj **desiredObjs;
- const char *final;
-
- /*
- * 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;
-
- /*
- * Match and assign the call's actual parameters to the procedure's formal
- * arguments. The formal arguments are described by the first numArgs
- * entries in both the Proc structure's local variable list and the call
- * frame's local variable array.
- */
-
- numArgs = procPtr->numArgs;
- argCt = framePtr->objc - skip; /* Set it to the number of args to the
- * procedure. */
- argObjs = framePtr->objv + skip;
- varPtr = framePtr->compiledLocals;
- localPtr = procPtr->firstLocalPtr;
- if (numArgs == 0) {
- if (argCt) {
- goto incorrectArgs;
- } else {
- goto correctArgs;
- }
- }
- imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
- for (i = 0; i < imax; i++) {
- /*
- * "Normal" arguments; last formal is special, depends on it being
- * 'args'.
- */
-
- Tcl_Obj *objPtr = argObjs[i];
-
- 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;
- }
- for (; i < numArgs-1; i++) {
- /*
- * This loop is entered if argCt < (numArgs-1). Set default values;
- * last formal is special.
- */
-
- if (localPtr->defValuePtr != NULL) {
- Tcl_Obj *objPtr = localPtr->defValuePtr;
-
- 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 {
- goto incorrectArgs;
- }
- }
-
- /*
- * When we get here, the last formal argument remains to be defined:
- * localPtr and varPtr point to the last argument to be initialized.
- */
-
- if (localPtr->flags & VAR_IS_ARGS) {
- Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
-
- varPtr->value.objPtr = listPtr;
- Tcl_IncrRefCount(listPtr); /* Local var is a reference. */
- } else if (argCt == numArgs) {
- Tcl_Obj *objPtr = argObjs[i];
-
- varPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) {
- Tcl_Obj *objPtr = localPtr->defValuePtr;
-
- varPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- } else {
- 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;
-
- localPtr = localPtr->nextPtr;
- varPtr++;
-
- /*
- * Initialise and resolve the remaining compiledLocals.
- */
-
- correctArgs:
- if (localPtr) {
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
- }
-
- return TCL_OK;
-
-
- incorrectArgs:
- /*
- * Do initialise all compiled locals, to avoid problems at
- * DeleteLocalVars.
- */
-
- final = NULL;
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
-
+ const char *final = NULL;
+
/*
* Build up desired argument list for Tcl_WrongNumArgs
*/
+ numArgs = framePtr->procPtr->numArgs;
desiredObjs = (Tcl_Obj **) TclStackAlloc(interp,
(int) sizeof(Tcl_Obj *) * (numArgs+1));
@@ -1198,22 +1064,23 @@
#endif /* AVOID_HACKS_FOR_ITCL */
Tcl_IncrRefCount(desiredObjs[0]);
- localPtr = procPtr->firstLocalPtr;
- for (i=1 ; i<=numArgs ; i++) {
+ defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
+ for (i=1 ; i<=numArgs ; i++, defPtr++) {
Tcl_Obj *argObj;
+ Tcl_Obj *namePtr = localName(framePtr, i-1);
- if (localPtr->defValuePtr != NULL) {
+ if (defPtr->value.objPtr != NULL) {
TclNewObj(argObj);
- Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL);
- } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) {
+ Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
+ } else if (defPtr->flags & VAR_IS_ARGS) {
numArgs--;
final = "...";
break;
} else {
- argObj = Tcl_NewStringObj(localPtr->name, -1);
+ argObj = namePtr;
+ Tcl_IncrRefCount(namePtr);
}
desiredObjs[i] = argObj;
- localPtr = localPtr->nextPtr;
}
Tcl_ResetResult(interp);
@@ -1229,6 +1096,46 @@
/*
*----------------------------------------------------------------------
*
+ * TclInitCompiledLocals --
+ *
+ * This routine is invoked in order to initialize the compiled locals
+ * table for a new call frame.
+ *
+ * DEPRECATED: functionality has been inlined elsewhere; this function
+ * remains to insure binary compatibility with Itcl.
+ *
+
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May invoke various name resolvers in order to determine which
+ * variables are being referenced at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+TclInitCompiledLocals(
+ Tcl_Interp *interp, /* Current interpreter. */
+ CallFrame *framePtr, /* Call frame to initialize. */
+ Namespace *nsPtr) /* Pointer to current namespace. */
+{
+ Var *varPtr = framePtr->compiledLocals;
+ Tcl_Obj *bodyPtr;
+ ByteCode *codePtr;
+
+ bodyPtr = framePtr->procPtr->bodyPtr;
+ if (bodyPtr->typePtr != &tclByteCodeType) {
+ Tcl_Panic("body object for proc attached to frame is not a byte code type");
+ }
+ codePtr = bodyPtr->internalRep.otherValuePtr;
+
+ InitCompiledLocals(interp, codePtr, varPtr, nsPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* InitCompiledLocals --
*
* This routine is invoked in order to initialize the compiled locals
@@ -1248,14 +1155,29 @@
InitCompiledLocals(
Tcl_Interp *interp, /* Current interpreter. */
ByteCode *codePtr,
- CompiledLocal *localPtr,
Var *varPtr,
Namespace *nsPtr) /* Pointer to current namespace. */
{
Interp *iPtr = (Interp *) interp;
int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr);
- CompiledLocal *firstLocalPtr;
+ CompiledLocal *firstLocalPtr, *localPtr;
+ int varNum;
+
+ /*
+ * Find the localPtr corresponding to varPtr
+ */
+
+ varNum = varPtr - iPtr->framePtr->compiledLocals;
+ localPtr = iPtr->framePtr->procPtr->firstLocalPtr;
+ while (varNum--) {
+ localPtr = localPtr->nextPtr;
+ }
+ /*
+ //FIXME: old bytecompiled code: drop whatever flags are coming in (except
+ //maybe for VAR_TEMPORARY? Who cares really?) A job for tbcload, not us.
+ */
+
if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) {
/*
* Initialize the array of local variables stored in the call frame.
@@ -1266,31 +1188,21 @@
doInitCompiledLocals:
if (!haveResolvers) {
+ /*
+ * Should not be called: deadwood.
+ */
+
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 +1214,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;
}
}
}
@@ -1361,46 +1273,224 @@
goto doInitCompiledLocals;
}
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclInitCompiledLocals --
- *
- * This routine is invoked in order to initialize the compiled locals
- * table for a new call frame.
- *
- * DEPRECATED: functionality has been inlined elsewhere; this function
- * remains to insure binary compatibility with Itcl.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May invoke various name resolvers in order to determine which
- * variables are being referenced at runtime.
- *
- *----------------------------------------------------------------------
- */
void
-TclInitCompiledLocals(
- Tcl_Interp *interp, /* Current interpreter. */
- CallFrame *framePtr, /* Call frame to initialize. */
- Namespace *nsPtr) /* Pointer to current namespace. */
+TclFreeLocalCache(
+ Tcl_Interp *interp,
+ LocalCache *localCachePtr)
{
- Var *varPtr = framePtr->compiledLocals;
- Tcl_Obj *bodyPtr;
- ByteCode *codePtr;
- CompiledLocal *localPtr = framePtr->procPtr->firstLocalPtr;
+ int i;
+ Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
- bodyPtr = framePtr->procPtr->bodyPtr;
- if (bodyPtr->typePtr != &tclByteCodeType) {
- Tcl_Panic("body object for proc attached to frame is not a byte code type");
+ for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
+ Tcl_Obj *objPtr = *namePtrPtr;
+ /*
+ * Note that this can be called with interp==NULL, on interp
+ * deletion. In that case, the literal table and objects go away
+ * on their own.
+ */
+ if (objPtr) {
+ if (interp) {
+ TclReleaseLiteral(interp, objPtr);
+ } else {
+ Tcl_DecrRefCount(objPtr);
+ }
+ }
}
- codePtr = bodyPtr->internalRep.otherValuePtr;
+ ckfree((char *) localCachePtr);
+}
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
+static void
+InitLocalCache(Proc *procPtr)
+{
+ Interp *iPtr = procPtr->iPtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr;
+ int localCt = procPtr->numCompiledLocals;
+ int numArgs = procPtr->numArgs, i = 0;
+
+ Tcl_Obj **namePtr;
+ Var *varPtr;
+ LocalCache *localCachePtr;
+ int new;
+
+ /*
+ * 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.
+ */
+
+ localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache)
+ + (localCt-1)*sizeof(Tcl_Obj *)
+ + numArgs*sizeof(Var));
+
+ namePtr = &localCachePtr->varName0;
+ varPtr = (Var *) (namePtr + localCt);
+ localPtr = codePtr->procPtr->firstLocalPtr;
+ while (localPtr) {
+ if (TclIsVarTemporary(localPtr)) {
+ *namePtr = NULL;
+ } else {
+ *namePtr = TclCreateLiteral(iPtr, localPtr->name,
+ localPtr->nameLength, /* hash */ (unsigned int) -1,
+ &new, /* nsPtr */ NULL, 0, NULL);
+ Tcl_IncrRefCount(*namePtr);
+ }
+
+ if (i < numArgs) {
+ varPtr->flags = (localPtr->flags & VAR_IS_ARGS);
+ varPtr->value.objPtr = localPtr->defValuePtr;
+ varPtr++;
+ i++;
+ }
+ namePtr++;
+ localPtr=localPtr->nextPtr;
+ }
+ codePtr->localCachePtr = localCachePtr;
+ localCachePtr->refCount = 1;
+ localCachePtr->numVars = localCt;
+}
+
+static int
+InitArgsAndLocals(
+ register Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
+ int skip) /* Number of initial arguments to be skipped,
+ * i.e., words in the "command name". */
+{
+ CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
+ register Proc *procPtr = framePtr->procPtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ register Var *varPtr, *defPtr;
+ int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
+ Tcl_Obj *const *argObjs;
+
+ /*
+ * Make sure that the local cache of variable names and initial values has
+ * been initialised properly .
+ */
+
+ if (localCt) {
+ if (!codePtr->localCachePtr) {
+ InitLocalCache(procPtr) ;
+ }
+ framePtr->localCachePtr = codePtr->localCachePtr;
+ framePtr->localCachePtr->refCount++;
+ defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
+ } else {
+ defPtr = NULL;
+ }
+
+ /*
+ * Create the "compiledLocals" array. Make sure it is large enough to hold
+ * all the procedure's compiled local variables, including its formal
+ * parameters.
+ */
+
+ varPtr = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
+ framePtr->compiledLocals = varPtr;
+ framePtr->numCompiledLocals = localCt;
+
+ /*
+ * Match and assign the call's actual parameters to the procedure's formal
+ * arguments. The formal arguments are described by the first numArgs
+ * entries in both the Proc structure's local variable list and the call
+ * frame's local variable array.
+ */
+
+ numArgs = procPtr->numArgs;
+ argCt = framePtr->objc - skip; /* Set it to the number of args to the
+ * procedure. */
+ argObjs = framePtr->objv + skip;
+ if (numArgs == 0) {
+ if (argCt) {
+ goto incorrectArgs;
+ } else {
+ goto correctArgs;
+ }
+ }
+ imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
+ for (i = 0; i < imax; i++, varPtr++, defPtr++) {
+ /*
+ * "Normal" arguments; last formal is special, depends on it being
+ * 'args'.
+ */
+
+ Tcl_Obj *objPtr = argObjs[i];
+
+ varPtr->flags = 0;
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
+ }
+ for (; i < numArgs-1; i++, varPtr++, defPtr++) {
+ /*
+ * This loop is entered if argCt < (numArgs-1). Set default values;
+ * last formal is special.
+ */
+
+ Tcl_Obj *objPtr = defPtr->value.objPtr;
+
+ if (objPtr) {
+ varPtr->flags = 0;
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var reference. */
+ } else {
+ goto incorrectArgs;
+ }
+ }
+
+ /*
+ * When we get here, the last formal argument remains to be defined:
+ * defPtr and varPtr point to the last argument to be initialized.
+ */
+
+
+ varPtr->flags = 0;
+ if (defPtr->flags & VAR_IS_ARGS) {
+ Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
+
+ varPtr->value.objPtr = listPtr;
+ Tcl_IncrRefCount(listPtr); /* Local var is a reference. */
+ } else if (argCt == numArgs) {
+ Tcl_Obj *objPtr = argObjs[i];
+
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
+ } else if ((argCt < numArgs) && (defPtr->value.objPtr != NULL)) {
+ Tcl_Obj *objPtr = defPtr->value.objPtr;
+
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
+ } else {
+ goto incorrectArgs;
+ }
+ varPtr++;
+
+ /*
+ * Initialise and resolve the remaining compiledLocals. In the absence of
+ * resolvers, they are undefined local vars: (flags=0, value=NULL).
+ */
+
+ correctArgs:
+ if (numArgs < localCt) {
+ if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) {
+ memset(varPtr, 0, (localCt - numArgs)*sizeof(Var));
+ } else {
+ InitCompiledLocals(interp, codePtr, varPtr, framePtr->nsPtr);
+ }
+ }
+
+ return TCL_OK;
+
+
+ incorrectArgs:
+ /*
+ * Initialise all compiled locals to avoid problems at DeleteLocalVars.
+ */
+
+ memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr)*sizeof(Var));
+ return ProcWrongNumArgs(interp, skip);
}
/*
@@ -1437,7 +1527,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 +1539,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 +1549,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 +1585,7 @@
framePtr->objc = objc;
framePtr->objv = objv;
framePtr->procPtr = procPtr;
-
+
return TCL_OK;
}
@@ -1602,7 +1693,7 @@
result = TCL_ERROR;
} else {
register ByteCode *codePtr =
- procPtr->bodyPtr->internalRep.otherValuePtr;
+ procPtr->bodyPtr->internalRep.otherValuePtr;
codePtr->refCount++;
result = TclExecuteByteCode(interp, codePtr);
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 23 Jul 2007 19:14:16 -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 23 Jul 2007 19:14:23 -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);
}
@@ -2484,6 +2484,34 @@
*/
int
+TclObjCallVarTraces(
+ Interp *iPtr, /* Interpreter containing variable. */
+ register Var *arrayPtr, /* Pointer to array variable that contains the
+ * variable, or NULL if the variable isn't an
+ * element of an array. */
+ Var *varPtr, /* Variable whose traces are to be invoked. */
+ Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, /* Variable's two-part name. */
+ int flags, /* Flags passed to trace functions: indicates
+ * what's happening to variable, plus maybe
+ * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */
+ int leaveErrMsg, /* If true, and one of the traces indicates an
+ * error, then leave an error message and
+ * stack trace information in *iPTr. */
+ int index)
+{
+ char *part1, *part2;
+
+ if (!part1Ptr) {
+ part1Ptr = localName(iPtr->varFramePtr, index);
+ }
+ part1 = TclGetString(part1Ptr);
+ part2 = part2Ptr? TclGetString(part2Ptr) : NULL;
+
+ return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg);
+}
+
+int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
register Var *arrayPtr, /* Pointer to array variable that contains the
@@ -2508,7 +2536,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 +2548,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 +2604,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 +2650,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 +2756,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 +2867,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 +2897,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 +2924,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 +3026,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 +3042,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 +3082,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 +3120,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 +3193,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 +3234,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 23 Jul 2007 19:14:23 -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,87 @@
#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 inline Var * VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr);
+static inline Var * VarHashFirstVar(TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr);
+static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr);
+static inline void CleanupVar(Var *varPtr, Var *arrayPtr);
+
+#define VarHashGetValue(hPtr) \
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
+
+static inline Var *
+VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr)
+{
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, (char *) key, newPtr);
+ if (hPtr) {
+ return VarHashGetValue(hPtr);
+ } else {
+ return 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))
+
+#define VarHashFirstEntry(tablePtr, searchPtr) \
+ Tcl_FirstHashEntry((Tcl_HashTable *) (tablePtr), (searchPtr))
+
+#define VarHashNextEntry(searchPtr) \
+ Tcl_NextHashEntry((searchPtr))
+
+static inline Var *
+VarHashFirstVar(TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr)
+{
+ Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr);
+ if (hPtr) {
+ return VarHashGetValue(hPtr);
+ } else {
+ return NULL;
+ }
+}
+
+static inline Var *
+VarHashNextVar(Tcl_HashSearch *searchPtr)
+{
+ Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr);
+ if (hPtr) {
+ return VarHashGetValue(hPtr);
+ } else {
+ return NULL;
+ }
+}
+
+#define VarHashGetKey(varPtr) \
+ (((VarInHash *)(varPtr))->entry.key.objPtr)
+
+#define VarHashDeleteTable(tablePtr) \
+ Tcl_DeleteHashTable((Tcl_HashTable *) (tablePtr))
+
/*
* The strings below are used to indicate what went wrong when a variable
* access is denied.
@@ -37,7 +119,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 +132,20 @@
* Forward references to functions defined later in this file:
*/
-static void DeleteSearches(Var *arrayVarPtr);
-static void DeleteArray(Interp *iPtr, const char *arrayName,
+static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ Tcl_Obj *patternPtr, int includeLinks);
+static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
+static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
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);
+ Tcl_Obj *myNamePtr, int myFlags, int index);
static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
- const char *varName, Tcl_Obj *handleObj);
+ Tcl_Obj *varNamePtr, Tcl_Obj *handleObj);
static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
- Interp *iPtr, const char *part1,
- const char *part2, int flags, int reachable);
+ Interp *iPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, int flags);
static int SetArraySearchObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
/*
@@ -70,10 +154,8 @@
*/
MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp,
- const char *varName, int flags, const int create,
+ Tcl_Obj *varNamePtr, int flags, const int create,
const char **errMsgPtr, int *indexPtr);
-MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp,
- Tcl_Obj *part1Ptr, const char *part2, int flags);
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
@@ -145,6 +227,69 @@
"array search",
NULL, NULL, NULL, SetArraySearchObj
};
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCleanupVar --
+ *
+ * This function is called when it looks like it may be OK to free up a
+ * variable's storage. If the variable is in a hashtable, its Var
+ * structure and hash table entry will be freed along with those of its
+ * containing array, if any. This function is called, for example, when
+ * a trace on a variable deletes a variable.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If the variable (or its containing array) really is dead and in a
+ * hashtable, then its Var structure, and possibly its hash table entry,
+ * is freed up.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline void
+CleanupVar(
+ Var *varPtr, /* Pointer to variable that may be a candidate
+ * for being expunged. */
+ Var *arrayPtr) /* Array that contains the variable, or NULL
+ * if this variable isn't an array element. */
+{
+ if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
+ && !TclIsVarTraced(varPtr)
+ && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) {
+ if (VarHashRefCount(varPtr) == 0) {
+ ckfree((char *) varPtr);
+ } else {
+ VarHashDeleteEntry(varPtr);
+ }
+ }
+ if (arrayPtr != NULL) {
+ if (TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr)
+ && !TclIsVarTraced(arrayPtr)
+ && (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) {
+ if (VarHashRefCount(arrayPtr) == 0) {
+ ckfree((char *) arrayPtr);
+ } else {
+ VarHashDeleteEntry(arrayPtr);
+ }
+ }
+ }
+}
+
+void
+TclCleanupVar(
+ Var *varPtr, /* Pointer to variable that may be a candidate
+ * for being expunged. */
+ Var *arrayPtr) /* Array that contains the variable, or NULL
+ * if this variable isn't an array element. */
+{
+ return CleanupVar(varPtr, arrayPtr);
+}
+
/*
*----------------------------------------------------------------------
@@ -153,8 +298,8 @@
*
* This function is used to locate a variable given its name(s). It has
* been mostly superseded by TclObjLookupVar, it is now only used by the
- * string-based interfaces. It is kept in tcl8.4 mainly because it is in
- * the internal stubs table, so that some extension may be calling it.
+ * trace code. It is kept in tcl8.5 mainly because it is in the internal
+ * stubs table, so that some extension may be calling it.
*
* Results:
* The return value is a pointer to the variable structure indicated by
@@ -208,89 +353,17 @@
* address of array variable. Otherwise this
* is set to NULL. */
{
+ Tcl_Obj *part1Ptr;
Var *varPtr;
- const char *elName; /* Name of array element or NULL; may be same
- * as part2, or may be openParen+1. */
- int openParen, closeParen; /* If this function parses a name into array
- * and index, these are the offsets to the
- * parens around the index. Otherwise they are
- * -1. */
- register const char *p;
- const char *errMsg = NULL;
- int index;
-#define VAR_NAME_BUF_SIZE 26
- char buffer[VAR_NAME_BUF_SIZE];
- char *newVarName = buffer;
-
- varPtr = NULL;
- *arrayPtrPtr = NULL;
- openParen = closeParen = -1;
- /*
- * Parse part1 into array name and index.
- * Always check if part1 is an array element name and allow it only if
- * part2 is not given. (If one does not care about creating array elements
- * that can't be used from tcl, and prefer slightly better performance,
- * one can put the following in an if (part2 == NULL) { ... } block and
- * remove the part2's test and error reporting or move that code in array
- * set.)
- */
-
- elName = part2;
- for (p = part1; *p ; p++) {
- if (*p == '(') {
- openParen = p - part1;
- do {
- p++;
- } while (*p != '\0');
- p--;
- if (*p == ')') {
- if (part2 != NULL) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- TclVarErrMsg(interp, part1, part2, msg, needArray);
- }
- return NULL;
- }
- closeParen = p - part1;
- } else {
- openParen = -1;
- }
- break;
- }
- }
- if (openParen != -1) {
- if (closeParen >= VAR_NAME_BUF_SIZE) {
- newVarName = ckalloc((unsigned int) (closeParen+1));
- }
- memcpy(newVarName, part1, (unsigned int) closeParen);
- newVarName[openParen] = '\0';
- newVarName[closeParen] = '\0';
- part1 = newVarName;
- elName = newVarName + openParen + 1;
- }
+ part1Ptr = Tcl_NewStringObj(part1, -1);
+ Tcl_IncrRefCount(part1Ptr);
- varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1,
- &errMsg, &index);
- if (varPtr == NULL) {
- if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
- TclVarErrMsg(interp, part1, elName, msg, errMsg);
- }
- } else {
- while (TclIsVarLink(varPtr)) {
- varPtr = varPtr->value.linkPtr;
- }
- if (elName != NULL) {
- *arrayPtrPtr = varPtr;
- varPtr = TclLookupArrayElement(interp, part1, elName, flags,
- msg, createPart1, createPart2, varPtr);
- }
- }
- if (newVarName != buffer) {
- ckfree(newVarName);
- }
+ varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg,
+ createPart1, createPart2, arrayPtrPtr);
+ TclDecrRefCount(part1Ptr);
return varPtr;
-#undef VAR_NAME_BUF_SIZE
}
/*
@@ -357,6 +430,36 @@
* address of array variable. Otherwise this
* is set to NULL. */
{
+ Tcl_Obj *part2Ptr;
+ Var *resPtr;
+
+ if (part2) {
+ part2Ptr = Tcl_NewStringObj(part2, -1);
+ Tcl_IncrRefCount(part2Ptr);
+ } else {
+ part2Ptr = NULL;
+ }
+
+ resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
+ flags, msg, createPart1, createPart2, arrayPtrPtr);
+
+ if (part2Ptr) {
+ Tcl_DecrRefCount(part2Ptr);
+ }
+
+ return resPtr;
+}
+
+Var *
+TclObjLookupVarEx(Tcl_Interp * interp,
+ Tcl_Obj * part1Ptr,
+ Tcl_Obj * part2Ptr,
+ int flags,
+ CONST char * msg,
+ CONST int createPart1,
+ CONST int createPart2,
+ Var ** arrayPtrPtr)
+{
Interp *iPtr = (Interp *) interp;
register Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
@@ -368,7 +471,9 @@
const char *errMsg = NULL;
CallFrame *varFramePtr = iPtr->varFramePtr;
Namespace *nsPtr;
-
+ char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
+ char *newPart2 = NULL;
+
/*
* If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed
* parts.
@@ -377,19 +482,22 @@
*arrayPtrPtr = NULL;
if (typePtr == &tclParsedVarNameType) {
if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
- if (part2 != NULL) {
+ if (part2Ptr != NULL) {
/*
* ERROR: part1Ptr is already an array element, cannot specify
* a part2.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
- part1 = TclGetString(part1Ptr);
- TclVarErrMsg(interp, part1, part2, msg, needArray);
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, needArray, -1);
}
return NULL;
}
- part2 = part1Ptr->internalRep.twoPtrValue.ptr2;
+ part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
+ if (newPart2) {
+ part2Ptr = Tcl_NewStringObj(newPart2, -1);
+ Tcl_IncrRefCount(part2Ptr);
+ }
part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
typePtr = part1Ptr->typePtr;
}
@@ -397,23 +505,34 @@
}
part1 = Tcl_GetStringFromObj(part1Ptr, &len1);
- nsPtr = varFramePtr->nsPtr;
- if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
+ if (varFramePtr) {
+ nsPtr = varFramePtr->nsPtr;
+ if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
+ goto doParse;
+ }
+ } else {
+ /*
+ * Some variables in the global ns have to be initialized before the
+ * root call frame is in place.
+ */
+
+ nsPtr = NULL;
goto doParse;
}
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.
*/
-
- varPtr = &(varFramePtr->compiledLocals[localIndex]);
- if ((varPtr->name != NULL) && (strcmp(part1, varPtr->name) == 0)) {
+ Tcl_Obj *namePtr = localName(iPtr->varFramePtr, localIndex);
+
+ if (namePtr && (strcmp(part1, TclGetString(namePtr)) == 0)) {
+ varPtr = (Var *) &(varFramePtr->compiledLocals[localIndex]);
goto donePart1;
}
}
@@ -438,14 +557,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
@@ -465,14 +584,13 @@
*/
register int i;
- char *newPart2;
len2 = -1;
for (i = 0; i < len1; i++) {
if (*(part1 + i) == '(') {
- if (part2 != NULL) {
+ if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
- TclVarErrMsg(interp, part1, part2, msg, needArray);
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, needArray, -1);
}
}
@@ -489,6 +607,8 @@
memcpy(newPart2, part2, (unsigned int) len2);
*(newPart2+len2) = '\0';
part2 = newPart2;
+ part2Ptr = Tcl_NewStringObj(newPart2, -1);
+ Tcl_IncrRefCount(part2Ptr);
/*
* Free the internal rep of the original part1Ptr, now renamed
@@ -528,11 +648,14 @@
TclFreeIntRep(part1Ptr);
part1Ptr->typePtr = NULL;
- varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1,
+ varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
- TclVarErrMsg(interp, part1, part2, msg, errMsg);
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1);
+ }
+ if (newPart2) {
+ Tcl_DecrRefCount(part2Ptr);
}
return NULL;
}
@@ -577,8 +700,8 @@
if (varPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
part1 = TclGetString(part1Ptr);
- TclVarErrMsg(interp, part1, part2, msg,
- "Cached variable reference is NULL.");
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
+ "Cached variable reference is NULL.", -1);
}
return NULL;
}
@@ -587,15 +710,17 @@
varPtr = varPtr->value.linkPtr;
}
- if (part2 != NULL) {
+ if (part2Ptr != NULL) {
/*
* Array element sought: look it up.
*/
- part1 = TclGetString(part1Ptr);
*arrayPtrPtr = varPtr;
- varPtr = TclLookupArrayElement(interp, part1, part2, flags, msg,
- createPart1, createPart2, varPtr);
+ varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg,
+ createPart1, createPart2, varPtr, -1);
+ if (newPart2) {
+ Tcl_DecrRefCount(part2Ptr);
+ }
}
return varPtr;
}
@@ -659,7 +784,7 @@
Var *
TclLookupSimpleVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
- const char *varName, /* This is a simple variable name that could
+ Tcl_Obj *varNamePtr, /* This is a simple variable name that could
* represent a scalar or an array. */
int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits
@@ -676,15 +801,15 @@
* 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;
+ const char *varName = TclGetString(varNamePtr);
varPtr = NULL;
varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
@@ -771,14 +896,12 @@
* 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) {
+ Tcl_Obj *tailPtr;
+
if (create) { /* var wasn't found so create it */
TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
@@ -789,12 +912,12 @@
if (tail == NULL) {
*errMsgPtr = missingName;
return NULL;
+ } else if (tail != varName) {
+ tailPtr = Tcl_NewStringObj(tail, -1);
+ } else {
+ tailPtr = varNamePtr;
}
- hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = varNsPtr;
+ varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &new);
if (lookGlobal) {
/*
* The variable was created starting from the global
@@ -814,50 +937,35 @@
} else { /* local var: look in frame varFramePtr */
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;
+ Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0;
+
+ for (i=0 ; i<localCt ; i++, objPtrPtr++) {
+ Tcl_Obj *objPtr = *objPtrPtr;
+ if (objPtr) {
+ char *localName = TclGetString(objPtr);
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, varNamePtr, &new);
} else {
- hPtr = NULL;
+ varPtr = NULL;
if (tablePtr != NULL) {
- hPtr = Tcl_FindHashEntry(tablePtr, varName);
+ varPtr = VarHashFindVar(tablePtr, varNamePtr);
}
- if (hPtr == NULL) {
+ if (varPtr == NULL) {
*errMsgPtr = noSuchVar;
- return NULL;
}
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
}
return varPtr;
@@ -903,8 +1011,9 @@
Var *
TclLookupArrayElement(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
- const char *arrayName, /* This is the name of the array. */
- const char *elName, /* Name of element within array. */
+ Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if
+ * index>= 0. */
+ Tcl_Obj *elNamePtr, /* Name of element within array. */
const int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */
const char *msg, /* Verb to use in error messages, e.g. "read"
* or "set". Only needed if TCL_LEAVE_ERR_MSG
@@ -916,11 +1025,13 @@
const int createElem, /* If 1, create hash table entry for the
* element, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
- Var *arrayPtr) /* Pointer to the array's Var structure. */
+ Var *arrayPtr, /* Pointer to the array's Var structure. */
+ int index) /* If >=0, the index of the local array. */
{
- 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
@@ -930,7 +1041,7 @@
if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
if (!createArray) {
if (flags & TCL_LEAVE_ERR_MSG) {
- TclVarErrMsg(interp, arrayName, elName, msg, noSuchVar);
+ TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, noSuchVar, index);
}
return NULL;
}
@@ -940,49 +1051,49 @@
* 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);
+ TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, danglingVar, index);
}
return NULL;
}
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);
+ TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, index);
}
return NULL;
}
if (createElem) {
- hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new);
+ varPtr = VarHashCreateVar(arrayPtr->value.tablePtr, elNamePtr, &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, elNamePtr);
+ if (varPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
- TclVarErrMsg(interp, arrayName, elName, msg, noSuchElement);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", elName,
+ TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, noSuchElement, index);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", TclGetString(elNamePtr),
NULL);
}
- return NULL;
}
}
- return (Var *) Tcl_GetHashValue(hPtr);
+ return varPtr;
}
/*
@@ -1097,17 +1208,25 @@
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
- Var *varPtr, *arrayPtr;
+ Tcl_Obj *part1Ptr, *part2Ptr, *resPtr;
- /* Filter to pass through only the flags this interface supports. */
- flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
- varPtr = TclLookupVar(interp, part1, part2, flags, "read",
- /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
- if (varPtr == NULL) {
- return NULL;
+ part1Ptr = Tcl_NewStringObj(part1, -1);
+ Tcl_IncrRefCount(part1Ptr);
+ if (part2) {
+ part2Ptr = Tcl_NewStringObj(part2, -1);
+ Tcl_IncrRefCount(part2Ptr);
+ } else {
+ part2Ptr = NULL;
}
+
+ resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
- return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
+ Tcl_DecrRefCount(part1Ptr);
+ if (part2Ptr) {
+ Tcl_DecrRefCount(part2Ptr);
+ }
+
+ return resPtr;
}
/*
@@ -1147,20 +1266,16 @@
* TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
- char *part1, *part2;
-
- part1 = TclGetString(part1Ptr);
- part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr));
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
- varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read",
/*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
- return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
+ return TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, -1);
}
/*
@@ -1192,25 +1307,27 @@
register Var *varPtr, /* The variable to be read.*/
Var *arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
- const char *part1, /* Name of an array (if part2 is non-NULL) or
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. */
- const char *part2, /* If non-NULL, gives the name of an element
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
* in the array part1. */
- const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
+ const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
+ int index)
{
Interp *iPtr = (Interp *) interp;
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 (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
+ if ((varPtr->flags & VAR_TRACED_READ)
+ || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) {
+ if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr,
+ part1Ptr, part2Ptr,
(flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
- | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
+ | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG), index)) {
goto errorReturn;
}
}
@@ -1224,7 +1341,7 @@
}
if (flags & TCL_LEAVE_ERR_MSG) {
- if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL)
+ if (TclIsVarUndefined(varPtr) && arrayPtr
&& !TclIsVarUndefined(arrayPtr)) {
msg = noSuchElement;
} else if (TclIsVarArray(varPtr)) {
@@ -1232,7 +1349,7 @@
} else {
msg = noSuchVar;
}
- TclVarErrMsg(interp, part1, part2, "read", msg);
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "read", msg, index);
}
/*
@@ -1443,22 +1560,25 @@
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
* TCL_LEAVE_ERR_MSG. */
{
- Var *varPtr, *arrayPtr;
+ Tcl_Obj *part1Ptr, *part2Ptr, *resPtr;
- /* Filter to pass through only the flags this interface supports. */
- flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
- |TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
- varPtr = TclLookupVar(interp, part1, part2, flags, "set",
- /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
- if (varPtr == NULL) {
- if (newValuePtr->refCount == 0) {
- Tcl_DecrRefCount(newValuePtr);
- }
- return NULL;
+ part1Ptr = Tcl_NewStringObj(part1, -1);
+ Tcl_IncrRefCount(part1Ptr);
+ if (part2) {
+ part2Ptr = Tcl_NewStringObj(part2, -1);
+ Tcl_IncrRefCount(part2Ptr);
+ } else {
+ part2Ptr = NULL;
}
+
+ resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags);
- return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
- newValuePtr, flags);
+ Tcl_DecrRefCount(part1Ptr);
+ if (part2Ptr) {
+ Tcl_DecrRefCount(part2Ptr);
+ }
+
+ return resPtr;
}
/*
@@ -1502,15 +1622,10 @@
* TCL_LEAVE_ERR_MSG. */
{
Var *varPtr, *arrayPtr;
- char *part1, *part2;
-
- part1 = TclGetString(part1Ptr);
- part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr));
-
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
- varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
if (newValuePtr->refCount == 0) {
@@ -1519,8 +1634,8 @@
return NULL;
}
- return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
- newValuePtr, flags);
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ newValuePtr, flags, -1);
}
/*
@@ -1556,18 +1671,20 @@
Var *arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
* scalar. */
- const char *part1, /* Name of an array (if part2 is non-NULL) or
- * the name of a variable. */
- const char *part2, /* If non-NULL, gives the name of an element
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
+ * the name of a variable. NULL if index >= 0*/
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
* in the array part1. */
Tcl_Obj *newValuePtr, /* New value for variable. */
- const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
+ const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
+ int index) /* index of local var where part1 is to be
+ * found. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *oldValuePtr;
Tcl_Obj *resultPtr = NULL;
- int result;
+ int result;
/*
* If the variable is in a hashtable and its hPtr field is NULL, then we
@@ -1577,12 +1694,12 @@
* 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);
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", danglingElement, index);
} else {
- TclVarErrMsg(interp, part1, part2, "set", danglingVar);
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", danglingVar, index);
}
}
goto earlyError;
@@ -1592,9 +1709,9 @@
* It's an error to try to set an array variable itself.
*/
- if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ if (TclIsVarArray(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
- TclVarErrMsg(interp, part1, part2, "set", isArray);
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", isArray, index);
}
goto earlyError;
}
@@ -1605,10 +1722,11 @@
* instructions.
*/
- if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL)
- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
- if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
- TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
+ if ((flags & TCL_TRACE_READS) && ((varPtr->flags & VAR_TRACED_READ)
+ || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ)))) {
+ if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr,
+ part1Ptr, part2Ptr,
+ TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG), index)) {
goto earlyError;
}
}
@@ -1620,16 +1738,22 @@
* 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 0
+ /*
+ * Can't happen now!
+ */
+
if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
TclDecrRefCount(oldValuePtr); /* discard old value */
varPtr->value.objPtr = NULL;
oldValuePtr = NULL;
}
+#endif
if (flags & TCL_LIST_ELEMENT) { /* append list element */
if (oldValuePtr == NULL) {
TclNewObj(oldValuePtr);
@@ -1641,8 +1765,7 @@
oldValuePtr = varPtr->value.objPtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
}
- result = Tcl_ListObjAppendElement(interp, oldValuePtr,
- newValuePtr);
+ result = Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr);
if (result != TCL_OK) {
goto earlyError;
}
@@ -1681,21 +1804,17 @@
TclDecrRefCount(oldValuePtr); /* discard old value */
}
}
- 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 (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
- | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
+ if ((varPtr->flags & VAR_TRACED_WRITE)
+ || (arrayPtr && (arrayPtr->flags & VAR_TRACED_WRITE))) {
+ if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr,
+ part1Ptr, part2Ptr,
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))|TCL_TRACE_WRITES,
+ (flags & TCL_LEAVE_ERR_MSG), index)) {
goto cleanup;
}
}
@@ -1778,20 +1897,16 @@
* TCL_LEAVE_ERR_MSG. */
{
Var *varPtr, *arrayPtr;
- char *part1, *part2;
-
- part1 = TclGetString(part1Ptr);
- part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));
- varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read",
1, 1, &arrayPtr);
if (varPtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
return NULL;
}
- return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2,
- incrPtr, flags);
+ return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ incrPtr, flags, -1);
}
/*
@@ -1827,25 +1942,30 @@
Var *arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
* scalar. */
- const char *part1, /* Points to an object holding the name of an
+ Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
- const char *part2, /* If non-null, points to an object holding
+ Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *incrPtr, /* Increment value */
/* TODO: Which of these flag values really make sense? */
- const int flags) /* Various flags that tell how to incr value:
+ const int flags, /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
+ int index)
{
register Tcl_Obj *varValuePtr, *newValuePtr = NULL;
int duplicated, code;
-
- varPtr->refCount++;
- varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
- varPtr->refCount--;
+
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
+ varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, index);
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
if (varValuePtr == NULL) {
varValuePtr = Tcl_NewIntObj(0);
}
@@ -1857,8 +1977,8 @@
}
code = TclIncrObj(interp, varValuePtr, incrPtr);
if (code == TCL_OK) {
- newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
- varValuePtr, flags);
+ newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ varValuePtr, flags, index);
} else if (duplicated) {
Tcl_DecrRefCount(varValuePtr);
}
@@ -1931,15 +2051,23 @@
* TCL_LEAVE_ERR_MSG. */
{
int result;
- Tcl_Obj *part1Ptr;
+ Tcl_Obj *part1Ptr, *part2Ptr = NULL;
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
+ if (part2) {
+ part2Ptr = Tcl_NewStringObj(part2, -1);
+ Tcl_IncrRefCount(part2Ptr);
+ }
+
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
- result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
- TclDecrRefCount(part1Ptr);
+ result = TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags);
+ Tcl_DecrRefCount(part1Ptr);
+ if (part2Ptr) {
+ Tcl_DecrRefCount(part2Ptr);
+ }
return result;
}
@@ -1969,7 +2097,7 @@
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
Tcl_Obj *part1Ptr, /* Name of variable or array. */
- const char *part2, /* Name of element within array or NULL. */
+ Tcl_Obj *part2Ptr, /* Name of element within array or NULL. */
int flags) /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
@@ -1978,10 +2106,8 @@
Interp *iPtr = (Interp *) interp;
Var *arrayPtr;
int result;
- char *part1;
- part1 = TclGetString(part1Ptr);
- varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset",
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "unset",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
@@ -1996,9 +2122,11 @@
* the variable's name.
*/
- varPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
- UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags, 1);
+ UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags);
/*
* It's an error to unset an undefined variable.
@@ -2006,8 +2134,8 @@
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
- TclVarErrMsg(interp, part1, part2, "unset",
- ((arrayPtr == NULL) ? noSuchVar : noSuchElement));
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
+ ((arrayPtr == NULL) ? noSuchVar : noSuchElement), -1);
}
}
@@ -2030,8 +2158,10 @@
* its value object, if any, was decremented above.
*/
- varPtr->refCount--;
- TclCleanupVar(varPtr, arrayPtr);
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ CleanupVar(varPtr, arrayPtr);
+ }
return result;
}
@@ -2059,23 +2189,21 @@
Var *varPtr,
Var *arrayPtr,
Interp *iPtr,
- 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 */
+ Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr,
+ 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 +2216,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 +2231,67 @@
*/
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);
- }
-
- 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);
+ 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;
+ }
}
- for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
- activePtr = activePtr->nextPtr) {
- if (activePtr->varPtr == varPtr) {
- activePtr->nextTracePtr = NULL;
+
+ if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr->flags & VAR_TRACED_UNSET)) {
+ dummyVar.flags &= ~VAR_TRACE_ACTIVE;
+ TclObjCallVarTraces(iPtr, arrayPtr, (Var *) &dummyVar, part1Ptr, part2Ptr,
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))| TCL_TRACE_UNSETS,
+ /* leaveErrMsg */ 0, -1);
+ 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;
+ }
+ }
+ dummyVar.flags &= ~VAR_ALL_TRACES;
}
}
+
- 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)) {
/*
* 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,25 +2300,28 @@
* computed at DeleteArray.
*/
- DeleteArray(iPtr, part1, dummyVarPtr, (flags
+ DeleteArray(iPtr, part1Ptr, (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)--;
+ CleanupVar(linkPtr, NULL);
+ }
}
- if (dummyVarPtr == varPtr) {
- TclSetVarUndefined(varPtr);
- TclSetVarScalar(varPtr);
- }
-
/*
* If the variable was a namespace variable, decrement its reference
* count.
*/
- if (TclIsVarNamespaceVar(varPtr)) {
- TclClearVarNamespaceVar(varPtr);
- varPtr->refCount--;
- }
+ TclClearVarNamespaceVar(varPtr);
}
/*
@@ -2293,8 +2418,6 @@
Tcl_Obj *const objv[]) /* Argument objects. */
{
Var *varPtr, *arrayPtr;
- char *part1;
-
register Tcl_Obj *varValuePtr = NULL;
/* Initialized to avoid compiler warning. */
int i;
@@ -2310,9 +2433,8 @@
return TCL_ERROR;
}
} else {
- varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
+ varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
- part1 = TclGetString(objv[1]);
if (varPtr == NULL) {
return TCL_ERROR;
}
@@ -2324,8 +2446,8 @@
* variable again.
*/
- varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
- objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
+ varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL,
+ objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG), -1);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
@@ -2363,7 +2485,6 @@
Tcl_Obj *varValuePtr, *newValuePtr;
int numElems, createdNewObj;
Var *varPtr, *arrayPtr;
- char *part1;
int result;
if (objc < 2) {
@@ -2409,21 +2530,24 @@
* and unused.
*/
- varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
+ varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
- varPtr->refCount++;
- if (arrayPtr != NULL) {
- arrayPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
}
- part1 = TclGetString(objv[1]);
- varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL,
- TCL_LEAVE_ERR_MSG);
- varPtr->refCount--;
- if (arrayPtr != NULL) {
- arrayPtr->refCount--;
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)++;
+ }
+ varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, objv[1], NULL,
+ TCL_LEAVE_ERR_MSG, -1);
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)--;
}
if (varValuePtr == NULL) {
@@ -2458,8 +2582,8 @@
* and we didn't create the variable.
*/
- newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
- varValuePtr, TCL_LEAVE_ERR_MSG);
+ newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL,
+ varValuePtr, TCL_LEAVE_ERR_MSG, -1);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
@@ -2519,7 +2643,6 @@
Tcl_HashEntry *hPtr;
Tcl_Obj *varNamePtr;
int notArray;
- char *varName;
int index, result;
if (objc < 3) {
@@ -2537,8 +2660,7 @@
*/
varNamePtr = objv[2];
- varName = TclGetString(varNamePtr);
- varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0,
+ varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
/*
@@ -2546,11 +2668,11 @@
* 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,
+ if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNamePtr,
NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1)) {
return TCL_ERROR;
}
}
@@ -2578,7 +2700,7 @@
if (notArray) {
goto error;
}
- searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
+ searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
@@ -2586,7 +2708,7 @@
Var *varPtr2;
if (searchPtr->nextEntry != NULL) {
- varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
+ varPtr2 = VarHashGetValue(searchPtr->nextEntry);
if (!TclIsVarUndefined(varPtr2)) {
break;
}
@@ -2610,14 +2732,20 @@
if (notArray) {
goto error;
}
- searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
+ searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]);
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 +2758,7 @@
case ARRAY_NEXTELEMENT: {
ArraySearch *searchPtr;
Tcl_HashEntry *hPtr;
+ Var *varPtr2;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId");
@@ -2638,13 +2767,11 @@
if (notArray) {
goto error;
}
- searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
+ searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
while (1) {
- Var *varPtr2;
-
hPtr = searchPtr->nextEntry;
if (hPtr == NULL) {
hPtr = Tcl_NextHashEntry(&searchPtr->search);
@@ -2654,17 +2781,19 @@
} 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));
+ Tcl_SetObjResult(interp, VarHashGetKey(varPtr2));
break;
}
case ARRAY_STARTSEARCH: {
ArraySearch *searchPtr;
+ int new;
+ char *varName = TclGetString(varNamePtr);
+
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
@@ -2674,21 +2803,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,37 +2858,34 @@
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, objv[3]);
+ if (varPtr2 == NULL) {
goto searchDone;
}
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
if (TclIsVarUndefined(varPtr2)) {
goto searchDone;
}
result = Tcl_ListObjAppendElement(interp, nameLstPtr,
- Tcl_NewStringObj(pattern, -1));
+ VarHashGetKey(varPtr2));
if (result != TCL_OK) {
TclDecrRefCount(nameLstPtr);
return result;
}
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; varPtr2 = VarHashNextVar(&search)) {
if (TclIsVarUndefined(varPtr2)) {
continue;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
+ namePtr = VarHashGetKey(varPtr2);
+ name = TclGetString(namePtr);
if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
continue; /* element name doesn't match pattern */
}
- namePtr = Tcl_NewStringObj(name, -1);
result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr);
if (result != TCL_OK) {
- TclDecrRefCount(namePtr); /* free unneeded name obj */
TclDecrRefCount(nameLstPtr);
return result;
}
@@ -2767,23 +2897,23 @@
* while we're working.
*/
- varPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
/*
* Get the array values corresponding to each element name
*/
TclNewObj(tmpResPtr);
- result = Tcl_ListObjGetElements(interp, nameLstPtr,
- &count, &namePtrPtr);
+ result = Tcl_ListObjGetElements(interp, nameLstPtr, &count, &namePtrPtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
for (i=0 ; i<count ; i++) {
namePtr = *namePtrPtr++;
- valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
- TCL_LEAVE_ERR_MSG);
+ valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
/*
* Some trace played a trick on us; we need to diagnose to
@@ -2791,7 +2921,7 @@
* the modification modify the complete array?
*/
- if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ if (TclIsVarArray(varPtr)) {
/*
* The array itself looks OK, the variable was undefined:
* forget it.
@@ -2808,13 +2938,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,11 +2986,10 @@
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, objv[3]);
+ if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(pattern, -1));
+ VarHashGetKey(varPtr2));
if (result != TCL_OK) {
TclDecrRefCount(resultPtr);
return result;
@@ -2865,13 +2998,13 @@
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);
+ namePtr = VarHashGetKey(varPtr2);
+ name = TclGetString(namePtr);
if (objc > 3) {
switch ((enum options) mode) {
case OPT_EXACT:
@@ -2893,10 +3026,8 @@
}
}
- namePtr = Tcl_NewStringObj(name, -1);
result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
if (result != TCL_OK) {
- TclDecrRefCount(resultPtr);
TclDecrRefCount(namePtr); /* free unneeded name obj */
return result;
}
@@ -2914,7 +3045,6 @@
Tcl_HashSearch search;
Var *varPtr2;
char *pattern = NULL;
- char *name;
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
@@ -2934,22 +3064,22 @@
} else {
pattern = TclGetString(objv[3]);
if (TclMatchIsTrivial(pattern)) {
- hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern);
- if (hPtr != NULL &&
- !TclIsVarUndefined((Var *)Tcl_GetHashValue(hPtr))){
- return TclObjUnsetVar2(interp, varNamePtr, pattern, 0);
+ varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]);
+ if (varPtr2 != NULL && !TclIsVarUndefined(varPtr2)) {
+ return TclObjUnsetVar2(interp, varNamePtr, objv[3], 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)) {
+ Tcl_Obj *namePtr;
+
if (TclIsVarUndefined(varPtr2)) {
continue;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
- if (Tcl_StringMatch(name, pattern) &&
- TclObjUnsetVar2(interp, varNamePtr, name,
+ namePtr = VarHashGetKey(varPtr2);
+ if (Tcl_StringMatch(TclGetString(namePtr), pattern) &&
+ TclObjUnsetVar2(interp, varNamePtr, namePtr,
0) != TCL_OK) {
return TCL_ERROR;
}
@@ -2975,9 +3105,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 +3124,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);
@@ -3009,7 +3138,7 @@
return TCL_OK;
error:
- Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL);
+ Tcl_AppendResult(interp, "\"", TclGetString(varNamePtr), "\" isn't an array", NULL);
return TCL_ERROR;
}
@@ -3039,26 +3168,19 @@
* NULL, create an empty array. */
{
Var *varPtr, *arrayPtr;
- int result, i, nameLen;
- char *varName, *p;
-
- varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
- p = varName + nameLen - 1;
- if (*p == ')') {
- while (--p >= varName) {
- if (*p == '(') {
- TclVarErrMsg(interp, varName, NULL, "set", needArray);
- return TCL_ERROR;
- }
- }
- }
+ int result, i;
- varPtr = TclObjLookupVar(interp, arrayNameObj, NULL,
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
/*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
- /*createPart2*/ 0, &arrayPtr);
+ /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
+ if (arrayPtr) {
+ CleanupVar(varPtr, arrayPtr);
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1);
+ return TCL_ERROR;
+ }
if (arrayElemObj == NULL) {
goto ensureArray;
@@ -3095,16 +3217,15 @@
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
/*
* At this point, it would be nice if the key was directly usable
- * by the array. This isn't the case though.
+ * by the array. This isn't the case though. ///
*/
- char *part2 = TclGetString(keyPtr);
- Var *elemVarPtr = TclLookupArrayElement(interp, varName,
- part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);
+ Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
+ keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
if ((elemVarPtr == NULL) ||
- (TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
- part2, valuePtr, TCL_LEAVE_ERR_MSG) == NULL)) {
+ (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
+ keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
@@ -3140,13 +3261,12 @@
copyListObj = TclListObjCopy(NULL, arrayElemObj);
for (i=0 ; i<elemLen ; i+=2) {
- char *part2 = TclGetString(elemPtrs[i]);
- Var *elemVarPtr = TclLookupArrayElement(interp, varName,
- part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);
+ Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
+ elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
if ((elemVarPtr == NULL) ||
- (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, part2,
- elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
+ (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, elemPtrs[i],
+ elemPtrs[i+1], TCL_LEAVE_ERR_MSG, -1) == NULL)) {
result = TCL_ERROR;
break;
}
@@ -3162,7 +3282,7 @@
ensureArray:
if (varPtr != NULL) {
- if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
+ if (TclIsVarArray(varPtr)) {
/*
* Already an array, done.
*/
@@ -3174,15 +3294,14 @@
* Either an array element, or a scalar: lose!
*/
- TclVarErrMsg(interp, varName, NULL, "array set", needArray);
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", needArray, -1);
return TCL_ERROR;
}
}
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;
}
@@ -3216,7 +3335,7 @@
const char *otherP2, /* Two-part name of variable in framePtr. */
const int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of "other" variable. */
- const char *myName, /* Name of variable which will refer to
+ Tcl_Obj *myNamePtr, /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of myName. */
@@ -3259,19 +3378,21 @@
*/
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)
- || (strstr(myName, "::") != NULL))) {
+ || (strstr(TclGetString(myNamePtr), "::") != NULL))) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
- myName, "\": upvar won't create namespace variable that "
+ TclGetString(myNamePtr), "\": upvar won't create namespace variable that "
"refers to procedure variable", NULL);
return TCL_ERROR;
}
}
- return TclPtrMakeUpvar(interp, otherPtr, myName, myFlags, index);
+ return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
}
/*
@@ -3306,18 +3427,48 @@
int index) /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1 */
{
+ Tcl_Obj *myNamePtr;
+ int result;
+
+ if (myName) {
+ myNamePtr = Tcl_NewStringObj(myName, -1);
+ Tcl_IncrRefCount(myNamePtr);
+ } else {
+ myNamePtr = NULL;
+ }
+ result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
+ if (myNamePtr) {
+ Tcl_DecrRefCount(myNamePtr);
+ }
+ return result;
+}
+
+int
+TclPtrObjMakeUpvar(
+ Tcl_Interp *interp, /* Interpreter containing variables. Used for
+ * error messages, too. */
+ Var *otherPtr, /* Pointer to the variable being linked-to */
+ Tcl_Obj *myNamePtr, /* Name of variable which will refer to
+ * otherP1/otherP2. Must be a scalar. */
+ int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
+ * indicates scope of myName. */
+ int index) /* If the variable to be linked is an indexed
+ * scalar, this is its index. Otherwise, -1 */
+{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
Var *varPtr;
const char *errMsg;
- const char *p;
+ const char *p;
+ const char *myName;
if (index >= 0) {
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]);
+ myNamePtr = localName(iPtr->varFramePtr, index);
+ myName = myNamePtr? TclGetString(myNamePtr) : NULL;
} else {
/*
* Do not permit the new variable to look like an array reference, as
@@ -3326,6 +3477,7 @@
* (and must remain consistent) with the code in TclObjLookupVar().
*/
+ myName = TclGetString(myNamePtr);
p = strstr(myName, "(");
if (p != NULL) {
p += strlen(p)-1;
@@ -3350,10 +3502,10 @@
* - Bug #631741 - do not use special namespace or interp resolvers.
*/
- varPtr = TclLookupSimpleVar(interp, myName, (myFlags|LOOKUP_FOR_UPVAR),
+ varPtr = TclLookupSimpleVar(interp, myNamePtr, (myFlags|LOOKUP_FOR_UPVAR),
/* create */ 1, &errMsg, &index);
if (varPtr == NULL) {
- TclVarErrMsg(interp, myName, NULL, "create", errMsg);
+ TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1);
return TCL_ERROR;
}
}
@@ -3364,7 +3516,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 +3533,11 @@
if (linkPtr == otherPtr) {
return TCL_OK;
}
- linkPtr->refCount--;
- if (TclIsVarUndefined(linkPtr)) {
- TclCleanupVar(linkPtr, NULL);
+ if (TclIsVarInHash(linkPtr)) {
+ VarHashRefCount(linkPtr)--;
+ if (TclIsVarUndefined(linkPtr)) {
+ CleanupVar(linkPtr, NULL);
+ }
}
} else {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
@@ -3392,9 +3546,10 @@
}
}
TclSetVarLink(varPtr);
- TclClearVarUndefined(varPtr);
varPtr->value.linkPtr = otherPtr;
- otherPtr->refCount++;
+ if (TclIsVarInHash(otherPtr)) {
+ VarHashRefCount(otherPtr)++;
+ }
return TCL_OK;
}
@@ -3469,7 +3624,7 @@
{
int result;
CallFrame *framePtr;
- Tcl_Obj *part1Ptr;
+ Tcl_Obj *part1Ptr, *localNamePtr;
if (TclGetFrame(interp, frameName, &framePtr) == -1) {
return TCL_ERROR;
@@ -3477,10 +3632,13 @@
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
- result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0,
- localName, flags, -1);
- TclDecrRefCount(part1Ptr);
+ localNamePtr = Tcl_NewStringObj(localName, -1);
+ Tcl_IncrRefCount(localNamePtr);
+ result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0,
+ localNamePtr, flags, -1);
+ Tcl_DecrRefCount(part1Ptr);
+ Tcl_DecrRefCount(localNamePtr);
return result;
}
@@ -3513,26 +3671,35 @@
{
Interp *iPtr = (Interp *) interp;
register Var *varPtr = (Var *) variable;
- char *name;
+ Tcl_Obj *namePtr;
+ 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);
- Tcl_AppendToObj(objPtr, name, -1);
+ if (TclIsVarInHash(varPtr)) {
+ if (!TclIsVarDeadHash(varPtr)) {
+ namePtr = VarHashGetKey(varPtr);
+ Tcl_AppendObjToObj(objPtr, namePtr);
+ }
+ } else if (iPtr->varFramePtr->procPtr) {
+ int index = varPtr - iPtr->varFramePtr->compiledLocals;
+
+ if (index < iPtr->varFramePtr->numCompiledLocals) {
+ namePtr = localName(iPtr->varFramePtr, index);
+ Tcl_AppendObjToObj(objPtr, namePtr);
+ }
}
}
}
@@ -3563,7 +3730,7 @@
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- register Tcl_Obj *objPtr;
+ register Tcl_Obj *objPtr, *tailPtr;
char *varName;
register char *tail;
int result, i;
@@ -3605,12 +3772,24 @@
tail++;
}
+ if (tail == varName) {
+ tailPtr = objPtr;
+ } else {
+ tailPtr = Tcl_NewStringObj(tail, -1);
+ Tcl_IncrRefCount(tailPtr);
+ }
+
/*
* Link to the variable "varName" in the global :: namespace.
*/
result = ObjMakeUpvar(interp, NULL, objPtr, NULL,
- TCL_GLOBAL_ONLY, /*myName*/ tail, /*myFlags*/ 0, -1);
+ TCL_GLOBAL_ONLY, /*myName*/ tailPtr, /*myFlags*/ 0, -1);
+
+ if (tail != varName) {
+ Tcl_DecrRefCount(tailPtr);
+ }
+
if (result != TCL_OK) {
return result;
}
@@ -3664,7 +3843,7 @@
Var *varPtr, *arrayPtr;
Tcl_Obj *varValuePtr;
int i, result;
- Tcl_Obj *varNamePtr;
+ Tcl_Obj *varNamePtr, *tailPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
@@ -3679,7 +3858,7 @@
varNamePtr = objv[i];
varName = TclGetString(varNamePtr);
- varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
+ varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
/*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
@@ -3689,7 +3868,7 @@
* non-NULL, it is, so throw up an error and return.
*/
- TclVarErrMsg(interp, varName, NULL, "define", isArrayElement);
+ TclObjVarErrMsg(interp, varNamePtr, NULL, "define", isArrayElement, -1);
return TCL_ERROR;
}
@@ -3703,10 +3882,7 @@
* destroyed or until the variable is unset.
*/
- if (!TclIsVarNamespaceVar(varPtr)) {
- TclSetVarNamespaceVar(varPtr);
- varPtr->refCount++;
- }
+ TclSetVarNamespaceVar(varPtr);
/*
* If a value was specified, set the variable to that value.
@@ -3716,8 +3892,8 @@
*/
if (i+1 < objc) { /* a value was specified */
- varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL,
- objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
+ varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varNamePtr, NULL,
+ objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), -1);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
@@ -3750,9 +3926,21 @@
* current namespace.
*/
+ if (tail == varName) {
+ tailPtr = varNamePtr;
+ } else {
+ tailPtr = Tcl_NewStringObj(tail, -1);
+ Tcl_IncrRefCount(tailPtr);
+ }
+
result = ObjMakeUpvar(interp, NULL, varNamePtr, /*otherP2*/ NULL,
/*otherFlags*/ TCL_NAMESPACE_ONLY,
- /*myName*/ tail, /*myFlags*/ 0, -1);
+ /*myName*/ tailPtr, /*myFlags*/ 0, -1);
+
+ if (tail != varName) {
+ Tcl_DecrRefCount(tailPtr);
+ }
+
if (result != TCL_OK) {
return result;
}
@@ -3787,7 +3975,6 @@
Tcl_Obj *const objv[]) /* Argument objects. */
{
CallFrame *framePtr;
- char *localName;
int result;
if (objc < 3) {
@@ -3819,9 +4006,8 @@
*/
for (; objc>0 ; objc-=2, objv+=2) {
- localName = TclGetString(objv[1]);
result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0],
- NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1);
+ NULL, 0, /* myVarName */ objv[1], /*flags*/ 0, -1);
if (result != TCL_OK) {
return TCL_ERROR;
}
@@ -3832,44 +4018,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
@@ -3959,17 +4107,19 @@
ParseSearchId(
Tcl_Interp *interp, /* Interpreter containing variable. */
const Var *varPtr, /* Array variable search is for. */
- const char *varName, /* Name of array variable that search is
+ Tcl_Obj *varNamePtr, /* Name of array variable that search is
* supposed to be for. */
Tcl_Obj *handleObj) /* Object containing id of search. Must have
* form "search-num-var" where "num" is a
* decimal number and "var" is a variable
* name. */
{
+ Interp *iPtr = (Interp *) interp;
register char *string;
register size_t offset;
int id;
ArraySearch *searchPtr;
+ char *varName = TclGetString(varNamePtr);
/*
* Parse the id.
@@ -4012,10 +4162,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 +4197,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 +4238,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 +4255,33 @@
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 */ VarHashGetKey(varPtr), 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;
- 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;
}
- TclCleanupVar(varPtr, NULL);
+ VarHashRefCount(varPtr)--;
+ VarHashDeleteEntry(varPtr);
}
- Tcl_DeleteHashTable(tablePtr);
+ VarHashDeleteTable(tablePtr);
}
/*
@@ -4142,12 +4307,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 +4327,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, VarHashGetKey(varPtr), NULL, flags);
}
- Tcl_DeleteHashTable(tablePtr);
+ VarHashDeleteTable(tablePtr);
}
/*
@@ -4213,77 +4370,13 @@
{
register Var *varPtr;
int numLocals, i;
-
+ Tcl_Obj **namePtrPtr;
+
numLocals = framePtr->numCompiledLocals;
varPtr = framePtr->compiledLocals;
- for (i=0 ; i<numLocals ; i++) {
-#if 1
- UnsetVarStruct(varPtr, NULL, iPtr, varPtr->name, NULL, TCL_TRACE_UNSETS, 0);
- 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
+ namePtrPtr = &localName(framePtr, 0);
+ for (i=0 ; i<numLocals ; i++, namePtrPtr++, varPtr++) {
+ UnsetVarStruct(varPtr, NULL, iPtr, *namePtrPtr, NULL, TCL_TRACE_UNSETS);
}
}
@@ -4311,7 +4404,7 @@
static void
DeleteArray(
Interp *iPtr, /* Interpreter containing array. */
- const char *arrayName, /* Name of array (used for trace callbacks),
+ Tcl_Obj *arrayNamePtr, /* Name of array (used for trace callbacks),
* or NULL if it is to be computed on demand */
Var *varPtr, /* Pointer to variable structure. */
int flags) /* Flags to pass to TclCallVarTraces:
@@ -4319,44 +4412,51 @@
* 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;
+ Tcl_Obj *objPtr;
+ 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) {
+ Tcl_Obj *elNamePtr = VarHashGetKey(elPtr);
+
+ elPtr->flags &= ~VAR_TRACE_ACTIVE;
+ TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr,
+ elNamePtr, flags,/* leaveErrMsg */ 0, -1);
+ }
+ 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) {
@@ -4365,7 +4465,6 @@
}
}
TclSetVarUndefined(elPtr);
- TclSetVarScalar(elPtr);
/*
* Even though array elements are not supposed to be namespace
@@ -4374,73 +4473,16 @@
* the corresponding Var struct, and is otherwise harmless.
*/
- if (TclIsVarNamespaceVar(elPtr)) {
- TclClearVarNamespaceVar(elPtr);
- elPtr->refCount--;
- }
- if (elPtr->refCount == 0) {
- ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */
- }
+ TclClearVarNamespaceVar(elPtr);
}
- if (arrayNamePtr) {
- Tcl_DecrRefCount(arrayNamePtr);
- }
- Tcl_DeleteHashTable(varPtr->value.tablePtr);
+ VarHashDeleteTable(varPtr->value.tablePtr);
ckfree((char *) varPtr->value.tablePtr);
}
/*
*----------------------------------------------------------------------
*
- * TclCleanupVar --
- *
- * This function is called when it looks like it may be OK to free up a
- * variable's storage. If the variable is in a hashtable, its Var
- * structure and hash table entry will be freed along with those of its
- * containing array, if any. This function is called, for example, when
- * a trace on a variable deletes a variable.
- *
- * Results:
- * None.
- *
- * Side effects:
- * If the variable (or its containing array) really is dead and in a
- * hashtable, then its Var structure, and possibly its hash table entry,
- * is freed up.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclCleanupVar(
- Var *varPtr, /* Pointer to variable that may be a candidate
- * for being expunged. */
- 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);
- }
- 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);
- }
- ckfree((char *) arrayPtr);
- }
- }
-}
-/*
- *----------------------------------------------------------------------
- *
- * TclVarErrMsg --
+ * TclTclObjVarErrMsg --
*
* Generate a reasonable error message describing why a variable
* operation failed.
@@ -4459,16 +4501,49 @@
void
TclVarErrMsg(
Tcl_Interp *interp, /* Interpreter in which to record message. */
- const char *part1,
+ const char *part1,
const char *part2, /* Variable's two-part name. */
const char *operation, /* String describing operation that failed,
* e.g. "read", "set", or "unset". */
const char *reason) /* String describing why operation failed. */
{
+ Tcl_Obj *part1Ptr = NULL, *part2Ptr = NULL;
+
+ part1Ptr = Tcl_NewStringObj(part1, -1);
+ Tcl_IncrRefCount(part1Ptr);
+ if (part2) {
+ part2Ptr = Tcl_NewStringObj(part2, -1);
+ Tcl_IncrRefCount(part2Ptr);
+ } else {
+ part2 = NULL;
+ }
+
+ TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1);
+
+ Tcl_DecrRefCount(part1Ptr);
+ if (part2Ptr) {
+ Tcl_DecrRefCount(part2Ptr);
+ }
+}
+
+void
+TclObjVarErrMsg(
+ Tcl_Interp *interp, /* Interpreter in which to record message. */
+ Tcl_Obj *part1Ptr, /* (may be NULL, if index >= 0) */
+ Tcl_Obj *part2Ptr, /* Variable's two-part name. */
+ const char *operation, /* String describing operation that failed,
+ * e.g. "read", "set", or "unset". */
+ const char *reason, /* String describing why operation failed. */
+ int index)
+{
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't ", operation, " \"", part1, NULL);
- if (part2 != NULL) {
- Tcl_AppendResult(interp, "(", part2, ")", NULL);
+ if (!part1Ptr) {
+ part1Ptr = localName(((Interp*)interp)->varFramePtr, index);
+ }
+ Tcl_AppendResult(interp, "can't ", operation, " \"",
+ TclGetString(part1Ptr), NULL);
+ if (part2Ptr) {
+ Tcl_AppendResult(interp, "(", TclGetString(part2Ptr), ")", NULL);
}
Tcl_AppendResult(interp, "\": ", reason, NULL);
}
@@ -4534,9 +4609,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)) {
+ CleanupVar(varPtr, NULL);
+ }
}
}
@@ -4550,7 +4627,9 @@
dupPtr->internalRep.twoPtrValue.ptr1 = nsPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = varPtr;
- varPtr->refCount++;
+ if (TclIsVarInHash(varPtr)) {
+ varPtr->refCount++;
+ }
dupPtr->typePtr = &tclNsVarNameType;
}
#endif
@@ -4636,6 +4715,701 @@
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ Tcl_Obj *simpleNamePtr;
+
+ /*
+ * 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;
+ simpleNamePtr = Tcl_NewStringObj(simpleName, -1);
+ Tcl_IncrRefCount(simpleNamePtr);
+ for (search = 0; (search < 2) && (varPtr == NULL); search++) {
+ if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
+ varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleNamePtr);
+ }
+ }
+ Tcl_DecrRefCount(simpleNamePtr);
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoVarsCmd -- (moved over from tclCmdIL.c)
+ *
+ * Called to implement the "info vars" command that returns the list of
+ * variables in the interpreter that match an optional pattern. The
+ * pattern, if any, consists of an optional sequence of namespace names
+ * separated by "::" qualifiers, which is followed by a glob-style
+ * pattern that restricts which variables are returned. Handles the
+ * following syntax:
+ *
+ * info vars ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInfoVarsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *varName, *pattern;
+ CONST char *simplePattern;
+ Tcl_HashSearch search;
+ Var *varPtr;
+ Namespace *nsPtr;
+ Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ Tcl_Obj *listPtr, *elemObjPtr;
+ int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
+ Tcl_Obj *simplePatternPtr = NULL, *varNamePtr;
+
+ /*
+ * Get the pattern and find the "effective namespace" in which to list
+ * variables. We only use this effective namespace if there's no active
+ * Tcl procedure frame.
+ */
+
+ if (objc == 1) {
+ simplePattern = NULL;
+ nsPtr = currNsPtr;
+ specificNsInPattern = 0;
+ } else if (objc == 2) {
+ /*
+ * From the pattern, get the effective namespace and the simple
+ * pattern (no namespace qualifiers or ::'s) at the end. If an error
+ * was found while parsing the pattern, return it. Otherwise, if the
+ * namespace wasn't found, just leave nsPtr NULL: we will return an
+ * empty list since no variables there can be found.
+ */
+
+ Namespace *dummy1NsPtr, *dummy2NsPtr;
+
+ pattern = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
+ /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
+ &simplePattern);
+
+ if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
+ specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
+ if (simplePattern == pattern) {
+ simplePatternPtr = objv[1];
+ } else {
+ simplePatternPtr = Tcl_NewStringObj(simplePattern, -1);
+ }
+ Tcl_IncrRefCount(simplePatternPtr);
+ }
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the namespace specified in the pattern wasn't found, just return.
+ */
+
+ if (nsPtr == NULL) {
+ return TCL_OK;
+ }
+
+ listPtr = Tcl_NewListObj(0, NULL);
+
+ if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)
+ || specificNsInPattern) {
+ /*
+ * There is no frame pointer, the frame pointer was pushed only to
+ * activate a namespace, or we are in a procedure call frame but a
+ * specific namespace was specified. Create a list containing only the
+ * variables in the effective namespace's variable table.
+ */
+
+ if (simplePattern && TclMatchIsTrivial(simplePattern)) {
+ /*
+ * If we can just do hash lookups, that simplifies things a lot.
+ */
+
+ varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr);
+ if (varPtr) {
+ if (!TclIsVarUndefined(varPtr)
+ || TclIsVarNamespaceVar(varPtr)) {
+ if (specificNsInPattern) {
+ elemObjPtr = Tcl_NewObj();
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
+ elemObjPtr);
+ } else {
+ elemObjPtr = VarHashGetKey(varPtr);
+ }
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ }
+ } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ varPtr = VarHashFindVar(&globalNsPtr->varTable, simplePatternPtr);
+ if (varPtr) {
+ if (!TclIsVarUndefined(varPtr)
+ || TclIsVarNamespaceVar(varPtr)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ VarHashGetKey(varPtr));
+ }
+ }
+ }
+ } else {
+ /*
+ * Have to scan the tables of variables.
+ */
+
+ varPtr = VarHashFirstVar(&nsPtr->varTable, &search);
+ while (varPtr) {
+ if (!TclIsVarUndefined(varPtr)
+ || TclIsVarNamespaceVar(varPtr)) {
+ varNamePtr = VarHashGetKey(varPtr);
+ varName = TclGetString(varNamePtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(varName, simplePattern)) {
+ if (specificNsInPattern) {
+ elemObjPtr = Tcl_NewObj();
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
+ elemObjPtr);
+ } else {
+ elemObjPtr = varNamePtr;
+ }
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ }
+ }
+ varPtr = VarHashNextVar(&search);
+ }
+
+ /*
+ * If the effective namespace isn't the global :: namespace, and a
+ * specific namespace wasn't requested in the pattern (i.e., the
+ * pattern only specifies variable names), then add in all global
+ * :: variables that match the simple pattern. Of course, add in
+ * only those variables that aren't hidden by a variable in the
+ * effective namespace.
+ */
+
+ if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search);
+ while (varPtr) {
+ if (!TclIsVarUndefined(varPtr)
+ || TclIsVarNamespaceVar(varPtr)) {
+ varNamePtr = VarHashGetKey(varPtr);
+ varName = TclGetString(varNamePtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(varName, simplePattern)) {
+ if (VarHashFindVar(&nsPtr->varTable, varNamePtr) == NULL) {
+ Tcl_ListObjAppendElement(interp, listPtr, varNamePtr);
+ }
+ }
+ }
+ varPtr = VarHashNextVar(&search);
+ }
+ }
+ }
+ } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
+ AppendLocals(interp, listPtr, simplePatternPtr, 1);
+ }
+
+ if (simplePatternPtr) {
+ Tcl_DecrRefCount(simplePatternPtr);
+ }
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoGlobalsCmd -- (moved over from tclCmdIL.c)
+ *
+ * Called to implement the "info globals" command that returns the list
+ * of global variables matching an optional pattern. Handles the
+ * following syntax:
+ *
+ * info globals ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInfoGlobalsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ char *varName, *pattern;
+ Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
+ Tcl_HashSearch search;
+ Var *varPtr;
+ Tcl_Obj *listPtr, *varNamePtr, *patternPtr;
+
+ if (objc == 1) {
+ pattern = NULL;
+ } else if (objc == 2) {
+ pattern = TclGetString(objv[1]);
+
+ /*
+ * Strip leading global-namespace qualifiers. [Bug 1057461]
+ */
+
+ if (pattern[0] == ':' && pattern[1] == ':') {
+ while (*pattern == ':') {
+ pattern++;
+ }
+ }
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Scan through the global :: namespace's variable table and create a list
+ * of all global variables that match the pattern.
+ */
+
+ listPtr = Tcl_NewListObj(0, NULL);
+ if (pattern != NULL && TclMatchIsTrivial(pattern)) {
+ if (pattern == TclGetString(objv[1])) {
+ patternPtr = objv[1];
+ } else {
+ patternPtr = Tcl_NewStringObj(pattern, -1);
+ }
+ Tcl_IncrRefCount(patternPtr);
+
+ varPtr = VarHashFindVar(&globalNsPtr->varTable, patternPtr);
+ if (varPtr) {
+ if (!TclIsVarUndefined(varPtr)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ VarHashGetKey(varPtr));
+ }
+ }
+ Tcl_DecrRefCount(patternPtr);
+ } else {
+ for (varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search);
+ varPtr != NULL;
+ varPtr = VarHashNextVar(&search)) {
+ if (TclIsVarUndefined(varPtr)) {
+ continue;
+ }
+ varNamePtr = VarHashGetKey(varPtr);
+ varName = TclGetString(varNamePtr);
+ if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr, varNamePtr);
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInfoLocalsCmd -- (moved over from tclCmdIl.c)
+ *
+ * Called to implement the "info locals" command to return a list of
+ * local variables that match an optional pattern. Handles the following
+ * syntax:
+ *
+ * info locals ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInfoLocalsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *patternPtr;
+ Tcl_Obj *listPtr;
+
+ if (objc == 1) {
+ patternPtr = NULL;
+ } else if (objc == 2) {
+ patternPtr = objv[1];
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
+ return TCL_ERROR;
+ }
+
+ if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) {
+ return TCL_OK;
+ }
+
+ /*
+ * Return a list containing names of first the compiled locals (i.e. the
+ * ones stored in the call frame), then the variables in the local hash
+ * table (if one exists).
+ */
+
+ listPtr = Tcl_NewListObj(0, NULL);
+ AppendLocals(interp, listPtr, patternPtr, 0);
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AppendLocals --
+ *
+ * Append the local variables for the current frame to the specified list
+ * object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AppendLocals(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *listPtr, /* List object to append names to. */
+ Tcl_Obj *patternPtr, /* Pattern to match against. */
+ int includeLinks) /* 1 if upvars should be included, else 0. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr;
+ int i, localVarCt;
+ Tcl_Obj **varNamePtr;
+ char *varName;
+ TclVarHashTable *localVarTablePtr;
+ Tcl_HashSearch search;
+ const char *pattern = patternPtr? TclGetString(patternPtr) : NULL;
+ Tcl_Obj *objNamePtr;
+
+ localVarCt = iPtr->varFramePtr->numCompiledLocals;
+ varPtr = iPtr->varFramePtr->compiledLocals;
+ localVarTablePtr = iPtr->varFramePtr->varTablePtr;
+ varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0;
+
+ for (i = 0; i < localVarCt; i++, varNamePtr++) {
+ /*
+ * Skip nameless (temporary) variables and undefined variables.
+ */
+
+ if (*varNamePtr && !TclIsVarUndefined(varPtr)
+ && (includeLinks || !TclIsVarLink(varPtr))) {
+ varName = TclGetString(*varNamePtr);
+ if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr);
+ }
+ }
+ varPtr++;
+ }
+
+ /*
+ * Do nothing if no local variables.
+ */
+
+ if (localVarTablePtr == NULL) {
+ return;
+ }
+
+ /*
+ * Check for the simple and fast case.
+ */
+
+ if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
+ varPtr = VarHashFindVar(localVarTablePtr, patternPtr);
+ if (varPtr != NULL) {
+ if (!TclIsVarUndefined(varPtr)
+ && (includeLinks || !TclIsVarLink(varPtr))) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ VarHashGetKey(varPtr));
+ }
+ }
+ return;
+ }
+
+ /*
+ * Scan over and process all local variables.
+ */
+
+ for (varPtr = VarHashFirstVar(localVarTablePtr, &search);
+ varPtr != NULL;
+ varPtr = VarHashNextVar(&search)) {
+ if (!TclIsVarUndefined(varPtr)
+ && (includeLinks || !TclIsVarLink(varPtr))) {
+ objNamePtr = VarHashGetKey(varPtr);
+ varName = TclGetString(objNamePtr);
+ if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
+ }
+ }
+ }
+}
+
+/*
+ * Hash table implementation - first, just copy and adapt the obj 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. */
+{
+ Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
+ Tcl_HashEntry *hPtr;
+ Var *varPtr;
+
+ varPtr = (Var *) ckalloc(sizeof(VarInHash));
+ varPtr->flags = VAR_IN_HASHTABLE;
+ varPtr->value.objPtr = NULL;
+ VarHashRefCount(varPtr) = 1;
+
+ hPtr = &(((VarInHash *)varPtr)->entry);
+ Tcl_SetHashValue(hPtr, varPtr);
+ hPtr->key.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr);
+
+ return hPtr;
+}
+
+static void
+FreeVarEntry(Tcl_HashEntry *hPtr)
+{
+ Var *varPtr = VarHashGetValue(hPtr);
+ Tcl_Obj *objPtr = hPtr->key.objPtr;
+
+ if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr)
+ && (VarHashRefCount(varPtr) == 1)) {
+ ckfree((char *) varPtr);
+ } else {
+ VarHashInvalidateEntry(varPtr);
+ TclSetVarUndefined(varPtr);
+ VarHashRefCount(varPtr)--;
+ }
+ Tcl_DecrRefCount(objPtr);
+}
+
+static int
+CompareVarKeys(
+ VOID *keyPtr, /* New key to compare. */
+ Tcl_HashEntry *hPtr) /* Existing key to compare. */
+{
+ Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
+ Tcl_Obj *objPtr2 = hPtr->key.objPtr;
+ register CONST char *p1, *p2;
+ register int l1, l2;
+
+ /*
+ * If the object pointers are the same then they match.
+ */
+
+ if (objPtr1 == objPtr2) {
+ return 1;
+ }
+
+ /*
+ * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
+ * in a register.
+ */
+
+ p1 = TclGetString(objPtr1);
+ l1 = objPtr1->length;
+ p2 = TclGetString(objPtr2);
+ l2 = objPtr2->length;
+
+ /*
+ * Only compare if the string representations are of the same length.
+ */
+
+ if (l1 == l2) {
+ for (;; p1++, p2++, l1--) {
+ if (*p1 != *p2) {
+ break;
+ }
+ if (l1 == 0) {
+ return 1;
+ }
+ }
+ }
+
+ return 0;
+}
+
+static unsigned int
+HashVarKey(
+ Tcl_HashTable *tablePtr, /* Hash table. */
+ VOID *keyPtr) /* Key from which to compute hash value. */
+{
+ Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
+ CONST char *string = TclGetString(objPtr);
+ int length = objPtr->length;
+ unsigned int result = 0;
+ int i;
+
+ /*
+ * 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.
+ */
+
+ for (i=0 ; i<length ; i++) {
+ result += (result << 3) + string[i];
+ }
+ return result;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
Index: tests/set-old.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/set-old.test,v
retrieving revision 1.17
diff -u -r1.17 set-old.test
--- tests/set-old.test 27 Mar 2003 21:44:05 -0000 1.17
+++ tests/set-old.test 23 Jul 2007 19:14:37 -0000
@@ -550,7 +550,7 @@
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.38.7 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg
-} {1 {can't set "bogusnamespace::var(0)": variable isn't array}}
+} {1 {can't set "bogusnamespace::var(0)": parent namespace doesn't exist}}
test set-old-8.39 {array command, size option} {
catch {unset a}
array size a
