tclobj.c

linux系统下的音频通信

 *	the interpreter's result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIntFromObj(interp, objPtr, intPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get a int. */
    register int *intPtr;	/* Place to store resulting int. */
{
    register long l;
    int result;
    
    if (objPtr->typePtr != &tclIntType) {
	result = SetIntFromAny(interp, objPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }
    l = objPtr->internalRep.longValue;
    if (((long)((int)l)) == l) {
	*intPtr = (int)objPtr->internalRep.longValue;
	return TCL_OK;
    }
    if (interp != NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
		"integer value too large to represent as non-long integer", -1);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * DupIntInternalRep --
 *
 *	Initialize the internal representation of an int Tcl_Obj to a
 *	copy of the internal representation of an existing int object. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	"copyPtr"s internal rep is set to the integer corresponding to
 *	"srcPtr"s internal rep.
 *
 *----------------------------------------------------------------------
 */

static void
DupIntInternalRep(srcPtr, copyPtr)
    register Tcl_Obj *srcPtr;	/* Object with internal rep to copy. */
    register Tcl_Obj *copyPtr;	/* Object with internal rep to set. */
{
    copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
    copyPtr->typePtr = &tclIntType;
}

/*
 *----------------------------------------------------------------------
 *
 * SetIntFromAny --
 *
 *	Attempt to generate an integer internal form for the Tcl object
 *	"objPtr".
 *
 * Results:
 *	The return value is a standard object Tcl result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If no error occurs, an int is stored as "objPtr"s internal
 *	representation. 
 *
 *----------------------------------------------------------------------
 */

static int
SetIntFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    Tcl_ObjType *oldTypePtr = objPtr->typePtr;
    char *string, *end;
    int length;
    register char *p;
    long newLong;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */

    string = TclGetStringFromObj(objPtr, &length);

    /*
     * Now parse "objPtr"s string as an int. We use an implementation here
     * that doesn't report errors in interp if interp is NULL. Note: use
     * strtoul instead of strtol for integer conversions to allow full-size
     * unsigned numbers, but don't depend on strtoul to handle sign
     * characters; it won't in some implementations.
     */

    errno = 0;
    for (p = string;  isspace(UCHAR(*p));  p++) {
	/* Empty loop body. */
    }
    if (*p == '-') {
	p++;
	newLong = -((long)strtoul(p, &end, 0));
    } else if (*p == '+') {
	p++;
	newLong = strtoul(p, &end, 0);
    } else {
	newLong = strtoul(p, &end, 0);
    }
    if (end == p) {
	badInteger:
	if (interp != NULL) {
	    /*
	     * Must copy string before resetting the result in case a caller
	     * is trying to convert the interpreter's result to an int.
	     */
	    
	    char buf[100];
	    sprintf(buf, "expected integer but got \"%.50s\"", string);
	    Tcl_ResetResult(interp);
	    Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
	}
	return TCL_ERROR;
    }
    if (errno == ERANGE) {
	if (interp != NULL) {
	    char *s = "integer value too large to represent";
	    Tcl_ResetResult(interp);
	    Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Make sure that the string has no garbage after the end of the int.
     */
    
    while ((end < (string+length)) && isspace(UCHAR(*end))) {
	end++;
    }
    if (end != (string+length)) {
	goto badInteger;
    }

    /*
     * The conversion to int succeeded. Free the old internalRep before
     * setting the new one. We do this as late as possible to allow the
     * conversion code, in particular Tcl_GetStringFromObj, to use that old
     * internalRep.
     */

    if ((oldTypePtr != NULL) &&	(oldTypePtr->freeIntRepProc != NULL)) {
	oldTypePtr->freeIntRepProc(objPtr);
    }
    
    objPtr->internalRep.longValue = newLong;
    objPtr->typePtr = &tclIntType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfInt --
 *
 *	Update the string representation for an integer object.
 *	Note: This procedure does not free an existing old string rep
 *	so storage will be lost if this has not already been done. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the int-to-string conversion.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfInt(objPtr)
    register Tcl_Obj *objPtr;	/* Int object whose string rep to update. */
{
    char buffer[TCL_DOUBLE_SPACE];
    register int len;
    
    len = TclFormatInt(buffer, objPtr->internalRep.longValue);
    
    objPtr->bytes = ckalloc((unsigned) len + 1);
    strcpy(objPtr->bytes, buffer);
    objPtr->length = len;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewLongObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewLongObj to create a new long integer object end up calling
 *	the debugging procedure Tcl_DbNewLongObj instead.
 *
 *	Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
 *	calls to Tcl_NewLongObj result in a call to one of the two
 *	Tcl_NewLongObj implementations below. We provide two implementations
 *	so that the Tcl core can be compiled to do memory debugging of the 
 *	core even if a client does not request it for itself.
 *
 *	Integer and long integer objects share the same "integer" type
 *	implementation. We store all integers as longs and Tcl_GetIntFromObj
 *	checks whether the current value of the long can be represented by
 *	an int.
 *
 * 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_NewLongObj

Tcl_Obj *
Tcl_NewLongObj(longValue)
    register long longValue;	/* Long integer used to initialize the
				 * new object. */
{
    return Tcl_DbNewLongObj(longValue, "unknown", 0);
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewLongObj(longValue)
    register long longValue;	/* Long integer used to initialize the
				 * new object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    objPtr->bytes = NULL;
    
    objPtr->internalRep.longValue = longValue;
    objPtr->typePtr = &tclIntType;
    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewLongObj --
 *
 *	If a client is compiled with TCL_MEM_DEBUG defined, calls to
 *	Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
 *	long integer objects end up calling the debugging procedure
 *	Tcl_DbNewLongObj instead. We provide two implementations of
 *	Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
 *	memory debugging of the core is independent of whether a client
 *	requests debugging for itself.
 *
 *	When the core is compiled with TCL_MEM_DEBUG defined,
 *	Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
 *	line number from its caller. This simplifies debugging since then
 *	the checkmem command will report the caller's file name and line
 *	number when reporting objects that haven't been freed.
 *
 *	Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
 *	this procedure just returns the result of calling Tcl_NewLongObj.
 *
 * Results:
 *	The newly created long integer object is returned. This object
 *	will have an invalid string representation. The returned object has
 *	ref count 0.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewLongObj(longValue, file, line)
    register long longValue;	/* Long integer used to initialize the
				 * new object. */
    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. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;
    
    objPtr->internalRep.longValue = longValue;
    objPtr->typePtr = &tclIntType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewLongObj(longValue, file, line)
    register long longValue;	/* Long integer used to initialize the
				 * new object. */
    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_NewLongObj(longValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetLongObj --
 *
 *	Modify an object to be an integer object and to have the specified
 *	long integer value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old
 *	internal rep is freed. 
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetLongObj(objPtr, longValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register long longValue;	/* Long integer used to initialize the
				 * object's value. */
{
    register Tcl_ObjType *oldTypePtr = objPtr->typePtr;

    if (Tcl_IsShared(objPtr)) {
	panic("Tcl_SetLongObj called with shared object");
    }

    Tcl_InvalidateStringRep(objPtr);
    if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
	oldTypePtr->freeIntRepProc(objPtr);
    }
    
    objPtr->internalRep.longValue = longValue;
    objPtr->typePtr = &tclIntType;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetLongFromObj --
 *
 *	Attempt to return an long integer from the Tcl object "objPtr". If
 *	the object is not already an int object, an attempt will be made to
 *	convert it to one.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int object, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetLongFromObj(interp, objPtr, longPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get a long. */
    register long *longPtr;	/* Place to store resulting long. */
{
    register int result;
    
    if (objPtr->typePtr == &tclIntType) {
	*longPtr = objPtr->internalRep.longValue;
	return TCL_OK;
    }
    result = SetIntFromAny(interp, objPtr);
    if (result == TCL_OK) {
	*longPtr = objPtr->internalRep.longValue;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbIncrRefCount --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. This checks to see whether or not
 *	the memory has been freed before incrementing the ref count.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just increments
 *	the reference count of the object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's ref count is incremented.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DbIncrRefCount(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object we are adding a reference to. */
    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. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	panic("Trying to increment refCount of previously disposed object.");
    }
#endif
    ++(objPtr)->refCount;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbDecrRefCount --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. This checks to see whether or not
 *	the memory has been freed before incrementing the ref count.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just increments
 *	the reference count of the object.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's ref count is incremented.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DbDecrRefCount(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object we are adding a reference to. */
    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. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	panic("Trying to decrement refCount of previously disposed object.");
    }
#endif
    if (--(objPtr)->refCount <= 0) {
	TclFreeObj(objPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbIsShared --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. This checks to see whether or not
 *	the memory has been freed before incrementing the ref count.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just decrements
 *	the reference count of the object and throws it away if the count
 *	is 0 or less.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's ref count is incremented.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DbIsShared(objPtr, file, line)
    register Tcl_Obj *objPtr;	/* The object we are adding a reference to. */
    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. */
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == 0x61616161) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	panic("Trying to check whether previously disposed object is shared.");
    }
#endif
    return ((objPtr)->refCount > 1);
}