fix bad cvs lf conversion

2 files changed, 1401 insertions, 1400 deletions

diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 0b428a6..5ff9449 100755
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -1,951 +1,952 @@
-/*

- * tclThreadAlloc.c --

- *

- *	This is a very fast storage allocator for used with threads (designed

- *	avoid lock contention).  The basic strategy is to allocate memory in

- *  	fixed size blocks from block caches.

- *

- * The Initial Developer of the Original Code is America Online, Inc.

- * Portions created by AOL are Copyright (C) 1999 America Online, Inc.

- *

- * See the file "license.terms" for information on usage and redistribution

- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

- *

- * RCS: @(#) $Id: tclThreadAlloc.c,v 1.5 2003/05/09 23:33:55 mistachkin Exp $ */

-

-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)

-

-#include "tclInt.h"

-

-#ifdef WIN32

-#include "tclWinInt.h"

-#else

-extern Tcl_Mutex *TclpNewAllocMutex(void);

-extern void *TclpGetAllocCache(void);

-extern void TclpSetAllocCache(void *);

-#endif

-

-/*

- * If range checking is enabled, an additional byte will be allocated

- * to store the magic number at the end of the requested memory.

- */

-

-#ifndef RCHECK

-#ifdef  NDEBUG

-#define RCHECK		0

-#else

-#define RCHECK		1

-#endif

-#endif

-

-/*

- * The following define the number of Tcl_Obj's to allocate/move

- * at a time and the high water mark to prune a per-thread cache.

- * On a 32 bit system, sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k.

- *

- */

-

-#define NOBJALLOC	 800

-#define NOBJHIGH	1200

-

-/*

- * The following defines the number of buckets in the bucket

- * cache and those block sizes from (1<<4) to (1<<(3+NBUCKETS))

- */

-

-#define NBUCKETS	  11

-#define MAXALLOC	  16284

-

-/*

- * The following union stores accounting information for

- * each block including two small magic numbers and

- * a bucket number when in use or a next pointer when

- * free.  The original requested size (not including

- * the Block overhead) is also maintained.

- */

-

-typedef struct Block {

-    union {

-    	struct Block *next;	  /* Next in free list. */

-    	struct {

-	    unsigned char magic1; /* First magic number. */

-	    unsigned char bucket; /* Bucket block allocated from. */

-	    unsigned char unused; /* Padding. */

-	    unsigned char magic2; /* Second magic number. */

-        } b_s;

-    } b_u;

-    size_t b_reqsize;		  /* Requested allocation size. */

-} Block;

-#define b_next		b_u.next

-#define b_bucket	b_u.b_s.bucket

-#define b_magic1	b_u.b_s.magic1

-#define b_magic2	b_u.b_s.magic2

-#define MAGIC		0xef

-

-/*

- * The following structure defines a bucket of blocks with

- * various accounting and statistics information.

- */

-

-typedef struct Bucket {

-    Block *firstPtr;

-    int nfree;

-    int nget;

-    int nput;

-    int nwait;

-    int nlock;

-    int nrequest;

-} Bucket;

-

-/*

- * The following structure defines a cache of buckets and objs.

- */

-

-typedef struct Cache {

-    struct Cache  *nextPtr;

-    Tcl_ThreadId   owner;

-    Tcl_Obj       *firstObjPtr;

-    int            nobjs;

-    int	           nsysalloc;

-    Bucket         buckets[NBUCKETS];

-} Cache;

-

-/*

- * The following array specifies various per-bucket

- * limits and locks.  The values are statically initialized

- * to avoid calculating them repeatedly.

- */

-

-struct binfo {

-    size_t blocksize;	/* Bucket blocksize. */

-    int maxblocks;	/* Max blocks before move to share. */

-    int nmove;		/* Num blocks to move to share. */

-    Tcl_Mutex *lockPtr; /* Share bucket lock. */

-} binfo[NBUCKETS] = {

-    {   16, 1024, 512, NULL},

-    {   32,  512, 256, NULL},

-    {   64,  256, 128, NULL},

-    {  128,  128,  64, NULL},

-    {  256,   64,  32, NULL},

-    {  512,   32,  16, NULL},

-    { 1024,   16,   8, NULL},

-    { 2048,    8,   4, NULL},

-    { 4096,    4,   2, NULL},

-    { 8192,    2,   1, NULL},

-    {16284,    1,   1, NULL},

-};

-

-/*

- * Static functions defined in this file.

- */

-

-static void LockBucket(Cache *cachePtr, int bucket);

-static void UnlockBucket(Cache *cachePtr, int bucket);

-static void PutBlocks(Cache *cachePtr, int bucket, int nmove);

-static int  GetBlocks(Cache *cachePtr, int bucket);

-static Block *Ptr2Block(char *ptr);

-static char *Block2Ptr(Block *blockPtr, int bucket, unsigned int reqsize);

-static void MoveObjs(Cache *fromPtr, Cache *toPtr, int nmove);

-

-/*

- * Local variables defined in this file and initialized at

- * startup.

- */

-

-static Tcl_Mutex *listLockPtr;

-static Tcl_Mutex *objLockPtr;

-static Cache     sharedCache;

-static Cache    *sharedPtr = &sharedCache;

-static Cache    *firstCachePtr = &sharedCache;

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  GetCache ---

- *

- *	Gets per-thread memory cache, allocating it if necessary.

- *

- * Results:

- *	Pointer to cache.

- *

- * Side effects:

- *  	None.

- *

- *----------------------------------------------------------------------

- */

-

-static Cache *

-GetCache(void)

-{

-    Cache *cachePtr;

-

-    /*

-     * Check for first-time initialization.

-     */

-

-    if (listLockPtr == NULL) {

-	Tcl_Mutex *initLockPtr;

-    	int i;

-

-	initLockPtr = Tcl_GetAllocMutex();

-	Tcl_MutexLock(initLockPtr);

-	if (listLockPtr == NULL) {

-	    listLockPtr = TclpNewAllocMutex();

-	    objLockPtr = TclpNewAllocMutex();

-	    for (i = 0; i < NBUCKETS; ++i) {

-	        binfo[i].lockPtr = TclpNewAllocMutex();

-	    }

-	}

-	Tcl_MutexUnlock(initLockPtr);

-    }

-

-    /*

-     * Get this thread's cache, allocating if necessary.

-     */

-

-    cachePtr = TclpGetAllocCache();

-    if (cachePtr == NULL) {

-    	cachePtr = calloc(1, sizeof(Cache));

-    	if (cachePtr == NULL) {

-	    panic("alloc: could not allocate new cache");

-    	}

-    	Tcl_MutexLock(listLockPtr);

-    	cachePtr->nextPtr = firstCachePtr;

-    	firstCachePtr = cachePtr;

-    	Tcl_MutexUnlock(listLockPtr);

-    	cachePtr->owner = Tcl_GetCurrentThread();

-	TclpSetAllocCache(cachePtr);

-    }

-    return cachePtr;

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  TclFreeAllocCache --

- *

- *	Flush and delete a cache, removing from list of caches.

- *

- * Results:

- *	None.

- *

- * Side effects:

- *	None.

- *

- *----------------------------------------------------------------------

- */

-

-void

-TclFreeAllocCache(void *arg)

-{

-    Cache *cachePtr = arg;

-    Cache **nextPtrPtr;

-    register int   bucket;

-

-    /*

-     * Flush blocks.

-     */

-

-    for (bucket = 0; bucket < NBUCKETS; ++bucket) {

-	if (cachePtr->buckets[bucket].nfree > 0) {

-	    PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].nfree);

-	}

-    }

-

-    /*

-     * Flush objs.

-     */

-

-    if (cachePtr->nobjs > 0) {

-    	Tcl_MutexLock(objLockPtr);

-    	MoveObjs(cachePtr, sharedPtr, cachePtr->nobjs);

-    	Tcl_MutexUnlock(objLockPtr);

-    }

-

-    /*

-     * Remove from pool list.

-     */

-

-    Tcl_MutexLock(listLockPtr);

-    nextPtrPtr = &firstCachePtr;

-    while (*nextPtrPtr != cachePtr) {

-	nextPtrPtr = &(*nextPtrPtr)->nextPtr;

-    }

-    *nextPtrPtr = cachePtr->nextPtr;

-    cachePtr->nextPtr = NULL;

-    Tcl_MutexUnlock(listLockPtr);

-    free(cachePtr);

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  TclpAlloc --

- *

- *	Allocate memory.

- *

- * Results:

- *	Pointer to memory just beyond Block pointer.

- *

- * Side effects:

- *	May allocate more blocks for a bucket.

- *

- *----------------------------------------------------------------------

- */

-

-char *

-TclpAlloc(unsigned int reqsize)

-{

-    Cache         *cachePtr = TclpGetAllocCache();

-    Block         *blockPtr;

-    register int   bucket;

-    size_t  	   size;

-

-    if (cachePtr == NULL) {

-	cachePtr = GetCache();

-    }

-

-    /*

-     * Increment the requested size to include room for

-     * the Block structure.  Call malloc() directly if the

-     * required amount is greater than the largest block,

-     * otherwise pop the smallest block large enough,

-     * allocating more blocks if necessary.

-     */

-

-    blockPtr = NULL;

-    size = reqsize + sizeof(Block);

-#if RCHECK

-    ++size;

-#endif

-    if (size > MAXALLOC) {

-	bucket = NBUCKETS;

-    	blockPtr = malloc(size);

-	if (blockPtr != NULL) {

-	    cachePtr->nsysalloc += reqsize;

-	}

-    } else {

-    	bucket = 0;

-    	while (binfo[bucket].blocksize < size) {

-    	    ++bucket;

-    	}

-    	if (cachePtr->buckets[bucket].nfree || GetBlocks(cachePtr, bucket)) {

-	    blockPtr = cachePtr->buckets[bucket].firstPtr;

-	    cachePtr->buckets[bucket].firstPtr = blockPtr->b_next;

-	    --cachePtr->buckets[bucket].nfree;

-    	    ++cachePtr->buckets[bucket].nget;

-	    cachePtr->buckets[bucket].nrequest += reqsize;

-	}

-    }

-    if (blockPtr == NULL) {

-    	return NULL;

-    }

-    return Block2Ptr(blockPtr, bucket, reqsize);

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  TclpFree --

- *

- *	Return blocks to the thread block cache.

- *

- * Results:

- *	None.

- *

- * Side effects:

- *	May move blocks to shared cache.

- *

- *----------------------------------------------------------------------

- */

-

-void

-TclpFree(char *ptr)

-{

-    if (ptr != NULL) {

-	Cache  *cachePtr = TclpGetAllocCache();

-	Block *blockPtr;

-	int bucket;

-

-	if (cachePtr == NULL) {

-	    cachePtr = GetCache();

-	}

-

-	/*

-	 * Get the block back from the user pointer and

-	 * call system free directly for large blocks.

-	 * Otherwise, push the block back on the bucket and

-	 * move blocks to the shared cache if there are now

-	 * too many free.

-	 */

-

-	blockPtr = Ptr2Block(ptr);

-	bucket = blockPtr->b_bucket;

-	if (bucket == NBUCKETS) {

-	    cachePtr->nsysalloc -= blockPtr->b_reqsize;

-	    free(blockPtr);

-	} else {

-	    cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;

-	    blockPtr->b_next = cachePtr->buckets[bucket].firstPtr;

-	    cachePtr->buckets[bucket].firstPtr = blockPtr;

-	    ++cachePtr->buckets[bucket].nfree;

-	    ++cachePtr->buckets[bucket].nput;

-	    if (cachePtr != sharedPtr &&

-		    cachePtr->buckets[bucket].nfree > binfo[bucket].maxblocks) {

-		PutBlocks(cachePtr, bucket, binfo[bucket].nmove);

-	    }

-	}

-    }

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  TclpRealloc --

- *

- *	Re-allocate memory to a larger or smaller size.

- *

- * Results:

- *	Pointer to memory just beyond Block pointer.

- *

- * Side effects:

- *	Previous memory, if any, may be freed.

- *

- *----------------------------------------------------------------------

- */

-

-char *

-TclpRealloc(char *ptr, unsigned int reqsize)

-{

-    Cache *cachePtr = TclpGetAllocCache();

-    Block *blockPtr;

-    void *new;

-    size_t size, min;

-    int bucket;

-

-    if (ptr == NULL) {

-	return TclpAlloc(reqsize);

-    }

-

-    if (cachePtr == NULL) {

-	cachePtr = GetCache();

-    }

-

-    /*

-     * If the block is not a system block and fits in place,

-     * simply return the existing pointer.  Otherwise, if the block

-     * is a system block and the new size would also require a system

-     * block, call realloc() directly.

-     */

-

-    blockPtr = Ptr2Block(ptr);

-    size = reqsize + sizeof(Block);

-#if RCHECK

-    ++size;

-#endif

-    bucket = blockPtr->b_bucket;

-    if (bucket != NBUCKETS) {

-	if (bucket > 0) {

-	    min = binfo[bucket-1].blocksize;

-	} else {

-	    min = 0;

-	}

-	if (size > min && size <= binfo[bucket].blocksize) {

-	    cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;

-	    cachePtr->buckets[bucket].nrequest += reqsize;

-	    return Block2Ptr(blockPtr, bucket, reqsize);

-	}

-    } else if (size > MAXALLOC) {

-	cachePtr->nsysalloc -= blockPtr->b_reqsize;

-	cachePtr->nsysalloc += reqsize;

-	blockPtr = realloc(blockPtr, size);

-	if (blockPtr == NULL) {

-	    return NULL;

-	}

-	return Block2Ptr(blockPtr, NBUCKETS, reqsize);

-    }

-

-    /*

-     * Finally, perform an expensive malloc/copy/free.

-     */

-

-    new = TclpAlloc(reqsize);

-    if (new != NULL) {

-	if (reqsize > blockPtr->b_reqsize) {

-	    reqsize = blockPtr->b_reqsize;

-	}

-    	memcpy(new, ptr, reqsize);

-    	TclpFree(ptr);

-    }

-    return new;

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- * TclThreadAllocObj --

- *

- *	Allocate a Tcl_Obj from the per-thread cache.

- *

- * Results:

- *	Pointer to uninitialized Tcl_Obj.

- *

- * Side effects:

- *	May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's

- *  	if list is empty.

- *

- *----------------------------------------------------------------------

- */

-

-Tcl_Obj *

-TclThreadAllocObj(void)

-{

-    register Cache *cachePtr = TclpGetAllocCache();

-    register int nmove;

-    register Tcl_Obj *objPtr;

-    Tcl_Obj *newObjsPtr;

-

-    if (cachePtr == NULL) {

-	cachePtr = GetCache();

-    }

-

-    /*

-     * Get this thread's obj list structure and move

-     * or allocate new objs if necessary.

-     */

-

-    if (cachePtr->nobjs == 0) {

-    	Tcl_MutexLock(objLockPtr);

-	nmove = sharedPtr->nobjs;

-	if (nmove > 0) {

-	    if (nmove > NOBJALLOC) {

-		nmove = NOBJALLOC;

-	    }

-	    MoveObjs(sharedPtr, cachePtr, nmove);

-	}

-    	Tcl_MutexUnlock(objLockPtr);

-	if (cachePtr->nobjs == 0) {

-	    cachePtr->nobjs = nmove = NOBJALLOC;

-	    newObjsPtr = malloc(sizeof(Tcl_Obj) * nmove);

-	    if (newObjsPtr == NULL) {

-		panic("alloc: could not allocate %d new objects", nmove);

-	    }

-	    while (--nmove >= 0) {

-		objPtr = &newObjsPtr[nmove];

-		objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;

-		cachePtr->firstObjPtr = objPtr;

-	    }

-	}

-    }

-

-    /*

-     * Pop the first object.

-     */

-

-    objPtr = cachePtr->firstObjPtr;

-    cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;

-    --cachePtr->nobjs;

-    return objPtr;

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- * TclThreadFreeObj --

- *

- *	Return a free Tcl_Obj to the per-thread cache.

- *

- * Results:

- *	None.

- *

- * Side effects:

- *	May move free Tcl_Obj's to shared list upon hitting high

- *  	water mark.

- *

- *----------------------------------------------------------------------

- */

-

-void

-TclThreadFreeObj(Tcl_Obj *objPtr)

-{

-    Cache *cachePtr = TclpGetAllocCache();

-

-    if (cachePtr == NULL) {

-	cachePtr = GetCache();

-    }

-

-    /*

-     * Get this thread's list and push on the free Tcl_Obj.

-     */

-

-    objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;

-    cachePtr->firstObjPtr = objPtr;

-    ++cachePtr->nobjs;

-

-    /*

-     * If the number of free objects has exceeded the high

-     * water mark, move some blocks to the shared list.

-     */

-

-    if (cachePtr->nobjs > NOBJHIGH) {

-	Tcl_MutexLock(objLockPtr);

-	MoveObjs(cachePtr, sharedPtr, NOBJALLOC);

-	Tcl_MutexUnlock(objLockPtr);

-    }

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- * Tcl_GetMemoryInfo --

- *

- *	Return a list-of-lists of memory stats.

- *

- * Results:

- *	None.

- *

- * Side effects:

- *  	List appended to given dstring.

- *

- *----------------------------------------------------------------------

- */

-

-void

-Tcl_GetMemoryInfo(Tcl_DString *dsPtr)

-{

-    Cache *cachePtr;

-    char buf[200];

-    int n;

-

-    Tcl_MutexLock(listLockPtr);

-    cachePtr = firstCachePtr;

-    while (cachePtr != NULL) {

-	Tcl_DStringStartSublist(dsPtr);

-	if (cachePtr == sharedPtr) {

-    	    Tcl_DStringAppendElement(dsPtr, "shared");

-	} else {

-	    sprintf(buf, "thread%d", (int) cachePtr->owner);

-    	    Tcl_DStringAppendElement(dsPtr, buf);

-	}

-	for (n = 0; n < NBUCKETS; ++n) {

-    	    sprintf(buf, "%d %d %d %d %d %d %d",

-		(int) binfo[n].blocksize,

-		cachePtr->buckets[n].nfree,

-		cachePtr->buckets[n].nget,

-		cachePtr->buckets[n].nput,

-		cachePtr->buckets[n].nrequest,

-		cachePtr->buckets[n].nlock,

-		cachePtr->buckets[n].nwait);

-	    Tcl_DStringAppendElement(dsPtr, buf);

-	}

-	Tcl_DStringEndSublist(dsPtr);

-	    cachePtr = cachePtr->nextPtr;

-    }

-    Tcl_MutexUnlock(listLockPtr);

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- * MoveObjs --

- *

- *	Move Tcl_Obj's between caches.

- *

- * Results:

- *	None.

- *

- * Side effects:

- *  	None.

- *

- *----------------------------------------------------------------------

- */

-

-static void

-MoveObjs(Cache *fromPtr, Cache *toPtr, int nmove)

-{

-    register Tcl_Obj *objPtr = fromPtr->firstObjPtr;

-    Tcl_Obj *fromFirstObjPtr = objPtr;

-

-    toPtr->nobjs += nmove;

-    fromPtr->nobjs -= nmove;

-

-    /*

-     * Find the last object to be moved; set the next one

-     * (the first one not to be moved) as the first object

-     * in the 'from' cache.

-     */

-

-    while (--nmove) {

-	objPtr = objPtr->internalRep.otherValuePtr;

-    }

-    fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;

-

-    /*

-     * Move all objects as a block - they are already linked to

-     * each other, we just have to update the first and last.

-     */

-

-    objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;

-    toPtr->firstObjPtr = fromFirstObjPtr;

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  Block2Ptr, Ptr2Block --

- *

- *	Convert between internal blocks and user pointers.

- *

- * Results:

- *	User pointer or internal block.

- *

- * Side effects:

- *	Invalid blocks will abort the server.

- *

- *----------------------------------------------------------------------

- */

-

-static char *

-Block2Ptr(Block *blockPtr, int bucket, unsigned int reqsize)

-{

-    register void *ptr;

-

-    blockPtr->b_magic1 = blockPtr->b_magic2 = MAGIC;

-    blockPtr->b_bucket = bucket;

-    blockPtr->b_reqsize = reqsize;

-    ptr = ((void *) (blockPtr + 1));

-#if RCHECK

-    ((unsigned char *)(ptr))[reqsize] = MAGIC;

-#endif

-    return (char *) ptr;

-}

-

-static Block *

-Ptr2Block(char *ptr)

-{

-    register Block *blockPtr;

-

-    blockPtr = (((Block *) ptr) - 1);

-    if (blockPtr->b_magic1 != MAGIC

-#if RCHECK

-	|| ((unsigned char *) ptr)[blockPtr->b_reqsize] != MAGIC

-#endif

-	|| blockPtr->b_magic2 != MAGIC) {

-	panic("alloc: invalid block: %p: %x %x %x\n",

-	    blockPtr, blockPtr->b_magic1, blockPtr->b_magic2,

-	    ((unsigned char *) ptr)[blockPtr->b_reqsize]);

-    }

-    return blockPtr;

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  LockBucket, UnlockBucket --

- *

- *	Set/unset the lock to access a bucket in the shared cache.

- *

- * Results:

- *  	None.

- *

- * Side effects:

- *	Lock activity and contention are monitored globally and on

- *  	a per-cache basis.

- *

- *----------------------------------------------------------------------

- */

-

-static void

-LockBucket(Cache *cachePtr, int bucket)

-{

-#if 0

-    if (Tcl_MutexTryLock(binfo[bucket].lockPtr) != TCL_OK) {

-	Tcl_MutexLock(binfo[bucket].lockPtr);

-    	++cachePtr->buckets[bucket].nwait;

-    	++sharedPtr->buckets[bucket].nwait;

-    }

-#else

-    Tcl_MutexLock(binfo[bucket].lockPtr);

-#endif

-    ++cachePtr->buckets[bucket].nlock;

-    ++sharedPtr->buckets[bucket].nlock;

-}

-

-

-static void

-UnlockBucket(Cache *cachePtr, int bucket)

-{

-    Tcl_MutexUnlock(binfo[bucket].lockPtr);

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  PutBlocks --

- *

- *	Return unused blocks to the shared cache.

- *

- * Results:

- *	None.

- *

- * Side effects:

- *	None.

- *

- *----------------------------------------------------------------------

- */

-

-static void

-PutBlocks(Cache *cachePtr, int bucket, int nmove)

-{

-    register Block *lastPtr, *firstPtr;

-    register int n = nmove;

-

-    /*

-     * Before acquiring the lock, walk the block list to find

-     * the last block to be moved.

-     */

-

-    firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr;

-    while (--n > 0) {

-	lastPtr = lastPtr->b_next;

-    }

-    cachePtr->buckets[bucket].firstPtr = lastPtr->b_next;

-    cachePtr->buckets[bucket].nfree -= nmove;

-

-    /*

-     * Aquire the lock and place the list of blocks at the front

-     * of the shared cache bucket.

-     */

-

-    LockBucket(cachePtr, bucket);

-    lastPtr->b_next = sharedPtr->buckets[bucket].firstPtr;

-    sharedPtr->buckets[bucket].firstPtr = firstPtr;

-    sharedPtr->buckets[bucket].nfree += nmove;

-    UnlockBucket(cachePtr, bucket);

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- *  GetBlocks --

- *

- *	Get more blocks for a bucket.

- *

- * Results:

- *	1 if blocks where allocated, 0 otherwise.

- *

- * Side effects:

- *	Cache may be filled with available blocks.

- *

- *----------------------------------------------------------------------

- */

-

-static int

-GetBlocks(Cache *cachePtr, int bucket)

-{

-    register Block *blockPtr;

-    register int n;

-    register size_t size;

-

-    /*

-     * First, atttempt to move blocks from the shared cache.  Note

-     * the potentially dirty read of nfree before acquiring the lock

-     * which is a slight performance enhancement.  The value is

-     * verified after the lock is actually acquired.

-     */

-

-    if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].nfree > 0) {

-	LockBucket(cachePtr, bucket);

-	if (sharedPtr->buckets[bucket].nfree > 0) {

-

-	    /*

-	     * Either move the entire list or walk the list to find

-	     * the last block to move.

-	     */

-

-	    n = binfo[bucket].nmove;

-	    if (n >= sharedPtr->buckets[bucket].nfree) {

-		cachePtr->buckets[bucket].firstPtr =

-		    sharedPtr->buckets[bucket].firstPtr;

-		cachePtr->buckets[bucket].nfree =

-		    sharedPtr->buckets[bucket].nfree;

-		sharedPtr->buckets[bucket].firstPtr = NULL;

-		sharedPtr->buckets[bucket].nfree = 0;

-	    } else {

-		blockPtr = sharedPtr->buckets[bucket].firstPtr;

-		cachePtr->buckets[bucket].firstPtr = blockPtr;

-		sharedPtr->buckets[bucket].nfree -= n;

-		cachePtr->buckets[bucket].nfree = n;

-		while (--n > 0) {

-    		    blockPtr = blockPtr->b_next;

-		}

-		sharedPtr->buckets[bucket].firstPtr = blockPtr->b_next;

-		blockPtr->b_next = NULL;

-	    }

-	}

-	UnlockBucket(cachePtr, bucket);

-    }

-

-    if (cachePtr->buckets[bucket].nfree == 0) {

-

-	/*

-	 * If no blocks could be moved from shared, first look for a

-	 * larger block in this cache to split up.

-	 */

-

-    	blockPtr = NULL;

-	n = NBUCKETS;

-	size = 0; /* lint */

-	while (--n > bucket) {

-    	    if (cachePtr->buckets[n].nfree > 0) {

-		size = binfo[n].blocksize;

-		blockPtr = cachePtr->buckets[n].firstPtr;

-		cachePtr->buckets[n].firstPtr = blockPtr->b_next;

-		--cachePtr->buckets[n].nfree;

-		break;

-	    }

-	}

-

-	/*

-	 * Otherwise, allocate a big new block directly.

-	 */

-

-	if (blockPtr == NULL) {

-	    size = MAXALLOC;

-	    blockPtr = malloc(size);

-	    if (blockPtr == NULL) {

-		return 0;

-	    }

-	}

-

-	/*

-	 * Split the larger block into smaller blocks for this bucket.

-	 */

-

-	n = size / binfo[bucket].blocksize;

-	cachePtr->buckets[bucket].nfree = n;

-	cachePtr->buckets[bucket].firstPtr = blockPtr;

-	while (--n > 0) {

-	    blockPtr->b_next = (Block *)

-		((char *) blockPtr + binfo[bucket].blocksize);

-	    blockPtr = blockPtr->b_next;

-	}

-	blockPtr->b_next = NULL;

-    }

-    return 1;

-}

-

-#endif /* TCL_THREADS */

+/*
+ * tclThreadAlloc.c --
+ *
+ *	This is a very fast storage allocator for used with threads (designed
+ *	avoid lock contention).  The basic strategy is to allocate memory in
+ *  	fixed size blocks from block caches.
+ *
+ * The Initial Developer of the Original Code is America Online, Inc.
+ * Portions created by AOL are Copyright (C) 1999 America Online, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclThreadAlloc.c,v 1.6 2003/05/10 04:28:59 mistachkin Exp $
+ */
+
+#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+
+#include "tclInt.h"
+
+#ifdef WIN32
+#include "tclWinInt.h"
+#else
+extern Tcl_Mutex *TclpNewAllocMutex(void);
+extern void *TclpGetAllocCache(void);
+extern void TclpSetAllocCache(void *);
+#endif
+
+/*
+ * If range checking is enabled, an additional byte will be allocated
+ * to store the magic number at the end of the requested memory.
+ */
+
+#ifndef RCHECK
+#ifdef  NDEBUG
+#define RCHECK		0
+#else
+#define RCHECK		1
+#endif
+#endif
+
+/*
+ * The following define the number of Tcl_Obj's to allocate/move
+ * at a time and the high water mark to prune a per-thread cache.
+ * On a 32 bit system, sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k.
+ *
+ */
+
+#define NOBJALLOC	 800
+#define NOBJHIGH	1200
+
+/*
+ * The following defines the number of buckets in the bucket
+ * cache and those block sizes from (1<<4) to (1<<(3+NBUCKETS))
+ */
+
+#define NBUCKETS	  11
+#define MAXALLOC	  16284
+
+/*
+ * The following union stores accounting information for
+ * each block including two small magic numbers and
+ * a bucket number when in use or a next pointer when
+ * free.  The original requested size (not including
+ * the Block overhead) is also maintained.
+ */
+
+typedef struct Block {
+    union {
+    	struct Block *next;	  /* Next in free list. */
+    	struct {
+	    unsigned char magic1; /* First magic number. */
+	    unsigned char bucket; /* Bucket block allocated from. */
+	    unsigned char unused; /* Padding. */
+	    unsigned char magic2; /* Second magic number. */
+        } b_s;
+    } b_u;
+    size_t b_reqsize;		  /* Requested allocation size. */
+} Block;
+#define b_next		b_u.next
+#define b_bucket	b_u.b_s.bucket
+#define b_magic1	b_u.b_s.magic1
+#define b_magic2	b_u.b_s.magic2
+#define MAGIC		0xef
+
+/*
+ * The following structure defines a bucket of blocks with
+ * various accounting and statistics information.
+ */
+
+typedef struct Bucket {
+    Block *firstPtr;
+    int nfree;
+    int nget;
+    int nput;
+    int nwait;
+    int nlock;
+    int nrequest;
+} Bucket;
+
+/*
+ * The following structure defines a cache of buckets and objs.
+ */
+
+typedef struct Cache {
+    struct Cache  *nextPtr;
+    Tcl_ThreadId   owner;
+    Tcl_Obj       *firstObjPtr;
+    int            nobjs;
+    int	           nsysalloc;
+    Bucket         buckets[NBUCKETS];
+} Cache;
+
+/*
+ * The following array specifies various per-bucket
+ * limits and locks.  The values are statically initialized
+ * to avoid calculating them repeatedly.
+ */
+
+struct binfo {
+    size_t blocksize;	/* Bucket blocksize. */
+    int maxblocks;	/* Max blocks before move to share. */
+    int nmove;		/* Num blocks to move to share. */
+    Tcl_Mutex *lockPtr; /* Share bucket lock. */
+} binfo[NBUCKETS] = {
+    {   16, 1024, 512, NULL},
+    {   32,  512, 256, NULL},
+    {   64,  256, 128, NULL},
+    {  128,  128,  64, NULL},
+    {  256,   64,  32, NULL},
+    {  512,   32,  16, NULL},
+    { 1024,   16,   8, NULL},
+    { 2048,    8,   4, NULL},
+    { 4096,    4,   2, NULL},
+    { 8192,    2,   1, NULL},
+    {16284,    1,   1, NULL},
+};
+
+/*
+ * Static functions defined in this file.
+ */
+
+static void LockBucket(Cache *cachePtr, int bucket);
+static void UnlockBucket(Cache *cachePtr, int bucket);
+static void PutBlocks(Cache *cachePtr, int bucket, int nmove);
+static int  GetBlocks(Cache *cachePtr, int bucket);
+static Block *Ptr2Block(char *ptr);
+static char *Block2Ptr(Block *blockPtr, int bucket, unsigned int reqsize);
+static void MoveObjs(Cache *fromPtr, Cache *toPtr, int nmove);
+
+/*
+ * Local variables defined in this file and initialized at
+ * startup.
+ */
+
+static Tcl_Mutex *listLockPtr;
+static Tcl_Mutex *objLockPtr;
+static Cache     sharedCache;
+static Cache    *sharedPtr = &sharedCache;
+static Cache    *firstCachePtr = &sharedCache;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  GetCache ---
+ *
+ *	Gets per-thread memory cache, allocating it if necessary.
+ *
+ * Results:
+ *	Pointer to cache.
+ *
+ * Side effects:
+ *  	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Cache *
+GetCache(void)
+{
+    Cache *cachePtr;
+
+    /*
+     * Check for first-time initialization.
+     */
+
+    if (listLockPtr == NULL) {
+	Tcl_Mutex *initLockPtr;
+    	int i;
+
+	initLockPtr = Tcl_GetAllocMutex();
+	Tcl_MutexLock(initLockPtr);
+	if (listLockPtr == NULL) {
+	    listLockPtr = TclpNewAllocMutex();
+	    objLockPtr = TclpNewAllocMutex();
+	    for (i = 0; i < NBUCKETS; ++i) {
+	        binfo[i].lockPtr = TclpNewAllocMutex();
+	    }
+	}
+	Tcl_MutexUnlock(initLockPtr);
+    }
+
+    /*
+     * Get this thread's cache, allocating if necessary.
+     */
+
+    cachePtr = TclpGetAllocCache();
+    if (cachePtr == NULL) {
+    	cachePtr = calloc(1, sizeof(Cache));
+    	if (cachePtr == NULL) {
+	    panic("alloc: could not allocate new cache");
+    	}
+    	Tcl_MutexLock(listLockPtr);
+    	cachePtr->nextPtr = firstCachePtr;
+    	firstCachePtr = cachePtr;
+    	Tcl_MutexUnlock(listLockPtr);
+    	cachePtr->owner = Tcl_GetCurrentThread();
+	TclpSetAllocCache(cachePtr);
+    }
+    return cachePtr;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  TclFreeAllocCache --
+ *
+ *	Flush and delete a cache, removing from list of caches.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFreeAllocCache(void *arg)
+{
+    Cache *cachePtr = arg;
+    Cache **nextPtrPtr;
+    register int   bucket;
+
+    /*
+     * Flush blocks.
+     */
+
+    for (bucket = 0; bucket < NBUCKETS; ++bucket) {
+	if (cachePtr->buckets[bucket].nfree > 0) {
+	    PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].nfree);
+	}
+    }
+
+    /*
+     * Flush objs.
+     */
+
+    if (cachePtr->nobjs > 0) {
+    	Tcl_MutexLock(objLockPtr);
+    	MoveObjs(cachePtr, sharedPtr, cachePtr->nobjs);
+    	Tcl_MutexUnlock(objLockPtr);
+    }
+
+    /*
+     * Remove from pool list.
+     */
+
+    Tcl_MutexLock(listLockPtr);
+    nextPtrPtr = &firstCachePtr;
+    while (*nextPtrPtr != cachePtr) {
+	nextPtrPtr = &(*nextPtrPtr)->nextPtr;
+    }
+    *nextPtrPtr = cachePtr->nextPtr;
+    cachePtr->nextPtr = NULL;
+    Tcl_MutexUnlock(listLockPtr);
+    free(cachePtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  TclpAlloc --
+ *
+ *	Allocate memory.
+ *
+ * Results:
+ *	Pointer to memory just beyond Block pointer.
+ *
+ * Side effects:
+ *	May allocate more blocks for a bucket.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclpAlloc(unsigned int reqsize)
+{
+    Cache         *cachePtr = TclpGetAllocCache();
+    Block         *blockPtr;
+    register int   bucket;
+    size_t  	   size;
+
+    if (cachePtr == NULL) {
+	cachePtr = GetCache();
+    }
+
+    /*
+     * Increment the requested size to include room for
+     * the Block structure.  Call malloc() directly if the
+     * required amount is greater than the largest block,
+     * otherwise pop the smallest block large enough,
+     * allocating more blocks if necessary.
+     */
+
+    blockPtr = NULL;
+    size = reqsize + sizeof(Block);
+#if RCHECK
+    ++size;
+#endif
+    if (size > MAXALLOC) {
+	bucket = NBUCKETS;
+    	blockPtr = malloc(size);
+	if (blockPtr != NULL) {
+	    cachePtr->nsysalloc += reqsize;
+	}
+    } else {
+    	bucket = 0;
+    	while (binfo[bucket].blocksize < size) {
+    	    ++bucket;
+    	}
+    	if (cachePtr->buckets[bucket].nfree || GetBlocks(cachePtr, bucket)) {
+	    blockPtr = cachePtr->buckets[bucket].firstPtr;
+	    cachePtr->buckets[bucket].firstPtr = blockPtr->b_next;
+	    --cachePtr->buckets[bucket].nfree;
+    	    ++cachePtr->buckets[bucket].nget;
+	    cachePtr->buckets[bucket].nrequest += reqsize;
+	}
+    }
+    if (blockPtr == NULL) {
+    	return NULL;
+    }
+    return Block2Ptr(blockPtr, bucket, reqsize);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  TclpFree --
+ *
+ *	Return blocks to the thread block cache.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May move blocks to shared cache.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFree(char *ptr)
+{
+    if (ptr != NULL) {
+	Cache  *cachePtr = TclpGetAllocCache();
+	Block *blockPtr;
+	int bucket;
+
+	if (cachePtr == NULL) {
+	    cachePtr = GetCache();
+	}
+
+	/*
+	 * Get the block back from the user pointer and
+	 * call system free directly for large blocks.
+	 * Otherwise, push the block back on the bucket and
+	 * move blocks to the shared cache if there are now
+	 * too many free.
+	 */
+
+	blockPtr = Ptr2Block(ptr);
+	bucket = blockPtr->b_bucket;
+	if (bucket == NBUCKETS) {
+	    cachePtr->nsysalloc -= blockPtr->b_reqsize;
+	    free(blockPtr);
+	} else {
+	    cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;
+	    blockPtr->b_next = cachePtr->buckets[bucket].firstPtr;
+	    cachePtr->buckets[bucket].firstPtr = blockPtr;
+	    ++cachePtr->buckets[bucket].nfree;
+	    ++cachePtr->buckets[bucket].nput;
+	    if (cachePtr != sharedPtr &&
+		    cachePtr->buckets[bucket].nfree > binfo[bucket].maxblocks) {
+		PutBlocks(cachePtr, bucket, binfo[bucket].nmove);
+	    }
+	}
+    }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  TclpRealloc --
+ *
+ *	Re-allocate memory to a larger or smaller size.
+ *
+ * Results:
+ *	Pointer to memory just beyond Block pointer.
+ *
+ * Side effects:
+ *	Previous memory, if any, may be freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclpRealloc(char *ptr, unsigned int reqsize)
+{
+    Cache *cachePtr = TclpGetAllocCache();
+    Block *blockPtr;
+    void *new;
+    size_t size, min;
+    int bucket;
+
+    if (ptr == NULL) {
+	return TclpAlloc(reqsize);
+    }
+
+    if (cachePtr == NULL) {
+	cachePtr = GetCache();
+    }
+
+    /*
+     * If the block is not a system block and fits in place,
+     * simply return the existing pointer.  Otherwise, if the block
+     * is a system block and the new size would also require a system
+     * block, call realloc() directly.
+     */
+
+    blockPtr = Ptr2Block(ptr);
+    size = reqsize + sizeof(Block);
+#if RCHECK
+    ++size;
+#endif
+    bucket = blockPtr->b_bucket;
+    if (bucket != NBUCKETS) {
+	if (bucket > 0) {
+	    min = binfo[bucket-1].blocksize;
+	} else {
+	    min = 0;
+	}
+	if (size > min && size <= binfo[bucket].blocksize) {
+	    cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;
+	    cachePtr->buckets[bucket].nrequest += reqsize;
+	    return Block2Ptr(blockPtr, bucket, reqsize);
+	}
+    } else if (size > MAXALLOC) {
+	cachePtr->nsysalloc -= blockPtr->b_reqsize;
+	cachePtr->nsysalloc += reqsize;
+	blockPtr = realloc(blockPtr, size);
+	if (blockPtr == NULL) {
+	    return NULL;
+	}
+	return Block2Ptr(blockPtr, NBUCKETS, reqsize);
+    }
+
+    /*
+     * Finally, perform an expensive malloc/copy/free.
+     */
+
+    new = TclpAlloc(reqsize);
+    if (new != NULL) {
+	if (reqsize > blockPtr->b_reqsize) {
+	    reqsize = blockPtr->b_reqsize;
+	}
+    	memcpy(new, ptr, reqsize);
+    	TclpFree(ptr);
+    }
+    return new;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclThreadAllocObj --
+ *
+ *	Allocate a Tcl_Obj from the per-thread cache.
+ *
+ * Results:
+ *	Pointer to uninitialized Tcl_Obj.
+ *
+ * Side effects:
+ *	May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's
+ *  	if list is empty.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclThreadAllocObj(void)
+{
+    register Cache *cachePtr = TclpGetAllocCache();
+    register int nmove;
+    register Tcl_Obj *objPtr;
+    Tcl_Obj *newObjsPtr;
+
+    if (cachePtr == NULL) {
+	cachePtr = GetCache();
+    }
+
+    /*
+     * Get this thread's obj list structure and move
+     * or allocate new objs if necessary.
+     */
+
+    if (cachePtr->nobjs == 0) {
+    	Tcl_MutexLock(objLockPtr);
+	nmove = sharedPtr->nobjs;
+	if (nmove > 0) {
+	    if (nmove > NOBJALLOC) {
+		nmove = NOBJALLOC;
+	    }
+	    MoveObjs(sharedPtr, cachePtr, nmove);
+	}
+    	Tcl_MutexUnlock(objLockPtr);
+	if (cachePtr->nobjs == 0) {
+	    cachePtr->nobjs = nmove = NOBJALLOC;
+	    newObjsPtr = malloc(sizeof(Tcl_Obj) * nmove);
+	    if (newObjsPtr == NULL) {
+		panic("alloc: could not allocate %d new objects", nmove);
+	    }
+	    while (--nmove >= 0) {
+		objPtr = &newObjsPtr[nmove];
+		objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
+		cachePtr->firstObjPtr = objPtr;
+	    }
+	}
+    }
+
+    /*
+     * Pop the first object.
+     */
+
+    objPtr = cachePtr->firstObjPtr;
+    cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
+    --cachePtr->nobjs;
+    return objPtr;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclThreadFreeObj --
+ *
+ *	Return a free Tcl_Obj to the per-thread cache.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May move free Tcl_Obj's to shared list upon hitting high
+ *  	water mark.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclThreadFreeObj(Tcl_Obj *objPtr)
+{
+    Cache *cachePtr = TclpGetAllocCache();
+
+    if (cachePtr == NULL) {
+	cachePtr = GetCache();
+    }
+
+    /*
+     * Get this thread's list and push on the free Tcl_Obj.
+     */
+
+    objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
+    cachePtr->firstObjPtr = objPtr;
+    ++cachePtr->nobjs;
+
+    /*
+     * If the number of free objects has exceeded the high
+     * water mark, move some blocks to the shared list.
+     */
+
+    if (cachePtr->nobjs > NOBJHIGH) {
+	Tcl_MutexLock(objLockPtr);
+	MoveObjs(cachePtr, sharedPtr, NOBJALLOC);
+	Tcl_MutexUnlock(objLockPtr);
+    }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetMemoryInfo --
+ *
+ *	Return a list-of-lists of memory stats.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *  	List appended to given dstring.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
+{
+    Cache *cachePtr;
+    char buf[200];
+    int n;
+
+    Tcl_MutexLock(listLockPtr);
+    cachePtr = firstCachePtr;
+    while (cachePtr != NULL) {
+	Tcl_DStringStartSublist(dsPtr);
+	if (cachePtr == sharedPtr) {
+    	    Tcl_DStringAppendElement(dsPtr, "shared");
+	} else {
+	    sprintf(buf, "thread%d", (int) cachePtr->owner);
+    	    Tcl_DStringAppendElement(dsPtr, buf);
+	}
+	for (n = 0; n < NBUCKETS; ++n) {
+    	    sprintf(buf, "%d %d %d %d %d %d %d",
+		(int) binfo[n].blocksize,
+		cachePtr->buckets[n].nfree,
+		cachePtr->buckets[n].nget,
+		cachePtr->buckets[n].nput,
+		cachePtr->buckets[n].nrequest,
+		cachePtr->buckets[n].nlock,
+		cachePtr->buckets[n].nwait);
+	    Tcl_DStringAppendElement(dsPtr, buf);
+	}
+	Tcl_DStringEndSublist(dsPtr);
+	    cachePtr = cachePtr->nextPtr;
+    }
+    Tcl_MutexUnlock(listLockPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MoveObjs --
+ *
+ *	Move Tcl_Obj's between caches.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *  	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MoveObjs(Cache *fromPtr, Cache *toPtr, int nmove)
+{
+    register Tcl_Obj *objPtr = fromPtr->firstObjPtr;
+    Tcl_Obj *fromFirstObjPtr = objPtr;
+
+    toPtr->nobjs += nmove;
+    fromPtr->nobjs -= nmove;
+
+    /*
+     * Find the last object to be moved; set the next one
+     * (the first one not to be moved) as the first object
+     * in the 'from' cache.
+     */
+
+    while (--nmove) {
+	objPtr = objPtr->internalRep.otherValuePtr;
+    }
+    fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
+
+    /*
+     * Move all objects as a block - they are already linked to
+     * each other, we just have to update the first and last.
+     */
+
+    objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;
+    toPtr->firstObjPtr = fromFirstObjPtr;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  Block2Ptr, Ptr2Block --
+ *
+ *	Convert between internal blocks and user pointers.
+ *
+ * Results:
+ *	User pointer or internal block.
+ *
+ * Side effects:
+ *	Invalid blocks will abort the server.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+Block2Ptr(Block *blockPtr, int bucket, unsigned int reqsize)
+{
+    register void *ptr;
+
+    blockPtr->b_magic1 = blockPtr->b_magic2 = MAGIC;
+    blockPtr->b_bucket = bucket;
+    blockPtr->b_reqsize = reqsize;
+    ptr = ((void *) (blockPtr + 1));
+#if RCHECK
+    ((unsigned char *)(ptr))[reqsize] = MAGIC;
+#endif
+    return (char *) ptr;
+}
+
+static Block *
+Ptr2Block(char *ptr)
+{
+    register Block *blockPtr;
+
+    blockPtr = (((Block *) ptr) - 1);
+    if (blockPtr->b_magic1 != MAGIC
+#if RCHECK
+	|| ((unsigned char *) ptr)[blockPtr->b_reqsize] != MAGIC
+#endif
+	|| blockPtr->b_magic2 != MAGIC) {
+	panic("alloc: invalid block: %p: %x %x %x\n",
+	    blockPtr, blockPtr->b_magic1, blockPtr->b_magic2,
+	    ((unsigned char *) ptr)[blockPtr->b_reqsize]);
+    }
+    return blockPtr;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  LockBucket, UnlockBucket --
+ *
+ *	Set/unset the lock to access a bucket in the shared cache.
+ *
+ * Results:
+ *  	None.
+ *
+ * Side effects:
+ *	Lock activity and contention are monitored globally and on
+ *  	a per-cache basis.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+LockBucket(Cache *cachePtr, int bucket)
+{
+#if 0
+    if (Tcl_MutexTryLock(binfo[bucket].lockPtr) != TCL_OK) {
+	Tcl_MutexLock(binfo[bucket].lockPtr);
+    	++cachePtr->buckets[bucket].nwait;
+    	++sharedPtr->buckets[bucket].nwait;
+    }
+#else
+    Tcl_MutexLock(binfo[bucket].lockPtr);
+#endif
+    ++cachePtr->buckets[bucket].nlock;
+    ++sharedPtr->buckets[bucket].nlock;
+}
+
+
+static void
+UnlockBucket(Cache *cachePtr, int bucket)
+{
+    Tcl_MutexUnlock(binfo[bucket].lockPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  PutBlocks --
+ *
+ *	Return unused blocks to the shared cache.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PutBlocks(Cache *cachePtr, int bucket, int nmove)
+{
+    register Block *lastPtr, *firstPtr;
+    register int n = nmove;
+
+    /*
+     * Before acquiring the lock, walk the block list to find
+     * the last block to be moved.
+     */
+
+    firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr;
+    while (--n > 0) {
+	lastPtr = lastPtr->b_next;
+    }
+    cachePtr->buckets[bucket].firstPtr = lastPtr->b_next;
+    cachePtr->buckets[bucket].nfree -= nmove;
+
+    /*
+     * Aquire the lock and place the list of blocks at the front
+     * of the shared cache bucket.
+     */
+
+    LockBucket(cachePtr, bucket);
+    lastPtr->b_next = sharedPtr->buckets[bucket].firstPtr;
+    sharedPtr->buckets[bucket].firstPtr = firstPtr;
+    sharedPtr->buckets[bucket].nfree += nmove;
+    UnlockBucket(cachePtr, bucket);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  GetBlocks --
+ *
+ *	Get more blocks for a bucket.
+ *
+ * Results:
+ *	1 if blocks where allocated, 0 otherwise.
+ *
+ * Side effects:
+ *	Cache may be filled with available blocks.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetBlocks(Cache *cachePtr, int bucket)
+{
+    register Block *blockPtr;
+    register int n;
+    register size_t size;
+
+    /*
+     * First, atttempt to move blocks from the shared cache.  Note
+     * the potentially dirty read of nfree before acquiring the lock
+     * which is a slight performance enhancement.  The value is
+     * verified after the lock is actually acquired.
+     */
+
+    if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].nfree > 0) {
+	LockBucket(cachePtr, bucket);
+	if (sharedPtr->buckets[bucket].nfree > 0) {
+
+	    /*
+	     * Either move the entire list or walk the list to find
+	     * the last block to move.
+	     */
+
+	    n = binfo[bucket].nmove;
+	    if (n >= sharedPtr->buckets[bucket].nfree) {
+		cachePtr->buckets[bucket].firstPtr =
+		    sharedPtr->buckets[bucket].firstPtr;
+		cachePtr->buckets[bucket].nfree =
+		    sharedPtr->buckets[bucket].nfree;
+		sharedPtr->buckets[bucket].firstPtr = NULL;
+		sharedPtr->buckets[bucket].nfree = 0;
+	    } else {
+		blockPtr = sharedPtr->buckets[bucket].firstPtr;
+		cachePtr->buckets[bucket].firstPtr = blockPtr;
+		sharedPtr->buckets[bucket].nfree -= n;
+		cachePtr->buckets[bucket].nfree = n;
+		while (--n > 0) {
+    		    blockPtr = blockPtr->b_next;
+		}
+		sharedPtr->buckets[bucket].firstPtr = blockPtr->b_next;
+		blockPtr->b_next = NULL;
+	    }
+	}
+	UnlockBucket(cachePtr, bucket);
+    }
+
+    if (cachePtr->buckets[bucket].nfree == 0) {
+
+	/*
+	 * If no blocks could be moved from shared, first look for a
+	 * larger block in this cache to split up.
+	 */
+
+    	blockPtr = NULL;
+	n = NBUCKETS;
+	size = 0; /* lint */
+	while (--n > bucket) {
+    	    if (cachePtr->buckets[n].nfree > 0) {
+		size = binfo[n].blocksize;
+		blockPtr = cachePtr->buckets[n].firstPtr;
+		cachePtr->buckets[n].firstPtr = blockPtr->b_next;
+		--cachePtr->buckets[n].nfree;
+		break;
+	    }
+	}
+
+	/*
+	 * Otherwise, allocate a big new block directly.
+	 */
+
+	if (blockPtr == NULL) {
+	    size = MAXALLOC;
+	    blockPtr = malloc(size);
+	    if (blockPtr == NULL) {
+		return 0;
+	    }
+	}
+
+	/*
+	 * Split the larger block into smaller blocks for this bucket.
+	 */
+
+	n = size / binfo[bucket].blocksize;
+	cachePtr->buckets[bucket].nfree = n;
+	cachePtr->buckets[bucket].firstPtr = blockPtr;
+	while (--n > 0) {
+	    blockPtr->b_next = (Block *)
+		((char *) blockPtr + binfo[bucket].blocksize);
+	    blockPtr = blockPtr->b_next;
+	}
+	blockPtr->b_next = NULL;
+    }
+    return 1;
+}
+
+#endif /* TCL_THREADS */
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
index 38fd50d..19acfe0 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -1,449 +1,449 @@
-/*

- * tclAppInit.c --

- *

- *	Provides a default version of the main program and Tcl_AppInit

- *	procedure for Tcl applications (without Tk).  Note that this

- *	program must be built in Win32 console mode to work properly.

- *

- * Copyright (c) 1996-1997 by Sun Microsystems, Inc.

- * Copyright (c) 1998-1999 by Scriptics Corporation.

- *

- * See the file "license.terms" for information on usage and redistribution

- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

- *

- * RCS: @(#) $Id: tclAppInit.c,v 1.12 2003/05/10 02:52:54 mistachkin Exp $

- */

-

-#include "tcl.h"

-#include <windows.h>

-#include <locale.h>

-

-#ifdef TCL_TEST

-extern int		Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp));

-extern int		Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));

-extern int		Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));

-extern int		TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));

-#ifdef TCL_THREADS

-extern int		TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));

-#endif

-#endif /* TCL_TEST */

-

-static void		setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));

-static BOOL __stdcall	sigHandler (DWORD fdwCtrlType);

-static Tcl_AsyncProc	asyncExit;

-static void		AppInitExitHandler(ClientData clientData);

-

-static char **          argvSave = NULL;

-static Tcl_AsyncHandler exitToken = NULL;

-static DWORD            exitErrorCode = 0;

-

-

-/*

- *----------------------------------------------------------------------

- *

- * main --

- *

- *	This is the main program for the application.

- *

- * Results:

- *	None: Tcl_Main never returns here, so this procedure never

- *	returns either.

- *

- * Side effects:

- *	Whatever the application does.

- *

- *----------------------------------------------------------------------

- */

-

-int

-main(argc, argv)

-    int argc;			/* Number of command-line arguments. */

-    char **argv;		/* Values of command-line arguments. */

-{

-    /*

-     * The following #if block allows you to change the AppInit

-     * function by using a #define of TCL_LOCAL_APPINIT instead

-     * of rewriting this entire file.  The #if checks for that

-     * #define and uses Tcl_AppInit if it doesn't exist.

-     */

-

-#ifndef TCL_LOCAL_APPINIT

-#define TCL_LOCAL_APPINIT Tcl_AppInit

-#endif

-    extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));

-

-    /*

-     * The following #if block allows you to change how Tcl finds the startup

-     * script, prime the library or encoding paths, fiddle with the argv,

-     * etc., without needing to rewrite Tcl_Main()

-     */

-

-#ifdef TCL_LOCAL_MAIN_HOOK

-    extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv));

-#endif

-

-    char buffer[MAX_PATH +1];

-    char *p;

-    /*

-     * Set up the default locale to be standard "C" locale so parsing

-     * is performed correctly.

-     */

-

-    setlocale(LC_ALL, "C");

-    setargv(&argc, &argv);

-

-    /*

-     * Save this for later, so we can free it.

-     */

-    argvSave = argv;

-

-    /*

-     * Replace argv[0] with full pathname of executable, and forward

-     * slashes substituted for backslashes.

-     */

-

-    GetModuleFileName(NULL, buffer, sizeof(buffer));

-    argv[0] = buffer;

-    for (p = buffer; *p != '\0'; p++) {

-	if (*p == '\\') {

-	    *p = '/';

-	}

-    }

-

-#ifdef TCL_LOCAL_MAIN_HOOK

-    TCL_LOCAL_MAIN_HOOK(&argc, &argv);

-#endif

-

-    Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);

-

-    return 0;			/* Needed only to prevent compiler warning. */

-}

-

-

-/*

- *----------------------------------------------------------------------

- *

- * Tcl_AppInit --

- *

- *	This procedure performs application-specific initialization.

- *	Most applications, especially those that incorporate additional

- *	packages, will have their own version of this procedure.

- *

- * Results:

- *	Returns a standard Tcl completion code, and leaves an error

- *	message in the interp's result if an error occurs.

- *

- * Side effects:

- *	Depends on the startup script.

- *

- *----------------------------------------------------------------------

- */

-

-int

-Tcl_AppInit(interp)

-    Tcl_Interp *interp;		/* Interpreter for application. */

-{

-    if (Tcl_Init(interp) == TCL_ERROR) {

-	return TCL_ERROR;

-    }

-

-    /*

-     * Install a signal handler to the win32 console tclsh is running in.

-     */

-    SetConsoleCtrlHandler(sigHandler, TRUE);

-    exitToken = Tcl_AsyncCreate(asyncExit, NULL);

-

-    /*

-     * This exit handler will be used to free the

-     * resources allocated in this file.

-     */

-    Tcl_CreateExitHandler(AppInitExitHandler, NULL);

-

-#ifdef TCL_TEST

-    if (Tcltest_Init(interp) == TCL_ERROR) {

-	return TCL_ERROR;

-    }

-    Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,

-            (Tcl_PackageInitProc *) NULL);

-    if (TclObjTest_Init(interp) == TCL_ERROR) {

-	return TCL_ERROR;

-    }

-#ifdef TCL_THREADS

-    if (TclThread_Init(interp) == TCL_ERROR) {

-	return TCL_ERROR;

-    }

-#endif

-    if (Procbodytest_Init(interp) == TCL_ERROR) {

-	return TCL_ERROR;

-    }

-    Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,

-            Procbodytest_SafeInit);

-#endif /* TCL_TEST */

-

-#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES)

-    {

-	extern Tcl_PackageInitProc Registry_Init;

-	extern Tcl_PackageInitProc Dde_Init;

-

-	if (Registry_Init(interp) == TCL_ERROR) {

-	    return TCL_ERROR;

-	}

-	Tcl_StaticPackage(interp, "registry", Registry_Init, NULL);

-

-	if (Dde_Init(interp) == TCL_ERROR) {

-	    return TCL_ERROR;

-	}

-	Tcl_StaticPackage(interp, "dde", Dde_Init, NULL);

-   }

-#endif

-

-    /*

-     * Call the init procedures for included packages.  Each call should

-     * look like this:

-     *

-     * if (Mod_Init(interp) == TCL_ERROR) {

-     *     return TCL_ERROR;

-     * }

-     *

-     * where "Mod" is the name of the module.

-     */

-

-    /*

-     * Call Tcl_CreateCommand for application-specific commands, if

-     * they weren't already created by the init procedures called above.

-     */

-

-    /*

-     * Specify a user-specific startup file to invoke if the application

-     * is run interactively.  Typically the startup file is "~/.apprc"

-     * where "app" is the name of the application.  If this line is deleted

-     * then no user-specific startup file will be run under any conditions.

-     */

-

-    Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);

-    return TCL_OK;

-}

-

-/*

- *----------------------------------------------------------------------

- *

- * AppInitExitHandler --

- *

- *	This function is called to cleanup the app init resources before

- *	Tcl is unloaded.

- *

- * Results:

- *	None.

- *

- * Side effects:

- *	Frees the saved argv and deletes the async exit handler.

- *

- *----------------------------------------------------------------------

- */

-

-static void

-AppInitExitHandler(

-    ClientData clientData)

-{

-    if (argvSave != NULL) {

-        ckfree((char *)argvSave);

-        argvSave = NULL;

-    }

-

-    if (exitToken != NULL) {

-        /*

-         * This should be safe to do even if we

-         * are in an async exit right now.

-         */

-        Tcl_AsyncDelete(exitToken);

-        exitToken = NULL;

-    }

-}

-

-/*

- *-------------------------------------------------------------------------

- *

- * setargv --

- *

- *	Parse the Windows command line string into argc/argv.  Done here

- *	because we don't trust the builtin argument parser in crt0.

- *	Windows applications are responsible for breaking their command

- *	line into arguments.

- *

- *	2N backslashes + quote -> N backslashes + begin quoted string

- *	2N + 1 backslashes + quote -> literal

- *	N backslashes + non-quote -> literal

- *	quote + quote in a quoted string -> single quote

- *	quote + quote not in quoted string -> empty string

- *	quote -> begin quoted string

- *

- * Results:

- *	Fills argcPtr with the number of arguments and argvPtr with the

- *	array of arguments.

- *

- * Side effects:

- *	Memory allocated.

- *

- *--------------------------------------------------------------------------

- */

-

-static void

-setargv(argcPtr, argvPtr)

-    int *argcPtr;		/* Filled with number of argument strings. */

-    char ***argvPtr;		/* Filled with argument strings (malloc'd). */

-{

-    char *cmdLine, *p, *arg, *argSpace;

-    char **argv;

-    int argc, size, inquote, copy, slashes;

-

-    cmdLine = GetCommandLine();	/* INTL: BUG */

-

-    /*

-     * Precompute an overly pessimistic guess at the number of arguments

-     * in the command line by counting non-space spans.

-     */

-

-    size = 2;

-    for (p = cmdLine; *p != '\0'; p++) {

-	if ((*p == ' ') || (*p == '\t')) {	/* INTL: ISO space. */

-	    size++;

-	    while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */

-		p++;

-	    }

-	    if (*p == '\0') {

-		break;

-	    }

-	}

-    }

-    argSpace = (char *) Tcl_Alloc(

-	    (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));

-    argv = (char **) argSpace;

-    argSpace += size * sizeof(char *);

-    size--;

-

-    p = cmdLine;

-    for (argc = 0; argc < size; argc++) {

-	argv[argc] = arg = argSpace;

-	while ((*p == ' ') || (*p == '\t')) {	/* INTL: ISO space. */

-	    p++;

-	}

-	if (*p == '\0') {

-	    break;

-	}

-

-	inquote = 0;

-	slashes = 0;

-	while (1) {

-	    copy = 1;

-	    while (*p == '\\') {

-		slashes++;

-		p++;

-	    }

-	    if (*p == '"') {

-		if ((slashes & 1) == 0) {

-		    copy = 0;

-		    if ((inquote) && (p[1] == '"')) {

-			p++;

-			copy = 1;

-		    } else {

-			inquote = !inquote;

-		    }

-                }

-                slashes >>= 1;

-            }

-

-            while (slashes) {

-		*arg = '\\';

-		arg++;

-		slashes--;

-	    }

-

-	    if ((*p == '\0')

-		    || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */

-		break;

-	    }

-	    if (copy != 0) {

-		*arg = *p;

-		arg++;

-	    }

-	    p++;

-        }

-	*arg = '\0';

-	argSpace = arg + 1;

-    }

-    argv[argc] = NULL;

-

-    *argcPtr = argc;

-    *argvPtr = argv;

-}

-

-/*

- *----------------------------------------------------------------------

- *

- * asyncExit --

- *

- * 	The AsyncProc for the exitToken.

- *

- * Results:

- * 	doesn't actually return.

- *

- * Side effects:

- * 	tclsh cleanly exits.

- *

- *----------------------------------------------------------------------

- */

-

-int

-asyncExit (ClientData clientData, Tcl_Interp *interp, int code)

-{

-    Tcl_Exit((int)exitErrorCode);

-

-    /* NOTREACHED */

-    return code;

-}

-

-/*

- *----------------------------------------------------------------------

- *

- * sigHandler --

- *

- *	Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and

- *	other exits. This is needed so tclsh can do it's real clean-up

- *	and not an unclean crash terminate.

- *

- * Results:

- *	TRUE.

- *

- * Side effects:

- *	Effects the way the app exits from a signal. This is an

- *	operating system supplied thread and unsafe to call ANY

- *	Tcl commands except for Tcl_AsyncMark.

- *

- *----------------------------------------------------------------------

- */

-

-BOOL __stdcall

-sigHandler(DWORD fdwCtrlType)

-{

-    HANDLE hStdIn;

-    /*

-     * If Tcl is currently executing some bytecode or in the eventloop,

-     * this will cause Tcl to enter asyncExit at the next command

-     * boundry.

-     */

-    exitErrorCode = fdwCtrlType;

-    Tcl_AsyncMark(exitToken);

-

-    /*

-     * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF>

-     * should it be blocked on input and our Tcl_AsyncMark didn't grab

-     * the attention of the interpreter.

-     */

-    hStdIn = GetStdHandle(STD_INPUT_HANDLE);

-    if (hStdIn) {

-	CloseHandle(hStdIn);

-    }

-

-    /* indicate to the OS not to call the default terminator */

-    return TRUE;

-}

+/*
+ * tclAppInit.c --
+ *
+ *	Provides a default version of the main program and Tcl_AppInit
+ *	procedure for Tcl applications (without Tk).  Note that this
+ *	program must be built in Win32 console mode to work properly.
+ *
+ * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclAppInit.c,v 1.13 2003/05/10 04:25:49 mistachkin Exp $
+ */
+
+#include "tcl.h"
+#include <windows.h>
+#include <locale.h>
+
+#ifdef TCL_TEST
+extern int		Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+extern int		Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));
+extern int		Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+extern int		TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#ifdef TCL_THREADS
+extern int		TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#endif
+#endif /* TCL_TEST */
+
+static void		setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
+static BOOL __stdcall	sigHandler (DWORD fdwCtrlType);
+static Tcl_AsyncProc	asyncExit;
+static void		AppInitExitHandler(ClientData clientData);
+
+static char **          argvSave = NULL;
+static Tcl_AsyncHandler exitToken = NULL;
+static DWORD            exitErrorCode = 0;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * main --
+ *
+ *	This is the main program for the application.
+ *
+ * Results:
+ *	None: Tcl_Main never returns here, so this procedure never
+ *	returns either.
+ *
+ * Side effects:
+ *	Whatever the application does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+main(argc, argv)
+    int argc;			/* Number of command-line arguments. */
+    char **argv;		/* Values of command-line arguments. */
+{
+    /*
+     * The following #if block allows you to change the AppInit
+     * function by using a #define of TCL_LOCAL_APPINIT instead
+     * of rewriting this entire file.  The #if checks for that
+     * #define and uses Tcl_AppInit if it doesn't exist.
+     */
+
+#ifndef TCL_LOCAL_APPINIT
+#define TCL_LOCAL_APPINIT Tcl_AppInit
+#endif
+    extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));
+
+    /*
+     * The following #if block allows you to change how Tcl finds the startup
+     * script, prime the library or encoding paths, fiddle with the argv,
+     * etc., without needing to rewrite Tcl_Main()
+     */
+
+#ifdef TCL_LOCAL_MAIN_HOOK
+    extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv));
+#endif
+
+    char buffer[MAX_PATH +1];
+    char *p;
+    /*
+     * Set up the default locale to be standard "C" locale so parsing
+     * is performed correctly.
+     */
+
+    setlocale(LC_ALL, "C");
+    setargv(&argc, &argv);
+
+    /*
+     * Save this for later, so we can free it.
+     */
+    argvSave = argv;
+
+    /*
+     * Replace argv[0] with full pathname of executable, and forward
+     * slashes substituted for backslashes.
+     */
+
+    GetModuleFileName(NULL, buffer, sizeof(buffer));
+    argv[0] = buffer;
+    for (p = buffer; *p != '\0'; p++) {
+	if (*p == '\\') {
+	    *p = '/';
+	}
+    }
+
+#ifdef TCL_LOCAL_MAIN_HOOK
+    TCL_LOCAL_MAIN_HOOK(&argc, &argv);
+#endif
+
+    Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
+
+    return 0;			/* Needed only to prevent compiler warning. */
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppInit --
+ *
+ *	This procedure performs application-specific initialization.
+ *	Most applications, especially those that incorporate additional
+ *	packages, will have their own version of this procedure.
+ *
+ * Results:
+ *	Returns a standard Tcl completion code, and leaves an error
+ *	message in the interp's result if an error occurs.
+ *
+ * Side effects:
+ *	Depends on the startup script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AppInit(interp)
+    Tcl_Interp *interp;		/* Interpreter for application. */
+{
+    if (Tcl_Init(interp) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Install a signal handler to the win32 console tclsh is running in.
+     */
+    SetConsoleCtrlHandler(sigHandler, TRUE);
+    exitToken = Tcl_AsyncCreate(asyncExit, NULL);
+
+    /*
+     * This exit handler will be used to free the
+     * resources allocated in this file.
+     */
+    Tcl_CreateExitHandler(AppInitExitHandler, NULL);
+
+#ifdef TCL_TEST
+    if (Tcltest_Init(interp) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+    Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
+            (Tcl_PackageInitProc *) NULL);
+    if (TclObjTest_Init(interp) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+#ifdef TCL_THREADS
+    if (TclThread_Init(interp) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+#endif
+    if (Procbodytest_Init(interp) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+    Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
+            Procbodytest_SafeInit);
+#endif /* TCL_TEST */
+
+#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES)
+    {
+	extern Tcl_PackageInitProc Registry_Init;
+	extern Tcl_PackageInitProc Dde_Init;
+
+	if (Registry_Init(interp) == TCL_ERROR) {
+	    return TCL_ERROR;
+	}
+	Tcl_StaticPackage(interp, "registry", Registry_Init, NULL);
+
+	if (Dde_Init(interp) == TCL_ERROR) {
+	    return TCL_ERROR;
+	}
+	Tcl_StaticPackage(interp, "dde", Dde_Init, NULL);
+   }
+#endif
+
+    /*
+     * Call the init procedures for included packages.  Each call should
+     * look like this:
+     *
+     * if (Mod_Init(interp) == TCL_ERROR) {
+     *     return TCL_ERROR;
+     * }
+     *
+     * where "Mod" is the name of the module.
+     */
+
+    /*
+     * Call Tcl_CreateCommand for application-specific commands, if
+     * they weren't already created by the init procedures called above.
+     */
+
+    /*
+     * Specify a user-specific startup file to invoke if the application
+     * is run interactively.  Typically the startup file is "~/.apprc"
+     * where "app" is the name of the application.  If this line is deleted
+     * then no user-specific startup file will be run under any conditions.
+     */
+
+    Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AppInitExitHandler --
+ *
+ *	This function is called to cleanup the app init resources before
+ *	Tcl is unloaded.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Frees the saved argv and deletes the async exit handler.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AppInitExitHandler(
+    ClientData clientData)
+{
+    if (argvSave != NULL) {
+        ckfree((char *)argvSave);
+        argvSave = NULL;
+    }
+
+    if (exitToken != NULL) {
+        /*
+         * This should be safe to do even if we
+         * are in an async exit right now.
+         */
+        Tcl_AsyncDelete(exitToken);
+        exitToken = NULL;
+    }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * setargv --
+ *
+ *	Parse the Windows command line string into argc/argv.  Done here
+ *	because we don't trust the builtin argument parser in crt0.
+ *	Windows applications are responsible for breaking their command
+ *	line into arguments.
+ *
+ *	2N backslashes + quote -> N backslashes + begin quoted string
+ *	2N + 1 backslashes + quote -> literal
+ *	N backslashes + non-quote -> literal
+ *	quote + quote in a quoted string -> single quote
+ *	quote + quote not in quoted string -> empty string
+ *	quote -> begin quoted string
+ *
+ * Results:
+ *	Fills argcPtr with the number of arguments and argvPtr with the
+ *	array of arguments.
+ *
+ * Side effects:
+ *	Memory allocated.
+ *
+ *--------------------------------------------------------------------------
+ */
+
+static void
+setargv(argcPtr, argvPtr)
+    int *argcPtr;		/* Filled with number of argument strings. */
+    char ***argvPtr;		/* Filled with argument strings (malloc'd). */
+{
+    char *cmdLine, *p, *arg, *argSpace;
+    char **argv;
+    int argc, size, inquote, copy, slashes;
+
+    cmdLine = GetCommandLine();	/* INTL: BUG */
+
+    /*
+     * Precompute an overly pessimistic guess at the number of arguments
+     * in the command line by counting non-space spans.
+     */
+
+    size = 2;
+    for (p = cmdLine; *p != '\0'; p++) {
+	if ((*p == ' ') || (*p == '\t')) {	/* INTL: ISO space. */
+	    size++;
+	    while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
+		p++;
+	    }
+	    if (*p == '\0') {
+		break;
+	    }
+	}
+    }
+    argSpace = (char *) Tcl_Alloc(
+	    (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));
+    argv = (char **) argSpace;
+    argSpace += size * sizeof(char *);
+    size--;
+
+    p = cmdLine;
+    for (argc = 0; argc < size; argc++) {
+	argv[argc] = arg = argSpace;
+	while ((*p == ' ') || (*p == '\t')) {	/* INTL: ISO space. */
+	    p++;
+	}
+	if (*p == '\0') {
+	    break;
+	}
+
+	inquote = 0;
+	slashes = 0;
+	while (1) {
+	    copy = 1;
+	    while (*p == '\\') {
+		slashes++;
+		p++;
+	    }
+	    if (*p == '"') {
+		if ((slashes & 1) == 0) {
+		    copy = 0;
+		    if ((inquote) && (p[1] == '"')) {
+			p++;
+			copy = 1;
+		    } else {
+			inquote = !inquote;
+		    }
+                }
+                slashes >>= 1;
+            }
+
+            while (slashes) {
+		*arg = '\\';
+		arg++;
+		slashes--;
+	    }
+
+	    if ((*p == '\0')
+		    || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
+		break;
+	    }
+	    if (copy != 0) {
+		*arg = *p;
+		arg++;
+	    }
+	    p++;
+        }
+	*arg = '\0';
+	argSpace = arg + 1;
+    }
+    argv[argc] = NULL;
+
+    *argcPtr = argc;
+    *argvPtr = argv;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * asyncExit --
+ *
+ * 	The AsyncProc for the exitToken.
+ *
+ * Results:
+ * 	doesn't actually return.
+ *
+ * Side effects:
+ * 	tclsh cleanly exits.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+asyncExit (ClientData clientData, Tcl_Interp *interp, int code)
+{
+    Tcl_Exit((int)exitErrorCode);
+
+    /* NOTREACHED */
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * sigHandler --
+ *
+ *	Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and
+ *	other exits. This is needed so tclsh can do it's real clean-up
+ *	and not an unclean crash terminate.
+ *
+ * Results:
+ *	TRUE.
+ *
+ * Side effects:
+ *	Effects the way the app exits from a signal. This is an
+ *	operating system supplied thread and unsafe to call ANY
+ *	Tcl commands except for Tcl_AsyncMark.
+ *
+ *----------------------------------------------------------------------
+ */
+
+BOOL __stdcall
+sigHandler(DWORD fdwCtrlType)
+{
+    HANDLE hStdIn;
+    /*
+     * If Tcl is currently executing some bytecode or in the eventloop,
+     * this will cause Tcl to enter asyncExit at the next command
+     * boundry.
+     */
+    exitErrorCode = fdwCtrlType;
+    Tcl_AsyncMark(exitToken);
+
+    /*
+     * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF>
+     * should it be blocked on input and our Tcl_AsyncMark didn't grab
+     * the attention of the interpreter.
+     */
+    hStdIn = GetStdHandle(STD_INPUT_HANDLE);
+    if (hStdIn) {
+	CloseHandle(hStdIn);
+    }
+
+    /* indicate to the OS not to call the default terminator */
+    return TRUE;
+}