/* 

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

  * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.  

  *

  * 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.19 2003/01/19 07:21:18 hobbs Exp $

  */

 #include "tclInt.h"

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

 };

 #if !defined(__SYMBIAN32__) || !defined(__WINSCW__)

 static struct mem_header *allocHead = NULL;  /* List of allocated structures */

 #else

 typedef struct mem_header (*memHeaderPtr);

 #define allocHead (*(memHeaderPtr*)get_allocHead())

 #endif

 #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 _ANSI_ARGS_((ClientData clientData,

 			    Tcl_Interp *interp, int argc, CONST char *argv[]));

 static int		MemoryCmd _ANSI_ARGS_((ClientData clientData,

 			    Tcl_Interp *interp, int argc, CONST char **argv));

 static void		ValidateMemory _ANSI_ARGS_((

 			    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() 

 {

     if (!ckallocInit) {

 	ckallocInit = 1;

 	ckallocMutexPtr = Tcl_GetAllocMutex();

     }

 }

 /*

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

  *

  * TclDumpMemoryInfo --

  *     Display the global memory management statistics.

  *

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

  */

 void

 TclDumpMemoryInfo(outFile) 

     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(memHeaderP, file, line, nukeGuards)

     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;

     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 &= 0xff;

             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,

 		memHeaderP->file, memHeaderP->line);

         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", 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);

         panic("Memory validation failure");

     }

     if (nukeGuards) {

         memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); 

         memset ((char *) 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.

  *

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

  */

 EXPORT_C void

 Tcl_ValidateAllMemory (file, line)

     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.

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

  */

 EXPORT_C int

 Tcl_DumpActiveMemory (fileName)

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

  *

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

  */

 EXPORT_C char *

 Tcl_DbCkalloc(size, file, line)

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

         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 ((VOID *) result, GUARD_VALUE,

 		size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);

     } else {

 	memset ((char *) 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(size, file, line)

     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 ((VOID *) result, GUARD_VALUE,

 		size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);

     } else {

 	memset ((char *) 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 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__.

  *

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

  */

 EXPORT_C int

 Tcl_DbCkfree(ptr, file, line)

     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((VOID *) 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.

  *

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

  */

 EXPORT_C char *

 Tcl_DbCkrealloc(ptr, size, file, line)

     char        *ptr;

     unsigned int size;

     CONST char  *file;

     int          line;

 {

     char *new;

     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;

     }

     new = Tcl_DbCkalloc(size, file, line);

     memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);

     Tcl_DbCkfree(ptr, file, line);

     return new;

 }

 char *

 Tcl_AttemptDbCkrealloc(ptr, size, file, line)

     char        *ptr;

     unsigned int size;

     CONST char  *file;

     int          line;

 {

     char *new;

     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;

     }

     new = Tcl_AttemptDbCkalloc(size, file, line);

     if (new == NULL) {

 	return NULL;

     }

     memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);

     Tcl_DbCkfree(ptr, file, line);

     return new;

 }

 /*

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

  *

  * 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

 EXPORT_C char *

 Tcl_Alloc(size)

     unsigned int size;

 {

     return Tcl_DbCkalloc(size, "unknown", 0);

 }

 char *

 Tcl_AttemptAlloc(size)

     unsigned int size;

 {

     return Tcl_AttemptDbCkalloc(size, "unknown", 0);

 }

 EXPORT_C void

 Tcl_Free(ptr)

     char *ptr;

 {

     Tcl_DbCkfree(ptr, "unknown", 0);

 }

 EXPORT_C char *

 Tcl_Realloc(ptr, size)

     char *ptr;

     unsigned int size;

 {

     return Tcl_DbCkrealloc(ptr, size, "unknown", 0);

 }

 char *

 Tcl_AttemptRealloc(ptr, size)

     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, interp, argc, argv)

     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..]\"", (char *) 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\"", (char *) 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], 

 		    (char *) 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) {

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

 	Tcl_SetResult(interp, buf, TCL_VOLATILE);

         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\"", (char *) 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\"", (char *) 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", (char *) NULL);

     return TCL_ERROR;

 argError:

     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

 	    " ", argv[1], " count\"", (char *) NULL);

     return TCL_ERROR;

 bad_suboption:

     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

 	    " ", argv[1], " on|off\"", (char *) 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, interp, argc, argv)

     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\"", (char *) 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.

  *

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

  */

 EXPORT_C void

 Tcl_InitMemory(interp)

     Tcl_Interp *interp;	/* Interpreter in which commands should be added */

 {

     TclInitDbCkalloc();

     Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, 

 	    (Tcl_CmdDeleteProc *) NULL);

     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,

 	    (Tcl_CmdDeleteProc *) 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.

  *

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

  */

 EXPORT_C char *

 Tcl_Alloc (size)

     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) {

 	panic("unable to alloc %u bytes", size);

     }

     return result;

 }

 EXPORT_C char *

 Tcl_DbCkalloc(size, file, line)

     unsigned int size;

     CONST char  *file;

     int          line;

 {

     char *result;

     result = (char *) TclpAlloc(size);

     if ((result == NULL) && size) {

         fflush(stdout);

         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.

  *

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

  */

 EXPORT_C char *

 Tcl_AttemptAlloc (size)

     unsigned int size;

 {

     char *result;

     result = TclpAlloc(size);

     return result;

 }

 EXPORT_C char *

 Tcl_AttemptDbCkalloc(size, file, line)

     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.

  *

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

  */

 EXPORT_C char *

 Tcl_Realloc(ptr, size)

     char *ptr;

     unsigned int size;

 {

     char *result;

     result = TclpRealloc(ptr, size);

     if ((result == NULL) && size) {

 	panic("unable to realloc %u bytes", size);

     }

     return result;

 }

 EXPORT_C char *

 Tcl_DbCkrealloc(ptr, size, file, line)

     char        *ptr;

     unsigned int size;

     CONST char  *file;

     int          line;

 {

     char *result;

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

     if ((result == NULL) && size) {

         fflush(stdout);

         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.

  *

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

  */

 EXPORT_C char *

 Tcl_AttemptRealloc(ptr, size)

     char *ptr;

     unsigned int size;

 {

     char *result;

     result = TclpRealloc(ptr, size);

     return result;

 }

 EXPORT_C char *

 Tcl_AttemptDbCkrealloc(ptr, size, file, line)

     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.

  *

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

  */

 EXPORT_C void

 Tcl_Free (ptr)

     char *ptr;

 {

     TclpFree(ptr);

 }

 EXPORT_C int

 Tcl_DbCkfree(ptr, file, line)

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

 EXPORT_C void

 Tcl_InitMemory(interp)

     Tcl_Interp *interp;

 {

 }

 EXPORT_C int

 Tcl_DumpActiveMemory(fileName)

     CONST char *fileName;

 {

     return TCL_OK;

 }

 EXPORT_C void

 Tcl_ValidateAllMemory(file, line)

     CONST char *file;

     int         line;

 {

 }

 EXPORT_C void

 TclDumpMemoryInfo(outFile) 

     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()

 {

 #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

 }