VarReform [Patch 1750051]

	*** POTENTIAL INCOMPATIBILITY *** (tclInt.h and tclCompile.h)

1 files changed, 37 insertions, 150 deletions

diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index b8ec6e8..7e4a0b0 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.146 2007/07/05 12:03:27 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.147 2007/07/31 17:03:39 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -404,7 +404,8 @@ Tcl_PushCallFrame(
     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 @@ Tcl_PopCallFrame(
     }
     if (framePtr->numCompiledLocals > 0) {
 	TclDeleteCompiledLocalVars(iPtr, framePtr);
+	if (--framePtr->localCachePtr->refCount == 0) {
+	    TclFreeLocalCache(interp, framePtr->localCachePtr);
+	}
+	framePtr->localCachePtr = NULL;
     }
 
     /*
@@ -793,7 +798,7 @@ Tcl_CreateNamespace(
     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 @@ TclTeardownNamespace(
      */
 
     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_FindCommand(
 /*
  *----------------------------------------------------------------------
  *
- * 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 @@ TclGetNamespaceFromObj(
      * 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 @@ TclGetNamespaceFromObj(
 
 	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 @@ NamespaceUpvarCmd(
 
 	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 @@ FreeNsNameInternalRep(
 				 * to free */
 {
     register ResolvedNsName *resNamePtr = (ResolvedNsName *)
-	    objPtr->internalRep.otherValuePtr;
+	    objPtr->internalRep.twoPtrValue.ptr1;
     Namespace *nsPtr;
 
     /*
@@ -4775,9 +4657,9 @@ DupNsNameInternalRep(
     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 @@ SetNsNameFromAny(
 
     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 @@ SetNsNameFromAny(
 	    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 @@ SetNsNameFromAny(
 	}
     } else {
 	TclFreeIntRep(objPtr);
-	objPtr->internalRep.otherValuePtr = (void *) NULL;
+	objPtr->internalRep.twoPtrValue.ptr1 = (void *) NULL;
 	objPtr->typePtr = &tclNsNameType;
     }
     return TCL_OK;
@@ -6994,27 +6876,32 @@ Tcl_LogCommandInfo(
 	    ? "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);
+	}
     }
 }