diff options
Diffstat (limited to 'generic/tclLiteral.c')
| -rw-r--r-- | generic/tclLiteral.c | 221 |
1 files changed, 117 insertions, 104 deletions
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index a456627..2b0cc7e 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -12,8 +12,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLiteral.c,v 1.42 2010/02/25 22:20:10 nijtmans Exp $ */ #include "tclInt.h" @@ -34,6 +32,10 @@ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); static unsigned HashString(const char *string, int length); +#ifdef TCL_COMPILE_DEBUG +static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, + Tcl_Obj *objPtr); +#endif static void RebuildLiteralTable(LiteralTable *tablePtr); /* @@ -77,78 +79,6 @@ TclInitLiteralTable( /* *---------------------------------------------------------------------- * - * TclCleanupLiteralTable -- - * - * This function frees the internal representation of every literal in a - * literal table. It is called prior to deleting an interp, so that - * variable refs will be cleaned up properly. - * - * Results: - * None. - * - * Side effects: - * Each literal in the table has its internal representation freed. - * - *---------------------------------------------------------------------- - */ - -void -TclCleanupLiteralTable( - Tcl_Interp *interp, /* Interpreter containing literals to purge */ - LiteralTable *tablePtr) /* Points to the literal table being - * cleaned. */ -{ - int i; - LiteralEntry *entryPtr; /* Pointer to the current entry in the hash - * table of literals. */ - LiteralEntry *nextPtr; /* Pointer to the next entry in the bucket. */ - Tcl_Obj *objPtr; /* Pointer to a literal object whose internal - * rep is being freed. */ - const Tcl_ObjType *typePtr; /* Pointer to the object's type. */ - int didOne; /* Flag for whether we've removed a literal in - * the current bucket. */ - -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable((Interp *) interp); -#endif /* TCL_COMPILE_DEBUG */ - - for (i=0 ; i<tablePtr->numBuckets ; i++) { - /* - * It is tempting simply to walk each hash bucket once and delete the - * internal representations of each literal in turn. It's also wrong. - * The problem is that freeing a literal's internal representation can - * delete other literals to which it refers, making nextPtr invalid. - * So each time we free an internal rep, we start its bucket over - * again. - */ - - do { - didOne = 0; - entryPtr = tablePtr->buckets[i]; - while (entryPtr != NULL) { - objPtr = entryPtr->objPtr; - nextPtr = entryPtr->nextPtr; - typePtr = objPtr->typePtr; - if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { - if (objPtr->bytes == NULL) { - Tcl_Panic("%s: literal without a string rep", - "TclCleanupLiteralTable"); - } - objPtr->typePtr = NULL; - typePtr->freeIntRepProc(objPtr); - didOne = 1; - break; - } else { - entryPtr = nextPtr; - } - } - } while (didOne); - } -} - -/* - *---------------------------------------------------------------------- - * * TclDeleteLiteralTable -- * * This function frees up everything associated with a literal table @@ -201,7 +131,7 @@ TclDeleteLiteralTable( objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; - ckfree((char *) entryPtr); + ckfree(entryPtr); entryPtr = nextPtr; } } @@ -211,7 +141,7 @@ TclDeleteLiteralTable( */ if (tablePtr->buckets != tablePtr->staticBuckets) { - ckfree((char *) tablePtr->buckets); + ckfree(tablePtr->buckets); } } @@ -285,7 +215,7 @@ TclCreateLiteral( *globalPtrPtr = globalPtr; } if (flags & LITERAL_ON_HEAP) { - ckfree((char *) bytes); + ckfree(bytes); } globalPtr->refCount++; return objPtr; @@ -293,7 +223,7 @@ TclCreateLiteral( } if (!newPtr) { if (flags & LITERAL_ON_HEAP) { - ckfree((char *) bytes); + ckfree(bytes); } return NULL; } @@ -313,13 +243,13 @@ TclCreateLiteral( } #ifdef TCL_COMPILE_DEBUG - if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { + if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", "TclRegisterLiteral", (length>60? 60 : length), bytes); } #endif - globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); + globalPtr = ckalloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; globalPtr->refCount = 1; globalPtr->nsPtr = nsPtr; @@ -375,6 +305,33 @@ TclCreateLiteral( /* *---------------------------------------------------------------------- * + * TclFetchLiteral -- + * + * Fetch from a CompileEnv the literal value identified by an index + * value, as returned by a prior call to TclRegisterLiteral(). + * + * Results: + * The literal value, or NULL if the index is out of range. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclFetchLiteral( + CompileEnv *envPtr, /* Points to the CompileEnv from which to + * fetch the registered literal value. */ + unsigned int index) /* Index of the desired literal, as returned + * by prior call to TclRegisterLiteral() */ +{ + if (index >= (unsigned int) envPtr->literalArrayNext) { + return NULL; + } + return envPtr->literalArrayPtr[index].objPtr; +} + +/* + *---------------------------------------------------------------------- + * * TclRegisterLiteral -- * * Find, or if necessary create, an object in a CompileEnv literal array @@ -401,7 +358,7 @@ TclCreateLiteral( int TclRegisterLiteral( - CompileEnv *envPtr, /* Points to the CompileEnv in whose object + void *ePtr, /* 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 @@ -411,10 +368,11 @@ TclRegisterLiteral( * 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 + * this function. If LITERAL_CMD_NAME then + * the literal should not be shared accross * namespaces. */ { + CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; @@ -441,7 +399,7 @@ TclRegisterLiteral( || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { if (flags & LITERAL_ON_HEAP) { - ckfree((char *) bytes); + ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); #ifdef TCL_COMPILE_DEBUG @@ -453,18 +411,22 @@ TclRegisterLiteral( } /* - * 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. + * The literal is new to this CompileEnv. If it is a command name, avoid + * sharing it accross namespaces, and try not to share it with non-cmd + * literals. Note that FQ command names can be shared, so that we register + * the namespace as the interp's global NS. */ - if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr - && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) { - nsPtr = iPtr->varFramePtr->nsPtr; + if (flags & LITERAL_CMD_NAME) { + if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) { + nsPtr = iPtr->globalNsPtr; + } else { + nsPtr = iPtr->varFramePtr->nsPtr; + } } else { nsPtr = NULL; } - + /* * Is it in the interpreter's global literal table? If not, create it. */ @@ -484,10 +446,11 @@ TclRegisterLiteral( return objIndex; } +#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * - * TclLookupLiteralEntry -- + * LookupLiteralEntry -- * * Finds the LiteralEntry that corresponds to a literal Tcl object * holding a literal. @@ -501,8 +464,8 @@ TclRegisterLiteral( *---------------------------------------------------------------------- */ -LiteralEntry * -TclLookupLiteralEntry( +static LiteralEntry * +LookupLiteralEntry( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ register Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal @@ -526,6 +489,7 @@ TclLookupLiteralEntry( return NULL; } +#endif /* *---------------------------------------------------------------------- * @@ -755,15 +719,14 @@ ExpandLocalLiteralArray( int i; if (envPtr->mallocedLiteralArray) { - newArrayPtr = (LiteralEntry *) - ckrealloc((char *)currArrayPtr, 2 * currBytes); + newArrayPtr = ckrealloc(currArrayPtr, 2 * currBytes); } else { /* * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must * code a ckrealloc equivalent for ourselves. */ - newArrayPtr = (LiteralEntry *) ckalloc(2 * currBytes); + newArrayPtr = ckalloc(2 * currBytes); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; } @@ -821,11 +784,16 @@ TclReleaseLiteral( * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &iPtr->literalTable; + LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; int length, index; + if (iPtr == NULL) { + goto done; + } + + globalTablePtr = &iPtr->literalTable; bytes = TclGetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); @@ -852,7 +820,7 @@ TclReleaseLiteral( } else { prevPtr->nextPtr = entryPtr->nextPtr; } - ckfree((char *) entryPtr); + ckfree(entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); @@ -869,6 +837,7 @@ TclReleaseLiteral( * Remove the reference corresponding to the local literal table entry. */ + done: Tcl_DecrRefCount(objPtr); } @@ -974,8 +943,7 @@ RebuildLiteralTable( */ tablePtr->numBuckets *= 4; - tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) - (tablePtr->numBuckets * sizeof(LiteralEntry *))); + tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*)); for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; count>0 ; count--, newChainPtr++) { *newChainPtr = NULL; @@ -1004,7 +972,52 @@ RebuildLiteralTable( */ if (oldBuckets != tablePtr->staticBuckets) { - ckfree((char *) oldBuckets); + ckfree(oldBuckets); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclInvalidateCmdLiteral -- + * + * Invalidate a command literal entry, if present in the literal hash + * tables, by resetting its internal representation. This invalidation + * leaves it in the literal tables and in existing literal arrays. As a + * result, existing references continue to work but we force a fresh + * command look-up upon the next use (see, in particular, + * TclSetCmdNameObj()). + * + * Results: + * None. + * + * Side effects: + * Resets the internal representation of the CmdName Tcl_Obj + * using TclFreeIntRep(). + * + *---------------------------------------------------------------------- + */ + +void +TclInvalidateCmdLiteral( + Tcl_Interp *interp, /* Interpreter for which to invalidate a + * command literal. */ + const char *name, /* Points to the start of the cmd literal + * name. */ + Namespace *nsPtr) /* The namespace for which to lookup and + * invalidate a cmd literal. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + strlen(name), -1, NULL, nsPtr, 0, NULL); + + if (literalObjPtr != NULL) { + if (literalObjPtr->typePtr == &tclCmdNameType) { + TclFreeIntRep(literalObjPtr); + } + /* Balance the refcount effects of TclCreateLiteral() above */ + Tcl_IncrRefCount(literalObjPtr); + TclReleaseLiteral(interp, literalObjPtr); } } @@ -1066,7 +1079,7 @@ TclLiteralStats( * Print out the histogram and a few other pieces of information. */ - result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + result = ckalloc(NUM_COUNTERS*60 + 300); sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); @@ -1122,7 +1135,7 @@ TclVerifyLocalLiteralTable( "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); } - if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, + if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" is not global", |