summaryrefslogtreecommitdiffstats
path: root/generic/tclObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclObj.c')
-rw-r--r--generic/tclObj.c3909
1 files changed, 2291 insertions, 1618 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 7b9bb61..5c17df2 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -1,28 +1,30 @@
-/*
+/*
* tclObj.c --
*
- * This file contains Tcl object-related procedures that are used by
- * many Tcl commands.
+ * This file contains Tcl object-related functions that are used by many
+ * Tcl commands.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
* Copyright (c) 2001 by ActiveState Corporation.
+ * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * 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 "tclCompile.h"
-#include "tclPort.h"
+#include "tommath.h"
+#include <float.h>
+#include <math.h>
/*
* Table of all object types.
*/
static Tcl_HashTable typeTable;
-static int typeTableInitialized = 0; /* 0 means not yet initialized. */
+static int typeTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)
/*
@@ -32,259 +34,379 @@ TCL_DECLARE_MUTEX(tableMutex)
Tcl_Obj *tclFreeObjList = NULL;
/*
- * The object allocator is single threaded. This mutex is referenced
- * by the TclNewObj macro, however, so must be visible.
+ * The object allocator is single threaded. This mutex is referenced by the
+ * TclNewObj macro, however, so must be visible.
*/
#ifdef TCL_THREADS
+MODULE_SCOPE Tcl_Mutex tclObjMutex;
Tcl_Mutex tclObjMutex;
#endif
/*
- * Pointer to a heap-allocated string of length zero that the Tcl core uses
- * as the value of an empty string representation for an object. This value
- * is shared by all new objects allocated by Tcl_NewObj.
+ * Pointer to a heap-allocated string of length zero that the Tcl core uses as
+ * the value of an empty string representation for an object. This value is
+ * shared by all new objects allocated by Tcl_NewObj.
*/
char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;
+
+#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+/*
+ * Structure for tracking the source file and line number where a given Tcl_Obj
+ * was allocated. We also track the pointer to the Tcl_Obj itself, for sanity
+ * checking purposes.
+ */
+typedef struct ObjData {
+ Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */
+ CONST char *file; /* The name of the source file calling this
+ * function; used for debugging. */
+ int line; /* Line number in the source file; used for
+ * debugging. */
+} ObjData;
+#endif /* TCL_MEM_DEBUG && TCL_THREADS */
-#ifdef TCL_TIP280
/*
- * 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.
+ * 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.
+ * Notice that different structures with the same name appear in other files.
+ * The structure defined below is used in this file only.
*/
typedef struct ThreadSpecificData {
- Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj generated
- * by a call to the function EvalTokensStandard()
- * from a literal text where bs+nl sequences
- * occured in it, if any. I.e. this table keeps
- * track of invisible/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.
- */
+ Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj
+ * generated by a call to the function
+ * TclSubstTokens() from a literal text
+ * where bs+nl sequences occured in it, if
+ * any. I.e. this table keeps track of
+ * invisible/stripped continuation lines. Its
+ * keys are Tcl_Obj pointers, the values are
+ * ContLineLoc pointers. See the file
+ * tclCompile.h for the definition of this
+ * structure, and for references to all related
+ * places in the core.
+ */
+#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+ /*
+ * Thread local table that is used to check that a Tcl_Obj was not
+ * allocated by some other thread.
+ */
+
+ Tcl_HashTable *objThreadMap;
+#endif /* TCL_MEM_DEBUG && TCL_THREADS */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
-static void ContLineLocFree _ANSI_ARGS_((char* clientData));
-static void TclThreadFinalizeObjects _ANSI_ARGS_((ClientData clientData));
-static ThreadSpecificData* TclGetContinuationTable _ANSI_ARGS_(());
+static void ContLineLocFree (char* clientData);
+static void TclThreadFinalizeContLines (ClientData clientData);
+static ThreadSpecificData* TclGetContLineTable (void);
+
+/*
+ * Nested Tcl_Obj deletion management support
+ *
+ * All context references used in the object freeing code are pointers to this
+ * structure; every thread will have its own structure instance. The purpose
+ * of this structure is to allow deeply nested collections of Tcl_Objs to be
+ * freed without taking a vast depth of C stack (which could cause all sorts
+ * of breakage.)
+ */
+
+typedef struct PendingObjData {
+ int deletionCount; /* Count of the number of invokations of
+ * TclFreeObj() are on the stack (at least
+ * conceptually; many are actually expanded
+ * macros). */
+ Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj()
+ * invoked upon them but which can't be
+ * deleted yet because they are in a nested
+ * invokation of TclFreeObj(). By postponing
+ * this way, we limit the maximum overall C
+ * stack depth when deleting a complex object.
+ * The down-side is that we alter the overall
+ * behaviour by altering the order in which
+ * objects are deleted, and we change the
+ * order in which the string rep and the
+ * internal rep of an object are deleted. Note
+ * that code which assumes the previous
+ * behaviour in either of these respects is
+ * unsafe anyway; it was never documented as
+ * to exactly what would happen in these
+ * cases, and the overall contract of a
+ * user-level Tcl_DecrRefCount() is still
+ * preserved (assuming that a particular T_DRC
+ * would delete an object is not very
+ * safe). */
+} PendingObjData;
+
+/*
+ * These are separated out so that some semantic content is attached
+ * to them.
+ */
+#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++)
+#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--)
+#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0)
+#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL)
+#define PushObjToDelete(contextPtr,objPtr) \
+ /* The string rep is already invalidated so we can use the bytes value \
+ * for our pointer chain: push onto the head of the stack. */ \
+ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
+ (contextPtr)->deletionStack = (objPtr)
+#define PopObjToDelete(contextPtr,objPtrVar) \
+ (objPtrVar) = (contextPtr)->deletionStack; \
+ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
+
+/*
+ * Macro to set up the local reference to the deletion context.
+ */
+#ifndef TCL_THREADS
+static PendingObjData pendingObjData;
+#define ObjInitDeletionContext(contextPtr) \
+ PendingObjData *CONST contextPtr = &pendingObjData
+#else
+static Tcl_ThreadDataKey pendingObjDataKey;
+#define ObjInitDeletionContext(contextPtr) \
+ PendingObjData *CONST contextPtr = (PendingObjData *) \
+ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
/*
- * Prototypes for procedures defined later in this file:
+ * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
*/
-static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
-static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
-static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
-static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp,
- Tcl_Obj *objPtr));
-static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
-static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
-static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
-static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
+#define PACK_BIGNUM(bignum, objPtr) \
+ if ((bignum).used > 0x7fff) { \
+ mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
+ *temp = bignum; \
+ (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \
+ (objPtr)->internalRep.ptrAndLongRep.value = (unsigned long)(-1); \
+ } else { \
+ if ((bignum).alloc > 0x7fff) { \
+ mp_shrink(&(bignum)); \
+ } \
+ (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \
+ (objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \
+ | ((bignum).alloc << 15) | ((bignum).used)); \
+ }
+
+#define UNPACK_BIGNUM(objPtr, bignum) \
+ if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \
+ (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \
+ } else { \
+ (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \
+ (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \
+ (bignum).alloc = \
+ ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \
+ (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \
+ }
-#ifndef TCL_WIDE_INT_IS_LONG
-static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
+/*
+ * Prototypes for functions defined later in this file:
+ */
+
+static int ParseBoolean(Tcl_Obj *objPtr);
+static int SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfDouble(Tcl_Obj *objPtr);
+static void UpdateStringOfInt(Tcl_Obj *objPtr);
+#ifndef NO_WIDE_TYPE
+static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
+static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
#endif
+static void FreeBignum(Tcl_Obj *objPtr);
+static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
+static void UpdateStringOfBignum(Tcl_Obj *objPtr);
+static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int copy, mp_int *bignumValue);
/*
* Prototypes for the array hash key methods.
*/
-static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_((
- Tcl_HashTable *tablePtr, VOID *keyPtr));
-static int CompareObjKeys _ANSI_ARGS_((
- VOID *keyPtr, Tcl_HashEntry *hPtr));
-static void FreeObjEntry _ANSI_ARGS_((
- Tcl_HashEntry *hPtr));
-static unsigned int HashObjKey _ANSI_ARGS_((
- Tcl_HashTable *tablePtr,
- VOID *keyPtr));
+static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Prototypes for the CommandName object type.
*/
-static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- Tcl_Obj *copyPtr));
-static void FreeCmdNameInternalRep _ANSI_ARGS_((
- Tcl_Obj *objPtr));
-static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
-
+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 procedures that can be invoked by generic object code. See also
+ * means of functions that can be invoked by generic object code. See also
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
* implementations.
*/
-Tcl_ObjType tclBooleanType = {
+static Tcl_ObjType oldBooleanType = {
"boolean", /* name */
- (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
- UpdateStringOfBoolean, /* updateStringProc */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetBooleanFromAny /* setFromAnyProc */
+};
+Tcl_ObjType tclBooleanType = {
+ "booleanString", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
SetBooleanFromAny /* setFromAnyProc */
};
-
Tcl_ObjType tclDoubleType = {
"double", /* name */
- (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny /* setFromAnyProc */
};
-
Tcl_ObjType tclIntType = {
"int", /* name */
- (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
-
+#ifndef NO_WIDE_TYPE
Tcl_ObjType tclWideIntType = {
"wideInt", /* name */
- (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
-#ifdef TCL_WIDE_INT_IS_LONG
- UpdateStringOfInt, /* updateStringProc */
-#else /* !TCL_WIDE_INT_IS_LONG */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
UpdateStringOfWideInt, /* updateStringProc */
-#endif
SetWideIntFromAny /* setFromAnyProc */
};
+#endif
+Tcl_ObjType tclBignumType = {
+ "bignum", /* name */
+ FreeBignum, /* freeIntRepProc */
+ DupBignum, /* dupIntRepProc */
+ UpdateStringOfBignum, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
/*
* The structure below defines the Tcl obj hash key type.
*/
+
Tcl_HashKeyType tclObjHashKeyType = {
- TCL_HASH_KEY_TYPE_VERSION, /* version */
- 0, /* flags */
- HashObjKey, /* hashKeyProc */
- CompareObjKeys, /* compareKeysProc */
- AllocObjEntry, /* allocEntryProc */
- FreeObjEntry /* freeEntryProc */
+ TCL_HASH_KEY_TYPE_VERSION, /* version */
+ 0, /* flags */
+ TclHashObjKey, /* hashKeyProc */
+ TclCompareObjKeys, /* compareKeysProc */
+ AllocObjEntry, /* allocEntryProc */
+ TclFreeObjEntry /* freeEntryProc */
};
/*
* The structure below defines the command name Tcl object type by means of
- * procedures 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.
+ * 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.
+ * 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.
*/
static Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
- (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
+ NULL, /* updateStringProc */
SetCmdNameFromAny /* setFromAnyProc */
};
-
/*
- * Structure containing a cached pointer to a command that is the result
- * of resolving the command's name in some namespace. It is the internal
- * representation for a cmdName object. It contains the pointer along
- * with some information that is used to check the pointer's validity.
+ * 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). */
+ * reference (not the namespace that contains
+ * the referenced command). NULL if the name
+ * is fully qualified.*/
long refNsId; /* refNsPtr's unique namespace id. Used to
- * verify that refNsPtr is still valid
- * (e.g., it's possible that the cmd's
- * containing namespace was deleted and a
- * new one created at the same address). */
+ * verify that refNsPtr is still valid (e.g.,
+ * it's possible that the cmd's containing
+ * namespace was deleted and a new one created
+ * at the same address). */
int refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
int cmdEpoch; /* Value of the command's cmdEpoch when this
- * pointer was cached. Before using the
- * cached pointer, we check if the cmd's
- * epoch was incremented; if so, the cmd was
- * renamed, deleted, hidden, or exposed, and
- * so the pointer is invalid. */
- int refCount; /* Reference count: 1 for each cmdName
- * object that has a pointer to this
- * ResolvedCmdName structure as its internal
- * rep. This structure can be freed when
- * refCount becomes zero. */
+ * pointer was cached. Before using the cached
+ * pointer, we check if the cmd's epoch was
+ * incremented; if so, the cmd was renamed,
+ * deleted, hidden, or exposed, and so the
+ * pointer is invalid. */
+ int refCount; /* Reference count: 1 for each cmdName object
+ * that has a pointer to this ResolvedCmdName
+ * structure as its internal rep. This
+ * structure can be freed when refCount
+ * becomes zero. */
} ResolvedCmdName;
-
/*
*-------------------------------------------------------------------------
*
* TclInitObjectSubsystem --
*
- * This procedure is invoked to perform once-only initialization of
- * the type table. It also registers the object types defined in
- * this file.
+ * 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.
+ * Initializes the table of defined object types "typeTable" with builtin
+ * object types defined in this file.
*
*-------------------------------------------------------------------------
*/
void
-TclInitObjSubsystem()
+TclInitObjSubsystem(void)
{
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
- Tcl_RegisterObjType(&tclBooleanType);
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
- Tcl_RegisterObjType(&tclWideIntType);
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
+ Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
- Tcl_RegisterObjType(&tclProcBodyType);
Tcl_RegisterObjType(&tclArraySearchType);
- Tcl_RegisterObjType(&tclIndexType);
- Tcl_RegisterObjType(&tclNsNameType);
Tcl_RegisterObjType(&tclCmdNameType);
+ Tcl_RegisterObjType(&tclRegexpType);
+ Tcl_RegisterObjType(&tclProcBodyType);
+
+ /* For backward compatibility only ... */
+ Tcl_RegisterObjType(&oldBooleanType);
+#ifndef NO_WIDE_TYPE
+ Tcl_RegisterObjType(&tclWideIntType);
+#endif
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
@@ -292,7 +414,7 @@ TclInitObjSubsystem()
tclObjsFreed = 0;
{
int i;
- for (i = 0; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
+ for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) {
tclObjsShared[i] = 0;
}
}
@@ -303,10 +425,53 @@ TclInitObjSubsystem()
/*
*----------------------------------------------------------------------
*
+ * TclFinalizeThreadObjects --
+ *
+ * This function is called by Tcl_FinalizeThread to clean up thread
+ * specific Tcl_Obj information.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeThreadObjects(void)
+{
+#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch hSearch;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
+
+ if (tablePtr != NULL) {
+ for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
+ ObjData *objData = Tcl_GetHashValue(hPtr);
+
+ if (objData != NULL) {
+ ckfree((char *) objData);
+ }
+ }
+
+ Tcl_DeleteHashTable(tablePtr);
+ ckfree((char *) tablePtr);
+ tsdPtr->objThreadMap = NULL;
+ }
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclFinalizeObjects --
*
- * This procedure is called by Tcl_Finalize to clean up all
- * registered Tcl_ObjType's and to reset the tclFreeObjList.
+ * This function is called by Tcl_Finalize to clean up all registered
+ * Tcl_ObjType's and to reset the tclFreeObjList.
*
* Results:
* None.
@@ -318,37 +483,36 @@ TclInitObjSubsystem()
*/
void
-TclFinalizeObjects()
+TclFinalizeObjects(void)
{
Tcl_MutexLock(&tableMutex);
if (typeTableInitialized) {
- Tcl_DeleteHashTable(&typeTable);
- typeTableInitialized = 0;
+ 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.
+ /*
+ * 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);
}
-#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
- * TclGetContinuationTable --
+ * TclGetContLineTable --
*
* This procedure is a helper which returns the thread-specific
* hash-table used to track continuation line information associated with
- * Tcl_Obj*.
+ * Tcl_Obj*, and the objThreadMap, etc.
*
* Results:
- * A reference to the continuation line thread-data.
+ * A reference to the thread-data.
*
* Side effects:
* May allocate memory for the thread-data.
@@ -358,7 +522,7 @@ TclFinalizeObjects()
*/
static ThreadSpecificData*
-TclGetContinuationTable()
+TclGetContLineTable()
{
/*
* Initialize the hashtable tracking invisible continuation lines. For
@@ -372,7 +536,7 @@ TclGetContinuationTable()
if (!tsdPtr->lineCLPtr) {
tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
- Tcl_CreateThreadExitHandler (TclThreadFinalizeObjects,NULL);
+ Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL);
}
return tsdPtr;
}
@@ -396,36 +560,49 @@ TclGetContinuationTable()
*/
ContLineLoc*
-TclContinuationsEnter(objPtr,num,loc)
- Tcl_Obj* objPtr;
- int num;
- int* loc;
+TclContinuationsEnter(Tcl_Obj* objPtr,
+ int num,
+ int* loc)
{
- int newEntry;
- ThreadSpecificData *tsdPtr = TclGetContinuationTable();
- Tcl_HashEntry* hPtr =
- Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry);
+ int newEntry;
+ ThreadSpecificData *tsdPtr = TclGetContLineTable();
+ Tcl_HashEntry* hPtr =
+ Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry);
- ContLineLoc* clLocPtr =
- (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int));
+ ContLineLoc* clLocPtr =
+ (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int));
if (!newEntry) {
/*
- * Somehow we're entering ContLineLoc data for the same value (objPtr)
- * more than one time. Not sure whether that's expected, or a sign of
- * trouble, but at a minimum, we should take care not to leak the old
- * entry.
+ * We're entering ContLineLoc data for the same value more than one
+ * time. Taking care not to leak the old entry.
+ *
+ * This can happen when literals in a proc body are shared. See for
+ * example test info-30.19 where the action (code) for all branches of
+ * the switch command is identical, mapping them all to the same
+ * literal. An interesting result of this is that the number and
+ * locations (offset) of invisible continuation lines in the literal
+ * are the same for all occurences.
+ *
+ * Note that while reusing the existing entry is possible it requires
+ * the same actions as for a new entry because we have to copy the
+ * incoming num/loc data even so. Because we are called from
+ * TclContinuationsEnterDerived for this case, which modified the
+ * stored locations (Rebased to the proper relative offset). Just
+ * returning the stored entry and data would rebase them a second
+ * time, or more, hosing the data. It is easier to simply replace, as
+ * we are doing.
*/
ckfree((char *) Tcl_GetHashValue(hPtr));
}
- clLocPtr->num = num;
- memcpy (&clLocPtr->loc, loc, num*sizeof(int));
- clLocPtr->loc[num] = CLL_END; /* Sentinel */
- Tcl_SetHashValue (hPtr, clLocPtr);
+ clLocPtr->num = num;
+ memcpy (&clLocPtr->loc, loc, num*sizeof(int));
+ clLocPtr->loc[num] = CLL_END; /* Sentinel */
+ Tcl_SetHashValue (hPtr, clLocPtr);
- return clLocPtr;
+ return clLocPtr;
}
/*
@@ -448,19 +625,16 @@ TclContinuationsEnter(objPtr,num,loc)
*/
void
-TclContinuationsEnterDerived(objPtr, start, clNext)
- Tcl_Obj* objPtr;
- int start;
- int* clNext;
+TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext)
{
/*
* We have to handle invisible continuations lines here as well, despite
- * the code we have in EvalTokensStandard (ETS) for that. Why ?
- * Nesting. If our script is the sole argument to an 'eval' command, for
- * example, the scriptCLLocPtr we are using here was generated by a
- * previous call to ETS, and while the words we have here may contain
- * continuation lines they are invisible already, and the call to ETS
- * above had no bs+nl sequences to trigger its code.
+ * 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
@@ -501,7 +675,7 @@ TclContinuationsEnterDerived(objPtr, start, clNext)
num = wordCLLast - clNext;
if (num) {
int i;
- ContLineLoc* clLocPtr =
+ ContLineLoc* clLocPtr =
TclContinuationsEnter(objPtr, num, clNext);
/*
@@ -547,7 +721,7 @@ TclContinuationsEnterDerived(objPtr, start, clNext)
void
TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
{
- ThreadSpecificData *tsdPtr = TclGetContinuationTable();
+ ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr);
if (hPtr) {
@@ -577,10 +751,9 @@ TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
*/
ContLineLoc*
-TclContinuationsGet(objPtr)
- Tcl_Obj* objPtr;
+TclContinuationsGet(Tcl_Obj* objPtr)
{
- ThreadSpecificData *tsdPtr = TclGetContinuationTable();
+ ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr);
if (hPtr) {
@@ -593,7 +766,7 @@ TclContinuationsGet(objPtr)
/*
*----------------------------------------------------------------------
*
- * TclThreadFinalizeObjects --
+ * TclThreadFinalizeContLines --
*
* This procedure is a helper which releases all continuation line
* information currently known. It is run as a thread exit handler.
@@ -609,31 +782,30 @@ TclContinuationsGet(objPtr)
*/
static void
-TclThreadFinalizeObjects (clientData)
- ClientData clientData;
+TclThreadFinalizeContLines (ClientData clientData)
{
/*
* Release the hashtable tracking invisible continuation lines.
*/
+ ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
- ThreadSpecificData *tsdPtr = TclGetContinuationTable();
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
/*
- * We are not using Tcl_EventuallyFree (as in
- * TclFreeObj()) because here we can be sure that the
- * compiler will not hold references to the data in the
- * hashtable, and using TEF might bork the finalization
- * sequence.
+ * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because
+ * here we can be sure that the compiler will not hold references to
+ * the data in the hashtable, and using TEF might bork the
+ * finalization sequence.
*/
ContLineLocFree (Tcl_GetHashValue (hPtr));
Tcl_DeleteHashEntry (hPtr);
}
Tcl_DeleteHashTable (tsdPtr->lineCLPtr);
+ ckfree((char *) tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
@@ -655,41 +827,41 @@ TclThreadFinalizeObjects (clientData)
*/
static void
-ContLineLocFree (clientData)
- char* clientData;
+ContLineLocFree (char* clientData)
{
- ckfree (clientData);
+ ckfree (clientData);
}
-#endif
+
/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
*
- * This procedure is called to register a new Tcl object type
- * in the table of all object types supported by Tcl.
+ * 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.
+ * The type is registered in the Tcl type table. If there was already a
+ * type with the same name as in typePtr, it is replaced with the new
+ * type.
*
*--------------------------------------------------------------
*/
void
-Tcl_RegisterObjType(typePtr)
- Tcl_ObjType *typePtr; /* Information about object type;
- * storage must be statically
- * allocated (must live forever). */
+Tcl_RegisterObjType(
+ Tcl_ObjType *typePtr) /* Information about object type; storage must
+ * be statically allocated (must live
+ * forever). */
{
- int new;
+ int isNew;
+
Tcl_MutexLock(&tableMutex);
Tcl_SetHashValue(
- Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr);
+ Tcl_CreateHashEntry(&typeTable, typePtr->name, &isNew), typePtr);
Tcl_MutexUnlock(&tableMutex);
}
@@ -698,56 +870,54 @@ Tcl_RegisterObjType(typePtr)
*
* Tcl_AppendAllObjTypes --
*
- * This procedure appends onto the argument object the name of each
- * object type as a list element. This includes the builtin object
- * types (e.g. int, list) as well as those added using
- * Tcl_NewObj. These names can be used, for example, with
- * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
- * structures.
+ * 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.
+ * 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.
+ * If necessary, the object referenced by objPtr is converted into a list
+ * object.
*
*----------------------------------------------------------------------
*/
int
-Tcl_AppendAllObjTypes(interp, objPtr)
- Tcl_Interp *interp; /* Interpreter used for error reporting. */
- Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
- * name of each registered type is appended
- * as a list element. */
+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. */
{
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
- int objc;
- Tcl_Obj **objv;
+ int numElems;
/*
* Get the test for a valid list out of the way first.
*/
- if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) {
return TCL_ERROR;
}
/*
- * Type names are NUL-terminated, not counted strings.
- * This code relies on that.
+ * 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)) {
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
+ Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
}
Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
@@ -758,12 +928,11 @@ Tcl_AppendAllObjTypes(interp, objPtr)
*
* Tcl_GetObjType --
*
- * This procedure looks up an object type by name.
+ * 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.
+ * 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.
@@ -772,16 +941,16 @@ Tcl_AppendAllObjTypes(interp, objPtr)
*/
Tcl_ObjType *
-Tcl_GetObjType(typeName)
- CONST char *typeName; /* Name of Tcl object type to look up. */
+Tcl_GetObjType(
+ CONST char *typeName) /* Name of Tcl object type to look up. */
{
register Tcl_HashEntry *hPtr;
Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
- if (hPtr != (Tcl_HashEntry *) NULL) {
- typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
+ if (hPtr != NULL) {
+ typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
@@ -796,10 +965,10 @@ Tcl_GetObjType(typeName)
*
* Results:
* The return value is TCL_OK on success and TCL_ERROR on failure. If
- * TCL_ERROR is returned, then the interpreter's result contains an
- * error message unless "interp" is NULL. Passing a NULL "interp"
- * allows this procedure to be used as a test whether the conversion
- * could be done (and in fact was done).
+ * 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.
@@ -808,46 +977,169 @@ Tcl_GetObjType(typeName)
*/
int
-Tcl_ConvertToType(interp, objPtr, typePtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- Tcl_Obj *objPtr; /* The object to convert. */
- Tcl_ObjType *typePtr; /* The target type. */
+Tcl_ConvertToType(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* The object to convert. */
+ Tcl_ObjType *typePtr) /* The target type. */
{
if (objPtr->typePtr == typePtr) {
return TCL_OK;
}
/*
- * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
- * form as appropriate for the target type. This frees the old internal
+ * 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) {
+ Tcl_Panic("may not convert object to type %s", typePtr->name);
+ }
+
return typePtr->setFromAnyProc(interp, objPtr);
}
/*
+ *--------------------------------------------------------------
+ *
+ * TclDbDumpActiveObjects --
+ *
+ * This function is called to dump all of the active Tcl_Obj structs this
+ * allocator knows about.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+TclDbDumpActiveObjects(
+ FILE *outFile)
+{
+#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+ Tcl_HashSearch hSearch;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashTable *tablePtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ tablePtr = tsdPtr->objThreadMap;
+
+ if (tablePtr != NULL) {
+ fprintf(outFile, "total objects: %d\n", tablePtr->numEntries);
+ for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+ ObjData *objData = Tcl_GetHashValue(hPtr);
+
+ if (objData != NULL) {
+ fprintf(outFile,
+ "key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n",
+ Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr,
+ objData->file, objData->line);
+ } else {
+ fprintf(outFile, "key = 0x%p\n",
+ Tcl_GetHashKey(tablePtr, hPtr));
+ }
+ }
+ }
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDbInitNewObj --
+ *
+ * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is
+ * enabled. This function will initialize the members of a Tcl_Obj
+ * struct. Initilization would be done inline via the TclNewObj macro
+ * when compiling without TCL_MEM_DEBUG.
+ *
+ * Results:
+ * The Tcl_Obj struct members are initialized.
+ *
+ * Side effects:
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+void
+TclDbInitNewObj(
+ register Tcl_Obj *objPtr,
+ register CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ register int line) /* Line number in the source file; used for
+ * debugging. */
+{
+ objPtr->refCount = 0;
+ objPtr->bytes = tclEmptyStringRep;
+ objPtr->length = 0;
+ objPtr->typePtr = NULL;
+
+#ifdef TCL_THREADS
+ /*
+ * Add entry to a thread local map used to check if a Tcl_Obj was
+ * allocated by the currently executing thread.
+ */
+
+ if (!TclInExit()) {
+ Tcl_HashEntry *hPtr;
+ Tcl_HashTable *tablePtr;
+ int isNew;
+ ObjData *objData;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (tsdPtr->objThreadMap == NULL) {
+ tsdPtr->objThreadMap = (Tcl_HashTable *)
+ ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
+ }
+ tablePtr = tsdPtr->objThreadMap;
+ hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew);
+ if (!isNew) {
+ Tcl_Panic("expected to create new entry for object map");
+ }
+
+ /*
+ * Record the debugging information.
+ */
+
+ objData = (ObjData *) ckalloc(sizeof(ObjData));
+ objData->objPtr = objPtr;
+ objData->file = file;
+ objData->line = line;
+ Tcl_SetHashValue(hPtr, objData);
+ }
+#endif /* TCL_THREADS */
+}
+#endif /* TCL_MEM_DEBUG */
+
+/*
*----------------------------------------------------------------------
*
* Tcl_NewObj --
*
- * This procedure is normally called when not debugging: i.e., when
+ * 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.
+ * string representation byte pointer. Type managers call this routine to
+ * allocate new objects that they further initialize.
*
- * When TCL_MEM_DEBUG is defined, this procedure just returns the
- * result of calling the debugging version Tcl_DbNewObj.
+ * 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.
+ * string. The new object's typePtr is set NULL and its ref count is set
+ * to 0.
*
* Side effects:
- * If compiling with TCL_COMPILE_STATS, this procedure increments
- * the global count of allocated objects (tclObjsAlloced).
+ * If compiling with TCL_COMPILE_STATS, this function increments the
+ * global count of allocated objects (tclObjsAlloced).
*
*----------------------------------------------------------------------
*/
@@ -856,7 +1148,7 @@ Tcl_ConvertToType(interp, objPtr, typePtr)
#undef Tcl_NewObj
Tcl_Obj *
-Tcl_NewObj()
+Tcl_NewObj(void)
{
return Tcl_DbNewObj("unknown", 0);
}
@@ -864,13 +1156,12 @@ Tcl_NewObj()
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_NewObj()
+Tcl_NewObj(void)
{
register Tcl_Obj *objPtr;
/*
- * Use the macro defined in tclInt.h - it will use the
- * correct allocator.
+ * Use the macro defined in tclInt.h - it will use the correct allocator.
*/
TclNewObj(objPtr);
@@ -883,24 +1174,24 @@ Tcl_NewObj()
*
* Tcl_DbNewObj --
*
- * This procedure is normally called when debugging: i.e., when
+ * 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 procedure above
- * except that it calls Tcl_DbCkalloc directly with the file name and
- * line number from its caller. This simplifies debugging since then
- * the [memory active] command will report the correct file name and line
+ * 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 procedure just returns the
+ * 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.
+ * The result is a newly allocated that represents the empty string. The
+ * new object's typePtr is set NULL and its ref count is set to 0.
*
* Side effects:
- * If compiling with TCL_COMPILE_STATS, this procedure increments
- * the global count of allocated objects (tclObjsAlloced).
+ * If compiling with TCL_COMPILE_STATS, this function increments the
+ * global count of allocated objects (tclObjsAlloced).
*
*----------------------------------------------------------------------
*/
@@ -908,17 +1199,16 @@ Tcl_NewObj()
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
-Tcl_DbNewObj(file, line)
- register CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- register int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbNewObj(
+ register CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ register int line) /* Line number in the source file; used for
+ * debugging. */
{
register Tcl_Obj *objPtr;
/*
- * Use the macro defined in tclInt.h - it will use the
- * correct allocator.
+ * Use the macro defined in tclInt.h - it will use the correct allocator.
*/
TclDbNewObj(objPtr, file, line);
@@ -927,11 +1217,11 @@ Tcl_DbNewObj(file, line)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_DbNewObj(file, line)
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbNewObj(
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
return Tcl_NewObj();
}
@@ -942,8 +1232,8 @@ Tcl_DbNewObj(file, line)
*
* TclAllocateFreeObjects --
*
- * Procedure to allocate a number of free Tcl_Objs. This is done using
- * a single ckalloc to reduce the overhead for Tcl_Obj allocation.
+ * Function to allocate a number of free Tcl_Objs. This is done using a
+ * single ckalloc to reduce the overhead for Tcl_Obj allocation.
*
* Assumes mutex is held.
*
@@ -961,7 +1251,7 @@ Tcl_DbNewObj(file, line)
#define OBJS_TO_ALLOC_EACH_TIME 100
void
-TclAllocateFreeObjects()
+TclAllocateFreeObjects(void)
{
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
char *basePtr;
@@ -969,22 +1259,20 @@ TclAllocateFreeObjects()
register int i;
/*
- * This has been noted by Purify to be a potential leak. The problem is
+ * This has been noted by Purify to be a potential leak. The problem is
* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
- * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
- * actually freeing the memory. TclFinalizeObjects() does not ckfree()
- * this memory, but leaves it to Tcl's memory subsystem finalziation to
- * release it. Purify apparently can't figure that out, and fires a
- * false alarm.
+ * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
+ * freeing the memory. TclFinalizeObjects() does not ckfree() this memory,
+ * but leaves it to Tcl's memory subsystem finalization to release it.
+ * Purify apparently can't figure that out, and fires a false alarm.
*/
basePtr = (char *) ckalloc(bytesToAlloc);
- memset(basePtr, 0, bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
- objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
+ objPtr->internalRep.otherValuePtr = (void *) prevPtr;
prevPtr = objPtr;
objPtr++;
}
@@ -997,64 +1285,166 @@ TclAllocateFreeObjects()
*
* TclFreeObj --
*
- * This procedure 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.
+ * 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 procedure increments the global count of freed objects
- * (tclObjsFreed).
+ * 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(objPtr)
- register Tcl_Obj *objPtr; /* The object to be freed. */
+TclFreeObj(
+ register Tcl_Obj *objPtr) /* The object to be freed. */
{
register Tcl_ObjType *typePtr = objPtr->typePtr;
-
-#ifdef TCL_MEM_DEBUG
- if ((objPtr)->refCount < -1) {
- panic("Reference count for %lx was negative", objPtr);
+
+ /*
+ * This macro declares a variable, so must come here...
+ */
+
+ ObjInitDeletionContext(context);
+
+ if (objPtr->refCount < -1) {
+ Tcl_Panic("Reference count for %lx was negative", objPtr);
}
-#endif /* TCL_MEM_DEBUG */
- TCL_DTRACE_OBJ_FREE(objPtr);
- if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
- typePtr->freeIntRepProc(objPtr);
+ /* Invalidate the string rep first so we can use the bytes value
+ * for our pointer chain, and signal an obj deletion (as opposed
+ * to shimmering) with 'length == -1' */
+
+ TclInvalidateStringRep(objPtr);
+ objPtr->length = -1;
+
+ if (ObjDeletePending(context)) {
+ PushObjToDelete(context, objPtr);
+ } else {
+ TCL_DTRACE_OBJ_FREE(objPtr);
+ if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+ ObjDeletionLock(context);
+ typePtr->freeIntRepProc(objPtr);
+ ObjDeletionUnlock(context);
+ }
+
+ Tcl_MutexLock(&tclObjMutex);
+ ckfree((char *) objPtr);
+ Tcl_MutexUnlock(&tclObjMutex);
+ TclIncrObjsFreed();
+ ObjDeletionLock(context);
+ while (ObjOnStack(context)) {
+ Tcl_Obj *objToFree;
+
+ PopObjToDelete(context,objToFree);
+ TCL_DTRACE_OBJ_FREE(objToFree);
+ TclFreeIntRep(objToFree);
+
+ Tcl_MutexLock(&tclObjMutex);
+ ckfree((char *) objToFree);
+ Tcl_MutexUnlock(&tclObjMutex);
+ TclIncrObjsFreed();
+ }
+ ObjDeletionUnlock(context);
}
- Tcl_InvalidateStringRep(objPtr);
/*
- * If debugging Tcl's memory usage, deallocate the object using ckfree.
- * Otherwise, deallocate it by adding it onto the list of free
- * Tcl_Obj structs we maintain.
+ * We cannot use TclGetContinuationTable() here, because that may
+ * re-initialize the thread-data for calls coming after the
+ * finalization. We have to access it using the low-level call and then
+ * check for validity. This function can be called after
+ * TclFinalizeThreadData() has already killed the thread-global data
+ * structures. Performing TCL_TSD_INIT will leave us with an
+ * un-initialized memory block upon which we crash (if we where to access
+ * the uninitialized hashtable).
*/
-#if defined(TCL_MEM_DEBUG) || defined(PURIFY)
- Tcl_MutexLock(&tclObjMutex);
- ckfree((char *) objPtr);
- Tcl_MutexUnlock(&tclObjMutex);
-#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
- TclThreadFreeObj(objPtr);
-#else
- Tcl_MutexLock(&tclObjMutex);
- objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
- tclFreeObjList = objPtr;
- Tcl_MutexUnlock(&tclObjMutex);
-#endif /* TCL_MEM_DEBUG */
+ {
+ ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
+ if (tsdPtr->lineCLPtr) {
+ Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr);
+ if (hPtr) {
+ Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree);
+ Tcl_DeleteHashEntry (hPtr);
+ }
+ }
+ }
+}
+#else /* TCL_MEM_DEBUG */
+
+void
+TclFreeObj(
+ register Tcl_Obj *objPtr) /* The object to be freed. */
+{
+ /* Invalidate the string rep first so we can use the bytes value
+ * for our pointer chain, and signal an obj deletion (as opposed
+ * to shimmering) with 'length == -1' */
+
+ TclInvalidateStringRep(objPtr);
+ objPtr->length = -1;
+
+ if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
+ /*
+ * objPtr can be freed safely, as it will not attempt to free any
+ * other objects: it will not cause recursive calls to this function.
+ */
+
+ TCL_DTRACE_OBJ_FREE(objPtr);
+ TclFreeObjStorage(objPtr);
+ TclIncrObjsFreed();
+ } else {
+ /*
+ * This macro declares a variable, so must come here...
+ */
+
+ ObjInitDeletionContext(context);
+
+ if (ObjDeletePending(context)) {
+ PushObjToDelete(context, objPtr);
+ } else {
+ /*
+ * Note that the contents of the while loop assume that the string
+ * rep has already been freed and we don't want to do anything
+ * fancy with adding to the queue inside ourselves. Must take care
+ * to unstack the object first since freeing the internal rep can
+ * add further objects to the stack. The code assumes that it is
+ * the first thing in a block; all current usages in the core
+ * satisfy this.
+ */
+
+ TCL_DTRACE_OBJ_FREE(objPtr);
+ ObjDeletionLock(context);
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ ObjDeletionUnlock(context);
+
+ TclFreeObjStorage(objPtr);
+ TclIncrObjsFreed();
+ ObjDeletionLock(context);
+ while (ObjOnStack(context)) {
+ Tcl_Obj *objToFree;
+ PopObjToDelete(context,objToFree);
+ TCL_DTRACE_OBJ_FREE(objToFree);
+ if ((objToFree->typePtr != NULL)
+ && (objToFree->typePtr->freeIntRepProc != NULL)) {
+ objToFree->typePtr->freeIntRepProc(objToFree);
+ }
+ TclFreeObjStorage(objToFree);
+ TclIncrObjsFreed();
+ }
+ ObjDeletionUnlock(context);
+ }
+ }
-#ifdef TCL_TIP280
/*
* We cannot use TclGetContinuationTable() here, because that may
* re-initialize the thread-data for calls coming after the
@@ -1076,9 +1466,34 @@ TclFreeObj(objPtr)
}
}
}
+}
#endif
- TclIncrObjsFreed();
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjBeingDeleted --
+ *
+ * This function returns 1 when the Tcl_Obj is being deleted. It is
+ * provided for the rare cases where the reason for the loss of an
+ * internal rep might be relevant. [FR 1512138]
+ *
+ * Results:
+ * 1 if being deleted, 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjBeingDeleted(
+ Tcl_Obj *objPtr)
+{
+ return (objPtr->length == -1);
}
+
/*
*----------------------------------------------------------------------
@@ -1089,29 +1504,29 @@ TclFreeObj(objPtr)
* 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:
+ * 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.
+ * 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.
+ * 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.
+ * 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.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
-Tcl_DuplicateObj(objPtr)
- register Tcl_Obj *objPtr; /* The object to duplicate. */
+Tcl_DuplicateObj(
+ register Tcl_Obj *objPtr) /* The object to duplicate. */
{
register Tcl_ObjType *typePtr = objPtr->typePtr;
register Tcl_Obj *dupPtr;
@@ -1123,7 +1538,7 @@ Tcl_DuplicateObj(objPtr)
} else if (objPtr->bytes != tclEmptyStringRep) {
TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
}
-
+
if (typePtr != NULL) {
if (typePtr->dupIntRepProc == NULL) {
dupPtr->internalRep = objPtr->internalRep;
@@ -1157,16 +1572,16 @@ Tcl_DuplicateObj(objPtr)
*/
char *
-Tcl_GetString(objPtr)
- register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
- * should be returned. */
+Tcl_GetString(
+ register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
+ * be returned. */
{
if (objPtr->bytes != NULL) {
return objPtr->bytes;
}
if (objPtr->typePtr->updateStringProc == NULL) {
- panic("UpdateStringProc should not be invoked for type %s",
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
(*objPtr->typePtr->updateStringProc)(objPtr);
@@ -1178,16 +1593,16 @@ Tcl_GetString(objPtr)
*
* Tcl_GetStringFromObj --
*
- * Returns the string representation's byte array pointer and length
- * for an object.
+ * 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.
+ * 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
@@ -1197,16 +1612,16 @@ Tcl_GetString(objPtr)
*/
char *
-Tcl_GetStringFromObj(objPtr, lengthPtr)
- register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should
+Tcl_GetStringFromObj(
+ register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
- register int *lengthPtr; /* If non-NULL, the location where the string
+ register int *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) {
if (objPtr->typePtr->updateStringProc == NULL) {
- panic("UpdateStringProc should not be invoked for type %s",
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
(*objPtr->typePtr->updateStringProc)(objPtr);
@@ -1223,48 +1638,44 @@ Tcl_GetStringFromObj(objPtr, lengthPtr)
*
* Tcl_InvalidateStringRep --
*
- * This procedure is called to invalidate an object's string
- * representation.
+ * 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.
+ * Deallocates the storage for any old string representation, then sets
+ * the string representation NULL to mark it invalid.
*
*----------------------------------------------------------------------
*/
void
-Tcl_InvalidateStringRep(objPtr)
- register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
- * should be freed. */
+Tcl_InvalidateStringRep(
+ register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
+ * be freed. */
{
- if (objPtr->bytes != NULL) {
- if (objPtr->bytes != tclEmptyStringRep) {
- ckfree((char *) objPtr->bytes);
- }
- objPtr->bytes = NULL;
- }
+ TclInvalidateStringRep(objPtr);
}
+
/*
*----------------------------------------------------------------------
*
* Tcl_NewBooleanObj --
*
- * This procedure is normally called when not debugging: i.e., when
+ * This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and
- * initializes it from the argument boolean value. A nonzero
- * "boolValue" is coerced to 1.
+ * initializes it from the argument boolean value. A nonzero "boolValue"
+ * is coerced to 1.
*
- * When TCL_MEM_DEBUG is defined, this procedure just returns the
- * result of calling the debugging version Tcl_DbNewBooleanObj.
+ * When TCL_MEM_DEBUG is defined, this function just returns the result
+ * of calling the debugging version Tcl_DbNewBooleanObj.
*
* Results:
- * The newly created object is returned. This object will have an
- * invalid string representation. The returned object has ref count 0.
+ * The newly created object is returned. This object will have an invalid
+ * string representation. The returned object has ref count 0.
*
* Side effects:
* None.
@@ -1276,8 +1687,8 @@ Tcl_InvalidateStringRep(objPtr)
#undef Tcl_NewBooleanObj
Tcl_Obj *
-Tcl_NewBooleanObj(boolValue)
- register int boolValue; /* Boolean used to initialize new object. */
+Tcl_NewBooleanObj(
+ register int boolValue) /* Boolean used to initialize new object. */
{
return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
}
@@ -1285,16 +1696,12 @@ Tcl_NewBooleanObj(boolValue)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_NewBooleanObj(boolValue)
- register int boolValue; /* Boolean used to initialize new object. */
+Tcl_NewBooleanObj(
+ register int boolValue) /* Boolean used to initialize new object. */
{
register Tcl_Obj *objPtr;
- TclNewObj(objPtr);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.longValue = (boolValue? 1 : 0);
- objPtr->typePtr = &tclBooleanType;
+ TclNewBooleanObj(objPtr, boolValue);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1304,20 +1711,20 @@ Tcl_NewBooleanObj(boolValue)
*
* Tcl_DbNewBooleanObj --
*
- * This procedure is normally called when debugging: i.e., when
+ * This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
- * same as the Tcl_NewBooleanObj procedure above except that it calls
+ * same as the Tcl_NewBooleanObj function above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
- * command will report the correct file name and line number when
+ * command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
- * When TCL_MEM_DEBUG is not defined, this procedure just returns the
+ * When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewBooleanObj.
*
* Results:
- * The newly created object is returned. This object will have an
- * invalid string representation. The returned object has ref count 0.
+ * The newly created object is returned. This object will have an invalid
+ * string representation. The returned object has ref count 0.
*
* Side effects:
* None.
@@ -1328,32 +1735,32 @@ Tcl_NewBooleanObj(boolValue)
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
-Tcl_DbNewBooleanObj(boolValue, file, line)
- register int boolValue; /* Boolean used to initialize new object. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbNewBooleanObj(
+ register int boolValue, /* Boolean used to initialize new object. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
-
+
objPtr->internalRep.longValue = (boolValue? 1 : 0);
- objPtr->typePtr = &tclBooleanType;
+ objPtr->typePtr = &tclIntType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_DbNewBooleanObj(boolValue, file, line)
- register int boolValue; /* Boolean used to initialize new object. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbNewBooleanObj(
+ register int boolValue, /* Boolean used to initialize new object. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
return Tcl_NewBooleanObj(boolValue);
}
@@ -1371,30 +1778,22 @@ Tcl_DbNewBooleanObj(boolValue, file, line)
* None.
*
* Side effects:
- * The object's old string rep, if any, is freed. Also, any old
- * internal rep is freed.
+ * The object's old string rep, if any, is freed. Also, any old internal
+ * rep is freed.
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetBooleanObj(objPtr, boolValue)
- register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
- register int boolValue; /* Boolean used to set object's value. */
+Tcl_SetBooleanObj(
+ register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ register int boolValue) /* Boolean used to set object's value. */
{
- register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
-
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetBooleanObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
-
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
-
- objPtr->internalRep.longValue = (boolValue? 1 : 0);
- objPtr->typePtr = &tclBooleanType;
- Tcl_InvalidateStringRep(objPtr);
+
+ TclSetBooleanObj(objPtr, boolValue);
}
/*
@@ -1402,9 +1801,8 @@ Tcl_SetBooleanObj(objPtr, boolValue)
*
* Tcl_GetBooleanFromObj --
*
- * Attempt to return a boolean from the Tcl object "objPtr". If the
- * object is not already a boolean, an attempt will be made to convert
- * it to one.
+ * 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
@@ -1412,30 +1810,56 @@ Tcl_SetBooleanObj(objPtr, boolValue)
* result unless "interp" is NULL.
*
* Side effects:
- * If the object is not already a boolean, the conversion will free
- * any old internal representation.
+ * The intrep of *objPtr may be changed.
*
*----------------------------------------------------------------------
*/
int
-Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object from which to get boolean. */
- register int *boolPtr; /* Place to store resulting boolean. */
+Tcl_GetBooleanFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr, /* The object from which to get boolean. */
+ register int *boolPtr) /* Place to store resulting boolean. */
{
- register int result;
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ *boolPtr = (objPtr->internalRep.longValue != 0);
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclBooleanType) {
+ *boolPtr = (int) objPtr->internalRep.longValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ /*
+ * Caution: Don't be tempted to check directly for the "double"
+ * Tcl_ObjType and then compare the intrep 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.
+ */
- if (objPtr->typePtr == &tclBooleanType) {
- result = TCL_OK;
- } else {
- result = SetBooleanFromAny(interp, objPtr);
- }
+ double d;
- if (result == TCL_OK) {
- *boolPtr = (int) objPtr->internalRep.longValue;
- }
- return result;
+ if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *boolPtr = (d != 0.0);
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ *boolPtr = 1;
+ return TCL_OK;
+ }
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ *boolPtr = (objPtr->internalRep.wideValue != 0);
+ return TCL_OK;
+ }
+#endif
+ } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
+ TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0)));
+ return TCL_ERROR;
}
/*
@@ -1452,218 +1876,174 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
* 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.
+ * 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.
*
*----------------------------------------------------------------------
*/
static int
-SetBooleanFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
-{
- Tcl_ObjType *oldTypePtr = objPtr->typePtr;
- char *string, *end;
- register char c;
- char lowerCase[10];
- int newBool, length;
- register int i;
-
+SetBooleanFromAny(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr) /* The object to convert. */
+{
/*
- * Get the string representation. Make it up-to-date if necessary.
+ * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
+ * whether a boolean conversion is possible without generating the string
+ * rep.
*/
-
- string = Tcl_GetStringFromObj(objPtr, &length);
+
+ if (objPtr->bytes == NULL) {
+ if (objPtr->typePtr == &tclIntType) {
+ switch (objPtr->internalRep.longValue) {
+ case 0L: case 1L:
+ return TCL_OK;
+ }
+ goto badBoolean;
+ }
+
+ if (objPtr->typePtr == &tclBignumType) {
+ goto badBoolean;
+ }
+
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ goto badBoolean;
+ }
+#endif
+
+ if (objPtr->typePtr == &tclDoubleType) {
+ goto badBoolean;
+ }
+ }
+
+ if (ParseBoolean(objPtr) == TCL_OK) {
+ return TCL_OK;
+ }
+
+ badBoolean:
+ if (interp != NULL) {
+ int length;
+ char *str = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_Obj *msg;
+
+ TclNewLiteralStringObj(msg, "expected boolean value but got \"");
+ Tcl_AppendLimitedToObj(msg, str, length, 50, "");
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
+ }
+ return TCL_ERROR;
+}
+
+static int
+ParseBoolean(
+ register Tcl_Obj *objPtr) /* The object to parse/convert. */
+{
+ int i, length, newBool;
+ char lowerCase[6], *str = TclGetStringFromObj(objPtr, &length);
+
+ if ((length == 0) || (length > 5)) {
+ /* longest valid boolean string rep. is "false" */
+ return TCL_ERROR;
+ }
+
+ switch (str[0]) {
+ case '0':
+ if (length == 1) {
+ newBool = 0;
+ goto numericBoolean;
+ }
+ return TCL_ERROR;
+ case '1':
+ if (length == 1) {
+ newBool = 1;
+ goto numericBoolean;
+ }
+ return TCL_ERROR;
+ }
/*
- * Use the obvious shortcuts for numerical values; if objPtr is not
- * of numerical type, parse its string rep.
+ * Force to lower case for case-insensitive detection. Filter out known
+ * invalid characters at the same time.
*/
-
- if (objPtr->typePtr == &tclIntType) {
- newBool = (objPtr->internalRep.longValue != 0);
- } else if (objPtr->typePtr == &tclDoubleType) {
- newBool = (objPtr->internalRep.doubleValue != 0.0);
- } else if (objPtr->typePtr == &tclWideIntType) {
- newBool = (objPtr->internalRep.wideValue != 0);
- } else {
- /*
- * Copy the string converting its characters to lower case.
- */
-
- for (i = 0; (i < 9) && (i < length); i++) {
- c = string[i];
- /*
- * Weed out international characters so we can safely operate
- * on single bytes.
- */
-
- if (c & 0x80) {
- goto badBoolean;
- }
- if (Tcl_UniCharIsUpper(UCHAR(c))) {
- c = (char) Tcl_UniCharToLower(UCHAR(c));
- }
+
+ 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[i] = 0;
-
+ }
+ lowerCase[length] = 0;
+ switch (lowerCase[0]) {
+ case 'y':
/*
- * Parse the string as a boolean. We use an implementation here that
- * doesn't report errors in interp if interp is NULL.
+ * Checking the 'y' is redundant, but makes the code clearer.
*/
-
- c = lowerCase[0];
- if ((c == '0') && (lowerCase[1] == '\0')) {
- newBool = 0;
- } else if ((c == '1') && (lowerCase[1] == '\0')) {
+ if (strncmp(lowerCase, "yes", (size_t) length) == 0) {
newBool = 1;
- } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
+ goto goodBoolean;
+ }
+ return TCL_ERROR;
+ case 'n':
+ if (strncmp(lowerCase, "no", (size_t) length) == 0) {
+ newBool = 0;
+ goto goodBoolean;
+ }
+ return TCL_ERROR;
+ case 't':
+ if (strncmp(lowerCase, "true", (size_t) length) == 0) {
newBool = 1;
- } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
+ goto goodBoolean;
+ }
+ return TCL_ERROR;
+ case 'f':
+ if (strncmp(lowerCase, "false", (size_t) length) == 0) {
newBool = 0;
- } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
+ goto goodBoolean;
+ }
+ return TCL_ERROR;
+ case 'o':
+ if (length < 2) {
+ return TCL_ERROR;
+ }
+ if (strncmp(lowerCase, "on", (size_t) length) == 0) {
newBool = 1;
- } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
+ goto goodBoolean;
+ } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
newBool = 0;
- } else if ((c == 'o') && (length >= 2)) {
- if (strncmp(lowerCase, "on", (size_t) length) == 0) {
- newBool = 1;
- } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
- newBool = 0;
- } else {
- goto badBoolean;
- }
- } else {
- double dbl;
- /*
- * Boolean values can be extracted from ints or doubles. Note
- * that we don't use strtoul or strtoull here because we don't
- * care about what the value is, just whether it is equal to
- * zero or not.
- */
-#ifdef TCL_WIDE_INT_IS_LONG
- newBool = strtol(string, &end, 0);
- if (end != string) {
- /*
- * Make sure the string has no garbage after the end of
- * the int.
- */
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO only */
- end++;
- }
- if (end == (string+length)) {
- newBool = (newBool != 0);
- goto goodBoolean;
- }
- }
-#else /* !TCL_WIDE_INT_IS_LONG */
- Tcl_WideInt wide = strtoll(string, &end, 0);
- if (end != string) {
- /*
- * Make sure the string has no garbage after the end of
- * the wide int.
- */
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO only */
- end++;
- }
- if (end == (string+length)) {
- newBool = (wide != Tcl_LongAsWide(0));
- goto goodBoolean;
- }
- }
-#endif /* TCL_WIDE_INT_IS_LONG */
- /*
- * Still might be a string containing the characters representing an
- * int or double that wasn't handled above. This would be a string
- * like "27" or "1.0" that is non-zero and not "1". Such a string
- * would result in the boolean value true. We try converting to
- * double. If that succeeds and the resulting double is non-zero, we
- * have a "true". Note that numbers can't have embedded NULLs.
- */
-
- dbl = strtod(string, &end);
- if (end == string) {
- goto badBoolean;
- }
-
- /*
- * Make sure the string has no garbage after the end of the double.
- */
-
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO only */
- end++;
- }
- if (end != (string+length)) {
- goto badBoolean;
- }
- newBool = (dbl != 0.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
+ * 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:
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
-
+ goodBoolean:
+ TclFreeIntRep(objPtr);
objPtr->internalRep.longValue = newBool;
objPtr->typePtr = &tclBooleanType;
return TCL_OK;
- badBoolean:
- if (interp != NULL) {
- /*
- * Must copy string before resetting the result in case a caller
- * is trying to convert the interpreter's result to a boolean.
- */
-
- char buf[100];
- sprintf(buf, "expected boolean value but got \"%.50s\"", string);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- }
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * UpdateStringOfBoolean --
- *
- * Update the string representation for a boolean object.
- * Note: This procedure does not free an existing old string rep
- * so storage will be lost if this has not already been done.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object's string is set to a valid string that results from
- * the boolean-to-string conversion.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfBoolean(objPtr)
- register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
-{
- char *s = ckalloc((unsigned) 2);
-
- s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
- s[1] = '\0';
- objPtr->bytes = s;
- objPtr->length = 1;
+ numericBoolean:
+ TclFreeIntRep(objPtr);
+ objPtr->internalRep.longValue = newBool;
+ objPtr->typePtr = &tclIntType;
+ return TCL_OK;
}
/*
@@ -1671,12 +2051,12 @@ UpdateStringOfBoolean(objPtr)
*
* Tcl_NewDoubleObj --
*
- * This procedure is normally called when not debugging: i.e., when
+ * 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 procedure just returns the
- * result of calling the debugging version Tcl_DbNewDoubleObj.
+ * 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
@@ -1692,8 +2072,8 @@ UpdateStringOfBoolean(objPtr)
#undef Tcl_NewDoubleObj
Tcl_Obj *
-Tcl_NewDoubleObj(dblValue)
- register double dblValue; /* Double used to initialize the object. */
+Tcl_NewDoubleObj(
+ register double dblValue) /* Double used to initialize the object. */
{
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
}
@@ -1701,16 +2081,12 @@ Tcl_NewDoubleObj(dblValue)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_NewDoubleObj(dblValue)
- register double dblValue; /* Double used to initialize the object. */
+Tcl_NewDoubleObj(
+ register double dblValue) /* Double used to initialize the object. */
{
register Tcl_Obj *objPtr;
- TclNewObj(objPtr);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.doubleValue = dblValue;
- objPtr->typePtr = &tclDoubleType;
+ TclNewDoubleObj(objPtr, dblValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -1720,20 +2096,20 @@ Tcl_NewDoubleObj(dblValue)
*
* Tcl_DbNewDoubleObj --
*
- * This procedure is normally called when debugging: i.e., when
+ * 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 procedure above except that it calls
+ * 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
+ * command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
- * When TCL_MEM_DEBUG is not defined, this procedure just returns the
+ * 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.
+ * The newly created object is returned. This object will have an invalid
+ * string representation. The returned object has ref count 0.
*
* Side effects:
* None.
@@ -1744,18 +2120,18 @@ Tcl_NewDoubleObj(dblValue)
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
-Tcl_DbNewDoubleObj(dblValue, file, line)
- register double dblValue; /* Double used to initialize the object. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbNewDoubleObj(
+ register 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. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
-
+
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
return objPtr;
@@ -1764,12 +2140,12 @@ Tcl_DbNewDoubleObj(dblValue, file, line)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_DbNewDoubleObj(dblValue, file, line)
- register double dblValue; /* Double used to initialize the object. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbNewDoubleObj(
+ register double dblValue, /* Double used to initialize the object. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
return Tcl_NewDoubleObj(dblValue);
}
@@ -1787,30 +2163,22 @@ Tcl_DbNewDoubleObj(dblValue, file, line)
* None.
*
* Side effects:
- * The object's old string rep, if any, is freed. Also, any old
- * internal rep is freed.
+ * The object's old string rep, if any, is freed. Also, any old internal
+ * rep is freed.
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetDoubleObj(objPtr, dblValue)
- register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
- register double dblValue; /* Double used to set the object's value. */
+Tcl_SetDoubleObj(
+ register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ register double dblValue) /* Double used to set the object's value. */
{
- register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
-
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetDoubleObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj");
}
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
-
- objPtr->internalRep.doubleValue = dblValue;
- objPtr->typePtr = &tclDoubleType;
- Tcl_InvalidateStringRep(objPtr);
+ TclSetDoubleObj(objPtr, dblValue);
}
/*
@@ -1818,9 +2186,8 @@ Tcl_SetDoubleObj(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.
+ * 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
@@ -1828,30 +2195,48 @@ Tcl_SetDoubleObj(objPtr, dblValue)
* result unless "interp" is NULL.
*
* Side effects:
- * If the object is not already a double, the conversion will free
- * any old internal representation.
+ * If the object is not already a double, the conversion will free any
+ * old internal representation.
*
*----------------------------------------------------------------------
*/
int
-Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object from which to get a double. */
- register double *dblPtr; /* Place to store resulting double. */
+Tcl_GetDoubleFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr, /* The object from which to get a double. */
+ register double *dblPtr) /* Place to store resulting double. */
{
- register int result;
-
- if (objPtr->typePtr == &tclDoubleType) {
- *dblPtr = objPtr->internalRep.doubleValue;
- return TCL_OK;
- }
-
- result = SetDoubleFromAny(interp, objPtr);
- if (result == TCL_OK) {
- *dblPtr = objPtr->internalRep.doubleValue;
- }
- return result;
+ do {
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "floating point value is Not a Number", -1));
+ }
+ return TCL_ERROR;
+ }
+ *dblPtr = (double) objPtr->internalRep.doubleValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclIntType) {
+ *dblPtr = objPtr->internalRep.longValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ mp_int big;
+ UNPACK_BIGNUM( objPtr, big );
+ *dblPtr = TclBignumToDouble( &big );
+ return TCL_OK;
+ }
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ *dblPtr = (double) objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+#endif
+ } while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
+ return TCL_ERROR;
}
/*
@@ -1875,78 +2260,12 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
*/
static int
-SetDoubleFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
+SetDoubleFromAny(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr) /* The object to convert. */
{
- Tcl_ObjType *oldTypePtr = objPtr->typePtr;
- char *string, *end;
- double newDouble;
- int length;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- string = Tcl_GetStringFromObj(objPtr, &length);
-
- /*
- * Now parse "objPtr"s string as an double. Numbers can't have embedded
- * NULLs. We use an implementation here that doesn't report errors in
- * interp if interp is NULL.
- */
-
- errno = 0;
- newDouble = strtod(string, &end);
- if (end == string) {
- badDouble:
- if (interp != NULL) {
- /*
- * Must copy string before resetting the result in case a caller
- * is trying to convert the interpreter's result to an int.
- */
-
- char buf[100];
- sprintf(buf, "expected floating-point number but got \"%.50s\"",
- string);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- }
- return TCL_ERROR;
- }
- if (errno != 0) {
- if (interp != NULL) {
- TclExprFloatError(interp, newDouble);
- }
- return TCL_ERROR;
- }
-
- /*
- * Make sure that the string has no garbage after the end of the double.
- */
-
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (end != (string+length)) {
- goto badDouble;
- }
-
- /*
- * The conversion to double succeeded. Free the old internalRep before
- * setting the new one. We do this as late as possible to allow the
- * conversion code, in particular Tcl_GetStringFromObj, to use that old
- * internalRep.
- */
-
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
-
- objPtr->internalRep.doubleValue = newDouble;
- objPtr->typePtr = &tclDoubleType;
- return TCL_OK;
+ return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1,
+ NULL, 0);
}
/*
@@ -1954,9 +2273,9 @@ SetDoubleFromAny(interp, objPtr)
*
* UpdateStringOfDouble --
*
- * Update the string representation for a double-precision floating
- * point object. This must obey the current tcl_precision value for
- * double-to-string conversions. Note: This procedure does not free an
+ * Update the string representation for a double-precision floating point
+ * object. This must obey the current tcl_precision value for
+ * double-to-string conversions. Note: This function does not free an
* existing old string rep so storage will be lost if this has not
* already been done.
*
@@ -1964,23 +2283,22 @@ SetDoubleFromAny(interp, objPtr)
* None.
*
* Side effects:
- * The object's string is set to a valid string that results from
- * the double-to-string conversion.
+ * The object's string is set to a valid string that results from the
+ * double-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
-UpdateStringOfDouble(objPtr)
- register Tcl_Obj *objPtr; /* Double obj with string rep to update. */
+UpdateStringOfDouble(
+ register Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
char buffer[TCL_DOUBLE_SPACE];
register int len;
-
- Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
- buffer);
+
+ Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer);
len = strlen(buffer);
-
+
objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
strcpy(objPtr->bytes, buffer);
objPtr->length = len;
@@ -1993,22 +2311,22 @@ UpdateStringOfDouble(objPtr)
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewIntObj to create a new integer object end up calling the
- * debugging procedure Tcl_DbNewLongObj instead.
+ * debugging function Tcl_DbNewLongObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewIntObj result in a call to one of the two
- * Tcl_NewIntObj implementations below. We provide two implementations
- * so that the Tcl core can be compiled to do memory debugging of the
- * core even if a client does not request it for itself.
+ * Tcl_NewIntObj implementations below. We provide two implementations so
+ * that the Tcl core can be compiled to do memory debugging of the core
+ * even if a client does not request it for itself.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
- * checks whether the current value of the long can be represented by
- * an int.
+ * checks whether the current value of the long can be represented by an
+ * int.
*
* Results:
- * The newly created object is returned. This object will have an
- * invalid string representation. The returned object has ref count 0.
+ * The newly created object is returned. This object will have an invalid
+ * string representation. The returned object has ref count 0.
*
* Side effects:
* None.
@@ -2020,8 +2338,8 @@ UpdateStringOfDouble(objPtr)
#undef Tcl_NewIntObj
Tcl_Obj *
-Tcl_NewIntObj(intValue)
- register int intValue; /* Int used to initialize the new object. */
+Tcl_NewIntObj(
+ register int intValue) /* Int used to initialize the new object. */
{
return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
}
@@ -2029,16 +2347,12 @@ Tcl_NewIntObj(intValue)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_NewIntObj(intValue)
- register int intValue; /* Int used to initialize the new object. */
+Tcl_NewIntObj(
+ register int intValue) /* Int used to initialize the new object. */
{
register Tcl_Obj *objPtr;
- TclNewObj(objPtr);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.longValue = (long)intValue;
- objPtr->typePtr = &tclIntType;
+ TclNewIntObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2055,30 +2369,22 @@ Tcl_NewIntObj(intValue)
* None.
*
* Side effects:
- * The object's old string rep, if any, is freed. Also, any old
- * internal rep is freed.
+ * The object's old string rep, if any, is freed. Also, any old internal
+ * rep is freed.
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetIntObj(objPtr, intValue)
- register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
- register int intValue; /* Integer used to set object's value. */
+Tcl_SetIntObj(
+ register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ register int intValue) /* Integer used to set object's value. */
{
- register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
-
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetIntObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_SetIntObj");
}
-
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
-
- objPtr->internalRep.longValue = (long) intValue;
- objPtr->typePtr = &tclIntType;
- Tcl_InvalidateStringRep(objPtr);
+
+ TclSetIntObj(objPtr, intValue);
}
/*
@@ -2091,67 +2397,48 @@ Tcl_SetIntObj(objPtr, intValue)
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
- * checks whether the current value of the long can be represented by
- * an int.
+ * checks whether the current value of the long can be represented by an
+ * int.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
- * during conversion or if the long integer held by the object
- * can not be represented by an int, an error message is left in
- * the interpreter's result unless "interp" is NULL.
+ * during conversion or if the long integer held by the object can not be
+ * represented by an int, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
*
* Side effects:
- * If the object is not already an int, the conversion will free
- * any old internal representation.
+ * If the object is not already an int, the conversion will free any old
+ * internal representation.
*
*----------------------------------------------------------------------
*/
int
-Tcl_GetIntFromObj(interp, objPtr, intPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object from which to get a int. */
- register int *intPtr; /* Place to store resulting int. */
+Tcl_GetIntFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr, /* The object from which to get a int. */
+ register int *intPtr) /* Place to store resulting int. */
{
- int result;
- Tcl_WideInt w = 0;
-
- /*
- * If the object isn't already an integer of any width, try to
- * convert it to one.
- */
-
- if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
- result = SetIntOrWideFromAny(interp, objPtr);
- if (result != TCL_OK) {
- return result;
- }
- }
-
- /*
- * Object should now be either int or wide. Get its value.
- */
+#if (LONG_MAX == INT_MAX)
+ return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
+#else
+ long l;
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- w = objPtr->internalRep.wideValue;
- } else
-#endif
- {
- w = Tcl_LongAsWide(objPtr->internalRep.longValue);
+ if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
+ return TCL_ERROR;
}
-
- if ((LLONG_MAX > UINT_MAX)
- && ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) {
+ if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) {
if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "integer value too large to represent as non-long integer",
- -1));
+ CONST char *s =
+ "integer value too large to represent as non-long integer";
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
- *intPtr = (int)w;
+ *intPtr = (int) l;
return TCL_OK;
+#endif
}
/*
@@ -2159,173 +2446,24 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr)
*
* 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 */
-{
- int result;
-
- result = SetIntOrWideFromAny( interp, objPtr );
- if ( result != TCL_OK ) {
- return result;
- }
- if ( objPtr->typePtr != &tclIntType ) {
- if ( interp != NULL ) {
- char *s = "integer value too large to represent";
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
- }
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SetIntOrWideFromAny --
- *
- * Attempt to generate an integer internal form for the Tcl object
- * "objPtr".
+ * 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.
*
- * Side effects:
- * If no error occurs, an int is stored as "objPtr"s internal
- * representation.
- *
*----------------------------------------------------------------------
*/
static int
-SetIntOrWideFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
-{
- Tcl_ObjType *oldTypePtr = objPtr->typePtr;
- char *string, *end;
- int length;
- register char *p;
- unsigned long newLong;
- int isNegative = 0;
- int isWide = 0;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- p = string = Tcl_GetStringFromObj(objPtr, &length);
-
- /*
- * Now parse "objPtr"s string as an int. We use an implementation here
- * that doesn't report errors in interp if interp is NULL. Note: use
- * strtoul instead of strtol for integer conversions to allow full-size
- * unsigned numbers, but don't depend on strtoul to handle sign
- * characters; it won't in some implementations.
- */
-
- errno = 0;
- for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
- /* Empty loop body. */
- }
- if (*p == '-') {
- p++;
- isNegative = 1;
- } else if (*p == '+') {
- p++;
- }
- if (!isdigit(UCHAR(*p))) {
- badInteger:
- if (interp != NULL) {
- /*
- * Must copy string before resetting the result in case a caller
- * is trying to convert the interpreter's result to an int.
- */
-
- char buf[100];
- sprintf(buf, "expected integer but got \"%.50s\"", string);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- TclCheckBadOctal(interp, string);
- }
- return TCL_ERROR;
- }
- newLong = strtoul(p, &end, 0);
- if (end == p) {
- goto badInteger;
- }
- if (errno == ERANGE) {
- if (interp != NULL) {
- char *s = "integer value too large to represent";
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
- }
- return TCL_ERROR;
- }
-
- /*
- * Make sure that the string has no garbage after the end of the int.
- */
-
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (end != (string+length)) {
- goto badInteger;
- }
-
- /*
- * If the resulting integer will exceed the range of a long,
- * put it into a wide instead. (Tcl Bug #868489)
- */
-
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
- || (!isNegative && newLong > LONG_MAX)) {
- isWide = 1;
- }
-#endif
-
- /*
- * The conversion to int succeeded. Free the old internalRep before
- * setting the new one. We do this as late as possible to allow the
- * conversion code, in particular Tcl_GetStringFromObj, to use that old
- * internalRep.
- */
-
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
-
- if (isWide) {
- objPtr->internalRep.wideValue =
- (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
- objPtr->typePtr = &tclWideIntType;
- } else {
- objPtr->internalRep.longValue =
- (isNegative ? -(long)newLong : (long)newLong);
- objPtr->typePtr = &tclIntType;
- }
- return TCL_OK;
+SetIntFromAny(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ Tcl_Obj *objPtr) /* Pointer to the object to convert */
+{
+ long l;
+ return TclGetLongFromObj(interp, objPtr, &l);
}
/*
@@ -2333,29 +2471,29 @@ SetIntOrWideFromAny(interp, objPtr)
*
* UpdateStringOfInt --
*
- * Update the string representation for an integer object.
- * Note: This procedure does not free an existing old string rep
- * so storage will be lost if this has not already been done.
+ * 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.
+ * The object's string is set to a valid string that results from the
+ * int-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
-UpdateStringOfInt(objPtr)
- register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
+UpdateStringOfInt(
+ register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char buffer[TCL_INTEGER_SPACE];
register int len;
-
+
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
-
+
objPtr->bytes = ckalloc((unsigned) len + 1);
strcpy(objPtr->bytes, buffer);
objPtr->length = len;
@@ -2367,23 +2505,23 @@ UpdateStringOfInt(objPtr)
* Tcl_NewLongObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
- * Tcl_NewLongObj to create a new long integer object end up calling
- * the debugging procedure Tcl_DbNewLongObj instead.
+ * Tcl_NewLongObj to create a new long integer object end up calling the
+ * debugging function Tcl_DbNewLongObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewLongObj result in a call to one of the two
* Tcl_NewLongObj implementations below. We provide two implementations
- * so that the Tcl core can be compiled to do memory debugging of the
+ * so that the Tcl core can be compiled to do memory debugging of the
* core even if a client does not request it for itself.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
- * checks whether the current value of the long can be represented by
- * an int.
+ * checks whether the current value of the long can be represented by an
+ * int.
*
* Results:
- * The newly created object is returned. This object will have an
- * invalid string representation. The returned object has ref count 0.
+ * The newly created object is returned. This object will have an invalid
+ * string representation. The returned object has ref count 0.
*
* Side effects:
* None.
@@ -2395,8 +2533,8 @@ UpdateStringOfInt(objPtr)
#undef Tcl_NewLongObj
Tcl_Obj *
-Tcl_NewLongObj(longValue)
- register long longValue; /* Long integer used to initialize the
+Tcl_NewLongObj(
+ register long longValue) /* Long integer used to initialize the
* new object. */
{
return Tcl_DbNewLongObj(longValue, "unknown", 0);
@@ -2405,17 +2543,13 @@ Tcl_NewLongObj(longValue)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_NewLongObj(longValue)
- register long longValue; /* Long integer used to initialize the
+Tcl_NewLongObj(
+ register long longValue) /* Long integer used to initialize the
* new object. */
{
register Tcl_Obj *objPtr;
- TclNewObj(objPtr);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.longValue = longValue;
- objPtr->typePtr = &tclIntType;
+ TclNewLongObj(objPtr, longValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2426,26 +2560,25 @@ Tcl_NewLongObj(longValue)
* Tcl_DbNewLongObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
- * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
- * long integer objects end up calling the debugging procedure
- * Tcl_DbNewLongObj instead. We provide two implementations of
- * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
- * memory debugging of the core is independent of whether a client
- * requests debugging for itself.
- *
- * When the core is compiled with TCL_MEM_DEBUG defined,
- * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
- * line number from its caller. This simplifies debugging since then
- * the [memory active] command will report the caller's file name and
- * line number when reporting objects that haven't been freed.
+ * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer
+ * objects end up calling the debugging function Tcl_DbNewLongObj
+ * instead. We provide two implementations of Tcl_DbNewLongObj so that
+ * whether the Tcl core is compiled to do memory debugging of the core is
+ * independent of whether a client requests debugging for itself.
+ *
+ * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj
+ * calls Tcl_DbCkalloc directly with the file name and line number from
+ * its caller. This simplifies debugging since then the [memory active]
+ * command will report the caller's file name and line number when
+ * reporting objects that haven't been freed.
*
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
- * this procedure just returns the result of calling Tcl_NewLongObj.
+ * this function just returns the result of calling Tcl_NewLongObj.
*
* Results:
- * The newly created long integer object is returned. This object
- * will have an invalid string representation. The returned object has
- * ref count 0.
+ * The newly created long integer object is returned. This object will
+ * have an invalid string representation. The returned object has ref
+ * count 0.
*
* Side effects:
* Allocates memory.
@@ -2456,19 +2589,19 @@ Tcl_NewLongObj(longValue)
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
-Tcl_DbNewLongObj(longValue, file, line)
- register long longValue; /* Long integer used to initialize the
- * new object. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbNewLongObj(
+ register long longValue, /* Long integer used to initialize the new
+ * object. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
-
+
objPtr->internalRep.longValue = longValue;
objPtr->typePtr = &tclIntType;
return objPtr;
@@ -2477,13 +2610,13 @@ Tcl_DbNewLongObj(longValue, file, line)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_DbNewLongObj(longValue, file, line)
- register long longValue; /* Long integer used to initialize the
- * new object. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbNewLongObj(
+ register long longValue, /* Long integer used to initialize the new
+ * object. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
return Tcl_NewLongObj(longValue);
}
@@ -2501,31 +2634,23 @@ Tcl_DbNewLongObj(longValue, file, line)
* None.
*
* Side effects:
- * The object's old string rep, if any, is freed. Also, any old
- * internal rep is freed.
+ * The object's old string rep, if any, is freed. Also, any old internal
+ * rep is freed.
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetLongObj(objPtr, longValue)
- register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
- register long longValue; /* Long integer used to initialize the
+Tcl_SetLongObj(
+ register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ register long longValue) /* Long integer used to initialize the
* object's value. */
{
- register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
-
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetLongObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_SetLongObj");
}
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
-
- objPtr->internalRep.longValue = longValue;
- objPtr->typePtr = &tclIntType;
- Tcl_InvalidateStringRep(objPtr);
+ TclSetLongObj(objPtr, longValue);
}
/*
@@ -2533,8 +2658,8 @@ Tcl_SetLongObj(objPtr, longValue)
*
* Tcl_GetLongFromObj --
*
- * Attempt to return an long integer from the Tcl object "objPtr". If
- * the object is not already an int object, an attempt will be made to
+ * 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:
@@ -2550,211 +2675,133 @@ Tcl_SetLongObj(objPtr, longValue)
*/
int
-Tcl_GetLongFromObj(interp, objPtr, longPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object from which to get a long. */
- register long *longPtr; /* Place to store resulting long. */
+Tcl_GetLongFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr, /* The object from which to get a long. */
+ register long *longPtr) /* Place to store resulting long. */
{
- register int result;
-
- if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
- result = SetIntOrWideFromAny(interp, objPtr);
- if (result != TCL_OK) {
- return result;
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ *longPtr = objPtr->internalRep.longValue;
+ return TCL_OK;
}
- }
-
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- /*
- * If the object is already a wide integer, don't convert it.
- * This code allows for any integer in the range -ULONG_MAX to
- * ULONG_MAX to be 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.
- */
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ /*
+ * We return any integer in the range -ULONG_MAX to ULONG_MAX
+ * converted to a long, ignoring overflow. The rule preserves
+ * existing semantics for conversion of integers on input, but
+ * avoids inadvertent demotion of wide integers to 32-bit ones in
+ * the internal rep.
+ */
- Tcl_WideInt w = objPtr->internalRep.wideValue;
- if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) {
- *longPtr = Tcl_WideAsLong(w);
- return TCL_OK;
- } else {
- if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "integer value too large to represent", -1);
+ Tcl_WideInt w = objPtr->internalRep.wideValue;
+ if (w >= -(Tcl_WideInt)(ULONG_MAX)
+ && w <= (Tcl_WideInt)(ULONG_MAX)) {
+ *longPtr = Tcl_WideAsLong(w);
+ return TCL_OK;
}
- return TCL_ERROR;
+ goto tooLarge;
}
- }
-#endif
-
- *longPtr = objPtr->internalRep.longValue;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SetWideIntFromAny --
- *
- * Attempt to generate an integer internal form for the Tcl object
- * "objPtr".
- *
- * Results:
- * The return value is a standard object Tcl result. If an error occurs
- * during conversion, an error message is left in the interpreter's
- * result unless "interp" is NULL.
- *
- * Side effects:
- * If no error occurs, an int is stored as "objPtr"s internal
- * representation.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetWideIntFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
-{
-#ifndef TCL_WIDE_INT_IS_LONG
- Tcl_ObjType *oldTypePtr = objPtr->typePtr;
- char *string, *end;
- int length;
- register char *p;
- Tcl_WideInt newWide;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- p = string = Tcl_GetStringFromObj(objPtr, &length);
-
- /*
- * Now parse "objPtr"s string as an int. We use an implementation here
- * that doesn't report errors in interp if interp is NULL. Note: use
- * strtoull instead of strtoll for integer conversions to allow full-size
- * unsigned numbers, but don't depend on strtoull to handle sign
- * characters; it won't in some implementations.
- */
-
- errno = 0;
-#ifdef TCL_STRTOUL_SIGN_CHECK
- for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
- /* Empty loop body. */
- }
- if (*p == '-') {
- p++;
- newWide = -((Tcl_WideInt)strtoull(p, &end, 0));
- } else if (*p == '+') {
- p++;
- newWide = strtoull(p, &end, 0);
- } else
-#else
- newWide = strtoull(p, &end, 0);
#endif
- if (end == p) {
- badInteger:
- if (interp != NULL) {
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_Obj *msg;
+
+ TclNewLiteralStringObj(msg, "expected integer but got \"");
+ Tcl_AppendObjToObj(msg, objPtr);
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
+ }
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
/*
- * Must copy string before resetting the result in case a caller
- * is trying to convert the interpreter's result to an int.
+ * 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.
*/
-
- char buf[100];
- sprintf(buf, "expected integer but got \"%.50s\"", string);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- TclCheckBadOctal(interp, string);
- }
- return TCL_ERROR;
- }
- if (errno == ERANGE) {
- if (interp != NULL) {
- char *s = "integer value too large to represent";
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
- }
- return TCL_ERROR;
- }
- /*
- * Make sure that the string has no garbage after the end of the int.
- */
-
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (end != (string+length)) {
- goto badInteger;
- }
-
- /*
- * The conversion to int succeeded. Free the old internalRep before
- * setting the new one. We do this as late as possible to allow the
- * conversion code, in particular Tcl_GetStringFromObj, to use that old
- * internalRep.
- */
-
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
-
- objPtr->internalRep.wideValue = newWide;
-#else
- if (TCL_ERROR == SetIntFromAny(interp, objPtr)) {
- return TCL_ERROR;
- }
+ mp_int big;
+
+ UNPACK_BIGNUM(objPtr, big);
+ if ((size_t)(big.used) <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
+ / DIGIT_BIT) {
+ unsigned long value = 0, numBytes = sizeof(long);
+ long scratch;
+ unsigned char *bytes = (unsigned char *)&scratch;
+ if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ *longPtr = - (long) value;
+ } else {
+ *longPtr = (long) value;
+ }
+ return TCL_OK;
+ }
+ }
+#ifndef NO_WIDE_TYPE
+ tooLarge:
#endif
- objPtr->typePtr = &tclWideIntType;
- return TCL_OK;
+ if (interp != NULL) {
+ char *s = "integer value too large to represent";
+ Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
+
+ Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
+ }
+ return TCL_ERROR;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
}
+#ifndef NO_WIDE_TYPE
/*
*----------------------------------------------------------------------
*
* UpdateStringOfWideInt --
*
- * Update the string representation for a wide integer object.
- * Note: This procedure does not free an existing old string rep
- * so storage will be lost if this has not already been done.
+ * Update the string representation for a wide integer object. Note: this
+ * function does not free an existing old string rep so storage will be
+ * lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
- * The object's string is set to a valid string that results from
- * the wideInt-to-string conversion.
+ * The object's string is set to a valid string that results from the
+ * wideInt-to-string conversion.
*
*----------------------------------------------------------------------
*/
-#ifndef TCL_WIDE_INT_IS_LONG
static void
-UpdateStringOfWideInt(objPtr)
- register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
+UpdateStringOfWideInt(
+ register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char buffer[TCL_INTEGER_SPACE+2];
register unsigned len;
register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
/*
- * Note that sprintf will generate a compiler warning under
- * Mingw claiming %I64 is an unknown format specifier.
- * Just ignore this warning. We can't use %L as the format
- * specifier since that gets printed as a 32 bit value.
+ * Note that sprintf will generate a compiler warning under Mingw claiming
+ * %I64 is an unknown format specifier. Just ignore this warning. We can't
+ * use %L as the format specifier since that gets printed as a 32 bit
+ * value.
*/
+
sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
len = strlen(buffer);
objPtr->bytes = ckalloc((unsigned) len + 1);
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
-#endif /* TCL_WIDE_INT_IS_LONG */
+#endif /* !NO_WIDE_TYPE */
/*
*----------------------------------------------------------------------
@@ -2763,17 +2810,17 @@ UpdateStringOfWideInt(objPtr)
*
* 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 procedure Tcl_DbNewWideIntObj instead.
+ * 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.
+ * 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.
+ * The newly created object is returned. This object will have an invalid
+ * string representation. The returned object has ref count 0.
*
* Side effects:
* None.
@@ -2785,9 +2832,10 @@ UpdateStringOfWideInt(objPtr)
#undef Tcl_NewWideIntObj
Tcl_Obj *
-Tcl_NewWideIntObj(wideValue)
- register Tcl_WideInt wideValue; /* Wide integer used to initialize
- * the new object. */
+Tcl_NewWideIntObj(
+ register Tcl_WideInt wideValue)
+ /* Wide integer used to initialize the new
+ * object. */
{
return Tcl_DbNewWideIntObj(wideValue, "unknown", 0);
}
@@ -2795,17 +2843,15 @@ Tcl_NewWideIntObj(wideValue)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_NewWideIntObj(wideValue)
- register Tcl_WideInt wideValue; /* Wide integer used to initialize
- * the new object. */
+Tcl_NewWideIntObj(
+ register Tcl_WideInt wideValue)
+ /* Wide integer used to initialize the new
+ * object. */
{
register Tcl_Obj *objPtr;
TclNewObj(objPtr);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.wideValue = wideValue;
- objPtr->typePtr = &tclWideIntType;
+ Tcl_SetWideIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2816,27 +2862,25 @@ Tcl_NewWideIntObj(wideValue)
* 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 procedure 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.
+ * 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.
+ * 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 procedure just returns the result of calling Tcl_NewWideIntObj.
+ * 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.
+ * 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.
@@ -2847,36 +2891,33 @@ Tcl_NewWideIntObj(wideValue)
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
-Tcl_DbNewWideIntObj(wideValue, file, line)
- register Tcl_WideInt wideValue; /* Wide integer used to initialize
- * the new object. */
- CONST char *file; /* The name of the source file
- * calling this procedure; used for
- * debugging. */
- int line; /* Line number in the source file;
- * used for debugging. */
+Tcl_DbNewWideIntObj(
+ register 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. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.wideValue = wideValue;
- objPtr->typePtr = &tclWideIntType;
+ Tcl_SetWideIntObj(objPtr, wideValue);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
-Tcl_DbNewWideIntObj(wideValue, file, line)
- register Tcl_WideInt wideValue; /* Long integer used to initialize
- * the new object. */
- CONST char *file; /* The name of the source file
- * calling this procedure; used for
- * debugging. */
- int line; /* Line number in the source file;
- * used for debugging. */
+Tcl_DbNewWideIntObj(
+ register Tcl_WideInt wideValue,
+ /* Long integer used to initialize the new
+ * object. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
return Tcl_NewWideIntObj(wideValue);
}
@@ -2887,38 +2928,43 @@ Tcl_DbNewWideIntObj(wideValue, file, line)
*
* Tcl_SetWideIntObj --
*
- * Modify an object to be a wide integer object and to have the
- * specified wide integer value.
+ * 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.
+ * The object's old string rep, if any, is freed. Also, any old internal
+ * rep is freed.
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetWideIntObj(objPtr, wideValue)
- register Tcl_Obj *objPtr; /* Object w. internal rep to init. */
- register Tcl_WideInt wideValue; /* Wide integer used to initialize
- * the object's value. */
+Tcl_SetWideIntObj(
+ register Tcl_Obj *objPtr, /* Object w. internal rep to init. */
+ register Tcl_WideInt wideValue)
+ /* Wide integer used to initialize the
+ * object's value. */
{
- register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
-
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetWideIntObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
+ if ((wideValue >= (Tcl_WideInt) LONG_MIN)
+ && (wideValue <= (Tcl_WideInt) LONG_MAX)) {
+ TclSetLongObj(objPtr, (long) wideValue);
+ } else {
+#ifndef NO_WIDE_TYPE
+ TclSetWideIntObj(objPtr, wideValue);
+#else
+ mp_int big;
+
+ TclBNInitBignumFromWideInt(&big, wideValue);
+ Tcl_SetBignumObj(objPtr, &big);
+#endif
}
-
- objPtr->internalRep.wideValue = wideValue;
- objPtr->typePtr = &tclWideIntType;
- Tcl_InvalidateStringRep(objPtr);
}
/*
@@ -2926,9 +2972,9 @@ Tcl_SetWideIntObj(objPtr, wideValue)
*
* 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.
+ * 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
@@ -2943,33 +2989,589 @@ Tcl_SetWideIntObj(objPtr, wideValue)
*/
int
-Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* Object from which to get a wide int. */
- register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
+Tcl_GetWideIntFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr, /* Object from which to get a wide int. */
+ register Tcl_WideInt *wideIntPtr)
+ /* Place to store resulting long. */
{
- register int result;
+ do {
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ *wideIntPtr = objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+#endif
+ if (objPtr->typePtr == &tclIntType) {
+ *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_Obj *msg;
+
+ TclNewLiteralStringObj(msg, "expected integer but got \"");
+ Tcl_AppendObjToObj(msg, objPtr);
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
+ }
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ /*
+ * Must check for those bignum values that can fit in a
+ * Tcl_WideInt, even when auto-narrowing is enabled.
+ */
- if (objPtr->typePtr == &tclWideIntType) {
- gotWide:
- *wideIntPtr = objPtr->internalRep.wideValue;
- return TCL_OK;
+ mp_int big;
+
+ UNPACK_BIGNUM(objPtr, big);
+ if ((size_t)(big.used) <= (CHAR_BIT * sizeof(Tcl_WideInt)
+ + DIGIT_BIT - 1) / DIGIT_BIT) {
+ Tcl_WideUInt value = 0;
+ unsigned long numBytes = sizeof(Tcl_WideInt);
+ Tcl_WideInt scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ *wideIntPtr = - (Tcl_WideInt) value;
+ } else {
+ *wideIntPtr = (Tcl_WideInt) value;
+ }
+ return TCL_OK;
+ }
+ }
+ if (interp != NULL) {
+ char *s = "integer value too large to represent";
+ Tcl_Obj* msg = Tcl_NewStringObj(s, -1);
+
+ Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
+ }
+ return TCL_ERROR;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
+}
+#ifndef NO_WIDE_TYPE
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetWideIntFromAny --
+ *
+ * Attempts to force the internal representation for a Tcl object to
+ * tclWideIntType, specifically.
+ *
+ * Results:
+ * The return value is a standard object Tcl result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetWideIntFromAny(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ Tcl_Obj *objPtr) /* Pointer to the object to convert */
+{
+ Tcl_WideInt w;
+ return Tcl_GetWideIntFromObj(interp, objPtr, &w);
+}
+#endif /* !NO_WIDE_TYPE */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeBignum --
+ *
+ * This function frees the internal rep of a bignum.
+ *
+ * Results:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeBignum(
+ Tcl_Obj *objPtr)
+{
+ mp_int toFree; /* Bignum to free */
+
+ UNPACK_BIGNUM(objPtr, toFree);
+ mp_clear(&toFree);
+ if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) {
+ ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupBignum --
+ *
+ * This function duplicates the internal rep of a bignum.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The destination object receies a copy of the source object
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupBignum(
+ Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr)
+{
+ mp_int bignumVal;
+ mp_int bignumCopy;
+
+ copyPtr->typePtr = &tclBignumType;
+ UNPACK_BIGNUM(srcPtr, bignumVal);
+ if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
+ Tcl_Panic("initialization failure in DupBignum");
}
- if (objPtr->typePtr == &tclIntType) {
+ PACK_BIGNUM(bignumCopy, copyPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfBignum --
+ *
+ * This function updates the string representation of a bignum object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string is set to whatever results from the bignum-
+ * to-string conversion.
+ *
+ * The object's existing string representation is NOT freed; memory will leak
+ * if the string rep is still valid at the time this function is called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfBignum(
+ Tcl_Obj *objPtr)
+{
+ mp_int bignumVal;
+ int size;
+ int status;
+ char* stringVal;
+
+ UNPACK_BIGNUM(objPtr, bignumVal);
+ status = mp_radix_size(&bignumVal, 10, &size);
+ if (status != MP_OKAY) {
+ Tcl_Panic("radix size failure in UpdateStringOfBignum");
+ }
+ if (size == 3) {
/*
- * This cast is safe; all valid ints/longs are wides.
+ * mp_radix_size() returns 3 when more than INT_MAX bytes would be
+ * needed to hold the string rep (because mp_radix_size ignores
+ * integer overflow issues). When we know the string rep will be more
+ * than 3, we can conclude the string rep would overflow our string
+ * length limits.
+ *
+ * Note that so long as we enforce our bignums to the size that fits
+ * in a packed bignum, this branch will never be taken.
*/
- objPtr->internalRep.wideValue =
- Tcl_LongAsWide(objPtr->internalRep.longValue);
- objPtr->typePtr = &tclWideIntType;
- goto gotWide;
+ Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
- result = SetWideIntFromAny(interp, objPtr);
- if (result == TCL_OK) {
- *wideIntPtr = objPtr->internalRep.wideValue;
+ stringVal = ckalloc((size_t) size);
+ status = mp_toradix_n(&bignumVal, stringVal, 10, size);
+ if (status != MP_OKAY) {
+ Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
- return result;
+ objPtr->bytes = stringVal;
+ objPtr->length = size - 1; /* size includes a trailing null byte */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NewBignumObj --
+ *
+ * Creates an initializes a bignum object.
+ *
+ * Results:
+ * Returns the newly created object.
+ *
+ * Side effects:
+ * The bignum value is cleared, since ownership has transferred to Tcl.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+#undef Tcl_NewBignumObj
+
+Tcl_Obj *
+Tcl_NewBignumObj(
+ mp_int *bignumValue)
+{
+ return Tcl_DbNewBignumObj(bignumValue, "unknown", 0);
+}
+#else
+Tcl_Obj *
+Tcl_NewBignumObj(
+ mp_int *bignumValue)
+{
+ Tcl_Obj* objPtr;
+
+ TclNewObj(objPtr);
+ Tcl_SetBignumObj(objPtr, bignumValue);
+ return objPtr;
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbNewBignumObj --
+ *
+ * This function is normally called when debugging: that is, when
+ * TCL_MEM_DEBUG is defined. It constructs a bignum object, recording the
+ * creation point so that [memory active] can report it.
+ *
+ * Results:
+ * Returns the newly created object.
+ *
+ * Side effects:
+ * The bignum value is cleared, since ownership has transferred to Tcl.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+Tcl_Obj *
+Tcl_DbNewBignumObj(
+ mp_int *bignumValue,
+ CONST char *file,
+ int line)
+{
+ Tcl_Obj *objPtr;
+
+ TclDbNewObj(objPtr, file, line);
+ Tcl_SetBignumObj(objPtr, bignumValue);
+ return objPtr;
+}
+#else
+Tcl_Obj *
+Tcl_DbNewBignumObj(
+ mp_int *bignumValue,
+ CONST char *file,
+ int line)
+{
+ return Tcl_NewBignumObj(bignumValue);
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetBignumFromObj --
+ *
+ * This function retrieves a 'bignum' value from a Tcl object, converting
+ * the object if necessary. Either copies or transfers the mp_int value
+ * depending on the copy flag value passed in.
+ *
+ * Results:
+ * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * A copy of bignum is stored in *bignumValue, which is expected to be
+ * uninitialized or cleared. If conversion fails, and the 'interp'
+ * argument is not NULL, an error message is stored in the interpreter
+ * result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetBignumFromObj(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting */
+ Tcl_Obj *objPtr, /* Object to read */
+ int copy, /* Whether to copy the returned bignum value */
+ mp_int *bignumValue) /* Returned bignum value. */
+{
+ do {
+ if (objPtr->typePtr == &tclBignumType) {
+ if (copy || Tcl_IsShared(objPtr)) {
+ mp_int temp;
+ UNPACK_BIGNUM(objPtr, temp);
+ mp_init_copy(bignumValue, &temp);
+ } else {
+ UNPACK_BIGNUM(objPtr, *bignumValue);
+ objPtr->internalRep.ptrAndLongRep.ptr = NULL;
+ objPtr->internalRep.ptrAndLongRep.value = 0;
+ objPtr->typePtr = NULL;
+ if (objPtr->bytes == NULL) {
+ TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ }
+ }
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclIntType) {
+ TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
+ return TCL_OK;
+ }
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ TclBNInitBignumFromWideInt(bignumValue,
+ objPtr->internalRep.wideValue);
+ return TCL_OK;
+ }
+#endif
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_Obj *msg;
+
+ TclNewLiteralStringObj(msg, "expected integer but got \"");
+ Tcl_AppendObjToObj(msg, objPtr);
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
+ }
+ return TCL_ERROR;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetBignumFromObj --
+ *
+ * This function retrieves a 'bignum' value from a Tcl object, converting
+ * the object if necessary.
+ *
+ * Results:
+ * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * A copy of bignum is stored in *bignumValue, which is expected to be
+ * uninitialized or cleared. If conversion fails, an the 'interp'
+ * argument is not NULL, an error message is stored in the interpreter
+ * result.
+ *
+ * It is expected that the caller will NOT have invoked mp_init on the
+ * bignum value before passing it in. Tcl will initialize the mp_int as
+ * it sets the value. The value is a copy of the value in objPtr, so it
+ * becomes the responsibility of the caller to call mp_clear on it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetBignumFromObj(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting */
+ Tcl_Obj *objPtr, /* Object to read */
+ mp_int *bignumValue) /* Returned bignum value. */
+{
+ return GetBignumFromObj(interp, objPtr, 1, bignumValue);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_TakeBignumFromObj --
+ *
+ * This function retrieves a 'bignum' value from a Tcl object, converting
+ * the object if necessary.
+ *
+ * Results:
+ * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * A copy of bignum is stored in *bignumValue, which is expected to be
+ * uninitialized or cleared. If conversion fails, an the 'interp'
+ * argument is not NULL, an error message is stored in the interpreter
+ * result.
+ *
+ * It is expected that the caller will NOT have invoked mp_init on the
+ * bignum value before passing it in. Tcl will initialize the mp_int as
+ * it sets the value. The value is transferred from the internals of
+ * objPtr to the caller, passing responsibility of the caller to call
+ * mp_clear on it. The objPtr is cleared to hold an empty value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_TakeBignumFromObj(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting */
+ Tcl_Obj *objPtr, /* Object to read */
+ mp_int *bignumValue) /* Returned bignum value. */
+{
+ return GetBignumFromObj(interp, objPtr, 0, bignumValue);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetBignumObj --
+ *
+ * This function sets the value of a Tcl_Obj to a large integer.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Object value is stored. The bignum value is cleared, since ownership
+ * has transferred to Tcl.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetBignumObj(
+ Tcl_Obj *objPtr, /* Object to set */
+ mp_int *bignumValue) /* Value to store */
+{
+ if (Tcl_IsShared(objPtr)) {
+ Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
+ }
+ if ((size_t)(bignumValue->used)
+ <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) {
+ unsigned long value = 0, numBytes = sizeof(long);
+ long scratch;
+ unsigned char *bytes = (unsigned char *)&scratch;
+ if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
+ goto tooLargeForLong;
+ }
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) {
+ goto tooLargeForLong;
+ }
+ if (bignumValue->sign) {
+ TclSetLongObj(objPtr, -(long)value);
+ } else {
+ TclSetLongObj(objPtr, (long)value);
+ }
+ mp_clear(bignumValue);
+ return;
+ }
+ tooLargeForLong:
+#ifndef NO_WIDE_TYPE
+ if ((size_t)(bignumValue->used)
+ <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
+ Tcl_WideUInt value = 0;
+ unsigned long numBytes = sizeof(Tcl_WideInt);
+ Tcl_WideInt scratch;
+ unsigned char *bytes = (unsigned char *)&scratch;
+ if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
+ goto tooLargeForWide;
+ }
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) {
+ goto tooLargeForWide;
+ }
+ if (bignumValue->sign) {
+ TclSetWideIntObj(objPtr, -(Tcl_WideInt)value);
+ } else {
+ TclSetWideIntObj(objPtr, (Tcl_WideInt)value);
+ }
+ mp_clear(bignumValue);
+ return;
+ }
+ tooLargeForWide:
+#endif
+ TclInvalidateStringRep(objPtr);
+ TclFreeIntRep(objPtr);
+ TclSetBignumIntRep(objPtr, bignumValue);
+}
+
+void
+TclSetBignumIntRep(
+ Tcl_Obj *objPtr,
+ mp_int *bignumValue)
+{
+ objPtr->typePtr = &tclBignumType;
+ PACK_BIGNUM(*bignumValue, objPtr);
+
+ /*
+ * Clear the mp_int value.
+ * Don't call mp_clear() because it would free the digit array
+ * we just packed into the Tcl_Obj.
+ */
+
+ bignumValue->dp = NULL;
+ bignumValue->alloc = bignumValue->used = 0;
+ bignumValue->sign = MP_NEG;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetNumberFromObj --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *----------------------------------------------------------------------
+ */
+
+int TclGetNumberFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ ClientData *clientDataPtr,
+ int *typePtr)
+{
+ do {
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+ *typePtr = TCL_NUMBER_NAN;
+ } else {
+ *typePtr = TCL_NUMBER_DOUBLE;
+ }
+ *clientDataPtr = &(objPtr->internalRep.doubleValue);
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclIntType) {
+ *typePtr = TCL_NUMBER_LONG;
+ *clientDataPtr = &(objPtr->internalRep.longValue);
+ return TCL_OK;
+ }
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ *typePtr = TCL_NUMBER_WIDE;
+ *clientDataPtr = &(objPtr->internalRep.wideValue);
+ return TCL_OK;
+ }
+#endif
+ if (objPtr->typePtr == &tclBignumType) {
+ static Tcl_ThreadDataKey bignumKey;
+ mp_int *bigPtr = Tcl_GetThreadData(&bignumKey,
+ (int) sizeof(mp_int));
+ UNPACK_BIGNUM( objPtr, *bigPtr );
+ *typePtr = TCL_NUMBER_BIG;
+ *clientDataPtr = bigPtr;
+ return TCL_OK;
+ }
+ } while (TCL_OK ==
+ TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
+ return TCL_ERROR;
}
/*
@@ -2977,12 +3579,12 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
*
* Tcl_DbIncrRefCount --
*
- * This procedure is normally called when debugging: i.e., when
- * TCL_MEM_DEBUG is defined. This checks to see whether or not
- * the memory has been freed before incrementing the ref count.
+ * 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 procedure just increments
- * the reference count of the object.
+ * When TCL_MEM_DEBUG is not defined, this function just increments the
+ * reference count of the object.
*
* Results:
* None.
@@ -2994,20 +3596,45 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
*/
void
-Tcl_DbIncrRefCount(objPtr, file, line)
- register Tcl_Obj *objPtr; /* The object we are registering a
- * reference to. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbIncrRefCount(
+ register Tcl_Obj *objPtr, /* The object we are registering a reference
+ * to. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
- panic("Trying to increment refCount of previously disposed object.");
+ Tcl_Panic("incrementing refCount of previously disposed object");
}
+
+# ifdef TCL_THREADS
+ /*
+ * Check to make sure that the Tcl_Obj was allocated by the current
+ * thread. Don't do this check when shutting down since thread local
+ * storage can be finalized before the last Tcl_Obj is freed.
+ */
+
+ if (!TclInExit()) {
+ Tcl_HashTable *tablePtr;
+ Tcl_HashEntry *hPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ tablePtr = tsdPtr->objThreadMap;
+ if (!tablePtr) {
+ Tcl_Panic("object table not initialized");
+ }
+ hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ if (!hPtr) {
+ Tcl_Panic("%s%s",
+ "Trying to incr ref count of "
+ "Tcl_Obj allocated in another thread");
+ }
+ }
+# endif
#endif
++(objPtr)->refCount;
}
@@ -3017,12 +3644,12 @@ Tcl_DbIncrRefCount(objPtr, file, line)
*
* Tcl_DbDecrRefCount --
*
- * This procedure is normally called when debugging: i.e., when
- * TCL_MEM_DEBUG is defined. This checks to see whether or not
- * the memory has been freed before decrementing the ref count.
+ * 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 procedure just decrements
- * the reference count of the object.
+ * When TCL_MEM_DEBUG is not defined, this function just decrements the
+ * reference count of the object.
*
* Results:
* None.
@@ -3034,20 +3661,59 @@ Tcl_DbIncrRefCount(objPtr, file, line)
*/
void
-Tcl_DbDecrRefCount(objPtr, file, line)
- register Tcl_Obj *objPtr; /* The object we are releasing a reference
+Tcl_DbDecrRefCount(
+ register Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
- panic("Trying to decrement refCount of previously disposed object.");
+ Tcl_Panic("decrementing refCount of previously disposed object");
}
+
+# ifdef TCL_THREADS
+ /*
+ * Check to make sure that the Tcl_Obj was allocated by the current
+ * thread. Don't do this check when shutting down since thread local
+ * storage can be finalized before the last Tcl_Obj is freed.
+ */
+
+ if (!TclInExit()) {
+ Tcl_HashTable *tablePtr;
+ Tcl_HashEntry *hPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ tablePtr = tsdPtr->objThreadMap;
+ if (!tablePtr) {
+ Tcl_Panic("object table not initialized");
+ }
+ hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ if (!hPtr) {
+ Tcl_Panic("%s%s",
+ "Trying to decr ref count of "
+ "Tcl_Obj allocated in another thread");
+ }
+
+ /*
+ * If the Tcl_Obj is going to be deleted, remove the entry.
+ */
+
+ if ((objPtr->refCount - 1) <= 0) {
+ ObjData *objData = Tcl_GetHashValue(hPtr);
+
+ if (objData != NULL) {
+ ckfree((char *) objData);
+ }
+
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ }
+# endif
#endif
if (--(objPtr)->refCount <= 0) {
TclFreeObj(objPtr);
@@ -3059,12 +3725,12 @@ Tcl_DbDecrRefCount(objPtr, file, line)
*
* Tcl_DbIsShared --
*
- * This procedure 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.
+ * 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 procedure just tests
- * if 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.
@@ -3076,20 +3742,45 @@ Tcl_DbDecrRefCount(objPtr, file, line)
*/
int
-Tcl_DbIsShared(objPtr, file, line)
- register Tcl_Obj *objPtr; /* The object to test for being shared. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+Tcl_DbIsShared(
+ register Tcl_Obj *objPtr, /* The object to test for being shared. */
+ CONST char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
- panic("Trying to check whether previously disposed object is shared.");
+ Tcl_Panic("checking whether previously disposed object is shared");
+ }
+
+# ifdef TCL_THREADS
+ /*
+ * Check to make sure that the Tcl_Obj was allocated by the current
+ * thread. Don't do this check when shutting down since thread local
+ * storage can be finalized before the last Tcl_Obj is freed.
+ */
+
+ if (!TclInExit()) {
+ Tcl_HashTable *tablePtr;
+ Tcl_HashEntry *hPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ tablePtr = tsdPtr->objThreadMap;
+ if (!tablePtr) {
+ Tcl_Panic("object table not initialized");
+ }
+ hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
+ if (!hPtr) {
+ Tcl_Panic("%s%s",
+ "Trying to check shared status of"
+ "Tcl_Obj allocated in another thread");
+ }
}
+# endif
#endif
+
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
if ((objPtr)->refCount <= 1) {
@@ -3101,6 +3792,7 @@ Tcl_DbIsShared(objPtr, file, line)
}
Tcl_MutexUnlock(&tclObjMutex);
#endif
+
return ((objPtr)->refCount > 1);
}
@@ -3109,8 +3801,8 @@ Tcl_DbIsShared(objPtr, file, line)
*
* Tcl_InitObjHashTable --
*
- * Given storage for a hash table, set up the fields to prepare
- * the hash table for use, the keys are Tcl_Obj *.
+ * Given storage for a hash table, set up the fields to prepare the hash
+ * table for use, the keys are Tcl_Obj *.
*
* Results:
* None.
@@ -3123,9 +3815,10 @@ Tcl_DbIsShared(objPtr, file, line)
*/
void
-Tcl_InitObjHashTable(tablePtr)
- register Tcl_HashTable *tablePtr; /* Pointer to table record, which
- * is supplied by the caller. */
+Tcl_InitObjHashTable(
+ register Tcl_HashTable *tablePtr)
+ /* Pointer to table record, which is supplied
+ * by the caller. */
{
Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
&tclObjHashKeyType);
@@ -3148,16 +3841,17 @@ Tcl_InitObjHashTable(tablePtr)
*/
static Tcl_HashEntry *
-AllocObjEntry(tablePtr, keyPtr)
- Tcl_HashTable *tablePtr; /* Hash table. */
- VOID *keyPtr; /* Key to store in the hash table entry. */
+AllocObjEntry(
+ Tcl_HashTable *tablePtr, /* Hash table. */
+ void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
Tcl_HashEntry *hPtr;
hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
hPtr->key.oneWordValue = (char *) objPtr;
- Tcl_IncrRefCount (objPtr);
+ Tcl_IncrRefCount(objPtr);
+ hPtr->clientData = NULL;
return hPtr;
}
@@ -3165,13 +3859,13 @@ AllocObjEntry(tablePtr, keyPtr)
/*
*----------------------------------------------------------------------
*
- * CompareObjKeys --
+ * TclCompareObjKeys --
*
* Compares two Tcl_Obj * keys.
*
* Results:
- * The return value is 0 if they are different and 1 if they are
- * the same.
+ * The return value is 0 if they are different and 1 if they are the
+ * same.
*
* Side effects:
* None.
@@ -3179,10 +3873,10 @@ AllocObjEntry(tablePtr, keyPtr)
*----------------------------------------------------------------------
*/
-static int
-CompareObjKeys(keyPtr, hPtr)
- VOID *keyPtr; /* New key to compare. */
- Tcl_HashEntry *hPtr; /* Existing key to compare. */
+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;
@@ -3192,6 +3886,7 @@ CompareObjKeys(keyPtr, hPtr)
/*
* If the object pointers are the same then they match.
*/
+
if (objPtr1 == objPtr2) {
return 1;
}
@@ -3200,14 +3895,16 @@ CompareObjKeys(keyPtr, hPtr)
* 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) {
@@ -3225,7 +3922,7 @@ CompareObjKeys(keyPtr, hPtr)
/*
*----------------------------------------------------------------------
*
- * FreeObjEntry --
+ * TclFreeObjEntry --
*
* Frees space for a Tcl_HashEntry containing the Tcl_Obj * key.
*
@@ -3238,27 +3935,27 @@ CompareObjKeys(keyPtr, hPtr)
*----------------------------------------------------------------------
*/
-static void
-FreeObjEntry(hPtr)
- Tcl_HashEntry *hPtr; /* Hash entry to free. */
+void
+TclFreeObjEntry(
+ Tcl_HashEntry *hPtr) /* Hash entry to free. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
- Tcl_DecrRefCount (objPtr);
- ckfree ((char *) hPtr);
+ Tcl_DecrRefCount(objPtr);
+ ckfree((char *) hPtr);
}
/*
*----------------------------------------------------------------------
*
- * HashObjKey --
+ * 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.
+ * The return value is a one-word summary of the information in the
+ * string representation of the Tcl_Obj.
*
* Side effects:
* None.
@@ -3266,36 +3963,35 @@ FreeObjEntry(hPtr)
*----------------------------------------------------------------------
*/
-static unsigned int
-HashObjKey(tablePtr, keyPtr)
- Tcl_HashTable *tablePtr; /* Hash table. */
- VOID *keyPtr; /* Key from which to compute hash value. */
+unsigned int
+TclHashObjKey(
+ Tcl_HashTable *tablePtr, /* Hash table. */
+ void *keyPtr) /* Key from which to compute hash value. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
CONST char *string = TclGetString(objPtr);
int length = objPtr->length;
- unsigned int result;
+ unsigned int result = 0;
int i;
/*
- * 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:
+ * 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.
+ * 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.
*/
- result = 0;
for (i=0 ; i<length ; i++) {
- result += (result<<3) + string[i];
+ result += (result << 3) + string[i];
}
return result;
}
@@ -3305,111 +4001,78 @@ HashObjKey(tablePtr, keyPtr)
*
* Tcl_GetCommandFromObj --
*
- * Returns the command specified by the name in a Tcl_Obj.
+ * 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.
+ * 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 procedure is
- * called with the same object, the command can be found quickly.
+ * 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(interp, objPtr)
- Tcl_Interp *interp; /* The interpreter in which to resolve the
+Tcl_GetCommandFromObj(
+ Tcl_Interp *interp, /* The interpreter in which to resolve the
* command and to report errors. */
- register 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. */
+ register 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. */
{
- Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
register Command *cmdPtr;
- Namespace *currNsPtr;
+ Namespace *refNsPtr;
int result;
- CallFrame *savedFramePtr;
- char *name;
-
- /*
- * If the variable name is fully qualified, do as if the lookup were
- * done from the global namespace; this helps avoid repeated lookups
- * of fully qualified names. It costs close to nothing, and may be very
- * helpful for OO applications which pass along a command name ("this"),
- * [Patch 456668]
- */
-
- savedFramePtr = iPtr->varFramePtr;
- name = Tcl_GetString(objPtr);
- if ((*name++ == ':') && (*name == ':')) {
- iPtr->varFramePtr = NULL;
- }
/*
* Get the internal representation, converting to a command type if
- * needed. The internal representation is a ResolvedCmdName that points
- * to the actual command.
+ * 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.
*/
-
- if (objPtr->typePtr != &tclCmdNameType) {
- result = tclCmdNameType.setFromAnyProc(interp, objPtr);
- if (result != TCL_OK) {
- iPtr->varFramePtr = savedFramePtr;
- return (Tcl_Command) NULL;
- }
- }
- resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
- /*
- * Get the current namespace.
- */
-
- if (iPtr->varFramePtr != NULL) {
- currNsPtr = iPtr->varFramePtr->nsPtr;
- } else {
- currNsPtr = iPtr->globalNsPtr;
+ resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
+ if ((objPtr->typePtr != &tclCmdNameType)
+ || (resPtr == NULL)
+ || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch)
+ || (cmdPtr->flags & CMD_IS_DELETED)
+ || (interp != cmdPtr->nsPtr->interp)
+ || (cmdPtr->nsPtr->flags & NS_DYING)
+ || ((resPtr->refNsPtr != NULL) &&
+ (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp))
+ != resPtr->refNsPtr)
+ || (resPtr->refNsId != refNsPtr->nsId)
+ || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch)))
+ ) {
+
+ result = tclCmdNameType.setFromAnyProc(interp, objPtr);
+
+ resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
+ if ((result == TCL_OK) && resPtr) {
+ cmdPtr = resPtr->cmdPtr;
+ } else {
+ cmdPtr = NULL;
+ }
}
-
- /*
- * Check the context namespace and the namespace epoch of the resolved
- * symbol to make sure that it is fresh. If not, then force another
- * conversion to the command type, to discard the old rep and create a
- * new one. 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.
- */
- cmdPtr = NULL;
- if ((resPtr != NULL)
- && (resPtr->refNsPtr == currNsPtr)
- && (resPtr->refNsId == currNsPtr->nsId)
- && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
- cmdPtr = resPtr->cmdPtr;
- if (cmdPtr->cmdEpoch != resPtr->cmdEpoch
- || (cmdPtr->flags & CMD_IS_DELETED)) {
- cmdPtr = NULL;
- }
- }
-
- if (cmdPtr == NULL) {
- result = tclCmdNameType.setFromAnyProc(interp, objPtr);
- if (result != TCL_OK) {
- iPtr->varFramePtr = savedFramePtr;
- return (Tcl_Command) NULL;
- }
- resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
- if (resPtr != NULL) {
- cmdPtr = resPtr->cmdPtr;
- }
- }
- iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) cmdPtr;
}
@@ -3426,54 +4089,59 @@ Tcl_GetCommandFromObj(interp, objPtr)
*
* Side effects:
* The object's old internal rep is freed. It's string rep is not
- * changed. The refcount in the Command structure is incremented to
- * keep it from being freed if the command is later deleted until
+ * changed. The refcount in the Command structure is incremented to keep
+ * it from being freed if the command is later deleted until
* TclExecuteByteCode has a chance to recognize that it was deleted.
*
*----------------------------------------------------------------------
*/
void
-TclSetCmdNameObj(interp, objPtr, cmdPtr)
- Tcl_Interp *interp; /* Points to interpreter containing command
+TclSetCmdNameObj(
+ Tcl_Interp *interp, /* Points to interpreter containing command
* that should be cached in objPtr. */
- register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
- * a CmdName object. */
- Command *cmdPtr; /* Points to Command structure that the
+ register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
+ * CmdName object. */
+ Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
- Tcl_ObjType *oldTypePtr = objPtr->typePtr;
register Namespace *currNsPtr;
+ char *name;
- if (oldTypePtr == &tclCmdNameType) {
+ if (objPtr->typePtr == &tclCmdNameType) {
return;
}
-
- /*
- * Get the current namespace.
- */
-
- if (iPtr->varFramePtr != NULL) {
- currNsPtr = iPtr->varFramePtr->nsPtr;
- } else {
- currNsPtr = iPtr->globalNsPtr;
- }
-
+
cmdPtr->refCount++;
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
-
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
+
+ name = TclGetString(objPtr);
+ if ((*name++ == ':') && (*name == ':')) {
+ /*
+ * The name is fully qualified: set the referring namespace to
+ * NULL.
+ */
+
+ resPtr->refNsPtr = NULL;
+ } else {
+ /*
+ * Get the current namespace.
+ */
+
+ currNsPtr = iPtr->varFramePtr->nsPtr;
+
+ resPtr->refNsPtr = currNsPtr;
+ resPtr->refNsId = currNsPtr->nsId;
+ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
}
- objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+
+ TclFreeIntRep(objPtr);
+ objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
@@ -3491,17 +4159,17 @@ TclSetCmdNameObj(interp, objPtr, cmdPtr)
*
* 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.
+ * 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(objPtr)
- register Tcl_Obj *objPtr; /* CmdName object with internal
+FreeCmdNameInternalRep(
+ register Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
register ResolvedCmdName *resPtr =
@@ -3509,23 +4177,24 @@ FreeCmdNameInternalRep(objPtr)
if (resPtr != NULL) {
/*
- * Decrement the reference count of the ResolvedCmdName structure.
- * If there are no more uses, free the ResolvedCmdName structure.
+ * Decrement the reference count of the ResolvedCmdName structure. If
+ * there are no more uses, free the ResolvedCmdName structure.
*/
-
- resPtr->refCount--;
- if (resPtr->refCount == 0) {
- /*
- * 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.
+
+ resPtr->refCount--;
+ if (resPtr->refCount == 0) {
+ /*
+ * 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;
- TclCleanupCommand(cmdPtr);
- ckfree((char *) resPtr);
- }
+
+ Command *cmdPtr = resPtr->cmdPtr;
+ TclCleanupCommandMacro(cmdPtr);
+ ckfree((char *) resPtr);
+ }
}
+ objPtr->typePtr = NULL;
}
/*
@@ -3533,33 +4202,33 @@ FreeCmdNameInternalRep(objPtr)
*
* DupCmdNameInternalRep --
*
- * Initialize the internal representation of an cmdName Tcl_Obj to a
- * copy of the internal representation of an existing cmdName object.
+ * 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.
+ * 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(srcPtr, copyPtr)
- Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
+DupCmdNameInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- register ResolvedCmdName *resPtr =
- (ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1;
+ register ResolvedCmdName *resPtr = (ResolvedCmdName *)
+ srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
- resPtr->refCount++;
+ resPtr->refCount++;
}
copyPtr->typePtr = &tclCmdNameType;
}
@@ -3577,22 +4246,21 @@ DupCmdNameInternalRep(srcPtr, copyPtr)
*
* 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.
+ * 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(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
+SetCmdNameFromAny(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
char *name;
- Tcl_Command cmd;
register Command *cmdPtr;
Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
@@ -3602,15 +4270,6 @@ SetCmdNameFromAny(interp, objPtr)
}
/*
- * Get "objPtr"s string representation. Make it up-to-date if necessary.
- */
-
- name = objPtr->bytes;
- if (name == NULL) {
- name = Tcl_GetString(objPtr);
- }
-
- /*
* 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
@@ -3618,47 +4277,62 @@ SetCmdNameFromAny(interp, objPtr)
* referenced from a CmdName object.
*/
- cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
- /*flags*/ 0);
- cmdPtr = (Command *) cmd;
- if (cmdPtr != NULL) {
- /*
- * Get the current namespace.
- */
-
- if (iPtr->varFramePtr != NULL) {
- currNsPtr = iPtr->varFramePtr->nsPtr;
- } else {
- currNsPtr = iPtr->globalNsPtr;
- }
-
- cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
- resPtr->cmdPtr = cmdPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
- } else {
- resPtr = NULL; /* no command named "name" was found */
- }
+ name = TclGetString(objPtr);
+ cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
- * Free the old internalRep before setting the new one. We do this as
- * late as possible to allow the conversion code, in particular
- * GetStringFromObj, to use that old internalRep. If no Command
- * structure was found, leave NULL as the cached value.
+ * Free the old internalRep before setting the new one. Do this after
+ * getting the string rep to allow the conversion code (in particular,
+ * Tcl_GetStringFromObj) to use that old internalRep.
*/
- if ((objPtr->typePtr != NULL)
- && (objPtr->typePtr->freeIntRepProc != NULL)) {
- objPtr->typePtr->freeIntRepProc(objPtr);
+ if (cmdPtr) {
+ cmdPtr->refCount++;
+ resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
+ if ((objPtr->typePtr == &tclCmdNameType)
+ && resPtr && (resPtr->refCount == 1)) {
+ /*
+ * Reuse the old ResolvedCmdName struct instead of freeing it
+ */
+
+ Command *oldCmdPtr = resPtr->cmdPtr;
+ if (--oldCmdPtr->refCount == 0) {
+ TclCleanupCommandMacro(oldCmdPtr);
+ }
+ } else {
+ TclFreeIntRep(objPtr);
+ resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr->refCount = 1;
+ objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
+ }
+ resPtr->cmdPtr = cmdPtr;
+ resPtr->cmdEpoch = cmdPtr->cmdEpoch;
+ if ((*name++ == ':') && (*name == ':')) {
+ /*
+ * The name is fully qualified: set the referring namespace to
+ * NULL.
+ */
+
+ resPtr->refNsPtr = NULL;
+ } else {
+ /*
+ * Get the current namespace.
+ */
+
+ currNsPtr = iPtr->varFramePtr->nsPtr;
+
+ resPtr->refNsPtr = currNsPtr;
+ resPtr->refNsId = currNsPtr->nsId;
+ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ }
+ } else {
+ TclFreeIntRep(objPtr);
+ objPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
}
-
- objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
return TCL_OK;
}
@@ -3669,4 +4343,3 @@ SetCmdNameFromAny(interp, objPtr)
* fill-column: 78
* End:
*/
-