From 5f27bf51933b916e9e5c01a9403a74ef83741b6a Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Sat, 4 Aug 2007 18:32:27 +0000 Subject: modifs to help itcl adapt to VarReform --- generic/tclInt.decls | 8 +++++++- generic/tclInt.h | 19 ++++++++++++------- generic/tclIntDecls.h | 13 ++++++++++++- generic/tclProc.c | 10 +++++++++- generic/tclStubInit.c | 3 ++- generic/tclVar.c | 21 +++++++++++++++++++-- 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, -- cgit v0.12