tclobj.c

linux系统下的音频通信

/* 
 * tclObj.c --
 *
 *	This file contains Tcl object-related procedures that are used by
 * 	many Tcl commands.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tclObj.c 1.47 97/10/30 13:39:00
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * Table of all object types.
 */

static Tcl_HashTable typeTable;
static int typeTableInitialized = 0;    /* 0 means not yet initialized. */

/*
 * Head of the list of free Tcl_Objs we maintain.
 */

Tcl_Obj *tclFreeObjList = NULL;

/*
 * Pointer to a heap-allocated string of length zero that the Tcl core uses
 * as the value of an empty string representation for an object. This value
 * is shared by all new objects allocated by Tcl_NewObj.
 */

char *tclEmptyStringRep = NULL;

/*
 * Count of the number of Tcl objects every allocated (by Tcl_NewObj) and
 * freed (by TclFreeObj).
 */

#ifdef TCL_COMPILE_STATS
long tclObjsAlloced = 0;
long tclObjsFreed = 0;
#endif /* TCL_COMPILE_STATS */

/*
 * Prototypes for procedures defined later in this file:
 */

static void		DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static void		DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static void		DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static void		FinalizeTypeTable _ANSI_ARGS_((void));
static void		FinalizeFreeObjList _ANSI_ARGS_((void));
static void		InitTypeTable _ANSI_ARGS_((void));
static int		SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static int		SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static int		SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));
static void		UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
static void		UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));

/*
 * The structures below defines the Tcl object types defined in this file by
 * means of procedures that can be invoked by generic object code. See also
 * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
 * implementations.
 */

Tcl_ObjType tclBooleanType = {
    "boolean",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
    DupBooleanInternalRep,		/* dupIntRepProc */
    UpdateStringOfBoolean,		/* updateStringProc */
    SetBooleanFromAny			/* setFromAnyProc */
};

Tcl_ObjType tclDoubleType = {
    "double",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
    DupDoubleInternalRep,		/* dupIntRepProc */
    UpdateStringOfDouble,		/* updateStringProc */
    SetDoubleFromAny			/* setFromAnyProc */
};

Tcl_ObjType tclIntType = {
    "int",				/* name */
    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
    DupIntInternalRep,		        /* dupIntRepProc */
    UpdateStringOfInt,			/* updateStringProc */
    SetIntFromAny			/* setFromAnyProc */
};

/*
 *--------------------------------------------------------------
 *
 * InitTypeTable --
 *
 *	This procedure is invoked to perform once-only initialization of
 *	the type table. It also registers the object types defined in 
 *	this file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Initializes the table of defined object types "typeTable" with
 *	builtin object types defined in this file. It also initializes the
 *	value of tclEmptyStringRep, which points to the heap-allocated
 *	string of length zero used as the string representation for
 *	newly-created objects.
 *
 *--------------------------------------------------------------
 */

static void
InitTypeTable()
{
    typeTableInitialized = 1;

    Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
    Tcl_RegisterObjType(&tclBooleanType);
    Tcl_RegisterObjType(&tclDoubleType);
    Tcl_RegisterObjType(&tclIntType);
    Tcl_RegisterObjType(&tclStringType);
    Tcl_RegisterObjType(&tclListType);
    Tcl_RegisterObjType(&tclByteCodeType);

    tclEmptyStringRep = (char *) ckalloc((unsigned) 1);
    tclEmptyStringRep[0] = '\0';
}

/*
 *----------------------------------------------------------------------
 *
 * FinalizeTypeTable --
 *
 *	This procedure is called by Tcl_Finalize after all exit handlers
 *	have been run to free up storage associated with the table of Tcl
 *	object types.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes all entries in the hash table of object types, "typeTable".
 *	Then sets "typeTableInitialized" to 0 so that the Tcl type system
 *	will be properly reinitialized if Tcl is restarted. Also deallocates
 *	the storage for tclEmptyStringRep.
 *
 *----------------------------------------------------------------------
 */

static void
FinalizeTypeTable()
{
    if (typeTableInitialized) {
        Tcl_DeleteHashTable(&typeTable);
	ckfree(tclEmptyStringRep);
        typeTableInitialized = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FinalizeFreeObjList --
 *
 *	Resets the free object list so it can later be reinitialized.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the value of tclFreeObjList.
 *
 *----------------------------------------------------------------------
 */

static void
FinalizeFreeObjList()
{
    tclFreeObjList = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeCompExecEnv --
 *
 *	Clean up the compiler execution environment so it can later be
 *	properly reinitialized.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up the execution environment
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeCompExecEnv()
{
    FinalizeTypeTable();
    FinalizeFreeObjList();
    TclFinalizeExecEnv();
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_RegisterObjType --
 *
 *	This procedure is called to register a new Tcl object type
 *	in the table of all object types supported by Tcl.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The type is registered in the Tcl type table. If there was already
 *	a type with the same name as in typePtr, it is replaced with the
 *	new type.
 *
 *--------------------------------------------------------------
 */

void
Tcl_RegisterObjType(typePtr)
    Tcl_ObjType *typePtr;	/* Information about object type;
				 * storage must be statically
				 * allocated (must live forever). */
{
    register Tcl_HashEntry *hPtr;
    int new;

    if (!typeTableInitialized) {
	InitTypeTable();
    }

    /*
     * If there's already an object type with the given name, remove it.
     */

    hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name);
    if (hPtr != (Tcl_HashEntry *) NULL) {
        Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Now insert the new object type.
     */

    hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new);
    if (new) {
	Tcl_SetHashValue(hPtr, typePtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendAllObjTypes --
 *
 *	This procedure appends onto the argument object the name of each
 *	object type as a list element. This includes the builtin object
 *	types (e.g. int, list) as well as those added using
 *	Tcl_CreateObjType. These names can be used, for example, with
 *	Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
 *	structures.
 *
 * Results:
 *	The return value is normally TCL_OK; in this case the object
 *	referenced by objPtr has each type name appended to it. If an
 *	error occurs, TCL_ERROR is returned and the interpreter's result
 *	holds an error message.
 *
 * Side effects:
 *	If necessary, the object referenced by objPtr is converted into
 *	a list object.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppendAllObjTypes(interp, objPtr)
    Tcl_Interp *interp;		/* Interpreter used for error reporting. */
    Tcl_Obj *objPtr;		/* Points to the Tcl object onto which the
				 * name of each registered type is appended
				 * as a list element. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_ObjType *typePtr;
    int result;
 
    if (!typeTableInitialized) {
	InitTypeTable();
    }

    /*
     * This code assumes that types names do not contain embedded NULLs.
     */

    for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
	    hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
        typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
	result = Tcl_ListObjAppendElement(interp, objPtr,
	        Tcl_NewStringObj(typePtr->name, -1));
	if (result == TCL_ERROR) {
	    return result;
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetObjType --
 *
 *	This procedure looks up an object type by name.
 *
 * Results:
 *	If an object type with name matching "typeName" is found, a pointer
 *	to its Tcl_ObjType structure is returned; otherwise, NULL is
 *	returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_ObjType *
Tcl_GetObjType(typeName)
    char *typeName;		/* Name of Tcl object type to look up. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_ObjType *typePtr;

    if (!typeTableInitialized) {
	InitTypeTable();
    }

    hPtr = Tcl_FindHashEntry(&typeTable, typeName);
    if (hPtr != (Tcl_HashEntry *) NULL) {
        typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
	return typePtr;
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConvertToType --
 *
 *	Convert the Tcl object "objPtr" to have type "typePtr" if possible.
 *
 * Results:
 *	The return value is TCL_OK on success and TCL_ERROR on failure. If
 *	TCL_ERROR is returned, then the interpreter's result contains an
 *	error message unless "interp" is NULL. Passing a NULL "interp"
 *	allows this procedure to be used as a test whether the conversion
 *	could be done (and in fact was done).
 *
 * Side effects:
 *	Any internal representation for the old type is freed.
 *
 *----------------------------------------------------------------------
 */

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;

    /*
     * Allocate the object using the list of free Tcl_Objs we maintain.
     */

    if (tclFreeObjList == NULL) {
	TclAllocateFreeObjects();
    }
    objPtr = tclFreeObjList;
    tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr;
    
    objPtr->refCount = 0;
    objPtr->bytes    = tclEmptyStringRep;
    objPtr->length   = 0;
    objPtr->typePtr  = NULL;
#ifdef TCL_COMPILE_STATS
    tclObjsAlloced++;
#endif /* TCL_COMPILE_STATS */
    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 checkmem 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 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;

    /*
     * If debugging Tcl's memory usage, allocate the object using ckalloc.
     * Otherwise, allocate it using the list of free Tcl_Objs we maintain.
     */

    objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
    objPtr->refCount = 0;
    objPtr->bytes    = tclEmptyStringRep;
    objPtr->length   = 0;
    objPtr->typePtr  = NULL;
#ifdef TCL_COMPILE_STATS
    tclObjsAlloced++;
#endif /* TCL_COMPILE_STATS */
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewObj(file, line)
    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 */

/*
 *----------------------------------------------------------------------
 *