/* * ------------------------------------------------------------------------ * APPLICATION: [incr Tcl] * PURPOSE: object-oriented extensions to Tcl * * This segment handles variables which are local to the scope of a * class. Variables are classified as "public", "protected" or "common". * Public variables can be manipulated from outside of the class * scope via the special "config" formal argument. Protected variables * can only be accessed within the class scope. Each object has its * own copy of public and protected variables. Common variables, on * the other hand, are allocated once for each class and are shared * among objects. * * ------------------------------------------------------------------------ * AUTHOR: Michael J. McLennan Phone: (610)712-2842 * AT&T Bell Laboratories E-mail: michael.mclennan@att.com * * RCS: itcl_vars.c,v 1.3 1994/04/25 19:14:57 mmc Exp * ======================================================================== * Copyright (c) 1993 AT&T Bell Laboratories * ======================================================================== * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, * provided that the above copyright notice appear in all copies and that * both that the copyright notice and warranty disclaimer appear in * supporting documentation, and that the names of AT&T Bell Laboratories * any of their entities not be used in advertising or publicity * pertaining to distribution of the software without specific, written * prior permission. * * AT&T disclaims all warranties with regard to this software, including * all implied warranties of merchantability and fitness. In no event * shall AT&T be liable for any special, indirect or consequential * damages or any damages whatsoever resulting from loss of use, data or * profits, whether in an action of contract, negligence or other * tortuous action, arising out of or in connection with the use or * performance of this software. * ======================================================================== */ #include "itcl_util.h" #include "itcl_vars.h" #include "itcl_class.h" #include "itcl_core.h" #define ITCL_VAR_LINK 0x4000 static Var* NewVar _ANSI_ARGS_((void)); static void CleanupVar _ANSI_ARGS_((Var* varPtr, Var* arrayPtr)); /* #ifndef lint static char sccsid[] = "@(#)itcl_vars.c 1.15 (10/25/93) Michael J. McLennan"; #endif */ /* * ------------------------------------------------------------------------ * Itcl_CreateVariable() * * Creates a new class variable definition and returns a pointer to it. * ------------------------------------------------------------------------ */ Itcl_Variable* Itcl_CreateVariable(cdefn,name,init,config) Itcl_Class* cdefn; /* class containing this variable */ char* name; /* name of new variable */ char* init; /* initial value for variable */ char* config; /* TCL code invoked when variable is config'd */ { Itcl_Variable *vdefn; char *fullname; vdefn = (Itcl_Variable*)ckalloc(sizeof(Itcl_Variable)); vdefn->cdefn = cdefn; vdefn->name = (char*)ckalloc((unsigned)(strlen(name)+1)); strcpy(vdefn->name, name); fullname = Itcl_MakeSlotName(cdefn->name, name); vdefn->fullname = (char*)ckalloc((unsigned)(strlen(fullname)+1)); strcpy(vdefn->fullname, fullname); vdefn->init = NULL; vdefn->config = NULL; if (init) { vdefn->init = (char*)ckalloc((unsigned)(strlen(init)+1)); strcpy(vdefn->init, init); } if (config) { vdefn->config = (char*)ckalloc((unsigned)(strlen(config)+1)); strcpy(vdefn->config, config); } vdefn->next = NULL; return vdefn; } /* * ------------------------------------------------------------------------ * Itcl_DeleteVariable() * * Destroys the given class variable, freeing all resources associated * with it. * ------------------------------------------------------------------------ */ void Itcl_DeleteVariable(vptr) Itcl_Variable **vptr; /* pointer to variable definition to be destroyed */ { Itcl_Variable *next = (*vptr)->next; ckfree((*vptr)->name); ckfree((*vptr)->fullname); if ((*vptr)->init) ckfree((*vptr)->init); if ((*vptr)->config) ckfree((*vptr)->config); ckfree((char*)(*vptr)); *vptr = next; /* close up linked list */ } /* * ------------------------------------------------------------------------ * Itcl_CreateVarScope() * * Creates a new variable scope, which is basically a hash table * connecting the varible names that are used in a particular class * scope to the actual variables in the object/class data. Variable * names have different meanings in different scopes, since each * class can redefine variables that override (or "shadow") variables * in a base class. If the "odefn" pointer is NULL, only the common * class variables are added to the scope. * Returns a pointer to the new scope object. * ------------------------------------------------------------------------ */ Itcl_VarScope* Itcl_CreateVarScope(odefn,cdefn) Itcl_Object *odefn; /* for object-specific public/protected vars */ Itcl_Class *cdefn; /* class representing scope */ { Itcl_VarScope *vscope; Itcl_Class *cd; Itcl_Variable *vdefn; Itcl_HierIter hier; /* * Allocate and initialize the variable scope definition. */ vscope = (Itcl_VarScope*)ckalloc(sizeof(Itcl_VarScope)); Tcl_InitHashTable(&vscope->allVars, TCL_STRING_KEYS); vscope->cdefn = cdefn; vscope->next = NULL; /* * Scan through all public/protected/common variable definitions * and create a list of variables recognized at this scope. */ Itcl_InitHierIter(&hier,cdefn); while ((cd=Itcl_AdvanceHierIter(&hier)) != NULL) { if (odefn) { for (vdefn=cd->publics; vdefn; vdefn=vdefn->next) Itcl_CreateTclVarLinks(vdefn, &odefn->data, &vscope->allVars, ITCL_VAR_LINK); for (vdefn=cd->protecteds; vdefn; vdefn=vdefn->next) Itcl_CreateTclVarLinks(vdefn, &odefn->data, &vscope->allVars, ITCL_VAR_LINK); } for (vdefn=cd->commons; vdefn; vdefn=vdefn->next) Itcl_CreateTclVarLinks(vdefn, &cd->data, &vscope->allVars, ITCL_VAR_LINK); } Itcl_DeleteHierIter(&hier); return vscope; } /* * ------------------------------------------------------------------------ * Itcl_DeleteVarScope() * * Destroys the given variable scope, freeing all data associated * with it. Usually invoked when an object definition is destroyed. * ------------------------------------------------------------------------ */ void Itcl_DeleteVarScope(vscope) Itcl_VarScope *vscope; /* variable scope data */ { if (vscope) { Interp *iPtr = (Interp*)vscope->cdefn->interp; Itcl_DeleteTclVars(iPtr, &vscope->allVars); ckfree((char*)vscope); } } /* * ------------------------------------------------------------------------ * Itcl_GlobalCmd() * * Installed into the interpreter associated with a class, and invoked * to access global variables in the external interpreter. Makes the * usual "global" command refer to global variables in the outside * world, instead of global variables in the class scope. * * global ?...? * * ------------------------------------------------------------------------ */ int Itcl_GlobalCmd(clientData, interp, argc, argv) ClientData clientData; /* class definition */ Tcl_Interp *interp; /* current interpreter */ int argc; /* number of arguments */ char **argv; /* argument strings */ { Itcl_Class *cdefn = (Itcl_Class*)clientData; register Interp *iPtr = (Interp*)interp; register Interp *exPtr = (Interp*)cdefn->info->main; Var *link, *gVar; Tcl_HashEntry *entry, *gEntry; Tcl_HashTable *vlist; int newEntry; Tcl_SetResult(interp, "", TCL_STATIC); if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName ?varName...?\"", (char*)NULL); return TCL_ERROR; } /* * Create links for all names declared as globals. */ for (argc--, argv++; argc > 0; argc--, argv++) { #if (TCL_MAJOR_VERSION < 8) gEntry = Tcl_CreateHashEntry(&exPtr->globalTable, *argv, &newEntry); #else gEntry = Tcl_CreateHashEntry(&exPtr->globalNsPtr->varTable, *argv, &newEntry); #endif if (newEntry) { gVar = NewVar(); Tcl_SetHashValue(gEntry, gVar); gVar->hPtr = gEntry; } else gVar = (Var*)Tcl_GetHashValue(gEntry); #if (TCL_MAJOR_VERSION < 8) vlist = (iPtr->varFramePtr) ? &iPtr->varFramePtr->varTable : &iPtr->globalTable; #else vlist = (iPtr->varFramePtr) ? &iPtr->varFramePtr->nsPtr->varTable : &iPtr->globalNsPtr->varTable; #endif entry = Tcl_CreateHashEntry(vlist, *argv, &newEntry); if (newEntry) link = NewVar(); else { link = (Var*)Tcl_GetHashValue(entry); #if (TCL_MAJOR_VERSION < 8) if (link->flags & VAR_UPVAR) #else if (link->flags & VAR_LINK) #endif { Var *upvarPtr; #if (TCL_MAJOR_VERSION < 8) upvarPtr = link->value.upvarPtr; #else upvarPtr = link->value.linkPtr; #endif if (upvarPtr == gVar) return TCL_OK; upvarPtr->refCount--; if (upvarPtr->flags & VAR_UNDEFINED) CleanupVar(upvarPtr, (Var*)NULL); } else if (!(link->flags & VAR_UNDEFINED)) { Tcl_AppendResult(interp, "variable \"", *argv, "\" already exists", (char*)NULL); return TCL_ERROR; } } #if (TCL_MAJOR_VERSION < 8) link->flags = (link->flags & ~VAR_UNDEFINED) | VAR_UPVAR; link->value.upvarPtr = gVar; #else link->flags = (link->flags & ~VAR_UNDEFINED) | VAR_LINK; link->value.linkPtr = gVar; #endif gVar->refCount++; Tcl_SetHashValue(entry, link); link->hPtr = entry; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_GetVar() * * Returns the value of the specified data member, or NULL if that * member is not found on the given list. * ------------------------------------------------------------------------ */ char* Itcl_GetVar(vdefn,vlist) Itcl_Variable *vdefn; /* desired variable */ Tcl_HashTable *vlist; /* variable list representing scope */ { Tcl_HashEntry *vEntry; vEntry = Tcl_FindHashEntry(vlist,vdefn->fullname); if (vEntry) { Var *var = (Var*)Tcl_GetHashValue(vEntry); #if (TCL_MAJOR_VERSION < 8) if (var->flags & VAR_UPVAR) { var = var->value.upvarPtr; if (var) return var->value.string; } #else if (var->flags & VAR_LINK) { var = var->value.linkPtr; if (var) return Tcl_GetStringFromObj(var->value.objPtr, NULL); } #endif else if (var->flags & VAR_ARRAY) return ""; else if (var->flags & VAR_UNDEFINED) return ""; else #if (TCL_MAJOR_VERSION < 8) return var->value.string; #else return Tcl_GetStringFromObj(var->value.objPtr, NULL); #endif } return (char*)NULL; } /* * ------------------------------------------------------------------------ * Itcl_CreateTclVar() * * Creates the structure representing a Tcl variable and installs * the variable into the hash table representing a scope. Provides * a cleaner interface to the Tcl "NewVar" routine. * ------------------------------------------------------------------------ */ Var* Itcl_CreateTclVar(vdefn,vlist) Itcl_Variable* vdefn; /* class containing this variable */ Tcl_HashTable *vlist; /* list of Tcl variables */ { Var *newvar; Tcl_HashEntry *entry; int newEntry; newvar = NewVar(); if (vdefn->init) { int newSize = strlen(vdefn->init)+1; newSize = (newSize < 24) ? 24 : newSize; #if (TCL_MAJOR_VERSION < 8) newvar->valueSpace = newSize; newvar->value.string = ckalloc((unsigned)newSize); strcpy(newvar->value.string, vdefn->init); #else newvar->value.objPtr = Tcl_NewStringObj (vdefn->init, -1); /*TclNewObj(newvar->value.objPtr); TclInitStringRep(newvar->value.objPtr, vdefn->init, newSize); Tcl_IncrRefCount(newvar->value.objPtr);*/ #endif newvar->flags &= ~VAR_UNDEFINED; } /* * Set refCount=1 so that this variable won't look * like garbage and accidentally get destroyed by * TclDeleteVars() after a method invocation. */ newvar->refCount = 1; entry = Tcl_CreateHashEntry(vlist,vdefn->fullname,&newEntry); Tcl_SetHashValue(entry, (ClientData)newvar); newvar->hPtr = entry; return newvar; } /* * ------------------------------------------------------------------------ * Itcl_CreateTclVarLinks() * * Creates the structure representing an "upvar" link to a Tcl variable * and installs the variable into the hash table representing a scope. * Actually, two such links are created: One for the full variable * name, and another for the short name if it is not already known. * If "flags" are specified, they are added to the flags for the "upvar" * structure; flags are usually included to signal that these links * should be protected from destruction in Itcl_RemoveCallFrame(). * Provides a cleaner interface to the Tcl "NewVar" routine. * ------------------------------------------------------------------------ */ void Itcl_CreateTclVarLinks(vdefn,vlist,scope,flags) Itcl_Variable* vdefn; /* class containing this variable */ Tcl_HashTable *vlist; /* variable list containing actual Var */ Tcl_HashTable *scope; /* variable list representing scope */ int flags; /* flags added to "upvar" links */ { int newEntry; Tcl_HashEntry *vEntry, *lEntry; Var *orgVar, *linkVar; /* * Find (or create) the original variable to link to. */ vEntry = Tcl_CreateHashEntry(vlist, vdefn->fullname, &newEntry); if (newEntry) { orgVar = NewVar(); Tcl_SetHashValue(vEntry, orgVar); orgVar->hPtr = vEntry; } else orgVar = (Var*)Tcl_GetHashValue(vEntry); /* * Create a link variable for the explicit variable name. */ linkVar = NewVar(); #if (TCL_MAJOR_VERSION < 8) linkVar->flags = (linkVar->flags & ~VAR_UNDEFINED) | VAR_UPVAR | flags; linkVar->value.upvarPtr = orgVar; #else linkVar->flags = (linkVar->flags & ~VAR_UNDEFINED) | VAR_LINK | flags; linkVar->value.linkPtr = orgVar; #endif if (flags != 0) /* special [incr Tcl] flags? */ linkVar->refCount++; /* then protect link from being deleted */ orgVar->refCount++; lEntry = Tcl_CreateHashEntry(scope, vdefn->fullname, &newEntry); Tcl_SetHashValue(lEntry, (ClientData)linkVar); linkVar->hPtr = lEntry; /* * Create a link variable for the short variable name * (without scope::) if this name is not already known. */ if (!Tcl_FindHashEntry(scope,vdefn->name)) { linkVar = NewVar(); #if (TCL_MAJOR_VERSION < 8) linkVar->flags = (linkVar->flags & ~VAR_UNDEFINED) | VAR_UPVAR | flags; linkVar->value.upvarPtr = orgVar; #else linkVar->flags = (linkVar->flags & ~VAR_UNDEFINED) | VAR_LINK | flags; linkVar->value.linkPtr = orgVar; #endif if (flags != 0) /* special [incr Tcl] flags? */ linkVar->refCount++; /* then protect link from being deleted */ orgVar->refCount++; lEntry = Tcl_CreateHashEntry(scope, vdefn->name, &newEntry); Tcl_SetHashValue(lEntry, (ClientData)linkVar); linkVar->hPtr = lEntry; } } /* * ------------------------------------------------------------------------ * Itcl_DeleteTclVars() * * Destroys all variables in the given hash table. Decrements the * variable reference count (thereby releasing [incr Tcl]'s claim on * the variable), and then calls the usual TclDeleteVars() to invoke * traces and destroy the variables. * ------------------------------------------------------------------------ */ void Itcl_DeleteTclVars(iPtr, vlist) Interp* iPtr; /* interpreter responsible for vars (for traces) */ Tcl_HashTable *vlist; /* variable list to be destroyed */ { Tcl_HashSearch place; Tcl_HashEntry *entry; Var *varPtr; /* * Decrement all reference counts to release [incr Tcl]'s claim * to these variables. */ entry = Tcl_FirstHashEntry(vlist, &place); while (entry) { varPtr = (Var*)Tcl_GetHashValue(entry); varPtr->refCount--; entry = Tcl_NextHashEntry(&place); } TclDeleteVars(iPtr,vlist); } /* * ------------------------------------------------------------------------ * Itcl_EnterExecScope() * * Modifies an interpreter to recognize a new scope of execution. * This routine is needed to allow multiple interpreters to share a * single stack of CallFrames. Upon entering a new execution scope, * the "varFramePtr" in the new interpreter is set to the current * stack in the calling interpreter. This gives the "upvar" and * "uplevel" commands in the new interpreter access to all existing * CallFrames, regardless of which interpreter they belong to. * * This routine establishes a new execution scope and returns a token * representing the new scope. This token must be passed to * Itcl_LeaveExecScope() to change the scope back to the calling * interpreter. Specifically, this routine does the following: * * 1) Patches the "varFramePtr" in the execution interpreter * to recognize CallFrames in the calling interpreter. * * 2) If a variable scope is specified, a new CallFrame is * created and initialized with variables in that scope. * * ------------------------------------------------------------------------ */ void Itcl_EnterExecScope(interp,exscope,vscope,from) Tcl_Interp* interp; /* execution interpreter for new scope */ Itcl_ExecScope *exscope; /* token to be initialized */ Itcl_VarScope *vscope; /* list of variables at this scope */ Tcl_Interp* from; /* calling interpreter */ { Interp *eiPtr = (Interp*)interp; Interp *ciPtr = (Interp*)from; /* * Reset the result in the new interp so that error * info gets wiped clean. */ Tcl_ResetResult(interp); /* * Patch in CallFrame stack from calling interpreter. */ exscope->savedVFPtr = eiPtr->varFramePtr; eiPtr->varFramePtr = ciPtr->varFramePtr; /* * If a variable scope was specificied, install a new CallFrame * initialized for this scope. */ exscope->frameActive = 0; if (vscope) { Itcl_InstallCallFrame(interp, &exscope->frame, vscope); exscope->frameActive = ~0; } } /* * ------------------------------------------------------------------------ * Itcl_LeaveExecScope() * * Cleans up after a previous call to Itcl_EnterExecScope(). Marks * the end of execution in a particular scope. If a CallFrame was * established when the scope was entered, it is removed at this point. * The execution interpreter is also patched to resume its previous * CallFrame stack. * ------------------------------------------------------------------------ */ void Itcl_LeaveExecScope(interp,exscope) Tcl_Interp* interp; /* execution interpreter for new scope */ Itcl_ExecScope *exscope; /* token to be initialized */ { Interp *eiPtr = (Interp*)interp; /* * If a CallFrame is active, then remove it. */ if (exscope->frameActive) Itcl_RemoveCallFrame(interp, &exscope->frame); /* * Patch in CallFrame stack back to its original state. */ eiPtr->varFramePtr = exscope->savedVFPtr; } /* * ------------------------------------------------------------------------ * Itcl_InstallCallFrame() * * Initializes a Tcl CallFrame and installs it into the given * interpreter. The variable table is automatically populated with * a series of variables from the given reference frame. This action * prepares the interpreter for a method/proc invocation. * ------------------------------------------------------------------------ */ void Itcl_InstallCallFrame(interp,frame,vscope) Tcl_Interp* interp; /* interpreter containing data */ CallFrame *frame; /* raw call frame to be installed */ Itcl_VarScope *vscope; /* list of variables at this scope */ { Interp *iPtr = (Interp*)interp; int newEntry; char *vname; Tcl_HashSearch place; register Tcl_HashEntry *entry, *copy; /* * Install the class's call frame for the proc invocation. * (Borrowing heavily from the "InterpProc" routine in "tclProc.c") */ if (iPtr->varFramePtr != NULL) frame->level = iPtr->varFramePtr->level + 1; else frame->level = 1; #if (TCL_MAJOR_VERSION < 8) frame->argc = 0; frame->argv = (char**)NULL; #else frame->objc = 0; frame->objv = (Tcl_Obj**)NULL; { static int nsc = 0; char nsn[8]; Namespace *nsPtr; sprintf (nsn, "ns%d", nsc++); nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsn, NULL, NULL); nsPtr->activationCount++; frame->nsPtr = nsPtr; } frame->isProcCallFrame = 0; frame->procPtr = NULL; frame->numCompiledLocals = 0; frame->compiledLocals = NULL; frame->varTablePtr = NULL; #endif frame->callerPtr = iPtr->framePtr; frame->callerVarPtr = iPtr->varFramePtr; iPtr->framePtr = frame; iPtr->varFramePtr = frame; /* * Populate the variable list in the frame with variables from * the current scope. */ #if (TCL_MAJOR_VERSION < 8) Tcl_InitHashTable(&frame->varTable, TCL_STRING_KEYS); #else /*frame->varTablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));*/ Tcl_InitHashTable(&frame->nsPtr->varTable, TCL_STRING_KEYS); #endif if (vscope) { entry = Tcl_FirstHashEntry(&vscope->allVars, &place); while (entry) { vname = Tcl_GetHashKey(&vscope->allVars,entry); #if (TCL_MAJOR_VERSION < 8) copy = Tcl_CreateHashEntry(&frame->varTable, vname, &newEntry); #else copy = Tcl_CreateHashEntry(&frame->nsPtr->varTable, vname, &newEntry); #endif Tcl_SetHashValue(copy, Tcl_GetHashValue(entry)); entry = Tcl_NextHashEntry(&place); } } } /* * ------------------------------------------------------------------------ * Itcl_SetArgVar() * * Similar to Tcl_SetVar() in that it sets a variable with the given * name to the specified value. But this routine also checks the * local variables in the current call frame to make sure that the * requested variable is not already installed as a data member from * an [incr Tcl] class. If it is, the reference to the data member * is removed, and a new variable is created in its place. Used to * initialize formal arguments for methods/procs. Makes sure that * formal arguments do not clobber data members having the same names. * ------------------------------------------------------------------------ */ void Itcl_SetArgVar(interp,name,value) Tcl_Interp* interp; /* interpreter containing data */ char *name; /* name of argument being set */ char *value; /* new value for argument variable */ { Interp *iPtr = (Interp*)interp; Tcl_HashEntry *entry; Var *var; /* * If interp has a CallFrame, then check for a variable * already installed with the argument name. If any such * variable exists, and if it is being used by [incr Tcl], * then unlink it before setting the argument variable. */ if (iPtr->framePtr) { #if (TCL_MAJOR_VERSION < 8) entry = Tcl_FindHashEntry(&iPtr->framePtr->varTable, name); if (entry) { var = (Var*)Tcl_GetHashValue(entry); if ((var->flags & VAR_UPVAR) && (var->flags & ITCL_VAR_LINK)) Tcl_DeleteHashEntry(entry); } #else entry = Tcl_FindHashEntry(&iPtr->framePtr->nsPtr->varTable, name); if (entry) { var = (Var*)Tcl_GetHashValue(entry); if ((var->flags & VAR_LINK) && (var->flags & ITCL_VAR_LINK)) Tcl_DeleteHashEntry(entry); } #endif } Tcl_SetVar(interp, name, value, 0); } /* * ------------------------------------------------------------------------ * Itcl_RemoveCallFrame() * * Removes the top-most frame for a Tcl interpreter, and destroys all * variables except for "upvar" links marked as ITCL_VAR_LINKs. * These links represent class/object data created by [incr Tcl], * and are left intact for the next proc/method invocation. * ------------------------------------------------------------------------ */ void Itcl_RemoveCallFrame(interp,frame) Tcl_Interp* interp; /* interpreter containing data */ CallFrame *frame; /* call frame to be cleaned */ { Interp *iPtr = (Interp*)interp; int newEntry; char *vname; Tcl_HashSearch place; Tcl_HashEntry *entry, *copy; Tcl_HashTable trash; Var *var; /* * Remove the call frame from the interpreter. It's important * to do this so that traces invoked during the deletion don't * see the partially deleted frame. */ iPtr->framePtr = frame->callerPtr; iPtr->varFramePtr = frame->callerVarPtr; /* * Scan through all variables in the given frame and look * for "upvar" links with a magic link count. Protect these * variables, but transfer all others to a list for deletion. */ Tcl_InitHashTable(&trash, TCL_STRING_KEYS); #if (TCL_MAJOR_VERSION < 8) entry = Tcl_FirstHashEntry(&frame->varTable, &place); #else entry = Tcl_FirstHashEntry(&frame->nsPtr->varTable, &place); #endif while (entry) { var = (Var*)Tcl_GetHashValue(entry); /* * Protect class/object data members */ #if (TCL_MAJOR_VERSION < 8) if ((var->flags & VAR_UPVAR) && (var->flags & ITCL_VAR_LINK)) ; /* protected data member */ #else if ((var->flags & VAR_LINK) && (var->flags & ITCL_VAR_LINK)) ; /* protected data member */ #endif /* * Destroy all other variables. */ else { #if (TCL_MAJOR_VERSION < 8) vname = Tcl_GetHashKey(&frame->varTable,entry); #else vname = Tcl_GetHashKey(&frame->nsPtr->varTable,entry); #endif copy = Tcl_CreateHashEntry(&trash,vname,&newEntry); Tcl_SetHashValue(copy, (ClientData)var); Tcl_DeleteHashEntry(entry); } entry = Tcl_NextHashEntry(&place); } TclDeleteVars(iPtr, &trash); #if (TCL_MAJOR_VERSION < 8) Tcl_DeleteHashTable(&frame->varTable); #else /*Tcl_DeleteHashTable(&frame->nsPtr->varTable);*/ if (frame->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, frame); } /* * Decrement the namespace's count of active call frames. If the * namespace is "dying" and there are no more active call frames, * call Tcl_DeleteNamespace to destroy it. */ { Namespace *nsPtr = frame->nsPtr; nsPtr->activationCount--; if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } frame->nsPtr = NULL; } #endif } /* * ======================================================================== * VARIABLE-HANDLING PROCEDURES * ======================================================================== * The following procedures are copied directly from tclVar.c in the * standard TCL distribution, and must be updated whenever TCL is * updated. These procedures must be coped here since they are static * (private) in the original distribution and cannot be accessed in * any other way. It seems to me that a clean interface to low-level * Tcl routines would be a useful thing. * ======================================================================== */ /* * tclVar.c -- * * This file contains routines that implement Tcl variables * (both scalars and arrays). * * The implementation of arrays is modelled after an initial * implementation by Karl Lehenbauer, Mark Diekhans and * Peter da Silva. * * Copyright 1987-1991 Regents of the University of California * Permission to use, copy, modify, and distribute this * software and its documentation for any purpose and without * fee is hereby granted, provided that the above copyright * notice appear in all copies. The University of California * makes no representations about the suitability of this * software for any purpose. It is provided "as is" without * express or implied warranty. */ #if (TCL_MAJOR_VERSION < 8) /* *---------------------------------------------------------------------- * * NewVar -- * * Create a new variable with a given amount of storage * space. * * Results: * The return value is a pointer to the new variable structure. * The variable will not be part of any hash table yet. Its * initial value is empty. * * Side effects: * Storage gets allocated. * *---------------------------------------------------------------------- */ static Var * NewVar() { register Var *varPtr; varPtr = (Var *) ckalloc(sizeof(Var)); varPtr->valueLength = 0; varPtr->valueSpace = 0; varPtr->value.string = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; varPtr->flags = VAR_UNDEFINED; return varPtr; } /* *---------------------------------------------------------------------- * * CleanupVar -- * * This procedure is called when it looks like it may be OK * to free up the variable's record and hash table entry, and * those of its containing parent. It's called, for example, * when a trace on a variable deletes the variable. * * Results: * None. * * Side effects: * If the variable (or its containing array) really is dead then * its record, and possibly its hash table entry, gets freed up. * *---------------------------------------------------------------------- */ static void CleanupVar(varPtr, arrayPtr) 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 ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0) && (varPtr->tracePtr == NULL)) { if (varPtr->hPtr != NULL) { Tcl_DeleteHashEntry(varPtr->hPtr); } ckfree((char *) varPtr); } if (arrayPtr != NULL) { if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0) && (arrayPtr->tracePtr == NULL)) { if (arrayPtr->hPtr != NULL) { Tcl_DeleteHashEntry(arrayPtr->hPtr); } ckfree((char *) arrayPtr); } } return; } #else /* *---------------------------------------------------------------------- * * 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() { 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; } /* *---------------------------------------------------------------------- * * CleanupVar -- * * This procedure 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 procedure 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 void CleanupVar(varPtr, arrayPtr) 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); } } } #endif