/*
|
/*
|
* tclObj.c --
|
* tclObj.c --
|
*
|
*
|
* This file contains Tcl object-related procedures that are used by
|
* This file contains Tcl object-related procedures that are used by
|
* many Tcl commands.
|
* many Tcl commands.
|
*
|
*
|
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclObj.c,v 1.1.1.1 2002-01-16 10:25:28 markom Exp $
|
* RCS: @(#) $Id: tclObj.c,v 1.1.1.1 2002-01-16 10:25:28 markom Exp $
|
*/
|
*/
|
|
|
#include "tclInt.h"
|
#include "tclInt.h"
|
#include "tclPort.h"
|
#include "tclPort.h"
|
|
|
/*
|
/*
|
* Table of all object types.
|
* Table of all object types.
|
*/
|
*/
|
|
|
static Tcl_HashTable typeTable;
|
static Tcl_HashTable typeTable;
|
static int typeTableInitialized = 0; /* 0 means not yet initialized. */
|
static int typeTableInitialized = 0; /* 0 means not yet initialized. */
|
|
|
/*
|
/*
|
* Head of the list of free Tcl_Objs we maintain.
|
* Head of the list of free Tcl_Objs we maintain.
|
*/
|
*/
|
|
|
Tcl_Obj *tclFreeObjList = NULL;
|
Tcl_Obj *tclFreeObjList = NULL;
|
|
|
/*
|
/*
|
* Pointer to a heap-allocated string of length zero that the Tcl core uses
|
* 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
|
* as the value of an empty string representation for an object. This value
|
* is shared by all new objects allocated by Tcl_NewObj.
|
* is shared by all new objects allocated by Tcl_NewObj.
|
*/
|
*/
|
|
|
char *tclEmptyStringRep = NULL;
|
char *tclEmptyStringRep = NULL;
|
|
|
/*
|
/*
|
* Count of the number of Tcl objects every allocated (by Tcl_NewObj) and
|
* Count of the number of Tcl objects every allocated (by Tcl_NewObj) and
|
* freed (by TclFreeObj).
|
* freed (by TclFreeObj).
|
*/
|
*/
|
|
|
#ifdef TCL_COMPILE_STATS
|
#ifdef TCL_COMPILE_STATS
|
long tclObjsAlloced = 0;
|
long tclObjsAlloced = 0;
|
long tclObjsFreed = 0;
|
long tclObjsFreed = 0;
|
#endif /* TCL_COMPILE_STATS */
|
#endif /* TCL_COMPILE_STATS */
|
|
|
/*
|
/*
|
* Prototypes for procedures defined later in this file:
|
* Prototypes for procedures defined later in this file:
|
*/
|
*/
|
|
|
static void DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
|
static void DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
|
Tcl_Obj *copyPtr));
|
Tcl_Obj *copyPtr));
|
static void DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
|
static void DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
|
Tcl_Obj *copyPtr));
|
Tcl_Obj *copyPtr));
|
static void DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
|
static void DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
|
Tcl_Obj *copyPtr));
|
Tcl_Obj *copyPtr));
|
static void FinalizeTypeTable _ANSI_ARGS_((void));
|
static void FinalizeTypeTable _ANSI_ARGS_((void));
|
static void FinalizeFreeObjList _ANSI_ARGS_((void));
|
static void FinalizeFreeObjList _ANSI_ARGS_((void));
|
static void InitTypeTable _ANSI_ARGS_((void));
|
static void InitTypeTable _ANSI_ARGS_((void));
|
static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Obj *objPtr));
|
Tcl_Obj *objPtr));
|
static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Obj *objPtr));
|
Tcl_Obj *objPtr));
|
static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Obj *objPtr));
|
Tcl_Obj *objPtr));
|
static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
|
static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
|
static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
|
static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
|
static void UpdateStringOfInt _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
|
* 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
|
* means of procedures that can be invoked by generic object code. See also
|
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
|
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
|
* implementations.
|
* implementations.
|
*/
|
*/
|
|
|
Tcl_ObjType tclBooleanType = {
|
Tcl_ObjType tclBooleanType = {
|
"boolean", /* name */
|
"boolean", /* name */
|
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
DupBooleanInternalRep, /* dupIntRepProc */
|
DupBooleanInternalRep, /* dupIntRepProc */
|
UpdateStringOfBoolean, /* updateStringProc */
|
UpdateStringOfBoolean, /* updateStringProc */
|
SetBooleanFromAny /* setFromAnyProc */
|
SetBooleanFromAny /* setFromAnyProc */
|
};
|
};
|
|
|
Tcl_ObjType tclDoubleType = {
|
Tcl_ObjType tclDoubleType = {
|
"double", /* name */
|
"double", /* name */
|
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
DupDoubleInternalRep, /* dupIntRepProc */
|
DupDoubleInternalRep, /* dupIntRepProc */
|
UpdateStringOfDouble, /* updateStringProc */
|
UpdateStringOfDouble, /* updateStringProc */
|
SetDoubleFromAny /* setFromAnyProc */
|
SetDoubleFromAny /* setFromAnyProc */
|
};
|
};
|
|
|
Tcl_ObjType tclIntType = {
|
Tcl_ObjType tclIntType = {
|
"int", /* name */
|
"int", /* name */
|
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
DupIntInternalRep, /* dupIntRepProc */
|
DupIntInternalRep, /* dupIntRepProc */
|
UpdateStringOfInt, /* updateStringProc */
|
UpdateStringOfInt, /* updateStringProc */
|
SetIntFromAny /* setFromAnyProc */
|
SetIntFromAny /* setFromAnyProc */
|
};
|
};
|
|
|
/*
|
/*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*
|
*
|
* InitTypeTable --
|
* InitTypeTable --
|
*
|
*
|
* This procedure is invoked to perform once-only initialization of
|
* This procedure is invoked to perform once-only initialization of
|
* the type table. It also registers the object types defined in
|
* the type table. It also registers the object types defined in
|
* this file.
|
* this file.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Initializes the table of defined object types "typeTable" with
|
* Initializes the table of defined object types "typeTable" with
|
* builtin object types defined in this file. It also initializes the
|
* builtin object types defined in this file. It also initializes the
|
* value of tclEmptyStringRep, which points to the heap-allocated
|
* value of tclEmptyStringRep, which points to the heap-allocated
|
* string of length zero used as the string representation for
|
* string of length zero used as the string representation for
|
* newly-created objects.
|
* newly-created objects.
|
*
|
*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
InitTypeTable()
|
InitTypeTable()
|
{
|
{
|
typeTableInitialized = 1;
|
typeTableInitialized = 1;
|
|
|
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
|
Tcl_RegisterObjType(&tclBooleanType);
|
Tcl_RegisterObjType(&tclBooleanType);
|
Tcl_RegisterObjType(&tclDoubleType);
|
Tcl_RegisterObjType(&tclDoubleType);
|
Tcl_RegisterObjType(&tclIntType);
|
Tcl_RegisterObjType(&tclIntType);
|
Tcl_RegisterObjType(&tclStringType);
|
Tcl_RegisterObjType(&tclStringType);
|
Tcl_RegisterObjType(&tclListType);
|
Tcl_RegisterObjType(&tclListType);
|
Tcl_RegisterObjType(&tclByteCodeType);
|
Tcl_RegisterObjType(&tclByteCodeType);
|
Tcl_RegisterObjType(&tclProcBodyType);
|
Tcl_RegisterObjType(&tclProcBodyType);
|
|
|
tclEmptyStringRep = (char *) ckalloc((unsigned) 1);
|
tclEmptyStringRep = (char *) ckalloc((unsigned) 1);
|
tclEmptyStringRep[0] = '\0';
|
tclEmptyStringRep[0] = '\0';
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* FinalizeTypeTable --
|
* FinalizeTypeTable --
|
*
|
*
|
* This procedure is called by Tcl_Finalize after all exit handlers
|
* This procedure is called by Tcl_Finalize after all exit handlers
|
* have been run to free up storage associated with the table of Tcl
|
* have been run to free up storage associated with the table of Tcl
|
* object types.
|
* object types.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deletes all entries in the hash table of object types, "typeTable".
|
* Deletes all entries in the hash table of object types, "typeTable".
|
* Then sets "typeTableInitialized" to 0 so that the Tcl type system
|
* Then sets "typeTableInitialized" to 0 so that the Tcl type system
|
* will be properly reinitialized if Tcl is restarted. Also deallocates
|
* will be properly reinitialized if Tcl is restarted. Also deallocates
|
* the storage for tclEmptyStringRep.
|
* the storage for tclEmptyStringRep.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
FinalizeTypeTable()
|
FinalizeTypeTable()
|
{
|
{
|
if (typeTableInitialized) {
|
if (typeTableInitialized) {
|
Tcl_DeleteHashTable(&typeTable);
|
Tcl_DeleteHashTable(&typeTable);
|
ckfree(tclEmptyStringRep);
|
ckfree(tclEmptyStringRep);
|
typeTableInitialized = 0;
|
typeTableInitialized = 0;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* FinalizeFreeObjList --
|
* FinalizeFreeObjList --
|
*
|
*
|
* Resets the free object list so it can later be reinitialized.
|
* Resets the free object list so it can later be reinitialized.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Resets the value of tclFreeObjList.
|
* Resets the value of tclFreeObjList.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
FinalizeFreeObjList()
|
FinalizeFreeObjList()
|
{
|
{
|
tclFreeObjList = NULL;
|
tclFreeObjList = NULL;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclFinalizeCompExecEnv --
|
* TclFinalizeCompExecEnv --
|
*
|
*
|
* Clean up the compiler execution environment so it can later be
|
* Clean up the compiler execution environment so it can later be
|
* properly reinitialized.
|
* properly reinitialized.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Cleans up the execution environment
|
* Cleans up the execution environment
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
TclFinalizeCompExecEnv()
|
TclFinalizeCompExecEnv()
|
{
|
{
|
FinalizeTypeTable();
|
FinalizeTypeTable();
|
FinalizeFreeObjList();
|
FinalizeFreeObjList();
|
TclFinalizeExecEnv();
|
TclFinalizeExecEnv();
|
}
|
}
|
|
|
/*
|
/*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*
|
*
|
* Tcl_RegisterObjType --
|
* Tcl_RegisterObjType --
|
*
|
*
|
* This procedure is called to register a new Tcl object type
|
* This procedure is called to register a new Tcl object type
|
* in the table of all object types supported by Tcl.
|
* in the table of all object types supported by Tcl.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The type is registered in the Tcl type table. If there was already
|
* 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
|
* a type with the same name as in typePtr, it is replaced with the
|
* new type.
|
* new type.
|
*
|
*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_RegisterObjType(typePtr)
|
Tcl_RegisterObjType(typePtr)
|
Tcl_ObjType *typePtr; /* Information about object type;
|
Tcl_ObjType *typePtr; /* Information about object type;
|
* storage must be statically
|
* storage must be statically
|
* allocated (must live forever). */
|
* allocated (must live forever). */
|
{
|
{
|
register Tcl_HashEntry *hPtr;
|
register Tcl_HashEntry *hPtr;
|
int new;
|
int new;
|
|
|
if (!typeTableInitialized) {
|
if (!typeTableInitialized) {
|
InitTypeTable();
|
InitTypeTable();
|
}
|
}
|
|
|
/*
|
/*
|
* If there's already an object type with the given name, remove it.
|
* If there's already an object type with the given name, remove it.
|
*/
|
*/
|
|
|
hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name);
|
hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name);
|
if (hPtr != (Tcl_HashEntry *) NULL) {
|
if (hPtr != (Tcl_HashEntry *) NULL) {
|
Tcl_DeleteHashEntry(hPtr);
|
Tcl_DeleteHashEntry(hPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Now insert the new object type.
|
* Now insert the new object type.
|
*/
|
*/
|
|
|
hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new);
|
hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new);
|
if (new) {
|
if (new) {
|
Tcl_SetHashValue(hPtr, typePtr);
|
Tcl_SetHashValue(hPtr, typePtr);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_AppendAllObjTypes --
|
* Tcl_AppendAllObjTypes --
|
*
|
*
|
* This procedure appends onto the argument object the name of each
|
* This procedure appends onto the argument object the name of each
|
* object type as a list element. This includes the builtin object
|
* object type as a list element. This includes the builtin object
|
* types (e.g. int, list) as well as those added using
|
* types (e.g. int, list) as well as those added using
|
* Tcl_CreateObjType. These names can be used, for example, with
|
* Tcl_CreateObjType. These names can be used, for example, with
|
* Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
|
* Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
|
* structures.
|
* structures.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is normally TCL_OK; in this case the object
|
* The return value is normally TCL_OK; in this case the object
|
* referenced by objPtr has each type name appended to it. If an
|
* referenced by objPtr has each type name appended to it. If an
|
* error occurs, TCL_ERROR is returned and the interpreter's result
|
* error occurs, TCL_ERROR is returned and the interpreter's result
|
* holds an error message.
|
* holds an error message.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If necessary, the object referenced by objPtr is converted into
|
* If necessary, the object referenced by objPtr is converted into
|
* a list object.
|
* a list object.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_AppendAllObjTypes(interp, objPtr)
|
Tcl_AppendAllObjTypes(interp, objPtr)
|
Tcl_Interp *interp; /* Interpreter used for error reporting. */
|
Tcl_Interp *interp; /* Interpreter used for error reporting. */
|
Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
|
Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
|
* name of each registered type is appended
|
* name of each registered type is appended
|
* as a list element. */
|
* as a list element. */
|
{
|
{
|
register Tcl_HashEntry *hPtr;
|
register Tcl_HashEntry *hPtr;
|
Tcl_HashSearch search;
|
Tcl_HashSearch search;
|
Tcl_ObjType *typePtr;
|
Tcl_ObjType *typePtr;
|
int result;
|
int result;
|
|
|
if (!typeTableInitialized) {
|
if (!typeTableInitialized) {
|
InitTypeTable();
|
InitTypeTable();
|
}
|
}
|
|
|
/*
|
/*
|
* This code assumes that types names do not contain embedded NULLs.
|
* This code assumes that types names do not contain embedded NULLs.
|
*/
|
*/
|
|
|
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
|
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
|
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
|
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
|
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
|
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
|
result = Tcl_ListObjAppendElement(interp, objPtr,
|
result = Tcl_ListObjAppendElement(interp, objPtr,
|
Tcl_NewStringObj(typePtr->name, -1));
|
Tcl_NewStringObj(typePtr->name, -1));
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetObjType --
|
* Tcl_GetObjType --
|
*
|
*
|
* This procedure looks up an object type by name.
|
* This procedure looks up an object type by name.
|
*
|
*
|
* Results:
|
* Results:
|
* If an object type with name matching "typeName" is found, a pointer
|
* If an object type with name matching "typeName" is found, a pointer
|
* to its Tcl_ObjType structure is returned; otherwise, NULL is
|
* to its Tcl_ObjType structure is returned; otherwise, NULL is
|
* returned.
|
* returned.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_ObjType *
|
Tcl_ObjType *
|
Tcl_GetObjType(typeName)
|
Tcl_GetObjType(typeName)
|
char *typeName; /* Name of Tcl object type to look up. */
|
char *typeName; /* Name of Tcl object type to look up. */
|
{
|
{
|
register Tcl_HashEntry *hPtr;
|
register Tcl_HashEntry *hPtr;
|
Tcl_ObjType *typePtr;
|
Tcl_ObjType *typePtr;
|
|
|
if (!typeTableInitialized) {
|
if (!typeTableInitialized) {
|
InitTypeTable();
|
InitTypeTable();
|
}
|
}
|
|
|
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
|
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
|
if (hPtr != (Tcl_HashEntry *) NULL) {
|
if (hPtr != (Tcl_HashEntry *) NULL) {
|
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
|
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
|
return typePtr;
|
return typePtr;
|
}
|
}
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ConvertToType --
|
* Tcl_ConvertToType --
|
*
|
*
|
* Convert the Tcl object "objPtr" to have type "typePtr" if possible.
|
* Convert the Tcl object "objPtr" to have type "typePtr" if possible.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is TCL_OK on success and TCL_ERROR on failure. If
|
* 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
|
* TCL_ERROR is returned, then the interpreter's result contains an
|
* error message unless "interp" is NULL. Passing a NULL "interp"
|
* error message unless "interp" is NULL. Passing a NULL "interp"
|
* allows this procedure to be used as a test whether the conversion
|
* allows this procedure to be used as a test whether the conversion
|
* could be done (and in fact was done).
|
* could be done (and in fact was done).
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Any internal representation for the old type is freed.
|
* Any internal representation for the old type is freed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ConvertToType(interp, objPtr, typePtr)
|
Tcl_ConvertToType(interp, objPtr, typePtr)
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Obj *objPtr; /* The object to convert. */
|
Tcl_Obj *objPtr; /* The object to convert. */
|
Tcl_ObjType *typePtr; /* The target type. */
|
Tcl_ObjType *typePtr; /* The target type. */
|
{
|
{
|
if (objPtr->typePtr == typePtr) {
|
if (objPtr->typePtr == typePtr) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
|
* Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
|
* form as appropriate for the target type. This frees the old internal
|
* form as appropriate for the target type. This frees the old internal
|
* representation.
|
* representation.
|
*/
|
*/
|
|
|
return typePtr->setFromAnyProc(interp, objPtr);
|
return typePtr->setFromAnyProc(interp, objPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_NewObj --
|
* Tcl_NewObj --
|
*
|
*
|
* This procedure is normally called when not debugging: i.e., when
|
* This procedure is normally called when not debugging: i.e., when
|
* TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
|
* 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
|
* the empty string. These objects have a NULL object type and NULL
|
* string representation byte pointer. Type managers call this routine
|
* string representation byte pointer. Type managers call this routine
|
* to allocate new objects that they further initialize.
|
* to allocate new objects that they further initialize.
|
*
|
*
|
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
* result of calling the debugging version Tcl_DbNewObj.
|
* result of calling the debugging version Tcl_DbNewObj.
|
*
|
*
|
* Results:
|
* Results:
|
* The result is a newly allocated object that represents the empty
|
* The result is a newly allocated object that represents the empty
|
* string. The new object's typePtr is set NULL and its ref count
|
* string. The new object's typePtr is set NULL and its ref count
|
* is set to 0.
|
* is set to 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If compiling with TCL_COMPILE_STATS, this procedure increments
|
* If compiling with TCL_COMPILE_STATS, this procedure increments
|
* the global count of allocated objects (tclObjsAlloced).
|
* the global count of allocated objects (tclObjsAlloced).
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
#undef Tcl_NewObj
|
#undef Tcl_NewObj
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewObj()
|
Tcl_NewObj()
|
{
|
{
|
return Tcl_DbNewObj("unknown", 0);
|
return Tcl_DbNewObj("unknown", 0);
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewObj()
|
Tcl_NewObj()
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
/*
|
/*
|
* Allocate the object using the list of free Tcl_Objs we maintain.
|
* Allocate the object using the list of free Tcl_Objs we maintain.
|
*/
|
*/
|
|
|
if (tclFreeObjList == NULL) {
|
if (tclFreeObjList == NULL) {
|
TclAllocateFreeObjects();
|
TclAllocateFreeObjects();
|
}
|
}
|
objPtr = tclFreeObjList;
|
objPtr = tclFreeObjList;
|
tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr;
|
tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr;
|
|
|
objPtr->refCount = 0;
|
objPtr->refCount = 0;
|
objPtr->bytes = tclEmptyStringRep;
|
objPtr->bytes = tclEmptyStringRep;
|
objPtr->length = 0;
|
objPtr->length = 0;
|
objPtr->typePtr = NULL;
|
objPtr->typePtr = NULL;
|
#ifdef TCL_COMPILE_STATS
|
#ifdef TCL_COMPILE_STATS
|
tclObjsAlloced++;
|
tclObjsAlloced++;
|
#endif /* TCL_COMPILE_STATS */
|
#endif /* TCL_COMPILE_STATS */
|
return objPtr;
|
return objPtr;
|
}
|
}
|
#endif /* TCL_MEM_DEBUG */
|
#endif /* TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DbNewObj --
|
* Tcl_DbNewObj --
|
*
|
*
|
* This procedure is normally called when debugging: i.e., when
|
* This procedure is normally called when debugging: i.e., when
|
* TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
|
* 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
|
* empty string. It is the same as the Tcl_NewObj procedure above
|
* except that it calls Tcl_DbCkalloc directly with the file name and
|
* except that it calls Tcl_DbCkalloc directly with the file name and
|
* line number from its caller. This simplifies debugging since then
|
* line number from its caller. This simplifies debugging since then
|
* the checkmem command will report the correct file name and line
|
* the checkmem command will report the correct file name and line
|
* number when reporting objects that haven't been freed.
|
* number when reporting objects that haven't been freed.
|
*
|
*
|
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
* result of calling Tcl_NewObj.
|
* result of calling Tcl_NewObj.
|
*
|
*
|
* Results:
|
* Results:
|
* The result is a newly allocated that represents the empty string.
|
* 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.
|
* The new object's typePtr is set NULL and its ref count is set to 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If compiling with TCL_COMPILE_STATS, this procedure increments
|
* If compiling with TCL_COMPILE_STATS, this procedure increments
|
* the global count of allocated objects (tclObjsAlloced).
|
* the global count of allocated objects (tclObjsAlloced).
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DbNewObj(file, line)
|
Tcl_DbNewObj(file, line)
|
register char *file; /* The name of the source file calling this
|
register char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
register int line; /* Line number in the source file; used
|
register int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
/*
|
/*
|
* If debugging Tcl's memory usage, allocate the object using ckalloc.
|
* If debugging Tcl's memory usage, allocate the object using ckalloc.
|
* Otherwise, allocate it using the list of free Tcl_Objs we maintain.
|
* Otherwise, allocate it using the list of free Tcl_Objs we maintain.
|
*/
|
*/
|
|
|
objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
|
objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
|
objPtr->refCount = 0;
|
objPtr->refCount = 0;
|
objPtr->bytes = tclEmptyStringRep;
|
objPtr->bytes = tclEmptyStringRep;
|
objPtr->length = 0;
|
objPtr->length = 0;
|
objPtr->typePtr = NULL;
|
objPtr->typePtr = NULL;
|
#ifdef TCL_COMPILE_STATS
|
#ifdef TCL_COMPILE_STATS
|
tclObjsAlloced++;
|
tclObjsAlloced++;
|
#endif /* TCL_COMPILE_STATS */
|
#endif /* TCL_COMPILE_STATS */
|
return objPtr;
|
return objPtr;
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DbNewObj(file, line)
|
Tcl_DbNewObj(file, line)
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
return Tcl_NewObj();
|
return Tcl_NewObj();
|
}
|
}
|
#endif /* TCL_MEM_DEBUG */
|
#endif /* TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclAllocateFreeObjects --
|
* TclAllocateFreeObjects --
|
*
|
*
|
* Procedure to allocate a number of free Tcl_Objs. This is done using
|
* Procedure to allocate a number of free Tcl_Objs. This is done using
|
* a single ckalloc to reduce the overhead for Tcl_Obj allocation.
|
* a single ckalloc to reduce the overhead for Tcl_Obj allocation.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
|
* 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
|
* first of a number of free Tcl_Obj's linked together by their
|
* internalRep.otherValuePtrs.
|
* internalRep.otherValuePtrs.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#define OBJS_TO_ALLOC_EACH_TIME 100
|
#define OBJS_TO_ALLOC_EACH_TIME 100
|
|
|
void
|
void
|
TclAllocateFreeObjects()
|
TclAllocateFreeObjects()
|
{
|
{
|
Tcl_Obj tmp[2];
|
Tcl_Obj tmp[2];
|
size_t objSizePlusPadding = /* NB: this assumes byte addressing. */
|
size_t objSizePlusPadding = /* NB: this assumes byte addressing. */
|
((int)(&(tmp[1])) - (int)(&(tmp[0])));
|
((int)(&(tmp[1])) - (int)(&(tmp[0])));
|
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
|
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
|
char *basePtr;
|
char *basePtr;
|
register Tcl_Obj *prevPtr, *objPtr;
|
register Tcl_Obj *prevPtr, *objPtr;
|
register int i;
|
register int i;
|
|
|
basePtr = (char *) ckalloc(bytesToAlloc);
|
basePtr = (char *) ckalloc(bytesToAlloc);
|
memset(basePtr, 0, bytesToAlloc);
|
memset(basePtr, 0, bytesToAlloc);
|
|
|
prevPtr = NULL;
|
prevPtr = NULL;
|
objPtr = (Tcl_Obj *) basePtr;
|
objPtr = (Tcl_Obj *) basePtr;
|
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
|
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
|
objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
|
objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
|
prevPtr = objPtr;
|
prevPtr = objPtr;
|
objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding);
|
objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding);
|
}
|
}
|
tclFreeObjList = prevPtr;
|
tclFreeObjList = prevPtr;
|
}
|
}
|
#undef OBJS_TO_ALLOC_EACH_TIME
|
#undef OBJS_TO_ALLOC_EACH_TIME
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclFreeObj --
|
* TclFreeObj --
|
*
|
*
|
* This procedure frees the memory associated with the argument
|
* This procedure frees the memory associated with the argument
|
* object. It is called by the tcl.h macro Tcl_DecrRefCount when an
|
* 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
|
* 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 callable by that macro wherever the macro is used. It should not
|
* be directly called by clients.
|
* be directly called by clients.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deallocates the storage for the object's Tcl_Obj structure
|
* Deallocates the storage for the object's Tcl_Obj structure
|
* after deallocating the string representation and calling the
|
* after deallocating the string representation and calling the
|
* type-specific Tcl_FreeInternalRepProc to deallocate the object's
|
* type-specific Tcl_FreeInternalRepProc to deallocate the object's
|
* internal representation. If compiling with TCL_COMPILE_STATS,
|
* internal representation. If compiling with TCL_COMPILE_STATS,
|
* this procedure increments the global count of freed objects
|
* this procedure increments the global count of freed objects
|
* (tclObjsFreed).
|
* (tclObjsFreed).
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
TclFreeObj(objPtr)
|
TclFreeObj(objPtr)
|
register Tcl_Obj *objPtr; /* The object to be freed. */
|
register Tcl_Obj *objPtr; /* The object to be freed. */
|
{
|
{
|
register Tcl_ObjType *typePtr = objPtr->typePtr;
|
register Tcl_ObjType *typePtr = objPtr->typePtr;
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
if ((objPtr)->refCount < -1) {
|
if ((objPtr)->refCount < -1) {
|
panic("Reference count for %lx was negative", objPtr);
|
panic("Reference count for %lx was negative", objPtr);
|
}
|
}
|
#endif /* TCL_MEM_DEBUG */
|
#endif /* TCL_MEM_DEBUG */
|
|
|
Tcl_InvalidateStringRep(objPtr);
|
Tcl_InvalidateStringRep(objPtr);
|
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
|
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
|
typePtr->freeIntRepProc(objPtr);
|
typePtr->freeIntRepProc(objPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* If debugging Tcl's memory usage, deallocate the object using ckfree.
|
* If debugging Tcl's memory usage, deallocate the object using ckfree.
|
* Otherwise, deallocate it by adding it onto the list of free
|
* Otherwise, deallocate it by adding it onto the list of free
|
* Tcl_Objs we maintain.
|
* Tcl_Objs we maintain.
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
ckfree((char *) objPtr);
|
ckfree((char *) objPtr);
|
#else
|
#else
|
objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
|
objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
|
tclFreeObjList = objPtr;
|
tclFreeObjList = objPtr;
|
#endif /* TCL_MEM_DEBUG */
|
#endif /* TCL_MEM_DEBUG */
|
|
|
#ifdef TCL_COMPILE_STATS
|
#ifdef TCL_COMPILE_STATS
|
tclObjsFreed++;
|
tclObjsFreed++;
|
#endif /* TCL_COMPILE_STATS */
|
#endif /* TCL_COMPILE_STATS */
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DuplicateObj --
|
* Tcl_DuplicateObj --
|
*
|
*
|
* Create and return a new object that is a duplicate of the argument
|
* Create and return a new object that is a duplicate of the argument
|
* object.
|
* object.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a pointer to a newly created Tcl_Obj. This
|
* 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
|
* object has reference count 0 and the same type, if any, as the
|
* source object objPtr. Also:
|
* source object objPtr. Also:
|
* 1) If the source object has a valid string rep, we copy it;
|
* 1) If the source object has a valid string rep, we copy it;
|
* otherwise, the duplicate's string rep is set NULL to mark
|
* otherwise, the duplicate's string rep is set NULL to mark
|
* it invalid.
|
* it invalid.
|
* 2) If the source object has an internal representation (i.e. its
|
* 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
|
* typePtr is non-NULL), the new object's internal rep is set to
|
* a copy; otherwise the new internal rep is marked invalid.
|
* a copy; otherwise the new internal rep is marked invalid.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* What constitutes "copying" the internal representation depends on
|
* What constitutes "copying" the internal representation depends on
|
* the type. For example, if the argument object is a list,
|
* the type. For example, if the argument object is a list,
|
* the element objects it points to will not actually be copied but
|
* 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
|
* will be shared with the duplicate list. That is, the ref counts of
|
* the element objects will be incremented.
|
* the element objects will be incremented.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DuplicateObj(objPtr)
|
Tcl_DuplicateObj(objPtr)
|
register Tcl_Obj *objPtr; /* The object to duplicate. */
|
register Tcl_Obj *objPtr; /* The object to duplicate. */
|
{
|
{
|
register Tcl_ObjType *typePtr = objPtr->typePtr;
|
register Tcl_ObjType *typePtr = objPtr->typePtr;
|
register Tcl_Obj *dupPtr;
|
register Tcl_Obj *dupPtr;
|
|
|
TclNewObj(dupPtr);
|
TclNewObj(dupPtr);
|
|
|
if (objPtr->bytes == NULL) {
|
if (objPtr->bytes == NULL) {
|
dupPtr->bytes = NULL;
|
dupPtr->bytes = NULL;
|
} else if (objPtr->bytes != tclEmptyStringRep) {
|
} else if (objPtr->bytes != tclEmptyStringRep) {
|
int len = objPtr->length;
|
int len = objPtr->length;
|
|
|
dupPtr->bytes = (char *) ckalloc((unsigned) len+1);
|
dupPtr->bytes = (char *) ckalloc((unsigned) len+1);
|
if (len > 0) {
|
if (len > 0) {
|
memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes,
|
memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes,
|
(unsigned) len);
|
(unsigned) len);
|
}
|
}
|
dupPtr->bytes[len] = '\0';
|
dupPtr->bytes[len] = '\0';
|
dupPtr->length = len;
|
dupPtr->length = len;
|
}
|
}
|
|
|
if (typePtr != NULL) {
|
if (typePtr != NULL) {
|
typePtr->dupIntRepProc(objPtr, dupPtr);
|
typePtr->dupIntRepProc(objPtr, dupPtr);
|
}
|
}
|
return dupPtr;
|
return dupPtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetStringFromObj --
|
* Tcl_GetStringFromObj --
|
*
|
*
|
* Returns the string representation's byte array pointer and length
|
* Returns the string representation's byte array pointer and length
|
* for an object.
|
* for an object.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns a pointer to the string representation of objPtr. If
|
* Returns a pointer to the string representation of objPtr. If
|
* lengthPtr isn't NULL, the length of the string representation is
|
* lengthPtr isn't NULL, the length of the string representation is
|
* stored at *lengthPtr. The byte array referenced by the returned
|
* stored at *lengthPtr. The byte array referenced by the returned
|
* pointer must not be modified by the caller. Furthermore, the
|
* pointer must not be modified by the caller. Furthermore, the
|
* caller must copy the bytes if they need to retain them since 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.
|
* object's string rep can change as a result of other operations.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* May call the object's updateStringProc to update the string
|
* May call the object's updateStringProc to update the string
|
* representation from the internal representation.
|
* representation from the internal representation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
char *
|
char *
|
Tcl_GetStringFromObj(objPtr, lengthPtr)
|
Tcl_GetStringFromObj(objPtr, lengthPtr)
|
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
|
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
|
* should be returned. */
|
* should be returned. */
|
register int *lengthPtr; /* If non-NULL, the location where the
|
register int *lengthPtr; /* If non-NULL, the location where the
|
* string rep's byte array length should be
|
* string rep's byte array length should be
|
* stored. If NULL, no length is stored. */
|
* stored. If NULL, no length is stored. */
|
{
|
{
|
if (objPtr->bytes != NULL) {
|
if (objPtr->bytes != NULL) {
|
if (lengthPtr != NULL) {
|
if (lengthPtr != NULL) {
|
*lengthPtr = objPtr->length;
|
*lengthPtr = objPtr->length;
|
}
|
}
|
return objPtr->bytes;
|
return objPtr->bytes;
|
}
|
}
|
|
|
objPtr->typePtr->updateStringProc(objPtr);
|
objPtr->typePtr->updateStringProc(objPtr);
|
if (lengthPtr != NULL) {
|
if (lengthPtr != NULL) {
|
*lengthPtr = objPtr->length;
|
*lengthPtr = objPtr->length;
|
}
|
}
|
return objPtr->bytes;
|
return objPtr->bytes;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_InvalidateStringRep --
|
* Tcl_InvalidateStringRep --
|
*
|
*
|
* This procedure is called to invalidate an object's string
|
* This procedure is called to invalidate an object's string
|
* representation.
|
* representation.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deallocates the storage for any old string representation, then
|
* Deallocates the storage for any old string representation, then
|
* sets the string representation NULL to mark it invalid.
|
* sets the string representation NULL to mark it invalid.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_InvalidateStringRep(objPtr)
|
Tcl_InvalidateStringRep(objPtr)
|
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
|
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
|
* should be freed. */
|
* should be freed. */
|
{
|
{
|
if (objPtr->bytes != NULL) {
|
if (objPtr->bytes != NULL) {
|
if (objPtr->bytes != tclEmptyStringRep) {
|
if (objPtr->bytes != tclEmptyStringRep) {
|
ckfree((char *) objPtr->bytes);
|
ckfree((char *) objPtr->bytes);
|
}
|
}
|
objPtr->bytes = NULL;
|
objPtr->bytes = NULL;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_NewBooleanObj --
|
* Tcl_NewBooleanObj --
|
*
|
*
|
* This procedure is normally called when not debugging: i.e., when
|
* This procedure is normally called when not debugging: i.e., when
|
* TCL_MEM_DEBUG is not defined. It creates a new boolean object and
|
* TCL_MEM_DEBUG is not defined. It creates a new boolean object and
|
* initializes it from the argument boolean value. A nonzero
|
* initializes it from the argument boolean value. A nonzero
|
* "boolValue" is coerced to 1.
|
* "boolValue" is coerced to 1.
|
*
|
*
|
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
* result of calling the debugging version Tcl_DbNewBooleanObj.
|
* result of calling the debugging version Tcl_DbNewBooleanObj.
|
*
|
*
|
* Results:
|
* Results:
|
* The newly created object is returned. This object will have an
|
* The newly created object is returned. This object will have an
|
* invalid string representation. The returned object has ref count 0.
|
* invalid string representation. The returned object has ref count 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
#undef Tcl_NewBooleanObj
|
#undef Tcl_NewBooleanObj
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewBooleanObj(boolValue)
|
Tcl_NewBooleanObj(boolValue)
|
register int boolValue; /* Boolean used to initialize new object. */
|
register int boolValue; /* Boolean used to initialize new object. */
|
{
|
{
|
return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
|
return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewBooleanObj(boolValue)
|
Tcl_NewBooleanObj(boolValue)
|
register int boolValue; /* Boolean used to initialize new object. */
|
register int boolValue; /* Boolean used to initialize new object. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
TclNewObj(objPtr);
|
TclNewObj(objPtr);
|
objPtr->bytes = NULL;
|
objPtr->bytes = NULL;
|
|
|
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
objPtr->typePtr = &tclBooleanType;
|
objPtr->typePtr = &tclBooleanType;
|
return objPtr;
|
return objPtr;
|
}
|
}
|
#endif /* TCL_MEM_DEBUG */
|
#endif /* TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DbNewBooleanObj --
|
* Tcl_DbNewBooleanObj --
|
*
|
*
|
* This procedure is normally called when debugging: i.e., when
|
* This procedure is normally called when debugging: i.e., when
|
* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
|
* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
|
* same as the Tcl_NewBooleanObj procedure above except that it calls
|
* same as the Tcl_NewBooleanObj procedure above except that it calls
|
* Tcl_DbCkalloc directly with the file name and line number from its
|
* Tcl_DbCkalloc directly with the file name and line number from its
|
* caller. This simplifies debugging since then the checkmem command
|
* caller. This simplifies debugging since then the checkmem command
|
* will report the correct file name and line number when reporting
|
* will report the correct file name and line number when reporting
|
* objects that haven't been freed.
|
* objects that haven't been freed.
|
*
|
*
|
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
* result of calling Tcl_NewBooleanObj.
|
* result of calling Tcl_NewBooleanObj.
|
*
|
*
|
* Results:
|
* Results:
|
* The newly created object is returned. This object will have an
|
* The newly created object is returned. This object will have an
|
* invalid string representation. The returned object has ref count 0.
|
* invalid string representation. The returned object has ref count 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DbNewBooleanObj(boolValue, file, line)
|
Tcl_DbNewBooleanObj(boolValue, file, line)
|
register int boolValue; /* Boolean used to initialize new object. */
|
register int boolValue; /* Boolean used to initialize new object. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
TclDbNewObj(objPtr, file, line);
|
TclDbNewObj(objPtr, file, line);
|
objPtr->bytes = NULL;
|
objPtr->bytes = NULL;
|
|
|
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
objPtr->typePtr = &tclBooleanType;
|
objPtr->typePtr = &tclBooleanType;
|
return objPtr;
|
return objPtr;
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DbNewBooleanObj(boolValue, file, line)
|
Tcl_DbNewBooleanObj(boolValue, file, line)
|
register int boolValue; /* Boolean used to initialize new object. */
|
register int boolValue; /* Boolean used to initialize new object. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
return Tcl_NewBooleanObj(boolValue);
|
return Tcl_NewBooleanObj(boolValue);
|
}
|
}
|
#endif /* TCL_MEM_DEBUG */
|
#endif /* TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetBooleanObj --
|
* Tcl_SetBooleanObj --
|
*
|
*
|
* Modify an object to be a boolean object and to have the specified
|
* Modify an object to be a boolean object and to have the specified
|
* boolean value. A nonzero "boolValue" is coerced to 1.
|
* boolean value. A nonzero "boolValue" is coerced to 1.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's old string rep, if any, is freed. Also, any old
|
* The object's old string rep, if any, is freed. Also, any old
|
* internal rep is freed.
|
* internal rep is freed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetBooleanObj(objPtr, boolValue)
|
Tcl_SetBooleanObj(objPtr, boolValue)
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
register int boolValue; /* Boolean used to set object's value. */
|
register int boolValue; /* Boolean used to set object's value. */
|
{
|
{
|
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
|
|
if (Tcl_IsShared(objPtr)) {
|
if (Tcl_IsShared(objPtr)) {
|
panic("Tcl_SetBooleanObj called with shared object");
|
panic("Tcl_SetBooleanObj called with shared object");
|
}
|
}
|
|
|
Tcl_InvalidateStringRep(objPtr);
|
Tcl_InvalidateStringRep(objPtr);
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
oldTypePtr->freeIntRepProc(objPtr);
|
oldTypePtr->freeIntRepProc(objPtr);
|
}
|
}
|
|
|
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
objPtr->typePtr = &tclBooleanType;
|
objPtr->typePtr = &tclBooleanType;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetBooleanFromObj --
|
* Tcl_GetBooleanFromObj --
|
*
|
*
|
* Attempt to return a boolean from the Tcl object "objPtr". If the
|
* Attempt to return a boolean from the Tcl object "objPtr". If the
|
* object is not already a boolean, an attempt will be made to convert
|
* object is not already a boolean, an attempt will be made to convert
|
* it to one.
|
* it to one.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a standard Tcl object result. If an error occurs
|
* The return value is a standard Tcl object result. If an error occurs
|
* during conversion, an error message is left in the interpreter's
|
* during conversion, an error message is left in the interpreter's
|
* result unless "interp" is NULL.
|
* result unless "interp" is NULL.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If the object is not already a boolean, the conversion will free
|
* If the object is not already a boolean, the conversion will free
|
* any old internal representation.
|
* any old internal representation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
|
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
|
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
|
register int *boolPtr; /* Place to store resulting boolean. */
|
register int *boolPtr; /* Place to store resulting boolean. */
|
{
|
{
|
register int result;
|
register int result;
|
|
|
result = SetBooleanFromAny(interp, objPtr);
|
result = SetBooleanFromAny(interp, objPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
*boolPtr = (int) objPtr->internalRep.longValue;
|
*boolPtr = (int) objPtr->internalRep.longValue;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DupBooleanInternalRep --
|
* DupBooleanInternalRep --
|
*
|
*
|
* Initialize the internal representation of a boolean Tcl_Obj to a
|
* Initialize the internal representation of a boolean Tcl_Obj to a
|
* copy of the internal representation of an existing boolean object.
|
* copy of the internal representation of an existing boolean object.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* "copyPtr"s internal rep is set to the boolean (an integer)
|
* "copyPtr"s internal rep is set to the boolean (an integer)
|
* corresponding to "srcPtr"s internal rep.
|
* corresponding to "srcPtr"s internal rep.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
DupBooleanInternalRep(srcPtr, copyPtr)
|
DupBooleanInternalRep(srcPtr, copyPtr)
|
register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
|
register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
|
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
|
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
|
{
|
{
|
copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
|
copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
|
copyPtr->typePtr = &tclBooleanType;
|
copyPtr->typePtr = &tclBooleanType;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SetBooleanFromAny --
|
* SetBooleanFromAny --
|
*
|
*
|
* Attempt to generate a boolean internal form for the Tcl object
|
* Attempt to generate a boolean internal form for the Tcl object
|
* "objPtr".
|
* "objPtr".
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a standard Tcl result. If an error occurs during
|
* The return value is a standard Tcl result. If an error occurs during
|
* conversion, an error message is left in the interpreter's result
|
* conversion, an error message is left in the interpreter's result
|
* unless "interp" is NULL.
|
* unless "interp" is NULL.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s
|
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s
|
* internal representation and the type of "objPtr" is set to boolean.
|
* internal representation and the type of "objPtr" is set to boolean.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SetBooleanFromAny(interp, objPtr)
|
SetBooleanFromAny(interp, objPtr)
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
register Tcl_Obj *objPtr; /* The object to convert. */
|
register Tcl_Obj *objPtr; /* The object to convert. */
|
{
|
{
|
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
char *string, *end;
|
char *string, *end;
|
register char c;
|
register char c;
|
char lowerCase[10];
|
char lowerCase[10];
|
int newBool, length;
|
int newBool, length;
|
register int i;
|
register int i;
|
double dbl;
|
double dbl;
|
|
|
/*
|
/*
|
* Get the string representation. Make it up-to-date if necessary.
|
* Get the string representation. Make it up-to-date if necessary.
|
*/
|
*/
|
|
|
string = TclGetStringFromObj(objPtr, &length);
|
string = TclGetStringFromObj(objPtr, &length);
|
|
|
/*
|
/*
|
* Copy the string converting its characters to lower case.
|
* Copy the string converting its characters to lower case.
|
*/
|
*/
|
|
|
for (i = 0; (i < 9) && (i < length); i++) {
|
for (i = 0; (i < 9) && (i < length); i++) {
|
c = string[i];
|
c = string[i];
|
if (isupper(UCHAR(c))) {
|
if (isupper(UCHAR(c))) {
|
c = (char) tolower(UCHAR(c));
|
c = (char) tolower(UCHAR(c));
|
}
|
}
|
lowerCase[i] = c;
|
lowerCase[i] = c;
|
}
|
}
|
lowerCase[i] = 0;
|
lowerCase[i] = 0;
|
|
|
/*
|
/*
|
* Parse the string as a boolean. We use an implementation here that
|
* Parse the string as a boolean. We use an implementation here that
|
* doesn't report errors in interp if interp is NULL.
|
* doesn't report errors in interp if interp is NULL.
|
*/
|
*/
|
|
|
c = lowerCase[0];
|
c = lowerCase[0];
|
if ((c == '0') && (lowerCase[1] == '\0')) {
|
if ((c == '0') && (lowerCase[1] == '\0')) {
|
newBool = 0;
|
newBool = 0;
|
} else if ((c == '1') && (lowerCase[1] == '\0')) {
|
} else if ((c == '1') && (lowerCase[1] == '\0')) {
|
newBool = 1;
|
newBool = 1;
|
} else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
|
} else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
|
newBool = 1;
|
newBool = 1;
|
} else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
|
} else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
|
newBool = 0;
|
newBool = 0;
|
} else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
|
} else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
|
newBool = 1;
|
newBool = 1;
|
} else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
|
} else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
|
newBool = 0;
|
newBool = 0;
|
} else if ((c == 'o') && (length >= 2)) {
|
} else if ((c == 'o') && (length >= 2)) {
|
if (strncmp(lowerCase, "on", (size_t) length) == 0) {
|
if (strncmp(lowerCase, "on", (size_t) length) == 0) {
|
newBool = 1;
|
newBool = 1;
|
} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
|
} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
|
newBool = 0;
|
newBool = 0;
|
} else {
|
} else {
|
goto badBoolean;
|
goto badBoolean;
|
}
|
}
|
} else {
|
} else {
|
/*
|
/*
|
* Still might be a string containing the characters representing an
|
* Still might be a string containing the characters representing an
|
* int or double that wasn't handled above. This would be a string
|
* int or double that wasn't handled above. This would be a string
|
* like "27" or "1.0" that is non-zero and not "1". Such a string
|
* like "27" or "1.0" that is non-zero and not "1". Such a string
|
* whould result in the boolean value true. We try converting to
|
* whould result in the boolean value true. We try converting to
|
* double. If that succeeds and the resulting double is non-zero, we
|
* double. If that succeeds and the resulting double is non-zero, we
|
* have a "true". Note that numbers can't have embedded NULLs.
|
* have a "true". Note that numbers can't have embedded NULLs.
|
*/
|
*/
|
|
|
dbl = strtod(string, &end);
|
dbl = strtod(string, &end);
|
if (end == string) {
|
if (end == string) {
|
goto badBoolean;
|
goto badBoolean;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure the string has no garbage after the end of the double.
|
* Make sure the string has no garbage after the end of the double.
|
*/
|
*/
|
|
|
while ((end < (string+length)) && isspace(UCHAR(*end))) {
|
while ((end < (string+length)) && isspace(UCHAR(*end))) {
|
end++;
|
end++;
|
}
|
}
|
if (end != (string+length)) {
|
if (end != (string+length)) {
|
goto badBoolean;
|
goto badBoolean;
|
}
|
}
|
newBool = (dbl != 0.0);
|
newBool = (dbl != 0.0);
|
}
|
}
|
|
|
/*
|
/*
|
* Free the old internalRep before setting the new one. We do this as
|
* Free the old internalRep before setting the new one. We do this as
|
* late as possible to allow the conversion code, in particular
|
* late as possible to allow the conversion code, in particular
|
* Tcl_GetStringFromObj, to use that old internalRep.
|
* Tcl_GetStringFromObj, to use that old internalRep.
|
*/
|
*/
|
|
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
oldTypePtr->freeIntRepProc(objPtr);
|
oldTypePtr->freeIntRepProc(objPtr);
|
}
|
}
|
|
|
objPtr->internalRep.longValue = newBool;
|
objPtr->internalRep.longValue = newBool;
|
objPtr->typePtr = &tclBooleanType;
|
objPtr->typePtr = &tclBooleanType;
|
return TCL_OK;
|
return TCL_OK;
|
|
|
badBoolean:
|
badBoolean:
|
if (interp != NULL) {
|
if (interp != NULL) {
|
/*
|
/*
|
* Must copy string before resetting the result in case a caller
|
* Must copy string before resetting the result in case a caller
|
* is trying to convert the interpreter's result to a boolean.
|
* is trying to convert the interpreter's result to a boolean.
|
*/
|
*/
|
|
|
char buf[100];
|
char buf[100];
|
sprintf(buf, "expected boolean value but got \"%.50s\"", string);
|
sprintf(buf, "expected boolean value but got \"%.50s\"", string);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* UpdateStringOfBoolean --
|
* UpdateStringOfBoolean --
|
*
|
*
|
* Update the string representation for a boolean object.
|
* Update the string representation for a boolean object.
|
* Note: This procedure does not free an existing old string rep
|
* Note: This procedure does not free an existing old string rep
|
* so storage will be lost if this has not already been done.
|
* so storage will be lost if this has not already been done.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's string is set to a valid string that results from
|
* The object's string is set to a valid string that results from
|
* the boolean-to-string conversion.
|
* the boolean-to-string conversion.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
UpdateStringOfBoolean(objPtr)
|
UpdateStringOfBoolean(objPtr)
|
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
|
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
|
{
|
{
|
char *s = ckalloc((unsigned) 2);
|
char *s = ckalloc((unsigned) 2);
|
|
|
s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
|
s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
|
s[1] = '\0';
|
s[1] = '\0';
|
objPtr->bytes = s;
|
objPtr->bytes = s;
|
objPtr->length = 1;
|
objPtr->length = 1;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_NewDoubleObj --
|
* Tcl_NewDoubleObj --
|
*
|
*
|
* This procedure is normally called when not debugging: i.e., when
|
* This procedure is normally called when not debugging: i.e., when
|
* TCL_MEM_DEBUG is not defined. It creates a new double object and
|
* TCL_MEM_DEBUG is not defined. It creates a new double object and
|
* initializes it from the argument double value.
|
* initializes it from the argument double value.
|
*
|
*
|
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
* result of calling the debugging version Tcl_DbNewDoubleObj.
|
* result of calling the debugging version Tcl_DbNewDoubleObj.
|
*
|
*
|
* Results:
|
* Results:
|
* The newly created object is returned. This object will have an
|
* The newly created object is returned. This object will have an
|
* invalid string representation. The returned object has ref count 0.
|
* invalid string representation. The returned object has ref count 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
#undef Tcl_NewDoubleObj
|
#undef Tcl_NewDoubleObj
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewDoubleObj(dblValue)
|
Tcl_NewDoubleObj(dblValue)
|
register double dblValue; /* Double used to initialize the object. */
|
register double dblValue; /* Double used to initialize the object. */
|
{
|
{
|
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
|
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewDoubleObj(dblValue)
|
Tcl_NewDoubleObj(dblValue)
|
register double dblValue; /* Double used to initialize the object. */
|
register double dblValue; /* Double used to initialize the object. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
TclNewObj(objPtr);
|
TclNewObj(objPtr);
|
objPtr->bytes = NULL;
|
objPtr->bytes = NULL;
|
|
|
objPtr->internalRep.doubleValue = dblValue;
|
objPtr->internalRep.doubleValue = dblValue;
|
objPtr->typePtr = &tclDoubleType;
|
objPtr->typePtr = &tclDoubleType;
|
return objPtr;
|
return objPtr;
|
}
|
}
|
#endif /* if TCL_MEM_DEBUG */
|
#endif /* if TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DbNewDoubleObj --
|
* Tcl_DbNewDoubleObj --
|
*
|
*
|
* This procedure is normally called when debugging: i.e., when
|
* This procedure is normally called when debugging: i.e., when
|
* TCL_MEM_DEBUG is defined. It creates new double objects. It is the
|
* TCL_MEM_DEBUG is defined. It creates new double objects. It is the
|
* same as the Tcl_NewDoubleObj procedure above except that it calls
|
* same as the Tcl_NewDoubleObj procedure above except that it calls
|
* Tcl_DbCkalloc directly with the file name and line number from its
|
* Tcl_DbCkalloc directly with the file name and line number from its
|
* caller. This simplifies debugging since then the checkmem command
|
* caller. This simplifies debugging since then the checkmem command
|
* will report the correct file name and line number when reporting
|
* will report the correct file name and line number when reporting
|
* objects that haven't been freed.
|
* objects that haven't been freed.
|
*
|
*
|
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
* result of calling Tcl_NewDoubleObj.
|
* result of calling Tcl_NewDoubleObj.
|
*
|
*
|
* Results:
|
* Results:
|
* The newly created object is returned. This object will have an
|
* The newly created object is returned. This object will have an
|
* invalid string representation. The returned object has ref count 0.
|
* invalid string representation. The returned object has ref count 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DbNewDoubleObj(dblValue, file, line)
|
Tcl_DbNewDoubleObj(dblValue, file, line)
|
register double dblValue; /* Double used to initialize the object. */
|
register double dblValue; /* Double used to initialize the object. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
TclDbNewObj(objPtr, file, line);
|
TclDbNewObj(objPtr, file, line);
|
objPtr->bytes = NULL;
|
objPtr->bytes = NULL;
|
|
|
objPtr->internalRep.doubleValue = dblValue;
|
objPtr->internalRep.doubleValue = dblValue;
|
objPtr->typePtr = &tclDoubleType;
|
objPtr->typePtr = &tclDoubleType;
|
return objPtr;
|
return objPtr;
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DbNewDoubleObj(dblValue, file, line)
|
Tcl_DbNewDoubleObj(dblValue, file, line)
|
register double dblValue; /* Double used to initialize the object. */
|
register double dblValue; /* Double used to initialize the object. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
return Tcl_NewDoubleObj(dblValue);
|
return Tcl_NewDoubleObj(dblValue);
|
}
|
}
|
#endif /* TCL_MEM_DEBUG */
|
#endif /* TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetDoubleObj --
|
* Tcl_SetDoubleObj --
|
*
|
*
|
* Modify an object to be a double object and to have the specified
|
* Modify an object to be a double object and to have the specified
|
* double value.
|
* double value.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's old string rep, if any, is freed. Also, any old
|
* The object's old string rep, if any, is freed. Also, any old
|
* internal rep is freed.
|
* internal rep is freed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetDoubleObj(objPtr, dblValue)
|
Tcl_SetDoubleObj(objPtr, dblValue)
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
register double dblValue; /* Double used to set the object's value. */
|
register double dblValue; /* Double used to set the object's value. */
|
{
|
{
|
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
|
|
if (Tcl_IsShared(objPtr)) {
|
if (Tcl_IsShared(objPtr)) {
|
panic("Tcl_SetDoubleObj called with shared object");
|
panic("Tcl_SetDoubleObj called with shared object");
|
}
|
}
|
|
|
Tcl_InvalidateStringRep(objPtr);
|
Tcl_InvalidateStringRep(objPtr);
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
oldTypePtr->freeIntRepProc(objPtr);
|
oldTypePtr->freeIntRepProc(objPtr);
|
}
|
}
|
|
|
objPtr->internalRep.doubleValue = dblValue;
|
objPtr->internalRep.doubleValue = dblValue;
|
objPtr->typePtr = &tclDoubleType;
|
objPtr->typePtr = &tclDoubleType;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetDoubleFromObj --
|
* Tcl_GetDoubleFromObj --
|
*
|
*
|
* Attempt to return a double from the Tcl object "objPtr". If the
|
* Attempt to return a double from the Tcl object "objPtr". If the
|
* object is not already a double, an attempt will be made to convert
|
* object is not already a double, an attempt will be made to convert
|
* it to one.
|
* it to one.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a standard Tcl object result. If an error occurs
|
* The return value is a standard Tcl object result. If an error occurs
|
* during conversion, an error message is left in the interpreter's
|
* during conversion, an error message is left in the interpreter's
|
* result unless "interp" is NULL.
|
* result unless "interp" is NULL.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If the object is not already a double, the conversion will free
|
* If the object is not already a double, the conversion will free
|
* any old internal representation.
|
* any old internal representation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
|
Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
register Tcl_Obj *objPtr; /* The object from which to get a double. */
|
register Tcl_Obj *objPtr; /* The object from which to get a double. */
|
register double *dblPtr; /* Place to store resulting double. */
|
register double *dblPtr; /* Place to store resulting double. */
|
{
|
{
|
register int result;
|
register int result;
|
|
|
if (objPtr->typePtr == &tclDoubleType) {
|
if (objPtr->typePtr == &tclDoubleType) {
|
*dblPtr = objPtr->internalRep.doubleValue;
|
*dblPtr = objPtr->internalRep.doubleValue;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
result = SetDoubleFromAny(interp, objPtr);
|
result = SetDoubleFromAny(interp, objPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
*dblPtr = objPtr->internalRep.doubleValue;
|
*dblPtr = objPtr->internalRep.doubleValue;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DupDoubleInternalRep --
|
* DupDoubleInternalRep --
|
*
|
*
|
* Initialize the internal representation of a double Tcl_Obj to a
|
* Initialize the internal representation of a double Tcl_Obj to a
|
* copy of the internal representation of an existing double object.
|
* copy of the internal representation of an existing double object.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* "copyPtr"s internal rep is set to the double precision floating
|
* "copyPtr"s internal rep is set to the double precision floating
|
* point number corresponding to "srcPtr"s internal rep.
|
* point number corresponding to "srcPtr"s internal rep.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
DupDoubleInternalRep(srcPtr, copyPtr)
|
DupDoubleInternalRep(srcPtr, copyPtr)
|
register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
|
register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
|
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
|
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
|
{
|
{
|
copyPtr->internalRep.doubleValue = srcPtr->internalRep.doubleValue;
|
copyPtr->internalRep.doubleValue = srcPtr->internalRep.doubleValue;
|
copyPtr->typePtr = &tclDoubleType;
|
copyPtr->typePtr = &tclDoubleType;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SetDoubleFromAny --
|
* SetDoubleFromAny --
|
*
|
*
|
* Attempt to generate an double-precision floating point internal form
|
* Attempt to generate an double-precision floating point internal form
|
* for the Tcl object "objPtr".
|
* for the Tcl object "objPtr".
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a standard Tcl object result. If an error occurs
|
* The return value is a standard Tcl object result. If an error occurs
|
* during conversion, an error message is left in the interpreter's
|
* during conversion, an error message is left in the interpreter's
|
* result unless "interp" is NULL.
|
* result unless "interp" is NULL.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If no error occurs, a double is stored as "objPtr"s internal
|
* If no error occurs, a double is stored as "objPtr"s internal
|
* representation.
|
* representation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SetDoubleFromAny(interp, objPtr)
|
SetDoubleFromAny(interp, objPtr)
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
register Tcl_Obj *objPtr; /* The object to convert. */
|
register Tcl_Obj *objPtr; /* The object to convert. */
|
{
|
{
|
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
char *string, *end;
|
char *string, *end;
|
double newDouble;
|
double newDouble;
|
int length;
|
int length;
|
|
|
/*
|
/*
|
* Get the string representation. Make it up-to-date if necessary.
|
* Get the string representation. Make it up-to-date if necessary.
|
*/
|
*/
|
|
|
string = TclGetStringFromObj(objPtr, &length);
|
string = TclGetStringFromObj(objPtr, &length);
|
|
|
/*
|
/*
|
* Now parse "objPtr"s string as an double. Numbers can't have embedded
|
* Now parse "objPtr"s string as an double. Numbers can't have embedded
|
* NULLs. We use an implementation here that doesn't report errors in
|
* NULLs. We use an implementation here that doesn't report errors in
|
* interp if interp is NULL.
|
* interp if interp is NULL.
|
*/
|
*/
|
|
|
errno = 0;
|
errno = 0;
|
newDouble = strtod(string, &end);
|
newDouble = strtod(string, &end);
|
if (end == string) {
|
if (end == string) {
|
badDouble:
|
badDouble:
|
if (interp != NULL) {
|
if (interp != NULL) {
|
/*
|
/*
|
* Must copy string before resetting the result in case a caller
|
* Must copy string before resetting the result in case a caller
|
* is trying to convert the interpreter's result to an int.
|
* is trying to convert the interpreter's result to an int.
|
*/
|
*/
|
|
|
char buf[100];
|
char buf[100];
|
sprintf(buf, "expected floating-point number but got \"%.50s\"",
|
sprintf(buf, "expected floating-point number but got \"%.50s\"",
|
string);
|
string);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (errno != 0) {
|
if (errno != 0) {
|
if (interp != NULL) {
|
if (interp != NULL) {
|
TclExprFloatError(interp, newDouble);
|
TclExprFloatError(interp, newDouble);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the string has no garbage after the end of the double.
|
* Make sure that the string has no garbage after the end of the double.
|
*/
|
*/
|
|
|
while ((end < (string+length)) && isspace(UCHAR(*end))) {
|
while ((end < (string+length)) && isspace(UCHAR(*end))) {
|
end++;
|
end++;
|
}
|
}
|
if (end != (string+length)) {
|
if (end != (string+length)) {
|
goto badDouble;
|
goto badDouble;
|
}
|
}
|
|
|
/*
|
/*
|
* The conversion to double succeeded. Free the old internalRep before
|
* The conversion to double succeeded. Free the old internalRep before
|
* setting the new one. We do this as late as possible to allow the
|
* setting the new one. We do this as late as possible to allow the
|
* conversion code, in particular Tcl_GetStringFromObj, to use that old
|
* conversion code, in particular Tcl_GetStringFromObj, to use that old
|
* internalRep.
|
* internalRep.
|
*/
|
*/
|
|
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
oldTypePtr->freeIntRepProc(objPtr);
|
oldTypePtr->freeIntRepProc(objPtr);
|
}
|
}
|
|
|
objPtr->internalRep.doubleValue = newDouble;
|
objPtr->internalRep.doubleValue = newDouble;
|
objPtr->typePtr = &tclDoubleType;
|
objPtr->typePtr = &tclDoubleType;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* UpdateStringOfDouble --
|
* UpdateStringOfDouble --
|
*
|
*
|
* Update the string representation for a double-precision floating
|
* Update the string representation for a double-precision floating
|
* point object. This must obey the current tcl_precision value for
|
* point object. This must obey the current tcl_precision value for
|
* double-to-string conversions. Note: This procedure does not free an
|
* double-to-string conversions. Note: This procedure does not free an
|
* existing old string rep so storage will be lost if this has not
|
* existing old string rep so storage will be lost if this has not
|
* already been done.
|
* already been done.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's string is set to a valid string that results from
|
* The object's string is set to a valid string that results from
|
* the double-to-string conversion.
|
* the double-to-string conversion.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
UpdateStringOfDouble(objPtr)
|
UpdateStringOfDouble(objPtr)
|
register Tcl_Obj *objPtr; /* Double obj with string rep to update. */
|
register Tcl_Obj *objPtr; /* Double obj with string rep to update. */
|
{
|
{
|
char buffer[TCL_DOUBLE_SPACE];
|
char buffer[TCL_DOUBLE_SPACE];
|
register int len;
|
register int len;
|
|
|
Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
|
Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
|
buffer);
|
buffer);
|
len = strlen(buffer);
|
len = strlen(buffer);
|
|
|
objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
|
objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
|
strcpy(objPtr->bytes, buffer);
|
strcpy(objPtr->bytes, buffer);
|
objPtr->length = len;
|
objPtr->length = len;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_NewIntObj --
|
* Tcl_NewIntObj --
|
*
|
*
|
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
* Tcl_NewIntObj to create a new integer object end up calling the
|
* Tcl_NewIntObj to create a new integer object end up calling the
|
* debugging procedure Tcl_DbNewLongObj instead.
|
* debugging procedure Tcl_DbNewLongObj instead.
|
*
|
*
|
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
|
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
|
* calls to Tcl_NewIntObj result in a call to one of the two
|
* calls to Tcl_NewIntObj result in a call to one of the two
|
* Tcl_NewIntObj implementations below. We provide two implementations
|
* Tcl_NewIntObj implementations below. We provide two implementations
|
* so that the Tcl core can be compiled to do memory debugging of the
|
* 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.
|
* core even if a client does not request it for itself.
|
*
|
*
|
* Integer and long integer objects share the same "integer" type
|
* Integer and long integer objects share the same "integer" type
|
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
* checks whether the current value of the long can be represented by
|
* checks whether the current value of the long can be represented by
|
* an int.
|
* an int.
|
*
|
*
|
* Results:
|
* Results:
|
* The newly created object is returned. This object will have an
|
* The newly created object is returned. This object will have an
|
* invalid string representation. The returned object has ref count 0.
|
* invalid string representation. The returned object has ref count 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
#undef Tcl_NewIntObj
|
#undef Tcl_NewIntObj
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewIntObj(intValue)
|
Tcl_NewIntObj(intValue)
|
register int intValue; /* Int used to initialize the new object. */
|
register int intValue; /* Int used to initialize the new object. */
|
{
|
{
|
return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
|
return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewIntObj(intValue)
|
Tcl_NewIntObj(intValue)
|
register int intValue; /* Int used to initialize the new object. */
|
register int intValue; /* Int used to initialize the new object. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
TclNewObj(objPtr);
|
TclNewObj(objPtr);
|
objPtr->bytes = NULL;
|
objPtr->bytes = NULL;
|
|
|
objPtr->internalRep.longValue = (long)intValue;
|
objPtr->internalRep.longValue = (long)intValue;
|
objPtr->typePtr = &tclIntType;
|
objPtr->typePtr = &tclIntType;
|
return objPtr;
|
return objPtr;
|
}
|
}
|
#endif /* if TCL_MEM_DEBUG */
|
#endif /* if TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetIntObj --
|
* Tcl_SetIntObj --
|
*
|
*
|
* Modify an object to be an integer and to have the specified integer
|
* Modify an object to be an integer and to have the specified integer
|
* value.
|
* value.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's old string rep, if any, is freed. Also, any old
|
* The object's old string rep, if any, is freed. Also, any old
|
* internal rep is freed.
|
* internal rep is freed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetIntObj(objPtr, intValue)
|
Tcl_SetIntObj(objPtr, intValue)
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
register int intValue; /* Integer used to set object's value. */
|
register int intValue; /* Integer used to set object's value. */
|
{
|
{
|
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
|
|
if (Tcl_IsShared(objPtr)) {
|
if (Tcl_IsShared(objPtr)) {
|
panic("Tcl_SetIntObj called with shared object");
|
panic("Tcl_SetIntObj called with shared object");
|
}
|
}
|
|
|
Tcl_InvalidateStringRep(objPtr);
|
Tcl_InvalidateStringRep(objPtr);
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
oldTypePtr->freeIntRepProc(objPtr);
|
oldTypePtr->freeIntRepProc(objPtr);
|
}
|
}
|
|
|
objPtr->internalRep.longValue = (long) intValue;
|
objPtr->internalRep.longValue = (long) intValue;
|
objPtr->typePtr = &tclIntType;
|
objPtr->typePtr = &tclIntType;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetIntFromObj --
|
* Tcl_GetIntFromObj --
|
*
|
*
|
* Attempt to return an int from the Tcl object "objPtr". If the object
|
* Attempt to return an int from the Tcl object "objPtr". If the object
|
* is not already an int, an attempt will be made to convert it to one.
|
* is not already an int, an attempt will be made to convert it to one.
|
*
|
*
|
* Integer and long integer objects share the same "integer" type
|
* Integer and long integer objects share the same "integer" type
|
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
* checks whether the current value of the long can be represented by
|
* checks whether the current value of the long can be represented by
|
* an int.
|
* an int.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a standard Tcl object result. If an error occurs
|
* The return value is a standard Tcl object result. If an error occurs
|
* during conversion or if the long integer held by the object
|
* during conversion or if the long integer held by the object
|
* can not be represented by an int, an error message is left in
|
* can not be represented by an int, an error message is left in
|
* the interpreter's result unless "interp" is NULL.
|
* the interpreter's result unless "interp" is NULL.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If the object is not already an int, the conversion will free
|
* If the object is not already an int, the conversion will free
|
* any old internal representation.
|
* any old internal representation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetIntFromObj(interp, objPtr, intPtr)
|
Tcl_GetIntFromObj(interp, objPtr, intPtr)
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
register Tcl_Obj *objPtr; /* The object from which to get a int. */
|
register Tcl_Obj *objPtr; /* The object from which to get a int. */
|
register int *intPtr; /* Place to store resulting int. */
|
register int *intPtr; /* Place to store resulting int. */
|
{
|
{
|
register long l;
|
register long l;
|
int result;
|
int result;
|
|
|
if (objPtr->typePtr != &tclIntType) {
|
if (objPtr->typePtr != &tclIntType) {
|
result = SetIntFromAny(interp, objPtr);
|
result = SetIntFromAny(interp, objPtr);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
l = objPtr->internalRep.longValue;
|
l = objPtr->internalRep.longValue;
|
if (((long)((int)l)) == l) {
|
if (((long)((int)l)) == l) {
|
*intPtr = (int)objPtr->internalRep.longValue;
|
*intPtr = (int)objPtr->internalRep.longValue;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
if (interp != NULL) {
|
if (interp != NULL) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"integer value too large to represent as non-long integer", -1);
|
"integer value too large to represent as non-long integer", -1);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DupIntInternalRep --
|
* DupIntInternalRep --
|
*
|
*
|
* Initialize the internal representation of an int Tcl_Obj to a
|
* Initialize the internal representation of an int Tcl_Obj to a
|
* copy of the internal representation of an existing int object.
|
* copy of the internal representation of an existing int object.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* "copyPtr"s internal rep is set to the integer corresponding to
|
* "copyPtr"s internal rep is set to the integer corresponding to
|
* "srcPtr"s internal rep.
|
* "srcPtr"s internal rep.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
DupIntInternalRep(srcPtr, copyPtr)
|
DupIntInternalRep(srcPtr, copyPtr)
|
register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
|
register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
|
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
|
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
|
{
|
{
|
copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
|
copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
|
copyPtr->typePtr = &tclIntType;
|
copyPtr->typePtr = &tclIntType;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SetIntFromAny --
|
* SetIntFromAny --
|
*
|
*
|
* Attempt to generate an integer internal form for the Tcl object
|
* Attempt to generate an integer internal form for the Tcl object
|
* "objPtr".
|
* "objPtr".
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a standard object Tcl result. If an error occurs
|
* The return value is a standard object Tcl result. If an error occurs
|
* during conversion, an error message is left in the interpreter's
|
* during conversion, an error message is left in the interpreter's
|
* result unless "interp" is NULL.
|
* result unless "interp" is NULL.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If no error occurs, an int is stored as "objPtr"s internal
|
* If no error occurs, an int is stored as "objPtr"s internal
|
* representation.
|
* representation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SetIntFromAny(interp, objPtr)
|
SetIntFromAny(interp, objPtr)
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
register Tcl_Obj *objPtr; /* The object to convert. */
|
register Tcl_Obj *objPtr; /* The object to convert. */
|
{
|
{
|
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
char *string, *end;
|
char *string, *end;
|
int length;
|
int length;
|
register char *p;
|
register char *p;
|
long newLong;
|
long newLong;
|
|
|
/*
|
/*
|
* Get the string representation. Make it up-to-date if necessary.
|
* Get the string representation. Make it up-to-date if necessary.
|
*/
|
*/
|
|
|
string = TclGetStringFromObj(objPtr, &length);
|
string = TclGetStringFromObj(objPtr, &length);
|
|
|
/*
|
/*
|
* Now parse "objPtr"s string as an int. We use an implementation here
|
* 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
|
* that doesn't report errors in interp if interp is NULL. Note: use
|
* strtoul instead of strtol for integer conversions to allow full-size
|
* strtoul instead of strtol for integer conversions to allow full-size
|
* unsigned numbers, but don't depend on strtoul to handle sign
|
* unsigned numbers, but don't depend on strtoul to handle sign
|
* characters; it won't in some implementations.
|
* characters; it won't in some implementations.
|
*/
|
*/
|
|
|
errno = 0;
|
errno = 0;
|
for (p = string; isspace(UCHAR(*p)); p++) {
|
for (p = string; isspace(UCHAR(*p)); p++) {
|
/* Empty loop body. */
|
/* Empty loop body. */
|
}
|
}
|
if (*p == '-') {
|
if (*p == '-') {
|
p++;
|
p++;
|
newLong = -((long)strtoul(p, &end, 0));
|
newLong = -((long)strtoul(p, &end, 0));
|
} else if (*p == '+') {
|
} else if (*p == '+') {
|
p++;
|
p++;
|
newLong = strtoul(p, &end, 0);
|
newLong = strtoul(p, &end, 0);
|
} else {
|
} else {
|
newLong = strtoul(p, &end, 0);
|
newLong = strtoul(p, &end, 0);
|
}
|
}
|
if (end == p) {
|
if (end == p) {
|
badInteger:
|
badInteger:
|
if (interp != NULL) {
|
if (interp != NULL) {
|
/*
|
/*
|
* Must copy string before resetting the result in case a caller
|
* Must copy string before resetting the result in case a caller
|
* is trying to convert the interpreter's result to an int.
|
* is trying to convert the interpreter's result to an int.
|
*/
|
*/
|
|
|
char buf[100];
|
char buf[100];
|
sprintf(buf, "expected integer but got \"%.50s\"", string);
|
sprintf(buf, "expected integer but got \"%.50s\"", string);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (errno == ERANGE) {
|
if (errno == ERANGE) {
|
if (interp != NULL) {
|
if (interp != NULL) {
|
char *s = "integer value too large to represent";
|
char *s = "integer value too large to represent";
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
|
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
|
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the string has no garbage after the end of the int.
|
* Make sure that the string has no garbage after the end of the int.
|
*/
|
*/
|
|
|
while ((end < (string+length)) && isspace(UCHAR(*end))) {
|
while ((end < (string+length)) && isspace(UCHAR(*end))) {
|
end++;
|
end++;
|
}
|
}
|
if (end != (string+length)) {
|
if (end != (string+length)) {
|
goto badInteger;
|
goto badInteger;
|
}
|
}
|
|
|
/*
|
/*
|
* The conversion to int succeeded. Free the old internalRep before
|
* The conversion to int succeeded. Free the old internalRep before
|
* setting the new one. We do this as late as possible to allow the
|
* setting the new one. We do this as late as possible to allow the
|
* conversion code, in particular Tcl_GetStringFromObj, to use that old
|
* conversion code, in particular Tcl_GetStringFromObj, to use that old
|
* internalRep.
|
* internalRep.
|
*/
|
*/
|
|
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
oldTypePtr->freeIntRepProc(objPtr);
|
oldTypePtr->freeIntRepProc(objPtr);
|
}
|
}
|
|
|
objPtr->internalRep.longValue = newLong;
|
objPtr->internalRep.longValue = newLong;
|
objPtr->typePtr = &tclIntType;
|
objPtr->typePtr = &tclIntType;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* UpdateStringOfInt --
|
* UpdateStringOfInt --
|
*
|
*
|
* Update the string representation for an integer object.
|
* Update the string representation for an integer object.
|
* Note: This procedure does not free an existing old string rep
|
* Note: This procedure does not free an existing old string rep
|
* so storage will be lost if this has not already been done.
|
* so storage will be lost if this has not already been done.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's string is set to a valid string that results from
|
* The object's string is set to a valid string that results from
|
* the int-to-string conversion.
|
* the int-to-string conversion.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
UpdateStringOfInt(objPtr)
|
UpdateStringOfInt(objPtr)
|
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
|
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
|
{
|
{
|
char buffer[TCL_DOUBLE_SPACE];
|
char buffer[TCL_DOUBLE_SPACE];
|
register int len;
|
register int len;
|
|
|
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
|
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
|
|
|
objPtr->bytes = ckalloc((unsigned) len + 1);
|
objPtr->bytes = ckalloc((unsigned) len + 1);
|
strcpy(objPtr->bytes, buffer);
|
strcpy(objPtr->bytes, buffer);
|
objPtr->length = len;
|
objPtr->length = len;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_NewLongObj --
|
* Tcl_NewLongObj --
|
*
|
*
|
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
* Tcl_NewLongObj to create a new long integer object end up calling
|
* Tcl_NewLongObj to create a new long integer object end up calling
|
* the debugging procedure Tcl_DbNewLongObj instead.
|
* the debugging procedure Tcl_DbNewLongObj instead.
|
*
|
*
|
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
|
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
|
* calls to Tcl_NewLongObj result in a call to one of the two
|
* calls to Tcl_NewLongObj result in a call to one of the two
|
* Tcl_NewLongObj implementations below. We provide two implementations
|
* Tcl_NewLongObj implementations below. We provide two implementations
|
* so that the Tcl core can be compiled to do memory debugging of the
|
* 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.
|
* core even if a client does not request it for itself.
|
*
|
*
|
* Integer and long integer objects share the same "integer" type
|
* Integer and long integer objects share the same "integer" type
|
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
* checks whether the current value of the long can be represented by
|
* checks whether the current value of the long can be represented by
|
* an int.
|
* an int.
|
*
|
*
|
* Results:
|
* Results:
|
* The newly created object is returned. This object will have an
|
* The newly created object is returned. This object will have an
|
* invalid string representation. The returned object has ref count 0.
|
* invalid string representation. The returned object has ref count 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
#undef Tcl_NewLongObj
|
#undef Tcl_NewLongObj
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewLongObj(longValue)
|
Tcl_NewLongObj(longValue)
|
register long longValue; /* Long integer used to initialize the
|
register long longValue; /* Long integer used to initialize the
|
* new object. */
|
* new object. */
|
{
|
{
|
return Tcl_DbNewLongObj(longValue, "unknown", 0);
|
return Tcl_DbNewLongObj(longValue, "unknown", 0);
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_NewLongObj(longValue)
|
Tcl_NewLongObj(longValue)
|
register long longValue; /* Long integer used to initialize the
|
register long longValue; /* Long integer used to initialize the
|
* new object. */
|
* new object. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
TclNewObj(objPtr);
|
TclNewObj(objPtr);
|
objPtr->bytes = NULL;
|
objPtr->bytes = NULL;
|
|
|
objPtr->internalRep.longValue = longValue;
|
objPtr->internalRep.longValue = longValue;
|
objPtr->typePtr = &tclIntType;
|
objPtr->typePtr = &tclIntType;
|
return objPtr;
|
return objPtr;
|
}
|
}
|
#endif /* if TCL_MEM_DEBUG */
|
#endif /* if TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DbNewLongObj --
|
* Tcl_DbNewLongObj --
|
*
|
*
|
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
* Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
|
* Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
|
* long integer objects end up calling the debugging procedure
|
* long integer objects end up calling the debugging procedure
|
* Tcl_DbNewLongObj instead. We provide two implementations of
|
* Tcl_DbNewLongObj instead. We provide two implementations of
|
* Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
|
* Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
|
* memory debugging of the core is independent of whether a client
|
* memory debugging of the core is independent of whether a client
|
* requests debugging for itself.
|
* requests debugging for itself.
|
*
|
*
|
* When the core is compiled with TCL_MEM_DEBUG defined,
|
* When the core is compiled with TCL_MEM_DEBUG defined,
|
* Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
|
* Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
|
* line number from its caller. This simplifies debugging since then
|
* line number from its caller. This simplifies debugging since then
|
* the checkmem command will report the caller's file name and line
|
* the checkmem command will report the caller's file name and line
|
* number when reporting objects that haven't been freed.
|
* number when reporting objects that haven't been freed.
|
*
|
*
|
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
|
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
|
* this procedure just returns the result of calling Tcl_NewLongObj.
|
* this procedure just returns the result of calling Tcl_NewLongObj.
|
*
|
*
|
* Results:
|
* Results:
|
* The newly created long integer object is returned. This object
|
* The newly created long integer object is returned. This object
|
* will have an invalid string representation. The returned object has
|
* will have an invalid string representation. The returned object has
|
* ref count 0.
|
* ref count 0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Allocates memory.
|
* Allocates memory.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DbNewLongObj(longValue, file, line)
|
Tcl_DbNewLongObj(longValue, file, line)
|
register long longValue; /* Long integer used to initialize the
|
register long longValue; /* Long integer used to initialize the
|
* new object. */
|
* new object. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
|
|
TclDbNewObj(objPtr, file, line);
|
TclDbNewObj(objPtr, file, line);
|
objPtr->bytes = NULL;
|
objPtr->bytes = NULL;
|
|
|
objPtr->internalRep.longValue = longValue;
|
objPtr->internalRep.longValue = longValue;
|
objPtr->typePtr = &tclIntType;
|
objPtr->typePtr = &tclIntType;
|
return objPtr;
|
return objPtr;
|
}
|
}
|
|
|
#else /* if not TCL_MEM_DEBUG */
|
#else /* if not TCL_MEM_DEBUG */
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_DbNewLongObj(longValue, file, line)
|
Tcl_DbNewLongObj(longValue, file, line)
|
register long longValue; /* Long integer used to initialize the
|
register long longValue; /* Long integer used to initialize the
|
* new object. */
|
* new object. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
return Tcl_NewLongObj(longValue);
|
return Tcl_NewLongObj(longValue);
|
}
|
}
|
#endif /* TCL_MEM_DEBUG */
|
#endif /* TCL_MEM_DEBUG */
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetLongObj --
|
* Tcl_SetLongObj --
|
*
|
*
|
* Modify an object to be an integer object and to have the specified
|
* Modify an object to be an integer object and to have the specified
|
* long integer value.
|
* long integer value.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's old string rep, if any, is freed. Also, any old
|
* The object's old string rep, if any, is freed. Also, any old
|
* internal rep is freed.
|
* internal rep is freed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetLongObj(objPtr, longValue)
|
Tcl_SetLongObj(objPtr, longValue)
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
register long longValue; /* Long integer used to initialize the
|
register long longValue; /* Long integer used to initialize the
|
* object's value. */
|
* object's value. */
|
{
|
{
|
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
|
|
if (Tcl_IsShared(objPtr)) {
|
if (Tcl_IsShared(objPtr)) {
|
panic("Tcl_SetLongObj called with shared object");
|
panic("Tcl_SetLongObj called with shared object");
|
}
|
}
|
|
|
Tcl_InvalidateStringRep(objPtr);
|
Tcl_InvalidateStringRep(objPtr);
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
oldTypePtr->freeIntRepProc(objPtr);
|
oldTypePtr->freeIntRepProc(objPtr);
|
}
|
}
|
|
|
objPtr->internalRep.longValue = longValue;
|
objPtr->internalRep.longValue = longValue;
|
objPtr->typePtr = &tclIntType;
|
objPtr->typePtr = &tclIntType;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetLongFromObj --
|
* Tcl_GetLongFromObj --
|
*
|
*
|
* Attempt to return an long integer from the Tcl object "objPtr". If
|
* 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
|
* the object is not already an int object, an attempt will be made to
|
* convert it to one.
|
* convert it to one.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a standard Tcl object result. If an error occurs
|
* The return value is a standard Tcl object result. If an error occurs
|
* during conversion, an error message is left in the interpreter's
|
* during conversion, an error message is left in the interpreter's
|
* result unless "interp" is NULL.
|
* result unless "interp" is NULL.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If the object is not already an int object, the conversion will free
|
* If the object is not already an int object, the conversion will free
|
* any old internal representation.
|
* any old internal representation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetLongFromObj(interp, objPtr, longPtr)
|
Tcl_GetLongFromObj(interp, objPtr, longPtr)
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
register Tcl_Obj *objPtr; /* The object from which to get a long. */
|
register Tcl_Obj *objPtr; /* The object from which to get a long. */
|
register long *longPtr; /* Place to store resulting long. */
|
register long *longPtr; /* Place to store resulting long. */
|
{
|
{
|
register int result;
|
register int result;
|
|
|
if (objPtr->typePtr == &tclIntType) {
|
if (objPtr->typePtr == &tclIntType) {
|
*longPtr = objPtr->internalRep.longValue;
|
*longPtr = objPtr->internalRep.longValue;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
result = SetIntFromAny(interp, objPtr);
|
result = SetIntFromAny(interp, objPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
*longPtr = objPtr->internalRep.longValue;
|
*longPtr = objPtr->internalRep.longValue;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DbIncrRefCount --
|
* Tcl_DbIncrRefCount --
|
*
|
*
|
* This procedure is normally called when debugging: i.e., when
|
* This procedure is normally called when debugging: i.e., when
|
* TCL_MEM_DEBUG is defined. This checks to see whether or not
|
* TCL_MEM_DEBUG is defined. This checks to see whether or not
|
* the memory has been freed before incrementing the ref count.
|
* the memory has been freed before incrementing the ref count.
|
*
|
*
|
* When TCL_MEM_DEBUG is not defined, this procedure just increments
|
* When TCL_MEM_DEBUG is not defined, this procedure just increments
|
* the reference count of the object.
|
* the reference count of the object.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's ref count is incremented.
|
* The object's ref count is incremented.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DbIncrRefCount(objPtr, file, line)
|
Tcl_DbIncrRefCount(objPtr, file, line)
|
register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
|
register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
if (objPtr->refCount == 0x61616161) {
|
if (objPtr->refCount == 0x61616161) {
|
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
fflush(stderr);
|
fflush(stderr);
|
panic("Trying to increment refCount of previously disposed object.");
|
panic("Trying to increment refCount of previously disposed object.");
|
}
|
}
|
#endif
|
#endif
|
++(objPtr)->refCount;
|
++(objPtr)->refCount;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DbDecrRefCount --
|
* Tcl_DbDecrRefCount --
|
*
|
*
|
* This procedure is normally called when debugging: i.e., when
|
* This procedure is normally called when debugging: i.e., when
|
* TCL_MEM_DEBUG is defined. This checks to see whether or not
|
* TCL_MEM_DEBUG is defined. This checks to see whether or not
|
* the memory has been freed before incrementing the ref count.
|
* the memory has been freed before incrementing the ref count.
|
*
|
*
|
* When TCL_MEM_DEBUG is not defined, this procedure just increments
|
* When TCL_MEM_DEBUG is not defined, this procedure just increments
|
* the reference count of the object.
|
* the reference count of the object.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's ref count is incremented.
|
* The object's ref count is incremented.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DbDecrRefCount(objPtr, file, line)
|
Tcl_DbDecrRefCount(objPtr, file, line)
|
register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
|
register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
if (objPtr->refCount == 0x61616161) {
|
if (objPtr->refCount == 0x61616161) {
|
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
fflush(stderr);
|
fflush(stderr);
|
panic("Trying to decrement refCount of previously disposed object.");
|
panic("Trying to decrement refCount of previously disposed object.");
|
}
|
}
|
#endif
|
#endif
|
if (--(objPtr)->refCount <= 0) {
|
if (--(objPtr)->refCount <= 0) {
|
TclFreeObj(objPtr);
|
TclFreeObj(objPtr);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DbIsShared --
|
* Tcl_DbIsShared --
|
*
|
*
|
* This procedure is normally called when debugging: i.e., when
|
* This procedure is normally called when debugging: i.e., when
|
* TCL_MEM_DEBUG is defined. This checks to see whether or not
|
* TCL_MEM_DEBUG is defined. This checks to see whether or not
|
* the memory has been freed before incrementing the ref count.
|
* the memory has been freed before incrementing the ref count.
|
*
|
*
|
* When TCL_MEM_DEBUG is not defined, this procedure just decrements
|
* When TCL_MEM_DEBUG is not defined, this procedure just decrements
|
* the reference count of the object and throws it away if the count
|
* the reference count of the object and throws it away if the count
|
* is 0 or less.
|
* is 0 or less.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object's ref count is incremented.
|
* The object's ref count is incremented.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_DbIsShared(objPtr, file, line)
|
Tcl_DbIsShared(objPtr, file, line)
|
register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
|
register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
|
char *file; /* The name of the source file calling this
|
char *file; /* The name of the source file calling this
|
* procedure; used for debugging. */
|
* procedure; used for debugging. */
|
int line; /* Line number in the source file; used
|
int line; /* Line number in the source file; used
|
* for debugging. */
|
* for debugging. */
|
{
|
{
|
#ifdef TCL_MEM_DEBUG
|
#ifdef TCL_MEM_DEBUG
|
if (objPtr->refCount == 0x61616161) {
|
if (objPtr->refCount == 0x61616161) {
|
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
fflush(stderr);
|
fflush(stderr);
|
panic("Trying to check whether previously disposed object is shared.");
|
panic("Trying to check whether previously disposed object is shared.");
|
}
|
}
|
#endif
|
#endif
|
return ((objPtr)->refCount > 1);
|
return ((objPtr)->refCount > 1);
|
}
|
}
|
|
|
