source: downloads/tcl8.5.2/generic/tclCkalloc.c @ 63

/*
 * tclCkalloc.c --
 *
 *    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.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.32 2007/04/23 20:33:56 das Exp $
 */

#include "tclInt.h"

#define FALSE   0
#define TRUE    1

#ifdef TCL_MEM_DEBUG

/*
 * One of the following structures is allocated each time the
 * "memory tag" command is invoked, to hold the current tag.
 */

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. */
} 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). */

/*
 * 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
                                 * NULL. */
    CONST char *file;
    long length;
    int line;
    unsigned char low_guard[LOW_GUARD_SIZE];
                                /* 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. */
};

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.
 */

#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.
 */

#define BODY_OFFSET \
        ((unsigned long) (&((struct mem_header *) 0)->body))

static int total_mallocs = 0;
static int total_frees = 0;
static int current_bytes_malloced = 0;
static int maximum_bytes_malloced = 0;
static int current_malloc_packets = 0;
static int maximum_malloc_packets = 0;
static int break_on_malloc = 0;
static int trace_on_at_malloc = 0;
static int alloc_tracing = FALSE;
static int init_malloced_bodies = TRUE;
#ifdef MEM_VALIDATE
static int validate_memory = TRUE;
#else
static int validate_memory = FALSE;
#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.
 */

char *tclMemDumpFileName = NULL;

static char *onExitMemDumpFileName = NULL;
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...
 */

static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;

/*
 * Prototypes for procedures defined in this file:
 */

static int              CheckmemCmd(ClientData clientData, Tcl_Interp *interp,
                            int argc, CONST char *argv[]);
static int              MemoryCmd(ClientData clientData, Tcl_Interp *interp,
                            int argc, CONST char *argv[]);
static void             ValidateMemory(struct mem_header *memHeaderP,
                            CONST char *file, int line, int nukeGuards);

/*
 *----------------------------------------------------------------------
 *
 * TclInitDbCkalloc --
 *
 *      Initialize the locks used by the allocator. This is only appropriate
 *      to call in a single threaded environment, such as during
 *      TclInitSubsystems.
 *
 *----------------------------------------------------------------------
 */

void
TclInitDbCkalloc(void)
{
    if (!ckallocInit) {
        ckallocInit = 1;
        ckallocMutexPtr = Tcl_GetAllocMutex();
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclDumpMemoryInfo --
 *
 *      Display the global memory management statistics.
 *
 *----------------------------------------------------------------------
 */

void
TclDumpMemoryInfo(
    FILE *outFile)
{
    fprintf(outFile,"total mallocs             %10d\n",
            total_mallocs);
    fprintf(outFile,"total frees               %10d\n",
            total_frees);
    fprintf(outFile,"current packets allocated %10d\n",
            current_malloc_packets);
    fprintf(outFile,"current bytes allocated   %10d\n",
            current_bytes_malloced);
    fprintf(outFile,"maximum packets allocated %10d\n",
            maximum_malloc_packets);
    fprintf(outFile,"maximum bytes allocated   %10d\n",
            maximum_bytes_malloced);
}

/*
 *----------------------------------------------------------------------
 *
 * ValidateMemory --
 *
 *      Validate memory guard zones for a particular chunk of allocated
 *      memory.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Prints validation information about the allocated memory to stderr.
 *
 *----------------------------------------------------------------------
 */

static void
ValidateMemory(
    struct mem_header *memHeaderP,
                                /* Memory chunk to validate */
    CONST char *file,           /* File containing the call to
                                 * Tcl_ValidateAllMemory */
    int line,                   /* Line number of call to
                                 * Tcl_ValidateAllMemory */
    int nukeGuards)             /* If non-zero, indicates that the memory
                                 * guards are to be reset to 0 after they have
                                 * been printed */
{
    unsigned char *hiPtr;
    size_t 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 &= 0xff;
            fprintf(stderr, "low guard byte %d is 0x%x  \t%c\n", (int)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,
                memHeaderP->file, memHeaderP->line);
        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 &= 0xff;
            fprintf(stderr, "hi guard byte %d is 0x%x  \t%c\n", (int)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",
                memHeaderP->length, memHeaderP->file,
                memHeaderP->line);
        Tcl_Panic("Memory validation failure");
    }

    if (nukeGuards) {
        memset(memHeaderP->low_guard, 0, LOW_GUARD_SIZE);
        memset(hiPtr, 0, HIGH_GUARD_SIZE);
    }

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ValidateAllMemory --
 *
 *      Validate memory guard regions for all allocated memory.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Displays memory validation information to stderr.
 *
 *----------------------------------------------------------------------
 */

void
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;

    if (!ckallocInit) {
        TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
        ValidateMemory(memScanP, file, line, FALSE);
    }
    Tcl_MutexUnlock(ckallocMutexPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DumpActiveMemory --
 *
 *      Displays all allocated memory to a file; if no filename is given,
 *      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.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DumpActiveMemory(
    CONST char *fileName)       /* Name of the file to write info to */
{
    FILE *fileP;
    struct mem_header *memScanP;
    char *address;

    if (fileName == NULL) {
        fileP = stderr;
    } else {
        fileP = fopen(fileName, "w");
        if (fileP == NULL) {
            return TCL_ERROR;
        }
    }

    Tcl_MutexLock(ckallocMutexPtr);
    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
        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,
                (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
        (void) fputc('\n', fileP);
    }
    Tcl_MutexUnlock(ckallocMutexPtr);

    if (fileP != stderr) {
        fclose(fileP);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *      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__.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DbCkalloc(
    unsigned int size,
    CONST char *file,
    int line)
{
    struct mem_header *result;

    if (validate_memory) {
        Tcl_ValidateAllMemory(file, line);
    }

    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);
    }

    /*
     * 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(result, GUARD_VALUE,
                size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    } else {
        memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
        memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
    }
    if (!ckallocInit) {
        TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    result->length = size;
    result->tagPtr = curTagPtr;
    if (curTagPtr != NULL) {
        curTagPtr->refCount++;
    }
    result->file = file;
    result->line = line;
    result->flink = allocHead;
    result->blink = NULL;

    if (allocHead != NULL) {
        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;
    }

    if (alloc_tracing) {
        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;
        (void) fflush(stdout);
        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;
    }
    current_bytes_malloced += size;
    if (current_bytes_malloced > maximum_bytes_malloced) {
        maximum_bytes_malloced = current_bytes_malloced;
    }

    Tcl_MutexUnlock(ckallocMutexPtr);

    return result->body;
}

char *
Tcl_AttemptDbCkalloc(
    unsigned int size,
    CONST char *file,
    int line)
{
    struct mem_header *result;

    if (validate_memory) {
        Tcl_ValidateAllMemory(file, line);
    }

    result = (struct mem_header *) TclpAlloc((unsigned)size +
            sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    if (result == NULL) {
        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.
     */
    if (init_malloced_bodies) {
        memset(result, GUARD_VALUE,
                size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    } else {
        memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
        memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
    }
    if (!ckallocInit) {
        TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    result->length = size;
    result->tagPtr = curTagPtr;
    if (curTagPtr != NULL) {
        curTagPtr->refCount++;
    }
    result->file = file;
    result->line = line;
    result->flink = allocHead;
    result->blink = NULL;

    if (allocHead != NULL) {
        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;
    }

    if (alloc_tracing) {
        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;
        (void) fflush(stdout);
        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;
    }
    current_bytes_malloced += size;
    if (current_bytes_malloced > maximum_bytes_malloced) {
        maximum_bytes_malloced = current_bytes_malloced;
    }

    Tcl_MutexUnlock(ckallocMutexPtr);

    return result->body;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbCkfree - debugging ckfree
 *
 *      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 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__.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DbCkfree(
    char *ptr,
    CONST char *file,
    int line)
{
    struct mem_header *memp;

    if (ptr == NULL) {
        return 0;
    }

    /*
     * 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",
                (long unsigned int) memp->body, memp->length, file, line);
    }

    if (validate_memory) {
        Tcl_ValidateAllMemory(file, line);
    }

    Tcl_MutexLock(ckallocMutexPtr);
    ValidateMemory(memp, file, line, TRUE);
    if (init_malloced_bodies) {
        memset(ptr, GUARD_VALUE, (size_t) memp->length);
    }

    total_frees++;
    current_malloc_packets--;
    current_bytes_malloced -= memp->length;

    if (memp->tagPtr != NULL) {
        memp->tagPtr->refCount--;
        if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
            TclpFree((char *) memp->tagPtr);
        }
    }

    /*
     * Delink from allocated list
     */

    if (memp->flink != NULL) {
        memp->flink->blink = memp->blink;
    }
    if (memp->blink != NULL) {
        memp->blink->flink = memp->flink;
    }
    if (allocHead == memp) {
        allocHead = memp->flink;
    }
    TclpFree((char *) memp);
    Tcl_MutexUnlock(ckallocMutexPtr);

    return 0;
}

/*
 *--------------------------------------------------------------------
 *
 * 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.
 *
 *--------------------------------------------------------------------
 */

char *
Tcl_DbCkrealloc(
    char *ptr,
    unsigned int size,
    CONST char *file,
    int line)
{
    char *newPtr;
    unsigned int copySize;
    struct mem_header *memp;

    if (ptr == NULL) {
        return Tcl_DbCkalloc(size, file, line);
    }

    /*
     * See comment from Tcl_DbCkfree before you change the following line.
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    copySize = size;
    if (copySize > (unsigned int) memp->length) {
        copySize = memp->length;
    }
    newPtr = Tcl_DbCkalloc(size, file, line);
    memcpy(newPtr, ptr, (size_t) copySize);
    Tcl_DbCkfree(ptr, file, line);
    return newPtr;
}

char *
Tcl_AttemptDbCkrealloc(
    char *ptr,
    unsigned int size,
    CONST char *file,
    int line)
{
    char *newPtr;
    unsigned int copySize;
    struct mem_header *memp;

    if (ptr == NULL) {
        return Tcl_AttemptDbCkalloc(size, file, line);
    }

    /*
     * See comment from Tcl_DbCkfree before you change the following line.
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    copySize = size;
    if (copySize > (unsigned int) memp->length) {
        copySize = memp->length;
    }
    newPtr = Tcl_AttemptDbCkalloc(size, file, line);
    if (newPtr == NULL) {
        return NULL;
    }
    memcpy(newPtr, ptr, (size_t) copySize);
    Tcl_DbCkfree(ptr, file, line);
    return newPtr;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Alloc, et al. --
 *
 *      These functions are defined in terms of the debugging versions when
 *      TCL_MEM_DEBUG is set.
 *
 * Results:
 *      Same as the debug versions.
 *
 * Side effects:
 *      Same as the debug versions.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_Alloc
#undef Tcl_Free
#undef Tcl_Realloc
#undef Tcl_AttemptAlloc
#undef Tcl_AttemptRealloc

char *
Tcl_Alloc(
    unsigned int size)
{
    return Tcl_DbCkalloc(size, "unknown", 0);
}

char *
Tcl_AttemptAlloc(
    unsigned int size)
{
    return Tcl_AttemptDbCkalloc(size, "unknown", 0);
}

void
Tcl_Free(
    char *ptr)
{
    Tcl_DbCkfree(ptr, "unknown", 0);
}

char *
Tcl_Realloc(
    char *ptr,
    unsigned int size)
{
    return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
}
char *
Tcl_AttemptRealloc(
    char *ptr,
    unsigned int size)
{
    return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
}

/*
 *----------------------------------------------------------------------
 *
 * MemoryCmd --
 *
 *      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
 *              memory init on|off
 *              memory onexit $file
 *              memory tag $string
 *              memory trace on|off
 *              memory trace_on_at_malloc $count
 *              memory validate on|off
 *
 * Results:
 *      Standard TCL results.
 *
 *----------------------------------------------------------------------
 */
        /* ARGSUSED */
static int
MemoryCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int argc,
    CONST char *argv[])
{
    CONST char *fileName;
    Tcl_DString buffer;
    int result;

    if (argc < 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                " option [args..]\"", NULL);
        return TCL_ERROR;
    }

    if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                    " ", argv[1], " file\"", NULL);
            return TCL_ERROR;
        }
        fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
        if (fileName == NULL) {
            return TCL_ERROR;
        }
        result = Tcl_DumpActiveMemory (fileName);
        Tcl_DStringFree(&buffer);
        if (result != TCL_OK) {
            Tcl_AppendResult(interp, "error accessing ", argv[2], NULL);
            return TCL_ERROR;
        }
        return TCL_OK;
    }
    if (strcmp(argv[1],"break_on_malloc") == 0) {
        if (argc != 3) {
            goto argError;
        }
        if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
            return TCL_ERROR;
        }
        return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "%-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));
        return TCL_OK;
    }
    if (strcmp(argv[1],"init") == 0) {
        if (argc != 3) {
            goto bad_suboption;
        }
        init_malloced_bodies = (strcmp(argv[2],"on") == 0);
        return TCL_OK;
    }
    if (strcmp(argv[1],"onexit") == 0) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                    " onexit file\"", NULL);
            return TCL_ERROR;
        }
        fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
        if (fileName == NULL) {
            return TCL_ERROR;
        }
        onExitMemDumpFileName = dumpFile;
        strcpy(onExitMemDumpFileName,fileName);
        Tcl_DStringFree(&buffer);
        return TCL_OK;
    }
    if (strcmp(argv[1],"tag") == 0) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                    " tag string\"", NULL);
            return TCL_ERROR;
        }
        if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
            TclpFree((char *) curTagPtr);
        }
        curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2])));
        curTagPtr->refCount = 0;
        strcpy(curTagPtr->string, argv[2]);
        return TCL_OK;
    }
    if (strcmp(argv[1],"trace") == 0) {
        if (argc != 3) {
            goto bad_suboption;
        }
        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 (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) {
            goto bad_suboption;
        }
        validate_memory = (strcmp(argv[2],"on") == 0);
        return TCL_OK;
    }

    Tcl_AppendResult(interp, "bad option \"", argv[1],
            "\": should be active, break_on_malloc, info, init, onexit, "
            "tag, trace, trace_on_at_malloc, or validate", NULL);
    return TCL_ERROR;

  argError:
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " ", argv[1], " count\"", NULL);
    return TCL_ERROR;

  bad_suboption:
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " ", argv[1], " on|off\"", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Results:
 *      Returns a standard Tcl completion code.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
CheckmemCmd(
    ClientData clientData,      /* Not used. */
    Tcl_Interp *interp,         /* Interpreter for evaluation. */
    int argc,                   /* Number of arguments. */
    CONST char *argv[])         /* String values of arguments. */
{
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                " fileName\"", NULL);
        return TCL_ERROR;
    }
    tclMemDumpFileName = dumpFile;
    strcpy(tclMemDumpFileName, argv[1]);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitMemory --
 *
 *      Create the "memory" and "checkmem" commands in the given interpreter.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      New commands are added to the interpreter.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InitMemory(
    Tcl_Interp *interp)         /* Interpreter in which commands should be
                                 * added */
{
    TclInitDbCkalloc();
    Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, NULL);
    Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, NULL);
}


#else   /* TCL_MEM_DEBUG */

/* This is the !TCL_MEM_DEBUG case */

#undef Tcl_InitMemory
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Alloc --
 *
 *      Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
 *      that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Alloc(
    unsigned int 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).
     *
     * 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);
    }
    return result;
}

char *
Tcl_DbCkalloc(
    unsigned int size,
    CONST char *file,
    int line)
{
    char *result;

    result = (char *) TclpAlloc(size);

    if ((result == NULL) && size) {
        fflush(stdout);
        Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AttemptAlloc --
 *
 *      Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
 *      check that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_AttemptAlloc(
    unsigned int size)
{
    char *result;

    result = TclpAlloc(size);
    return result;
}

char *
Tcl_AttemptDbCkalloc(
    unsigned int size,
    CONST char *file,
    int line)
{
    char *result;

    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.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Realloc(
    char *ptr,
    unsigned int size)
{
    char *result;

    result = TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
        Tcl_Panic("unable to realloc %u bytes", size);
    }
    return result;
}

char *
Tcl_DbCkrealloc(
    char *ptr,
    unsigned int size,
    CONST char *file,
    int line)
{
    char *result;

    result = (char *) TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
        fflush(stdout);
        Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AttemptRealloc --
 *
 *      Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not
 *      check that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_AttemptRealloc(
    char *ptr,
    unsigned int size)
{
    char *result;

    result = TclpRealloc(ptr, size);
    return result;
}

char *
Tcl_AttemptDbCkrealloc(
    char *ptr,
    unsigned int size,
    CONST char *file,
    int line)
{
    char *result;

    result = (char *) TclpRealloc(ptr, size);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Free(
    char *ptr)
{
    TclpFree(ptr);
}

int
Tcl_DbCkfree(
    char *ptr,
    CONST char *file,
    int line)
{
    TclpFree(ptr);
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitMemory --
 *
 *      Dummy initialization for memory command, which is only available if
 *      TCL_MEM_DEBUG is on.
 *
 *----------------------------------------------------------------------
 */
        /* ARGSUSED */
void
Tcl_InitMemory(
    Tcl_Interp *interp)
{
}

int
Tcl_DumpActiveMemory(
    CONST char *fileName)
{
    return TCL_OK;
}

void
Tcl_ValidateAllMemory(
    CONST char *file,
    int line)
{
}

void
TclDumpMemoryInfo(
    FILE *outFile)
{
}

#endif  /* TCL_MEM_DEBUG */

/*
 *---------------------------------------------------------------------------
 *
 * TclFinalizeMemorySubsystem --
 *
 *      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.
 *
 *---------------------------------------------------------------------------
 */

void
TclFinalizeMemorySubsystem(void)
{
#ifdef TCL_MEM_DEBUG
    if (tclMemDumpFileName != NULL) {
        Tcl_DumpActiveMemory(tclMemDumpFileName);
    } 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();
#endif
}

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