modifs to help itcl adapt to VarReform

6 files changed, 61 insertions, 13 deletions

diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index f2abb35..54256ea 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 # 
-# RCS: @(#) $Id: tclInt.decls,v 1.111 2007/07/31 17:03:38 msofer Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.112 2007/08/04 18:32:27 msofer Exp $
 
 library tcl
 
@@ -928,6 +928,12 @@ declare 233 generic {
     void TclGetSrcInfoForPc(CmdFrame *contextPtr)
 }
 
+# Exports for VarReform compat: Itcl likes to peek into our varTables :(
+declare 234 generic {
+    Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, 
+             int *newPtr)
+}
+
 ##############################################################################
 
 # Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 5f47fcc..5aae19d 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.327 2007/08/03 13:51:40 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.328 2007/08/04 18:32:27 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -204,6 +204,13 @@ typedef struct TclVarHashTable {
     struct Namespace *nsPtr;
 } TclVarHashTable;
 
+/*
+ * This is for itcl - it likes to search our varTables directly :(
+ */
+
+#define TclVarHashFindVar(tablePtr, key) \
+    TclVarHashCreateVar((tablePtr), (key), NULL)
+
 
 /*
  * The structure below defines a namespace.
@@ -631,7 +638,7 @@ typedef struct VarInHash {
 #define VAR_IN_HASHTABLE	0x4
 #define VAR_DEAD_HASH           0x8
 #define VAR_ARRAY_ELEMENT	0x1000
-#define VAR_NAMESPACE_VAR	0x2000
+#define VAR_NAMESPACE_VAR	0x80      /* KEEP OLD VALUE for Itcl */
 
 #define VAR_ALL_HASH (VAR_IN_HASHTABLE|VAR_DEAD_HASH|VAR_NAMESPACE_VAR|VAR_ARRAY_ELEMENT)
 
@@ -641,7 +648,7 @@ typedef struct VarInHash {
 #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_TRACE_ACTIVE       0x2000
 #define VAR_SEARCH_ACTIVE      0x4000
 #define VAR_ALL_TRACES \
    (VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_ARRAY|VAR_TRACED_UNSET)
@@ -690,10 +697,8 @@ typedef struct VarInHash {
     (varPtr)->flags &= ~VAR_TRACE_ACTIVE
 
 #define TclSetVarNamespaceVar(varPtr) \
-    if (TclIsVarInHash(varPtr) && ! TclIsVarNamespaceVar(varPtr)) {\
-        (varPtr)->flags |= VAR_NAMESPACE_VAR;\
-        ((VarInHash *)(varPtr))->refCount++;\
-    }
+    (varPtr)->flags |= VAR_NAMESPACE_VAR;\
+    ((VarInHash *)(varPtr))->refCount++
 
 #define TclClearVarNamespaceVar(varPtr) \
     if (TclIsVarNamespaceVar(varPtr)) {\
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index abef656..e08b38b 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIntDecls.h,v 1.102 2007/07/31 17:03:38 msofer Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.103 2007/08/04 18:32:27 msofer Exp $
  */
 
 #ifndef _TCLINTDECLS
@@ -1039,6 +1039,12 @@ EXTERN int		TclEvalObjEx (Tcl_Interp * interp, Tcl_Obj * objPtr,
 /* 233 */
 EXTERN void		TclGetSrcInfoForPc (CmdFrame * contextPtr);
 #endif
+#ifndef TclVarHashCreateVar_TCL_DECLARED
+#define TclVarHashCreateVar_TCL_DECLARED
+/* 234 */
+EXTERN Var *		TclVarHashCreateVar (TclVarHashTable * tablePtr, 
+				const char * key, int * newPtr);
+#endif
 
 typedef struct TclIntStubs {
     int magic;
@@ -1293,6 +1299,7 @@ typedef struct TclIntStubs {
     int (*tclGetNamespaceFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Namespace ** nsPtrPtr); /* 231 */
     int (*tclEvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, const CmdFrame * invoker, int word); /* 232 */
     void (*tclGetSrcInfoForPc) (CmdFrame * contextPtr); /* 233 */
+    Var * (*tclVarHashCreateVar) (TclVarHashTable * tablePtr, const char * key, int * newPtr); /* 234 */
 } TclIntStubs;
 
 #ifdef __cplusplus
@@ -2014,6 +2021,10 @@ extern TclIntStubs *tclIntStubsPtr;
 #define TclGetSrcInfoForPc \
 	(tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */
 #endif
+#ifndef TclVarHashCreateVar
+#define TclVarHashCreateVar \
+	(tclIntStubsPtr->tclVarHashCreateVar) /* 234 */
+#endif
 
 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
 
diff --git a/generic/tclProc.c b/generic/tclProc.c
index c6e0219..9a7a422 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclProc.c,v 1.126 2007/07/31 17:03:39 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.127 2007/08/04 18:32:27 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1130,6 +1130,14 @@ TclInitCompiledLocals(
     }
     codePtr = bodyPtr->internalRep.otherValuePtr;
 
+    if (framePtr->numCompiledLocals) {
+	if (!codePtr->localCachePtr) {
+	    InitLocalCache(framePtr->procPtr) ;
+	}
+	framePtr->localCachePtr = codePtr->localCachePtr;
+	framePtr->localCachePtr->refCount++;
+    }    
+
     InitCompiledLocals(interp, codePtr, varPtr, nsPtr);
 }
 
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 35bfa12..efde178 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclStubInit.c,v 1.141 2007/07/02 21:10:52 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.142 2007/08/04 18:32:28 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -323,6 +323,7 @@ TclIntStubs tclIntStubs = {
     TclGetNamespaceFromObj, /* 231 */
     TclEvalObjEx, /* 232 */
     TclGetSrcInfoForPc, /* 233 */
+    TclVarHashCreateVar, /* 234 */
 };
 
 TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 8405c5f..acb2834 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclVar.c,v 1.148 2007/08/03 13:51:41 dkf Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.149 2007/08/04 18:32:28 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -238,6 +238,23 @@ Tcl_ObjType tclArraySearchType = {
     "array search",
     NULL, NULL, NULL, SetArraySearchObj
 };
+
+Var *
+TclVarHashCreateVar(
+    TclVarHashTable *tablePtr,
+    const char *key, 
+    int *newPtr)
+{
+    Tcl_Obj *keyPtr;
+    Var *varPtr;
+
+    keyPtr = Tcl_NewStringObj(key, -1);
+    Tcl_IncrRefCount(keyPtr);
+    varPtr = VarHashCreateVar(tablePtr, keyPtr, newPtr);
+    Tcl_DecrRefCount(keyPtr);
+
+    return varPtr;
+}
 
 /*
  *----------------------------------------------------------------------
@@ -2288,7 +2305,7 @@ UnsetVarStruct(
 	}
 
 	if ((dummyVar.flags & VAR_TRACED_UNSET)
-		|| (arrayPtr->flags & VAR_TRACED_UNSET)) {
+		|| (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) {
 	    dummyVar.flags &= ~VAR_TRACE_ACTIVE;
 	    TclObjCallVarTraces(iPtr, arrayPtr, (Var *) &dummyVar,
 		    part1Ptr, part2Ptr,