riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/generic/tclObj.c

4551 lines
128 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/*
* tclObj.c --
*
* This file contains Tcl object-related functions that are used by many
* Tcl commands.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
* Copyright (c) 2001 by ActiveState Corporation.
* Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tommath.h"
#include <math.h>
/*
* Table of all object types.
*/
static Tcl_HashTable typeTable;
static int typeTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)
/*
* Head of the list of free Tcl_Obj structs we maintain.
*/
Tcl_Obj *tclFreeObjList = NULL;
/*
* The object allocator is single threaded. This mutex is referenced by the
* TclNewObj macro, however, so must be visible.
*/
#ifdef TCL_THREADS
MODULE_SCOPE Tcl_Mutex tclObjMutex;
Tcl_Mutex tclObjMutex;
#endif
/*
* Pointer to a heap-allocated string of length zero that the Tcl core uses as
* the value of an empty string representation for an object. This value is
* shared by all new objects allocated by Tcl_NewObj.
*/
char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
* Structure for tracking the source file and line number where a given
* Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself,
* for sanity checking purposes.
*/
typedef struct ObjData {
Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */
const char *file; /* The name of the source file calling this
* function; used for debugging. */
int line; /* Line number in the source file; used for
* debugging. */
} ObjData;
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
/*
* All static variables used in this file are collected into a single instance
* of the following structure. For multi-threaded implementations, there is
* one instance of this structure for each thread.
*
* Notice that different structures with the same name appear in other files.
* The structure defined below is used in this file only.
*/
typedef struct ThreadSpecificData {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
* generated by a call to the function
* TclSubstTokens() from a literal text
* where bs+nl sequences occured in it, if
* any. I.e. this table keeps track of
* invisible and stripped continuation lines.
* Its keys are Tcl_Obj pointers, the values
* are ContLineLoc pointers. See the file
* tclCompile.h for the definition of this
* structure, and for references to all
* related places in the core. */
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
* that a Tcl_Obj was not allocated by some
* other thread. */
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
static void TclThreadFinalizeContLines(ClientData clientData);
static ThreadSpecificData *TclGetContLineTable(void);
/*
* Nested Tcl_Obj deletion management support
*
* All context references used in the object freeing code are pointers to this
* structure; every thread will have its own structure instance. The purpose
* of this structure is to allow deeply nested collections of Tcl_Objs to be
* freed without taking a vast depth of C stack (which could cause all sorts
* of breakage.)
*/
typedef struct PendingObjData {
int deletionCount; /* Count of the number of invokations of
* TclFreeObj() are on the stack (at least
* conceptually; many are actually expanded
* macros). */
Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj()
* invoked upon them but which can't be
* deleted yet because they are in a nested
* invokation of TclFreeObj(). By postponing
* this way, we limit the maximum overall C
* stack depth when deleting a complex object.
* The down-side is that we alter the overall
* behaviour by altering the order in which
* objects are deleted, and we change the
* order in which the string rep and the
* internal rep of an object are deleted. Note
* that code which assumes the previous
* behaviour in either of these respects is
* unsafe anyway; it was never documented as
* to exactly what would happen in these
* cases, and the overall contract of a
* user-level Tcl_DecrRefCount() is still
* preserved (assuming that a particular T_DRC
* would delete an object is not very
* safe). */
} PendingObjData;
/*
* These are separated out so that some semantic content is attached
* to them.
*/
#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++)
#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--)
#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0)
#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL)
#define PushObjToDelete(contextPtr,objPtr) \
/* The string rep is already invalidated so we can use the bytes value \
* for our pointer chain: push onto the head of the stack. */ \
(objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
(contextPtr)->deletionStack = (objPtr)
#define PopObjToDelete(contextPtr,objPtrVar) \
(objPtrVar) = (contextPtr)->deletionStack; \
(contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
/*
* Macro to set up the local reference to the deletion context.
*/
#ifndef TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#elif defined(HAVE_FAST_TSD)
static __thread PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#else
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = \
Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
/*
* Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
*/
#define PACK_BIGNUM(bignum, objPtr) \
if ((bignum).used > 0x7FFF) { \
mp_int *temp = (mp_int *)ckalloc(sizeof(mp_int)); \
*temp = bignum; \
(objPtr)->internalRep.twoPtrValue.ptr1 = temp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \
} else { \
if ((bignum).alloc > 0x7FFF) { \
mp_shrink(&(bignum)); \
} \
(objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
#define UNPACK_BIGNUM(objPtr, bignum) \
if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \
(bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \
} else { \
(bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \
(bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \
(bignum).alloc = \
(PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7FFF; \
(bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7FFF; \
}
/*
* Prototypes for functions defined later in this file:
*/
static int ParseBoolean(Tcl_Obj *objPtr);
static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
#ifndef TCL_WIDE_INT_IS_LONG
static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
#endif
static void FreeBignum(Tcl_Obj *objPtr);
static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void UpdateStringOfBignum(Tcl_Obj *objPtr);
static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int copy, mp_int *bignumValue);
/*
* Prototypes for the array hash key methods.
*/
static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Prototypes for the CommandName object type.
*/
static void DupCmdNameInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
static void FreeCmdNameInternalRep(Tcl_Obj *objPtr);
static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
/*
* The structures below defines the Tcl object types defined in this file by
* means of functions that can be invoked by generic object code. See also
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
* implementations.
*/
static const Tcl_ObjType oldBooleanType = {
"boolean", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclBooleanType = {
"booleanString", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclDoubleType = {
"double", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclIntType = {
"int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
#ifndef TCL_WIDE_INT_IS_LONG
const Tcl_ObjType tclWideIntType = {
"wideInt", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfWideInt, /* updateStringProc */
SetWideIntFromAny /* setFromAnyProc */
};
#endif
const Tcl_ObjType tclBignumType = {
"bignum", /* name */
FreeBignum, /* freeIntRepProc */
DupBignum, /* dupIntRepProc */
UpdateStringOfBignum, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* The structure below defines the Tcl obj hash key type.
*/
const Tcl_HashKeyType tclObjHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
TclHashObjKey, /* hashKeyProc */
TclCompareObjKeys, /* compareKeysProc */
AllocObjEntry, /* allocEntryProc */
TclFreeObjEntry /* freeEntryProc */
};
/*
* The structure below defines the command name Tcl object type by means of
* functions that can be invoked by generic object code. Objects of this type
* cache the Command pointer that results from looking up command names in the
* command hashtable. Such objects appear as the zeroth ("command name")
* argument in a Tcl command.
*
* NOTE: the ResolvedCmdName that gets cached is stored in the
* twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. You might
* think you could use the simpler otherValuePtr field to store the single
* ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions
* use the second internal pointer field of the twoPtrValue field for their
* own purposes.
*
* TRICKY POINT! Some extensions update this structure! (Notably, these
* include TclBlend and TCom). This is highly ill-advised on their part, but
* does allow them to delete a command when references to it are gone, which
* is fragile but useful given their somewhat-OO style. Because of this, this
* structure MUST NOT be const so that the C compiler puts the data in
* writable memory. [Bug 2558422] [Bug 07d13d99b0a9]
* TODO: Provide a better API for those extensions so that they can coexist...
*/
Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetCmdNameFromAny /* setFromAnyProc */
};
/*
* Structure containing a cached pointer to a command that is the result of
* resolving the command's name in some namespace. It is the internal
* representation for a cmdName object. It contains the pointer along with
* some information that is used to check the pointer's validity.
*/
typedef struct ResolvedCmdName {
Command *cmdPtr; /* A cached Command pointer. */
Namespace *refNsPtr; /* Points to the namespace containing the
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
long refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid (e.g.,
* it's possible that the cmd's containing
* namespace was deleted and a new one created
* at the same address). */
int refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
int cmdEpoch; /* Value of the command's cmdEpoch when this
* pointer was cached. Before using the cached
* pointer, we check if the cmd's epoch was
* incremented; if so, the cmd was renamed,
* deleted, hidden, or exposed, and so the
* pointer is invalid. */
int refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
* becomes zero. */
} ResolvedCmdName;
/*
*-------------------------------------------------------------------------
*
* TclInitObjectSubsystem --
*
* This function is invoked to perform once-only initialization of the
* type table. It also registers the object types defined in this file.
*
* Results:
* None.
*
* Side effects:
* Initializes the table of defined object types "typeTable" with builtin
* object types defined in this file.
*
*-------------------------------------------------------------------------
*/
void
TclInitObjSubsystem(void)
{
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
/* For backward compatibility only ... */
Tcl_RegisterObjType(&oldBooleanType);
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_RegisterObjType(&tclWideIntType);
#endif
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
tclObjsFreed = 0;
{
int i;
for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) {
tclObjsShared[i] = 0;
}
}
Tcl_MutexUnlock(&tclObjMutex);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadObjects --
*
* This function is called by Tcl_FinalizeThread to clean up thread
* specific Tcl_Obj information.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadObjects(void)
{
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
}
}
Tcl_DeleteHashTable(tablePtr);
ckfree(tablePtr);
tsdPtr->objThreadMap = NULL;
}
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeObjects --
*
* This function is called by Tcl_Finalize to clean up all registered
* Tcl_ObjType's and to reset the tclFreeObjList.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeObjects(void)
{
Tcl_MutexLock(&tableMutex);
if (typeTableInitialized) {
Tcl_DeleteHashTable(&typeTable);
typeTableInitialized = 0;
}
Tcl_MutexUnlock(&tableMutex);
/*
* All we do here is reset the head pointer of the linked list of free
* Tcl_Obj's to NULL; the memory finalization will take care of releasing
* memory for us.
*/
Tcl_MutexLock(&tclObjMutex);
tclFreeObjList = NULL;
Tcl_MutexUnlock(&tclObjMutex);
}
/*
*----------------------------------------------------------------------
*
* TclGetContLineTable --
*
* This procedure is a helper which returns the thread-specific
* hash-table used to track continuation line information associated with
* Tcl_Obj*, and the objThreadMap, etc.
*
* Results:
* A reference to the thread-data.
*
* Side effects:
* May allocate memory for the thread-data.
*
* TIP #280
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
TclGetContLineTable(void)
{
/*
* Initialize the hashtable tracking invisible continuation lines. For
* the release we use a thread exit handler to ensure that this is done
* before TSD blocks are made invalid. The TclFinalizeObjects() which
* would be the natural place for this is invoked afterwards, meaning that
* we try to operate on a data structure already gone.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
}
return tsdPtr;
}
/*
*----------------------------------------------------------------------
*
* TclContinuationsEnter --
*
* This procedure is a helper which saves the continuation line
* information associated with a Tcl_Obj*.
*
* Results:
* A reference to the newly created continuation line location table.
*
* Side effects:
* Allocates memory for the table of continuation line locations.
*
* TIP #280
*----------------------------------------------------------------------
*/
ContLineLoc *
TclContinuationsEnter(
Tcl_Obj *objPtr,
int num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(TclOffset(ContLineLoc, loc) + (num + 1) *sizeof(int));
if (!newEntry) {
/*
* We're entering ContLineLoc data for the same value more than one
* time. Taking care not to leak the old entry.
*
* This can happen when literals in a proc body are shared. See for
* example test info-30.19 where the action (code) for all branches of
* the switch command is identical, mapping them all to the same
* literal. An interesting result of this is that the number and
* locations (offset) of invisible continuation lines in the literal
* are the same for all occurences.
*
* Note that while reusing the existing entry is possible it requires
* the same actions as for a new entry because we have to copy the
* incoming num/loc data even so. Because we are called from
* TclContinuationsEnterDerived for this case, which modified the
* stored locations (Rebased to the proper relative offset). Just
* returning the stored entry would rebase them a second time, or
* more, hosing the data. It is easier to simply replace, as we are
* doing.
*/
ckfree(Tcl_GetHashValue(hPtr));
}
clLocPtr->num = num;
memcpy(&clLocPtr->loc, loc, num*sizeof(int));
clLocPtr->loc[num] = CLL_END; /* Sentinel */
Tcl_SetHashValue(hPtr, clLocPtr);
return clLocPtr;
}
/*
*----------------------------------------------------------------------
*
* TclContinuationsEnterDerived --
*
* This procedure is a helper which computes the continuation line
* information associated with a Tcl_Obj* cut from the middle of a
* script.
*
* Results:
* None.
*
* Side effects:
* Allocates memory for the table of continuation line locations.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclContinuationsEnterDerived(
Tcl_Obj *objPtr,
int start,
int *clNext)
{
int length, end, num;
int *wordCLLast = clNext;
/*
* We have to handle invisible continuations lines here as well, despite
* the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If
* our script is the sole argument to an 'eval' command, for example, the
* scriptCLLocPtr we are using was generated by a previous call to TST,
* and while the words we have here may contain continuation lines they
* are invisible already, and the inner call to TST had no bs+nl sequences
* to trigger its code.
*
* Luckily for us, the table we have to create here for the current word
* has to be a slice of the table currently in use, with the locations
* suitably modified to be relative to the start of the word instead of
* relative to the script.
*
* That is what we are doing now. Determine the slice we need, and if not
* empty, wrap it into a new table, and save the result into our
* thread-global hashtable, as usual.
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
TclGetStringFromObj(objPtr, &length);
end = start + length; /* First char after the word */
/*
* Then compute the table slice covering the range of the word.
*/
while (*wordCLLast >= 0 && *wordCLLast < end) {
wordCLLast++;
}
/*
* And generate the table from the slice, if it was not empty.
*/
num = wordCLLast - clNext;
if (num) {
int i;
ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext);
/*
* Re-base the locations.
*/
for (i=0 ; i<num ; i++) {
clLocPtr->loc[i] -= start;
/*
* Continuation lines coming before the string and affecting us
* should not happen, due to the proper maintenance of clNext
* during compilation.
*/
if (clLocPtr->loc[i] < 0) {
Tcl_Panic("Derived ICL data for object using offsets from before the script");
}
}
}
}
/*
*----------------------------------------------------------------------
*
* TclContinuationsCopy --
*
* This procedure is a helper which copies the continuation line
* information associated with a Tcl_Obj* to another Tcl_Obj*. It is
* assumed that both contain the same string/script. Use this when a
* script is duplicated because it was shared.
*
* Results:
* None.
*
* Side effects:
* Allocates memory for the table of continuation line locations.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclContinuationsCopy(
Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
}
}
/*
*----------------------------------------------------------------------
*
* TclContinuationsGet --
*
* This procedure is a helper which retrieves the continuation line
* information associated with a Tcl_Obj*, if it has any.
*
* Results:
* A reference to the continuation line location table, or NULL if the
* Tcl_Obj* has no such information associated with it.
*
* Side effects:
* None.
*
* TIP #280
*----------------------------------------------------------------------
*/
ContLineLoc *
TclContinuationsGet(
Tcl_Obj *objPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (!hPtr) {
return NULL;
}
return Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclThreadFinalizeContLines --
*
* This procedure is a helper which releases all continuation line
* information currently known. It is run as a thread exit handler.
*
* Results:
* None.
*
* Side effects:
* Releases memory.
*
* TIP #280
*----------------------------------------------------------------------
*/
static void
TclThreadFinalizeContLines(
ClientData clientData)
{
/*
* Release the hashtable tracking invisible continuation lines.
*/
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
ckfree(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
*
* This function is called to register a new Tcl object type in the table
* of all object types supported by Tcl.
*
* Results:
* None.
*
* Side effects:
* The type is registered in the Tcl type table. If there was already a
* type with the same name as in typePtr, it is replaced with the new
* type.
*
*--------------------------------------------------------------
*/
void
Tcl_RegisterObjType(
const Tcl_ObjType *typePtr) /* Information about object type; storage must
* be statically allocated (must live
* forever). */
{
int isNew;
Tcl_MutexLock(&tableMutex);
Tcl_SetHashValue(
Tcl_CreateHashEntry(&typeTable, typePtr->name, &isNew), typePtr);
Tcl_MutexUnlock(&tableMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendAllObjTypes --
*
* This function appends onto the argument object the name of each object
* type as a list element. This includes the builtin object types (e.g.
* int, list) as well as those added using Tcl_NewObj. These names can be
* used, for example, with Tcl_GetObjType to get pointers to the
* corresponding Tcl_ObjType structures.
*
* Results:
* The return value is normally TCL_OK; in this case the object
* referenced by objPtr has each type name appended to it. If an error
* occurs, TCL_ERROR is returned and the interpreter's result holds an
* error message.
*
* Side effects:
* If necessary, the object referenced by objPtr is converted into a list
* object.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppendAllObjTypes(
Tcl_Interp *interp, /* Interpreter used for error reporting. */
Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
* name of each registered type is appended as
* a list element. */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int numElems;
/*
* Get the test for a valid list out of the way first.
*/
if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) {
return TCL_ERROR;
}
/*
* Type names are NUL-terminated, not counted strings. This code relies on
* that.
*/
Tcl_MutexLock(&tableMutex);
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
}
Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetObjType --
*
* This function looks up an object type by name.
*
* Results:
* If an object type with name matching "typeName" is found, a pointer to
* its Tcl_ObjType structure is returned; otherwise, NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
const Tcl_ObjType *
Tcl_GetObjType(
const char *typeName) /* Name of Tcl object type to look up. */
{
Tcl_HashEntry *hPtr;
const Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != NULL) {
typePtr = Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertToType --
*
* Convert the Tcl object "objPtr" to have type "typePtr" if possible.
*
* Results:
* The return value is TCL_OK on success and TCL_ERROR on failure. If
* TCL_ERROR is returned, then the interpreter's result contains an error
* message unless "interp" is NULL. Passing a NULL "interp" allows this
* function to be used as a test whether the conversion could be done
* (and in fact was done).
*
* Side effects:
* Any internal representation for the old type is freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConvertToType(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object to convert. */
const Tcl_ObjType *typePtr) /* The target type. */
{
if (objPtr->typePtr == typePtr) {
return TCL_OK;
}
/*
* Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form
* as appropriate for the target type. This frees the old internal
* representation.
*/
if (typePtr->setFromAnyProc == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't convert value to type %s", typePtr->name));
Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL);
}
return TCL_ERROR;
}
return typePtr->setFromAnyProc(interp, objPtr);
}
/*
*--------------------------------------------------------------
*
* TclDbDumpActiveObjects --
*
* This function is called to dump all of the active Tcl_Obj structs this
* allocator knows about.
*
* Results:
* None.
*
* Side effects:
* None.
*
*--------------------------------------------------------------
*/
void
TclDbDumpActiveObjects(
FILE *outFile)
{
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
Tcl_HashSearch hSearch;
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
fprintf(outFile, "total objects: %d\n", tablePtr->numEntries);
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
fprintf(outFile,
"key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n",
Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr,
objData->file, objData->line);
} else {
fprintf(outFile, "key = 0x%p\n",
Tcl_GetHashKey(tablePtr, hPtr));
}
}
}
#endif
}
/*
*----------------------------------------------------------------------
*
* TclDbInitNewObj --
*
* Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is
* enabled. This function will initialize the members of a Tcl_Obj
* struct. Initilization would be done inline via the TclNewObj macro
* when compiling without TCL_MEM_DEBUG.
*
* Results:
* The Tcl_Obj struct members are initialized.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
TclDbInitNewObj(
Tcl_Obj *objPtr,
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
objPtr->refCount = 0;
objPtr->bytes = tclEmptyStringRep;
objPtr->length = 0;
objPtr->typePtr = NULL;
#ifdef TCL_THREADS
/*
* Add entry to a thread local map used to check if a Tcl_Obj was
* allocated by the currently executing thread.
*/
if (!TclInExit()) {
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
int isNew;
ObjData *objData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
}
tablePtr = tsdPtr->objThreadMap;
hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew);
if (!isNew) {
Tcl_Panic("expected to create new entry for object map");
}
/*
* Record the debugging information.
*/
objData = (ObjData *)ckalloc(sizeof(ObjData));
objData->objPtr = objPtr;
objData->file = file;
objData->line = line;
Tcl_SetHashValue(hPtr, objData);
}
#endif /* TCL_THREADS */
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_NewObj --
*
* This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
* the empty string. These objects have a NULL object type and NULL
* string representation byte pointer. Type managers call this routine to
* allocate new objects that they further initialize.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
* of calling the debugging version Tcl_DbNewObj.
*
* Results:
* The result is a newly allocated object that represents the empty
* string. The new object's typePtr is set NULL and its ref count is set
* to 0.
*
* Side effects:
* If compiling with TCL_COMPILE_STATS, this function increments the
* global count of allocated objects (tclObjsAlloced).
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewObj
Tcl_Obj *
Tcl_NewObj(void)
{
return Tcl_DbNewObj("unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewObj(void)
{
Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the correct allocator.
*/
TclNewObj(objPtr);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewObj --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
* empty string. It is the same as the Tcl_NewObj function above except
* that it calls Tcl_DbCkalloc directly with the file name and line
* number from its caller. This simplifies debugging since then the
* [memory active] command will report the correct file name and line
* number when reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewObj.
*
* Results:
* The result is a newly allocated that represents the empty string. The
* new object's typePtr is set NULL and its ref count is set to 0.
*
* Side effects:
* If compiling with TCL_COMPILE_STATS, this function increments the
* global count of allocated objects (tclObjsAlloced).
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewObj(
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the correct allocator.
*/
TclDbNewObj(objPtr, file, line);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewObj(
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
return Tcl_NewObj();
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* TclAllocateFreeObjects --
*
* Function to allocate a number of free Tcl_Objs. This is done using a
* single ckalloc to reduce the overhead for Tcl_Obj allocation.
*
* Assumes mutex is held.
*
* Results:
* None.
*
* Side effects:
* tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
* first of a number of free Tcl_Obj's linked together by their
* internalRep.twoPtrValue.ptr1's.
*
*----------------------------------------------------------------------
*/
#define OBJS_TO_ALLOC_EACH_TIME 100
void
TclAllocateFreeObjects(void)
{
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
char *basePtr;
Tcl_Obj *prevPtr, *objPtr;
int i;
/*
* This has been noted by Purify to be a potential leak. The problem is
* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
* Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
* freeing the memory. TclFinalizeObjects() does not ckfree() this memory,
* but leaves it to Tcl's memory subsystem finalization to release it.
* Purify apparently can't figure that out, and fires a false alarm.
*/
basePtr = (char *)ckalloc(bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
objPtr->internalRep.twoPtrValue.ptr1 = prevPtr;
prevPtr = objPtr;
objPtr++;
}
tclFreeObjList = prevPtr;
}
#undef OBJS_TO_ALLOC_EACH_TIME
/*
*----------------------------------------------------------------------
*
* TclFreeObj --
*
* This function frees the memory associated with the argument object.
* It is called by the tcl.h macro Tcl_DecrRefCount when an object's ref
* count is zero. It is only "public" since it must be callable by that
* macro wherever the macro is used. It should not be directly called by
* clients.
*
* Results:
* None.
*
* Side effects:
* Deallocates the storage for the object's Tcl_Obj structure after
* deallocating the string representation and calling the type-specific
* Tcl_FreeInternalRepProc to deallocate the object's internal
* representation. If compiling with TCL_COMPILE_STATS, this function
* increments the global count of freed objects (tclObjsFreed).
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
TclFreeObj(
Tcl_Obj *objPtr) /* The object to be freed. */
{
const Tcl_ObjType *typePtr = objPtr->typePtr;
/*
* This macro declares a variable, so must come here...
*/
ObjInitDeletionContext(context);
# ifdef TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
* storage can be finalized before the last Tcl_Obj is freed.
*/
if (!TclInExit()) {
Tcl_HashTable *tablePtr;
Tcl_HashEntry *hPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tablePtr = tsdPtr->objThreadMap;
if (!tablePtr) {
Tcl_Panic("TclFreeObj: object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
if (hPtr) {
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
ObjData *objData = Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
}
Tcl_DeleteHashEntry(hPtr);
}
}
# endif
/*
* Check for a double free of the same value. This is slightly tricky
* because it is customary to free a Tcl_Obj when its refcount falls
* either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though,
* and so on, is always a sign of a botch in the caller.
*/
if (objPtr->refCount < -1) {
Tcl_Panic("Reference count for %p was negative", objPtr);
}
/*
* Now, in case we just approved drop from 1 to 0 as acceptable, make
* sure we do not accept a second free when falling from 0 to -1.
* Skip that possibility so any double free will trigger the panic.
*/
objPtr->refCount = -1;
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering)
* with 'length == -1'.
*/
TclInvalidateStringRep(objPtr);
objPtr->length = -1;
if (ObjDeletePending(context)) {
PushObjToDelete(context, objPtr);
} else {
TCL_DTRACE_OBJ_FREE(objPtr);
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
ObjDeletionLock(context);
typePtr->freeIntRepProc(objPtr);
ObjDeletionUnlock(context);
}
Tcl_MutexLock(&tclObjMutex);
ckfree(objPtr);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
ObjDeletionLock(context);
while (ObjOnStack(context)) {
Tcl_Obj *objToFree;
PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
TclFreeIntRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
ckfree(objToFree);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
}
ObjDeletionUnlock(context);
}
/*
* We cannot use TclGetContinuationTable() here, because that may
* re-initialize the thread-data for calls coming after the finalization.
* We have to access it using the low-level call and then check for
* validity. This function can be called after TclFinalizeThreadData() has
* already killed the thread-global data structures. Performing
* TCL_TSD_INIT will leave us with an un-initialized memory block upon
* which we crash (if we where to access the uninitialized hashtable).
*/
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
}
}
#else /* TCL_MEM_DEBUG */
void
TclFreeObj(
Tcl_Obj *objPtr) /* The object to be freed. */
{
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering)
* with 'length == -1'.
*/
TclInvalidateStringRep(objPtr);
objPtr->length = -1;
if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
/*
* objPtr can be freed safely, as it will not attempt to free any
* other objects: it will not cause recursive calls to this function.
*/
TCL_DTRACE_OBJ_FREE(objPtr);
TclFreeObjStorage(objPtr);
TclIncrObjsFreed();
} else {
/*
* This macro declares a variable, so must come here...
*/
ObjInitDeletionContext(context);
if (ObjDeletePending(context)) {
PushObjToDelete(context, objPtr);
} else {
/*
* Note that the contents of the while loop assume that the string
* rep has already been freed and we don't want to do anything
* fancy with adding to the queue inside ourselves. Must take care
* to unstack the object first since freeing the internal rep can
* add further objects to the stack. The code assumes that it is
* the first thing in a block; all current usages in the core
* satisfy this.
*/
TCL_DTRACE_OBJ_FREE(objPtr);
ObjDeletionLock(context);
objPtr->typePtr->freeIntRepProc(objPtr);
ObjDeletionUnlock(context);
TclFreeObjStorage(objPtr);
TclIncrObjsFreed();
ObjDeletionLock(context);
while (ObjOnStack(context)) {
Tcl_Obj *objToFree;
PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
if ((objToFree->typePtr != NULL)
&& (objToFree->typePtr->freeIntRepProc != NULL)) {
objToFree->typePtr->freeIntRepProc(objToFree);
}
TclFreeObjStorage(objToFree);
TclIncrObjsFreed();
}
ObjDeletionUnlock(context);
}
}
/*
* We cannot use TclGetContinuationTable() here, because that may
* re-initialize the thread-data for calls coming after the finalization.
* We have to access it using the low-level call and then check for
* validity. This function can be called after TclFinalizeThreadData() has
* already killed the thread-global data structures. Performing
* TCL_TSD_INIT will leave us with an un-initialized memory block upon
* which we crash (if we where to access the uninitialized hashtable).
*/
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
}
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* TclObjBeingDeleted --
*
* This function returns 1 when the Tcl_Obj is being deleted. It is
* provided for the rare cases where the reason for the loss of an
* internal rep might be relevant. [FR 1512138]
*
* Results:
* 1 if being deleted, 0 otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
return (objPtr->length == -1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DuplicateObj --
*
* Create and return a new object that is a duplicate of the argument
* object.
*
* Results:
* The return value is a pointer to a newly created Tcl_Obj. This object
* has reference count 0 and the same type, if any, as the source object
* objPtr. Also:
* 1) If the source object has a valid string rep, we copy it;
* otherwise, the duplicate's string rep is set NULL to mark it
* invalid.
* 2) If the source object has an internal representation (i.e. its
* typePtr is non-NULL), the new object's internal rep is set to a
* copy; otherwise the new internal rep is marked invalid.
*
* Side effects:
* What constitutes "copying" the internal representation depends on the
* type. For example, if the argument object is a list, the element
* objects it points to will not actually be copied but will be shared
* with the duplicate list. That is, the ref counts of the element
* objects will be incremented.
*
*----------------------------------------------------------------------
*/
#define SetDuplicateObj(dupPtr, objPtr) \
{ \
const Tcl_ObjType *typePtr = (objPtr)->typePtr; \
const char *bytes = (objPtr)->bytes; \
if (bytes) { \
TclInitStringRep((dupPtr), bytes, (objPtr)->length); \
} else { \
(dupPtr)->bytes = NULL; \
} \
if (typePtr) { \
if (typePtr->dupIntRepProc) { \
typePtr->dupIntRepProc((objPtr), (dupPtr)); \
} else { \
(dupPtr)->internalRep = (objPtr)->internalRep; \
(dupPtr)->typePtr = typePtr; \
} \
} \
}
Tcl_Obj *
Tcl_DuplicateObj(
Tcl_Obj *objPtr) /* The object to duplicate. */
{
Tcl_Obj *dupPtr;
TclNewObj(dupPtr);
SetDuplicateObj(dupPtr, objPtr);
return dupPtr;
}
void
TclSetDuplicateObj(
Tcl_Obj *dupPtr,
Tcl_Obj *objPtr)
{
if (Tcl_IsShared(dupPtr)) {
Tcl_Panic("%s called with shared object", "TclSetDuplicateObj");
}
TclInvalidateStringRep(dupPtr);
TclFreeIntRep(dupPtr);
SetDuplicateObj(dupPtr, objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetString --
*
* Returns the string representation byte array pointer for an object.
*
* Results:
* Returns a pointer to the string representation of objPtr. The byte
* array referenced by the returned pointer must not be modified by the
* caller. Furthermore, the caller must copy the bytes if they need to
* retain them since the object's string rep can change as a result of
* other operations.
*
* Side effects:
* May call the object's updateStringProc to update the string
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
char *
Tcl_GetString(
Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be returned. */
{
if (objPtr->bytes != NULL) {
return objPtr->bytes;
}
/*
* Note we do not check for objPtr->typePtr == NULL. An invariant of
* a properly maintained Tcl_Obj is that at least one of objPtr->bytes
* and objPtr->typePtr must not be NULL. If broken extensions fail to
* maintain that invariant, we can crash here.
*/
if (objPtr->typePtr->updateStringProc == NULL) {
/*
* Those Tcl_ObjTypes which choose not to define an updateStringProc
* must be written in such a way that (objPtr->bytes) never becomes
* NULL. This panic was added in Tcl 8.1.
*/
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
objPtr->typePtr->updateStringProc(objPtr);
if (objPtr->bytes == NULL || objPtr->length < 0
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep", objPtr->typePtr->name);
}
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStringFromObj --
*
* Returns the string representation's byte array pointer and length for
* an object.
*
* Results:
* Returns a pointer to the string representation of objPtr. If lengthPtr
* isn't NULL, the length of the string representation is stored at
* *lengthPtr. The byte array referenced by the returned pointer must not
* be modified by the caller. Furthermore, the caller must copy the bytes
* if they need to retain them since the object's string rep can change
* as a result of other operations.
*
* Side effects:
* May call the object's updateStringProc to update the string
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
char *
Tcl_GetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
int *lengthPtr) /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
(void) TclGetString(objPtr);
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
}
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InvalidateStringRep --
*
* This function is called to invalidate an object's string
* representation.
*
* Results:
* None.
*
* Side effects:
* Deallocates the storage for any old string representation, then sets
* the string representation NULL to mark it invalid.
*
*----------------------------------------------------------------------
*/
void
Tcl_InvalidateStringRep(
Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be freed. */
{
TclInvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewBooleanObj --
*
* This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and
* initializes it from the argument boolean value. A nonzero "boolValue"
* is coerced to 1.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
* of calling the debugging version Tcl_DbNewBooleanObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_NewBooleanObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewBooleanObj(
int boolValue) /* Boolean used to initialize new object. */
{
return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewBooleanObj(
int boolValue) /* Boolean used to initialize new object. */
{
Tcl_Obj *objPtr;
TclNewBooleanObj(objPtr, boolValue);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewBooleanObj --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
* same as the Tcl_NewBooleanObj function above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewBooleanObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBooleanObj(
int boolValue, /* Boolean used to initialize new object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = (boolValue? 1 : 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewBooleanObj(
int boolValue, /* Boolean used to initialize new object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
return Tcl_NewBooleanObj(boolValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetBooleanObj --
*
* Modify an object to be a boolean object and to have the specified
* boolean value. A nonzero "boolValue" is coerced to 1.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
#undef Tcl_SetBooleanObj
void
Tcl_SetBooleanObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
int boolValue) /* Boolean used to set object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
TclSetBooleanObj(objPtr, boolValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetBooleanFromObj --
*
* Attempt to return a boolean from the Tcl object "objPtr". This
* includes conversion from any of Tcl's numeric types.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* The internalrep of *objPtr may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetBooleanFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
int *boolPtr) /* Place to store resulting boolean. */
{
do {
if (objPtr->typePtr == &tclIntType) {
*boolPtr = (objPtr->internalRep.longValue != 0);
return TCL_OK;
}
if (objPtr->typePtr == &tclBooleanType) {
*boolPtr = (int) objPtr->internalRep.longValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
/*
* Caution: Don't be tempted to check directly for the "double"
* Tcl_ObjType and then compare the internalrep to 0.0. This isn't
* reliable because a "double" Tcl_ObjType can hold the NaN value.
* Use the API Tcl_GetDoubleFromObj, which does the checking and
* sets the proper error message for us.
*/
double d;
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
}
*boolPtr = (d != 0.0);
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
*boolPtr = 1;
return TCL_OK;
}
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*boolPtr = (objPtr->internalRep.wideValue != 0);
return TCL_OK;
}
#endif
} while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0)));
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclSetBooleanFromAny --
*
* Attempt to generate a boolean internal form for the Tcl object
* "objPtr".
*
* Results:
* The return value is a standard Tcl result. If an error occurs during
* conversion, an error message is left in the interpreter's result
* unless "interp" is NULL.
*
* Side effects:
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal
* representation and the type of "objPtr" is set to boolean.
*
*----------------------------------------------------------------------
*/
int
TclSetBooleanFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
/*
* For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
* whether a boolean conversion is possible without generating the string
* rep.
*/
if (objPtr->bytes == NULL) {
if (objPtr->typePtr == &tclIntType) {
switch (objPtr->internalRep.longValue) {
case 0L: case 1L:
return TCL_OK;
}
goto badBoolean;
}
if (objPtr->typePtr == &tclBignumType) {
goto badBoolean;
}
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
goto badBoolean;
}
#endif
if (objPtr->typePtr == &tclDoubleType) {
goto badBoolean;
}
}
if (ParseBoolean(objPtr) == TCL_OK) {
return TCL_OK;
}
badBoolean:
if (interp != NULL) {
int length;
const char *str = TclGetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
Tcl_AppendLimitedToObj(msg, str, length, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL);
}
return TCL_ERROR;
}
static int
ParseBoolean(
Tcl_Obj *objPtr) /* The object to parse/convert. */
{
int i, length, newBool;
char lowerCase[6];
const char *str = TclGetStringFromObj(objPtr, &length);
if ((length == 0) || (length > 5)) {
/*
* Longest valid boolean string rep. is "false".
*/
return TCL_ERROR;
}
switch (str[0]) {
case '0':
if (length == 1) {
newBool = 0;
goto numericBoolean;
}
return TCL_ERROR;
case '1':
if (length == 1) {
newBool = 1;
goto numericBoolean;
}
return TCL_ERROR;
}
/*
* Force to lower case for case-insensitive detection. Filter out known
* invalid characters at the same time.
*/
for (i=0; i < length; i++) {
char c = str[i];
switch (c) {
case 'A': case 'E': case 'F': case 'L': case 'N':
case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y':
lowerCase[i] = c + (char) ('a' - 'A');
break;
case 'a': case 'e': case 'f': case 'l': case 'n':
case 'o': case 'r': case 's': case 't': case 'u': case 'y':
lowerCase[i] = c;
break;
default:
return TCL_ERROR;
}
}
lowerCase[length] = 0;
switch (lowerCase[0]) {
case 'y':
/*
* Checking the 'y' is redundant, but makes the code clearer.
*/
if (strncmp(lowerCase, "yes", length) == 0) {
newBool = 1;
goto goodBoolean;
}
return TCL_ERROR;
case 'n':
if (strncmp(lowerCase, "no", length) == 0) {
newBool = 0;
goto goodBoolean;
}
return TCL_ERROR;
case 't':
if (strncmp(lowerCase, "true", length) == 0) {
newBool = 1;
goto goodBoolean;
}
return TCL_ERROR;
case 'f':
if (strncmp(lowerCase, "false", length) == 0) {
newBool = 0;
goto goodBoolean;
}
return TCL_ERROR;
case 'o':
if (length < 2) {
return TCL_ERROR;
}
if (strncmp(lowerCase, "on", length) == 0) {
newBool = 1;
goto goodBoolean;
} else if (strncmp(lowerCase, "off", length) == 0) {
newBool = 0;
goto goodBoolean;
}
return TCL_ERROR;
default:
return TCL_ERROR;
}
/*
* Free the old internalRep before setting the new one. We do this as late
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
goodBoolean:
TclFreeIntRep(objPtr);
objPtr->internalRep.longValue = newBool;
objPtr->typePtr = &tclBooleanType;
return TCL_OK;
numericBoolean:
TclFreeIntRep(objPtr);
objPtr->internalRep.longValue = newBool;
objPtr->typePtr = &tclIntType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewDoubleObj --
*
* This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new double object and
* initializes it from the argument double value.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
* of calling the debugging version Tcl_DbNewDoubleObj.
*
* Results:
* The newly created object is returned. This object will have an
* invalid string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewDoubleObj
Tcl_Obj *
Tcl_NewDoubleObj(
double dblValue) /* Double used to initialize the object. */
{
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewDoubleObj(
double dblValue) /* Double used to initialize the object. */
{
Tcl_Obj *objPtr;
TclNewDoubleObj(objPtr, dblValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewDoubleObj --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new double objects. It is the
* same as the Tcl_NewDoubleObj function above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewDoubleObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
return Tcl_NewDoubleObj(dblValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetDoubleObj --
*
* Modify an object to be a double object and to have the specified
* double value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetDoubleObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
double dblValue) /* Double used to set the object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj");
}
TclSetDoubleObj(objPtr, dblValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetDoubleFromObj --
*
* 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 it to one.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If the object is not already a double, the conversion will free any
* old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a double. */
double *dblPtr) /* Place to store resulting double. */
{
do {
if (objPtr->typePtr == &tclDoubleType) {
if (TclIsNaN(objPtr->internalRep.doubleValue)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
NULL);
}
return TCL_ERROR;
}
*dblPtr = (double) objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
*dblPtr = objPtr->internalRep.longValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
UNPACK_BIGNUM(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
#endif
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* SetDoubleFromAny --
*
* Attempt to generate an double-precision floating point internal form
* for the Tcl object "objPtr".
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If no error occurs, a double is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetDoubleFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1,
NULL, 0);
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfDouble --
*
* Update the string representation for a double-precision floating point
* object. This must obey the current tcl_precision value for
* double-to-string conversions. Note: This function does not free an
* existing old string rep so storage will be lost if this has not
* already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from the
* double-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfDouble(
Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
char buffer[TCL_DOUBLE_SPACE];
int len;
Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer);
len = strlen(buffer);
objPtr->bytes = (char *)ckalloc(len + 1);
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewIntObj to create a new integer object end up calling the
* debugging function Tcl_DbNewLongObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewIntObj result in a call to one of the two
* Tcl_NewIntObj implementations below. We provide two implementations so
* that the Tcl core can be compiled to do memory debugging of the core
* even if a client does not request it for itself.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
* checks whether the current value of the long can be represented by an
* int.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_NewIntObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewIntObj(
int intValue) /* Int used to initialize the new object. */
{
return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewIntObj(
int intValue) /* Int used to initialize the new object. */
{
Tcl_Obj *objPtr;
TclNewIntObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetIntObj --
*
* Modify an object to be an integer and to have the specified integer
* value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
int intValue) /* Integer used to set object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetIntObj");
}
TclSetIntObj(objPtr, intValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntFromObj --
*
* Retrieve the integer value of 'objPtr'.
*
* Value
*
* TCL_OK
*
* Success.
*
* TCL_ERROR
*
* An error occurred during conversion or the integral value can not
* be represented as an integer (it might be too large). An error
* message is left in the interpreter's result if 'interp' is not
* NULL.
*
* Effect
*
* 'objPtr' is converted to an integer if necessary if it is not one
* already. The conversion frees any previously-existing internal
* representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a int. */
int *intPtr) /* Place to store resulting int. */
{
#if (LONG_MAX == INT_MAX)
return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
#else
long l;
if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) {
if (interp != NULL) {
const char *s =
"integer value too large to represent as non-long integer";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
*intPtr = (int) l;
return TCL_OK;
#endif
}
/*
*----------------------------------------------------------------------
*
* SetIntFromAny --
*
* Attempts to force the internal representation for a Tcl object to
* tclIntType, specifically.
*
* Results:
* The return value is a standard object Tcl result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
*----------------------------------------------------------------------
*/
static int
SetIntFromAny(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
long l;
return TclGetLongFromObj(interp, objPtr, &l);
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfInt --
*
* Update the string representation for an integer object. Note: This
* function does not free an existing old string rep so storage will be
* lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from the
* int-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char buffer[TCL_INTEGER_SPACE];
int len;
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
objPtr->bytes = (char *)ckalloc(len + 1);
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewLongObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewLongObj to create a new long integer object end up calling the
* debugging function Tcl_DbNewLongObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewLongObj result in a call to one of the two
* Tcl_NewLongObj implementations below. We provide two implementations
* so that the Tcl core can be compiled to do memory debugging of the
* core even if a client does not request it for itself.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
* checks whether the current value of the long can be represented by an
* int.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewLongObj
Tcl_Obj *
Tcl_NewLongObj(
long longValue) /* Long integer used to initialize the
* new object. */
{
return Tcl_DbNewLongObj(longValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewLongObj(
long longValue) /* Long integer used to initialize the
* new object. */
{
Tcl_Obj *objPtr;
TclNewLongObj(objPtr, longValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewLongObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer
* objects end up calling the debugging function Tcl_DbNewLongObj
* instead. We provide two implementations of Tcl_DbNewLongObj so that
* whether the Tcl core is compiled to do memory debugging of the core is
* independent of whether a client requests debugging for itself.
*
* When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj
* calls Tcl_DbCkalloc directly with the file name and line number from
* its caller. This simplifies debugging since then the [memory active]
* command will report the caller's file name and line number when
* reporting objects that haven't been freed.
*
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
* this function just returns the result of calling Tcl_NewLongObj.
*
* Results:
* The newly created long integer object is returned. This object will
* have an invalid string representation. The returned object has ref
* count 0.
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewLongObj(
long longValue, /* Long integer used to initialize the new
* object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = longValue;
objPtr->typePtr = &tclIntType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewLongObj(
long longValue, /* Long integer used to initialize the new
* object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
return Tcl_NewLongObj(longValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetLongObj --
*
* Modify an object to be an integer object and to have the specified
* long integer value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetLongObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
long longValue) /* Long integer used to initialize the
* object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetLongObj");
}
TclSetLongObj(objPtr, longValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetLongFromObj --
*
* Attempt to return an long integer from the Tcl object "objPtr". If the
* object is not already an int object, an attempt will be made to
* convert it to one.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If the object is not already an int object, the conversion will free
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a long. */
long *longPtr) /* Place to store resulting long. */
{
do {
if (objPtr->typePtr == &tclIntType) {
*longPtr = objPtr->internalRep.longValue;
return TCL_OK;
}
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
/*
* We return any integer in the range -ULONG_MAX to ULONG_MAX
* converted to a long, ignoring overflow. The rule preserves
* existing semantics for conversion of integers on input, but
* avoids inadvertent demotion of wide integers to 32-bit ones in
* the internal rep.
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
if (w >= -(Tcl_WideInt)(ULONG_MAX)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = Tcl_WideAsLong(w);
return TCL_OK;
}
goto tooLarge;
}
#endif
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a long, even
* when auto-narrowing is enabled. Only those values in the signed
* long range get auto-narrowed to tclIntType, while all the
* values in the unsigned long range will fit in a long.
*/
mp_int big;
UNPACK_BIGNUM(objPtr, big);
if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1)
/ MP_DIGIT_BIT) {
unsigned long value = 0;
size_t numBytes;
long scratch;
unsigned char *bytes = (unsigned char *) &scratch;
if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
*longPtr = - (long) value;
} else {
*longPtr = (long) value;
}
return TCL_OK;
}
}
#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
*
* UpdateStringOfWideInt --
*
* Update the string representation for a wide integer object. Note: this
* function does not free an existing old string rep so storage will be
* lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from the
* wideInt-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfWideInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char buffer[TCL_INTEGER_SPACE+2];
unsigned len;
Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
/*
* Note that sprintf will generate a compiler warning under Mingw claiming
* %I64 is an unknown format specifier. Just ignore this warning. We can't
* use %L as the format specifier since that gets printed as a 32 bit
* value.
*/
sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
len = strlen(buffer);
objPtr->bytes = (char *)ckalloc(len + 1);
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
*
* Tcl_NewWideIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewWideIntObj to create a new 64-bit integer object end up calling
* the debugging function Tcl_DbNewWideIntObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewWideIntObj result in a call to one of the two
* Tcl_NewWideIntObj implementations below. We provide two
* implementations so that the Tcl core can be compiled to do memory
* debugging of the core even if a client does not request it for itself.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewWideIntObj
Tcl_Obj *
Tcl_NewWideIntObj(
Tcl_WideInt wideValue)
/* Wide integer used to initialize the new
* object. */
{
return Tcl_DbNewWideIntObj(wideValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewWideIntObj(
Tcl_WideInt wideValue)
/* Wide integer used to initialize the new
* object. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetWideIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewWideIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewWideIntObj to create new wide integer end up calling the
* debugging function Tcl_DbNewWideIntObj instead. We provide two
* implementations of Tcl_DbNewWideIntObj so that whether the Tcl core is
* compiled to do memory debugging of the core is independent of whether
* a client requests debugging for itself.
*
* When the core is compiled with TCL_MEM_DEBUG defined,
* Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file name
* and line number from its caller. This simplifies debugging since then
* the checkmem command will report the caller's file name and line
* number when reporting objects that haven't been freed.
*
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
* this function just returns the result of calling Tcl_NewWideIntObj.
*
* Results:
* The newly created wide integer object is returned. This object will
* have an invalid string representation. The returned object has ref
* count 0.
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue,
/* Wide integer used to initialize the new
* object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
Tcl_SetWideIntObj(objPtr, wideValue);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue,
/* Long integer used to initialize the new
* object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
return Tcl_NewWideIntObj(wideValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetWideIntObj --
*
* Modify an object to be a wide integer object and to have the specified
* wide integer value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetWideIntObj(
Tcl_Obj *objPtr, /* Object w. internal rep to init. */
Tcl_WideInt wideValue)
/* Wide integer used to initialize the
* object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
if ((wideValue >= (Tcl_WideInt) LONG_MIN)
&& (wideValue <= (Tcl_WideInt) LONG_MAX)) {
TclSetLongObj(objPtr, (long) wideValue);
} else {
#ifndef TCL_WIDE_INT_IS_LONG
TclSetWideIntObj(objPtr, wideValue);
#else
mp_int big;
TclBNInitBignumFromWideInt(&big, wideValue);
Tcl_SetBignumObj(objPtr, &big);
#endif
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetWideIntFromObj --
*
* Attempt to return a wide integer from the Tcl object "objPtr". If the
* object is not already a wide int object, an attempt will be made to
* convert it to one.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If the object is not already an int object, the conversion will free
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
{
do {
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
#endif
if (objPtr->typePtr == &tclIntType) {
*wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideInt, even when auto-narrowing is enabled.
*/
mp_int big;
UNPACK_BIGNUM(objPtr, big);
if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt)
+ MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
Tcl_WideUInt value = 0;
size_t numBytes;
Tcl_WideInt scratch;
unsigned char *bytes = (unsigned char *) &scratch;
if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
*wideIntPtr = - (Tcl_WideInt) value;
} else {
*wideIntPtr = (Tcl_WideInt) value;
}
return TCL_OK;
}
}
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
*
* SetWideIntFromAny --
*
* Attempts to force the internal representation for a Tcl object to
* tclWideIntType, specifically.
*
* Results:
* The return value is a standard object Tcl result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
*----------------------------------------------------------------------
*/
static int
SetWideIntFromAny(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
Tcl_WideInt w;
return Tcl_GetWideIntFromObj(interp, objPtr, &w);
}
#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
*
* FreeBignum --
*
* This function frees the internal rep of a bignum.
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static void
FreeBignum(
Tcl_Obj *objPtr)
{
mp_int toFree; /* Bignum to free */
UNPACK_BIGNUM(objPtr, toFree);
mp_clear(&toFree);
if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
ckfree(objPtr->internalRep.twoPtrValue.ptr1);
}
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* DupBignum --
*
* This function duplicates the internal rep of a bignum.
*
* Results:
* None.
*
* Side effects:
* The destination object receies a copy of the source object
*
*----------------------------------------------------------------------
*/
static void
DupBignum(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
copyPtr->typePtr = &tclBignumType;
UNPACK_BIGNUM(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
PACK_BIGNUM(bignumCopy, copyPtr);
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfBignum --
*
* This function updates the string representation of a bignum object.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to whatever results from the bignum-
* to-string conversion.
*
* The object's existing string representation is NOT freed; memory will leak
* if the string rep is still valid at the time this function is called.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfBignum(
Tcl_Obj *objPtr)
{
mp_int bignumVal;
int size;
int status;
char *stringVal;
UNPACK_BIGNUM(objPtr, bignumVal);
status = mp_radix_size(&bignumVal, 10, &size);
if (status != MP_OKAY) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
if (size < 2) {
/*
* mp_radix_size() returns < 2 when more than INT_MAX bytes would be
* needed to hold the string rep (because mp_radix_size ignores
* integer overflow issues).
*
* Note that so long as we enforce our bignums to the size that fits
* in a packed bignum, this branch will never be taken.
*/
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
stringVal = (char *)ckalloc(size);
status = mp_to_radix(&bignumVal, stringVal, size, NULL, 10);
if (status != MP_OKAY) {
Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
objPtr->bytes = stringVal;
objPtr->length = size - 1; /* size includes a trailing NUL byte. */
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewBignumObj --
*
* Creates an initializes a bignum object.
*
* Results:
* Returns the newly created object.
*
* Side effects:
* The bignum value is cleared, since ownership has transferred to Tcl.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewBignumObj
Tcl_Obj *
Tcl_NewBignumObj(
mp_int *bignumValue)
{
return Tcl_DbNewBignumObj(bignumValue, "unknown", 0);
}
#else
Tcl_Obj *
Tcl_NewBignumObj(
mp_int *bignumValue)
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetBignumObj(objPtr, bignumValue);
return objPtr;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewBignumObj --
*
* This function is normally called when debugging: that is, when
* TCL_MEM_DEBUG is defined. It constructs a bignum object, recording the
* creation point so that [memory active] can report it.
*
* Results:
* Returns the newly created object.
*
* Side effects:
* The bignum value is cleared, since ownership has transferred to Tcl.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBignumObj(
mp_int *bignumValue,
const char *file,
int line)
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
Tcl_SetBignumObj(objPtr, bignumValue);
return objPtr;
}
#else
Tcl_Obj *
Tcl_DbNewBignumObj(
mp_int *bignumValue,
const char *file,
int line)
{
return Tcl_NewBignumObj(bignumValue);
}
#endif
/*
*----------------------------------------------------------------------
*
* GetBignumFromObj --
*
* This function retrieves a 'bignum' value from a Tcl object, converting
* the object if necessary. Either copies or transfers the mp_int value
* depending on the copy flag value passed in.
*
* Results:
* Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
*
* Side effects:
* A copy of bignum is stored in *bignumValue, which is expected to be
* uninitialized or cleared. If conversion fails, and the 'interp'
* argument is not NULL, an error message is stored in the interpreter
* result.
*
*----------------------------------------------------------------------
*/
static int
GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
int copy, /* Whether to copy the returned bignum value */
mp_int *bignumValue) /* Returned bignum value. */
{
do {
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
UNPACK_BIGNUM(objPtr, temp);
if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to unpack bignum", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
} else {
UNPACK_BIGNUM(objPtr, *bignumValue);
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
if (objPtr->bytes == NULL) {
TclInitStringRep(objPtr, tclEmptyStringRep, 0);
}
}
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
return TCL_OK;
}
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
TclBNInitBignumFromWideInt(bignumValue,
objPtr->internalRep.wideValue);
return TCL_OK;
}
#endif
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetBignumFromObj --
*
* This function retrieves a 'bignum' value from a Tcl object, converting
* the object if necessary.
*
* Results:
* Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
*
* Side effects:
* A copy of bignum is stored in *bignumValue, which is expected to be
* uninitialized or cleared. If conversion fails, an the 'interp'
* argument is not NULL, an error message is stored in the interpreter
* result.
*
* It is expected that the caller will NOT have invoked mp_init on the
* bignum value before passing it in. Tcl will initialize the mp_int as
* it sets the value. The value is a copy of the value in objPtr, so it
* becomes the responsibility of the caller to call mp_clear on it.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
mp_int *bignumValue) /* Returned bignum value. */
{
return GetBignumFromObj(interp, objPtr, 1, bignumValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_TakeBignumFromObj --
*
* This function retrieves a 'bignum' value from a Tcl object, converting
* the object if necessary.
*
* Results:
* Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
*
* Side effects:
* A copy of bignum is stored in *bignumValue, which is expected to be
* uninitialized or cleared. If conversion fails, an the 'interp'
* argument is not NULL, an error message is stored in the interpreter
* result.
*
* It is expected that the caller will NOT have invoked mp_init on the
* bignum value before passing it in. Tcl will initialize the mp_int as
* it sets the value. The value is transferred from the internals of
* objPtr to the caller, passing responsibility of the caller to call
* mp_clear on it. The objPtr is cleared to hold an empty value.
*
*----------------------------------------------------------------------
*/
int
Tcl_TakeBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
mp_int *bignumValue) /* Returned bignum value. */
{
return GetBignumFromObj(interp, objPtr, 0, bignumValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetBignumObj --
*
* This function sets the value of a Tcl_Obj to a large integer.
*
* Results:
* None.
*
* Side effects:
* Object value is stored. The bignum value is cleared, since ownership
* has transferred to Tcl.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetBignumObj(
Tcl_Obj *objPtr, /* Object to set */
mp_int *bignumValue) /* Value to store */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
}
if ((size_t) bignumValue->used
<= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
unsigned long value = 0;
size_t numBytes;
long scratch;
unsigned char *bytes = (unsigned char *) &scratch;
if (mp_to_ubin(bignumValue, bytes, sizeof(long), &numBytes) != MP_OKAY) {
goto tooLargeForLong;
}
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) {
goto tooLargeForLong;
}
if (bignumValue->sign) {
TclSetLongObj(objPtr, -(long)value);
} else {
TclSetLongObj(objPtr, (long)value);
}
mp_clear(bignumValue);
return;
}
tooLargeForLong:
#ifndef TCL_WIDE_INT_IS_LONG
if ((size_t) bignumValue->used
<= (CHAR_BIT * sizeof(Tcl_WideInt) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
Tcl_WideUInt value = 0;
size_t numBytes;
Tcl_WideInt scratch;
unsigned char *bytes = (unsigned char *)&scratch;
if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideInt), &numBytes) != MP_OKAY) {
goto tooLargeForWide;
}
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) {
goto tooLargeForWide;
}
if (bignumValue->sign) {
TclSetWideIntObj(objPtr, -(Tcl_WideInt)value);
} else {
TclSetWideIntObj(objPtr, (Tcl_WideInt)value);
}
mp_clear(bignumValue);
return;
}
tooLargeForWide:
#endif
TclInvalidateStringRep(objPtr);
TclFreeIntRep(objPtr);
TclSetBignumInternalRep(objPtr, bignumValue);
}
/*
*----------------------------------------------------------------------
*
* TclSetBignumInternalRep --
*
* Install a bignum into the internal representation of an object.
*
* Results:
* None.
*
* Side effects:
* Object internal representation is updated and object type is set. The
* bignum value is cleared, since ownership has transferred to the
* object.
*
*----------------------------------------------------------------------
*/
void
TclSetBignumInternalRep(
Tcl_Obj *objPtr,
mp_int *bignumValue)
{
objPtr->typePtr = &tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
/*
* Clear the mp_int value.
*
* Don't call mp_clear() because it would free the digit array we just
* packed into the Tcl_Obj.
*/
bignumValue->dp = NULL;
bignumValue->alloc = bignumValue->used = 0;
bignumValue->sign = MP_NEG;
}
/*
*----------------------------------------------------------------------
*
* TclGetNumberFromObj --
*
* Extracts a number (of any possible numeric type) from an object.
*
* Results:
* Whether the extraction worked. The type is stored in the variable
* referred to by the typePtr argument, and a pointer to the
* representation is stored in the variable referred to by the
* clientDataPtr.
*
* Side effects:
* Can allocate thread-specific data for handling the copy-out space for
* bignums; this space is shared within a thread.
*
*----------------------------------------------------------------------
*/
int
TclGetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
ClientData *clientDataPtr,
int *typePtr)
{
do {
if (objPtr->typePtr == &tclDoubleType) {
if (TclIsNaN(objPtr->internalRep.doubleValue)) {
*typePtr = TCL_NUMBER_NAN;
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_LONG;
*clientDataPtr = &objPtr->internalRep.longValue;
return TCL_OK;
}
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*typePtr = TCL_NUMBER_WIDE;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
#endif
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = Tcl_GetThreadData(&bignumKey,
(int) sizeof(mp_int));
UNPACK_BIGNUM(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
}
} while (TCL_OK ==
TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbIncrRefCount --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. This checks to see whether or not the memory
* has been freed before incrementing the ref count.
*
* When TCL_MEM_DEBUG is not defined, this function just increments the
* reference count of the object.
*
* Results:
* None.
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("incrementing refCount of previously disposed object");
}
# ifdef TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
* storage can be finalized before the last Tcl_Obj is freed.
*/
if (!TclInExit()) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
Tcl_HashEntry *hPtr;
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"incr ref count");
}
}
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */
++(objPtr)->refCount;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbDecrRefCount --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. This checks to see whether or not the memory
* has been freed before decrementing the ref count.
*
* When TCL_MEM_DEBUG is not defined, this function just decrements the
* reference count of the object.
*
* Results:
* None.
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("decrementing refCount of previously disposed object");
}
# ifdef TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
* storage can be finalized before the last Tcl_Obj is freed.
*/
if (!TclInExit()) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
Tcl_HashEntry *hPtr;
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"decr ref count");
}
}
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbIsShared --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It tests whether the object has a ref count
* greater than one.
*
* When TCL_MEM_DEBUG is not defined, this function just tests if the
* object has a ref count greater than one.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_DbIsShared(
Tcl_Obj *objPtr, /* The object to test for being shared. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("checking whether previously disposed object is shared");
}
# ifdef TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
* storage can be finalized before the last Tcl_Obj is freed.
*/
if (!TclInExit()) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
Tcl_HashEntry *hPtr;
if (!tablePtr) {
Tcl_Panic("object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"check shared status");
}
}
# endif /* TCL_THREADS */
#endif /* TCL_MEM_DEBUG */
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
if ((objPtr)->refCount <= 1) {
tclObjsShared[1]++;
} else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
tclObjsShared[(objPtr)->refCount]++;
} else {
tclObjsShared[0]++;
}
Tcl_MutexUnlock(&tclObjMutex);
#endif /* TCL_COMPILE_STATS */
return ((objPtr)->refCount > 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitObjHashTable --
*
* Given storage for a hash table, set up the fields to prepare the hash
* table for use, the keys are Tcl_Obj *.
*
* Results:
* None.
*
* Side effects:
* TablePtr is now ready to be passed to Tcl_FindHashEntry and
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitObjHashTable(
Tcl_HashTable *tablePtr)
/* Pointer to table record, which is supplied
* by the caller. */
{
Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
&tclObjHashKeyType);
}
/*
*----------------------------------------------------------------------
*
* AllocObjEntry --
*
* Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key.
*
* Results:
* The return value is a pointer to the created entry.
*
* Side effects:
* Increments the reference count on the object.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocObjEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
hPtr->clientData = NULL;
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* TclCompareObjKeys --
*
* Compares two Tcl_Obj * keys.
*
* Results:
* The return value is 0 if they are different and 1 if they are the
* same.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
Tcl_Obj *objPtr1 = keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
const char *p1, *p2;
size_t l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
if (objPtr1 == objPtr2) return 1;
*/
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
* in a register.
*/
p1 = TclGetString(objPtr1);
l1 = objPtr1->length;
p2 = TclGetString(objPtr2);
l2 = objPtr2->length;
/*
* Only compare if the string representations are of the same length.
*/
if (l1 == l2) {
for (;; p1++, p2++, l1--) {
if (*p1 != *p2) {
break;
}
if (l1 == 0) {
return 1;
}
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclFreeObjEntry --
*
* Frees space for a Tcl_HashEntry containing the Tcl_Obj * key.
*
* Results:
* The return value is a pointer to the created entry.
*
* Side effects:
* Decrements the reference count of the object.
*
*----------------------------------------------------------------------
*/
void
TclFreeObjEntry(
Tcl_HashEntry *hPtr) /* Hash entry to free. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
ckfree(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclHashObjKey --
*
* Compute a one-word summary of the string representation of the
* Tcl_Obj, which can be used to generate a hash index.
*
* Results:
* The return value is a one-word summary of the information in the
* string representation of the Tcl_Obj.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
unsigned int
TclHashObjKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
Tcl_Obj *objPtr = keyPtr;
int length;
const char *string = TclGetStringFromObj(objPtr, &length);
unsigned int result = 0;
/*
* I tried a zillion different hash functions and asked many other people
* for advice. Many people had their own favorite functions, all
* different, but no-one had much idea why they were good ones. I chose
* the one below (multiply by 9 and add new character) because of the
* following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings, and
* multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
* character's bits hang around in the low-order bits of the hash value
* for ever, plus they spread fairly rapidly up to the high-order bits
* to fill out the hash value. This seems works well both for decimal
* and non-decimal strings.
*
* Note that this function is very weak against malicious strings; it's
* very easy to generate multiple keys that have the same hashcode. On the
* other hand, that hardly ever actually occurs and this function *is*
* very cheap, even by comparison with industry-standard hashes like FNV.
* If real strength of hash is required though, use a custom hash based on
* Bob Jenkins's lookup3(), but be aware that it's significantly slower.
* Tcl does not use that level of strength because it typically does not
* need it (and some of the aspects of that strength are genuinely
* unnecessary given the rest of Tcl's hash machinery, and the fact that
* we do not either transfer hashes to another machine, use them as a true
* substitute for equality, or attempt to minimize work in rebuilding the
* hash table).
*
* See also HashStringKey in tclHash.c.
* See also HashString in tclLiteral.c.
*
* See [tcl-Feature Request #2958832]
*/
if (length > 0) {
result = UCHAR(*string);
while (--length) {
result += (result << 3) + UCHAR(*++string);
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandFromObj --
*
* Returns the command specified by the name in a Tcl_Obj.
*
* Results:
* Returns a token for the command if it is found. Otherwise, if it can't
* be found or there is an error, returns NULL.
*
* Side effects:
* May update the internal representation for the object, caching the
* command reference so that the next time this function is called with
* the same object, the command can be found quickly.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_GetCommandFromObj(
Tcl_Interp *interp, /* The interpreter in which to resolve the
* command and to report errors. */
Tcl_Obj *objPtr) /* The object containing the command's name.
* If the name starts with "::", will be
* looked up in global namespace. Else, looked
* up first in the current namespace, then in
* global namespace. */
{
ResolvedCmdName *resPtr;
/*
* Get the internal representation, converting to a command type if
* needed. The internal representation is a ResolvedCmdName that points to
* the actual command.
*
* Check the context namespace and the namespace epoch of the resolved
* symbol to make sure that it is fresh. Note that we verify that the
* namespace id of the context namespace is the same as the one we cached;
* this insures that the namespace wasn't deleted and a new one created at
* the same address with the same command epoch. Note that fully qualified
* names have a NULL refNsPtr, these checks needn't be made.
*
* Check also that the command's epoch is up to date, and that the command
* is not deleted.
*
* If any check fails, then force another conversion to the command type,
* to discard the old rep and create a new one.
*/
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
&& !(cmdPtr->flags & CMD_IS_DELETED)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
Namespace *refNsPtr = (Namespace *)
TclGetCurrentNamespace(interp);
if ((resPtr->refNsPtr == NULL)
|| ((refNsPtr == resPtr->refNsPtr)
&& (resPtr->refNsId == refNsPtr->nsId)
&& (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) {
return (Tcl_Command) cmdPtr;
}
}
}
/*
* OK, must create a new internal representation (or fail) as any cache we
* had is invalid one way or another.
*/
/* See [] why we cannot call SetCmdNameFromAny() directly here. */
if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
return NULL;
}
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}
/*
*----------------------------------------------------------------------
*
* TclSetCmdNameObj --
*
* Modify an object to be an CmdName object that refers to the argument
* Command structure.
*
* Results:
* None.
*
* Side effects:
* The object's old internal rep is freed. It's string rep is not
* changed. The refcount in the Command structure is incremented to keep
* it from being freed if the command is later deleted until
* TclNRExecuteByteCode has a chance to recognize that it was deleted.
*
*----------------------------------------------------------------------
*/
void
TclSetCmdNameObj(
Tcl_Interp *interp, /* Points to interpreter containing command
* that should be cached in objPtr. */
Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
* CmdName object. */
Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
Interp *iPtr = (Interp *) interp;
ResolvedCmdName *resPtr;
Namespace *currNsPtr;
const char *name;
if (objPtr->typePtr == &tclCmdNameType) {
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
return;
}
}
cmdPtr->refCount++;
resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
name = TclGetString(objPtr);
if ((*name++ == ':') && (*name == ':')) {
/*
* The name is fully qualified: set the referring namespace to
* NULL.
*/
resPtr->refNsPtr = NULL;
} else {
/*
* Get the current namespace.
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
}
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
/*
*----------------------------------------------------------------------
*
* FreeCmdNameInternalRep --
*
* Frees the resources associated with a cmdName object's internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Decrements the ref count of any cached ResolvedCmdName structure
* pointed to by the cmdName's internal representation. If this is the
* last use of the ResolvedCmdName, it is freed. This in turn decrements
* the ref count of the Command structure pointed to by the
* ResolvedSymbol, which may free the Command structure.
*
*----------------------------------------------------------------------
*/
static void
FreeCmdNameInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
*/
if (resPtr->refCount-- == 1) {
/*
* Now free the cached command, unless it is still in its hash
* table or if there are other references to it from other cmdName
* objects.
*/
Command *cmdPtr = resPtr->cmdPtr;
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
}
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* DupCmdNameInternalRep --
*
* Initialize the internal representation of an cmdName Tcl_Obj to a copy
* of the internal representation of an existing cmdName object.
*
* Results:
* None.
*
* Side effects:
* "copyPtr"s internal rep is set to point to the ResolvedCmdName
* structure corresponding to "srcPtr"s internal rep. Increments the ref
* count of the ResolvedCmdName structure pointed to by the cmdName's
* internal representation.
*
*----------------------------------------------------------------------
*/
static void
DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
}
copyPtr->typePtr = &tclCmdNameType;
}
/*
*----------------------------------------------------------------------
*
* SetCmdNameFromAny --
*
* Generate an cmdName internal form for the Tcl object "objPtr".
*
* Results:
* The return value is a standard Tcl result. The conversion always
* succeeds and TCL_OK is returned.
*
* Side effects:
* A pointer to a ResolvedCmdName structure that holds a cached pointer
* to the command with a name that matches objPtr's string rep is stored
* as objPtr's internal representation. This ResolvedCmdName pointer will
* be NULL if no matching command was found. The ref count of the cached
* Command's structure (if any) is also incremented.
*
*----------------------------------------------------------------------
*/
static int
SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Command *cmdPtr;
Namespace *currNsPtr;
ResolvedCmdName *resPtr;
if (interp == NULL) {
return TCL_ERROR;
}
/*
* Find the Command structure, if any, that describes the command called
* "name". Build a ResolvedCmdName that holds a cached pointer to this
* Command, and bump the reference count in the referenced Command
* structure. A Command structure will not be deleted as long as it is
* referenced from a CmdName object.
*/
name = TclGetString(objPtr);
cmdPtr = (Command *)
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
* Free the old internalRep before setting the new one. Do this after
* getting the string rep to allow the conversion code (in particular,
* Tcl_GetStringFromObj) to use that old internalRep.
*/
if (cmdPtr) {
cmdPtr->refCount++;
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType)
&& resPtr && (resPtr->refCount == 1)) {
/*
* Reuse the old ResolvedCmdName struct instead of freeing it
*/
Command *oldCmdPtr = resPtr->cmdPtr;
if (--oldCmdPtr->refCount == 0) {
TclCleanupCommandMacro(oldCmdPtr);
}
} else {
TclFreeIntRep(objPtr);
resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
resPtr->refCount = 1;
objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
resPtr->cmdPtr = cmdPtr;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
if ((*name++ == ':') && (*name == ':')) {
/*
* The name is fully qualified: set the referring namespace to
* NULL.
*/
resPtr->refNsPtr = NULL;
} else {
/*
* Get the current namespace.
*/
currNsPtr = iPtr->varFramePtr->nsPtr;
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
}
} else {
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RepresentationCmd --
*
* Implementation of the "tcl::unsupported::representation" command.
*
* Results:
* Reports the current representation (Tcl_Obj type) of its argument.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_RepresentationCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
char ptrBuffer[2*TCL_INTEGER_SPACE+6];
Tcl_Obj *descObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
/*
* Value is a bignum with a refcount of 14, object pointer at 0x12345678,
* internal representation 0x45671234:0x98765432, string representation
* "1872361827361287"
*/
sprintf(ptrBuffer, "%p", (void *) objv[1]);
descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d,"
" object pointer at %s",
objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
objv[1]->refCount, ptrBuffer);
/*
* This is a workaround to silence reports from `make valgrind`
* on 64-bit systems. The problem is that the test suite
* includes calling the [represenation] command on values of
* &tclDoubleType. When these values are created, the "doubleValue"
* is set, but when the "twoPtrValue" is examined, its "ptr2"
* field has never been initialized. Since [representation]
* presents the value of the ptr2 value in its output, valgrind
* alerts about the read of uninitialized memory.
*
* The general problem with [representation], that it can read
* and report uninitialized fields, is still present. This is
* just the minimal workaround to silence one particular test.
*/
if ((sizeof(void *) > 4) && objv[1]->typePtr == &tclDoubleType) {
objv[1]->internalRep.twoPtrValue.ptr2 = NULL;
}
if (objv[1]->typePtr) {
sprintf(ptrBuffer, "%p:%p",
(void *) objv[1]->internalRep.twoPtrValue.ptr1,
(void *) objv[1]->internalRep.twoPtrValue.ptr2);
Tcl_AppendPrintfToObj(descObj, ", internal representation %s",
ptrBuffer);
}
if (objv[1]->bytes) {
Tcl_AppendToObj(descObj, ", string representation \"", -1);
Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
16, "...");
Tcl_AppendToObj(descObj, "\"", -1);
} else {
Tcl_AppendToObj(descObj, ", no string representation", -1);
}
Tcl_SetObjResult(interp, descObj);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
Reference in New Issue View Git Blame Copy Permalink