diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclAlloc.c | 225 | ||||
| -rw-r--r-- | generic/tclAsync.c | 177 | ||||
| -rw-r--r-- | generic/tclCkalloc.c | 478 | ||||
| -rw-r--r-- | generic/tclIOSock.c | 33 | ||||
| -rw-r--r-- | generic/tclPanic.c | 40 | ||||
| -rw-r--r-- | generic/tclPkg.c | 836 | ||||
| -rw-r--r-- | generic/tclPosixStr.c | 758 | ||||
| -rw-r--r-- | generic/tclThreadJoin.c | 301 | ||||
| -rw-r--r-- | generic/tclThreadStorage.c | 286 |
9 files changed, 1599 insertions, 1535 deletions
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 8c1218d..fcdd75d 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -1,10 +1,10 @@ -/* +/* * tclAlloc.c -- * - * This is a very fast storage allocator. It allocates blocks of a - * small number of different sizes, and keeps free lists of each size. - * Blocks that don't exactly fit are passed up to the next larger size. - * Blocks over a certain size are directly allocated from the system. + * This is a very fast storage allocator. It allocates blocks of a small + * number of different sizes, and keeps free lists of each size. Blocks + * that don't exactly fit are passed up to the next larger size. Blocks + * over a certain size are directly allocated from the system. * * Copyright (c) 1983 Regents of the University of California. * Copyright (c) 1996-1997 Sun Microsystems, Inc. @@ -12,10 +12,10 @@ * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAlloc.c,v 1.21 2004/10/06 12:44:52 dkf Exp $ + * RCS: @(#) $Id: tclAlloc.c,v 1.22 2005/07/19 22:45:18 dkf Exp $ */ /* @@ -35,36 +35,37 @@ #endif /* - * We should really make use of AC_CHECK_TYPE(caddr_t) - * here, but it can wait until Tcl uses config.h properly. + * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait + * until Tcl uses config.h properly. */ + #if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) typedef unsigned long caddr_t; #endif /* - * The overhead on a block is at least 8 bytes. When free, this space - * contains a pointer to the next free block, and the bottom two bits must * be zero. When in use, the first byte is set to MAGIC, and the second - * byte is the size index. The remaining bytes are for alignment. - * If range checking is enabled then a second word holds the size of the - * requested block, less 1, rounded up to a multiple of sizeof(RMAGIC). - * The order of elements is critical: ov.magic must overlay the low order - * bits of ov.next, and ov.magic can not be a valid ov.next bit pattern. + * The overhead on a block is at least 8 bytes. When free, this space contains + * a pointer to the next free block, and the bottom two bits must be zero. + * When in use, the first byte is set to MAGIC, and the second byte is the + * size index. The remaining bytes are for alignment. If range checking is + * enabled then a second word holds the size of the requested block, less 1, + * rounded up to a multiple of sizeof(RMAGIC). The order of elements is + * critical: ov.magic must overlay the low order bits of ov.next, and ov.magic + * can not be a valid ov.next bit pattern. */ union overhead { - union overhead *next; /* when free */ - unsigned char padding[8]; /* Ensure the structure is 8-byte - * aligned. */ + union overhead *next; /* when free */ + unsigned char padding[8]; /* Ensure the structure is 8-byte aligned. */ struct { - unsigned char magic0; /* magic number */ - unsigned char index; /* bucket # */ - unsigned char unused; /* unused */ - unsigned char magic1; /* other magic number */ + unsigned char magic0; /* magic number */ + unsigned char index; /* bucket # */ + unsigned char unused; /* unused */ + unsigned char magic1; /* other magic number */ #ifdef RCHECK - unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ - unsigned short unused2; /* padding to 8-byte align */ + unsigned short rmagic; /* range magic number */ + unsigned long size; /* actual block size */ + unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; #define overMagic0 ovu.magic0 @@ -75,8 +76,8 @@ union overhead { }; -#define MAGIC 0xef /* magic # on accounting info */ -#define RMAGIC 0x5555 /* magic # on range info */ +#define MAGIC 0xef /* magic # on accounting info */ +#define RMAGIC 0x5555 /* magic # on range info */ #ifdef RCHECK #define RSLOP sizeof (unsigned short) @@ -94,37 +95,37 @@ union overhead { (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize)) /* - * nextf[i] is the pointer to the next free block of size 2^(i+3). The - * smallest allocatable block is 8 bytes. The overhead information - * precedes the data area returned to the user. + * nextf[i] is the pointer to the next free block of size 2^(i+3). The + * smallest allocatable block is 8 bytes. The overhead information precedes + * the data area returned to the user. */ #define NBUCKETS 13 #define MAXMALLOC (1<<(NBUCKETS+2)) -static union overhead *nextf[NBUCKETS]; +static union overhead *nextf[NBUCKETS]; -/* - * The following structure is used to keep track of all system memory - * currently owned by Tcl. When finalizing, all this memory will - * be returned to the system. +/* + * The following structure is used to keep track of all system memory + * currently owned by Tcl. When finalizing, all this memory will be returned + * to the system. */ struct block { struct block *nextPtr; /* Linked list. */ - struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte + struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte * alignment for suballocated blocks. */ }; -static struct block *blockList; /* Tracks the suballocated blocks. */ -static struct block bigBlocks = { /* Big blocks aren't suballocated. */ +static struct block *blockList; /* Tracks the suballocated blocks. */ +static struct block bigBlocks={ /* Big blocks aren't suballocated. */ &bigBlocks, &bigBlocks }; /* - * The allocator is protected by a special mutex that must be - * explicitly initialized. Futhermore, because Tcl_Alloc may be - * used before anything else in Tcl, we make this module self-initializing - * after all with the allocInit variable. + * The allocator is protected by a special mutex that must be explicitly + * initialized. Futhermore, because Tcl_Alloc may be used before anything else + * in Tcl, we make this module self-initializing after all with the allocInit + * variable. */ #ifdef TCL_THREADS @@ -132,12 +133,11 @@ static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; - #ifdef MSTATS /* - * numMallocs[i] is the difference between the number of mallocs and frees - * for a given block size. + * numMallocs[i] is the difference between the number of mallocs and frees for + * a given block size. */ static unsigned int numMallocs[NBUCKETS+1]; @@ -145,7 +145,7 @@ static unsigned int numMallocs[NBUCKETS+1]; #endif #if defined(DEBUG) || defined(RCHECK) -#define ASSERT(p) if (!(p)) Tcl_Panic(# p) +#define ASSERT(p) if (!(p)) Tcl_Panic(# p) #define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) #else #define ASSERT(p) @@ -157,7 +157,6 @@ static unsigned int numMallocs[NBUCKETS+1]; */ static void MoreCore _ANSI_ARGS_((int bucket)); - /* *------------------------------------------------------------------------- @@ -191,21 +190,20 @@ TclInitAlloc() * * TclFinalizeAllocSubsystem -- * - * Release all resources being used by this subsystem, including - * aggressively freeing all memory allocated by TclpAlloc() that - * has not yet been released with TclpFree(). - * - * After this function is called, all memory allocated with - * TclpAlloc() should be considered unusable. + * Release all resources being used by this subsystem, including + * aggressively freeing all memory allocated by TclpAlloc() that has not + * yet been released with TclpFree(). + * + * After this function is called, all memory allocated with TclpAlloc() + * should be considered unusable. * * Results: * None. * * Side effects: - * This subsystem is self-initializing, since memory can be - * allocated before Tcl is formally initialized. After this call, - * this subsystem has been reset to its initial state and is - * usable again. + * This subsystem is self-initializing, since memory can be allocated + * before Tcl is formally initialized. After this call, this subsystem + * has been reset to its initial state and is usable again. * *------------------------------------------------------------------------- */ @@ -231,7 +229,7 @@ TclFinalizeAllocSubsystem() bigBlocks.nextPtr = &bigBlocks; bigBlocks.prevPtr = &bigBlocks; - for (i = 0; i < NBUCKETS; i++) { + for (i=0 ; i<NBUCKETS ; i++) { nextf[i] = NULL; #ifdef MSTATS numMallocs[i] = 0; @@ -270,18 +268,20 @@ TclpAlloc(numBytes) if (!allocInit) { /* - * We have to make the "self initializing" because Tcl_Alloc - * may be used before any other part of Tcl. E.g., see - * main() for tclsh! + * We have to make the "self initializing" because Tcl_Alloc may be + * used before any other part of Tcl. E.g., see main() for tclsh! */ + TclInitAlloc(); } Tcl_MutexLock(allocMutexPtr); + /* - * First the simple case: we simple allocate big blocks directly + * First the simple case: we simple allocate big blocks directly. */ + if (numBytes + OVERHEAD >= MAXMALLOC) { - bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) + bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) (sizeof(struct block) + OVERHEAD + numBytes), 0); if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); @@ -298,23 +298,27 @@ TclpAlloc(numBytes) #ifdef MSTATS numMallocs[NBUCKETS]++; #endif + #ifdef RCHECK /* - * Record allocated size of block and - * bound space with magic numbers. + * Record allocated size of block and bound space with magic numbers. */ + overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif + Tcl_MutexUnlock(allocMutexPtr); return (void *)(overPtr+1); } + /* - * Convert amount of memory requested into closest block size - * stored in hash buckets which satisfies request. - * Account for space used per block for accounting. + * Convert amount of memory requested into closest block size stored in + * hash buckets which satisfies request. Account for space used per block + * for accounting. */ + #ifndef RCHECK amount = 8; /* size of first bucket */ bucket = 0; @@ -322,45 +326,52 @@ TclpAlloc(numBytes) amount = 16; /* size of first bucket */ bucket = 1; #endif + while (numBytes + OVERHEAD > amount) { amount <<= 1; if (amount == 0) { Tcl_MutexUnlock(allocMutexPtr); - return (NULL); + return NULL; } bucket++; } ASSERT(bucket < NBUCKETS); /* - * If nothing in hash bucket right now, - * request more memory from the system. + * If nothing in hash bucket right now, request more memory from the + * system. */ + if ((overPtr = nextf[bucket]) == NULL) { MoreCore(bucket); if ((overPtr = nextf[bucket]) == NULL) { Tcl_MutexUnlock(allocMutexPtr); - return (NULL); + return NULL; } } + /* * Remove from linked list */ + nextf[bucket] = overPtr->next; overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; overPtr->bucketIndex = (unsigned char) bucket; + #ifdef MSTATS numMallocs[bucket]++; #endif + #ifdef RCHECK /* - * Record allocated size of block and - * bound space with magic numbers. + * Record allocated size of block and bound space with magic numbers. */ + overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif + Tcl_MutexUnlock(allocMutexPtr); return ((char *)(overPtr + 1)); } @@ -394,9 +405,10 @@ MoreCore(bucket) struct block *blockPtr; /* - * sbrk_size <= 0 only for big, FLUFFY, requests (about - * 2^30 bytes on a VAX, I think) or for a negative arg. + * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a + * VAX, I think) or for a negative arg. */ + size = 1 << (bucket + 3); ASSERT(size > 0); @@ -404,7 +416,7 @@ MoreCore(bucket) numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc((unsigned) + blockPtr = (struct block *) TclpSysAlloc((unsigned) (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { @@ -414,11 +426,11 @@ MoreCore(bucket) blockList = blockPtr; overPtr = (union overhead *) (blockPtr + 1); - + /* - * Add new memory allocated to that on - * free list for this hash bucket. + * Add new memory allocated to that on free list for this hash bucket. */ + nextf[bucket] = overPtr; while (--numBlocks > 0) { overPtr->next = (union overhead *)((caddr_t)overPtr + size); @@ -446,7 +458,7 @@ MoreCore(bucket) void TclpFree(oldPtr) char *oldPtr; /* Pointer to memory to free. */ -{ +{ register long size; register union overhead *overPtr; struct block *bigBlockPtr; @@ -472,19 +484,23 @@ TclpFree(oldPtr) #ifdef MSTATS numMallocs[NBUCKETS]--; #endif + bigBlockPtr = (struct block *) overPtr - 1; bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr; TclpSysFree(bigBlockPtr); + Tcl_MutexUnlock(allocMutexPtr); return; } ASSERT(size < NBUCKETS); overPtr->next = nextf[size]; /* also clobbers overMagic */ nextf[size] = overPtr; + #ifdef MSTATS numMallocs[size]--; #endif + Tcl_MutexUnlock(allocMutexPtr); } @@ -508,7 +524,7 @@ char * TclpRealloc(oldPtr, numBytes) char *oldPtr; /* Pointer to alloced block. */ unsigned int numBytes; /* New size of memory. */ -{ +{ int i; union overhead *overPtr; struct block *bigBlockPtr; @@ -516,7 +532,7 @@ TclpRealloc(oldPtr, numBytes) unsigned long maxSize; if (oldPtr == NULL) { - return (TclpAlloc(numBytes)); + return TclpAlloc(numBytes); } Tcl_MutexLock(allocMutexPtr); @@ -543,7 +559,7 @@ TclpRealloc(oldPtr, numBytes) bigBlockPtr = (struct block *) overPtr - 1; prevPtr = bigBlockPtr->prevPtr; nextPtr = bigBlockPtr->nextPtr; - bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, + bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, sizeof(struct block) + OVERHEAD + numBytes); if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); @@ -552,8 +568,8 @@ TclpRealloc(oldPtr, numBytes) if (prevPtr->nextPtr != bigBlockPtr) { /* - * If the block has moved, splice the new block into the list where - * the old block used to be. + * If the block has moved, splice the new block into the list + * where the old block used to be. */ prevPtr->nextPtr = bigBlockPtr; @@ -561,9 +577,11 @@ TclpRealloc(oldPtr, numBytes) } overPtr = (union overhead *) (bigBlockPtr + 1); + #ifdef MSTATS numMallocs[NBUCKETS]++; #endif + #ifdef RCHECK /* * Record allocated size of block and update magic number bounds. @@ -572,6 +590,7 @@ TclpRealloc(oldPtr, numBytes) overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif + Tcl_MutexUnlock(allocMutexPtr); return (char *)(overPtr+1); } @@ -600,14 +619,16 @@ TclpRealloc(oldPtr, numBytes) TclpFree(oldPtr); return newPtr; } - + /* * Ok, we don't have to copy, it fits as-is */ + #ifdef RCHECK overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif + Tcl_MutexUnlock(allocMutexPtr); return(oldPtr); } @@ -617,9 +638,9 @@ TclpRealloc(oldPtr, numBytes) * * mstats -- * - * Prints two lines of numbers, one showing the length of the - * free list for each size category, the second showing the - * number of mallocs - frees for each size category. + * Prints two lines of numbers, one showing the length of the free list + * for each size category, the second showing the number of mallocs - + * frees for each size category. * * Results: * None. @@ -633,13 +654,14 @@ TclpRealloc(oldPtr, numBytes) #ifdef MSTATS void mstats(s) - char *s; /* Where to write info. */ + char *s; /* Where to write info. */ { register int i, j; register union overhead *overPtr; int totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); + fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { @@ -647,15 +669,18 @@ mstats(s) } totalFree += j * (1 << (i + 3)); } + fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { fprintf(stderr, " %d", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } + fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", MAXMALLOC, numMallocs[NBUCKETS]); + Tcl_MutexUnlock(allocMutexPtr); } #endif @@ -704,7 +729,7 @@ TclpAlloc(numBytes) void TclpFree(oldPtr) char *oldPtr; /* Pointer to memory to free. */ -{ +{ free(oldPtr); return; } @@ -729,9 +754,17 @@ char * TclpRealloc(oldPtr, numBytes) char *oldPtr; /* Pointer to alloced block. */ unsigned int numBytes; /* New size of memory. */ -{ +{ return (char*) realloc(oldPtr, numBytes); } #endif /* !USE_TCLALLOC */ #endif /* !TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclAsync.c b/generic/tclAsync.c index 49bebfb..ce29235 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -1,18 +1,17 @@ -/* +/* * tclAsync.c -- * - * This file provides low-level support needed to invoke signal - * handlers in a safe way. The code here doesn't actually handle - * signals, though. This code is based on proposals made by - * Mark Diekhans and Don Libes. + * This file provides low-level support needed to invoke signal handlers + * in a safe way. The code here doesn't actually handle signals, though. + * This code is based on proposals made by Mark Diekhans and Don Libes. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAsync.c,v 1.7 2004/04/06 22:25:48 dgp Exp $ + * RCS: @(#) $Id: tclAsync.c,v 1.8 2005/07/19 22:45:19 dkf Exp $ */ #include "tclInt.h" @@ -21,72 +20,61 @@ struct ThreadSpecificData; /* - * One of the following structures exists for each asynchronous - * handler: + * One of the following structures exists for each asynchronous handler: */ typedef struct AsyncHandler { - int ready; /* Non-zero means this handler should - * be invoked in the next call to - * Tcl_AsyncInvoke. */ - struct AsyncHandler *nextPtr; /* Next in list of all handlers for - * the process. */ - Tcl_AsyncProc *proc; /* Procedure to call when handler - * is invoked. */ - ClientData clientData; /* Value to pass to handler when it - * is invoked. */ + int ready; /* Non-zero means this handler should be + * invoked in the next call to + * Tcl_AsyncInvoke. */ + struct AsyncHandler *nextPtr; + /* Next in list of all handlers for the + * process. */ + Tcl_AsyncProc *proc; /* Procedure to call when handler is + * invoked. */ + ClientData clientData; /* Value to pass to handler when it is + * invoked. */ struct ThreadSpecificData *originTsd; - /* Used in Tcl_AsyncMark to modify thread- - * specific data from outside the thread - * it is associated to. */ - Tcl_ThreadId originThrdId; /* Origin thread where this token was - * created and where it will be - * yielded. */ + /* Used in Tcl_AsyncMark to modify thread- + * specific data from outside the thread it is + * associated to. */ + Tcl_ThreadId originThrdId; /* Origin thread where this token was created + * and where it will be yielded. */ } AsyncHandler; - typedef struct ThreadSpecificData { /* - * The variables below maintain a list of all existing handlers - * specific to the calling thread. - */ - AsyncHandler *firstHandler; /* First handler defined for process, - * or NULL if none. */ - AsyncHandler *lastHandler; /* Last handler or NULL. */ - - /* - * The variable below is set to 1 whenever a handler becomes ready and - * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be - * checked elsewhere in the application by calling Tcl_AsyncReady to see - * if Tcl_AsyncInvoke should be invoked. - */ - - int asyncReady; - - /* - * The variable below indicates whether Tcl_AsyncInvoke is currently - * working. If so then we won't set asyncReady again until - * Tcl_AsyncInvoke returns. + * The variables below maintain a list of all existing handlers specific + * to the calling thread. */ - - int asyncActive; - - Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list lock */ - + AsyncHandler *firstHandler; /* First handler defined for process, or NULL + * if none. */ + AsyncHandler *lastHandler; /* Last handler or NULL. */ + int asyncReady; /* This is set to 1 whenever a handler becomes + * ready and it is cleared to zero whenever + * Tcl_AsyncInvoke is called. It can be + * checked elsewhere in the application by + * calling Tcl_AsyncReady to see if + * Tcl_AsyncInvoke should be invoked. */ + int asyncActive; /* Indicates whether Tcl_AsyncInvoke is + * currently working. If so then we won't set + * asyncReady again until Tcl_AsyncInvoke + * returns. */ + Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list + * lock */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; - /* *---------------------------------------------------------------------- * * TclFinalizeAsync -- * - * Finalizes the mutex in the thread local data structure for the - * async subsystem. + * Finalizes the mutex in the thread local data structure for the async + * subsystem. * * Results: - * None. + * None. * * Side effects: * Forgets knowledge of the mutex should it have been created. @@ -110,12 +98,12 @@ TclFinalizeAsync() * Tcl_AsyncCreate -- * * This procedure creates the data structures for an asynchronous - * handler, so that no memory has to be allocated when the handler - * is activated. + * handler, so that no memory has to be allocated when the handler is + * activated. * * Results: - * The return value is a token for the handler, which can be used - * to activate it later on. + * The return value is a token for the handler, which can be used to + * activate it later on. * * Side effects: * Information about the handler is recorded. @@ -125,9 +113,9 @@ TclFinalizeAsync() Tcl_AsyncHandler Tcl_AsyncCreate(proc, clientData) - Tcl_AsyncProc *proc; /* Procedure to call when handler - * is invoked. */ - ClientData clientData; /* Argument to pass to handler. */ + Tcl_AsyncProc *proc; /* Procedure to call when handler is + * invoked. */ + ClientData clientData; /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -156,10 +144,10 @@ Tcl_AsyncCreate(proc, clientData) * * Tcl_AsyncMark -- * - * This procedure is called to request that an asynchronous handler - * be invoked as soon as possible. It's typically called from - * an interrupt handler, where it isn't safe to do anything that - * depends on or modifies application state. + * This procedure is called to request that an asynchronous handler be + * invoked as soon as possible. It's typically called from an interrupt + * handler, where it isn't safe to do anything that depends on or + * modifies application state. * * Results: * None. @@ -190,13 +178,12 @@ Tcl_AsyncMark(async) * * Tcl_AsyncInvoke -- * - * This procedure is called at a "safe" time at background level - * to invoke any active asynchronous handlers. + * This procedure is called at a "safe" time at background level to + * invoke any active asynchronous handlers. * * Results: - * The return value is a normal Tcl result, which is intended to - * replace the code argument as the current completion code for - * interp. + * The return value is a normal Tcl result, which is intended to replace + * the code argument as the current completion code for interp. * * Side effects: * Depends on the handlers that are active. @@ -206,13 +193,12 @@ Tcl_AsyncMark(async) int Tcl_AsyncInvoke(interp, code) - Tcl_Interp *interp; /* If invoked from Tcl_Eval just after - * completing a command, points to - * interpreter. Otherwise it is - * NULL. */ - int code; /* If interp is non-NULL, this gives - * completion code from command that - * just completed. */ + Tcl_Interp *interp; /* If invoked from Tcl_Eval just after + * completing a command, points to + * interpreter. Otherwise it is NULL. */ + int code; /* If interp is non-NULL, this gives + * completion code from command that just + * completed. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -230,13 +216,12 @@ Tcl_AsyncInvoke(interp, code) } /* - * Make one or more passes over the list of handlers, invoking - * at most one handler in each pass. After invoking a handler, - * go back to the start of the list again so that (a) if a new - * higher-priority handler gets marked while executing a lower - * priority handler, we execute the higher-priority handler - * next, and (b) if a handler gets deleted during the execution - * of a handler, then the list structure may change so it isn't + * Make one or more passes over the list of handlers, invoking at most one + * handler in each pass. After invoking a handler, go back to the start of + * the list again so that (a) if a new higher-priority handler gets marked + * while executing a lower priority handler, we execute the higher- + * priority handler next, and (b) if a handler gets deleted during the + * execution of a handler, then the list structure may change so it isn't * safe to continue down the list anyway. */ @@ -265,8 +250,8 @@ Tcl_AsyncInvoke(interp, code) * * Tcl_AsyncDelete -- * - * Frees up all the state for an asynchronous handler. The handler - * should never be used again. + * Frees up all the state for an asynchronous handler. The handler should + * never be used again. * * Results: * None. @@ -310,13 +295,13 @@ Tcl_AsyncDelete(async) * * Tcl_AsyncReady -- * - * This procedure can be used to tell whether Tcl_AsyncInvoke - * needs to be called. This procedure is the external interface - * for checking the thread-specific asyncReady variable. + * This procedure can be used to tell whether Tcl_AsyncInvoke needs to be + * called. This procedure is the external interface for checking the + * thread-specific asyncReady variable. * * Results: - * The return value is 1 whenever a handler is ready and is 0 - * when no handlers are ready. + * The return value is 1 whenever a handler is ready and is 0 when no + * handlers are ready. * * Side effects: * None. @@ -330,3 +315,11 @@ Tcl_AsyncReady() ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); return tsdPtr->asyncReady; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index dbae0fd..595c24a 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -1,19 +1,20 @@ -/* +/* * tclCkalloc.c -- * - * Interface to malloc and free that provides support for debugging problems - * involving overwritten, double freeing memory and loss of memory. + * Interface to malloc and free that provides support for debugging + * problems involving overwritten, double freeing memory and loss of + * memory. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.22 2004/10/06 13:05:02 dkf Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.23 2005/07/19 22:45:35 dkf Exp $ */ #include "tclInt.h" @@ -29,29 +30,29 @@ */ typedef struct MemTag { - int refCount; /* Number of mem_headers referencing - * this tag. */ - char string[4]; /* Actual size of string will be as - * large as needed for actual tag. This - * must be the last field in the structure. */ + int refCount; /* Number of mem_headers referencing this + * tag. */ + char string[4]; /* Actual size of string will be as large as + * needed for actual tag. This must be the + * last field in the structure. */ } MemTag; #define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) -static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers - * (set by "memory tag" command). */ +static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set + * by "memory tag" command). */ /* - * One of the following structures is allocated just before each - * dynamically allocated chunk of memory, both to record information - * about the chunk and to help detect chunk under-runs. + * One of the following structures is allocated just before each dynamically + * allocated chunk of memory, both to record information about the chunk and + * to help detect chunk under-runs. */ #define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; - MemTag *tagPtr; /* Tag from "memory tag" command; may be + MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ CONST char *file; long length; @@ -60,9 +61,8 @@ struct mem_header { /* Aligns body on 8-byte boundary, plus * provides at least 8 additional guard bytes * to detect underruns. */ - char body[1]; /* First byte of client's space. Actual - * size of this field will be larger than - * one. */ + char body[1]; /* First byte of client's space. Actual size + * of this field will be larger than one. */ }; static struct mem_header *allocHead = NULL; /* List of allocated structures */ @@ -70,16 +70,16 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define GUARD_VALUE 0141 /* - * The following macro determines the amount of guard space *above* each - * chunk of memory. + * The following macro determines the amount of guard space *above* each chunk + * of memory. */ #define HIGH_GUARD_SIZE 8 /* * The following macro computes the offset of the "body" field within - * mem_header. It is used to get back to the header pointer from the - * body pointer that's used by clients. + * mem_header. It is used to get back to the header pointer from the body + * pointer that's used by clients. */ #define BODY_OFFSET \ @@ -102,10 +102,10 @@ static int init_malloced_bodies = TRUE; #endif /* - * The following variable indicates to TclFinalizeMemorySubsystem() - * that it should dump out the state of memory before exiting. If the - * value is non-NULL, it gives the name of the file in which to - * dump memory usage information. + * The following variable indicates to TclFinalizeMemorySubsystem() that it + * should dump out the state of memory before exiting. If the value is + * non-NULL, it gives the name of the file in which to dump memory usage + * information. */ char *tclMemDumpFileName = NULL; @@ -115,10 +115,11 @@ static char dumpFile[100]; /* Records where to dump memory allocation * information. */ /* - * Mutex to serialize allocations. This is a low-level mutex that must - * be explicitly initialized. This is necessary because the self - * initializing mutexes use ckalloc... + * Mutex to serialize allocations. This is a low-level mutex that must be + * explicitly initialized. This is necessary because the self initializing + * mutexes use ckalloc... */ + static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; @@ -138,15 +139,16 @@ static void ValidateMemory _ANSI_ARGS_(( *---------------------------------------------------------------------- * * TclInitDbCkalloc -- - * Initialize the locks used by the allocator. - * This is only appropriate to call in a single threaded environment, - * such as during TclInitSubsystems. + * + * Initialize the locks used by the allocator. This is only appropriate + * to call in a single threaded environment, such as during + * TclInitSubsystems. * *---------------------------------------------------------------------- */ void -TclInitDbCkalloc() +TclInitDbCkalloc() { if (!ckallocInit) { ckallocInit = 1; @@ -158,26 +160,27 @@ TclInitDbCkalloc() *---------------------------------------------------------------------- * * TclDumpMemoryInfo -- - * Display the global memory management statistics. + * + * Display the global memory management statistics. * *---------------------------------------------------------------------- */ void -TclDumpMemoryInfo(outFile) +TclDumpMemoryInfo(outFile) FILE *outFile; { - fprintf(outFile,"total mallocs %10d\n", + fprintf(outFile,"total mallocs %10d\n", total_mallocs); - fprintf(outFile,"total frees %10d\n", + fprintf(outFile,"total frees %10d\n", total_frees); - fprintf(outFile,"current packets allocated %10d\n", + fprintf(outFile,"current packets allocated %10d\n", current_malloc_packets); - fprintf(outFile,"current bytes allocated %10d\n", + fprintf(outFile,"current bytes allocated %10d\n", current_bytes_malloced); - fprintf(outFile,"maximum packets allocated %10d\n", + fprintf(outFile,"maximum packets allocated %10d\n", maximum_malloc_packets); - fprintf(outFile,"maximum bytes allocated %10d\n", + fprintf(outFile,"maximum bytes allocated %10d\n", maximum_bytes_malloced); } @@ -213,53 +216,53 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) int idx; int guard_failed = FALSE; int byte; - + for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { - byte = *(memHeaderP->low_guard + idx); - if (byte != GUARD_VALUE) { - guard_failed = TRUE; - fflush(stdout); + byte = *(memHeaderP->low_guard + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush(stdout); byte &= 0xff; - fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, + fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ - } + } } if (guard_failed) { - TclDumpMemoryInfo (stderr); - fprintf(stderr, "low guard failed at %lx, %s %d\n", - (long unsigned int) memHeaderP->body, file, line); - fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, + TclDumpMemoryInfo (stderr); + fprintf(stderr, "low guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush(stderr); /* In case name pointer is bad. */ + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); - Tcl_Panic("Memory validation failure"); + Tcl_Panic("Memory validation failure"); } hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { - byte = *(hiPtr + idx); - if (byte != GUARD_VALUE) { - guard_failed = TRUE; - fflush(stdout); + byte = *(hiPtr + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush(stdout); byte &= 0xff; - fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, + fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ - } + } } if (guard_failed) { - TclDumpMemoryInfo(stderr); - fprintf(stderr, "high guard failed at %lx, %s %d\n", - (long unsigned int) memHeaderP->body, file, line); - fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", + TclDumpMemoryInfo(stderr); + fprintf(stderr, "high guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush(stderr); /* In case name pointer is bad. */ + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); - Tcl_Panic("Memory validation failure"); + Tcl_Panic("Memory validation failure"); } if (nukeGuards) { - memset((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); - memset((char *) hiPtr, 0, HIGH_GUARD_SIZE); + memset((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); + memset((char *) hiPtr, 0, HIGH_GUARD_SIZE); } } @@ -282,8 +285,10 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) void Tcl_ValidateAllMemory(file, line) - CONST char *file; /* File from which Tcl_ValidateAllMemory was called */ - int line; /* Line number of call to Tcl_ValidateAllMemory */ + CONST char *file; /* File from which Tcl_ValidateAllMemory was + * called. */ + int line; /* Line number of call to + * Tcl_ValidateAllMemory */ { struct mem_header *memScanP; @@ -292,7 +297,7 @@ Tcl_ValidateAllMemory(file, line) } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { - ValidateMemory(memScanP, file, line, FALSE); + ValidateMemory(memScanP, file, line, FALSE); } Tcl_MutexUnlock(ckallocMutexPtr); } @@ -306,14 +311,15 @@ Tcl_ValidateAllMemory(file, line) * information will be written to stderr. * * Results: - * Return TCL_ERROR if an error accessing the file occurs, `errno' - * will have the file error number left in it. + * Return TCL_ERROR if an error accessing the file occurs, `errno' will + * have the file error number left in it. + * *---------------------------------------------------------------------- */ int Tcl_DumpActiveMemory (fileName) - CONST char *fileName; /* Name of the file to write info to */ + CONST char *fileName; /* Name of the file to write info to */ { FILE *fileP; struct mem_header *memScanP; @@ -330,8 +336,8 @@ Tcl_DumpActiveMemory (fileName) Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { - address = &memScanP->body [0]; - fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", + address = &memScanP->body [0]; + fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", (long unsigned int) address, (long unsigned int) address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, @@ -351,16 +357,15 @@ Tcl_DumpActiveMemory (fileName) * * Tcl_DbCkalloc - debugging ckalloc * - * Allocate the requested amount of space plus some extra for - * guard bands at both ends of the request, plus a size, panicing - * if there isn't enough space, then write in the guard bands - * and return the address of the space in the middle that the - * user asked for. + * Allocate the requested amount of space plus some extra for guard bands + * at both ends of the request, plus a size, panicing if there isn't + * enough space, then write in the guard bands and return the address of + * the space in the middle that the user asked for. * - * The second and third arguments are file and line, these contain - * the filename and line number corresponding to the caller. - * These are sent by the ckalloc macro; it uses the preprocessor - * autodefines __FILE__ and __LINE__. + * The second and third arguments are file and line, these contain the + * filename and line number corresponding to the caller. These are sent + * by the ckalloc macro; it uses the preprocessor autodefines __FILE__ + * and __LINE__. * *---------------------------------------------------------------------- */ @@ -374,24 +379,25 @@ Tcl_DbCkalloc(size, file, line) struct mem_header *result; if (validate_memory) { - Tcl_ValidateAllMemory(file, line); + Tcl_ValidateAllMemory(file, line); } - result = (struct mem_header *) TclpAlloc((unsigned)size + + result = (struct mem_header *) TclpAlloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { - fflush(stdout); - TclDumpMemoryInfo(stderr); - Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); + fflush(stdout); + TclDumpMemoryInfo(stderr); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } /* - * Fill in guard zones and size. Also initialize the contents of - * the block with bogus bytes to detect uses of initialized data. - * Link into allocated list. + * Fill in guard zones and size. Also initialize the contents of the block + * with bogus bytes to detect uses of initialized data. Link into + * allocated list. */ + if (init_malloced_bodies) { - memset((VOID *) result, GUARD_VALUE, + memset((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); @@ -412,42 +418,42 @@ Tcl_DbCkalloc(size, file, line) result->blink = NULL; if (allocHead != NULL) { - allocHead->blink = result; + allocHead->blink = result; } allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", - total_mallocs); - fflush(stderr); - alloc_tracing = TRUE; - trace_on_at_malloc = 0; + fprintf(stderr, "reached malloc trace enable point (%d)\n", + total_mallocs); + fflush(stderr); + alloc_tracing = TRUE; + trace_on_at_malloc = 0; } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", + fprintf(stderr,"ckalloc %lx %u %s %d\n", (long unsigned int) result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { - break_on_malloc = 0; + break_on_malloc = 0; (void) fflush(stdout); - fprintf(stderr,"reached malloc break limit (%d)\n", - total_mallocs); - fprintf(stderr, "program will now enter C debugger\n"); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { - maximum_malloc_packets = current_malloc_packets; + maximum_malloc_packets = current_malloc_packets; } current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) { - maximum_bytes_malloced = current_bytes_malloced; + maximum_bytes_malloced = current_bytes_malloced; } Tcl_MutexUnlock(ckallocMutexPtr); @@ -464,24 +470,24 @@ Tcl_AttemptDbCkalloc(size, file, line) struct mem_header *result; if (validate_memory) { - Tcl_ValidateAllMemory(file, line); + Tcl_ValidateAllMemory(file, line); } - result = (struct mem_header *) TclpAlloc((unsigned)size + + result = (struct mem_header *) TclpAlloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { - fflush(stdout); - TclDumpMemoryInfo(stderr); + fflush(stdout); + TclDumpMemoryInfo(stderr); return NULL; } /* - * Fill in guard zones and size. Also initialize the contents of - * the block with bogus bytes to detect uses of initialized data. - * Link into allocated list. + * Fill in guard zones and size. Also initialize the contents of the block + * with bogus bytes to detect uses of initialized data. Link into + * allocated list. */ if (init_malloced_bodies) { - memset((VOID *) result, GUARD_VALUE, + memset((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); @@ -502,42 +508,42 @@ Tcl_AttemptDbCkalloc(size, file, line) result->blink = NULL; if (allocHead != NULL) { - allocHead->blink = result; + allocHead->blink = result; } allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", - total_mallocs); - fflush(stderr); - alloc_tracing = TRUE; - trace_on_at_malloc = 0; + fprintf(stderr, "reached malloc trace enable point (%d)\n", + total_mallocs); + fflush(stderr); + alloc_tracing = TRUE; + trace_on_at_malloc = 0; } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", + fprintf(stderr,"ckalloc %lx %u %s %d\n", (long unsigned int) result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { - break_on_malloc = 0; + break_on_malloc = 0; (void) fflush(stdout); - fprintf(stderr,"reached malloc break limit (%d)\n", - total_mallocs); - fprintf(stderr, "program will now enter C debugger\n"); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { - maximum_malloc_packets = current_malloc_packets; + maximum_malloc_packets = current_malloc_packets; } current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) { - maximum_bytes_malloced = current_bytes_malloced; + maximum_bytes_malloced = current_bytes_malloced; } Tcl_MutexUnlock(ckallocMutexPtr); @@ -550,16 +556,15 @@ Tcl_AttemptDbCkalloc(size, file, line) * * Tcl_DbCkfree - debugging ckfree * - * Verify that the low and high guards are intact, and if so - * then free the buffer else Tcl_Panic. + * Verify that the low and high guards are intact, and if so then free + * the buffer else Tcl_Panic. * - * The guards are erased after being checked to catch duplicate - * frees. + * The guards are erased after being checked to catch duplicate frees. * - * The second and third arguments are file and line, these contain - * the filename and line number corresponding to the caller. - * These are sent by the ckfree macro; it uses the preprocessor - * autodefines __FILE__ and __LINE__. + * The second and third arguments are file and line, these contain the + * filename and line number corresponding to the caller. These are sent + * by the ckfree macro; it uses the preprocessor autodefines __FILE__ and + * __LINE__. * *---------------------------------------------------------------------- */ @@ -577,22 +582,22 @@ Tcl_DbCkfree(ptr, file, line) } /* - * The following cast is *very* tricky. Must convert the pointer - * to an integer before doing arithmetic on it, because otherwise - * the arithmetic will be done differently (and incorrectly) on - * word-addressed machines such as Crays (will subtract only bytes, - * even though BODY_OFFSET is in words on these machines). + * The following cast is *very* tricky. Must convert the pointer to an + * integer before doing arithmetic on it, because otherwise the arithmetic + * will be done differently (and incorrectly) on word-addressed machines + * such as Crays (will subtract only bytes, even though BODY_OFFSET is in + * words on these machines). */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "ckfree %lx %ld %s %d\n", + fprintf(stderr, "ckfree %lx %ld %s %d\n", (long unsigned int) memp->body, memp->length, file, line); } if (validate_memory) { - Tcl_ValidateAllMemory(file, line); + Tcl_ValidateAllMemory(file, line); } Tcl_MutexLock(ckallocMutexPtr); @@ -615,14 +620,15 @@ Tcl_DbCkfree(ptr, file, line) /* * Delink from allocated list */ + if (memp->flink != NULL) { - memp->flink->blink = memp->blink; + memp->flink->blink = memp->blink; } if (memp->blink != NULL) { - memp->blink->flink = memp->flink; + memp->blink->flink = memp->flink; } if (allocHead == memp) { - allocHead = memp->flink; + allocHead = memp->flink; } TclpFree((char *) memp); Tcl_MutexUnlock(ckallocMutexPtr); @@ -635,10 +641,10 @@ Tcl_DbCkfree(ptr, file, line) * * Tcl_DbCkrealloc - debugging ckrealloc * - * Reallocate a chunk of memory by allocating a new one of the - * right size, copying the old data to the new location, and then - * freeing the old memory space, using all the memory checking - * features of this package. + * Reallocate a chunk of memory by allocating a new one of the right + * size, copying the old data to the new location, and then freeing the + * old memory space, using all the memory checking features of this + * package. * *-------------------------------------------------------------------- */ @@ -659,8 +665,7 @@ Tcl_DbCkrealloc(ptr, size, file, line) } /* - * See comment from Tcl_DbCkfree before you change the following - * line. + * See comment from Tcl_DbCkfree before you change the following line. */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); @@ -691,8 +696,7 @@ Tcl_AttemptDbCkrealloc(ptr, size, file, line) } /* - * See comment from Tcl_DbCkfree before you change the following - * line. + * See comment from Tcl_DbCkfree before you change the following line. */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); @@ -716,8 +720,8 @@ Tcl_AttemptDbCkrealloc(ptr, size, file, line) * * Tcl_Alloc, et al. -- * - * These functions are defined in terms of the debugging versions - * when TCL_MEM_DEBUG is set. + * These functions are defined in terms of the debugging versions when + * TCL_MEM_DEBUG is set. * * Results: * Same as the debug versions. @@ -774,8 +778,9 @@ Tcl_AttemptRealloc(ptr, size) *---------------------------------------------------------------------- * * MemoryCmd -- - * Implements the Tcl "memory" command, which provides Tcl-level - * control of Tcl memory debugging information. + * + * Implements the Tcl "memory" command, which provides Tcl-level control + * of Tcl memory debugging information. * memory active $file * memory break_on_malloc $count * memory info @@ -787,7 +792,7 @@ Tcl_AttemptRealloc(ptr, size) * memory validate on|off * * Results: - * Standard TCL results. + * Standard TCL results. * *---------------------------------------------------------------------- */ @@ -810,7 +815,7 @@ MemoryCmd(clientData, interp, argc, argv) } if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { - if (argc != 3) { + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " file\"", (char *) NULL); return TCL_ERROR; @@ -822,41 +827,41 @@ MemoryCmd(clientData, interp, argc, argv) result = Tcl_DumpActiveMemory (fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { - Tcl_AppendResult(interp, "error accessing ", argv[2], + Tcl_AppendResult(interp, "error accessing ", argv[2], (char *) NULL); return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { - if (argc != 3) { - goto argError; + if (argc != 3) { + goto argError; } - if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { return TCL_ERROR; } - return TCL_OK; + return TCL_OK; } if (strcmp(argv[1],"info") == 0) { char buf[400]; sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", - "total mallocs", total_mallocs, "total frees", total_frees, - "current packets allocated", current_malloc_packets, - "current bytes allocated", current_bytes_malloced, - "maximum packets allocated", maximum_malloc_packets, - "maximum bytes allocated", maximum_bytes_malloced); + "total mallocs", total_mallocs, "total frees", total_frees, + "current packets allocated", current_malloc_packets, + "current bytes allocated", current_bytes_malloced, + "maximum packets allocated", maximum_malloc_packets, + "maximum bytes allocated", maximum_bytes_malloced); Tcl_SetResult(interp, buf, TCL_VOLATILE); - return TCL_OK; + return TCL_OK; } if (strcmp(argv[1],"init") == 0) { - if (argc != 3) { - goto bad_suboption; + if (argc != 3) { + goto bad_suboption; } - init_malloced_bodies = (strcmp(argv[2],"on") == 0); - return TCL_OK; + init_malloced_bodies = (strcmp(argv[2],"on") == 0); + return TCL_OK; } if (strcmp(argv[1],"onexit") == 0) { - if (argc != 3) { + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " onexit file\"", (char *) NULL); return TCL_ERROR; @@ -885,28 +890,28 @@ MemoryCmd(clientData, interp, argc, argv) return TCL_OK; } if (strcmp(argv[1],"trace") == 0) { - if (argc != 3) { - goto bad_suboption; + if (argc != 3) { + goto bad_suboption; } - alloc_tracing = (strcmp(argv[2],"on") == 0); - return TCL_OK; + alloc_tracing = (strcmp(argv[2],"on") == 0); + return TCL_OK; } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { - if (argc != 3) { - goto argError; + if (argc != 3) { + goto argError; } - if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { - if (argc != 3) { + if (argc != 3) { goto bad_suboption; } - validate_memory = (strcmp(argv[2],"on") == 0); - return TCL_OK; + validate_memory = (strcmp(argv[2],"on") == 0); + return TCL_OK; } Tcl_AppendResult(interp, "bad option \"", argv[1], @@ -914,12 +919,12 @@ MemoryCmd(clientData, interp, argc, argv) "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); return TCL_ERROR; -argError: + argError: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " count\"", (char *) NULL); return TCL_ERROR; -bad_suboption: + bad_suboption: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " on|off\"", (char *) NULL); return TCL_ERROR; @@ -930,10 +935,9 @@ bad_suboption: * * CheckmemCmd -- * - * This is the command procedure for the "checkmem" command, which - * causes the application to exit after printing information about - * memory usage to the file passed to this command as its first - * argument. + * This is the command procedure for the "checkmem" command, which causes + * the application to exit after printing information about memory usage + * to the file passed to this command as its first argument. * * Results: * Returns a standard Tcl completion code. @@ -966,8 +970,7 @@ CheckmemCmd(clientData, interp, argc, argv) * * Tcl_InitMemory -- * - * Create the "memory" and "checkmem" commands in the given - * interpreter. + * Create the "memory" and "checkmem" commands in the given interpreter. * * Results: * None. @@ -983,7 +986,7 @@ Tcl_InitMemory(interp) Tcl_Interp *interp; /* Interpreter in which commands should be added */ { TclInitDbCkalloc(); - Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, + Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); @@ -1003,8 +1006,9 @@ Tcl_InitMemory(interp) *---------------------------------------------------------------------- * * Tcl_Alloc -- - * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check - * that memory was actually allocated. + * + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check + * that memory was actually allocated. * *---------------------------------------------------------------------- */ @@ -1016,15 +1020,17 @@ Tcl_Alloc(size) char *result; result = TclpAlloc(size); + /* - * Most systems will not alloc(0), instead bumping it to one so - * that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0) - * by returning NULL, so we have to check that the NULL we get is - * not in response to alloc(0). + * Most systems will not alloc(0), instead bumping it to one so that NULL + * isn't returned. Some systems (AIX, Tru64) will alloc(0) by returning + * NULL, so we have to check that the NULL we get is not in response to + * alloc(0). * - * The ANSI spec actually says that systems either return NULL *or* - * a special pointer on failure, but we only check for NULL + * The ANSI spec actually says that systems either return NULL *or* a + * special pointer on failure, but we only check for NULL */ + if ((result == NULL) && size) { Tcl_Panic("unable to alloc %u bytes", size); } @@ -1042,8 +1048,8 @@ Tcl_DbCkalloc(size, file, line) result = (char *) TclpAlloc(size); if ((result == NULL) && size) { - fflush(stdout); - Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); + fflush(stdout); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } return result; } @@ -1052,8 +1058,9 @@ Tcl_DbCkalloc(size, file, line) *---------------------------------------------------------------------- * * Tcl_AttemptAlloc -- - * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not - * check that memory was actually allocated. + * + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not + * check that memory was actually allocated. * *---------------------------------------------------------------------- */ @@ -1079,14 +1086,14 @@ Tcl_AttemptDbCkalloc(size, file, line) result = (char *) TclpAlloc(size); return result; } - /* *---------------------------------------------------------------------- * * Tcl_Realloc -- - * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does - * check that memory was actually allocated. + * + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check + * that memory was actually allocated. * *---------------------------------------------------------------------- */ @@ -1118,8 +1125,8 @@ Tcl_DbCkrealloc(ptr, size, file, line) result = (char *) TclpRealloc(ptr, size); if ((result == NULL) && size) { - fflush(stdout); - Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); + fflush(stdout); + Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); } return result; } @@ -1128,8 +1135,9 @@ Tcl_DbCkrealloc(ptr, size, file, line) *---------------------------------------------------------------------- * * Tcl_AttemptRealloc -- - * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does - * not check that memory was actually allocated. + * + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not + * check that memory was actually allocated. * *---------------------------------------------------------------------- */ @@ -1162,9 +1170,10 @@ Tcl_AttemptDbCkrealloc(ptr, size, file, line) *---------------------------------------------------------------------- * * Tcl_Free -- - * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here - * rather in the macro to keep some modules from being compiled with - * TCL_MEM_DEBUG enabled and some with it disabled. + * + * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here rather + * in the macro to keep some modules from being compiled with + * TCL_MEM_DEBUG enabled and some with it disabled. * *---------------------------------------------------------------------- */ @@ -1190,8 +1199,9 @@ Tcl_DbCkfree(ptr, file, line) *---------------------------------------------------------------------- * * Tcl_InitMemory -- - * Dummy initialization for memory command, which is only available - * if TCL_MEM_DEBUG is on. + * + * Dummy initialization for memory command, which is only available if + * TCL_MEM_DEBUG is on. * *---------------------------------------------------------------------- */ @@ -1217,7 +1227,7 @@ Tcl_ValidateAllMemory(file, line) } void -TclDumpMemoryInfo(outFile) +TclDumpMemoryInfo(outFile) FILE *outFile; { } @@ -1229,17 +1239,16 @@ TclDumpMemoryInfo(outFile) * * TclFinalizeMemorySubsystem -- * - * This procedure is called to finalize all the structures that - * are used by the memory allocator on a per-process basis. + * This procedure is called to finalize all the structures that are used + * by the memory allocator on a per-process basis. * * Results: * None. * * Side effects: - * This subsystem is self-initializing, since memory can be - * allocated before Tcl is formally initialized. After this call, - * this subsystem has been reset to its initial state and is - * usable again. + * This subsystem is self-initializing, since memory can be allocated + * before Tcl is formally initialized. After this call, this subsystem + * has been reset to its initial state and is usable again. * *--------------------------------------------------------------------------- */ @@ -1253,16 +1262,27 @@ TclFinalizeMemorySubsystem() } else if (onExitMemDumpFileName != NULL) { Tcl_DumpActiveMemory(onExitMemDumpFileName); } + Tcl_MutexLock(ckallocMutexPtr); + if (curTagPtr != NULL) { TclpFree((char *) curTagPtr); curTagPtr = NULL; } allocHead = NULL; + Tcl_MutexUnlock(ckallocMutexPtr); #endif #if USE_TCLALLOC - TclFinalizeAllocSubsystem(); + TclFinalizeAllocSubsystem(); #endif } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 8a1a94c..366d0ab 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -1,14 +1,14 @@ -/* +/* * tclIOSock.c -- * * Common routines used by all socket based channel types. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOSock.c,v 1.8 2004/04/06 22:25:53 dgp Exp $ + * RCS: @(#) $Id: tclIOSock.c,v 1.9 2005/07/19 22:45:35 dkf Exp $ */ #include "tclInt.h" @@ -18,14 +18,13 @@ * * TclSockGetPort -- * - * Maps from a string, which could be a service name, to a port. - * Used by socket creation code to get port numbers and resolve - * registered service names to port numbers. + * Maps from a string, which could be a service name, to a port. Used by + * socket creation code to get port numbers and resolve registered + * service names to port numbers. * * Results: - * A standard Tcl result. On success, the port number is returned - * in portPtr. On failure, an error message is left in the interp's - * result. + * A standard Tcl result. On success, the port number is returned in + * portPtr. On failure, an error message is left in the interp's result. * * Side effects: * None. @@ -48,7 +47,7 @@ TclSockGetPort(interp, string, proto, portPtr) /* * Don't bother translating 'proto' to native. */ - + native = Tcl_UtfToExternalDString(NULL, string, -1, &ds); sp = getservbyname(native, proto); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -61,8 +60,8 @@ TclSockGetPort(interp, string, proto, portPtr) return TCL_ERROR; } if (*portPtr > 0xFFFF) { - Tcl_AppendResult(interp, "couldn't open socket: port number too high", - (char *) NULL); + Tcl_AppendResult(interp, "couldn't open socket: port number too high", + (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -106,3 +105,11 @@ TclSockMinimumBuffers(sock, size) } return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclPanic.c b/generic/tclPanic.c index e20d0e4..9b1c36f 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -1,44 +1,42 @@ -/* +/* * tclPanic.c -- * - * Source code for the "Tcl_Panic" library procedure for Tcl; - * individual applications will probably call Tcl_SetPanicProc() - * to set an application-specific panic procedure. + * Source code for the "Tcl_Panic" library procedure for Tcl; individual + * applications will probably call Tcl_SetPanicProc() to set an + * application-specific panic procedure. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPanic.c,v 1.5 2004/04/06 22:25:54 dgp Exp $ + * RCS: @(#) $Id: tclPanic.c,v 1.6 2005/07/19 22:45:35 dkf Exp $ */ #include "tclInt.h" /* - * The panicProc variable contains a pointer to an application - * specific panic procedure. + * The panicProc variable contains a pointer to an application specific panic + * procedure. */ static Tcl_PanicProc *panicProc = NULL; /* - * The platformPanicProc variable contains a pointer to a platform - * specific panic procedure, if any. ( TclpPanic may be NULL via - * a macro. ) + * The platformPanicProc variable contains a pointer to a platform specific + * panic procedure, if any. (TclpPanic may be NULL via a macro.) */ -static Tcl_PanicProc * CONST platformPanicProc = TclpPanic; - +static Tcl_PanicProc *CONST platformPanicProc = TclpPanic; /* *---------------------------------------------------------------------- * * Tcl_SetPanicProc -- * - * Replace the default panic behavior with the specified functiion. + * Replace the default panic behavior with the specified function. * * Results: * None. @@ -73,7 +71,7 @@ Tcl_SetPanicProc(proc) */ void -Tcl_PanicVA (format, argList) +Tcl_PanicVA(format, argList) CONST char *format; /* Format string, suitable for passing to * fprintf. */ va_list argList; /* Variable argument list. */ @@ -90,7 +88,7 @@ Tcl_PanicVA (format, argList) arg6 = va_arg(argList, char *); arg7 = va_arg(argList, char *); arg8 = va_arg(argList, char *); - + if (panicProc != NULL) { (void) (*panicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); @@ -133,3 +131,11 @@ Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1) Tcl_PanicVA(format, argList); va_end (argList); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclPkg.c b/generic/tclPkg.c index a58feb4..397acd9 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1,48 +1,48 @@ -/* +/* * tclPkg.c -- * - * This file implements package and version control for Tcl via - * the "package" command and a few C APIs. + * This file implements package and version control for Tcl via the + * "package" command and a few C APIs. * * Copyright (c) 1996 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPkg.c,v 1.11 2004/10/06 15:59:25 dgp Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.12 2005/07/19 22:45:35 dkf Exp $ */ #include "tclInt.h" /* - * Each invocation of the "package ifneeded" command creates a structure - * of the following type, which is used to load the package into the - * interpreter if it is requested with a "package require" command. + * Each invocation of the "package ifneeded" command creates a structure of + * the following type, which is used to load the package into the interpreter + * if it is requested with a "package require" command. */ typedef struct PkgAvail { char *version; /* Version string; malloc'ed. */ - char *script; /* Script to invoke to provide this version - * of the package. Malloc'ed and protected - * by Tcl_Preserve and Tcl_Release. */ - struct PkgAvail *nextPtr; /* Next in list of available versions of - * the same package. */ + char *script; /* Script to invoke to provide this version of + * the package. Malloc'ed and protected by + * Tcl_Preserve and Tcl_Release. */ + struct PkgAvail *nextPtr; /* Next in list of available versions of the + * same package. */ } PkgAvail; /* - * For each package that is known in any way to an interpreter, there - * is one record of the following type. These records are stored in - * the "packageTable" hash table in the interpreter, keyed by - * package name such as "Tk" (no version number). + * For each package that is known in any way to an interpreter, there is one + * record of the following type. These records are stored in the + * "packageTable" hash table in the interpreter, keyed by package name such as + * "Tk" (no version number). */ typedef struct Package { char *version; /* Version that has been supplied in this * interpreter via "package provide" - * (malloc'ed). NULL means the package doesn't - * exist in this interpreter yet. */ - PkgAvail *availPtr; /* First in list of all available versions - * of this package. */ + * (malloc'ed). NULL means the package + * doesn't exist in this interpreter yet. */ + PkgAvail *availPtr; /* First in list of all available versions of + * this package. */ ClientData clientData; /* Client data. */ } Package; @@ -52,9 +52,8 @@ typedef struct Package { static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, CONST char *string)); -static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, - CONST char *v2, - int *satPtr)); +static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, + CONST char *v2, int *satPtr)); static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); @@ -63,20 +62,18 @@ static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, * * Tcl_PkgProvide / Tcl_PkgProvideEx -- * - * This procedure is invoked to declare that a particular version - * of a particular package is now present in an interpreter. There - * must not be any other version of this package already - * provided in the interpreter. + * This procedure is invoked to declare that a particular version of a + * particular package is now present in an interpreter. There must not be + * any other version of this package already provided in the interpreter. * * Results: - * Normally returns TCL_OK; if there is already another version - * of the package loaded then TCL_ERROR is returned and an error - * message is left in the interp's result. + * Normally returns TCL_OK; if there is already another version of the + * package loaded then TCL_ERROR is returned and an error message is left + * in the interp's result. * * Side effects: - * The interpreter remembers that this package is available, - * so that no other version of the package may be provided for - * the interpreter. + * The interpreter remembers that this package is available, so that no + * other version of the package may be provided for the interpreter. * *---------------------------------------------------------------------- */ @@ -97,8 +94,8 @@ Tcl_PkgProvideEx(interp, name, version, clientData) * available. */ CONST char *name; /* Name of package. */ CONST char *version; /* Version string for package. */ - ClientData clientData; /* clientdata for this package (normally - * used for C callback function table) */ + ClientData clientData; /* clientdata for this package (normally used + * for C callback function table) */ { Package *pkgPtr; @@ -125,26 +122,24 @@ Tcl_PkgProvideEx(interp, name, version, clientData) * * Tcl_PkgRequire / Tcl_PkgRequireEx -- * - * This procedure is called by code that depends on a particular - * version of a particular package. If the package is not already - * provided in the interpreter, this procedure invokes a Tcl script - * to provide it. If the package is already provided, this - * procedure makes sure that the caller's needs don't conflict with - * the version that is present. + * This procedure is called by code that depends on a particular version + * of a particular package. If the package is not already provided in the + * interpreter, this procedure invokes a Tcl script to provide it. If the + * package is already provided, this procedure makes sure that the + * caller's needs don't conflict with the version that is present. * * Results: - * If successful, returns the version string for the currently - * provided version of the package, which may be different from - * the "version" argument. If the caller's requirements - * cannot be met (e.g. the version requested conflicts with - * a currently provided version, or the required version cannot - * be found, or the script to provide the required version - * generates an error), NULL is returned and an error - * message is left in the interp's result. + * If successful, returns the version string for the currently provided + * version of the package, which may be different from the "version" + * argument. If the caller's requirements cannot be met (e.g. the version + * requested conflicts with a currently provided version, or the required + * version cannot be found, or the script to provide the required version + * generates an error), NULL is returned and an error message is left in + * the interp's result. * * Side effects: - * The script from some previous "package ifneeded" command may - * be invoked to provide the package. + * The script from some previous "package ifneeded" command may be + * invoked to provide the package. * *---------------------------------------------------------------------- */ @@ -154,12 +149,11 @@ Tcl_PkgRequire(interp, name, version, exact) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version - * available. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ { return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL); } @@ -169,16 +163,15 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version - * available. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ ClientData *clientDataPtr; /* Used to return the client data for this - * package. If it is NULL then the client - * data is not returned. This is unchanged - * if this call fails for any reason. */ + * package. If it is NULL then the client data + * is not returned. This is unchanged if this + * call fails for any reason. */ { Package *pkgPtr; PkgAvail *availPtr, *bestPtr; @@ -188,85 +181,81 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) /* * If an attempt is being made to load this into a standalone executable - * on a platform where backlinking is not supported then this must be - * a shared version of Tcl (Otherwise the load would have failed). - * Detect this situation by checking that this library has been correctly + * on a platform where backlinking is not supported then this must be a + * shared version of Tcl (Otherwise the load would have failed). Detect + * this situation by checking that this library has been correctly * initialised. If it has not been then return immediately as nothing will * work. */ - + if (tclEmptyStringRep == NULL) { /* * OK, so what's going on here? * - * First, what are we doing? We are performing a check on behalf of - * one particular caller, Tcl_InitStubs(). When a package is - * stub-enabled, it is statically linked to libtclstub.a, which - * contains a copy of Tcl_InitStubs(). When a stub-enabled package - * is loaded, its *_Init() function is supposed to call - * Tcl_InitStubs() before calling any other functions in the Tcl - * library. The first Tcl function called by Tcl_InitStubs() through - * the stub table is Tcl_PkgRequireEx(), so this code right here is - * the first code that is part of the original Tcl library in the - * executable that gets executed on behalf of a newly loaded - * stub-enabled package. + * First, what are we doing? We are performing a check on behalf of + * one particular caller, Tcl_InitStubs(). When a package is stub- + * enabled, it is statically linked to libtclstub.a, which contains a + * copy of Tcl_InitStubs(). When a stub-enabled package is loaded, its + * *_Init() function is supposed to call Tcl_InitStubs() before + * calling any other functions in the Tcl library. The first Tcl + * function called by Tcl_InitStubs() through the stub table is + * Tcl_PkgRequireEx(), so this code right here is the first code that + * is part of the original Tcl library in the executable that gets + * executed on behalf of a newly loaded stub-enabled package. * * One easy error for the developer/builder of a stub-enabled package * to make is to forget to define USE_TCL_STUBS when compiling the - * package. When that happens, the package will contain symbols - * that are references to the Tcl library, rather than function - * pointers referencing the stub table. On platforms that lack - * backlinking, those unresolved references may cause the loading - * of the package to also load a second copy of the Tcl library, - * leading to all kinds of trouble. We would like to catch that - * error and report a useful message back to the user. That's - * what we're doing. + * package. When that happens, the package will contain symbols that + * are references to the Tcl library, rather than function pointers + * referencing the stub table. On platforms that lack backlinking, + * those unresolved references may cause the loading of the package to + * also load a second copy of the Tcl library, leading to all kinds of + * trouble. We would like to catch that error and report a useful + * message back to the user. That's what we're doing. * - * Second, how does this work? If we reach this point, then the - * global variable tclEmptyStringRep has the value NULL. Compare - * that with the definition of tclEmptyStringRep near the top of - * the file generic/tclObj.c. It clearly should not have the value - * NULL; it should point to the char tclEmptyString. If we see it - * having the value NULL, then somehow we are seeing a Tcl library - * that isn't completely initialized, and that's an indicator for the - * error condition described above. (Further explanation is welcome.) + * Second, how does this work? If we reach this point, then the global + * variable tclEmptyStringRep has the value NULL. Compare that with + * the definition of tclEmptyStringRep near the top of the file + * generic/tclObj.c. It clearly should not have the value NULL; it + * should point to the char tclEmptyString. If we see it having the + * value NULL, then somehow we are seeing a Tcl library that isn't + * completely initialized, and that's an indicator for the error + * condition described above. (Further explanation is welcome.) * - * Third, so what do we do about it? This situation indicates - * the package we just loaded wasn't properly compiled to be - * stub-enabled, yet it thinks it is stub-enabled (it called - * Tcl_InitStubs()). We want to report that the package just - * loaded is broken, so we want to place an error message in - * the interpreter result and return NULL to indicate failure - * to Tcl_InitStubs() so that it will also fail. (Further - * explanation why we don't want to Tcl_Panic() is welcome. + * Third, so what do we do about it? This situation indicates the + * package we just loaded wasn't properly compiled to be stub-enabled, + * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We + * want to report that the package just loaded is broken, so we want + * to place an error message in the interpreter result and return NULL + * to indicate failure to Tcl_InitStubs() so that it will also fail. + * (Further explanation why we don't want to Tcl_Panic() is welcome. * After all, two Tcl libraries can't be a good thing!) * - * Trouble is that's going to be tricky. We're now using a Tcl - * library that's not fully initialized. In particular, it - * doesn't have a proper value for tclEmptyStringRep. The - * Tcl_Obj system heavily depends on the value of tclEmptyStringRep - * and all of Tcl depends (increasingly) on the Tcl_Obj system, we - * need to correct that flaw before making the calls to set the - * interpreter result to the error message. That's the only flaw - * corrected; other problems with initialization of the Tcl library - * are not remedied, so be very careful about adding any other calls - * here without checking how they behave when initialization is - * incomplete. + * Trouble is that's going to be tricky. We're now using a Tcl library + * that's not fully initialized. In particular, it doesn't have a + * proper value for tclEmptyStringRep. The Tcl_Obj system heavily + * depends on the value of tclEmptyStringRep and all of Tcl depends + * (increasingly) on the Tcl_Obj system, we need to correct that flaw + * before making the calls to set the interpreter result to the error + * message. That's the only flaw corrected; other problems with + * initialization of the Tcl library are not remedied, so be very + * careful about adding any other calls here without checking how they + * behave when initialization is incomplete. */ tclEmptyStringRep = &tclEmptyString; - Tcl_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not ", - "compiled with stub support", NULL); - return NULL; + Tcl_AppendResult(interp, "Cannot load package \"", name, + "\" in standalone executable: This package is not ", + "compiled with stub support", NULL); + return NULL; } /* - * It can take up to three passes to find the package: one pass to - * run the "package unknown" script, one to run the "package ifneeded" - * script for a specific version, and a final pass to lookup the - * package loaded by the "package ifneeded" script. + * It can take up to three passes to find the package: one pass to run the + * "package unknown" script, one to run the "package ifneeded" script for + * a specific version, and a final pass to lookup the package loaded by + * the "package ifneeded" script. */ for (pass = 1; ; pass++) { @@ -279,7 +268,7 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) * The package isn't yet present. Search the list of available * versions and invoke the script for the best available version. */ - + bestPtr = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { @@ -302,11 +291,11 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) if (bestPtr != NULL) { /* * We found an ifneeded script for the package. Be careful while - * executing it: this could cause reentrancy, so (a) protect the + * executing it: this could cause reentrancy, so (a) protect the * script itself from deletion and (b) don't assume that bestPtr * will still exist when the script completes. */ - + script = bestPtr->script; Tcl_Preserve((ClientData) script); code = Tcl_GlobalEval(interp, script); @@ -325,8 +314,8 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) /* * Package not in the database. If there is a "package unknown" - * command, invoke it (but only on the first pass; after that, - * we should not get here in the first place). + * command, invoke it (but only on the first pass; after that, we + * should not get here in the first place). */ if (pass > 1) { @@ -371,7 +360,7 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) */ if (version == NULL) { - if (clientDataPtr) { + if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; @@ -391,19 +380,18 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) /* *---------------------------------------------------------------------- - * + *q * Tcl_PkgPresent / Tcl_PkgPresentEx -- * - * Checks to see whether the specified package is present. If it - * is not then no additional action is taken. + * Checks to see whether the specified package is present. If it is not + * then no additional action is taken. * * Results: - * If successful, returns the version string for the currently - * provided version of the package, which may be different from - * the "version" argument. If the caller's requirements - * cannot be met (e.g. the version requested conflicts with - * a currently provided version), NULL is returned and an error - * message is left in interp->result. + * If successful, returns the version string for the currently provided + * version of the package, which may be different from the "version" + * argument. If the caller's requirements cannot be met (e.g. the version + * requested conflicts with a currently provided version), NULL is + * returned and an error message is left in interp->result. * * Side effects: * None. @@ -416,12 +404,11 @@ Tcl_PkgPresent(interp, name, version, exact) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version - * available. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ { return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL); } @@ -431,16 +418,15 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version - * available. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ ClientData *clientDataPtr; /* Used to return the client data for this - * package. If it is NULL then the client - * data is not returned. This is unchanged - * if this call fails for any reason. */ + * package. If it is NULL then the client data + * is not returned. This is unchanged if this + * call fails for any reason. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; @@ -451,9 +437,8 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) if (hPtr) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - /* - * At this point we know that the package is present. Make sure + * At this point we know that the package is present. Make sure * that the provided version meets the current requirement. */ @@ -461,7 +446,7 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - + return pkgPtr->version; } result = ComparePkgVersions(pkgPtr->version, version, &satisfies); @@ -469,22 +454,22 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - + return pkgPtr->version; } - Tcl_AppendResult(interp, "version conflict for package \"", - name, "\": have ", pkgPtr->version, - ", need ", version, (char *) NULL); + Tcl_AppendResult(interp, "version conflict for package \"", name, + "\": have ", pkgPtr->version, ", need ", version, + (char *) NULL); return NULL; } } if (version != NULL) { Tcl_AppendResult(interp, "package ", name, " ", version, - " is not present", (char *) NULL); + " is not present", (char *) NULL); } else { Tcl_AppendResult(interp, "package ", name, " is not present", - (char *) NULL); + (char *) NULL); } return NULL; } @@ -494,8 +479,8 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) * * Tcl_PackageObjCmd -- * - * This procedure is invoked to process the "package" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "package" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -509,9 +494,9 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) /* ARGSUSED */ int Tcl_PackageObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *pkgOptions[] = { @@ -534,7 +519,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) char *argv2, *argv3, *argv4; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } @@ -543,259 +528,252 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { - case PKG_FORGET: { - char *keyString; - for (i = 2; i < objc; i++) { - keyString = Tcl_GetString(objv[i]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); - if (hPtr == NULL) { - continue; - } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - } - while (pkgPtr->availPtr != NULL) { - availPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr->nextPtr; - ckfree(availPtr->version); - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - ckfree((char *) availPtr); - } - ckfree((char *) pkgPtr); - } - break; - } - case PKG_IFNEEDED: { - int length; - if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); - return TCL_ERROR; - } - argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if (objc == 4) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr == NULL) { - return TCL_OK; - } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - } else { - pkgPtr = FindPackage(interp, argv2); - } - argv3 = Tcl_GetStringFromObj(objv[3], &length); - for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; - prevPtr = availPtr, availPtr = availPtr->nextPtr) { - if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL) - == 0) { - if (objc == 4) { - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); - return TCL_OK; - } - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - break; - } + case PKG_FORGET: { + char *keyString; + + for (i = 2; i < objc; i++) { + keyString = Tcl_GetString(objv[i]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); + if (hPtr == NULL) { + continue; } - if (objc == 4) { - return TCL_OK; + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); } - if (availPtr == NULL) { - availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); - availPtr->version = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->version, argv3); - if (prevPtr == NULL) { - availPtr->nextPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr; - } else { - availPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = availPtr; - } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); } - argv4 = Tcl_GetStringFromObj(objv[4], &length); - availPtr->script = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->script, argv4); - break; + ckfree((char *) pkgPtr); } - case PKG_NAMES: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); - } - } - break; + break; + } + case PKG_IFNEEDED: { + int length; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; } - case PKG_PRESENT: { - if (objc < 3) { - presentSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - exact = 1; - } else { - exact = 0; - } - version = NULL; - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { - return TCL_ERROR; - } - } else if ((objc != 3) || exact) { - goto presentSyntax; - } - if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgPresent(interp, argv3, version, exact); - } else { - version = Tcl_PkgPresent(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); - break; + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; } - case PKG_PROVIDE: { - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if (objc == 3) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); - } - } + argv2 = Tcl_GetString(objv[2]); + if (objc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr == NULL) { return TCL_OK; } - argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { - return TCL_ERROR; - } - return Tcl_PkgProvide(interp, argv2, argv3); + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv2); } - case PKG_REQUIRE: { - if (objc < 3) { - requireSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - exact = 1; - } else { - exact = 0; - } - version = NULL; - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { - return TCL_ERROR; + argv3 = Tcl_GetStringFromObj(objv[3], &length); + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)==0){ + if (objc == 4) { + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + return TCL_OK; } - } else if ((objc != 3) || exact) { - goto requireSyntax; + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; } - if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgRequire(interp, argv3, version, exact); - } else { - version = Tcl_PkgRequire(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); - break; } - case PKG_UNKNOWN: { - int length; - if (objc == 2) { - if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); - } - } else if (objc == 3) { - if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); - } - argv2 = Tcl_GetStringFromObj(objv[2], &length); - if (argv2[0] == 0) { - iPtr->packageUnknown = NULL; - } else { - iPtr->packageUnknown = (char *) ckalloc((unsigned) - (length + 1)); - strcpy(iPtr->packageUnknown, argv2); - } + if (objc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->version, argv3); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; } else { - Tcl_WrongNumArgs(interp, 2, objv, "?command?"); - return TCL_ERROR; + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; } - break; } - case PKG_VCOMPARE: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); - return TCL_ERROR; - } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { - return TCL_ERROR; + argv4 = Tcl_GetStringFromObj(objv[4], &length); + availPtr->script = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->script, argv4); + break; + } + case PKG_NAMES: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); } - Tcl_SetObjResult(interp, Tcl_NewIntObj( - ComparePkgVersions(argv2, argv3, (int *) NULL))); - break; } - case PKG_VERSIONS: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "package"); + break; + case PKG_PRESENT: + if (objc < 3) { + presentSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { return TCL_ERROR; } - argv2 = Tcl_GetString(objv[2]); + } else if ((objc != 3) || exact) { + goto presentSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgPresent(interp, argv3, version, exact); + } else { + version = Tcl_PkgPresent(interp, argv2, version, exact); + } + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); + break; + case PKG_PROVIDE: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_AppendElement(interp, availPtr->version); + if (pkgPtr->version != NULL) { + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); } } - break; + return TCL_OK; + } + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv2, argv3); + case PKG_REQUIRE: + if (objc < 3) { + requireSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; } - case PKG_VSATISFIES: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { return TCL_ERROR; } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { - return TCL_ERROR; + } else if ((objc != 3) || exact) { + goto requireSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgRequire(interp, argv3, version, exact); + } else { + version = Tcl_PkgRequire(interp, argv2, version, exact); + } + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1)); + break; + case PKG_UNKNOWN: { + int length; + + if (objc == 2) { + if (iPtr->packageUnknown != NULL) { + Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + } + } else if (objc == 3) { + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } + argv2 = Tcl_GetStringFromObj(objv[2], &length); + if (argv2[0] == 0) { + iPtr->packageUnknown = NULL; + } else { + iPtr->packageUnknown = (char *) ckalloc((unsigned) (length+1)); + strcpy(iPtr->packageUnknown, argv2); } - ComparePkgVersions(argv2, argv3, &satisfies); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); - break; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?command?"); + return TCL_ERROR; + } + break; + } + case PKG_VCOMPARE: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj( + ComparePkgVersions(argv2, argv3, (int *) NULL))); + break; + case PKG_VERSIONS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; } - default: { - Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + argv2 = Tcl_GetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } + } + break; + case PKG_VSATISFIES: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; } + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; + } + ComparePkgVersions(argv2, argv3, &satisfies); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); + break; + default: + Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } return TCL_OK; } @@ -805,13 +783,12 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) * * FindPackage -- * - * This procedure finds the Package record for a particular package - * in a particular interpreter, creating a record if one doesn't - * already exist. + * This procedure finds the Package record for a particular package in a + * particular interpreter, creating a record if one doesn't already + * exist. * * Results: - * The return value is a pointer to the Package record for the - * package. + * The return value is a pointer to the Package record for the package. * * Side effects: * A new Package record may be created. @@ -847,9 +824,8 @@ FindPackage(interp, name) * * TclFreePackageInfo -- * - * This procedure is called during interpreter deletion to - * free all of the package-related information for the - * interpreter. + * This procedure is called during interpreter deletion to free all of + * the package-related information for the interpreter. * * Results: * None. @@ -895,13 +871,13 @@ TclFreePackageInfo(iPtr) * * CheckVersion -- * - * This procedure checks to see whether a version number has - * valid syntax. + * This procedure checks to see whether a version number has valid + * syntax. * * Results: - * If string is a properly formed version number the TCL_OK - * is returned. Otherwise TCL_ERROR is returned and an error - * message is left in the interp's result. + * If string is a properly formed version number the TCL_OK is returned. + * Otherwise TCL_ERROR is returned and an error message is left in the + * interp's result. * * Side effects: * None. @@ -913,12 +889,12 @@ static int CheckVersion(interp, string) Tcl_Interp *interp; /* Used for error reporting. */ CONST char *string; /* Supposedly a version number, which is - * groups of decimal digits separated - * by dots. */ + * groups of decimal digits separated by + * dots. */ { CONST char *p = string; char prevChar; - + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } @@ -933,9 +909,9 @@ CheckVersion(interp, string) return TCL_OK; } - error: - Tcl_AppendResult(interp, "expected version number but got \"", - string, "\"", (char *) NULL); + error: + Tcl_AppendResult(interp, "expected version number but got \"", string, + "\"", (char *) NULL); return TCL_ERROR; } @@ -947,11 +923,10 @@ CheckVersion(interp, string) * This procedure compares two version numbers. * * Results: - * The return value is -1 if v1 is less than v2, 0 if the two - * version numbers are the same, and 1 if v1 is greater than v2. - * If *satPtr is non-NULL, the word it points to is filled in - * with 1 if v2 >= v1 and both numbers have the same major number - * or 0 otherwise. + * The return value is -1 if v1 is less than v2, 0 if the two version + * numbers are the same, and 1 if v1 is greater than v2. If *satPtr is + * non-NULL, the word it points to is filled in with 1 if v2 >= v1 and + * both numbers have the same major number or 0 otherwise. * * Side effects: * None. @@ -962,21 +937,20 @@ CheckVersion(interp, string) static int ComparePkgVersions(v1, v2, satPtr) CONST char *v1; - CONST char *v2; /* Versions strings, of form 2.1.3 (any - * number of version numbers). */ - int *satPtr; /* If non-null, the word pointed to is - * filled in with a 0/1 value. 1 means - * v1 "satisfies" v2: v1 is greater than - * or equal to v2 and both version numbers - * have the same major number. */ + CONST char *v2; /* Versions strings, of form 2.1.3 (any number + * of version numbers). */ + int *satPtr; /* If non-null, the word pointed to is filled + * in with a 0/1 value. 1 means v1 "satisfies" + * v2: v1 is greater than or equal to v2 and + * both version numbers have the same major + * number. */ { int thisIsMajor, n1, n2; /* - * Each iteration of the following loop processes one number from - * each string, terminated by a ".". If those numbers don't match - * then the comparison is over; otherwise, we loop back for the - * next number. + * Each iteration of the following loop processes one number from each + * string, terminated by a ".". If those numbers don't match then the + * comparison is over; otherwise, we loop back for the next number. */ thisIsMajor = 1; @@ -996,8 +970,8 @@ ComparePkgVersions(v1, v2, satPtr) } /* - * Compare and go on to the next version number if the - * current numbers match. + * Compare and go on to the next version number if the current numbers + * match. */ if (n1 != n2) { @@ -1024,3 +998,11 @@ ComparePkgVersions(v1, v2, satPtr) return -1; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c index a3aedf5..7cb2bdb 100644 --- a/generic/tclPosixStr.c +++ b/generic/tclPosixStr.c @@ -1,9 +1,8 @@ /* * tclPosixStr.c -- * - * This file contains procedures that generate strings - * corresponding to various POSIX-related codes, such - * as errno and signals. + * This file contains procedures that generate strings corresponding to + * various POSIX-related codes, such as errno and signals. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -11,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPosixStr.c,v 1.10 2004/04/06 22:25:54 dgp Exp $ + * RCS: @(#) $Id: tclPosixStr.c,v 1.11 2005/07/19 22:45:35 dkf Exp $ */ #include "tclInt.h" @@ -24,9 +23,9 @@ * Return a textual identifier for the current errno value. * * Results: - * This procedure returns a machine-readable textual identifier - * that corresponds to the current errno value (e.g. "EPERM"). - * The identifier is the same as the #define name in errno.h. + * This procedure returns a machine-readable textual identifier that + * corresponds to the current errno value (e.g. "EPERM"). The identifier + * is the same as the #define name in errno.h. * * Side effects: * None. @@ -39,421 +38,421 @@ Tcl_ErrnoId() { switch (errno) { #ifdef E2BIG - case E2BIG: return "E2BIG"; + case E2BIG: return "E2BIG"; #endif #ifdef EACCES - case EACCES: return "EACCES"; + case EACCES: return "EACCES"; #endif #ifdef EADDRINUSE - case EADDRINUSE: return "EADDRINUSE"; + case EADDRINUSE: return "EADDRINUSE"; #endif #ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; + case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; #endif #ifdef EADV - case EADV: return "EADV"; + case EADV: return "EADV"; #endif #ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return "EAFNOSUPPORT"; + case EAFNOSUPPORT: return "EAFNOSUPPORT"; #endif #ifdef EAGAIN - case EAGAIN: return "EAGAIN"; + case EAGAIN: return "EAGAIN"; #endif #ifdef EALIGN - case EALIGN: return "EALIGN"; + case EALIGN: return "EALIGN"; #endif #if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) - case EALREADY: return "EALREADY"; + case EALREADY: return "EALREADY"; #endif #ifdef EBADE - case EBADE: return "EBADE"; + case EBADE: return "EBADE"; #endif #ifdef EBADF - case EBADF: return "EBADF"; + case EBADF: return "EBADF"; #endif #ifdef EBADFD - case EBADFD: return "EBADFD"; + case EBADFD: return "EBADFD"; #endif #ifdef EBADMSG - case EBADMSG: return "EBADMSG"; + case EBADMSG: return "EBADMSG"; #endif #ifdef EBADR - case EBADR: return "EBADR"; + case EBADR: return "EBADR"; #endif #ifdef EBADRPC - case EBADRPC: return "EBADRPC"; + case EBADRPC: return "EBADRPC"; #endif #ifdef EBADRQC - case EBADRQC: return "EBADRQC"; + case EBADRQC: return "EBADRQC"; #endif #ifdef EBADSLT - case EBADSLT: return "EBADSLT"; + case EBADSLT: return "EBADSLT"; #endif #ifdef EBFONT - case EBFONT: return "EBFONT"; + case EBFONT: return "EBFONT"; #endif #ifdef EBUSY - case EBUSY: return "EBUSY"; + case EBUSY: return "EBUSY"; #endif #ifdef ECHILD - case ECHILD: return "ECHILD"; + case ECHILD: return "ECHILD"; #endif #ifdef ECHRNG - case ECHRNG: return "ECHRNG"; + case ECHRNG: return "ECHRNG"; #endif #ifdef ECOMM - case ECOMM: return "ECOMM"; + case ECOMM: return "ECOMM"; #endif #ifdef ECONNABORTED - case ECONNABORTED: return "ECONNABORTED"; + case ECONNABORTED: return "ECONNABORTED"; #endif #ifdef ECONNREFUSED - case ECONNREFUSED: return "ECONNREFUSED"; + case ECONNREFUSED: return "ECONNREFUSED"; #endif #ifdef ECONNRESET - case ECONNRESET: return "ECONNRESET"; + case ECONNRESET: return "ECONNRESET"; #endif #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) - case EDEADLK: return "EDEADLK"; + case EDEADLK: return "EDEADLK"; #endif #if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) - case EDEADLOCK: return "EDEADLOCK"; + case EDEADLOCK: return "EDEADLOCK"; #endif #ifdef EDESTADDRREQ - case EDESTADDRREQ: return "EDESTADDRREQ"; + case EDESTADDRREQ: return "EDESTADDRREQ"; #endif #ifdef EDIRTY - case EDIRTY: return "EDIRTY"; + case EDIRTY: return "EDIRTY"; #endif #ifdef EDOM - case EDOM: return "EDOM"; + case EDOM: return "EDOM"; #endif #ifdef EDOTDOT - case EDOTDOT: return "EDOTDOT"; + case EDOTDOT: return "EDOTDOT"; #endif #ifdef EDQUOT - case EDQUOT: return "EDQUOT"; + case EDQUOT: return "EDQUOT"; #endif #ifdef EDUPPKG - case EDUPPKG: return "EDUPPKG"; + case EDUPPKG: return "EDUPPKG"; #endif #ifdef EEXIST - case EEXIST: return "EEXIST"; + case EEXIST: return "EEXIST"; #endif #ifdef EFAULT - case EFAULT: return "EFAULT"; + case EFAULT: return "EFAULT"; #endif #ifdef EFBIG - case EFBIG: return "EFBIG"; + case EFBIG: return "EFBIG"; #endif #ifdef EHOSTDOWN - case EHOSTDOWN: return "EHOSTDOWN"; + case EHOSTDOWN: return "EHOSTDOWN"; #endif #ifdef EHOSTUNREACH - case EHOSTUNREACH: return "EHOSTUNREACH"; + case EHOSTUNREACH: return "EHOSTUNREACH"; #endif #if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) - case EIDRM: return "EIDRM"; + case EIDRM: return "EIDRM"; #endif #ifdef EINIT - case EINIT: return "EINIT"; + case EINIT: return "EINIT"; #endif #ifdef EINPROGRESS - case EINPROGRESS: return "EINPROGRESS"; + case EINPROGRESS: return "EINPROGRESS"; #endif #ifdef EINTR - case EINTR: return "EINTR"; + case EINTR: return "EINTR"; #endif #ifdef EINVAL - case EINVAL: return "EINVAL"; + case EINVAL: return "EINVAL"; #endif #ifdef EIO - case EIO: return "EIO"; + case EIO: return "EIO"; #endif #ifdef EISCONN - case EISCONN: return "EISCONN"; + case EISCONN: return "EISCONN"; #endif #ifdef EISDIR - case EISDIR: return "EISDIR"; + case EISDIR: return "EISDIR"; #endif #ifdef EISNAME - case EISNAM: return "EISNAM"; + case EISNAM: return "EISNAM"; #endif #ifdef ELBIN - case ELBIN: return "ELBIN"; + case ELBIN: return "ELBIN"; #endif #ifdef EL2HLT - case EL2HLT: return "EL2HLT"; + case EL2HLT: return "EL2HLT"; #endif #ifdef EL2NSYNC - case EL2NSYNC: return "EL2NSYNC"; + case EL2NSYNC: return "EL2NSYNC"; #endif #ifdef EL3HLT - case EL3HLT: return "EL3HLT"; + case EL3HLT: return "EL3HLT"; #endif #ifdef EL3RST - case EL3RST: return "EL3RST"; + case EL3RST: return "EL3RST"; #endif #ifdef ELIBACC - case ELIBACC: return "ELIBACC"; + case ELIBACC: return "ELIBACC"; #endif #ifdef ELIBBAD - case ELIBBAD: return "ELIBBAD"; + case ELIBBAD: return "ELIBBAD"; #endif #ifdef ELIBEXEC - case ELIBEXEC: return "ELIBEXEC"; + case ELIBEXEC: return "ELIBEXEC"; #endif #ifdef ELIBMAX - case ELIBMAX: return "ELIBMAX"; + case ELIBMAX: return "ELIBMAX"; #endif #ifdef ELIBSCN - case ELIBSCN: return "ELIBSCN"; + case ELIBSCN: return "ELIBSCN"; #endif #ifdef ELNRNG - case ELNRNG: return "ELNRNG"; + case ELNRNG: return "ELNRNG"; #endif #if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) - case ELOOP: return "ELOOP"; + case ELOOP: return "ELOOP"; #endif #ifdef EMFILE - case EMFILE: return "EMFILE"; + case EMFILE: return "EMFILE"; #endif #ifdef EMLINK - case EMLINK: return "EMLINK"; + case EMLINK: return "EMLINK"; #endif #ifdef EMSGSIZE - case EMSGSIZE: return "EMSGSIZE"; + case EMSGSIZE: return "EMSGSIZE"; #endif #ifdef EMULTIHOP - case EMULTIHOP: return "EMULTIHOP"; + case EMULTIHOP: return "EMULTIHOP"; #endif #ifdef ENAMETOOLONG - case ENAMETOOLONG: return "ENAMETOOLONG"; + case ENAMETOOLONG: return "ENAMETOOLONG"; #endif #ifdef ENAVAIL - case ENAVAIL: return "ENAVAIL"; + case ENAVAIL: return "ENAVAIL"; #endif #ifdef ENET - case ENET: return "ENET"; + case ENET: return "ENET"; #endif #ifdef ENETDOWN - case ENETDOWN: return "ENETDOWN"; + case ENETDOWN: return "ENETDOWN"; #endif #ifdef ENETRESET - case ENETRESET: return "ENETRESET"; + case ENETRESET: return "ENETRESET"; #endif #ifdef ENETUNREACH - case ENETUNREACH: return "ENETUNREACH"; + case ENETUNREACH: return "ENETUNREACH"; #endif #ifdef ENFILE - case ENFILE: return "ENFILE"; + case ENFILE: return "ENFILE"; #endif #ifdef ENOANO - case ENOANO: return "ENOANO"; + case ENOANO: return "ENOANO"; #endif #if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) - case ENOBUFS: return "ENOBUFS"; + case ENOBUFS: return "ENOBUFS"; #endif #ifdef ENOCSI - case ENOCSI: return "ENOCSI"; + case ENOCSI: return "ENOCSI"; #endif #if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) - case ENODATA: return "ENODATA"; + case ENODATA: return "ENODATA"; #endif #ifdef ENODEV - case ENODEV: return "ENODEV"; + case ENODEV: return "ENODEV"; #endif #ifdef ENOENT - case ENOENT: return "ENOENT"; + case ENOENT: return "ENOENT"; #endif #ifdef ENOEXEC - case ENOEXEC: return "ENOEXEC"; + case ENOEXEC: return "ENOEXEC"; #endif #ifdef ENOLCK - case ENOLCK: return "ENOLCK"; + case ENOLCK: return "ENOLCK"; #endif #ifdef ENOLINK - case ENOLINK: return "ENOLINK"; + case ENOLINK: return "ENOLINK"; #endif #ifdef ENOMEM - case ENOMEM: return "ENOMEM"; + case ENOMEM: return "ENOMEM"; #endif #ifdef ENOMSG - case ENOMSG: return "ENOMSG"; + case ENOMSG: return "ENOMSG"; #endif #ifdef ENONET - case ENONET: return "ENONET"; + case ENONET: return "ENONET"; #endif #ifdef ENOPKG - case ENOPKG: return "ENOPKG"; + case ENOPKG: return "ENOPKG"; #endif #ifdef ENOPROTOOPT - case ENOPROTOOPT: return "ENOPROTOOPT"; + case ENOPROTOOPT: return "ENOPROTOOPT"; #endif #ifdef ENOSPC - case ENOSPC: return "ENOSPC"; + case ENOSPC: return "ENOSPC"; #endif #if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) - case ENOSR: return "ENOSR"; + case ENOSR: return "ENOSR"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) - case ENOSTR: return "ENOSTR"; + case ENOSTR: return "ENOSTR"; #endif #ifdef ENOSYM - case ENOSYM: return "ENOSYM"; + case ENOSYM: return "ENOSYM"; #endif #ifdef ENOSYS - case ENOSYS: return "ENOSYS"; + case ENOSYS: return "ENOSYS"; #endif #ifdef ENOTBLK - case ENOTBLK: return "ENOTBLK"; + case ENOTBLK: return "ENOTBLK"; #endif #ifdef ENOTCONN - case ENOTCONN: return "ENOTCONN"; + case ENOTCONN: return "ENOTCONN"; #endif #ifdef ENOTDIR - case ENOTDIR: return "ENOTDIR"; + case ENOTDIR: return "ENOTDIR"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) - case ENOTEMPTY: return "ENOTEMPTY"; + case ENOTEMPTY: return "ENOTEMPTY"; #endif #ifdef ENOTNAM - case ENOTNAM: return "ENOTNAM"; + case ENOTNAM: return "ENOTNAM"; #endif #ifdef ENOTSOCK - case ENOTSOCK: return "ENOTSOCK"; + case ENOTSOCK: return "ENOTSOCK"; #endif #ifdef ENOTSUP - case ENOTSUP: return "ENOTSUP"; + case ENOTSUP: return "ENOTSUP"; #endif #ifdef ENOTTY - case ENOTTY: return "ENOTTY"; + case ENOTTY: return "ENOTTY"; #endif #ifdef ENOTUNIQ - case ENOTUNIQ: return "ENOTUNIQ"; + case ENOTUNIQ: return "ENOTUNIQ"; #endif #ifdef ENXIO - case ENXIO: return "ENXIO"; + case ENXIO: return "ENXIO"; #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) - case EOPNOTSUPP: return "EOPNOTSUPP"; + case EOPNOTSUPP: return "EOPNOTSUPP"; #endif #if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) - case EOVERFLOW: return "EOVERFLOW"; + case EOVERFLOW: return "EOVERFLOW"; #endif #ifdef EPERM - case EPERM: return "EPERM"; + case EPERM: return "EPERM"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) - case EPFNOSUPPORT: return "EPFNOSUPPORT"; + case EPFNOSUPPORT: return "EPFNOSUPPORT"; #endif #ifdef EPIPE - case EPIPE: return "EPIPE"; + case EPIPE: return "EPIPE"; #endif #ifdef EPROCLIM - case EPROCLIM: return "EPROCLIM"; + case EPROCLIM: return "EPROCLIM"; #endif #ifdef EPROCUNAVAIL - case EPROCUNAVAIL: return "EPROCUNAVAIL"; + case EPROCUNAVAIL: return "EPROCUNAVAIL"; #endif #ifdef EPROGMISMATCH - case EPROGMISMATCH: return "EPROGMISMATCH"; + case EPROGMISMATCH: return "EPROGMISMATCH"; #endif #ifdef EPROGUNAVAIL - case EPROGUNAVAIL: return "EPROGUNAVAIL"; + case EPROGUNAVAIL: return "EPROGUNAVAIL"; #endif #ifdef EPROTO - case EPROTO: return "EPROTO"; + case EPROTO: return "EPROTO"; #endif #ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; + case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; #endif #ifdef EPROTOTYPE - case EPROTOTYPE: return "EPROTOTYPE"; + case EPROTOTYPE: return "EPROTOTYPE"; #endif #ifdef ERANGE - case ERANGE: return "ERANGE"; + case ERANGE: return "ERANGE"; #endif #if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) - case EREFUSED: return "EREFUSED"; + case EREFUSED: return "EREFUSED"; #endif #ifdef EREMCHG - case EREMCHG: return "EREMCHG"; + case EREMCHG: return "EREMCHG"; #endif #ifdef EREMDEV - case EREMDEV: return "EREMDEV"; + case EREMDEV: return "EREMDEV"; #endif #ifdef EREMOTE - case EREMOTE: return "EREMOTE"; + case EREMOTE: return "EREMOTE"; #endif #ifdef EREMOTEIO - case EREMOTEIO: return "EREMOTEIO"; + case EREMOTEIO: return "EREMOTEIO"; #endif #ifdef EREMOTERELEASE - case EREMOTERELEASE: return "EREMOTERELEASE"; + case EREMOTERELEASE: return "EREMOTERELEASE"; #endif #ifdef EROFS - case EROFS: return "EROFS"; + case EROFS: return "EROFS"; #endif #ifdef ERPCMISMATCH - case ERPCMISMATCH: return "ERPCMISMATCH"; + case ERPCMISMATCH: return "ERPCMISMATCH"; #endif #ifdef ERREMOTE - case ERREMOTE: return "ERREMOTE"; + case ERREMOTE: return "ERREMOTE"; #endif #ifdef ESHUTDOWN - case ESHUTDOWN: return "ESHUTDOWN"; + case ESHUTDOWN: return "ESHUTDOWN"; #endif #ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; + case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; #endif #ifdef ESPIPE - case ESPIPE: return "ESPIPE"; + case ESPIPE: return "ESPIPE"; #endif #ifdef ESRCH - case ESRCH: return "ESRCH"; + case ESRCH: return "ESRCH"; #endif #ifdef ESRMNT - case ESRMNT: return "ESRMNT"; + case ESRMNT: return "ESRMNT"; #endif #ifdef ESTALE - case ESTALE: return "ESTALE"; + case ESTALE: return "ESTALE"; #endif #ifdef ESUCCESS - case ESUCCESS: return "ESUCCESS"; + case ESUCCESS: return "ESUCCESS"; #endif #if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) - case ETIME: return "ETIME"; + case ETIME: return "ETIME"; #endif #if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) - case ETIMEDOUT: return "ETIMEDOUT"; + case ETIMEDOUT: return "ETIMEDOUT"; #endif #ifdef ETOOMANYREFS - case ETOOMANYREFS: return "ETOOMANYREFS"; + case ETOOMANYREFS: return "ETOOMANYREFS"; #endif #ifdef ETXTBSY - case ETXTBSY: return "ETXTBSY"; + case ETXTBSY: return "ETXTBSY"; #endif #ifdef EUCLEAN - case EUCLEAN: return "EUCLEAN"; + case EUCLEAN: return "EUCLEAN"; #endif #ifdef EUNATCH - case EUNATCH: return "EUNATCH"; + case EUNATCH: return "EUNATCH"; #endif #ifdef EUSERS - case EUSERS: return "EUSERS"; + case EUSERS: return "EUSERS"; #endif #ifdef EVERSION - case EVERSION: return "EVERSION"; + case EVERSION: return "EVERSION"; #endif #if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) - case EWOULDBLOCK: return "EWOULDBLOCK"; + case EWOULDBLOCK: return "EWOULDBLOCK"; #endif #ifdef EXDEV - case EXDEV: return "EXDEV"; + case EXDEV: return "EXDEV"; #endif #ifdef EXFULL - case EXFULL: return "EXFULL"; + case EXFULL: return "EXFULL"; #endif } return "unknown error"; @@ -464,17 +463,15 @@ Tcl_ErrnoId() * * Tcl_ErrnoMsg -- * - * Return a human-readable message corresponding to a given - * errno value. + * Return a human-readable message corresponding to a given errno value. * * Results: - * The return value is the standard POSIX error message for - * errno. This procedure is used instead of strerror because - * strerror returns slightly different values on different - * machines (e.g. different capitalizations), which cause - * problems for things such as regression tests. This procedure - * provides messages for most standard errors, then it calls - * strerror for things it doesn't understand. + * The return value is the standard POSIX error message for errno. This + * procedure is used instead of strerror because strerror returns + * slightly different values on different machines (e.g. different + * capitalizations), which cause problems for things such as regression + * tests. This procedure provides messages for most standard errors, then + * it calls strerror for things it doesn't understand. * * Side effects: * None. @@ -484,432 +481,432 @@ Tcl_ErrnoId() CONST char * Tcl_ErrnoMsg(err) - int err; /* Error number (such as in errno variable). */ + int err; /* Error number (such as in errno variable). */ { switch (err) { #ifdef E2BIG - case E2BIG: return "argument list too long"; + case E2BIG: return "argument list too long"; #endif #ifdef EACCES - case EACCES: return "permission denied"; + case EACCES: return "permission denied"; #endif #ifdef EADDRINUSE - case EADDRINUSE: return "address already in use"; + case EADDRINUSE: return "address already in use"; #endif #ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return "can't assign requested address"; + case EADDRNOTAVAIL: return "can't assign requested address"; #endif #ifdef EADV - case EADV: return "advertise error"; + case EADV: return "advertise error"; #endif #ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return "address family not supported by protocol family"; + case EAFNOSUPPORT: return "address family not supported by protocol family"; #endif #ifdef EAGAIN - case EAGAIN: return "resource temporarily unavailable"; + case EAGAIN: return "resource temporarily unavailable"; #endif #ifdef EALIGN - case EALIGN: return "EALIGN"; + case EALIGN: return "EALIGN"; #endif #if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) - case EALREADY: return "operation already in progress"; + case EALREADY: return "operation already in progress"; #endif #ifdef EBADE - case EBADE: return "bad exchange descriptor"; + case EBADE: return "bad exchange descriptor"; #endif #ifdef EBADF - case EBADF: return "bad file number"; + case EBADF: return "bad file number"; #endif #ifdef EBADFD - case EBADFD: return "file descriptor in bad state"; + case EBADFD: return "file descriptor in bad state"; #endif #ifdef EBADMSG - case EBADMSG: return "not a data message"; + case EBADMSG: return "not a data message"; #endif #ifdef EBADR - case EBADR: return "bad request descriptor"; + case EBADR: return "bad request descriptor"; #endif #ifdef EBADRPC - case EBADRPC: return "RPC structure is bad"; + case EBADRPC: return "RPC structure is bad"; #endif #ifdef EBADRQC - case EBADRQC: return "bad request code"; + case EBADRQC: return "bad request code"; #endif #ifdef EBADSLT - case EBADSLT: return "invalid slot"; + case EBADSLT: return "invalid slot"; #endif #ifdef EBFONT - case EBFONT: return "bad font file format"; + case EBFONT: return "bad font file format"; #endif #ifdef EBUSY - case EBUSY: return "file busy"; + case EBUSY: return "file busy"; #endif #ifdef ECHILD - case ECHILD: return "no children"; + case ECHILD: return "no children"; #endif #ifdef ECHRNG - case ECHRNG: return "channel number out of range"; + case ECHRNG: return "channel number out of range"; #endif #ifdef ECOMM - case ECOMM: return "communication error on send"; + case ECOMM: return "communication error on send"; #endif #ifdef ECONNABORTED - case ECONNABORTED: return "software caused connection abort"; + case ECONNABORTED: return "software caused connection abort"; #endif #ifdef ECONNREFUSED - case ECONNREFUSED: return "connection refused"; + case ECONNREFUSED: return "connection refused"; #endif #ifdef ECONNRESET - case ECONNRESET: return "connection reset by peer"; + case ECONNRESET: return "connection reset by peer"; #endif #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) - case EDEADLK: return "resource deadlock avoided"; + case EDEADLK: return "resource deadlock avoided"; #endif #if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) - case EDEADLOCK: return "resource deadlock avoided"; + case EDEADLOCK: return "resource deadlock avoided"; #endif #ifdef EDESTADDRREQ - case EDESTADDRREQ: return "destination address required"; + case EDESTADDRREQ: return "destination address required"; #endif #ifdef EDIRTY - case EDIRTY: return "mounting a dirty fs w/o force"; + case EDIRTY: return "mounting a dirty fs w/o force"; #endif #ifdef EDOM - case EDOM: return "math argument out of range"; + case EDOM: return "math argument out of range"; #endif #ifdef EDOTDOT - case EDOTDOT: return "cross mount point"; + case EDOTDOT: return "cross mount point"; #endif #ifdef EDQUOT - case EDQUOT: return "disk quota exceeded"; + case EDQUOT: return "disk quota exceeded"; #endif #ifdef EDUPPKG - case EDUPPKG: return "duplicate package name"; + case EDUPPKG: return "duplicate package name"; #endif #ifdef EEXIST - case EEXIST: return "file already exists"; + case EEXIST: return "file already exists"; #endif #ifdef EFAULT - case EFAULT: return "bad address in system call argument"; + case EFAULT: return "bad address in system call argument"; #endif #ifdef EFBIG - case EFBIG: return "file too large"; + case EFBIG: return "file too large"; #endif #ifdef EHOSTDOWN - case EHOSTDOWN: return "host is down"; + case EHOSTDOWN: return "host is down"; #endif #ifdef EHOSTUNREACH - case EHOSTUNREACH: return "host is unreachable"; + case EHOSTUNREACH: return "host is unreachable"; #endif #if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) - case EIDRM: return "identifier removed"; + case EIDRM: return "identifier removed"; #endif #ifdef EINIT - case EINIT: return "initialization error"; + case EINIT: return "initialization error"; #endif #ifdef EINPROGRESS - case EINPROGRESS: return "operation now in progress"; + case EINPROGRESS: return "operation now in progress"; #endif #ifdef EINTR - case EINTR: return "interrupted system call"; + case EINTR: return "interrupted system call"; #endif #ifdef EINVAL - case EINVAL: return "invalid argument"; + case EINVAL: return "invalid argument"; #endif #ifdef EIO - case EIO: return "I/O error"; + case EIO: return "I/O error"; #endif #ifdef EISCONN - case EISCONN: return "socket is already connected"; + case EISCONN: return "socket is already connected"; #endif #ifdef EISDIR - case EISDIR: return "illegal operation on a directory"; + case EISDIR: return "illegal operation on a directory"; #endif #ifdef EISNAME - case EISNAM: return "is a name file"; + case EISNAM: return "is a name file"; #endif #ifdef ELBIN - case ELBIN: return "ELBIN"; + case ELBIN: return "ELBIN"; #endif #ifdef EL2HLT - case EL2HLT: return "level 2 halted"; + case EL2HLT: return "level 2 halted"; #endif #ifdef EL2NSYNC - case EL2NSYNC: return "level 2 not synchronized"; + case EL2NSYNC: return "level 2 not synchronized"; #endif #ifdef EL3HLT - case EL3HLT: return "level 3 halted"; + case EL3HLT: return "level 3 halted"; #endif #ifdef EL3RST - case EL3RST: return "level 3 reset"; + case EL3RST: return "level 3 reset"; #endif #ifdef ELIBACC - case ELIBACC: return "can not access a needed shared library"; + case ELIBACC: return "can not access a needed shared library"; #endif #ifdef ELIBBAD - case ELIBBAD: return "accessing a corrupted shared library"; + case ELIBBAD: return "accessing a corrupted shared library"; #endif #ifdef ELIBEXEC - case ELIBEXEC: return "can not exec a shared library directly"; + case ELIBEXEC: return "can not exec a shared library directly"; #endif #ifdef ELIBMAX - case ELIBMAX: return - "attempting to link in more shared libraries than system limit"; + case ELIBMAX: return + "attempting to link in more shared libraries than system limit"; #endif #ifdef ELIBSCN - case ELIBSCN: return ".lib section in a.out corrupted"; + case ELIBSCN: return ".lib section in a.out corrupted"; #endif #ifdef ELNRNG - case ELNRNG: return "link number out of range"; + case ELNRNG: return "link number out of range"; #endif #if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) - case ELOOP: return "too many levels of symbolic links"; + case ELOOP: return "too many levels of symbolic links"; #endif #ifdef EMFILE - case EMFILE: return "too many open files"; + case EMFILE: return "too many open files"; #endif #ifdef EMLINK - case EMLINK: return "too many links"; + case EMLINK: return "too many links"; #endif #ifdef EMSGSIZE - case EMSGSIZE: return "message too long"; + case EMSGSIZE: return "message too long"; #endif #ifdef EMULTIHOP - case EMULTIHOP: return "multihop attempted"; + case EMULTIHOP: return "multihop attempted"; #endif #ifdef ENAMETOOLONG - case ENAMETOOLONG: return "file name too long"; + case ENAMETOOLONG: return "file name too long"; #endif #ifdef ENAVAIL - case ENAVAIL: return "not available"; + case ENAVAIL: return "not available"; #endif #ifdef ENET - case ENET: return "ENET"; + case ENET: return "ENET"; #endif #ifdef ENETDOWN - case ENETDOWN: return "network is down"; + case ENETDOWN: return "network is down"; #endif #ifdef ENETRESET - case ENETRESET: return "network dropped connection on reset"; + case ENETRESET: return "network dropped connection on reset"; #endif #ifdef ENETUNREACH - case ENETUNREACH: return "network is unreachable"; + case ENETUNREACH: return "network is unreachable"; #endif #ifdef ENFILE - case ENFILE: return "file table overflow"; + case ENFILE: return "file table overflow"; #endif #ifdef ENOANO - case ENOANO: return "anode table overflow"; + case ENOANO: return "anode table overflow"; #endif #if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) - case ENOBUFS: return "no buffer space available"; + case ENOBUFS: return "no buffer space available"; #endif #ifdef ENOCSI - case ENOCSI: return "no CSI structure available"; + case ENOCSI: return "no CSI structure available"; #endif #if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) - case ENODATA: return "no data available"; + case ENODATA: return "no data available"; #endif #ifdef ENODEV - case ENODEV: return "no such device"; + case ENODEV: return "no such device"; #endif #ifdef ENOENT - case ENOENT: return "no such file or directory"; + case ENOENT: return "no such file or directory"; #endif #ifdef ENOEXEC - case ENOEXEC: return "exec format error"; + case ENOEXEC: return "exec format error"; #endif #ifdef ENOLCK - case ENOLCK: return "no locks available"; + case ENOLCK: return "no locks available"; #endif #ifdef ENOLINK - case ENOLINK: return "link has be severed"; + case ENOLINK: return "link has be severed"; #endif #ifdef ENOMEM - case ENOMEM: return "not enough memory"; + case ENOMEM: return "not enough memory"; #endif #ifdef ENOMSG - case ENOMSG: return "no message of desired type"; + case ENOMSG: return "no message of desired type"; #endif #ifdef ENONET - case ENONET: return "machine is not on the network"; + case ENONET: return "machine is not on the network"; #endif #ifdef ENOPKG - case ENOPKG: return "package not installed"; + case ENOPKG: return "package not installed"; #endif #ifdef ENOPROTOOPT - case ENOPROTOOPT: return "bad protocol option"; + case ENOPROTOOPT: return "bad protocol option"; #endif #ifdef ENOSPC - case ENOSPC: return "no space left on device"; + case ENOSPC: return "no space left on device"; #endif #if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) - case ENOSR: return "out of stream resources"; + case ENOSR: return "out of stream resources"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) - case ENOSTR: return "not a stream device"; + case ENOSTR: return "not a stream device"; #endif #ifdef ENOSYM - case ENOSYM: return "unresolved symbol name"; + case ENOSYM: return "unresolved symbol name"; #endif #ifdef ENOSYS - case ENOSYS: return "function not implemented"; + case ENOSYS: return "function not implemented"; #endif #ifdef ENOTBLK - case ENOTBLK: return "block device required"; + case ENOTBLK: return "block device required"; #endif #ifdef ENOTCONN - case ENOTCONN: return "socket is not connected"; + case ENOTCONN: return "socket is not connected"; #endif #ifdef ENOTDIR - case ENOTDIR: return "not a directory"; + case ENOTDIR: return "not a directory"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) - case ENOTEMPTY: return "directory not empty"; + case ENOTEMPTY: return "directory not empty"; #endif #ifdef ENOTNAM - case ENOTNAM: return "not a name file"; + case ENOTNAM: return "not a name file"; #endif #ifdef ENOTSOCK - case ENOTSOCK: return "socket operation on non-socket"; + case ENOTSOCK: return "socket operation on non-socket"; #endif #ifdef ENOTSUP - case ENOTSUP: return "operation not supported"; + case ENOTSUP: return "operation not supported"; #endif #ifdef ENOTTY - case ENOTTY: return "inappropriate device for ioctl"; + case ENOTTY: return "inappropriate device for ioctl"; #endif #ifdef ENOTUNIQ - case ENOTUNIQ: return "name not unique on network"; + case ENOTUNIQ: return "name not unique on network"; #endif #ifdef ENXIO - case ENXIO: return "no such device or address"; + case ENXIO: return "no such device or address"; #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) - case EOPNOTSUPP: return "operation not supported on socket"; + case EOPNOTSUPP: return "operation not supported on socket"; #endif #if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) - case EOVERFLOW: return "file too big"; + case EOVERFLOW: return "file too big"; #endif #ifdef EPERM - case EPERM: return "not owner"; + case EPERM: return "not owner"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) - case EPFNOSUPPORT: return "protocol family not supported"; + case EPFNOSUPPORT: return "protocol family not supported"; #endif #ifdef EPIPE - case EPIPE: return "broken pipe"; + case EPIPE: return "broken pipe"; #endif #ifdef EPROCLIM - case EPROCLIM: return "too many processes"; + case EPROCLIM: return "too many processes"; #endif #ifdef EPROCUNAVAIL - case EPROCUNAVAIL: return "bad procedure for program"; + case EPROCUNAVAIL: return "bad procedure for program"; #endif #ifdef EPROGMISMATCH - case EPROGMISMATCH: return "program version wrong"; + case EPROGMISMATCH: return "program version wrong"; #endif #ifdef EPROGUNAVAIL - case EPROGUNAVAIL: return "RPC program not available"; + case EPROGUNAVAIL: return "RPC program not available"; #endif #ifdef EPROTO - case EPROTO: return "protocol error"; + case EPROTO: return "protocol error"; #endif #ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return "protocol not suppored"; + case EPROTONOSUPPORT: return "protocol not suppored"; #endif #ifdef EPROTOTYPE - case EPROTOTYPE: return "protocol wrong type for socket"; + case EPROTOTYPE: return "protocol wrong type for socket"; #endif #ifdef ERANGE - case ERANGE: return "math result unrepresentable"; + case ERANGE: return "math result unrepresentable"; #endif #if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) - case EREFUSED: return "EREFUSED"; + case EREFUSED: return "EREFUSED"; #endif #ifdef EREMCHG - case EREMCHG: return "remote address changed"; + case EREMCHG: return "remote address changed"; #endif #ifdef EREMDEV - case EREMDEV: return "remote device"; + case EREMDEV: return "remote device"; #endif #ifdef EREMOTE - case EREMOTE: return "pathname hit remote file system"; + case EREMOTE: return "pathname hit remote file system"; #endif #ifdef EREMOTEIO - case EREMOTEIO: return "remote i/o error"; + case EREMOTEIO: return "remote i/o error"; #endif #ifdef EREMOTERELEASE - case EREMOTERELEASE: return "EREMOTERELEASE"; + case EREMOTERELEASE: return "EREMOTERELEASE"; #endif #ifdef EROFS - case EROFS: return "read-only file system"; + case EROFS: return "read-only file system"; #endif #ifdef ERPCMISMATCH - case ERPCMISMATCH: return "RPC version is wrong"; + case ERPCMISMATCH: return "RPC version is wrong"; #endif #ifdef ERREMOTE - case ERREMOTE: return "object is remote"; + case ERREMOTE: return "object is remote"; #endif #ifdef ESHUTDOWN - case ESHUTDOWN: return "can't send afer socket shutdown"; + case ESHUTDOWN: return "can't send afer socket shutdown"; #endif #ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return "socket type not supported"; + case ESOCKTNOSUPPORT: return "socket type not supported"; #endif #ifdef ESPIPE - case ESPIPE: return "invalid seek"; + case ESPIPE: return "invalid seek"; #endif #ifdef ESRCH - case ESRCH: return "no such process"; + case ESRCH: return "no such process"; #endif #ifdef ESRMNT - case ESRMNT: return "srmount error"; + case ESRMNT: return "srmount error"; #endif #ifdef ESTALE - case ESTALE: return "stale remote file handle"; + case ESTALE: return "stale remote file handle"; #endif #ifdef ESUCCESS - case ESUCCESS: return "Error 0"; + case ESUCCESS: return "Error 0"; #endif #if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) - case ETIME: return "timer expired"; + case ETIME: return "timer expired"; #endif #if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) - case ETIMEDOUT: return "connection timed out"; + case ETIMEDOUT: return "connection timed out"; #endif #ifdef ETOOMANYREFS - case ETOOMANYREFS: return "too many references: can't splice"; + case ETOOMANYREFS: return "too many references: can't splice"; #endif #ifdef ETXTBSY - case ETXTBSY: return "text file or pseudo-device busy"; + case ETXTBSY: return "text file or pseudo-device busy"; #endif #ifdef EUCLEAN - case EUCLEAN: return "structure needs cleaning"; + case EUCLEAN: return "structure needs cleaning"; #endif #ifdef EUNATCH - case EUNATCH: return "protocol driver not attached"; + case EUNATCH: return "protocol driver not attached"; #endif #ifdef EUSERS - case EUSERS: return "too many users"; + case EUSERS: return "too many users"; #endif #ifdef EVERSION - case EVERSION: return "version mismatch"; + case EVERSION: return "version mismatch"; #endif #if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) - case EWOULDBLOCK: return "operation would block"; + case EWOULDBLOCK: return "operation would block"; #endif #ifdef EXDEV - case EXDEV: return "cross-domain link"; + case EXDEV: return "cross-domain link"; #endif #ifdef EXFULL - case EXFULL: return "message tables full"; + case EXFULL: return "message tables full"; #endif - default: + default: #ifdef NO_STRERROR - return "unknown POSIX error"; + return "unknown POSIX error"; #else - return strerror(errno); + return strerror(errno); #endif } } @@ -922,9 +919,9 @@ Tcl_ErrnoMsg(err) * Return a textual identifier for a signal number. * * Results: - * This procedure returns a machine-readable textual identifier - * that corresponds to sig. The identifier is the same as the - * #define name in signal.h. + * This procedure returns a machine-readable textual identifier that + * corresponds to sig. The identifier is the same as the #define name in + * signal.h. * * Side effects: * None. @@ -934,113 +931,113 @@ Tcl_ErrnoMsg(err) CONST char * Tcl_SignalId(sig) - int sig; /* Number of signal. */ + int sig; /* Number of signal. */ { switch (sig) { #ifdef SIGABRT - case SIGABRT: return "SIGABRT"; + case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM - case SIGALRM: return "SIGALRM"; + case SIGALRM: return "SIGALRM"; #endif #ifdef SIGBUS - case SIGBUS: return "SIGBUS"; + case SIGBUS: return "SIGBUS"; #endif #ifdef SIGCHLD - case SIGCHLD: return "SIGCHLD"; + case SIGCHLD: return "SIGCHLD"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) - case SIGCLD: return "SIGCLD"; + case SIGCLD: return "SIGCLD"; #endif #ifdef SIGCONT - case SIGCONT: return "SIGCONT"; + case SIGCONT: return "SIGCONT"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) - case SIGEMT: return "SIGEMT"; + case SIGEMT: return "SIGEMT"; #endif #ifdef SIGFPE - case SIGFPE: return "SIGFPE"; + case SIGFPE: return "SIGFPE"; #endif #ifdef SIGHUP - case SIGHUP: return "SIGHUP"; + case SIGHUP: return "SIGHUP"; #endif #ifdef SIGILL - case SIGILL: return "SIGILL"; + case SIGILL: return "SIGILL"; #endif #ifdef SIGINT - case SIGINT: return "SIGINT"; + case SIGINT: return "SIGINT"; #endif #ifdef SIGIO - case SIGIO: return "SIGIO"; + case SIGIO: return "SIGIO"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) - case SIGIOT: return "SIGIOT"; + case SIGIOT: return "SIGIOT"; #endif #ifdef SIGKILL - case SIGKILL: return "SIGKILL"; + case SIGKILL: return "SIGKILL"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) - case SIGLOST: return "SIGLOST"; + case SIGLOST: return "SIGLOST"; #endif #ifdef SIGPIPE - case SIGPIPE: return "SIGPIPE"; + case SIGPIPE: return "SIGPIPE"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) - case SIGPOLL: return "SIGPOLL"; + case SIGPOLL: return "SIGPOLL"; #endif #ifdef SIGPROF - case SIGPROF: return "SIGPROF"; + case SIGPROF: return "SIGPROF"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST)) - case SIGPWR: return "SIGPWR"; + case SIGPWR: return "SIGPWR"; #endif #ifdef SIGQUIT - case SIGQUIT: return "SIGQUIT"; + case SIGQUIT: return "SIGQUIT"; #endif #ifdef SIGSEGV - case SIGSEGV: return "SIGSEGV"; + case SIGSEGV: return "SIGSEGV"; #endif #ifdef SIGSTOP - case SIGSTOP: return "SIGSTOP"; + case SIGSTOP: return "SIGSTOP"; #endif #ifdef SIGSYS - case SIGSYS: return "SIGSYS"; + case SIGSYS: return "SIGSYS"; #endif #ifdef SIGTERM - case SIGTERM: return "SIGTERM"; + case SIGTERM: return "SIGTERM"; #endif #ifdef SIGTRAP - case SIGTRAP: return "SIGTRAP"; + case SIGTRAP: return "SIGTRAP"; #endif #ifdef SIGTSTP - case SIGTSTP: return "SIGTSTP"; + case SIGTSTP: return "SIGTSTP"; #endif #ifdef SIGTTIN - case SIGTTIN: return "SIGTTIN"; + case SIGTTIN: return "SIGTTIN"; #endif #ifdef SIGTTOU - case SIGTTOU: return "SIGTTOU"; + case SIGTTOU: return "SIGTTOU"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) - case SIGURG: return "SIGURG"; + case SIGURG: return "SIGURG"; #endif #if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) - case SIGUSR1: return "SIGUSR1"; + case SIGUSR1: return "SIGUSR1"; #endif #if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) - case SIGUSR2: return "SIGUSR2"; + case SIGUSR2: return "SIGUSR2"; #endif #ifdef SIGVTALRM - case SIGVTALRM: return "SIGVTALRM"; + case SIGVTALRM: return "SIGVTALRM"; #endif #ifdef SIGWINCH - case SIGWINCH: return "SIGWINCH"; + case SIGWINCH: return "SIGWINCH"; #endif #ifdef SIGXCPU - case SIGXCPU: return "SIGXCPU"; + case SIGXCPU: return "SIGXCPU"; #endif #ifdef SIGXFSZ - case SIGXFSZ: return "SIGXFSZ"; + case SIGXFSZ: return "SIGXFSZ"; #endif } return "unknown signal"; @@ -1054,9 +1051,8 @@ Tcl_SignalId(sig) * Return a human-readable message describing a signal. * * Results: - * This procedure returns a string describing sig that should - * make sense to a human. It may not be easy for a machine - * to parse. + * This procedure returns a string describing sig that should make sense + * to a human. It may not be easy for a machine to parse. * * Side effects: * None. @@ -1066,114 +1062,122 @@ Tcl_SignalId(sig) CONST char * Tcl_SignalMsg(sig) - int sig; /* Number of signal. */ + int sig; /* Number of signal. */ { switch (sig) { #ifdef SIGABRT - case SIGABRT: return "SIGABRT"; + case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM - case SIGALRM: return "alarm clock"; + case SIGALRM: return "alarm clock"; #endif #ifdef SIGBUS - case SIGBUS: return "bus error"; + case SIGBUS: return "bus error"; #endif #ifdef SIGCHLD - case SIGCHLD: return "child status changed"; + case SIGCHLD: return "child status changed"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) - case SIGCLD: return "child status changed"; + case SIGCLD: return "child status changed"; #endif #ifdef SIGCONT - case SIGCONT: return "continue after stop"; + case SIGCONT: return "continue after stop"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) - case SIGEMT: return "EMT instruction"; + case SIGEMT: return "EMT instruction"; #endif #ifdef SIGFPE - case SIGFPE: return "floating-point exception"; + case SIGFPE: return "floating-point exception"; #endif #ifdef SIGHUP - case SIGHUP: return "hangup"; + case SIGHUP: return "hangup"; #endif #ifdef SIGILL - case SIGILL: return "illegal instruction"; + case SIGILL: return "illegal instruction"; #endif #ifdef SIGINT - case SIGINT: return "interrupt"; + case SIGINT: return "interrupt"; #endif #ifdef SIGIO - case SIGIO: return "input/output possible on file"; + case SIGIO: return "input/output possible on file"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) - case SIGIOT: return "IOT instruction"; + case SIGIOT: return "IOT instruction"; #endif #ifdef SIGKILL - case SIGKILL: return "kill signal"; + case SIGKILL: return "kill signal"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) - case SIGLOST: return "resource lost"; + case SIGLOST: return "resource lost"; #endif #ifdef SIGPIPE - case SIGPIPE: return "write on pipe with no readers"; + case SIGPIPE: return "write on pipe with no readers"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) - case SIGPOLL: return "input/output possible on file"; + case SIGPOLL: return "input/output possible on file"; #endif #ifdef SIGPROF - case SIGPROF: return "profiling alarm"; + case SIGPROF: return "profiling alarm"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST)) - case SIGPWR: return "power-fail restart"; + case SIGPWR: return "power-fail restart"; #endif #ifdef SIGQUIT - case SIGQUIT: return "quit signal"; + case SIGQUIT: return "quit signal"; #endif #ifdef SIGSEGV - case SIGSEGV: return "segmentation violation"; + case SIGSEGV: return "segmentation violation"; #endif #ifdef SIGSTOP - case SIGSTOP: return "stop"; + case SIGSTOP: return "stop"; #endif #ifdef SIGSYS - case SIGSYS: return "bad argument to system call"; + case SIGSYS: return "bad argument to system call"; #endif #ifdef SIGTERM - case SIGTERM: return "software termination signal"; + case SIGTERM: return "software termination signal"; #endif #ifdef SIGTRAP - case SIGTRAP: return "trace trap"; + case SIGTRAP: return "trace trap"; #endif #ifdef SIGTSTP - case SIGTSTP: return "stop signal from tty"; + case SIGTSTP: return "stop signal from tty"; #endif #ifdef SIGTTIN - case SIGTTIN: return "background tty read"; + case SIGTTIN: return "background tty read"; #endif #ifdef SIGTTOU - case SIGTTOU: return "background tty write"; + case SIGTTOU: return "background tty write"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) - case SIGURG: return "urgent I/O condition"; + case SIGURG: return "urgent I/O condition"; #endif #if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) - case SIGUSR1: return "user-defined signal 1"; + case SIGUSR1: return "user-defined signal 1"; #endif #if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) - case SIGUSR2: return "user-defined signal 2"; + case SIGUSR2: return "user-defined signal 2"; #endif #ifdef SIGVTALRM - case SIGVTALRM: return "virtual time alarm"; + case SIGVTALRM: return "virtual time alarm"; #endif #ifdef SIGWINCH - case SIGWINCH: return "window changed"; + case SIGWINCH: return "window changed"; #endif #ifdef SIGXCPU - case SIGXCPU: return "exceeded CPU time limit"; + case SIGXCPU: return "exceeded CPU time limit"; #endif #ifdef SIGXFSZ - case SIGXFSZ: return "exceeded file size limit"; + case SIGXFSZ: return "exceeded file size limit"; #endif } return "unknown signal"; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index 51d320f..7abcfcc 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -1,71 +1,68 @@ -/* +/* * tclThreadJoin.c -- * - * This file implements a platform independent emulation layer for - * the handling of joinable threads. The Windows platform - * uses this code to provide the functionality of joining threads. - * This code is currently not necessary on Unix. + * This file implements a platform independent emulation layer for the + * handling of joinable threads. The Windows platform uses this code to + * provide the functionality of joining threads. This code is currently + * not necessary on Unix. * * Copyright (c) 2000 by Scriptics Corporation * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadJoin.c,v 1.5 2004/03/17 18:14:14 das Exp $ + * RCS: @(#) $Id: tclThreadJoin.c,v 1.6 2005/07/19 22:45:35 dkf Exp $ */ #include "tclInt.h" -#if defined(WIN32) +#ifdef WIN32 -/* The information about each joinable thread is remembered in a - * structure as defined below. +/* + * The information about each joinable thread is remembered in a structure as + * defined below. */ typedef struct JoinableThread { - Tcl_ThreadId id; /* The id of the joinable thread */ - int result; /* A place for the result after the - * demise of the thread */ - int done; /* Boolean flag. Initialized to 0 - * and set to 1 after the exit of - * the thread. This allows a thread - * requesting a join to detect when - * waiting is not necessary. */ - int waitedUpon; /* Boolean flag. Initialized to 0 - * and set to 1 by the thread waiting - * for this one via Tcl_JoinThread. - * Used to lock any other thread - * trying to wait on this one. - */ - Tcl_Mutex threadMutex; /* The mutex used to serialize access - * to this structure. */ - Tcl_Condition cond; /* This is the condition a thread has - * to wait upon to get notified of the - * end of the described thread. It is - * signaled indirectly by - * Tcl_ExitThread. */ - struct JoinableThread* nextThreadPtr; /* Reference to the next thread in the - * list of joinable threads */ + Tcl_ThreadId id; /* The id of the joinable thread. */ + int result; /* A place for the result after the demise of + * the thread. */ + int done; /* Boolean flag. Initialized to 0 and set to 1 + * after the exit of the thread. This allows a + * thread requesting a join to detect when + * waiting is not necessary. */ + int waitedUpon; /* Boolean flag. Initialized to 0 and set to 1 + * by the thread waiting for this one via + * Tcl_JoinThread. Used to lock any other + * thread trying to wait on this one. */ + Tcl_Mutex threadMutex; /* The mutex used to serialize access to this + * structure. */ + Tcl_Condition cond; /* This is the condition a thread has to wait + * upon to get notified of the end of the + * described thread. It is signaled indirectly + * by Tcl_ExitThread. */ + struct JoinableThread *nextThreadPtr; + /* Reference to the next thread in the list of + * joinable threads. */ } JoinableThread; -/* The following variable is used to maintain the global list of all - * joinable threads. Usage by a thread is allowed only if the - * thread acquired the 'joinMutex'. +/* + * The following variable is used to maintain the global list of all joinable + * threads. Usage by a thread is allowed only if the thread acquired the + * 'joinMutex'. */ TCL_DECLARE_MUTEX(joinMutex) static JoinableThread* firstThreadPtr; - - /* *---------------------------------------------------------------------- * * TclJoinThread -- * - * This procedure waits for the exit of the thread with the specified - * id and returns its result. + * This procedure waits for the exit of the thread with the specified id + * and returns its result. * * Results: * A standard tcl result signaling the overall success/failure of the @@ -74,135 +71,139 @@ static JoinableThread* firstThreadPtr; * * Side effects: * Deallocates the memory allocated by TclRememberJoinableThread. - * Removes the data associated to the thread waited upon from the - * list of joinable threads. + * Removes the data associated to the thread waited upon from the list of + * joinable threads. * *---------------------------------------------------------------------- */ int TclJoinThread(id, result) - Tcl_ThreadId id; /* The id of the thread to wait upon. */ - int* result; /* Reference to a location for the result - * of the thread we are waiting upon. */ + Tcl_ThreadId id; /* The id of the thread to wait upon. */ + int *result; /* Reference to a location for the result of + * the thread we are waiting upon. */ { - /* Steps done here: + JoinableThread *threadPtr; + + /* + * Steps done here: * i. Acquire the joinMutex and search for the thread. * ii. Error out if it could not be found. * iii. If found, switch from exclusive access to the list to exclusive - * access to the thread structure. + * access to the thread structure. * iv. Error out if some other is already waiting. * v. Skip the waiting part of the thread is already done. * vi. Wait for the thread to exit, mark it as waited upon too. - * vii. Get the result form the structure, + * vii. Get the result form the structure, * viii. switch to exclusive access of the list, * ix. remove the structure from the list, * x. then switch back to exclusive access to the structure * xi. and delete it. */ - JoinableThread* threadPtr; + Tcl_MutexLock(&joinMutex); - Tcl_MutexLock (&joinMutex); - - for (threadPtr = firstThreadPtr; - (threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id); - threadPtr = threadPtr->nextThreadPtr) - /* empty body */ - ; + threadPtr = firstThreadPtr; + while (threadPtr!=NULL && threadPtr->id!=id) { + threadPtr = threadPtr->nextThreadPtr; + } - if (threadPtr == (JoinableThread*) NULL) { - /* Thread not found. Either not joinable, or already waited - * upon and exited. Whatever, an error is in order. + if (threadPtr == NULL) { + /* + * Thread not found. Either not joinable, or already waited upon and + * exited. Whatever, an error is in order. */ - Tcl_MutexUnlock (&joinMutex); - return TCL_ERROR; + Tcl_MutexUnlock(&joinMutex); + return TCL_ERROR; } - /* [1] If we don't lock the structure before giving up exclusive access - * to the list some other thread just completing its wait on the same - * thread can delete the structure from under us, leaving us with a - * dangling pointer. + /* + * [1] If we don't lock the structure before giving up exclusive access to + * the list some other thread just completing its wait on the same thread + * can delete the structure from under us, leaving us with a dangling + * pointer. */ - Tcl_MutexLock (&threadPtr->threadMutex); - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexLock(&threadPtr->threadMutex); + Tcl_MutexUnlock(&joinMutex); - /* [2] Now that we have the structure mutex any other thread that just - * tries to delete structure will wait at location [3] until we are - * done with the structure. And in that case we are done with it - * rather quickly as 'waitedUpon' will be set and we will have to - * error out. + /* + * [2] Now that we have the structure mutex any other thread that just + * tries to delete structure will wait at location [3] until we are done + * with the structure. And in that case we are done with it rather quickly + * as 'waitedUpon' will be set and we will have to error out. */ if (threadPtr->waitedUpon) { - Tcl_MutexUnlock (&threadPtr->threadMutex); + Tcl_MutexUnlock(&threadPtr->threadMutex); return TCL_ERROR; } - /* We are waiting now, let other threads recognize this + /* + * We are waiting now, let other threads recognize this. */ threadPtr->waitedUpon = 1; while (!threadPtr->done) { - Tcl_ConditionWait (&threadPtr->cond, &threadPtr->threadMutex, NULL); + Tcl_ConditionWait(&threadPtr->cond, &threadPtr->threadMutex, NULL); } - /* We have to release the structure before trying to access the list - * again or we can run into deadlock with a thread at [1] (see above) - * because of us holding the structure and the other holding the list. - * There is no problem with dangling pointers here as 'waitedUpon == 1' - * is still valid and any other thread will error out and not come to - * this place. IOW, the fact that we are here also means that no other - * thread came here before us and is able to delete the structure. + /* + * We have to release the structure before trying to access the list again + * or we can run into deadlock with a thread at [1] (see above) because of + * us holding the structure and the other holding the list. There is no + * problem with dangling pointers here as 'waitedUpon == 1' is still valid + * and any other thread will error out and not come to this place. IOW, + * the fact that we are here also means that no other thread came here + * before us and is able to delete the structure. */ - Tcl_MutexUnlock (&threadPtr->threadMutex); - Tcl_MutexLock (&joinMutex); + Tcl_MutexUnlock(&threadPtr->threadMutex); + Tcl_MutexLock(&joinMutex); - /* We have to search the list again as its structure may (may, almost + /* + * We have to search the list again as its structure may (may, almost * certainly) have changed while we were waiting. Especially now is the - * time to compute the predecessor in the list. Any earlier result can - * be dangling by now. + * time to compute the predecessor in the list. Any earlier result can be + * dangling by now. */ if (firstThreadPtr == threadPtr) { - firstThreadPtr = threadPtr->nextThreadPtr; + firstThreadPtr = threadPtr->nextThreadPtr; } else { - JoinableThread* prevThreadPtr; - - for (prevThreadPtr = firstThreadPtr; - prevThreadPtr->nextThreadPtr != threadPtr; - prevThreadPtr = prevThreadPtr->nextThreadPtr) - /* empty body */ - ; + JoinableThread *prevThreadPtr = firstThreadPtr; + while (prevThreadPtr->nextThreadPtr != threadPtr) { + prevThreadPtr = prevThreadPtr->nextThreadPtr; + } prevThreadPtr->nextThreadPtr = threadPtr->nextThreadPtr; } - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexUnlock(&joinMutex); - /* [3] Now that the structure is not part of the list anymore no other + /* + * [3] Now that the structure is not part of the list anymore no other * thread can acquire its mutex from now on. But it is possible that - * another thread is still holding the mutex though, see location [2]. - * So we have to acquire the mutex one more time to wait for that thread - * to finish. We can (and have to) release the mutex immediately. + * another thread is still holding the mutex though, see location [2]. So + * we have to acquire the mutex one more time to wait for that thread to + * finish. We can (and have to) release the mutex immediately. */ - Tcl_MutexLock (&threadPtr->threadMutex); - Tcl_MutexUnlock (&threadPtr->threadMutex); + Tcl_MutexLock(&threadPtr->threadMutex); + Tcl_MutexUnlock(&threadPtr->threadMutex); - /* Copy the result to us, finalize the synchronisation objects, then - * free the structure and return. + /* + * Copy the result to us, finalize the synchronisation objects, then free + * the structure and return. */ *result = threadPtr->result; - Tcl_ConditionFinalize (&threadPtr->cond); - Tcl_MutexFinalize (&threadPtr->threadMutex); - ckfree ((VOID*) threadPtr); + Tcl_ConditionFinalize(&threadPtr->cond); + Tcl_MutexFinalize(&threadPtr->threadMutex); + ckfree((char *) threadPtr); return TCL_OK; } @@ -213,16 +214,14 @@ TclJoinThread(id, result) * TclRememberJoinableThread -- * * This procedure remebers a thread as joinable. Only a call to - * TclJoinThread will remove the structre created (and initialized) - * here. IOW, not waiting upon a joinable thread will cause memory - * leaks. + * TclJoinThread will remove the structre created (and initialized) here. + * IOW, not waiting upon a joinable thread will cause memory leaks. * * Results: * None. * * Side effects: - * Allocates memory, adds it to the global list of all joinable - * threads. + * Allocates memory, adds it to the global list of all joinable threads. * *---------------------------------------------------------------------- */ @@ -231,21 +230,21 @@ VOID TclRememberJoinableThread(id) Tcl_ThreadId id; /* The thread to remember as joinable */ { - JoinableThread* threadPtr; + JoinableThread *threadPtr; - threadPtr = (JoinableThread*) ckalloc (sizeof (JoinableThread)); - threadPtr->id = id; - threadPtr->done = 0; - threadPtr->waitedUpon = 0; + threadPtr = (JoinableThread *) ckalloc(sizeof(JoinableThread)); + threadPtr->id = id; + threadPtr->done = 0; + threadPtr->waitedUpon = 0; threadPtr->threadMutex = (Tcl_Mutex) NULL; - threadPtr->cond = (Tcl_Condition) NULL; + threadPtr->cond = (Tcl_Condition) NULL; - Tcl_MutexLock (&joinMutex); + Tcl_MutexLock(&joinMutex); threadPtr->nextThreadPtr = firstThreadPtr; - firstThreadPtr = threadPtr; + firstThreadPtr = threadPtr; - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexUnlock(&joinMutex); } /* @@ -253,9 +252,9 @@ TclRememberJoinableThread(id) * * TclSignalExitThread -- * - * This procedure signals that the specified thread is done with - * its work. If the thread is joinable this signal is propagated - * to the thread waiting upon it. + * This procedure signals that the specified thread is done with its + * work. If the thread is joinable this signal is propagated to the + * thread waiting upon it. * * Results: * None. @@ -268,44 +267,52 @@ TclRememberJoinableThread(id) VOID TclSignalExitThread(id,result) - Tcl_ThreadId id; /* Id of the thread signaling its exit */ - int result; /* The result from the thread */ + Tcl_ThreadId id; /* Id of the thread signaling its exit. */ + int result; /* The result from the thread. */ { - JoinableThread* threadPtr; + JoinableThread *threadPtr; - Tcl_MutexLock (&joinMutex); + Tcl_MutexLock(&joinMutex); - for (threadPtr = firstThreadPtr; - (threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id); - threadPtr = threadPtr->nextThreadPtr) - /* empty body */ - ; + threadPtr = firstThreadPtr; + while ((threadPtr != NULL) && (threadPtr->id != id)) { + threadPtr = threadPtr->nextThreadPtr; + } - if (threadPtr == (JoinableThread*) NULL) { - /* Thread not found. Not joinable. No problem, nothing to do. + if (threadPtr == NULL) { + /* + * Thread not found. Not joinable. No problem, nothing to do. */ - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexUnlock(&joinMutex); return; } - /* Switch over the exclusive access from the list to the structure, - * then store the result, set the flag and notify the waiting thread, - * provided that it exists. The order of lock/unlock ensures that a - * thread entering 'TclJoinThread' will not interfere with us. + /* + * Switch over the exclusive access from the list to the structure, then + * store the result, set the flag and notify the waiting thread, provided + * that it exists. The order of lock/unlock ensures that a thread entering + * 'TclJoinThread' will not interfere with us. */ - Tcl_MutexLock (&threadPtr->threadMutex); - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexLock(&threadPtr->threadMutex); + Tcl_MutexUnlock(&joinMutex); - threadPtr->done = 1; + threadPtr->done = 1; threadPtr->result = result; if (threadPtr->waitedUpon) { - Tcl_ConditionNotify (&threadPtr->cond); + Tcl_ConditionNotify(&threadPtr->cond); } - Tcl_MutexUnlock (&threadPtr->threadMutex); + Tcl_MutexUnlock(&threadPtr->threadMutex); } - #endif /* WIN32 */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index 7eb66be..09aa125 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -5,10 +5,10 @@ * * Copyright (c) 2003-2004 by Joe Mistachkin * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadStorage.c,v 1.4 2004/06/24 09:05:46 dkf Exp $ + * RCS: @(#) $Id: tclThreadStorage.c,v 1.5 2005/07/19 22:45:35 dkf Exp $ */ #include "tclInt.h" @@ -16,29 +16,28 @@ #if defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) /* - * This is the thread storage cache array and it's accompanying mutex. - * The elements are pairs of thread Id and an associated hash table - * pointer; the hash table being pointed to contains the thread storage - * for it's associated thread. The purpose of this cache is to minimize - * the number of hash table lookups in the master thread storage hash - * table. + * This is the thread storage cache array and it's accompanying mutex. The + * elements are pairs of thread Id and an associated hash table pointer; the + * hash table being pointed to contains the thread storage for it's associated + * thread. The purpose of this cache is to minimize the number of hash table + * lookups in the master thread storage hash table. */ static Tcl_Mutex threadStorageLock; /* - * This is the struct used for a thread storage cache slot. It contains - * the owning thread Id and the associated hash table pointer. + * This is the struct used for a thread storage cache slot. It contains the + * owning thread Id and the associated hash table pointer. */ typedef struct ThreadStorage { - Tcl_ThreadId id; /* the owning thread id */ - Tcl_HashTable *hashTablePtr; /* the hash table for the thread */ + Tcl_ThreadId id; /* the owning thread id */ + Tcl_HashTable *hashTablePtr;/* the hash table for the thread */ } ThreadStorage; /* - * These are the prototypes for the custom hash table allocation - * functions used by the thread storage subsystem. + * These are the prototypes for the custom hash table allocation functions + * used by the thread storage subsystem. */ static Tcl_HashEntry * AllocThreadStorageEntry _ANSI_ARGS_(( @@ -51,6 +50,7 @@ static void FreeThreadStorageEntry _ANSI_ARGS_(( * combination with the new hash key type flag TCL_HASH_KEY_SYSTEM_HASH * because these hash tables MAY be used by the threaded memory allocator. */ + Tcl_HashKeyType tclThreadStorageHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ TCL_HASH_KEY_SYSTEM_HASH, /* flags */ @@ -73,31 +73,30 @@ Tcl_HashKeyType tclThreadStorageHashKeyType = { #define STORAGE_INVALID_KEY 0 /* - * This is the first valid key for use by external callers. - * All the values below this are RESERVED for future use. + * This is the first valid key for use by external callers. All the values + * below this are RESERVED for future use. */ #define STORAGE_FIRST_KEY 101 /* - * This is the default number of thread storage cache slots. - * This define may need to be fine tuned for maximum performance. + * This is the default number of thread storage cache slots. This define may + * need to be fine tuned for maximum performance. */ #define STORAGE_CACHE_SLOTS 97 /* - * This is the master thread storage hash table. It is keyed on - * thread Id and contains values that are hash tables for each thread. - * The thread specific hash tables contain the actual thread storage. + * This is the master thread storage hash table. It is keyed on thread Id and + * contains values that are hash tables for each thread. The thread specific + * hash tables contain the actual thread storage. */ static Tcl_HashTable *threadStorageHashTablePtr = NULL; /* - * This is the next thread data key value to use. We increment this - * everytime we "allocate" one. It is initially set to 1 in - * TclThreadStorageInit. + * This is the next thread data key value to use. We increment this everytime + * we "allocate" one. It is initially set to 1 in TclThreadStorageInit. */ static int nextThreadStorageKey = STORAGE_INVALID_KEY; @@ -109,9 +108,8 @@ static int nextThreadStorageKey = STORAGE_INVALID_KEY; static int initThreadStorage = 0; /* - * This is the master thread storage cache. Per kennykb's idea, this - * prevents unnecessary lookups for threads that use a lot of thread - * storage. + * This is the master thread storage cache. Per Kevin Kenny's idea, this + * prevents unnecessary lookups for threads that use a lot of thread storage. */ static volatile ThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS]; @@ -121,15 +119,15 @@ static volatile ThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS]; * * TclThreadStorageLockInit * - * This procedure is used to initialize the lock that serializes - * creation of thread storage. + * This procedure is used to initialize the lock that serializes creation + * of thread storage. * * Results: * None. * * Side effects: - * The master lock is acquired and possibly initialized for the - * first time. + * The master lock is acquired and possibly initialized for the first + * time. * *---------------------------------------------------------------------- */ @@ -139,10 +137,11 @@ TclThreadStorageLockInit() { if (!initThreadStorage) { /* - * Mutexes in Tcl are self initializing, and we are taking - * advantage of that fact since this file cannot contain - * platform specific calls. + * Mutexes in Tcl are self initializing, and we are taking advantage + * of that fact since this file cannot contain platform specific + * calls. */ + initThreadStorage = 1; } } @@ -152,11 +151,11 @@ TclThreadStorageLockInit() * * TclThreadStorageLock * - * This procedure is used to grab a lock that serializes creation - * of thread storage. + * This procedure is used to grab a lock that serializes creation of + * thread storage. * - * This lock must be different than the initLock because the - * initLock is held during creation of syncronization objects. + * This lock must be different than the initLock because the initLock is + * held during creation of syncronization objects. * * Results: * None. @@ -179,8 +178,8 @@ TclThreadStorageLock() * * TclThreadStorageUnlock * - * This procedure is used to release a lock that serializes creation - * of thread storage. + * This procedure is used to release a lock that serializes creation of + * thread storage. * * Results: * None. @@ -202,9 +201,9 @@ TclThreadStorageUnlock() * * AllocThreadStorageEntry -- * - * Allocate space for a Tcl_HashEntry using TclpSysAlloc (not - * ckalloc). We do this because the threaded memory allocator MAY - * use the thread storage hash tables. + * Allocate space for a Tcl_HashEntry using TclpSysAlloc (not ckalloc). + * We do this because the threaded memory allocator MAY use the thread + * storage hash tables. * * Results: * The return value is a pointer to the created entry. @@ -233,9 +232,9 @@ AllocThreadStorageEntry(tablePtr, keyPtr) * * FreeThreadStorageEntry -- * - * Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree). - * We do this because the threaded memory allocator MAY use the - * thread storage hash tables. + * Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree). We do + * this because the threaded memory allocator MAY use the thread storage + * hash tables. * * Results: * None. @@ -258,9 +257,9 @@ FreeThreadStorageEntry(hPtr) * * TclThreadStoragePrint -- * - * This procedure prints out the contents of the master thread - * storage hash table, the thread storage cache, and the next key - * value to the specified file. + * This procedure prints out the contents of the master thread storage + * hash table, the thread storage cache, and the next key value to the + * specified file. * * This assumes that thread storage lock is held. * @@ -303,7 +302,7 @@ TclThreadStoragePrint(outFile, flags) } header = 0; /* we have not output the header yet. */ - for (index = 0; index < STORAGE_CACHE_SLOTS; index++) { + for (index=0 ; index<STORAGE_CACHE_SLOTS ; index++) { if (threadStorageCache[index].id != STORAGE_INVALID_THREAD) { if (!header) { fprintf(outFile, "thread storage cache (%d total slots):\n", @@ -314,12 +313,14 @@ TclThreadStoragePrint(outFile, flags) fprintf(outFile, "slot %d, thread %p, thread table ptr %p\n", index, threadStorageCache[index].id, threadStorageCache[index].hashTablePtr); + #ifdef VERBOSE_THREAD_STORAGE_DEBUGGING /* - * Currently not enabled by default due to Tcl_HashStats - * use of ckalloc and ckfree. Please note that this can - * produce a LOT of output. + * Currently not enabled by default due to Tcl_HashStats use of + * ckalloc and ckfree. Please note that this can produce a LOT of + * output. */ + if (threadStorageCache[index].hashTablePtr != NULL) { CONST char *stats = Tcl_HashStats(threadStorageCache[index].hashTablePtr); @@ -333,6 +334,7 @@ TclThreadStoragePrint(outFile, flags) } } #endif + } else { /* fprintf(outFile, "cache slot %d not used\n", index); */ } @@ -362,12 +364,12 @@ TclThreadStoragePrint(outFile, flags) * This assumes that thread storage lock is held. * * Results: - * A hash table pointer for the specified thread, or NULL - * if the hash table has not been created yet. + * A hash table pointer for the specified thread, or NULL if the hash + * table has not been created yet. * * Side effects: - * May change an entry in the master thread storage cache to point - * to the specified thread and it's associated hash table. + * May change an entry in the master thread storage cache to point to the + * specified thread and it's associated hash table. * *---------------------------------------------------------------------- */ @@ -381,9 +383,9 @@ TclThreadStorageGetHashTable(id) int new; /* - * It's important that we pick up the hash table pointer BEFORE - * comparing thread Id in case another thread is in the critical - * region changing things out from under you. + * It's important that we pick up the hash table pointer BEFORE comparing + * thread Id in case another thread is in the critical region changing + * things out from under you. */ Tcl_HashTable *hashTablePtr = threadStorageCache[index].hashTablePtr; @@ -408,11 +410,13 @@ TclThreadStorageGetHashTable(id) /* * We found it, extract the hash table pointer. */ + hashTablePtr = Tcl_GetHashValue(hPtr); } else { /* * The thread specific hash table is not found. */ + hashTablePtr = NULL; } @@ -429,8 +433,7 @@ TclThreadStorageGetHashTable(id) &tclThreadStorageHashKeyType); /* - * Add new thread storage hash table to the master - * hash table. + * Add new thread storage hash table to the master hash table. */ hPtr = Tcl_CreateHashEntry(threadStorageHashTablePtr, @@ -444,17 +447,18 @@ TclThreadStorageGetHashTable(id) } /* - * Now, we put it in the cache since it is highly likely - * it will be needed again shortly. + * Now, we put it in the cache since it is highly likely it will + * be needed again shortly. */ threadStorageCache[index].id = id; threadStorageCache[index].hashTablePtr = hashTablePtr; } else { /* - * We cannot look it up, the master hash table has not - * been initialized. + * We cannot look it up, the master hash table has not been + * initialized. */ + hashTablePtr = NULL; } TclThreadStorageUnlock(); @@ -475,8 +479,8 @@ TclThreadStorageGetHashTable(id) * This assumes that thread storage lock is held. * * Results: - * A hash table pointer for the specified thread, or NULL if we are - * be called to initialize the master hash table only. + * A hash table pointer for the specified thread, or NULL if we are be + * called to initialize the master hash table only. * * Side effects: * The thread specific hash table may be initialized and added to the @@ -496,8 +500,8 @@ TclThreadStorageInit(id, reserved) if (threadStorageHashTablePtr == NULL) { /* - * Looks like we haven't created the outer hash table yet we - * can just do that now. + * Looks like we haven't created the outer hash table yet we can just + * do that now. */ threadStorageHashTablePtr = (Tcl_HashTable *) @@ -531,30 +535,29 @@ TclThreadStorageInit(id, reserved) * * TclThreadStorageDataKeyInit -- * - * This procedure initializes a thread specific data block key. - * Each thread has table of pointers to thread specific data. - * all threads agree on which table entry is used by each module. - * this is remembered in a "data key", that is just an index into - * this table. To allow self initialization, the interface - * passes a pointer to this key and the first thread to use - * the key fills in the pointer to the key. The key should be - * a process-wide static. + * This procedure initializes a thread specific data block key. Each + * thread has table of pointers to thread specific data. all threads + * agree on which table entry is used by each module. this is remembered + * in a "data key", that is just an index into this table. To allow self + * initialization, the interface passes a pointer to this key and the + * first thread to use the key fills in the pointer to the key. The key + * should be a process-wide static. * * Results: * None. * * Side effects: - * Will allocate memory the first time this process calls for - * this key. In this case it modifies its argument - * to hold the pointer to information about the key. + * Will allocate memory the first time this process calls for this key. + * In this case it modifies its argument to hold the pointer to + * information about the key. * *---------------------------------------------------------------------- */ void TclThreadStorageDataKeyInit(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (int **) */ + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (int**) */ { int *indexPtr; int newKey; @@ -566,8 +569,8 @@ TclThreadStorageDataKeyInit(keyPtr) } /* - * We must call this now to make sure that - * nextThreadStorageKey has a well defined value. + * We must call this now to make sure that nextThreadStorageKey has a + * well defined value. */ TclThreadStorageLock(); @@ -579,11 +582,11 @@ TclThreadStorageDataKeyInit(keyPtr) TclThreadStorageInit(STORAGE_INVALID_THREAD, NULL); /* - * These data key values are sequentially assigned and we must - * use the storage lock to prevent serious problems here. - * Also note that the caller should NOT make any assumptions - * about the provided values. In particular, we may need to - * reserve some values in the future. + * These data key values are sequentially assigned and we must use the + * storage lock to prevent serious problems here. Also note that the + * caller should NOT make any assumptions about the provided + * values. In particular, we may need to reserve some values in the + * future. */ newKey = nextThreadStorageKey++; @@ -603,8 +606,8 @@ TclThreadStorageDataKeyInit(keyPtr) * This procedure returns a pointer to a block of thread local storage. * * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. + * A thread-specific pointer to the data structure, or NULL if the memory + * has not been assigned to this key for this thread. * * Side effects: * None. @@ -614,8 +617,8 @@ TclThreadStorageDataKeyInit(keyPtr) void * TclThreadStorageDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (int **) */ + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (int**) */ { int *indexPtr = *(int **)keyPtr; @@ -631,12 +634,12 @@ TclThreadStorageDataKeyGet(keyPtr) "TclThreadStorageDataKeyGet!"); } - hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr); + hPtr = Tcl_FindHashEntry(hashTablePtr, (char *) *indexPtr); if (hPtr == NULL) { return NULL; } - return (void *)Tcl_GetHashValue(hPtr); + return (void *) Tcl_GetHashValue(hPtr); } } @@ -651,16 +654,16 @@ TclThreadStorageDataKeyGet(keyPtr) * None. * * Side effects: - * Sets up the thread so future calls to TclThreadStorageDataKeyGet - * with this key will return the data pointer. + * Sets up the thread so future calls to TclThreadStorageDataKeyGet with + * this key will return the data pointer. * *---------------------------------------------------------------------- */ void TclThreadStorageDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (pthread_key_t **) */ void *data; /* Thread local storage */ { int *indexPtr = *(int **)keyPtr; @@ -678,8 +681,10 @@ TclThreadStorageDataKeySet(keyPtr, data) /* * Does the item need to be created? */ + if (hPtr == NULL) { int new; + hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)*indexPtr, &new); if (hPtr == NULL) { Tcl_Panic("could not create hash entry value from " @@ -709,12 +714,12 @@ TclThreadStorageDataKeySet(keyPtr, data) void TclFinalizeThreadStorageThread(id) - Tcl_ThreadId id; /* Id of the thread to finalize */ + Tcl_ThreadId id; /* Id of the thread to finalize. */ { int index = (unsigned int)id % STORAGE_CACHE_SLOTS; - Tcl_HashTable *hashTablePtr; /* Hash table for current thread */ + Tcl_HashTable *hashTablePtr;/* Hash table for current thread. */ Tcl_HashEntry *hPtr; /* Hash entry for current thread in master - * table */ + * table. */ TclThreadStorageLock(); @@ -730,8 +735,7 @@ TclFinalizeThreadStorageThread(id) if (hashTablePtr != NULL) { /* - * Delete thread specific hash table and free the - * struct. + * Delete thread specific hash table and free the struct. */ Tcl_DeleteHashTable(hashTablePtr); @@ -752,9 +756,8 @@ TclFinalizeThreadStorageThread(id) if (threadStorageCache[index].id == id) { /* - * We do not step on another thread's cache entry. This is - * especially important if we are creating and exiting a lot - * of threads. + * We do not step on another thread's cache entry. This is especially + * important if we are creating and exiting a lot of threads. */ threadStorageCache[index].id = STORAGE_INVALID_THREAD; @@ -769,8 +772,8 @@ TclFinalizeThreadStorageThread(id) * * TclFinalizeThreadStorage -- * - * This procedure cleans up the master thread storage hash table, - * all thread specific hash tables, and the thread storage cache. + * This procedure cleans up the master thread storage hash table, all + * thread specific hash tables, and the thread storage cache. * * Results: * None. @@ -794,9 +797,9 @@ TclFinalizeThreadStorage() * master table. */ /* - * We are going to delete the hash table for every thread now. - * This hash table should be empty at this point, except for - * one entry for the current thread. + * We are going to delete the hash table for every thread now. This + * hash table should be empty at this point, except for one entry for + * the current thread. */ for (hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search); @@ -838,8 +841,8 @@ TclFinalizeThreadStorage() sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS); /* - * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the - * thread storage subsystem gets reinitialized + * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the thread + * storage subsystem gets reinitialized */ nextThreadStorageKey = STORAGE_INVALID_KEY; @@ -852,8 +855,8 @@ TclFinalizeThreadStorage() * * TclFinalizeThreadStorageData -- * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. + * This procedure cleans up the thread-local storage. This is called + * once for each thread. * * Results: * None. @@ -870,7 +873,7 @@ TclFinalizeThreadStorageData(keyPtr) { if (*keyPtr != NULL) { Tcl_ThreadId id = Tcl_GetCurrentThread(); - Tcl_HashTable *hashTablePtr; /* Hash table for current thread */ + Tcl_HashTable *hashTablePtr; /* Hash table for current thread. */ Tcl_HashEntry *hPtr; /* Hash entry for data key in current * thread. */ int *indexPtr = *(int **)keyPtr; @@ -887,9 +890,10 @@ TclFinalizeThreadStorageData(keyPtr) if (result != NULL) { /* - * This must be ckfree because tclThread.c allocates - * these using ckalloc. + * This must be ckfree because tclThread.c allocates these + * using ckalloc. */ + ckfree((char *)result); } @@ -903,9 +907,9 @@ TclFinalizeThreadStorageData(keyPtr) * * TclFinalizeThreadStorageDataKey -- * - * This procedure is invoked to clean up one key. This is a - * process-wide storage identifier. The thread finalization code - * cleans up the thread local storage itself. + * This procedure is invoked to clean up one key. This is a process-wide + * storage identifier. The thread finalization code cleans up the thread + * local storage itself. * * This assumes the master lock is held. * @@ -923,7 +927,7 @@ TclFinalizeThreadStorageDataKey(keyPtr) Tcl_ThreadDataKey *keyPtr; { int *indexPtr; - Tcl_HashTable *hashTablePtr;/* Hash table for current thread */ + Tcl_HashTable *hashTablePtr;/* Hash table for current thread. */ Tcl_HashSearch search; /* Need to hit every thread with this search */ Tcl_HashEntry *hPtr; /* Hash entry for current thread in master * table. */ @@ -936,22 +940,23 @@ TclFinalizeThreadStorageDataKey(keyPtr) if (threadStorageHashTablePtr != NULL) { /* - * We are going to delete the specified data key entry - * from every thread. + * We are going to delete the specified data key entry from every + * thread. */ for (hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - /* * Get the hash table corresponding to the thread in question. */ + hashTablePtr = Tcl_GetHashValue(hPtr); if (hashTablePtr != NULL) { /* * Now find the entry for the specified data key. */ + hDataPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr); @@ -959,6 +964,7 @@ TclFinalizeThreadStorageDataKey(keyPtr) /* * Delete the data key for this thread. */ + Tcl_DeleteHashEntry(hDataPtr); } } @@ -981,15 +987,14 @@ static void ThreadStoragePanic _ANSI_ARGS_((CONST char *message)); * * ThreadStoragePanic -- * - * Panic if Tcl was compiled without TCL_THREADS or without - * USE_THREAD_STORAGE and a thread storage function has been - * called. + * Panic if Tcl was compiled without TCL_THREADS or without + * USE_THREAD_STORAGE and a thread storage function has been called. * * Results: - * None. + * None. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -999,10 +1004,9 @@ static void ThreadStoragePanic(message) #ifdef TCL_THREADS # ifdef USE_THREAD_STORAGE /* - * Do nothing, everything is OK. However, this should never happen - * because this function only gets called by the dummy thread - * storage functions (used when one or both of these DEFINES are - * not present). + * Do nothing, everything is OK. However, this should never happen because + * this function only gets called by the dummy thread storage functions + * (used when one or both of these DEFINES are not present). */ # else Tcl_Panic("Tcl was not compiled with thread storage enabled."); @@ -1110,3 +1114,11 @@ TclFinalizeThreadStorageDataKey(keyPtr) } #endif /* defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |