tclckalloc.c

tcl是工具命令语言

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

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

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

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

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

    result = TclpAlloc(size);
    return result;
}

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

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

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

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

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

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

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

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 */
void
Tcl_InitMemory(interp)
    Tcl_Interp *interp;
{
}

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

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

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
}