tclobj.c

tcl是工具命令语言

 *----------------------------------------------------------------------
 */

int
Tcl_ConvertToType(interp, objPtr, typePtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;		/* The object to convert. */
    Tcl_ObjType *typePtr;	/* The target type. */
{
    if (objPtr->typePtr == typePtr) {
	return TCL_OK;
    }

    /*
     * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
     * form as appropriate for the target type. This frees the old internal
     * representation.
     */

    return typePtr->setFromAnyProc(interp, objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
 *	the empty string. These objects have a NULL object type and NULL
 *	string representation byte pointer. Type managers call this routine
 *	to allocate new objects that they further initialize.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the
 *	result of calling the debugging version Tcl_DbNewObj.
 *
 * Results:
 *	The result is a newly allocated object that represents the empty
 *	string. The new object's typePtr is set NULL and its ref count
 *	is set to 0.
 *
 * Side effects:
 *	If compiling with TCL_COMPILE_STATS, this procedure increments
 *	the global count of allocated objects (tclObjsAlloced).
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewObj

Tcl_Obj *
Tcl_NewObj()
{
    return Tcl_DbNewObj("unknown", 0);
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewObj()
{
    register Tcl_Obj *objPtr;

    /*
     * Use the macro defined in tclInt.h - it will use the
     * correct allocator.
     */

    TclNewObj(objPtr);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
 *	empty string. It is the same as the Tcl_NewObj procedure above
 *	except that it calls Tcl_DbCkalloc directly with the file name and
 *	line number from its caller. This simplifies debugging since then
 *	the [memory active] command will report the correct file name and line
 *	number when reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewObj.
 *
 * Results:
 *	The result is a newly allocated that represents the empty string.
 *	The new object's typePtr is set NULL and its ref count is set to 0.
 *
 * Side effects:
 *	If compiling with TCL_COMPILE_STATS, this procedure increments
 *	the global count of allocated objects (tclObjsAlloced).
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewObj(file, line)
    register CONST char *file;	/* The name of the source file calling this
				 * procedure; used for debugging. */
    register int line;		/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    /*
     * Use the macro defined in tclInt.h - it will use the
     * correct allocator.
     */

    TclDbNewObj(objPtr, file, line);
    return objPtr;
}
#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewObj(file, line)
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewObj();
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclAllocateFreeObjects --
 *
 *	Procedure to allocate a number of free Tcl_Objs. This is done using
 *	a single ckalloc to reduce the overhead for Tcl_Obj allocation.
 *
 *	Assumes mutex is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
 *	first of a number of free Tcl_Obj's linked together by their
 *	internalRep.otherValuePtrs.
 *
 *----------------------------------------------------------------------
 */

#define OBJS_TO_ALLOC_EACH_TIME 100

void
TclAllocateFreeObjects()
{
    size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
    char *basePtr;
    register Tcl_Obj *prevPtr, *objPtr;
    register int i;

    /*
     * This has been noted by Purify to be a potential leak.  The problem is
     * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
     * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
     * actually freeing the memory.  These never do get freed properly.
     */

    basePtr = (char *) ckalloc(bytesToAlloc);
    memset(basePtr, 0, bytesToAlloc);

    prevPtr = NULL;
    objPtr = (Tcl_Obj *) basePtr;
    for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
	objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
	prevPtr = objPtr;
	objPtr++;
    }
    tclFreeObjList = prevPtr;
}
#undef OBJS_TO_ALLOC_EACH_TIME

/*
 *----------------------------------------------------------------------
 *
 * TclFreeObj --
 *
 *	This procedure frees the memory associated with the argument
 *	object. It is called by the tcl.h macro Tcl_DecrRefCount when an
 *	object's ref count is zero. It is only "public" since it must
 *	be callable by that macro wherever the macro is used. It should not
 *	be directly called by clients.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates the storage for the object's Tcl_Obj structure
 *	after deallocating the string representation and calling the
 *	type-specific Tcl_FreeInternalRepProc to deallocate the object's
 *	internal representation. If compiling with TCL_COMPILE_STATS,
 *	this procedure increments the global count of freed objects
 *	(tclObjsFreed).
 *
 *----------------------------------------------------------------------
 */

void
TclFreeObj(objPtr)
    register Tcl_Obj *objPtr;	/* The object to be freed. */
{
    register Tcl_ObjType *typePtr = objPtr->typePtr;
    
#ifdef TCL_MEM_DEBUG
    if ((objPtr)->refCount < -1) {
	panic("Reference count for %lx was negative", objPtr);
    }
#endif /* TCL_MEM_DEBUG */

    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
	typePtr->freeIntRepProc(objPtr);
    }
    Tcl_InvalidateStringRep(objPtr);

    /*
     * If debugging Tcl's memory usage, deallocate the object using ckfree.
     * Otherwise, deallocate it by adding it onto the list of free
     * Tcl_Obj structs we maintain.
     */

#if defined(TCL_MEM_DEBUG) || defined(PURIFY)
    Tcl_MutexLock(&tclObjMutex);
    ckfree((char *) objPtr);
    Tcl_MutexUnlock(&tclObjMutex);
#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) 
    TclThreadFreeObj(objPtr); 
#else 
    Tcl_MutexLock(&tclObjMutex);
    objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
    tclFreeObjList = objPtr;
    Tcl_MutexUnlock(&tclObjMutex);
#endif /* TCL_MEM_DEBUG */

#ifdef TCL_COMPILE_STATS
    tclObjsFreed++;
#endif /* TCL_COMPILE_STATS */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DuplicateObj --
 *
 *	Create and return a new object that is a duplicate of the argument
 *	object.
 *
 * Results:
 *	The return value is a pointer to a newly created Tcl_Obj. This
 *	object has reference count 0 and the same type, if any, as the
 *	source object objPtr. Also:
 *	  1) If the source object has a valid string rep, we copy it;
 *	     otherwise, the duplicate's string rep is set NULL to mark
 *	     it invalid.
 *	  2) If the source object has an internal representation (i.e. its
 *	     typePtr is non-NULL), the new object's internal rep is set to
 *	     a copy; otherwise the new internal rep is marked invalid.
 *
 * Side effects:
 *      What constitutes "copying" the internal representation depends on
 *	the type. For example, if the argument object is a list,
 *	the element objects it points to will not actually be copied but
 *	will be shared with the duplicate list. That is, the ref counts of
 *	the element objects will be incremented.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_DuplicateObj(objPtr)
    register Tcl_Obj *objPtr;		/* The object to duplicate. */
{
    register Tcl_ObjType *typePtr = objPtr->typePtr;
    register Tcl_Obj *dupPtr;

    TclNewObj(dupPtr);

    if (objPtr->bytes == NULL) {
	dupPtr->bytes = NULL;
    } else if (objPtr->bytes != tclEmptyStringRep) {
	TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
    }
    
    if (typePtr != NULL) {
	if (typePtr->dupIntRepProc == NULL) {
	    dupPtr->internalRep = objPtr->internalRep;
	    dupPtr->typePtr = typePtr;
	} else {
	    (*typePtr->dupIntRepProc)(objPtr, dupPtr);
	}
    }
    return dupPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetString --
 *
 *	Returns the string representation byte array pointer for an object.
 *
 * Results:
 *	Returns a pointer to the string representation of objPtr. The byte
 *	array referenced by the returned pointer must not be modified by the
 *	caller. Furthermore, the caller must copy the bytes if they need to
 *	retain them since the object's string rep can change as a result of
 *	other operations.
 *
 * Side effects:
 *	May call the object's updateStringProc to update the string
 *	representation from the internal representation.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_GetString(objPtr)
    register Tcl_Obj *objPtr;	/* Object whose string rep byte pointer
				 * should be returned. */
{
    if (objPtr->bytes != NULL) {
	return objPtr->bytes;
    }

    if (objPtr->typePtr->updateStringProc == NULL) {
	panic("UpdateStringProc should not be invoked for type %s",
		objPtr->typePtr->name);
    }
    (*objPtr->typePtr->updateStringProc)(objPtr);
    return objPtr->bytes;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStringFromObj --
 *
 *	Returns the string representation's byte array pointer and length
 *	for an object.
 *
 * Results:
 *	Returns a pointer to the string representation of objPtr. If
 *	lengthPtr isn't NULL, the length of the string representation is
 *	stored at *lengthPtr. The byte array referenced by the returned
 *	pointer must not be modified by the caller. Furthermore, the
 *	caller must copy the bytes if they need to retain them since the
 *	object's string rep can change as a result of other operations.
 *
 * Side effects:
 *	May call the object's updateStringProc to update the string
 *	representation from the internal representation.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_GetStringFromObj(objPtr, lengthPtr)
    register Tcl_Obj *objPtr;	/* Object whose string rep byte pointer should
				 * be returned. */
    register int *lengthPtr;	/* If non-NULL, the location where the string
				 * rep's byte array length should * be stored.
				 * If NULL, no length is stored. */
{
    if (objPtr->bytes == NULL) {
	if (objPtr->typePtr->updateStringProc == NULL) {
	    panic("UpdateStringProc should not be invoked for type %s",
		    objPtr->typePtr->name);
	}
	(*objPtr->typePtr->updateStringProc)(objPtr);
    }

    if (lengthPtr != NULL) {
	*lengthPtr = objPtr->length;
    }
    return objPtr->bytes;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InvalidateStringRep --
 *
 *	This procedure is called to invalidate an object's string
 *	representation. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates the storage for any old string representation, then
 *	sets the string representation NULL to mark it invalid.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_InvalidateStringRep(objPtr)
     register Tcl_Obj *objPtr;	/* Object whose string rep byte pointer
				 * should be freed. */
{
    if (objPtr->bytes != NULL) {
	if (objPtr->bytes != tclEmptyStringRep) {
	    ckfree((char *) objPtr->bytes);
	}
	objPtr->bytes = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewBooleanObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new boolean object and
 *	initializes it from the argument boolean value. A nonzero
 *	"boolValue" is coerced to 1.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the
 *	result of calling the debugging version Tcl_DbNewBooleanObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewBooleanObj

Tcl_Obj *
Tcl_NewBooleanObj(boolValue)
    register int boolValue;	/* Boolean used to initialize new object. */
{
    return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
}