tclckalloc.c

tcl源码详细资料

    if (alloc_tracing)
        tracef("ckfree %lx %ld %s %d\n", memp->body, 
                memp->length, file, line);

    if (validate_memory)
        Tcl_ValidateAllMemory (file, line);

    ValidateMemory (memp, file, line, TRUE);

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

    /*
     * 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;
    Tcl_Free((char *) memp);
    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(ptr, size, file, line)
    char *ptr;
    unsigned int size;
    char *file;
    int line;
{
    char *new;

    new = Tcl_DbCkalloc(size, file, line);
    memcpy((VOID *) new, (VOID *) ptr, (int) size);
    Tcl_DbCkfree(ptr, file, line);
    return(new);
}

/*
 *----------------------------------------------------------------------
 *
 * MemoryCmd --
 *     Implements the TCL memory command:
 *       memory info
 *       memory display
 *       break_on_malloc count
 *       trace_on_at_malloc count
 *       trace on|off
 *       validate on|off
 *
 * Results:
 *     Standard TCL results.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
static int
MemoryCmd (clientData, interp, argc, argv)
    char       *clientData;
    Tcl_Interp *interp;
    int         argc;
    char      **argv;
{
    char *fileName;

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

    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],"init") == 0) {
        if (argc != 3)
            goto bad_suboption;
        init_malloced_bodies = (strcmp(argv[2],"on") == 0);
        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;
    }
    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],"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) {
        dump_memory_info();
        return TCL_OK;
    }
    if (strcmp(argv[1],"active") == 0) {
        if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args:  should be \"",
		    argv[0], " active file", (char *) NULL);
	    return TCL_ERROR;
	}
        fileName = argv [2];
        if (fileName [0] == '~')
            if ((fileName = Tcl_TildeSubst (interp, fileName)) == NULL)
                return TCL_ERROR;
        if (Tcl_DumpActiveMemory (fileName) != TCL_OK) {
	    Tcl_AppendResult(interp, "error accessing ", argv[2], 
		    (char *) NULL);
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    Tcl_AppendResult(interp, "bad option \"", argv[1],
	    "\":  should be info, init, active, break_on_malloc, ",
	    "trace_on_at_malloc, trace, 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;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitMemory --
 *     Initialize the memory command.
 *
 *----------------------------------------------------------------------
 */
void
Tcl_InitMemory(interp)
    Tcl_Interp *interp;
{
    Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData)NULL, 
                      (void (*)())NULL);
}

#else


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Ckalloc --
 *     Interface to malloc when TCL_MEM_DEBUG is disabled.  It does check
 *     that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */
VOID *
Tcl_Ckalloc (size)
    unsigned int size;
{
    void *result;

    result = Tcl_Malloc(size);
    if (result == NULL) {
        panic("unable to alloc %d bytes", size);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TckCkfree --
 *     Interface to free 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_Ckfree (ptr)
    VOID *ptr;
{
    if (ptr == NULL) {
        panic("null memory pointer to free");
        return;
    }

    Tcl_Free (ptr);
}

/*
 *----------------------------------------------------------------------
 *
 * 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;
{
}

#endif

/*====================================================================*/

void
Tcl_InitHeap (void)
{
    memHeap = heapMallocInit(heapPool_0, ((unsigned long)sizeof(heapPool_0)+
					  (unsigned long)sizeof(heapPool_1)+
					  (unsigned long)sizeof(heapPool_2)+
					  (unsigned long)sizeof(heapPool_3)));
}

void
Tcl_DumpHeap (void)
{
    if (memHeap != NULL) {
        heapPrintFreeList(memHeap);
    }
}

VOID *
Tcl_Malloc (size)
    unsigned int size;
{
    void *result;

    if (memHeap == NULL) {
        panic("memory heap not initialized");
        return NULL;
    }

    result = heapMalloc(memHeap, size);
    if (result == NULL) {
        panic("unable to alloc %d bytes", size);
    }
    return result;
}

void
Tcl_Free (ptr)
    char *ptr;
{
    if (memHeap == NULL) {
        panic("memory heap not initialized");
        return;
    }

    if (ptr == NULL) {
        panic("null memory pointer to free");
        return;
    }

    heapFree(memHeap, ptr);
}

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

    if (ptr == NULL) {
	return (Tcl_Malloc(size));
    }

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

    if ((new = Tcl_Malloc(size)) == NULL) {
	return (NULL);
    }
    memcpy(new, ptr, size);
    Tcl_Free(ptr);
    return (new);
}

#else

static const char file_name[] = "tclCkalloc.c";

#endif /* EXCLUDE_TCL */