/*
 * tclObj.c --
 *
 *	This file contains Tcl object-related functions that are used by many
 *	Tcl commands.
 *
 * Copyright © 1995-1997 Sun Microsystems, Inc.
 * Copyright © 1999 Scriptics Corporation.
 * Copyright © 2001 ActiveState Corporation.
 * Copyright © 2005 Kevin B. Kenny.  All rights reserved.
 * Copyright © 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 "tclTomMath.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.
 */

#if 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';

#if TCL_THREADS && defined(TCL_MEM_DEBUG)
/*
 * 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 {
    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 {
    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 occurred 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 TCL_THREADS && defined(TCL_MEM_DEBUG)
    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(void *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 invocations 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
				 * invocation 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.
 */
#if !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 = (PendingObjData *)		\
	    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 *)Tcl_Alloc(sizeof(mp_int));		\
	*temp = bignum;							\
	(objPtr)->internalRep.twoPtrValue.ptr1 = temp;			\
	(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1);		\
    } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \
	(objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp;		\
	(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \
		| ((bignum).alloc << 15) | ((bignum).used));		\
    }

/*
 * 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);
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.
 */

const Tcl_ObjType tclBooleanType= {
    "boolean",
    NULL,			// FreeIntRep
    NULL,			// DupIntRep
    NULL,			// UpdateString
    TclSetBooleanFromAny,
    TCL_OBJTYPE_V1(TclLengthOne)
};
const Tcl_ObjType tclDoubleType= {
    "double",
    NULL,			// FreeIntRep
    NULL,			// DupIntRep
    UpdateStringOfDouble,
    SetDoubleFromAny,
    TCL_OBJTYPE_V1(TclLengthOne)
};
const Tcl_ObjType tclIntType = {
    "int",
    NULL,			// FreeIntRep
    NULL,			// DupIntRep
    UpdateStringOfInt,
    SetIntFromAny,
    TCL_OBJTYPE_V1(TclLengthOne)
};
const Tcl_ObjType tclBignumType = {
    "bignum",
    FreeBignum,
    DupBignum,
    UpdateStringOfBignum,
    NULL,			// SetFromAny
    TCL_OBJTYPE_V1(TclLengthOne)
};

/*
 * The structure below defines the Tcl obj hash key type.
 */

const Tcl_HashKeyType tclObjHashKeyType = {
    TCL_HASH_KEY_TYPE_VERSION,	/* version */
    TCL_HASH_KEY_DIRECT_COMPARE,/* allows compare keys by pointers */
    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",
    FreeCmdNameInternalRep,
    DupCmdNameInternalRep,
    NULL,			// UpdateString
    SetCmdNameFromAny,
    TCL_OBJTYPE_V0
};

/*
 * 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.*/
    size_t 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). */
    Tcl_Size 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. */
    Tcl_Size 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. */
    size_t 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;

#ifdef TCL_MEM_DEBUG
/*
 * Filler matches the value used for filling freed memory in tclCkalloc.
 * On 32-bit systems, the ref counts do not cross 0x7fffffff. On 64-bit
 * implementations, ref counts will never reach this value (unless explicitly
 * incremented without actual references!)
 */
#define FREEDREFCOUNTFILLER \
    (Tcl_Size)(sizeof(objPtr->refCount) == 4 ? 0xe8e8e8e8 : 0xe8e8e8e8e8e8e8e8)
#endif

/*
 *-------------------------------------------------------------------------
 *
 * 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(&tclByteCodeType);
    Tcl_RegisterObjType(&tclCmdNameType);
    Tcl_RegisterObjType(&tclDictType);
    Tcl_RegisterObjType(&tclDoubleType);
    Tcl_RegisterObjType(&tclListType);
    Tcl_RegisterObjType(&tclProcBodyType);
    Tcl_RegisterObjType(&tclRegexpType);
    Tcl_RegisterObjType(&tclStringType);

#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 TCL_THREADS && defined(TCL_MEM_DEBUG)
    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 = (ObjData *)Tcl_GetHashValue(hPtr);

	    if (objData != NULL) {
		Tcl_Free(objData);
	    }
	}

	Tcl_DeleteHashTable(tablePtr);
	Tcl_Free(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 *)Tcl_Alloc(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,
    Tcl_Size num,
    Tcl_Size *loc)
{
    int newEntry;
    ThreadSpecificData *tsdPtr = TclGetContLineTable();
    Tcl_HashEntry *hPtr =
	    Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
    ContLineLoc *clLocPtr = (ContLineLoc *)
	    Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size));

    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 occurrences.
	 *
	 * 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.
	 */

	Tcl_Free(Tcl_GetHashValue(hPtr));
    }

    clLocPtr->num = num;
    memcpy(&clLocPtr->loc, loc, num*sizeof(Tcl_Size));
    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,
    Tcl_Size start,
    Tcl_Size *clNext)
{
    Tcl_Size length;
    Tcl_Size end, num;
    Tcl_Size *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?)
     */

    (void)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) {
	Tcl_Size 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 = (ContLineLoc *)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 (ContLineLoc *)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(
    TCL_UNUSED(void *))
{
    /*
     * 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)) {
	Tcl_Free(Tcl_GetHashValue(hPtr));
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
    Tcl_Free(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). */
{
    Tcl_MutexLock(&tableMutex);
    Tcl_SetHashValue(
	    Tcl_CreateHashEntry(&typeTable, typePtr->name, NULL), 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;
    Tcl_Size 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((char *)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 = (const Tcl_ObjType *)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", (char *)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.
 *
 *--------------------------------------------------------------
 */

#if TCL_THREADS && defined(TCL_MEM_DEBUG)
void
TclDbDumpActiveObjects(
    FILE *outFile)
{
    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: %" TCL_SIZE_MODIFIER "d\n", tablePtr->numEntries);
	for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
		hPtr = Tcl_NextHashEntry(&hSearch)) {
	    ObjData *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));
	    }
	}
    }
}
#else
void
TclDbDumpActiveObjects(
    TCL_UNUSED(FILE *))
{
}
#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. Initialization 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->typePtr = NULL;
    TclInitEmptyStringRep(objPtr);

#if 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;
	ObjData *objData;
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	if (tsdPtr->objThreadMap == NULL) {
	    tsdPtr->objThreadMap = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
	    Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
	}
	tablePtr = tsdPtr->objThreadMap;
	hPtr = Tcl_AttemptCreateHashEntry(tablePtr, objPtr, NULL);
	if (!hPtr) {
	    /* This is just for debugging, in case of memory problem just remove it */
	    Tcl_DeleteHashTable(tsdPtr->objThreadMap);
	    Tcl_Free(tsdPtr->objThreadMap);
	    tsdPtr->objThreadMap = NULL;
	}

	/*
	 * Record the debugging information.
	 */

	objData = (ObjData *)Tcl_Alloc(sizeof(ObjData));
	objData->objPtr = objPtr;
	objData->file = file;
	objData->line = line;
	if (hPtr) {
	    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(
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    Tcl_Obj *objPtr;
    TclNewObj(objPtr);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclAllocateFreeObjects --
 *
 *	Function to allocate a number of free Tcl_Objs. This is done using a
 *	single Tcl_Alloc 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 Tcl_Free() 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 *)Tcl_Alloc(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);

#if 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("%s: object table not initialized", "TclFreeObj");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (hPtr) {
	    /*
	     * As the Tcl_Obj is going to be deleted we remove the entry.
	     */

	    ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);

	    if (objData != NULL) {
		Tcl_Free(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 = TCL_INDEX_NONE;

    /*
     * 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 == TCL_INDEX_NONE'.
     */

    TclInvalidateStringRep(objPtr);
    objPtr->length = TCL_INDEX_NONE;

    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);
	Tcl_Free(objPtr);
	Tcl_MutexUnlock(&tclObjMutex);
	TclIncrObjsFreed();
	ObjDeletionLock(context);
	while (ObjOnStack(context)) {
	    Tcl_Obj *objToFree;

	    PopObjToDelete(context, objToFree);
	    TCL_DTRACE_OBJ_FREE(objToFree);
	    TclFreeInternalRep(objToFree);

	    Tcl_MutexLock(&tclObjMutex);
	    Tcl_Free(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 uninitialized 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) {
		Tcl_Free(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 = TCL_INDEX_NONE;

    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 uninitialized 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) {
		Tcl_Free(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 == TCL_INDEX_NONE;
}

/*
 *----------------------------------------------------------------------
 *
 * 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);
    TclFreeInternalRep(dupPtr);
    SetDuplicateObj(dupPtr, objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStringFromObj/TclGetStringFromObj --
 *
 *	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.
 *
 *----------------------------------------------------------------------
 */

#ifndef TCL_NO_DEPRECATED
#undef TclGetStringFromObj
char *
TclGetStringFromObj(
    Tcl_Obj *objPtr,		/* Object whose string rep byte pointer should
				 * be returned. */
    void *lengthPtr)		/* If non-NULL, the location where the string
				 * rep's byte array length should * be stored.
				 * If NULL, no length is stored. */
{
    if (objPtr->bytes == NULL) {
	/*
	 * 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.
	     */
	    Tcl_Panic("UpdateStringProc should not be invoked for type %s",
		    objPtr->typePtr->name);
	}
	objPtr->typePtr->updateStringProc(objPtr);
	if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE
		|| objPtr->bytes[objPtr->length] != '\0') {
	    Tcl_Panic("UpdateStringProc for type '%s' "
		    "failed to create a valid string rep",
		    objPtr->typePtr->name);
	}
    }
    if (lengthPtr != NULL) {
	if (objPtr->length > INT_MAX) {
	    Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr"
		    " cannot handle such long strings. Please use 'Tcl_Size'");
	}
	*(int *)lengthPtr = (int)objPtr->length;
    }
    return objPtr->bytes;
}
#endif /* !TCL_NO_DEPRECATED */

#undef Tcl_GetStringFromObj
char *
Tcl_GetStringFromObj(
    Tcl_Obj *objPtr,		/* Object whose string rep byte pointer should
				 * be returned. */
    Tcl_Size *lengthPtr)	/* If non-NULL, the location where the string
				 * rep's byte array length should * be stored.
				 * If NULL, no length is stored. */
{
    if (objPtr->bytes == NULL) {
	/*
	 * 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.
	     */
	    Tcl_Panic("UpdateStringProc should not be invoked for type %s",
		    objPtr->typePtr->name);
	}
	objPtr->typePtr->updateStringProc(objPtr);
	if (objPtr->bytes == NULL
		|| objPtr->bytes[objPtr->length] != '\0') {
	    Tcl_Panic("UpdateStringProc for type '%s' "
		    "failed to create a valid string rep",
		    objPtr->typePtr->name);
	}
    }
    if (lengthPtr != NULL) {
	*lengthPtr = objPtr->length;
    }
    return objPtr->bytes;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitStringRep --
 *
 *	This function is called in several configurations to provide all
 *	the tools needed to set an object's string representation. The
 *	function is determined by the arguments.
 *
 *	(objPtr->bytes != NULL && bytes != NULL) || (numBytes == -1)
 *	    Invalid call -- panic!
 *
 *	objPtr->bytes == NULL && bytes == NULL && numBytes != -1
 *	    Allocation only - allocate space for (numBytes+1) chars.
 *	    store in objPtr->bytes and return. Also sets
 *	    objPtr->length to 0 and objPtr->bytes[0] to NUL.
 *
 *	objPtr->bytes == NULL && bytes != NULL && numBytes != -1
 *	    Allocate and copy. bytes is assumed to point to chars to
 *	    copy into the string rep. objPtr->length = numBytes. Allocate
 *	    array of (numBytes + 1) chars. store in objPtr->bytes. Copy
 *	    numBytes chars from bytes to objPtr->bytes; Set
 *	    objPtr->bytes[numBytes] to NUL and return objPtr->bytes.
 *	    Caller must guarantee there are numBytes chars at bytes to
 *	    be copied.
 *
 *	objPtr->bytes != NULL && bytes == NULL && numBytes != -1
 *	    Truncate.  Set objPtr->length to numBytes and
 *	    objPr->bytes[numBytes] to NUL.  Caller has to guarantee
 *	    that a prior allocating call allocated enough bytes for
 *	    this to be valid. Return objPtr->bytes.
 *
 *	Caller is expected to ascertain that the bytes copied into
 *	the string rep make up complete valid UTF-8 characters.
 *
 * Results:
 *	A pointer to the string rep of objPtr.
 *
 * Side effects:
 *	As described above.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_InitStringRep(
    Tcl_Obj *objPtr,		/* Object whose string rep is to be set */
    const char *bytes,
    size_t numBytes)
{
    assert(objPtr->bytes == NULL || bytes == NULL);

    if (objPtr->bytes == NULL) {
	/* Start with no string rep */
	if (numBytes == 0) {
	    TclInitEmptyStringRep(objPtr);
	    return objPtr->bytes;
	} else {
	    objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1);
	    if (objPtr->bytes) {
		objPtr->length = numBytes;
		if (bytes) {
		    memcpy(objPtr->bytes, bytes, numBytes);
		}
		objPtr->bytes[objPtr->length] = '\0';
	    }
	}
    } else if (objPtr->bytes == &tclEmptyString) {
	/* Start with empty string rep (not allocated) */
	if (numBytes == 0) {
	    return objPtr->bytes;
	} else {
	    objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1);
	    if (objPtr->bytes) {
		objPtr->length = numBytes;
		objPtr->bytes[objPtr->length] = '\0';
	    }
	}
    } else {
	/* Start with non-empty string rep (allocated) */
	if (numBytes == 0) {
	    Tcl_Free(objPtr->bytes);
	    TclInitEmptyStringRep(objPtr);
	    return objPtr->bytes;
	} else {
	    objPtr->bytes = (char *)Tcl_AttemptRealloc(objPtr->bytes,
		    numBytes + 1);
	    if (objPtr->bytes) {
		objPtr->length = numBytes;
		objPtr->bytes[objPtr->length] = '\0';
	    }
	}
    }

    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_HasStringRep --
 *
 *	This function reports whether object has a string representation.
 *
 * Results:
 *	Boolean.
 *----------------------------------------------------------------------
 */

int
Tcl_HasStringRep(
    Tcl_Obj *objPtr)		/* Object to test */
{
    return TclHasStringRep(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StoreInternalRep --
 *
 *	Called to set the object's internal representation to match a
 *	particular type.
 *
 *	It is the caller's responsibility to guarantee that
 *	the value of the submitted internalrep is in agreement with
 *	the value of any existing string rep.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Calls the freeIntRepProc of the current Tcl_ObjType, if any.
 *	Sets the internalRep and typePtr fields to the submitted values.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_StoreInternalRep(
    Tcl_Obj *objPtr,		/* Object whose internal rep should be set. */
    const Tcl_ObjType *typePtr,	/* New type for the object */
    const Tcl_ObjInternalRep *irPtr)	/* New internalrep for the object */
{
    /* Clear out any existing internalrep ( "shimmer" ) */
    TclFreeInternalRep(objPtr);

    /* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */
    if (irPtr) {
	/* Copy the new internalrep into place */
	objPtr->internalRep = *irPtr;

	/* Set the type to match */
	objPtr->typePtr = typePtr;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FetchInternalRep --
 *
 *	This function is called to retrieve the object's internal
 *	representation matching a requested type, if any.
 *
 * Results:
 *	A read-only pointer to the associated Tcl_ObjInternalRep, or
 *	NULL if no such internal representation exists.
 *
 * Side effects:
 *	Calls the freeIntRepProc of the current Tcl_ObjType, if any.
 *	Sets the internalRep and typePtr fields to the submitted values.
 *
 *----------------------------------------------------------------------
 */

Tcl_ObjInternalRep *
Tcl_FetchInternalRep(
    Tcl_Obj *objPtr,		/* Object to fetch from. */
    const Tcl_ObjType *typePtr)	/* Requested type */
{
    return TclFetchInternalRep(objPtr, typePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FreeInternalRep --
 *
 *	This function is called to free an object's internal representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Calls the freeIntRepProc of the current Tcl_ObjType, if any.
 *	Sets typePtr field to NULL.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FreeInternalRep(
    Tcl_Obj *objPtr)		/* Object whose internal rep should be freed. */
{
    TclFreeInternalRep(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetBoolFromObj, 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.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_GetBoolFromObj
int
Tcl_GetBoolFromObj(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* The object from which to get boolean. */
    int flags,
    char *charPtr)		/* Place to store resulting boolean. */
{
    int result;

    if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_IsEmpty(objPtr))) {
	result = -1;
	goto boolEnd;
    } else if (objPtr == NULL) {
	if (interp) {
	    TclNewObj(objPtr);
	    TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
		    ? "boolean value or \"\"" : "boolean value", NULL,
		    TCL_INDEX_NONE, NULL, 0);
	    Tcl_DecrRefCount(objPtr);
	}
	return TCL_ERROR;
    }
    do {
	if (TclHasInternalRep(objPtr, &tclIntType)
		|| TclHasInternalRep(objPtr, &tclBooleanType)) {
	    result = (objPtr->internalRep.wideValue != 0);
	    goto boolEnd;
	}
	if (TclHasInternalRep(objPtr, &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;
	    }
	    result = (d != 0.0);
	    goto boolEnd;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    result = 1;
	boolEnd:
	    if (charPtr != NULL) {
		flags &= (TCL_NULL_OK-2);
		if (flags) {
		    if (flags == (int)sizeof(int)) {
			*(int *)charPtr = result;
			return TCL_OK;
		    } else if (flags == (int)sizeof(short)) {
			*(short *)charPtr = (short)result;
			return TCL_OK;
		    } else {
			Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolFromObj");
		    }
		}
		*charPtr = (char)result;
	    }
	    return TCL_OK;
	}
    } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
	    TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
		    ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0)));
    return TCL_ERROR;
}

#undef Tcl_GetBooleanFromObj
int
Tcl_GetBooleanFromObj(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* The object from which to get boolean. */
    int *intPtr)		/* Place to store resulting boolean. */
{
    return Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof(int),
	    (char *)(void *)intPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * 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 or int.
 *
 *----------------------------------------------------------------------
 */

int
TclSetBooleanFromAny(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr)		/* The object to convert. */
{
    if (ParseBoolean(objPtr) == TCL_OK) {
	return TCL_OK;
    }

    if (interp != NULL) {
	Tcl_Obj *msg;

	TclNewLiteralStringObj(msg, "expected boolean value but got ");

	Tcl_Size argc;
	const char **argv = NULL;
	if (!objPtr->bytes || ((TclMaxListLength(objPtr->bytes, TCL_INDEX_NONE, NULL) > 1)
		&& Tcl_SplitList(NULL, objPtr->bytes, &argc, &argv) == TCL_OK)) {
	    if (argv) {
		Tcl_Free(argv);
	    }
	    Tcl_AppendToObj(msg, "a list", -1);
	} else {
	    Tcl_AppendToObj(msg, "\"", -1);
	    Tcl_AppendLimitedToObj(msg, objPtr->bytes, objPtr->length, 50, "");
	    Tcl_AppendToObj(msg, "\"", -1);
	}
	Tcl_SetObjResult(interp, msg);
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (char *)NULL);
    }
    return TCL_ERROR;
}

static int
ParseBoolean(
    Tcl_Obj *objPtr)		/* The object to parse/convert. */
{
    int newBool;
    char lowerCase[6];
    Tcl_Size i, length;
    const char *str;

    /*
     * 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 (TclHasInternalRep(objPtr, &tclIntType)) {
	    if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) {
		return TCL_OK;
	    }
	    return TCL_ERROR;
	}

	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    return TCL_ERROR;
	}

	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    return TCL_ERROR;
	}
	/* Handle dict separately, because it doesn't have a lengthProc */
	if (TclHasInternalRep(objPtr, &tclDictType)) {
	    Tcl_DictObjSize(NULL, objPtr, &length);
	    if (length > 0) {
		return TCL_ERROR;
	    }
	}
	Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
	if (lengthProc && lengthProc(objPtr) != 1) {
	    return TCL_ERROR;
	}
    }
    str = Tcl_GetStringFromObj(objPtr, &length);

    if ((length < 1) || (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:
    TclFreeInternalRep(objPtr);
    objPtr->internalRep.wideValue = newBool;
    objPtr->typePtr = &tclBooleanType;
    return TCL_OK;

  numericBoolean:
    TclFreeInternalRep(objPtr);
    objPtr->internalRep.wideValue = 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);
    /* Optimized TclInvalidateStringRep() */
    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. */
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    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 (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (isnan(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",
			    (char *)NULL);
		}
		return TCL_ERROR;
	    }
	    *dblPtr = (double) objPtr->internalRep.doubleValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    *dblPtr = (double) objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    mp_int big;

	    TclUnpackBignum(objPtr, big);
	    *dblPtr = TclBignumToDouble(&big);
	    return TCL_OK;
	}
    } 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. 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 *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);

    TclOOM(dst, TCL_DOUBLE_SPACE + 1);

    Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
    (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
}

/*
 *----------------------------------------------------------------------
 *
 * 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 < INT_MIN))) {
	if (interp != NULL) {
	    const char *s =
		    "integer value too large to represent";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)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 */
{
    Tcl_WideInt w;
    return TclGetWideIntFromObj(interp, objPtr, &w);
}

/*
 *----------------------------------------------------------------------
 *
 * 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 *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);

    TclOOM(dst, TCL_INTEGER_SPACE + 1);
    (void) Tcl_InitStringRep(objPtr, NULL,
	    TclFormatInt(dst, objPtr->internalRep.wideValue));
}

/*
 *----------------------------------------------------------------------
 *
 * 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 {
#ifdef TCL_WIDE_INT_IS_LONG
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    *longPtr = objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
#else
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    /*
	     * We return any integer in the range LONG_MIN 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)(LONG_MIN)
		    && w <= (Tcl_WideInt)(ULONG_MAX)) {
		*longPtr = (long)w;
		return TCL_OK;
	    }
	    goto tooLarge;
	}
#endif
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"expected integer but got \"%s\"",
			TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	if (TclHasInternalRep(objPtr, &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;
	    unsigned long scratch, value = 0;
	    unsigned char *bytes = (unsigned char *) &scratch;
	    size_t numBytes;

	    TclUnpackBignum(objPtr, big);
	    if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
		while (numBytes-- > 0) {
		    value = (value << CHAR_BIT) | *bytes++;
		}
		if (big.sign) {
		    if (value <= 1 + (unsigned long)LONG_MAX) {
			*longPtr = (long)(-value);
			return TCL_OK;
		    }
		} else {
		    if (value <= (unsigned long)ULONG_MAX) {
			*longPtr = (long)value;
			return TCL_OK;
		    }
		}
	    }
	    goto tooLarge;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;

  tooLarge:
    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, (char *)NULL);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * 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);
    TclSetIntObj(objPtr, wideValue);
    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewWideUIntObj --
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_NewWideUIntObj(
    Tcl_WideUInt uwideValue)	/* Wide integer used to initialize the new
				 * object. */
{
    Tcl_Obj *objPtr;

    TclNewUIntObj(objPtr, uwideValue);
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * 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);
    if (objPtr) {
	TclSetIntObj(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. */
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    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");
    }

    TclSetIntObj(objPtr, wideValue);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetWideUIntObj --
 *
 *	Modify an object to be a wide integer object or a bignum object
 *	and to have the specified unsigned 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_SetWideUIntObj(
    Tcl_Obj *objPtr,		/* Object w. internal rep to init. */
    Tcl_WideUInt uwideValue)	/* Wide integer used to initialize the
				 * object's value. */
{
    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetWideUIntObj");
    }

    if (uwideValue > WIDE_MAX) {
	mp_int bignumValue;
	if (mp_init_u64(&bignumValue, uwideValue) != MP_OKAY) {
	    Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj");
	}
	TclSetBignumInternalRep(objPtr, &bignumValue);
    } else {
	TclSetIntObj(objPtr, (Tcl_WideInt)uwideValue);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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 {
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    *wideIntPtr = objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"expected integer but got \"%s\"",
			TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    /*
	     * Must check for those bignum values that can fit in a
	     * Tcl_WideInt, even when auto-narrowing is enabled.
	     */

	    mp_int big;
	    Tcl_WideUInt value = 0;
	    size_t numBytes;
	    Tcl_WideInt scratch;
	    unsigned char *bytes = (unsigned char *) &scratch;

	    TclUnpackBignum(objPtr, big);
	    if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) {
		while (numBytes-- > 0) {
		    value = (value << CHAR_BIT) | *bytes++;
		}
		if (big.sign) {
		    if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) {
			*wideIntPtr = (Tcl_WideInt)(-value);
			return TCL_OK;
		    }
		} else {
		    if (value <= (Tcl_WideUInt)WIDE_MAX) {
			*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, (char *)NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetWideUIntFromObj --
 *
 *	Attempt to return a unsigned wide integer from the Tcl object "objPtr". If the
 *	object is not already a wide int object or a bignum 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_GetWideUIntFromObj(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* Object from which to get a wide int. */
    Tcl_WideUInt *wideUIntPtr)	/* Place to store resulting long. */
{
    do {
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    if (objPtr->internalRep.wideValue < 0) {
	wideUIntOutOfRange:
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "expected unsigned integer but got \"%s\"",
			    TclGetString(objPtr)));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
		}
		return TCL_ERROR;
	    }
	    *wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    goto wideUIntOutOfRange;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    /*
	     * Must check for those bignum values that can fit in a
	     * Tcl_WideUInt, even when auto-narrowing is enabled.
	     */

	    mp_int big;
	    Tcl_WideUInt value = 0;
	    size_t numBytes;
	    Tcl_WideUInt scratch;
	    unsigned char *bytes = (unsigned char *) &scratch;

	    TclUnpackBignum(objPtr, big);
	    if (big.sign == MP_NEG) {
		goto wideUIntOutOfRange;
	    }
	    if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideUInt), &numBytes) == MP_OKAY) {
		while (numBytes-- > 0) {
		    value = (value << CHAR_BIT) | *bytes++;
		}
		*wideUIntPtr = (Tcl_WideUInt)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, (char *)NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetWideBitsFromObj --
 *
 *	Attempt to return a wide integer from the Tcl object "objPtr". If the
 *	object is not already a int, double or bignum, an attempt will be made
 *	to convert it to one of these. Out-of-range values don't result in an
 *	error, but only the least significant 64 bits will be returned.
 *
 * 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, double or bignum object, the
 *	conversion will free any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
TclGetWideBitsFromObj(
    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 wide integer. */
{
    do {
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    *wideIntPtr = objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"expected integer but got \"%s\"",
			TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
	    }
	    return TCL_ERROR;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    mp_int big;
	    mp_err err;

	    Tcl_WideUInt value = 0, scratch;
	    size_t numBytes;
	    unsigned char *bytes = (unsigned char *) &scratch;

	    Tcl_GetBignumFromObj(NULL, objPtr, &big);
	    err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big);
	    if (err == MP_OKAY) {
		err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes);
	    }
	    if (err != MP_OKAY) {
		return TCL_ERROR;
	    }
	    while (numBytes-- > 0) {
		value = (value << CHAR_BIT) | *bytes++;
	    }
	    *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value;
	    mp_clear(&big);
	    return TCL_OK;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetSizeIntFromObj --
 *
 *	Attempt to return a Tcl_Size from the Tcl object "objPtr".
 *
 * Results:
 *	TCL_OK - the converted Tcl_Size value is stored in *sizePtr
 *	TCL_ERROR - the error message is stored in interp
 *
 * Side effects:
 *	The function may free up any existing internal representation.
 *
 *----------------------------------------------------------------------
 */
int
Tcl_GetSizeIntFromObj(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* The object from which to get a int. */
    Tcl_Size *sizePtr)		/* Place to store resulting int. */
{
    if (sizeof(Tcl_Size) == sizeof(int)) {
	return TclGetIntFromObj(interp, objPtr, (int *)sizePtr);
    } else {
	Tcl_WideInt wide;
	if (TclGetWideIntFromObj(interp, objPtr, &wide) != TCL_OK) {
	    return TCL_ERROR;
	}
	*sizePtr = (Tcl_Size)wide;
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * FreeBignum --
 *
 *	This function frees the internal rep of a bignum.
 *
 * Results:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
FreeBignum(
    Tcl_Obj *objPtr)
{
    mp_int toFree;		/* Bignum to free */

    TclUnpackBignum(objPtr, toFree);
    mp_clear(&toFree);
    if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
	Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1);
    }
    objPtr->typePtr = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DupBignum --
 *
 *	This function duplicates the internal rep of a bignum.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The destination object receives a copy of the source object
 *
 *----------------------------------------------------------------------
 */

static void
DupBignum(
    Tcl_Obj *srcPtr,
    Tcl_Obj *copyPtr)
{
    mp_int bignumVal;
    mp_int bignumCopy;

    copyPtr->typePtr = &tclBignumType;
    TclUnpackBignum(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;
    char *stringVal;

    TclUnpackBignum(objPtr, bignumVal);
    if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) {
	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 = Tcl_InitStringRep(objPtr, NULL, size - 1);

    TclOOM(stringVal, size);
    if (MP_OKAY != mp_to_radix(&bignumVal, stringVal, size, NULL, 10)) {
	Tcl_Panic("conversion failure in UpdateStringOfBignum");
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewBignumObj --
 *
 *	Creates and 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(
    void *bignumValue)
{
    return Tcl_DbNewBignumObj(bignumValue, "unknown", 0);
}
#else
Tcl_Obj *
Tcl_NewBignumObj(
    void *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(
    void *bignumValue,
    const char *file,
    int line)
{
    Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    Tcl_SetBignumObj(objPtr, bignumValue);
    return objPtr;
}
#else
Tcl_Obj *
Tcl_DbNewBignumObj(
    void *bignumValue,
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(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 (TclHasInternalRep(objPtr, &tclBignumType)) {
	    if (copy || Tcl_IsShared(objPtr)) {
		mp_int temp;

		TclUnpackBignum(objPtr, temp);
		if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
		    return TCL_ERROR;
		}
	    } else {
		TclUnpackBignum(objPtr, *bignumValue);
		/* Optimized TclFreeInternalRep */
		objPtr->internalRep.twoPtrValue.ptr1 = NULL;
		objPtr->internalRep.twoPtrValue.ptr2 = NULL;
		objPtr->typePtr = NULL;
		/*
		 * TODO: If objPtr has a string rep, this leaves
		 * it undisturbed.  Not clear that's proper. Pure
		 * bignum values are converted to empty string.
		 */
		if (objPtr->bytes == NULL) {
		    TclInitEmptyStringRep(objPtr);
		}
	    }
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    if (mp_init_i64(bignumValue,
		    objPtr->internalRep.wideValue) != MP_OKAY) {
		return TCL_ERROR;
	    }
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"expected integer but got \"%s\"",
			TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)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 */
    void *bignumValue)		/* Returned bignum value. */
{
    return GetBignumFromObj(interp, objPtr, 1, (mp_int *)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 and 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 */
    void *bignumValue)		/* Returned bignum value. */
{
    return GetBignumFromObj(interp, objPtr, 0, (mp_int *)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 */
    void *big)			/* Value to store */
{
    Tcl_WideUInt value = 0;
    size_t numBytes;
    Tcl_WideUInt scratch;
    unsigned char *bytes = (unsigned char *) &scratch;
    mp_int *bignumValue = (mp_int *) big;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
    }
    if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) {
	goto tooLargeForWide;
    }
    while (numBytes-- > 0) {
	value = (value << CHAR_BIT) | *bytes++;
    }
    if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) {
	goto tooLargeForWide;
    }
    if (bignumValue->sign) {
	TclSetIntObj(objPtr, (Tcl_WideInt)(-value));
    } else {
	TclSetIntObj(objPtr, (Tcl_WideInt)value);
    }
    mp_clear(bignumValue);
    return;
  tooLargeForWide:
    TclInvalidateStringRep(objPtr);
    TclFreeInternalRep(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,
    void *big)
{
    mp_int *bignumValue = (mp_int *)big;
    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;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetNumberFromObj --
 *
 *	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
Tcl_GetNumberFromObj(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    void **clientDataPtr,
    int *typePtr)
{
    do {
	if (TclHasInternalRep(objPtr, &tclDoubleType)) {
	    if (isnan(objPtr->internalRep.doubleValue)) {
		*typePtr = TCL_NUMBER_NAN;
	    } else {
		*typePtr = TCL_NUMBER_DOUBLE;
	    }
	    *clientDataPtr = &objPtr->internalRep.doubleValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclIntType)) {
	    *typePtr = TCL_NUMBER_INT;
	    *clientDataPtr = &objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
	if (TclHasInternalRep(objPtr, &tclBignumType)) {
	    static Tcl_ThreadDataKey bignumKey;
	    mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
		    sizeof(mp_int));

	    TclUnpackBignum(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;
}

int
Tcl_GetNumber(
    Tcl_Interp *interp,
    const char *bytes,
    Tcl_Size numBytes,
    void **clientDataPtr,
    int *typePtr)
{
    static Tcl_ThreadDataKey numberCacheKey;
    Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetThreadData(&numberCacheKey,
	    sizeof(Tcl_Obj));

    Tcl_FreeInternalRep(objPtr);

    if (bytes == NULL) {
	bytes = &tclEmptyString;
	numBytes = 0;
    }
    if (numBytes < 0) {
	numBytes = strlen(bytes);
    }

    objPtr->bytes = (char *) bytes;
    objPtr->length = numBytes;

    return Tcl_GetNumberFromObj(interp, objPtr, clientDataPtr, typePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IncrRefCount --
 *
 *	Increments the reference count of the object.
 *
 * Results:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_IncrRefCount
void
Tcl_IncrRefCount(
    Tcl_Obj *objPtr)		/* The object we are registering a reference to. */
{
    ++(objPtr)->refCount;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DecrRefCount --
 *
 *	Decrements the reference count of the object.
 *
 * Results:
 *	The storage for objPtr may be freed.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_DecrRefCount
void
Tcl_DecrRefCount(
    Tcl_Obj *objPtr)		/* The object we are releasing a reference to. */
{
    if (objPtr->refCount-- <= 1) {
	TclFreeObj(objPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclUndoRefCount --
 *
 *	Decrement the refCount of objPtr without causing it to be freed if it
 *	drops from 1 to 0.  This allows a function increment a refCount but
 *	then decrement it and still be able to pass return it to a caller,
 *	possibly with a refCount of 0.  The caller must have previously
 *	incremented the refCount.
 *
 *----------------------------------------------------------------------
 */
void
TclUndoRefCount(
    Tcl_Obj *objPtr)		/* The object we are releasing a reference to. */
{
    if (objPtr->refCount > 0) {
	--objPtr->refCount;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsShared --
 *
 *	Tests if the object has a ref count greater than one.
 *
 * Results:
 *	Boolean value that is the result of the test.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_IsShared
int
Tcl_IsShared(
    Tcl_Obj *objPtr)		/* The object to test for being shared. */
{
    return objPtr->refCount > 1;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
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. */
{
    if (objPtr->refCount == FREEDREFCOUNTFILLER) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("incrementing refCount of previously disposed object");
    }

#if 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("%s: object table not initialized", "Tcl_DbIncrRefCount");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s: Tcl_Obj allocated in another thread",
		    "Tcl_DbIncrRefCount");
	}
    }
# endif /* TCL_THREADS */
    ++(objPtr)->refCount;
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbIncrRefCount(
    Tcl_Obj *objPtr,		/* The object we are registering a reference
				 * to. */
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    ++(objPtr)->refCount;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
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. */
{
    if (objPtr->refCount == FREEDREFCOUNTFILLER) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("decrementing refCount of previously disposed object");
    }

#if 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("%s: object table not initialized", "Tcl_DbDecrRefCount");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s: Tcl_Obj allocated in another thread",
		    "Tcl_DbDecrRefCount");
	}
    }
# endif /* TCL_THREADS */

    if (objPtr->refCount-- <= 1) {
	TclFreeObj(objPtr);
    }
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbDecrRefCount(
    Tcl_Obj *objPtr,		/* The object we are releasing a reference
				 * to. */
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/)
{
    if (objPtr->refCount-- <= 1) {
	TclFreeObj(objPtr);
    }
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * 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. */
#ifdef TCL_MEM_DEBUG
    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. */
#else
    TCL_UNUSED(const char *) /*file*/,
    TCL_UNUSED(int) /*line*/
#endif
    )
{
#ifdef TCL_MEM_DEBUG
    if (objPtr->refCount == FREEDREFCOUNTFILLER) {
	fprintf(stderr, "file = %s, line = %d\n", file, line);
	fflush(stderr);
	Tcl_Panic("checking whether previously disposed object is shared");
    }

#if 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("%s: object table not initialized", "Tcl_DbIsShared");
	}
	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
	if (!hPtr) {
	    Tcl_Panic("%s: Tcl_Obj allocated in another thread",
		    "Tcl_DbIsShared");
	}
    }
# 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_UNUSED(Tcl_HashTable *),
    void *keyPtr)		/* Key to store in the hash table entry. */
{
    Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
    Tcl_HashEntry *hPtr = (Tcl_HashEntry *)Tcl_AttemptAlloc(sizeof(Tcl_HashEntry));

    if (hPtr) {
	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 = (Tcl_Obj *)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);
    Tcl_Free(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.
 *
 *----------------------------------------------------------------------
 */

size_t
TclHashObjKey(
    TCL_UNUSED(Tcl_HashTable *),
    void *keyPtr)		/* Key from which to compute hash value. */
{
    Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
    Tcl_Size length;
    const char *string = Tcl_GetStringFromObj(objPtr, &length);
    size_t 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 = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
    if (TclHasInternalRep(objPtr, &tclCmdNameType)) {
	Command *cmdPtr = resPtr->cmdPtr;

	if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
		&& (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 [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
    if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
	return NULL;
    }
    resPtr = (ResolvedCmdName *)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. Its 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.
 *
 *----------------------------------------------------------------------
 */

static void
SetCmdNameObj(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    Command *cmdPtr,
    ResolvedCmdName *resPtr)
{
    Interp *iPtr = (Interp *) interp;
    ResolvedCmdName *fillPtr;
    const char *name = TclGetString(objPtr);

    if (resPtr) {
	fillPtr = resPtr;
    } else {
	fillPtr = (ResolvedCmdName *)Tcl_Alloc(sizeof(ResolvedCmdName));
	fillPtr->refCount = 1;
    }

    fillPtr->cmdPtr = cmdPtr;
    cmdPtr->refCount++;
    fillPtr->cmdEpoch = cmdPtr->cmdEpoch;

    /* NOTE: relying on NULL termination here. */
    if ((name[0] == ':') && (name[1] == ':')) {
	/*
	 * Fully qualified names always resolve to same thing. No need
	 * to record resolution context information.
	 */

	fillPtr->refNsPtr = NULL;
	fillPtr->refNsId = 0;		/* Will not be read */
	fillPtr->refNsCmdEpoch = 0;	/* Will not be read */
    } else {
	/*
	 * Record current state of current namespace as the resolution
	 * context of this command name lookup.
	 */
	Namespace *currNsPtr = iPtr->varFramePtr->nsPtr;

	fillPtr->refNsPtr = currNsPtr;
	fillPtr->refNsId = currNsPtr->nsId;
	fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
    }

    if (resPtr == NULL) {
	TclFreeInternalRep(objPtr);

	objPtr->internalRep.twoPtrValue.ptr1 = fillPtr;
	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
	objPtr->typePtr = &tclCmdNameType;
    }
}

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. */
{
    ResolvedCmdName *resPtr;

    if (TclHasInternalRep(objPtr, &tclCmdNameType)) {
	resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
	if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
	    return;
	}
    }

    SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * 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 = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;

	/*
	 * 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);
	    Tcl_Free(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 = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1;

    copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = 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. */
{
    const char *name;
    Command *cmdPtr;
    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);

    /*
     * Stop shimmering and caching nothing when we found nothing.  Just
     * report the failure to find the command as an error.
     */

    if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) {
	return TCL_ERROR;
    }

    resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
    if (TclHasInternalRep(objPtr, &tclCmdNameType) && (resPtr->refCount == 1)) {
	/*
	 * Re-use existing ResolvedCmdName struct when possible.
	 * Cleanup the old fields that need it.
	 */

	Command *oldCmdPtr = resPtr->cmdPtr;

	if (oldCmdPtr->refCount-- <= 1) {
	    TclCleanupCommandMacro(oldCmdPtr);
	}
    } else {
	resPtr = NULL;
    }

    SetCmdNameObj(interp, objPtr, cmdPtr, resPtr);
    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(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    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"
     */

    descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_SIZE_MODIFIER "d,"
	    " object pointer at %p",
	    objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
	    objv[1]->refCount, objv[1]);

    if (objv[1]->typePtr) {
	if (TclHasInternalRep(objv[1], &tclDoubleType)) {
	    Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
		    objv[1]->internalRep.doubleValue);
	} else {
	    Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
		    (void *) objv[1]->internalRep.twoPtrValue.ptr1,
		    (void *) objv[1]->internalRep.twoPtrValue.ptr2);
	}
    }

    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:
 */
