/[dtapublic]/projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclliteral.c
ViewVC logotype

Diff of /projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclliteral.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

projs/trunk/shared_source/tcl_base/tclliteral.c revision 42 by dashley, Fri Oct 14 01:50:00 2016 UTC projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclliteral.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclliteral.c,v 1.1.1.1 2001/06/13 04:42:47 dtashley Exp $ */  
   
 /*  
  * tclLiteral.c --  
  *  
  *      Implementation of the global and ByteCode-local literal tables  
  *      used to manage the Tcl objects created for literal values during  
  *      compilation of Tcl scripts. This implementation borrows heavily  
  *      from the more general hashtable implementation of Tcl hash tables  
  *      that appears in tclHash.c.  
  *  
  * Copyright (c) 1997-1998 Sun Microsystems, Inc.  
  *  
  * 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.1.1.1 2001/06/13 04:42:47 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
 #include "tclCompile.h"  
 #include "tclPort.h"  
 /*  
  * When there are this many entries per bucket, on average, rebuild  
  * a literal's hash table to make it larger.  
  */  
   
 #define REBUILD_MULTIPLIER      3  
   
 /*  
  * Procedure prototypes for static procedures in this file:  
  */  
   
 static int              AddLocalLiteralEntry _ANSI_ARGS_((  
                             CompileEnv *envPtr, LiteralEntry *globalPtr,  
                             int localHash));  
 static void             ExpandLocalLiteralArray _ANSI_ARGS_((  
                             CompileEnv *envPtr));  
 static unsigned int     HashString _ANSI_ARGS_((CONST char *bytes,  
                             int length));  
 static void             RebuildLiteralTable _ANSI_ARGS_((  
                             LiteralTable *tablePtr));  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclInitLiteralTable --  
  *  
  *      This procedure is called to initialize the fields of a literal table  
  *      structure for either an interpreter or a compilation's CompileEnv  
  *      structure.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The literal table is made ready for use.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclInitLiteralTable(tablePtr)  
     register LiteralTable *tablePtr; /* Pointer to table structure, which  
                                       * is supplied by the caller. */  
 {  
 #if (TCL_SMALL_HASH_TABLE != 4)  
     panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",  
             TCL_SMALL_HASH_TABLE);  
 #endif  
       
     tablePtr->buckets = tablePtr->staticBuckets;  
     tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;  
     tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;  
     tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;  
     tablePtr->numEntries = 0;  
     tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;  
     tablePtr->mask = 3;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclDeleteLiteralTable --  
  *  
  *      This procedure frees up everything associated with a literal table  
  *      except for the table's structure itself.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Each literal in the table is released: i.e., its reference count  
  *      in the global literal table is decremented and, if it becomes zero,  
  *      the literal is freed. In addition, the table's bucket array is  
  *      freed.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclDeleteLiteralTable(interp, tablePtr)  
     Tcl_Interp *interp;         /* Interpreter containing shared literals  
                                  * referenced by the table to delete. */  
     LiteralTable *tablePtr;     /* Points to the literal table to delete. */  
 {  
     LiteralEntry *entryPtr;  
     int i, start;  
   
     /*  
      * Release remaining literals in the table. Note that releasing a  
      * literal might release other literals, modifying the table, so we  
      * restart the search from the bucket chain we last found an entry.  
      */  
   
 #ifdef TCL_COMPILE_DEBUG  
     TclVerifyGlobalLiteralTable((Interp *) interp);  
 #endif /*TCL_COMPILE_DEBUG*/  
   
     start = 0;  
     while (tablePtr->numEntries > 0) {  
         for (i = start;  i < tablePtr->numBuckets;  i++) {  
             entryPtr = tablePtr->buckets[i];  
             if (entryPtr != NULL) {  
                 TclReleaseLiteral(interp, entryPtr->objPtr);  
                 start = i;  
                 break;  
             }  
         }  
     }  
   
     /*  
      * Free up the table's bucket array if it was dynamically allocated.  
      */  
   
     if (tablePtr->buckets != tablePtr->staticBuckets) {  
         ckfree((char *) tablePtr->buckets);  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclRegisterLiteral --  
  *  
  *      Find, or if necessary create, an object in a CompileEnv literal  
  *      array that has a string representation matching the argument string.  
  *  
  * Results:  
  *      The index in the CompileEnv's literal array that references a  
  *      shared literal matching the string. The object is created if  
  *      necessary.  
  *  
  * Side effects:  
  *      To maximize sharing, we look up the string in the interpreter's  
  *      global literal table. If not found, we create a new shared literal  
  *      in the global table. We then add a reference to the shared  
  *      literal in the CompileEnv's literal array.  
  *  
  *      If onHeap is 1, this procedure is given ownership of the string: if  
  *      an object is created then its string representation is set directly  
  *      from string, otherwise the string is freed. Typically, a caller sets  
  *      onHeap 1 if "string" is an already heap-allocated buffer holding the  
  *      result of backslash substitutions.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclRegisterLiteral(envPtr, bytes, length, onHeap)  
     CompileEnv *envPtr;         /* 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  
                                  * array. */  
     int length;                 /* Number of bytes in the string. If < 0,  
                                  * the string consists of all bytes up to  
                                  * the first null character. */  
     int onHeap;                 /* If 1 then the caller already malloc'd  
                                  * bytes and ownership is passed to this  
                                  * procedure. */  
 {  
     Interp *iPtr = envPtr->iPtr;  
     LiteralTable *globalTablePtr = &(iPtr->literalTable);  
     LiteralTable *localTablePtr = &(envPtr->localLitTable);  
     register LiteralEntry *globalPtr, *localPtr;  
     register Tcl_Obj *objPtr;  
     unsigned int hash;  
     int localHash, globalHash, objIndex;  
     long n;  
     char buf[TCL_INTEGER_SPACE];  
   
     if (length < 0) {  
         length = (bytes? strlen(bytes) : 0);  
     }  
     hash = HashString(bytes, length);  
   
     /*  
      * Is the literal already in the CompileEnv's local literal array?  
      * If so, just return its index.  
      */  
   
     localHash = (hash & localTablePtr->mask);  
     for (localPtr = localTablePtr->buckets[localHash];  
           localPtr != NULL;  localPtr = localPtr->nextPtr) {  
         objPtr = localPtr->objPtr;  
         if ((objPtr->length == length) && ((length == 0)  
                 || ((objPtr->bytes[0] == bytes[0])  
                         && (memcmp(objPtr->bytes, bytes, (unsigned) length)  
                                 == 0)))) {  
             if (onHeap) {  
                 ckfree(bytes);  
             }  
             objIndex = (localPtr - envPtr->literalArrayPtr);  
 #ifdef TCL_COMPILE_DEBUG  
             TclVerifyLocalLiteralTable(envPtr);  
 #endif /*TCL_COMPILE_DEBUG*/  
   
             return objIndex;  
         }  
     }  
   
     /*  
      * The literal is new to this CompileEnv. Is it in the interpreter's  
      * global literal table?  
      */  
   
     globalHash = (hash & globalTablePtr->mask);  
     for (globalPtr = globalTablePtr->buckets[globalHash];  
          globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {  
         objPtr = globalPtr->objPtr;  
         if ((objPtr->length == length) && ((length == 0)  
                 || ((objPtr->bytes[0] == bytes[0])  
                         && (memcmp(objPtr->bytes, bytes, (unsigned) length)  
                                 == 0)))) {  
             /*  
              * A global literal was found. Add an entry to the CompileEnv's  
              * local literal array.  
              */  
               
             if (onHeap) {  
                 ckfree(bytes);  
             }  
             objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);  
 #ifdef TCL_COMPILE_DEBUG  
             if (globalPtr->refCount < 1) {  
                 panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",  
                         (length>60? 60 : length), bytes,  
                         globalPtr->refCount);  
             }  
             TclVerifyLocalLiteralTable(envPtr);  
 #endif /*TCL_COMPILE_DEBUG*/  
             return objIndex;  
         }  
     }  
   
     /*  
      * The literal is new to the interpreter. Add it to the global literal  
      * table then add an entry to the CompileEnv's local literal array.  
      * Convert the object to an integer object if possible.  
      */  
   
     TclNewObj(objPtr);  
     Tcl_IncrRefCount(objPtr);  
     if (onHeap) {  
         objPtr->bytes = bytes;  
         objPtr->length = length;  
     } else {  
         TclInitStringRep(objPtr, bytes, length);  
     }  
   
     if (TclLooksLikeInt(bytes, length)) {  
         /*  
          * From here we use the objPtr, because it is NULL terminated  
          */  
         if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {  
             TclFormatInt(buf, n);  
             if (strcmp(objPtr->bytes, buf) == 0) {  
                 objPtr->internalRep.longValue = n;  
                 objPtr->typePtr = &tclIntType;  
             }  
         }  
     }  
       
 #ifdef TCL_COMPILE_DEBUG  
     if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {  
         panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",  
                 (length>60? 60 : length), bytes);  
     }  
 #endif  
   
     globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));  
     globalPtr->objPtr = objPtr;  
     globalPtr->refCount = 0;  
     globalPtr->nextPtr = globalTablePtr->buckets[globalHash];  
     globalTablePtr->buckets[globalHash] = globalPtr;  
     globalTablePtr->numEntries++;  
   
     /*  
      * If the global literal table has exceeded a decent size, rebuild it  
      * with more buckets.  
      */  
   
     if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {  
         RebuildLiteralTable(globalTablePtr);  
     }  
     objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);  
   
 #ifdef TCL_COMPILE_DEBUG  
     TclVerifyGlobalLiteralTable(iPtr);  
     TclVerifyLocalLiteralTable(envPtr);  
     {  
         LiteralEntry *entryPtr;  
         int found, i;  
         found = 0;  
         for (i = 0;  i < globalTablePtr->numBuckets;  i++) {  
             for (entryPtr = globalTablePtr->buckets[i];  
                     entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {  
                 if ((entryPtr == globalPtr)  
                         && (entryPtr->objPtr == objPtr)) {  
                     found = 1;  
                 }  
             }  
         }  
         if (!found) {  
             panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",  
                     (length>60? 60 : length), bytes);  
         }  
     }  
 #endif /*TCL_COMPILE_DEBUG*/  
 #ifdef TCL_COMPILE_STATS    
     iPtr->stats.numLiteralsCreated++;  
     iPtr->stats.totalLitStringBytes   += (double) (length + 1);  
     iPtr->stats.currentLitStringBytes += (double) (length + 1);  
     iPtr->stats.literalCount[TclLog2(length)]++;  
 #endif /*TCL_COMPILE_STATS*/  
     return objIndex;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclLookupLiteralEntry --  
  *  
  *      Finds the LiteralEntry that corresponds to a literal Tcl object  
  *      holding a literal.  
  *  
  * Results:  
  *      Returns the matching LiteralEntry if found, otherwise NULL.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 LiteralEntry *  
 TclLookupLiteralEntry(interp, objPtr)  
     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 that was previously created by a  
                                  * call to TclRegisterLiteral. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     LiteralTable *globalTablePtr = &(iPtr->literalTable);  
     register LiteralEntry *entryPtr;  
     char *bytes;  
     int length, globalHash;  
   
     bytes = Tcl_GetStringFromObj(objPtr, &length);  
     globalHash = (HashString(bytes, length) & globalTablePtr->mask);  
     for (entryPtr = globalTablePtr->buckets[globalHash];  
             entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {  
         if (entryPtr->objPtr == objPtr) {  
             return entryPtr;  
         }  
     }  
     return NULL;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclHideLiteral --  
  *  
  *      Remove a literal entry from the literal hash tables, leaving it in  
  *      the literal array so existing references continue to function.  
  *      This makes it possible to turn a shared literal into a private  
  *      literal that cannot be shared.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Removes the literal from the local hash table and decrements the  
  *      global hash entry's reference count.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclHideLiteral(interp, envPtr, index)  
     Tcl_Interp *interp;          /* Interpreter for which objPtr was created  
                                   * to hold a literal. */  
     register CompileEnv *envPtr; /* Points to CompileEnv whose literal array  
                                   * contains the entry being hidden. */  
     int index;                   /* The index of the entry in the literal  
                                   * array. */  
 {  
     LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;  
     LiteralTable *localTablePtr = &(envPtr->localLitTable);  
     int localHash, length;  
     char *bytes;  
     Tcl_Obj *newObjPtr;  
   
     lPtr = &(envPtr->literalArrayPtr[index]);  
   
     /*  
      * To avoid unwanted sharing we need to copy the object and remove it from  
      * the local and global literal tables.  It still has a slot in the literal  
      * array so it can be referred to by byte codes, but it will not be matched  
      * by literal searches.  
      */  
   
     newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);  
     Tcl_IncrRefCount(newObjPtr);  
     TclReleaseLiteral(interp, lPtr->objPtr);  
     lPtr->objPtr = newObjPtr;  
   
     bytes = Tcl_GetStringFromObj(newObjPtr, &length);  
     localHash = (HashString(bytes, length) & localTablePtr->mask);  
     nextPtrPtr = &localTablePtr->buckets[localHash];  
   
     for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) {  
         if (entryPtr == lPtr) {  
             *nextPtrPtr = lPtr->nextPtr;  
             lPtr->nextPtr = NULL;  
             localTablePtr->numEntries--;  
             break;  
         }  
         nextPtrPtr = &entryPtr->nextPtr;  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclAddLiteralObj --  
  *  
  *      Add a single literal object to the literal array.  This  
  *      function does not add the literal to the local or global  
  *      literal tables.  The caller is expected to add the entry  
  *      to whatever tables are appropriate.  
  *  
  * Results:  
  *      The index in the CompileEnv's literal array that references the  
  *      literal.  Stores the pointer to the new literal entry in the  
  *      location referenced by the localPtrPtr argument.  
  *  
  * Side effects:  
  *      Expands the literal array if necessary.  Increments the refcount  
  *      on the literal object.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclAddLiteralObj(envPtr, objPtr, litPtrPtr)  
     register CompileEnv *envPtr; /* Points to CompileEnv in whose literal  
                                   * array the object is to be inserted. */  
     Tcl_Obj *objPtr;             /* The object to insert into the array. */  
     LiteralEntry **litPtrPtr;    /* The location where the pointer to the  
                                   * new literal entry should be stored.  
                                   * May be NULL. */  
 {  
     register LiteralEntry *lPtr;  
     int objIndex;  
   
     if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {  
         ExpandLocalLiteralArray(envPtr);  
     }  
     objIndex = envPtr->literalArrayNext;  
     envPtr->literalArrayNext++;  
   
     lPtr = &(envPtr->literalArrayPtr[objIndex]);  
     lPtr->objPtr = objPtr;  
     Tcl_IncrRefCount(objPtr);  
     lPtr->refCount = -1;        /* i.e., unused */  
     lPtr->nextPtr = NULL;  
   
     if (litPtrPtr) {  
         *litPtrPtr = lPtr;  
     }  
   
     return objIndex;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * AddLocalLiteralEntry --  
  *  
  *      Insert a new literal into a CompileEnv's local literal array.  
  *  
  * Results:  
  *      The index in the CompileEnv's literal array that references the  
  *      literal.  
  *  
  * Side effects:  
  *      Increments the ref count of the global LiteralEntry since the  
  *      CompileEnv now refers to the literal. Expands the literal array  
  *      if necessary. May rebuild the hash bucket array of the CompileEnv's  
  *      literal array if it becomes too large.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 AddLocalLiteralEntry(envPtr, globalPtr, localHash)  
     register CompileEnv *envPtr; /* Points to CompileEnv in whose literal  
                                   * array the object is to be inserted. */  
     LiteralEntry *globalPtr;     /* Points to the global LiteralEntry for  
                                   * the literal to add to the CompileEnv. */  
     int localHash;               /* Hash value for the literal's string. */  
 {  
     register LiteralTable *localTablePtr = &(envPtr->localLitTable);  
     LiteralEntry *localPtr;  
     int objIndex;  
       
     objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);  
   
     /*  
      * Add the literal to the local table.  
      */  
   
     localPtr->nextPtr = localTablePtr->buckets[localHash];  
     localTablePtr->buckets[localHash] = localPtr;  
     localTablePtr->numEntries++;  
   
     globalPtr->refCount++;  
   
     /*  
      * If the CompileEnv's local literal table has exceeded a decent size,  
      * rebuild it with more buckets.  
      */  
   
     if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {  
         RebuildLiteralTable(localTablePtr);  
     }  
   
 #ifdef TCL_COMPILE_DEBUG  
     TclVerifyLocalLiteralTable(envPtr);  
     {  
         char *bytes;  
         int length, found, i;  
         found = 0;  
         for (i = 0;  i < localTablePtr->numBuckets;  i++) {  
             for (localPtr = localTablePtr->buckets[i];  
                     localPtr != NULL;  localPtr = localPtr->nextPtr) {  
                 if (localPtr->objPtr == globalPtr->objPtr) {  
                     found = 1;  
                 }  
             }  
         }  
         if (!found) {  
             bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);  
             panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",  
                     (length>60? 60 : length), bytes);  
         }  
     }  
 #endif /*TCL_COMPILE_DEBUG*/  
     return objIndex;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * ExpandLocalLiteralArray --  
  *  
  *      Procedure that uses malloc to allocate more storage for a  
  *      CompileEnv's local literal array.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The literal array in *envPtr is reallocated to a new array of  
  *      double the size, and if envPtr->mallocedLiteralArray is non-zero  
  *      the old array is freed. Entries are copied from the old array  
  *      to the new one. The local literal table is updated to refer to  
  *      the new entries.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 ExpandLocalLiteralArray(envPtr)  
     register CompileEnv *envPtr; /* Points to the CompileEnv whose object  
                                   * array must be enlarged. */  
 {  
     /*  
      * The current allocated local literal entries are stored between  
      * elements 0 and (envPtr->literalArrayNext - 1) [inclusive].  
      */  
   
     LiteralTable *localTablePtr = &(envPtr->localLitTable);  
     int currElems = envPtr->literalArrayNext;  
     size_t currBytes = (currElems * sizeof(LiteralEntry));  
     register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;  
     register LiteralEntry *newArrayPtr =  
             (LiteralEntry *) ckalloc((unsigned) (2 * currBytes));  
     int i;  
       
     /*  
      * Copy from the old literal array to the new, then update the local  
      * literal table's bucket array.  
      */  
   
     memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);  
     for (i = 0;  i < currElems;  i++) {  
         if (currArrayPtr[i].nextPtr == NULL) {  
             newArrayPtr[i].nextPtr = NULL;  
         } else {  
             newArrayPtr[i].nextPtr = newArrayPtr  
                     + (currArrayPtr[i].nextPtr - currArrayPtr);  
         }  
     }  
     for (i = 0;  i < localTablePtr->numBuckets;  i++) {  
         if (localTablePtr->buckets[i] != NULL) {  
             localTablePtr->buckets[i] = newArrayPtr  
                     + (localTablePtr->buckets[i] - currArrayPtr);  
         }  
     }  
   
     /*  
      * Free the old literal array if needed, and mark the new literal  
      * array as malloced.  
      */  
       
     if (envPtr->mallocedLiteralArray) {  
         ckfree((char *) currArrayPtr);  
     }  
     envPtr->literalArrayPtr = newArrayPtr;  
     envPtr->literalArrayEnd = (2 * currElems);  
     envPtr->mallocedLiteralArray = 1;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclReleaseLiteral --  
  *  
  *      This procedure releases a reference to one of the shared Tcl objects  
  *      that hold literals. It is called to release the literals referenced  
  *      by a ByteCode that is being destroyed, and it is also called by  
  *      TclDeleteLiteralTable.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The reference count for the global LiteralTable entry that  
  *      corresponds to the literal is decremented. If no other reference  
  *      to a global literal object remains, it is freed.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclReleaseLiteral(interp, objPtr)  
     Tcl_Interp *interp;         /* Interpreter for which objPtr was created  
                                  * to hold a literal. */  
     register Tcl_Obj *objPtr;   /* Points to a literal object that was  
                                  * previously created by a call to  
                                  * TclRegisterLiteral. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     LiteralTable *globalTablePtr = &(iPtr->literalTable);  
     register LiteralEntry *entryPtr, *prevPtr;  
     ByteCode* codePtr;  
     char *bytes;  
     int length, index;  
   
     bytes = Tcl_GetStringFromObj(objPtr, &length);  
     index = (HashString(bytes, length) & globalTablePtr->mask);  
   
     /*  
      * Check to see if the object is in the global literal table and  
      * remove this reference.  The object may not be in the table if  
      * it is a hidden local literal.  
      */  
   
     for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];  
             entryPtr != NULL;  
             prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {  
         if (entryPtr->objPtr == objPtr) {  
             entryPtr->refCount--;  
   
             /*  
              * We found the matching LiteralEntry. Check if it's only being  
              * kept alive only by a circular reference from a ByteCode  
              * stored as its internal rep.  
              */  
               
             if ((entryPtr->refCount == 1)  
                     && (objPtr->typePtr == &tclByteCodeType)) {  
                 codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;  
                 if ((codePtr->numLitObjects == 1)  
                         && (codePtr->objArrayPtr[0] == objPtr)) {  
                     entryPtr->refCount = 0;  
   
                     /*  
                      * Set the ByteCode object array entry NULL to signal  
                      * to TclCleanupByteCode to not try to release this  
                      * about to be freed literal again.  
                      */  
   
                     codePtr->objArrayPtr[0] = NULL;  
                 }  
             }  
   
             /*  
              * If the literal is no longer being used by any ByteCode,  
              * delete the entry then decrement the ref count of its object.  
              */  
                   
             if (entryPtr->refCount == 0) {  
                 if (prevPtr == NULL) {  
                     globalTablePtr->buckets[index] = entryPtr->nextPtr;  
                 } else {  
                     prevPtr->nextPtr = entryPtr->nextPtr;  
                 }  
 #ifdef TCL_COMPILE_STATS  
                 iPtr->stats.currentLitStringBytes -= (double) (length + 1);  
 #endif /*TCL_COMPILE_STATS*/  
                 ckfree((char *) entryPtr);  
                 globalTablePtr->numEntries--;  
   
                 /*  
                  * Remove the reference corresponding to the global  
                  * literal table entry.  
                  */  
   
                 TclDecrRefCount(objPtr);  
             }  
             break;  
         }  
     }  
   
     /*  
      * Remove the reference corresponding to the local literal table  
      * entry.  
      */  
     Tcl_DecrRefCount(objPtr);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * HashString --  
  *  
  *      Compute a one-word summary of a text string, which can be  
  *      used to generate a hash index.  
  *  
  * Results:  
  *      The return value is a one-word summary of the information in  
  *      string.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static unsigned int  
 HashString(bytes, length)  
     register CONST char *bytes; /* String for which to compute hash  
                                  * value. */  
     int length;                 /* Number of bytes in the string. */  
 {  
     register unsigned int result;  
     register int i;  
   
     /*  
      * I tried a zillion different hash functions and asked many other  
      * people for advice.  Many people had their own favorite functions,  
      * all different, but no-one had much idea why they were good ones.  
      * I chose the one below (multiply by 9 and add new character)  
      * because of the following reasons:  
      *  
      * 1. Multiplying by 10 is perfect for keys that are decimal strings,  
      *    and multiplying by 9 is just about as good.  
      * 2. Times-9 is (shift-left-3) plus (old).  This means that each  
      *    character's bits hang around in the low-order bits of the  
      *    hash value for ever, plus they spread fairly rapidly up to  
      *    the high-order bits to fill out the hash value.  This seems  
      *    works well both for decimal and non-decimal strings.  
      */  
   
     result = 0;  
     for (i = 0;  i < length;  i++) {  
         result += (result<<3) + *bytes++;  
     }  
     return result;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * RebuildLiteralTable --  
  *  
  *      This procedure is invoked when the ratio of entries to hash buckets  
  *      becomes too large in a local or global literal table. It allocates  
  *      a larger bucket array and moves the entries into the new buckets.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Memory gets reallocated and entries get rehashed into new buckets.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 RebuildLiteralTable(tablePtr)  
     register LiteralTable *tablePtr; /* Local or global table to enlarge. */  
 {  
     LiteralEntry **oldBuckets;  
     register LiteralEntry **oldChainPtr, **newChainPtr;  
     register LiteralEntry *entryPtr;  
     LiteralEntry **bucketPtr;  
     char *bytes;  
     int oldSize, count, index, length;  
   
     oldSize = tablePtr->numBuckets;  
     oldBuckets = tablePtr->buckets;  
   
     /*  
      * Allocate and initialize the new bucket array, and set up  
      * hashing constants for new array size.  
      */  
   
     tablePtr->numBuckets *= 4;  
     tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)  
             (tablePtr->numBuckets * sizeof(LiteralEntry *)));  
     for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;  
             count > 0;  
             count--, newChainPtr++) {  
         *newChainPtr = NULL;  
     }  
     tablePtr->rebuildSize *= 4;  
     tablePtr->mask = (tablePtr->mask << 2) + 3;  
   
     /*  
      * Rehash all of the existing entries into the new bucket array.  
      */  
   
     for (oldChainPtr = oldBuckets;  
             oldSize > 0;  
             oldSize--, oldChainPtr++) {  
         for (entryPtr = *oldChainPtr;  entryPtr != NULL;  
                 entryPtr = *oldChainPtr) {  
             bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);  
             index = (HashString(bytes, length) & tablePtr->mask);  
               
             *oldChainPtr = entryPtr->nextPtr;  
             bucketPtr = &(tablePtr->buckets[index]);  
             entryPtr->nextPtr = *bucketPtr;  
             *bucketPtr = entryPtr;  
         }  
     }  
   
     /*  
      * Free up the old bucket array, if it was dynamically allocated.  
      */  
   
     if (oldBuckets != tablePtr->staticBuckets) {  
         ckfree((char *) oldBuckets);  
     }  
 }  
   
 #ifdef TCL_COMPILE_STATS  
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclLiteralStats --  
  *  
  *      Return statistics describing the layout of the hash table  
  *      in its hash buckets.  
  *  
  * Results:  
  *      The return value is a malloc-ed string containing information  
  *      about tablePtr.  It is the caller's responsibility to free  
  *      this string.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 char *  
 TclLiteralStats(tablePtr)  
     LiteralTable *tablePtr;     /* Table for which to produce stats. */  
 {  
 #define NUM_COUNTERS 10  
     int count[NUM_COUNTERS], overflow, i, j;  
     double average, tmp;  
     register LiteralEntry *entryPtr;  
     char *result, *p;  
   
     /*  
      * Compute a histogram of bucket usage. For each bucket chain i,  
      * j is the number of entries in the chain.  
      */  
   
     for (i = 0;  i < NUM_COUNTERS;  i++) {  
         count[i] = 0;  
     }  
     overflow = 0;  
     average = 0.0;  
     for (i = 0;  i < tablePtr->numBuckets;  i++) {  
         j = 0;  
         for (entryPtr = tablePtr->buckets[i];  entryPtr != NULL;  
                 entryPtr = entryPtr->nextPtr) {  
             j++;  
         }  
         if (j < NUM_COUNTERS) {  
             count[j]++;  
         } else {  
             overflow++;  
         }  
         tmp = j;  
         average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;  
     }  
   
     /*  
      * Print out the histogram and a few other pieces of information.  
      */  
   
     result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));  
     sprintf(result, "%d entries in table, %d buckets\n",  
             tablePtr->numEntries, tablePtr->numBuckets);  
     p = result + strlen(result);  
     for (i = 0; i < NUM_COUNTERS; i++) {  
         sprintf(p, "number of buckets with %d entries: %d\n",  
                 i, count[i]);  
         p += strlen(p);  
     }  
     sprintf(p, "number of buckets with %d or more entries: %d\n",  
             NUM_COUNTERS, overflow);  
     p += strlen(p);  
     sprintf(p, "average search distance for entry: %.1f", average);  
     return result;  
 }  
 #endif /*TCL_COMPILE_STATS*/  
   
 #ifdef TCL_COMPILE_DEBUG  
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclVerifyLocalLiteralTable --  
  *  
  *      Check a CompileEnv's local literal table for consistency.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Panics if problems are found.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclVerifyLocalLiteralTable(envPtr)  
     CompileEnv *envPtr;         /* Points to CompileEnv whose literal  
                                  * table is to be validated. */  
 {  
     register LiteralTable *localTablePtr = &(envPtr->localLitTable);  
     register LiteralEntry *localPtr;  
     char *bytes;  
     register int i;  
     int length, count;  
   
     count = 0;  
     for (i = 0;  i < localTablePtr->numBuckets;  i++) {  
         for (localPtr = localTablePtr->buckets[i];  
                 localPtr != NULL;  localPtr = localPtr->nextPtr) {  
             count++;  
             if (localPtr->refCount != -1) {  
                 bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);  
                 panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",  
                         (length>60? 60 : length), bytes,  
                         localPtr->refCount);  
             }  
             if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,  
                     localPtr->objPtr) == NULL) {  
                 bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);  
                 panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",  
                          (length>60? 60 : length), bytes);  
             }  
             if (localPtr->objPtr->bytes == NULL) {  
                 panic("TclVerifyLocalLiteralTable: literal has NULL string rep");  
             }  
         }  
     }  
     if (count != localTablePtr->numEntries) {  
         panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",  
               count, localTablePtr->numEntries);  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclVerifyGlobalLiteralTable --  
  *  
  *      Check an interpreter's global literal table literal for consistency.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Panics if problems are found.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclVerifyGlobalLiteralTable(iPtr)  
     Interp *iPtr;               /* Points to interpreter whose global  
                                  * literal table is to be validated. */  
 {  
     register LiteralTable *globalTablePtr = &(iPtr->literalTable);  
     register LiteralEntry *globalPtr;  
     char *bytes;  
     register int i;  
     int length, count;  
   
     count = 0;  
     for (i = 0;  i < globalTablePtr->numBuckets;  i++) {  
         for (globalPtr = globalTablePtr->buckets[i];  
                 globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {  
             count++;  
             if (globalPtr->refCount < 1) {  
                 bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);  
                 panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",  
                         (length>60? 60 : length), bytes,  
                         globalPtr->refCount);  
             }  
             if (globalPtr->objPtr->bytes == NULL) {  
                 panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");  
             }  
         }  
     }  
     if (count != globalTablePtr->numEntries) {  
         panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",  
               count, globalTablePtr->numEntries);  
     }  
 }  
 #endif /*TCL_COMPILE_DEBUG*/  
   
   
 /* $History: tclliteral.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:32a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLLITERAL.C */  
1    /* $Header$ */
2    /*
3     * tclLiteral.c --
4     *
5     *      Implementation of the global and ByteCode-local literal tables
6     *      used to manage the Tcl objects created for literal values during
7     *      compilation of Tcl scripts. This implementation borrows heavily
8     *      from the more general hashtable implementation of Tcl hash tables
9     *      that appears in tclHash.c.
10     *
11     * Copyright (c) 1997-1998 Sun Microsystems, Inc.
12     *
13     * See the file "license.terms" for information on usage and redistribution
14     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15     *
16     * RCS: @(#) $Id: tclliteral.c,v 1.1.1.1 2001/06/13 04:42:47 dtashley Exp $
17     */
18    
19    #include "tclInt.h"
20    #include "tclCompile.h"
21    #include "tclPort.h"
22    /*
23     * When there are this many entries per bucket, on average, rebuild
24     * a literal's hash table to make it larger.
25     */
26    
27    #define REBUILD_MULTIPLIER      3
28    
29    /*
30     * Procedure prototypes for static procedures in this file:
31     */
32    
33    static int              AddLocalLiteralEntry _ANSI_ARGS_((
34                                CompileEnv *envPtr, LiteralEntry *globalPtr,
35                                int localHash));
36    static void             ExpandLocalLiteralArray _ANSI_ARGS_((
37                                CompileEnv *envPtr));
38    static unsigned int     HashString _ANSI_ARGS_((CONST char *bytes,
39                                int length));
40    static void             RebuildLiteralTable _ANSI_ARGS_((
41                                LiteralTable *tablePtr));
42    
43    /*
44     *----------------------------------------------------------------------
45     *
46     * TclInitLiteralTable --
47     *
48     *      This procedure is called to initialize the fields of a literal table
49     *      structure for either an interpreter or a compilation's CompileEnv
50     *      structure.
51     *
52     * Results:
53     *      None.
54     *
55     * Side effects:
56     *      The literal table is made ready for use.
57     *
58     *----------------------------------------------------------------------
59     */
60    
61    void
62    TclInitLiteralTable(tablePtr)
63        register LiteralTable *tablePtr; /* Pointer to table structure, which
64                                          * is supplied by the caller. */
65    {
66    #if (TCL_SMALL_HASH_TABLE != 4)
67        panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
68                TCL_SMALL_HASH_TABLE);
69    #endif
70        
71        tablePtr->buckets = tablePtr->staticBuckets;
72        tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
73        tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
74        tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
75        tablePtr->numEntries = 0;
76        tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
77        tablePtr->mask = 3;
78    }
79    
80    /*
81     *----------------------------------------------------------------------
82     *
83     * TclDeleteLiteralTable --
84     *
85     *      This procedure frees up everything associated with a literal table
86     *      except for the table's structure itself.
87     *
88     * Results:
89     *      None.
90     *
91     * Side effects:
92     *      Each literal in the table is released: i.e., its reference count
93     *      in the global literal table is decremented and, if it becomes zero,
94     *      the literal is freed. In addition, the table's bucket array is
95     *      freed.
96     *
97     *----------------------------------------------------------------------
98     */
99    
100    void
101    TclDeleteLiteralTable(interp, tablePtr)
102        Tcl_Interp *interp;         /* Interpreter containing shared literals
103                                     * referenced by the table to delete. */
104        LiteralTable *tablePtr;     /* Points to the literal table to delete. */
105    {
106        LiteralEntry *entryPtr;
107        int i, start;
108    
109        /*
110         * Release remaining literals in the table. Note that releasing a
111         * literal might release other literals, modifying the table, so we
112         * restart the search from the bucket chain we last found an entry.
113         */
114    
115    #ifdef TCL_COMPILE_DEBUG
116        TclVerifyGlobalLiteralTable((Interp *) interp);
117    #endif /*TCL_COMPILE_DEBUG*/
118    
119        start = 0;
120        while (tablePtr->numEntries > 0) {
121            for (i = start;  i < tablePtr->numBuckets;  i++) {
122                entryPtr = tablePtr->buckets[i];
123                if (entryPtr != NULL) {
124                    TclReleaseLiteral(interp, entryPtr->objPtr);
125                    start = i;
126                    break;
127                }
128            }
129        }
130    
131        /*
132         * Free up the table's bucket array if it was dynamically allocated.
133         */
134    
135        if (tablePtr->buckets != tablePtr->staticBuckets) {
136            ckfree((char *) tablePtr->buckets);
137        }
138    }
139    
140    /*
141     *----------------------------------------------------------------------
142     *
143     * TclRegisterLiteral --
144     *
145     *      Find, or if necessary create, an object in a CompileEnv literal
146     *      array that has a string representation matching the argument string.
147     *
148     * Results:
149     *      The index in the CompileEnv's literal array that references a
150     *      shared literal matching the string. The object is created if
151     *      necessary.
152     *
153     * Side effects:
154     *      To maximize sharing, we look up the string in the interpreter's
155     *      global literal table. If not found, we create a new shared literal
156     *      in the global table. We then add a reference to the shared
157     *      literal in the CompileEnv's literal array.
158     *
159     *      If onHeap is 1, this procedure is given ownership of the string: if
160     *      an object is created then its string representation is set directly
161     *      from string, otherwise the string is freed. Typically, a caller sets
162     *      onHeap 1 if "string" is an already heap-allocated buffer holding the
163     *      result of backslash substitutions.
164     *
165     *----------------------------------------------------------------------
166     */
167    
168    int
169    TclRegisterLiteral(envPtr, bytes, length, onHeap)
170        CompileEnv *envPtr;         /* Points to the CompileEnv in whose object
171                                     * array an object is found or created. */
172        register char *bytes;       /* Points to string for which to find or
173                                     * create an object in CompileEnv's object
174                                     * array. */
175        int length;                 /* Number of bytes in the string. If < 0,
176                                     * the string consists of all bytes up to
177                                     * the first null character. */
178        int onHeap;                 /* If 1 then the caller already malloc'd
179                                     * bytes and ownership is passed to this
180                                     * procedure. */
181    {
182        Interp *iPtr = envPtr->iPtr;
183        LiteralTable *globalTablePtr = &(iPtr->literalTable);
184        LiteralTable *localTablePtr = &(envPtr->localLitTable);
185        register LiteralEntry *globalPtr, *localPtr;
186        register Tcl_Obj *objPtr;
187        unsigned int hash;
188        int localHash, globalHash, objIndex;
189        long n;
190        char buf[TCL_INTEGER_SPACE];
191    
192        if (length < 0) {
193            length = (bytes? strlen(bytes) : 0);
194        }
195        hash = HashString(bytes, length);
196    
197        /*
198         * Is the literal already in the CompileEnv's local literal array?
199         * If so, just return its index.
200         */
201    
202        localHash = (hash & localTablePtr->mask);
203        for (localPtr = localTablePtr->buckets[localHash];
204              localPtr != NULL;  localPtr = localPtr->nextPtr) {
205            objPtr = localPtr->objPtr;
206            if ((objPtr->length == length) && ((length == 0)
207                    || ((objPtr->bytes[0] == bytes[0])
208                            && (memcmp(objPtr->bytes, bytes, (unsigned) length)
209                                    == 0)))) {
210                if (onHeap) {
211                    ckfree(bytes);
212                }
213                objIndex = (localPtr - envPtr->literalArrayPtr);
214    #ifdef TCL_COMPILE_DEBUG
215                TclVerifyLocalLiteralTable(envPtr);
216    #endif /*TCL_COMPILE_DEBUG*/
217    
218                return objIndex;
219            }
220        }
221    
222        /*
223         * The literal is new to this CompileEnv. Is it in the interpreter's
224         * global literal table?
225         */
226    
227        globalHash = (hash & globalTablePtr->mask);
228        for (globalPtr = globalTablePtr->buckets[globalHash];
229             globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
230            objPtr = globalPtr->objPtr;
231            if ((objPtr->length == length) && ((length == 0)
232                    || ((objPtr->bytes[0] == bytes[0])
233                            && (memcmp(objPtr->bytes, bytes, (unsigned) length)
234                                    == 0)))) {
235                /*
236                 * A global literal was found. Add an entry to the CompileEnv's
237                 * local literal array.
238                 */
239                
240                if (onHeap) {
241                    ckfree(bytes);
242                }
243                objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
244    #ifdef TCL_COMPILE_DEBUG
245                if (globalPtr->refCount < 1) {
246                    panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
247                            (length>60? 60 : length), bytes,
248                            globalPtr->refCount);
249                }
250                TclVerifyLocalLiteralTable(envPtr);
251    #endif /*TCL_COMPILE_DEBUG*/
252                return objIndex;
253            }
254        }
255    
256        /*
257         * The literal is new to the interpreter. Add it to the global literal
258         * table then add an entry to the CompileEnv's local literal array.
259         * Convert the object to an integer object if possible.
260         */
261    
262        TclNewObj(objPtr);
263        Tcl_IncrRefCount(objPtr);
264        if (onHeap) {
265            objPtr->bytes = bytes;
266            objPtr->length = length;
267        } else {
268            TclInitStringRep(objPtr, bytes, length);
269        }
270    
271        if (TclLooksLikeInt(bytes, length)) {
272            /*
273             * From here we use the objPtr, because it is NULL terminated
274             */
275            if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
276                TclFormatInt(buf, n);
277                if (strcmp(objPtr->bytes, buf) == 0) {
278                    objPtr->internalRep.longValue = n;
279                    objPtr->typePtr = &tclIntType;
280                }
281            }
282        }
283        
284    #ifdef TCL_COMPILE_DEBUG
285        if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
286            panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
287                    (length>60? 60 : length), bytes);
288        }
289    #endif
290    
291        globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
292        globalPtr->objPtr = objPtr;
293        globalPtr->refCount = 0;
294        globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
295        globalTablePtr->buckets[globalHash] = globalPtr;
296        globalTablePtr->numEntries++;
297    
298        /*
299         * If the global literal table has exceeded a decent size, rebuild it
300         * with more buckets.
301         */
302    
303        if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
304            RebuildLiteralTable(globalTablePtr);
305        }
306        objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
307    
308    #ifdef TCL_COMPILE_DEBUG
309        TclVerifyGlobalLiteralTable(iPtr);
310        TclVerifyLocalLiteralTable(envPtr);
311        {
312            LiteralEntry *entryPtr;
313            int found, i;
314            found = 0;
315            for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
316                for (entryPtr = globalTablePtr->buckets[i];
317                        entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
318                    if ((entryPtr == globalPtr)
319                            && (entryPtr->objPtr == objPtr)) {
320                        found = 1;
321                    }
322                }
323            }
324            if (!found) {
325                panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
326                        (length>60? 60 : length), bytes);
327            }
328        }
329    #endif /*TCL_COMPILE_DEBUG*/
330    #ifdef TCL_COMPILE_STATS  
331        iPtr->stats.numLiteralsCreated++;
332        iPtr->stats.totalLitStringBytes   += (double) (length + 1);
333        iPtr->stats.currentLitStringBytes += (double) (length + 1);
334        iPtr->stats.literalCount[TclLog2(length)]++;
335    #endif /*TCL_COMPILE_STATS*/
336        return objIndex;
337    }
338    
339    /*
340     *----------------------------------------------------------------------
341     *
342     * TclLookupLiteralEntry --
343     *
344     *      Finds the LiteralEntry that corresponds to a literal Tcl object
345     *      holding a literal.
346     *
347     * Results:
348     *      Returns the matching LiteralEntry if found, otherwise NULL.
349     *
350     * Side effects:
351     *      None.
352     *
353     *----------------------------------------------------------------------
354     */
355    
356    LiteralEntry *
357    TclLookupLiteralEntry(interp, objPtr)
358        Tcl_Interp *interp;         /* Interpreter for which objPtr was created
359                                     * to hold a literal. */
360        register Tcl_Obj *objPtr;   /* Points to a Tcl object holding a
361                                     * literal that was previously created by a
362                                     * call to TclRegisterLiteral. */
363    {
364        Interp *iPtr = (Interp *) interp;
365        LiteralTable *globalTablePtr = &(iPtr->literalTable);
366        register LiteralEntry *entryPtr;
367        char *bytes;
368        int length, globalHash;
369    
370        bytes = Tcl_GetStringFromObj(objPtr, &length);
371        globalHash = (HashString(bytes, length) & globalTablePtr->mask);
372        for (entryPtr = globalTablePtr->buckets[globalHash];
373                entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
374            if (entryPtr->objPtr == objPtr) {
375                return entryPtr;
376            }
377        }
378        return NULL;
379    }
380    
381    /*
382     *----------------------------------------------------------------------
383     *
384     * TclHideLiteral --
385     *
386     *      Remove a literal entry from the literal hash tables, leaving it in
387     *      the literal array so existing references continue to function.
388     *      This makes it possible to turn a shared literal into a private
389     *      literal that cannot be shared.
390     *
391     * Results:
392     *      None.
393     *
394     * Side effects:
395     *      Removes the literal from the local hash table and decrements the
396     *      global hash entry's reference count.
397     *
398     *----------------------------------------------------------------------
399     */
400    
401    void
402    TclHideLiteral(interp, envPtr, index)
403        Tcl_Interp *interp;          /* Interpreter for which objPtr was created
404                                      * to hold a literal. */
405        register CompileEnv *envPtr; /* Points to CompileEnv whose literal array
406                                      * contains the entry being hidden. */
407        int index;                   /* The index of the entry in the literal
408                                      * array. */
409    {
410        LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
411        LiteralTable *localTablePtr = &(envPtr->localLitTable);
412        int localHash, length;
413        char *bytes;
414        Tcl_Obj *newObjPtr;
415    
416        lPtr = &(envPtr->literalArrayPtr[index]);
417    
418        /*
419         * To avoid unwanted sharing we need to copy the object and remove it from
420         * the local and global literal tables.  It still has a slot in the literal
421         * array so it can be referred to by byte codes, but it will not be matched
422         * by literal searches.
423         */
424    
425        newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
426        Tcl_IncrRefCount(newObjPtr);
427        TclReleaseLiteral(interp, lPtr->objPtr);
428        lPtr->objPtr = newObjPtr;
429    
430        bytes = Tcl_GetStringFromObj(newObjPtr, &length);
431        localHash = (HashString(bytes, length) & localTablePtr->mask);
432        nextPtrPtr = &localTablePtr->buckets[localHash];
433    
434        for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) {
435            if (entryPtr == lPtr) {
436                *nextPtrPtr = lPtr->nextPtr;
437                lPtr->nextPtr = NULL;
438                localTablePtr->numEntries--;
439                break;
440            }
441            nextPtrPtr = &entryPtr->nextPtr;
442        }
443    }
444    
445    /*
446     *----------------------------------------------------------------------
447     *
448     * TclAddLiteralObj --
449     *
450     *      Add a single literal object to the literal array.  This
451     *      function does not add the literal to the local or global
452     *      literal tables.  The caller is expected to add the entry
453     *      to whatever tables are appropriate.
454     *
455     * Results:
456     *      The index in the CompileEnv's literal array that references the
457     *      literal.  Stores the pointer to the new literal entry in the
458     *      location referenced by the localPtrPtr argument.
459     *
460     * Side effects:
461     *      Expands the literal array if necessary.  Increments the refcount
462     *      on the literal object.
463     *
464     *----------------------------------------------------------------------
465     */
466    
467    int
468    TclAddLiteralObj(envPtr, objPtr, litPtrPtr)
469        register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
470                                      * array the object is to be inserted. */
471        Tcl_Obj *objPtr;             /* The object to insert into the array. */
472        LiteralEntry **litPtrPtr;    /* The location where the pointer to the
473                                      * new literal entry should be stored.
474                                      * May be NULL. */
475    {
476        register LiteralEntry *lPtr;
477        int objIndex;
478    
479        if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
480            ExpandLocalLiteralArray(envPtr);
481        }
482        objIndex = envPtr->literalArrayNext;
483        envPtr->literalArrayNext++;
484    
485        lPtr = &(envPtr->literalArrayPtr[objIndex]);
486        lPtr->objPtr = objPtr;
487        Tcl_IncrRefCount(objPtr);
488        lPtr->refCount = -1;        /* i.e., unused */
489        lPtr->nextPtr = NULL;
490    
491        if (litPtrPtr) {
492            *litPtrPtr = lPtr;
493        }
494    
495        return objIndex;
496    }
497    
498    /*
499     *----------------------------------------------------------------------
500     *
501     * AddLocalLiteralEntry --
502     *
503     *      Insert a new literal into a CompileEnv's local literal array.
504     *
505     * Results:
506     *      The index in the CompileEnv's literal array that references the
507     *      literal.
508     *
509     * Side effects:
510     *      Increments the ref count of the global LiteralEntry since the
511     *      CompileEnv now refers to the literal. Expands the literal array
512     *      if necessary. May rebuild the hash bucket array of the CompileEnv's
513     *      literal array if it becomes too large.
514     *
515     *----------------------------------------------------------------------
516     */
517    
518    static int
519    AddLocalLiteralEntry(envPtr, globalPtr, localHash)
520        register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
521                                      * array the object is to be inserted. */
522        LiteralEntry *globalPtr;     /* Points to the global LiteralEntry for
523                                      * the literal to add to the CompileEnv. */
524        int localHash;               /* Hash value for the literal's string. */
525    {
526        register LiteralTable *localTablePtr = &(envPtr->localLitTable);
527        LiteralEntry *localPtr;
528        int objIndex;
529        
530        objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);
531    
532        /*
533         * Add the literal to the local table.
534         */
535    
536        localPtr->nextPtr = localTablePtr->buckets[localHash];
537        localTablePtr->buckets[localHash] = localPtr;
538        localTablePtr->numEntries++;
539    
540        globalPtr->refCount++;
541    
542        /*
543         * If the CompileEnv's local literal table has exceeded a decent size,
544         * rebuild it with more buckets.
545         */
546    
547        if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
548            RebuildLiteralTable(localTablePtr);
549        }
550    
551    #ifdef TCL_COMPILE_DEBUG
552        TclVerifyLocalLiteralTable(envPtr);
553        {
554            char *bytes;
555            int length, found, i;
556            found = 0;
557            for (i = 0;  i < localTablePtr->numBuckets;  i++) {
558                for (localPtr = localTablePtr->buckets[i];
559                        localPtr != NULL;  localPtr = localPtr->nextPtr) {
560                    if (localPtr->objPtr == globalPtr->objPtr) {
561                        found = 1;
562                    }
563                }
564            }
565            if (!found) {
566                bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
567                panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
568                        (length>60? 60 : length), bytes);
569            }
570        }
571    #endif /*TCL_COMPILE_DEBUG*/
572        return objIndex;
573    }
574    
575    /*
576     *----------------------------------------------------------------------
577     *
578     * ExpandLocalLiteralArray --
579     *
580     *      Procedure that uses malloc to allocate more storage for a
581     *      CompileEnv's local literal array.
582     *
583     * Results:
584     *      None.
585     *
586     * Side effects:
587     *      The literal array in *envPtr is reallocated to a new array of
588     *      double the size, and if envPtr->mallocedLiteralArray is non-zero
589     *      the old array is freed. Entries are copied from the old array
590     *      to the new one. The local literal table is updated to refer to
591     *      the new entries.
592     *
593     *----------------------------------------------------------------------
594     */
595    
596    static void
597    ExpandLocalLiteralArray(envPtr)
598        register CompileEnv *envPtr; /* Points to the CompileEnv whose object
599                                      * array must be enlarged. */
600    {
601        /*
602         * The current allocated local literal entries are stored between
603         * elements 0 and (envPtr->literalArrayNext - 1) [inclusive].
604         */
605    
606        LiteralTable *localTablePtr = &(envPtr->localLitTable);
607        int currElems = envPtr->literalArrayNext;
608        size_t currBytes = (currElems * sizeof(LiteralEntry));
609        register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
610        register LiteralEntry *newArrayPtr =
611                (LiteralEntry *) ckalloc((unsigned) (2 * currBytes));
612        int i;
613        
614        /*
615         * Copy from the old literal array to the new, then update the local
616         * literal table's bucket array.
617         */
618    
619        memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);
620        for (i = 0;  i < currElems;  i++) {
621            if (currArrayPtr[i].nextPtr == NULL) {
622                newArrayPtr[i].nextPtr = NULL;
623            } else {
624                newArrayPtr[i].nextPtr = newArrayPtr
625                        + (currArrayPtr[i].nextPtr - currArrayPtr);
626            }
627        }
628        for (i = 0;  i < localTablePtr->numBuckets;  i++) {
629            if (localTablePtr->buckets[i] != NULL) {
630                localTablePtr->buckets[i] = newArrayPtr
631                        + (localTablePtr->buckets[i] - currArrayPtr);
632            }
633        }
634    
635        /*
636         * Free the old literal array if needed, and mark the new literal
637         * array as malloced.
638         */
639        
640        if (envPtr->mallocedLiteralArray) {
641            ckfree((char *) currArrayPtr);
642        }
643        envPtr->literalArrayPtr = newArrayPtr;
644        envPtr->literalArrayEnd = (2 * currElems);
645        envPtr->mallocedLiteralArray = 1;
646    }
647    
648    /*
649     *----------------------------------------------------------------------
650     *
651     * TclReleaseLiteral --
652     *
653     *      This procedure releases a reference to one of the shared Tcl objects
654     *      that hold literals. It is called to release the literals referenced
655     *      by a ByteCode that is being destroyed, and it is also called by
656     *      TclDeleteLiteralTable.
657     *
658     * Results:
659     *      None.
660     *
661     * Side effects:
662     *      The reference count for the global LiteralTable entry that
663     *      corresponds to the literal is decremented. If no other reference
664     *      to a global literal object remains, it is freed.
665     *
666     *----------------------------------------------------------------------
667     */
668    
669    void
670    TclReleaseLiteral(interp, objPtr)
671        Tcl_Interp *interp;         /* Interpreter for which objPtr was created
672                                     * to hold a literal. */
673        register Tcl_Obj *objPtr;   /* Points to a literal object that was
674                                     * previously created by a call to
675                                     * TclRegisterLiteral. */
676    {
677        Interp *iPtr = (Interp *) interp;
678        LiteralTable *globalTablePtr = &(iPtr->literalTable);
679        register LiteralEntry *entryPtr, *prevPtr;
680        ByteCode* codePtr;
681        char *bytes;
682        int length, index;
683    
684        bytes = Tcl_GetStringFromObj(objPtr, &length);
685        index = (HashString(bytes, length) & globalTablePtr->mask);
686    
687        /*
688         * Check to see if the object is in the global literal table and
689         * remove this reference.  The object may not be in the table if
690         * it is a hidden local literal.
691         */
692    
693        for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];
694                entryPtr != NULL;
695                prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {
696            if (entryPtr->objPtr == objPtr) {
697                entryPtr->refCount--;
698    
699                /*
700                 * We found the matching LiteralEntry. Check if it's only being
701                 * kept alive only by a circular reference from a ByteCode
702                 * stored as its internal rep.
703                 */
704                
705                if ((entryPtr->refCount == 1)
706                        && (objPtr->typePtr == &tclByteCodeType)) {
707                    codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
708                    if ((codePtr->numLitObjects == 1)
709                            && (codePtr->objArrayPtr[0] == objPtr)) {
710                        entryPtr->refCount = 0;
711    
712                        /*
713                         * Set the ByteCode object array entry NULL to signal
714                         * to TclCleanupByteCode to not try to release this
715                         * about to be freed literal again.
716                         */
717    
718                        codePtr->objArrayPtr[0] = NULL;
719                    }
720                }
721    
722                /*
723                 * If the literal is no longer being used by any ByteCode,
724                 * delete the entry then decrement the ref count of its object.
725                 */
726                    
727                if (entryPtr->refCount == 0) {
728                    if (prevPtr == NULL) {
729                        globalTablePtr->buckets[index] = entryPtr->nextPtr;
730                    } else {
731                        prevPtr->nextPtr = entryPtr->nextPtr;
732                    }
733    #ifdef TCL_COMPILE_STATS
734                    iPtr->stats.currentLitStringBytes -= (double) (length + 1);
735    #endif /*TCL_COMPILE_STATS*/
736                    ckfree((char *) entryPtr);
737                    globalTablePtr->numEntries--;
738    
739                    /*
740                     * Remove the reference corresponding to the global
741                     * literal table entry.
742                     */
743    
744                    TclDecrRefCount(objPtr);
745                }
746                break;
747            }
748        }
749    
750        /*
751         * Remove the reference corresponding to the local literal table
752         * entry.
753         */
754        Tcl_DecrRefCount(objPtr);
755    }
756    
757    /*
758     *----------------------------------------------------------------------
759     *
760     * HashString --
761     *
762     *      Compute a one-word summary of a text string, which can be
763     *      used to generate a hash index.
764     *
765     * Results:
766     *      The return value is a one-word summary of the information in
767     *      string.
768     *
769     * Side effects:
770     *      None.
771     *
772     *----------------------------------------------------------------------
773     */
774    
775    static unsigned int
776    HashString(bytes, length)
777        register CONST char *bytes; /* String for which to compute hash
778                                     * value. */
779        int length;                 /* Number of bytes in the string. */
780    {
781        register unsigned int result;
782        register int i;
783    
784        /*
785         * I tried a zillion different hash functions and asked many other
786         * people for advice.  Many people had their own favorite functions,
787         * all different, but no-one had much idea why they were good ones.
788         * I chose the one below (multiply by 9 and add new character)
789         * because of the following reasons:
790         *
791         * 1. Multiplying by 10 is perfect for keys that are decimal strings,
792         *    and multiplying by 9 is just about as good.
793         * 2. Times-9 is (shift-left-3) plus (old).  This means that each
794         *    character's bits hang around in the low-order bits of the
795         *    hash value for ever, plus they spread fairly rapidly up to
796         *    the high-order bits to fill out the hash value.  This seems
797         *    works well both for decimal and non-decimal strings.
798         */
799    
800        result = 0;
801        for (i = 0;  i < length;  i++) {
802            result += (result<<3) + *bytes++;
803        }
804        return result;
805    }
806    
807    /*
808     *----------------------------------------------------------------------
809     *
810     * RebuildLiteralTable --
811     *
812     *      This procedure is invoked when the ratio of entries to hash buckets
813     *      becomes too large in a local or global literal table. It allocates
814     *      a larger bucket array and moves the entries into the new buckets.
815     *
816     * Results:
817     *      None.
818     *
819     * Side effects:
820     *      Memory gets reallocated and entries get rehashed into new buckets.
821     *
822     *----------------------------------------------------------------------
823     */
824    
825    static void
826    RebuildLiteralTable(tablePtr)
827        register LiteralTable *tablePtr; /* Local or global table to enlarge. */
828    {
829        LiteralEntry **oldBuckets;
830        register LiteralEntry **oldChainPtr, **newChainPtr;
831        register LiteralEntry *entryPtr;
832        LiteralEntry **bucketPtr;
833        char *bytes;
834        int oldSize, count, index, length;
835    
836        oldSize = tablePtr->numBuckets;
837        oldBuckets = tablePtr->buckets;
838    
839        /*
840         * Allocate and initialize the new bucket array, and set up
841         * hashing constants for new array size.
842         */
843    
844        tablePtr->numBuckets *= 4;
845        tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
846                (tablePtr->numBuckets * sizeof(LiteralEntry *)));
847        for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
848                count > 0;
849                count--, newChainPtr++) {
850            *newChainPtr = NULL;
851        }
852        tablePtr->rebuildSize *= 4;
853        tablePtr->mask = (tablePtr->mask << 2) + 3;
854    
855        /*
856         * Rehash all of the existing entries into the new bucket array.
857         */
858    
859        for (oldChainPtr = oldBuckets;
860                oldSize > 0;
861                oldSize--, oldChainPtr++) {
862            for (entryPtr = *oldChainPtr;  entryPtr != NULL;
863                    entryPtr = *oldChainPtr) {
864                bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
865                index = (HashString(bytes, length) & tablePtr->mask);
866                
867                *oldChainPtr = entryPtr->nextPtr;
868                bucketPtr = &(tablePtr->buckets[index]);
869                entryPtr->nextPtr = *bucketPtr;
870                *bucketPtr = entryPtr;
871            }
872        }
873    
874        /*
875         * Free up the old bucket array, if it was dynamically allocated.
876         */
877    
878        if (oldBuckets != tablePtr->staticBuckets) {
879            ckfree((char *) oldBuckets);
880        }
881    }
882    
883    #ifdef TCL_COMPILE_STATS
884    /*
885     *----------------------------------------------------------------------
886     *
887     * TclLiteralStats --
888     *
889     *      Return statistics describing the layout of the hash table
890     *      in its hash buckets.
891     *
892     * Results:
893     *      The return value is a malloc-ed string containing information
894     *      about tablePtr.  It is the caller's responsibility to free
895     *      this string.
896     *
897     * Side effects:
898     *      None.
899     *
900     *----------------------------------------------------------------------
901     */
902    
903    char *
904    TclLiteralStats(tablePtr)
905        LiteralTable *tablePtr;     /* Table for which to produce stats. */
906    {
907    #define NUM_COUNTERS 10
908        int count[NUM_COUNTERS], overflow, i, j;
909        double average, tmp;
910        register LiteralEntry *entryPtr;
911        char *result, *p;
912    
913        /*
914         * Compute a histogram of bucket usage. For each bucket chain i,
915         * j is the number of entries in the chain.
916         */
917    
918        for (i = 0;  i < NUM_COUNTERS;  i++) {
919            count[i] = 0;
920        }
921        overflow = 0;
922        average = 0.0;
923        for (i = 0;  i < tablePtr->numBuckets;  i++) {
924            j = 0;
925            for (entryPtr = tablePtr->buckets[i];  entryPtr != NULL;
926                    entryPtr = entryPtr->nextPtr) {
927                j++;
928            }
929            if (j < NUM_COUNTERS) {
930                count[j]++;
931            } else {
932                overflow++;
933            }
934            tmp = j;
935            average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
936        }
937    
938        /*
939         * Print out the histogram and a few other pieces of information.
940         */
941    
942        result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
943        sprintf(result, "%d entries in table, %d buckets\n",
944                tablePtr->numEntries, tablePtr->numBuckets);
945        p = result + strlen(result);
946        for (i = 0; i < NUM_COUNTERS; i++) {
947            sprintf(p, "number of buckets with %d entries: %d\n",
948                    i, count[i]);
949            p += strlen(p);
950        }
951        sprintf(p, "number of buckets with %d or more entries: %d\n",
952                NUM_COUNTERS, overflow);
953        p += strlen(p);
954        sprintf(p, "average search distance for entry: %.1f", average);
955        return result;
956    }
957    #endif /*TCL_COMPILE_STATS*/
958    
959    #ifdef TCL_COMPILE_DEBUG
960    /*
961     *----------------------------------------------------------------------
962     *
963     * TclVerifyLocalLiteralTable --
964     *
965     *      Check a CompileEnv's local literal table for consistency.
966     *
967     * Results:
968     *      None.
969     *
970     * Side effects:
971     *      Panics if problems are found.
972     *
973     *----------------------------------------------------------------------
974     */
975    
976    void
977    TclVerifyLocalLiteralTable(envPtr)
978        CompileEnv *envPtr;         /* Points to CompileEnv whose literal
979                                     * table is to be validated. */
980    {
981        register LiteralTable *localTablePtr = &(envPtr->localLitTable);
982        register LiteralEntry *localPtr;
983        char *bytes;
984        register int i;
985        int length, count;
986    
987        count = 0;
988        for (i = 0;  i < localTablePtr->numBuckets;  i++) {
989            for (localPtr = localTablePtr->buckets[i];
990                    localPtr != NULL;  localPtr = localPtr->nextPtr) {
991                count++;
992                if (localPtr->refCount != -1) {
993                    bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
994                    panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
995                            (length>60? 60 : length), bytes,
996                            localPtr->refCount);
997                }
998                if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
999                        localPtr->objPtr) == NULL) {
1000                    bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
1001                    panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
1002                             (length>60? 60 : length), bytes);
1003                }
1004                if (localPtr->objPtr->bytes == NULL) {
1005                    panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
1006                }
1007            }
1008        }
1009        if (count != localTablePtr->numEntries) {
1010            panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
1011                  count, localTablePtr->numEntries);
1012        }
1013    }
1014    
1015    /*
1016     *----------------------------------------------------------------------
1017     *
1018     * TclVerifyGlobalLiteralTable --
1019     *
1020     *      Check an interpreter's global literal table literal for consistency.
1021     *
1022     * Results:
1023     *      None.
1024     *
1025     * Side effects:
1026     *      Panics if problems are found.
1027     *
1028     *----------------------------------------------------------------------
1029     */
1030    
1031    void
1032    TclVerifyGlobalLiteralTable(iPtr)
1033        Interp *iPtr;               /* Points to interpreter whose global
1034                                     * literal table is to be validated. */
1035    {
1036        register LiteralTable *globalTablePtr = &(iPtr->literalTable);
1037        register LiteralEntry *globalPtr;
1038        char *bytes;
1039        register int i;
1040        int length, count;
1041    
1042        count = 0;
1043        for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
1044            for (globalPtr = globalTablePtr->buckets[i];
1045                    globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
1046                count++;
1047                if (globalPtr->refCount < 1) {
1048                    bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
1049                    panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
1050                            (length>60? 60 : length), bytes,
1051                            globalPtr->refCount);
1052                }
1053                if (globalPtr->objPtr->bytes == NULL) {
1054                    panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
1055                }
1056            }
1057        }
1058        if (count != globalTablePtr->numEntries) {
1059            panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
1060                  count, globalTablePtr->numEntries);
1061        }
1062    }
1063    #endif /*TCL_COMPILE_DEBUG*/
1064    
1065    /* End of tclliteral.c */
Legend:
Removed from v.42  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25