Tcl Source Code

TclBrodnikArrayDeclare(T,static);					\
TclBrodnikArrayDefine(T,static)

#define TclBrodnikArrayDefine(T,scope)					\
scope BA_ ## T *							\
BA_ ## T ## _Create()							\
{									\
    BA_ ## T *newPtr = Tcl_Alloc(sizeof(BA_ ## T));			\
									\
    newPtr->hi = 0;							\
    newPtr->lo = 0;							\
    newPtr->dbsize = 1;							\
    newPtr->count = 0;							\
    newPtr->dbused = 1;							\
    newPtr->dbavail = 1;						\
    newPtr->store = Tcl_Alloc(sizeof(T *));				\
    newPtr->store[0] = Tcl_Alloc(sizeof(T));				\
    return newPtr;							\
}									\
									\
scope void								\
BA_ ## T ## _Destroy(							\
    BA_ ## T *a)							\
{									\
    unsigned int i = a->dbused;						\
									\
    while (i--) {							\
	Tcl_Free(a->store[i]);						\
    }									\
    Tcl_Free(a->store);							\
    Tcl_Free(a);								\
}									\
									\
scope size_t								\
BA_ ## T ## _Size(							\
    BA_ ## T *a)							\
{									\
    if (a == NULL) {							\
	return 0;							\
    }									\
    return TclBAInvertIndices(a->hi, a->lo);				\
}									\
									\
scope void								\
BA_ ## T ## _Grow(							\
    BA_ ## T *a)							\
{									\
    if (a->dbused == a->dbavail) {					\
	a->dbavail *= 2;						\
	a->store = Tcl_Realloc(a->store, a->dbavail*sizeof(T *));		\
    }									\
    a->store[a->dbused] = Tcl_Alloc(a->dbsize * sizeof(T));		\
    a->dbused++;							\
}									\
									\
scope void								\
BA_ ## T ## _Shrink(							\
    BA_ ## T *a)							\
{									\
    a->dbused--;							\
    Tcl_Free(a->store[a->dbused]);					\
    if (a->dbavail / a->dbused >= 4) {					\
	a->dbavail /= 2;						\
	a->store = Tcl_Realloc(a->store, a->dbavail*sizeof(T *));		\
    }									\
}									\
									\
scope void								\
BA_ ## T ## _Copy(							\
    T *p,								\
    BA_ ## T *a)							\

	BP_pchar ptr;
	pchar *p = BA_pchar_First(env.cachePtr, &ptr);

	while (p) {
	    if (*p == oldStr) {
		pchar *lastPtr;

		Tcl_Free(*p);

		if (newStr) {
		    *p = newStr;
		    return;
		}

		lastPtr = BA_pchar_Detach(env.cachePtr);

	kt->dropRefProc(l->key);
    }
    l->key = NULL;
    if (vt && vt->dropRefProc) {
	vt->dropRefProc(l->value);
    }
    l->value = NULL;
    Tcl_Free(l);
}

static 
int KVLEqualKeys(
    HAMT *hamt,
    ClientData key1,
    ClientData key2)

KVList KVLNew(
    HAMT *hamt,
    ClientData key,
    ClientData value)
{
    const TclHAMTKeyType *kt = hamt->kt;
    const TclHAMTValueType *vt = hamt->vt;
    KVList new = Tcl_Alloc(sizeof(KVNode));
    new->claim = 0;
    if (kt && kt->makeRefProc) {
	kt->makeRefProc(key);
    }
    new->key = key;
    if (vt && vt->makeRefProc) {
	vt->makeRefProc(value);

    }
    KVLDisclaim(hamt, c->l);
    c->l = NULL;
    if (c->next) {
	CNDisclaim(hamt, c->next);
    }
    c->next = NULL;
    Tcl_Free(c);
}

static
Collision CNNew(
    KVList l,
    Collision next)
{
    Collision new = Tcl_Alloc(sizeof(CNode));
    new->claim = 0;
    if (next) {
	CNClaim(next);
    }
    new->next = next;
    KVLClaim(l);
    new->l = l;

	am->slot[i] = NULL;
    }
    for (i = 2*numList; i < 2*numList + numSubnode; i++) {
	AMDisclaim(hamt, am->slot[i]);
	am->slot[i] = NULL;
    }

    Tcl_Free(am);
}

/*
 *----------------------------------------------------------------------
 *
 * AMNew --
 *

ArrayMap AMNew(
    TclHAMT hamt,
    int numList,
    int numSubnode,
    size_t mask,
    size_t id)
{
    ArrayMap new = Tcl_Alloc(AMN_SIZE(numList, numSubnode));

    new->canWrite = (hamt) ? hamt->id : 0;
    new->claim = 0;
    new->size = 0;
    new->mask = mask;
    new->id = id;
    return new;

 */

TclHAMT
TclHAMTCreate(
    const TclHAMTKeyType *kt,	/* Custom key handling functions */
    const TclHAMTValueType *vt)	/* Custom value handling functions */
{
    HAMT *hamt = Tcl_Alloc(sizeof(HAMT));

    hamt->id = 0;
    hamt->claim = 0;
    hamt->kt = kt;
    hamt->vt = vt;
    hamt->kvl = NULL;
    hamt->x.am = NULL;

	hamt->x.am = NULL;
    }
    if (hamt->overflow) {
	CNDisclaim(hamt, hamt->overflow);
    }
    hamt->kt = NULL;
    hamt->vt = NULL;
    Tcl_Free(hamt);
}

/*
 *----------------------------------------------------------------------
 *
 * TclHAMTFetch --
 *

    assert ( hamt );

    if (hamt->kvl == NULL && hamt->x.am == NULL) {
	/* Empty */
	return NULL;
    }

    i = Tcl_Alloc(sizeof(Idx) + depth*sizeof(ArrayMap));

    /*
     * We claim an interest in hamt.  After that we need not claim any
     * interest in any of its sub-parts since it already takes care of
     * that for us.
     */

TclHAMTDone(
    TclHAMTIdx idx)
{
    Idx *i = idx;

    TclHAMTDisclaim(i->hamt);
    i->hamt = NULL;
    Tcl_Free(i);
}

/*
 *----------------------------------------------------------------------
 *
 * TclHAMTInfo --
 *

Tcl_Obj *
TclHAMTInfo(
    TclHAMT hamt)
{
    const int branchShift = TclMSB(branchFactor);
    const int depth = CHAR_BIT * sizeof(size_t) / branchShift;
    size_t *accum = Tcl_Alloc(depth*sizeof(size_t));
    size_t size = TclHAMTSize(hamt);
    double avg = 0.0;
    int i, collisions = 0;
    size_t nodes = 0;
    size_t numBytes = 0;
    size_t slots = 0;
    size_t hist[129];

	Tcl_DecrRefCount(count);

	fraction = (1.0 * accum[i]) / size;
	avg += i * fraction;
    }
    Tcl_AppendPrintfToObj(result, "\naverage hops: %g ", avg);
    }
    Tcl_Free(accum);

    return result;
}


/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

AllocChainEntry(
    Tcl_HashTable *tablePtr,
    void *keyPtr)
{
    Tcl_Obj *objPtr = keyPtr;
    ChainEntry *cPtr;

    cPtr = Tcl_Alloc(sizeof(ChainEntry));
    cPtr->entry.key.objPtr = objPtr;
    Tcl_IncrRefCount(objPtr);
    Tcl_SetHashValue(&cPtr->entry, NULL);
    cPtr->prevPtr = cPtr->nextPtr = NULL;

    return &cPtr->entry;
}

 */

static void
DeleteDict(
    Dict *dict)
{
    DeleteChainTable(dict);
    Tcl_Free(dict);
}

/*
 *----------------------------------------------------------------------
 *
 * TclTraceDictPath --
 *

#else /* !TCL_MEM_DEBUG */

    Tcl_Obj *dictPtr;
    Dict *dict;

    TclNewObj(dictPtr);
    TclInvalidateStringRep(dictPtr);
    dict = Tcl_Alloc(sizeof(Dict));
    InitChainTable(dict);
    dict->epoch = 1;
    dict->chain = NULL;
    dict->refCount = 1;
    DICT(dictPtr) = dict;
    dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
    dictPtr->typePtr = &tclDictType;

{
#ifdef TCL_MEM_DEBUG
    Tcl_Obj *dictPtr;
    Dict *dict;

    TclDbNewObj(dictPtr, file, line);
    TclInvalidateStringRep(dictPtr);
    dict = Tcl_Alloc(sizeof(Dict));
    InitChainTable(dict);
    dict->epoch = 1;
    dict->chain = NULL;
    dict->refCount = 1;
    DICT(dictPtr) = dict;
    dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
    dictPtr->typePtr = &tclDictType;

	    tirPtr->scriptObjPtr = NULL;
	    Tcl_DecrRefCount(releaseMe);
	    if (originalShimmered == 0) {
		return;
	    }
	}
    }
    Tcl_Free(tirPtr->tokenPtr);
    Tcl_Free(tirPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * DupTokensInternalRep --
 *

SetTokensFromAny (interp, objPtr)
    Tcl_Interp *interp;	/* Not used. */
    Tcl_Obj *objPtr;	/* Value for which to generate Tcl_Token array by
			 * parsing the string value */
{
    int numBytes;
    const char *script = Tcl_GetStringFromObj(objPtr, &numBytes);
    TokenIntRep *tirPtr = Tcl_Alloc(sizeof(TokenIntRep));

    /*
     * Free the old internal rep, parse the string as a Tcl script, and
     * stash the Tcl_Token array into a new internal rep
     *
     * NOTE: the Tcl_Token array contains pointers pointing into the
     * parsed string rep, which in this situation is objPtr->bytes.

	*termPtr = parsePtr->term;
    }
    /*
     * Note no call to Tcl_FreeParse().
     * We'll transfer the tokens to the caller.
     */
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	result = Tcl_Realloc(parsePtr->tokenPtr,
		parsePtr->numTokens * sizeof(Tcl_Token));
    } else {
	result = Tcl_Alloc(parsePtr->numTokens * sizeof(Tcl_Token));
	memcpy(result, parsePtr->tokenPtr, 
		(size_t) (parsePtr->numTokens * sizeof(Tcl_Token)));
    }

    if (lastTokenPtrPtr != NULL) {
	*lastTokenPtrPtr = &(result[parsePtr->numTokens - 1]);
    }

!ifndef _RULES_VC
_RULES_VC = 1

# The following macros define the version of the rules.vc nmake build system
# For modifications that are not backward-compatible, you *must* change
# the major version.
RULES_VERSION_MAJOR = 1
RULES_VERSION_MINOR = 4

# The PROJECT macro must be defined by parent makefile.
!if "$(PROJECT)" == ""
!error *** Error: Macro PROJECT not defined! Please define it before including rules.vc
!endif

!if "$(PRJ_PACKAGE_TCLNAME)" == ""

!if $(TCL_MEM_DEBUG)
OPTDEFINES	= $(OPTDEFINES) -DTCL_MEM_DEBUG
!endif
!if $(TCL_COMPILE_DEBUG)
OPTDEFINES	= $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
!endif
!if $(TCL_THREADS) && $(TCL_VERSION) <= 86
OPTDEFINES	= $(OPTDEFINES) -DTCL_THREADS=1
!if $(USE_THREAD_ALLOC)
OPTDEFINES	= $(OPTDEFINES) -DUSE_THREAD_ALLOC=1
!endif
!endif
!if $(STATIC_BUILD)
OPTDEFINES	= $(OPTDEFINES) -DSTATIC_BUILD

# appcflags contains $(cflags) and flags for building the application
# object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus
# flags used for building shared object files The two differ in the
# BUILD_$(PROJECT) macro which should be defined only for the shared
# library *implementation* and not for its caller interface


appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES)
appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS)
pkgcflags = $(appcflags) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT)
pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT)

# stubscflags contains $(cflags) plus flags used for building a stubs
# library for the package.  Note: -DSTATIC_BUILD is defined in
# $(OPTDEFINES) only if the OPTS configuration indicates a static
# library. However the stubs library is ALWAYS static hence included
# here irrespective of the OPTS setting.
#
# TBD - tclvfs has a comment that stubs libs should not be compiled with -GL
# without stating why. Tcl itself compiled stubs libs with this flag.
# so we do not remove it from cflags. -GL may prevent extensions
# compiled with one VC version to fail to link against stubs library
# compiled with another VC version. Check for this and fix accordingly.
stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl -DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS)

# Link flags

!if $(DEBUG)
ldebug	= -debug -debugtype:cv
!else
ldebug	= -release -opt:ref -opt:icf,3