diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 3351 |
1 files changed, 1960 insertions, 1391 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index 89ff127..930e1fd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1,33 +1,22 @@ /* * tclObj.c -- * - * This file contains Tcl object-related procedures that are used by many + * 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. - * - * RCS: @(#) $Id: tclObj.c,v 1.95 2005/09/05 10:25:54 dkf Exp $ */ #include "tclInt.h" #include "tommath.h" -#include <float.h> - -/* - * Define test for NaN - */ - -#ifdef _MSC_VER -#define IS_NAN(f) _isnan((f)) -#else -#define IS_NAN(f) ((f) != (f)) -#endif +#include <math.h> /* * Table of all object types. @@ -44,11 +33,12 @@ TCL_DECLARE_MUTEX(tableMutex) Tcl_Obj *tclFreeObjList = NULL; /* - * The object allocator is single threaded. This mutex is referenced by the + * 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 @@ -63,22 +53,58 @@ char *tclEmptyStringRep = &tclEmptyString; #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. + * Structure for tracking the source file and line number where a given + * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, + * for sanity checking purposes. + */ + +typedef struct ObjData { + Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ + const char *file; /* The name of the source file calling this + * function; used for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ +} ObjData; +#endif /* TCL_MEM_DEBUG && TCL_THREADS */ + +/* + * All static variables used in this file are collected into a single instance + * of the following structure. For multi-threaded implementations, there is + * one instance of this structure for each thread. + * + * Notice that different structures with the same name appear in other files. + * The structure defined below is used in this file only. */ + typedef struct ThreadSpecificData { - Tcl_HashTable *objThreadMap; + Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj + * generated by a call to the function + * TclSubstTokens() from a literal text + * where bs+nl sequences occured in it, if + * any. I.e. this table keeps track of + * invisible and stripped continuation lines. + * Its keys are Tcl_Obj pointers, the values + * are ContLineLoc pointers. See the file + * tclCompile.h for the definition of this + * structure, and for references to all + * related places in the core. */ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + Tcl_HashTable *objThreadMap;/* Thread local table that is used to check + * that a Tcl_Obj was not allocated by some + * other thread. */ +#endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -#endif /* TCL_MEM_DEBUG && TCL_THREADS */ +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 + * 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.) @@ -120,17 +146,12 @@ typedef struct PendingObjData { #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) #define PushObjToDelete(contextPtr,objPtr) \ - /* Invalidate the string rep first so we can use the bytes value \ - * for our pointer chain. */ \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ - } \ - /* Now push onto the head of the stack. */ \ - (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ + /* 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; \ + (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* @@ -139,155 +160,150 @@ typedef struct PendingObjData { #ifndef TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *CONST contextPtr = &pendingObjData + PendingObjData *const contextPtr = &pendingObjData +#elif HAVE_FAST_TSD +static __thread PendingObjData pendingObjData; +#define ObjInitDeletionContext(contextPtr) \ + PendingObjData *const contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *CONST contextPtr = (PendingObjData *) \ + PendingObjData *const contextPtr = \ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif - /* * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep */ #define PACK_BIGNUM(bignum, objPtr) \ - do { \ - (objPtr)->internalRep.bignumValue.digits = (void*) (bignum).dp; \ - (objPtr)->internalRep.bignumValue.misc = ( \ - ((bignum).sign << 30) \ - | ((bignum).alloc << 15) \ - | ((bignum).used)); \ - } while (0) + if ((bignum).used > 0x7fff) { \ + mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ + *temp = bignum; \ + (objPtr)->internalRep.ptrAndLongRep.ptr = 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) \ - do { \ - (bignum).dp = (mp_digit*) (objPtr)->internalRep.bignumValue.digits; \ - (bignum).sign = (objPtr)->internalRep.bignumValue.misc >> 30; \ - (bignum).alloc = \ - ((objPtr)->internalRep.bignumValue.misc >> 15) & 0x7fff; \ - (bignum).used = (objPtr)->internalRep.bignumValue.misc & 0x7fff; \ - } while (0) - -/* - * Prototypes for procedures defined later in this file: - */ - -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 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)); + if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \ + (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \ + } else { \ + (bignum).dp = (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; \ + } +/* + * Prototypes for functions defined later in this file: + */ + +static int ParseBoolean(Tcl_Obj *objPtr); +static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfDouble(Tcl_Obj *objPtr); +static void UpdateStringOfInt(Tcl_Obj *objPtr); #ifndef TCL_WIDE_INT_IS_LONG -static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void UpdateStringOfWideInt(Tcl_Obj *objPtr); +static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif - -static void FreeBignum _ANSI_ARGS_((Tcl_Obj *objPtr)); -static void DupBignum _ANSI_ARGS_((Tcl_Obj *objPtr, - Tcl_Obj *copyPtr)); -static void UpdateStringOfBignum _ANSI_ARGS_((Tcl_Obj *objPtr)); -static int SetBignumFromAny _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj* objPtr)); +static void FreeBignum(Tcl_Obj *objPtr); +static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); +static void UpdateStringOfBignum(Tcl_Obj *objPtr); +static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int copy, mp_int *bignumValue); /* * Prototypes for the array hash key methods. */ -static Tcl_HashEntry * AllocObjEntry _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 = { - "boolean", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ +static const Tcl_ObjType oldBooleanType = { + "boolean", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; - -Tcl_ObjType tclDoubleType = { - "double", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ +const Tcl_ObjType tclBooleanType = { + "booleanString", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; - -Tcl_ObjType tclIntType = { - "int", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ +const Tcl_ObjType tclDoubleType = { + "double", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ }; - -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 */ - UpdateStringOfWideInt, /* updateStringProc */ -#endif /* TCL_WIDE_INT_IS_LONG */ - SetWideIntFromAny /* setFromAnyProc */ +const Tcl_ObjType tclIntType = { + "int", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; - -Tcl_ObjType tclBignumType = { - "bignum", /* name */ - FreeBignum, /* freeIntRepProc */ - DupBignum, /* dupIntRepProc */ - UpdateStringOfBignum, /* updateStringProc */ - SetBignumFromAny /* setFromAnyProc */ +#ifndef TCL_WIDE_INT_IS_LONG +const Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ +}; +#endif +const Tcl_ObjType tclBignumType = { + "bignum", /* name */ + FreeBignum, /* freeIntRepProc */ + DupBignum, /* dupIntRepProc */ + UpdateStringOfBignum, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* * The structure below defines the Tcl obj hash key type. */ -Tcl_HashKeyType tclObjHashKeyType = { - TCL_HASH_KEY_TYPE_VERSION, /* version */ - 0, /* flags */ - HashObjKey, /* hashKeyProc */ - CompareObjKeys, /* compareKeysProc */ - AllocObjEntry, /* allocEntryProc */ - FreeObjEntry /* freeEntryProc */ + +const Tcl_HashKeyType tclObjHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + TclHashObjKey, /* hashKeyProc */ + TclCompareObjKeys, /* compareKeysProc */ + AllocObjEntry, /* allocEntryProc */ + TclFreeObjEntry /* freeEntryProc */ }; /* * The structure below defines the command name Tcl object type by means of - * procedures that can be invoked by generic object code. Objects of this type + * 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. @@ -298,17 +314,24 @@ Tcl_HashKeyType tclObjHashKeyType = { * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions * use the second internal pointer field of the twoPtrValue field for their * own purposes. + * + * TRICKY POINT! Some extensions update this structure! (Notably, these + * include TclBlend and TCom). This is highly ill-advised on their part, but + * does allow them to delete a command when references to it are gone, which + * is fragile but useful given their somewhat-OO style. Because of this, this + * structure MUST NOT be const so that the C compiler puts the data in + * writable memory. [Bug 2558422] + * TODO: Provide a better API for those extensions so that they can coexist... */ -static Tcl_ObjType tclCmdNameType = { - "cmdName", /* name */ - FreeCmdNameInternalRep, /* freeIntRepProc */ - DupCmdNameInternalRep, /* dupIntRepProc */ - (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ +Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ }; - /* * Structure containing a cached pointer to a command that is the result of * resolving the command's name in some namespace. It is the internal @@ -320,7 +343,8 @@ 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). */ + * 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 @@ -343,14 +367,13 @@ typedef struct ResolvedCmdName { * structure can be freed when refCount * becomes zero. */ } ResolvedCmdName; - /* *------------------------------------------------------------------------- * * TclInitObjectSubsystem -- * - * This procedure is invoked to perform once-only initialization of the + * This function is invoked to perform once-only initialization of the * type table. It also registers the object types defined in this file. * * Results: @@ -364,7 +387,7 @@ typedef struct ResolvedCmdName { */ void -TclInitObjSubsystem() +TclInitObjSubsystem(void) { Tcl_MutexLock(&tableMutex); typeTableInitialized = 1; @@ -375,23 +398,28 @@ TclInitObjSubsystem() Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); - Tcl_RegisterObjType(&tclWideIntType); - Tcl_RegisterObjType(&tclBignumType); Tcl_RegisterObjType(&tclStringType); + Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclArraySearchType); - Tcl_RegisterObjType(&tclNsNameType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); + /* For backward compatibility only ... */ + Tcl_RegisterObjType(&oldBooleanType); +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_RegisterObjType(&tclWideIntType); +#endif + #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; { int i; + for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { tclObjsShared[i] = 0; } @@ -403,10 +431,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(objData); + } + } + + Tcl_DeleteHashTable(tablePtr); + ckfree(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. @@ -418,7 +489,7 @@ TclInitObjSubsystem() */ void -TclFinalizeObjects() +TclFinalizeObjects(void) { Tcl_MutexLock(&tableMutex); if (typeTableInitialized) { @@ -428,9 +499,9 @@ TclFinalizeObjects() 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; @@ -438,12 +509,316 @@ TclFinalizeObjects() } /* + *---------------------------------------------------------------------- + * + * TclGetContLineTable -- + * + * This procedure is a helper which returns the thread-specific + * hash-table used to track continuation line information associated with + * Tcl_Obj*, and the objThreadMap, etc. + * + * Results: + * A reference to the thread-data. + * + * Side effects: + * May allocate memory for the thread-data. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static ThreadSpecificData * +TclGetContLineTable(void) +{ + /* + * Initialize the hashtable tracking invisible continuation lines. For + * the release we use a thread exit handler to ensure that this is done + * before TSD blocks are made invalid. The TclFinalizeObjects() which + * would be the natural place for this is invoked afterwards, meaning that + * we try to operate on a data structure already gone. + */ + + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!tsdPtr->lineCLPtr) { + tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); + Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); + } + return tsdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsEnter -- + * + * This procedure is a helper which saves the continuation line + * information associated with a Tcl_Obj*. + * + * Results: + * A reference to the newly created continuation line location table. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +ContLineLoc * +TclContinuationsEnter( + Tcl_Obj *objPtr, + int num, + int *loc) +{ + int newEntry; + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry *hPtr = + Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); + ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int)); + + if (!newEntry) { + /* + * We're entering ContLineLoc data for the same value more than one + * time. Taking care not to leak the old entry. + * + * This can happen when literals in a proc body are shared. See for + * example test info-30.19 where the action (code) for all branches of + * the switch command is identical, mapping them all to the same + * literal. An interesting result of this is that the number and + * locations (offset) of invisible continuation lines in the literal + * are the same for all occurences. + * + * Note that while reusing the existing entry is possible it requires + * the same actions as for a new entry because we have to copy the + * incoming num/loc data even so. Because we are called from + * TclContinuationsEnterDerived for this case, which modified the + * stored locations (Rebased to the proper relative offset). Just + * returning the stored entry would rebase them a second time, or + * more, hosing the data. It is easier to simply replace, as we are + * doing. + */ + + ckfree(Tcl_GetHashValue(hPtr)); + } + + clLocPtr->num = num; + memcpy(&clLocPtr->loc, loc, num*sizeof(int)); + clLocPtr->loc[num] = CLL_END; /* Sentinel */ + Tcl_SetHashValue(hPtr, clLocPtr); + + return clLocPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsEnterDerived -- + * + * This procedure is a helper which computes the continuation line + * information associated with a Tcl_Obj* cut from the middle of a + * script. + * + * Results: + * None. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclContinuationsEnterDerived( + Tcl_Obj *objPtr, + int start, + int *clNext) +{ + int length, end, num; + int *wordCLLast = clNext; + + /* + * We have to handle invisible continuations lines here as well, despite + * the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If + * our script is the sole argument to an 'eval' command, for example, the + * scriptCLLocPtr we are using was generated by a previous call to TST, + * and while the words we have here may contain continuation lines they + * are invisible already, and the inner call to TST had no bs+nl sequences + * to trigger its code. + * + * Luckily for us, the table we have to create here for the current word + * has to be a slice of the table currently in use, with the locations + * suitably modified to be relative to the start of the word instead of + * relative to the script. + * + * That is what we are doing now. Determine the slice we need, and if not + * empty, wrap it into a new table, and save the result into our + * thread-global hashtable, as usual. + */ + + /* + * First compute the range of the word within the script. (Is there a + * better way which doesn't shimmer?) + */ + + Tcl_GetStringFromObj(objPtr, &length); + end = start + length; /* First char after the word */ + + /* + * Then compute the table slice covering the range of the word. + */ + + while (*wordCLLast >= 0 && *wordCLLast < end) { + wordCLLast++; + } + + /* + * And generate the table from the slice, if it was not empty. + */ + + num = wordCLLast - clNext; + if (num) { + int i; + ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext); + + /* + * Re-base the locations. + */ + + for (i=0 ; i<num ; i++) { + clLocPtr->loc[i] -= start; + + /* + * Continuation lines coming before the string and affecting us + * should not happen, due to the proper maintenance of clNext + * during compilation. + */ + + if (clLocPtr->loc[i] < 0) { + Tcl_Panic("Derived ICL data for object using offsets from before the script"); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsCopy -- + * + * This procedure is a helper which copies the continuation line + * information associated with a Tcl_Obj* to another Tcl_Obj*. It is + * assumed that both contain the same string/script. Use this when a + * script is duplicated because it was shared. + * + * Results: + * None. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclContinuationsCopy( + Tcl_Obj *objPtr, + Tcl_Obj *originObjPtr) +{ + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); + + if (hPtr) { + ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr); + + TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsGet -- + * + * This procedure is a helper which retrieves the continuation line + * information associated with a Tcl_Obj*, if it has any. + * + * Results: + * A reference to the continuation line location table, or NULL if the + * Tcl_Obj* has no such information associated with it. + * + * Side effects: + * None. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +ContLineLoc * +TclContinuationsGet( + Tcl_Obj *objPtr) +{ + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + + if (!hPtr) { + return NULL; + } + return Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclThreadFinalizeContLines -- + * + * This procedure is a helper which releases all continuation line + * information currently known. It is run as a thread exit handler. + * + * Results: + * None. + * + * Side effects: + * Releases memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static void +TclThreadFinalizeContLines( + ClientData clientData) +{ + /* + * Release the hashtable tracking invisible continuation lines. + */ + + ThreadSpecificData *tsdPtr = TclGetContLineTable(); + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(tsdPtr->lineCLPtr); + ckfree(tsdPtr->lineCLPtr); + tsdPtr->lineCLPtr = NULL; +} + +/* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- * - * This 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. @@ -457,15 +832,16 @@ TclFinalizeObjects() */ void -Tcl_RegisterObjType(typePtr) - Tcl_ObjType *typePtr; /* Information about object type; storage must +Tcl_RegisterObjType( + const 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); } @@ -474,10 +850,10 @@ 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 + * 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: @@ -494,33 +870,32 @@ Tcl_RegisterObjType(typePtr) */ int -Tcl_AppendAllObjTypes(interp, objPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting. */ - Tcl_Obj *objPtr; /* Points to the Tcl object onto which the +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)); } @@ -533,7 +908,7 @@ 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 @@ -545,17 +920,17 @@ Tcl_AppendAllObjTypes(interp, objPtr) *---------------------------------------------------------------------- */ -Tcl_ObjType * -Tcl_GetObjType(typeName) - CONST char *typeName; /* Name of Tcl object type to look up. */ +const Tcl_ObjType * +Tcl_GetObjType( + const char *typeName) /* Name of Tcl object type to look up. */ { register Tcl_HashEntry *hPtr; - Tcl_ObjType *typePtr = NULL; + const 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_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; @@ -572,7 +947,7 @@ Tcl_GetObjType(typeName) * 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 + * function to be used as a test whether the conversion could be done * (and in fact was done). * * Side effects: @@ -582,10 +957,10 @@ 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. */ + const Tcl_ObjType *typePtr) /* The target type. */ { if (objPtr->typePtr == typePtr) { return TCL_OK; @@ -598,13 +973,67 @@ Tcl_ConvertToType(interp, objPtr, typePtr) */ if (typePtr->setFromAnyProc == NULL) { - Tcl_Panic("may not convert object to type %s", typePtr->name); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't convert value to type %s", typePtr->name)); + Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL); + } + return TCL_ERROR; } return typePtr->setFromAnyProc(interp, objPtr); } /* + *-------------------------------------------------------------- + * + * TclDbDumpActiveObjects -- + * + * This function is called to dump all of the active Tcl_Obj structs this + * allocator knows about. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TclDbDumpActiveObjects( + FILE *outFile) +{ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + Tcl_HashTable *tablePtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tablePtr = tsdPtr->objThreadMap; + + if (tablePtr != NULL) { + fprintf(outFile, "total objects: %d\n", tablePtr->numEntries); + for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + fprintf(outFile, + "key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n", + Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr, + objData->file, objData->line); + } else { + fprintf(outFile, "key = 0x%p\n", + Tcl_GetHashKey(tablePtr, hPtr)); + } + } + } +#endif +} + +/* *---------------------------------------------------------------------- * * TclDbInitNewObj -- @@ -623,8 +1052,13 @@ Tcl_ConvertToType(interp, objPtr, typePtr) */ #ifdef TCL_MEM_DEBUG -void TclDbInitNewObj(objPtr) - register Tcl_Obj *objPtr; +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; @@ -640,20 +1074,29 @@ void TclDbInitNewObj(objPtr) if (!TclInExit()) { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; - int new; + int isNew; + ObjData *objData; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; - hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &new); - if (!new) { + hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew); + if (!isNew) { Tcl_Panic("expected to create new entry for object map"); } - Tcl_SetHashValue(hPtr, NULL); + + /* + * Record the debugging information. + */ + + objData = ckalloc(sizeof(ObjData)); + objData->objPtr = objPtr; + objData->file = file; + objData->line = line; + Tcl_SetHashValue(hPtr, objData); } #endif /* TCL_THREADS */ } @@ -664,13 +1107,13 @@ void TclDbInitNewObj(objPtr) * * 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. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the result + * When TCL_MEM_DEBUG is defined, this function just returns the result * of calling the debugging version Tcl_DbNewObj. * * Results: @@ -679,7 +1122,7 @@ void TclDbInitNewObj(objPtr) * to 0. * * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments the + * If compiling with TCL_COMPILE_STATS, this function increments the * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- @@ -689,7 +1132,7 @@ void TclDbInitNewObj(objPtr) #undef Tcl_NewObj Tcl_Obj * -Tcl_NewObj() +Tcl_NewObj(void) { return Tcl_DbNewObj("unknown", 0); } @@ -697,7 +1140,7 @@ Tcl_NewObj() #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewObj() +Tcl_NewObj(void) { register Tcl_Obj *objPtr; @@ -715,15 +1158,15 @@ 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 + * 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: @@ -731,7 +1174,7 @@ Tcl_NewObj() * 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 + * If compiling with TCL_COMPILE_STATS, this function increments the * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- @@ -740,10 +1183,10 @@ 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 +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; @@ -758,10 +1201,10 @@ 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 +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(); @@ -773,7 +1216,7 @@ Tcl_DbNewObj(file, line) * * TclAllocateFreeObjects -- * - * Procedure to allocate a number of free Tcl_Objs. This is done using a + * 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. @@ -784,7 +1227,7 @@ Tcl_DbNewObj(file, line) * Side effects: * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the * first of a number of free Tcl_Obj's linked together by their - * internalRep.otherValuePtrs. + * internalRep.twoPtrValue.ptr1's. * *---------------------------------------------------------------------- */ @@ -792,7 +1235,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; @@ -800,21 +1243,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, + * 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); + basePtr = ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; + objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; prevPtr = objPtr; objPtr++; } @@ -827,7 +1269,7 @@ TclAllocateFreeObjects() * * TclFreeObj -- * - * This procedure frees the memory associated with the argument object. + * 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 @@ -840,7 +1282,7 @@ TclAllocateFreeObjects() * 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 + * representation. If compiling with TCL_COMPILE_STATS, this function * increments the global count of freed objects (tclObjsFreed). * *---------------------------------------------------------------------- @@ -848,10 +1290,10 @@ TclAllocateFreeObjects() #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; + register const Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... @@ -859,58 +1301,106 @@ TclFreeObj(objPtr) ObjInitDeletionContext(context); + /* + * Check for a double free of the same value. This is slightly tricky + * because it is customary to free a Tcl_Obj when its refcount falls + * either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though, + * and so on, is always a sign of a botch in the caller. + */ if (objPtr->refCount < -1) { - Tcl_Panic("Reference count for %lx was negative", objPtr); + Tcl_Panic("Reference count for %p was negative", objPtr); } + /* + * Now, in case we just approved drop from 1 to 0 as acceptable, make + * sure we do not accept a second free when falling from 0 to -1. + * Skip that possibility so any double free will trigger the panic. + */ + objPtr->refCount = -1; + + /* + * Invalidate the string rep first so we can use the bytes value for our + * pointer chain, and signal an obj deletion (as opposed to shimmering) + * with 'length == -1'. + */ + + TclInvalidateStringRep(objPtr); + objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { + TCL_DTRACE_OBJ_FREE(objPtr); if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { ObjDeletionLock(context); typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); } - Tcl_InvalidateStringRep(objPtr); Tcl_MutexLock(&tclObjMutex); - ckfree((char *) objPtr); + ckfree(objPtr); Tcl_MutexUnlock(&tclObjMutex); -#ifdef TCL_COMPILE_STATS - tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ + TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; - PopObjToDelete(context,objToFree); + PopObjToDelete(context, objToFree); + TCL_DTRACE_OBJ_FREE(objToFree); TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); - ckfree((char *) objToFree); + ckfree(objToFree); Tcl_MutexUnlock(&tclObjMutex); -#ifdef TCL_COMPILE_STATS - tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ + TclIncrObjsFreed(); } ObjDeletionUnlock(context); } + + /* + * We cannot use TclGetContinuationTable() here, because that may + * re-initialize the thread-data for calls coming after the finalization. + * We have to access it using the low-level call and then check for + * validity. This function can be called after TclFinalizeThreadData() has + * already killed the thread-global data structures. Performing + * TCL_TSD_INIT will leave us with an un-initialized memory block upon + * which we crash (if we where to access the uninitialized hashtable). + */ + + { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashEntry *hPtr; + + if (tsdPtr->lineCLPtr) { + hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + if (hPtr) { + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + } + } } #else /* TCL_MEM_DEBUG */ void -TclFreeObj(objPtr) - register Tcl_Obj *objPtr; /* The object to be freed. */ +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. */ - if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { - ckfree((char *) objPtr->bytes); - } + TCL_DTRACE_OBJ_FREE(objPtr); TclFreeObjStorage(objPtr); TclIncrObjsFreed(); } else { @@ -933,19 +1423,19 @@ TclFreeObj(objPtr) * satisfy this. */ + TCL_DTRACE_OBJ_FREE(objPtr); ObjDeletionLock(context); objPtr->typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); - if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { - ckfree((char *) objPtr->bytes); - } TclFreeObjStorage(objPtr); TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; - PopObjToDelete(context,objToFree); + + PopObjToDelete(context, objToFree); + TCL_DTRACE_OBJ_FREE(objToFree); if ((objToFree->typePtr != NULL) && (objToFree->typePtr->freeIntRepProc != NULL)) { objToFree->typePtr->freeIntRepProc(objToFree); @@ -956,8 +1446,56 @@ TclFreeObj(objPtr) ObjDeletionUnlock(context); } } + + /* + * We cannot use TclGetContinuationTable() here, because that may + * re-initialize the thread-data for calls coming after the finalization. + * We have to access it using the low-level call and then check for + * validity. This function can be called after TclFinalizeThreadData() has + * already killed the thread-global data structures. Performing + * TCL_TSD_INIT will leave us with an un-initialized memory block upon + * which we crash (if we where to access the uninitialized hashtable). + */ + + { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashEntry *hPtr; + + if (tsdPtr->lineCLPtr) { + hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + if (hPtr) { + ckfree(Tcl_GetHashValue(hPtr)); + Tcl_DeleteHashEntry(hPtr); + } + } + } +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclObjBeingDeleted -- + * + * This function returns 1 when the Tcl_Obj is being deleted. It is + * provided for the rare cases where the reason for the loss of an + * internal rep might be relevant. [FR 1512138] + * + * Results: + * 1 if being deleted, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclObjBeingDeleted( + Tcl_Obj *objPtr) +{ + return (objPtr->length == -1); } -#endif /* *---------------------------------------------------------------------- @@ -988,30 +1526,47 @@ TclFreeObj(objPtr) *---------------------------------------------------------------------- */ +#define SetDuplicateObj(dupPtr, objPtr) \ + { \ + const Tcl_ObjType *typePtr = (objPtr)->typePtr; \ + const char *bytes = (objPtr)->bytes; \ + if (bytes) { \ + TclInitStringRep((dupPtr), bytes, (objPtr)->length); \ + } else { \ + (dupPtr)->bytes = NULL; \ + } \ + if (typePtr) { \ + if (typePtr->dupIntRepProc) { \ + typePtr->dupIntRepProc((objPtr), (dupPtr)); \ + } else { \ + (dupPtr)->internalRep = (objPtr)->internalRep; \ + (dupPtr)->typePtr = typePtr; \ + } \ + } \ + } + Tcl_Obj * -Tcl_DuplicateObj(objPtr) - register Tcl_Obj *objPtr; /* The object to duplicate. */ +Tcl_DuplicateObj( + Tcl_Obj *objPtr) /* The object to duplicate. */ { - register Tcl_ObjType *typePtr = objPtr->typePtr; - register Tcl_Obj *dupPtr; + Tcl_Obj *dupPtr; TclNewObj(dupPtr); + SetDuplicateObj(dupPtr, objPtr); + return dupPtr; +} - if (objPtr->bytes == NULL) { - dupPtr->bytes = NULL; - } else if (objPtr->bytes != tclEmptyStringRep) { - TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); - } - - if (typePtr != NULL) { - if (typePtr->dupIntRepProc == NULL) { - dupPtr->internalRep = objPtr->internalRep; - dupPtr->typePtr = typePtr; - } else { - (*typePtr->dupIntRepProc)(objPtr, dupPtr); - } +void +TclSetDuplicateObj( + Tcl_Obj *dupPtr, + Tcl_Obj *objPtr) +{ + if (Tcl_IsShared(dupPtr)) { + Tcl_Panic("%s called with shared object", "TclSetDuplicateObj"); } - return dupPtr; + TclInvalidateStringRep(dupPtr); + TclFreeIntRep(dupPtr); + SetDuplicateObj(dupPtr, objPtr); } /* @@ -1036,19 +1591,37 @@ Tcl_DuplicateObj(objPtr) */ char * -Tcl_GetString(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should +Tcl_GetString( + register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { if (objPtr->bytes != NULL) { return objPtr->bytes; } + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant of + * a properly maintained Tcl_Obj is that at least one of objPtr->bytes + * and objPtr->typePtr must not be NULL. If broken extensions fail to + * maintain that invariant, we can crash here. + */ + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an updateStringProc + * must be written in such a way that (objPtr->bytes) never becomes + * NULL. This panic was added in Tcl 8.1. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", objPtr->typePtr->name); } - (*objPtr->typePtr->updateStringProc)(objPtr); + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", objPtr->typePtr->name); + } return objPtr->bytes; } @@ -1076,20 +1649,14 @@ 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) { - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - (*objPtr->typePtr->updateStringProc)(objPtr); - } + (void) TclGetString(objPtr); if (lengthPtr != NULL) { *lengthPtr = objPtr->length; @@ -1102,7 +1669,7 @@ Tcl_GetStringFromObj(objPtr, lengthPtr) * * Tcl_InvalidateStringRep -- * - * This procedure is called to invalidate an object's string + * This function is called to invalidate an object's string * representation. * * Results: @@ -1116,25 +1683,24 @@ Tcl_GetStringFromObj(objPtr, lengthPtr) */ void -Tcl_InvalidateStringRep(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should +Tcl_InvalidateStringRep( + register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { 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. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the result + * When TCL_MEM_DEBUG is defined, this function just returns the result * of calling the debugging version Tcl_DbNewBooleanObj. * * Results: @@ -1147,12 +1713,12 @@ Tcl_InvalidateStringRep(objPtr) *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewBooleanObj +#ifdef 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. */ { return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); } @@ -1160,8 +1726,8 @@ 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; @@ -1175,15 +1741,15 @@ 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 * 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: @@ -1196,14 +1762,15 @@ Tcl_NewBooleanObj(boolValue) *---------------------------------------------------------------------- */ +#undef Tcl_DbNewBooleanObj #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 +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; @@ -1219,11 +1786,11 @@ Tcl_DbNewBooleanObj(boolValue, file, line) #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 +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); @@ -1248,13 +1815,14 @@ Tcl_DbNewBooleanObj(boolValue, file, line) *---------------------------------------------------------------------- */ +#undef Tcl_SetBooleanObj 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. */ { if (Tcl_IsShared(objPtr)) { - Tcl_Panic("Tcl_SetBooleanObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } TclSetBooleanObj(objPtr, boolValue); @@ -1280,104 +1848,56 @@ Tcl_SetBooleanObj(objPtr, boolValue) */ 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. */ { - double d; - long l; - - /* - * The flow through this routine is "optimized" to avoid the generation of - * string rep. for "pure" numeric values. However, once the string rep is - * generated it's fairly inefficient at determining a string is *not* a - * valid boolean. It has to scan the string as many as four times (ruling - * out "double", "long", "wideint", and "boolean" in turn) to figure out - * that an invalid boolean value is stored in objPtr->bytes. - */ - - if (objPtr->typePtr == &tclIntType) { - *boolPtr = (int) (objPtr->internalRep.longValue != 0); - return TCL_OK; - } - if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = (int) objPtr->internalRep.longValue; - return TCL_OK; - } - if (objPtr->typePtr == &tclWideIntType) { - *boolPtr = (int) (objPtr->internalRep.wideValue != 0); - return TCL_OK; - } - - /* - * 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 for us. - */ - - /* - * The following call retrieves a numeric value without generating the - * string rep of a double. - */ - - if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) { - *boolPtr = (d != 0.0); - - /* - * Tcl_GetDoubleFromObj() will succeed on the strings "0" and "1", but - * we'd rather keep those values around as a better objType for - * boolean value. Following call will shimmer appropriately. - */ - - if (objPtr->bytes != NULL) { - SetBooleanFromAny(NULL, objPtr); + do { + if (objPtr->typePtr == &tclIntType) { + *boolPtr = (objPtr->internalRep.longValue != 0); + return TCL_OK; } - 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. + */ - /* - * Value didn't already have a numeric intrep, but perhaps we can generate - * one. Try a long value first... - */ + double d; - if (Tcl_GetLongFromObj(NULL, objPtr, &l) == TCL_OK) { - *boolPtr = (l != 0); - return TCL_OK; - } + if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { + return TCL_ERROR; + } + *boolPtr = (d != 0.0); + return TCL_OK; + } + if (objPtr->typePtr == &tclBignumType) { + *boolPtr = 1; + return TCL_OK; + } #ifndef TCL_WIDE_INT_IS_LONG - else { - Tcl_WideInt w; - - /* - * ...then a wide. Check in that order so that we don't promote - * anything to wide unnecessarily. - */ - - if (Tcl_GetWideIntFromObj(NULL, objPtr, &w) == TCL_OK) { - *boolPtr = (w != 0); + if (objPtr->typePtr == &tclWideIntType) { + *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } - } #endif - - /* - * Finally, check for the string values like "yes" and generate error - * message for non-boolean values. - */ - - if (SetBooleanFromAny(interp, objPtr) == TCL_OK) { - *boolPtr = (int) objPtr->internalRep.longValue; - return TCL_OK; - } + } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == + TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * SetBooleanFromAny -- + * TclSetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". @@ -1394,14 +1914,11 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) *---------------------------------------------------------------------- */ -static int -SetBooleanFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ +int +TclSetBooleanFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { - char *str, lowerCase[6]; - int i, newBool, length; - /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine * whether a boolean conversion is possible without generating the string @@ -1409,9 +1926,6 @@ SetBooleanFromAny(interp, objPtr) */ if (objPtr->bytes == NULL) { - if (objPtr->typePtr == &tclDoubleType) { - goto badBoolean; - } if (objPtr->typePtr == &tclIntType) { switch (objPtr->internalRep.longValue) { case 0L: case 1L: @@ -1419,26 +1933,55 @@ SetBooleanFromAny(interp, objPtr) } goto badBoolean; } + + if (objPtr->typePtr == &tclBignumType) { + goto badBoolean; + } + +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { - Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w == 0 || w == 1) { - newBool = (int) w; - goto numericBoolean; - } else { - goto badBoolean; - } + goto badBoolean; + } +#endif + + if (objPtr->typePtr == &tclDoubleType) { + goto badBoolean; } } - /* - * Parse the string as a boolean. We use an implementation here that - * doesn't report errors in interp if interp is NULL. - */ + if (ParseBoolean(objPtr) == TCL_OK) { + return TCL_OK; + } + + badBoolean: + if (interp != NULL) { + int length; + const 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); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL); + } + return TCL_ERROR; +} + +static int +ParseBoolean( + register Tcl_Obj *objPtr) /* The object to parse/convert. */ +{ + int i, length, newBool; + char lowerCase[6]; + const char *str = TclGetStringFromObj(objPtr, &length); - str = Tcl_GetStringFromObj(objPtr, &length); if ((length == 0) || (length > 5)) { - /* longest valid boolean string rep. is "false" */ - goto badBoolean; + /* + * Longest valid boolean string rep. is "false". + */ + + return TCL_ERROR; } switch (str[0]) { @@ -1447,22 +1990,23 @@ SetBooleanFromAny(interp, objPtr) newBool = 0; goto numericBoolean; } - goto badBoolean; + return TCL_ERROR; case '1': if (length == 1) { newBool = 1; goto numericBoolean; } - goto badBoolean; + return TCL_ERROR; } /* - * Force to lower case for case-insensitive detection. Filter out known + * Force to lower case for case-insensitive detection. Filter out known * invalid characters at the same time. */ for (i=0; i < length; i++) { char c = str[i]; + switch (c) { case 'A': case 'E': case 'F': case 'L': case 'N': case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': @@ -1473,7 +2017,7 @@ SetBooleanFromAny(interp, objPtr) lowerCase[i] = c; break; default: - goto badBoolean; + return TCL_ERROR; } } lowerCase[length] = 0; @@ -1486,28 +2030,28 @@ SetBooleanFromAny(interp, objPtr) newBool = 1; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; case 'n': if (strncmp(lowerCase, "no", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; case 't': if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; case 'f': if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; case 'o': if (length < 2) { - goto badBoolean; + return TCL_ERROR; } if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; @@ -1516,9 +2060,9 @@ SetBooleanFromAny(interp, objPtr) newBool = 0; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; default: - goto badBoolean; + return TCL_ERROR; } /* @@ -1533,17 +2077,6 @@ SetBooleanFromAny(interp, objPtr) objPtr->typePtr = &tclBooleanType; return TCL_OK; - badBoolean: - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected boolean value but got \"", -1); - str = Tcl_GetStringFromObj(objPtr, &length); - TclAppendLimitedToObj(msg, str, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - } - return TCL_ERROR; - numericBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; @@ -1556,11 +2089,11 @@ SetBooleanFromAny(interp, 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 + * When TCL_MEM_DEBUG is defined, this function just returns the result * of calling the debugging version Tcl_DbNewDoubleObj. * * Results: @@ -1577,8 +2110,8 @@ SetBooleanFromAny(interp, 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); } @@ -1586,8 +2119,8 @@ 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; @@ -1601,15 +2134,15 @@ 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 * 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: @@ -1625,11 +2158,11 @@ 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 +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; @@ -1645,11 +2178,11 @@ 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 +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); @@ -1675,12 +2208,12 @@ Tcl_DbNewDoubleObj(dblValue, file, line) */ 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. */ { if (Tcl_IsShared(objPtr)) { - Tcl_Panic("Tcl_SetDoubleObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); } TclSetDoubleObj(objPtr, dblValue); @@ -1707,34 +2240,44 @@ Tcl_SetDoubleObj(objPtr, dblValue) */ 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; + do { + if (objPtr->typePtr == &tclDoubleType) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "floating point value is Not a Number", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", + NULL); + } + return TCL_ERROR; + } + *dblPtr = (double) objPtr->internalRep.doubleValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclIntType) { + *dblPtr = objPtr->internalRep.longValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclBignumType) { + mp_int big; - if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; - return TCL_OK; - } else if (objPtr->typePtr == &tclWideIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; - return TCL_OK; - } else if (objPtr->typePtr != &tclDoubleType) { - result = SetDoubleFromAny(interp, objPtr); - if (result != TCL_OK) { - return TCL_ERROR; + UNPACK_BIGNUM(objPtr, big); + *dblPtr = TclBignumToDouble(&big); + return TCL_OK; } - } - if (IS_NAN(objPtr->internalRep.doubleValue)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "floating point value is Not a Number", -1)); +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + *dblPtr = (double) objPtr->internalRep.wideValue; + return TCL_OK; } - return TCL_ERROR; - } - *dblPtr = objPtr->internalRep.doubleValue; - return TCL_OK; +#endif + } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); + return TCL_ERROR; } /* @@ -1758,70 +2301,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. */ { - CONST 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 = TclStrToD(string, &end); - if (end == string) { - badDouble: - if (interp != NULL) { - Tcl_Obj *msg = Tcl_NewStringObj( - "expected floating-point number but got \"", -1); - TclAppendLimitedToObj(msg, string, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - } - 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; - } - - if (errno != 0 && errno != ERANGE) { - if (interp != NULL) { - TclExprFloatError(interp, newDouble); - } - return TCL_ERROR; - } - - /* - * 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. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.doubleValue = newDouble; - objPtr->typePtr = &tclDoubleType; - return TCL_OK; + return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, + NULL, 0); } /* @@ -1831,7 +2316,7 @@ SetDoubleFromAny(interp, objPtr) * * 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 + * 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. * @@ -1846,18 +2331,17 @@ SetDoubleFromAny(interp, objPtr) */ 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->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } @@ -1868,7 +2352,7 @@ 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 @@ -1891,12 +2375,12 @@ UpdateStringOfDouble(objPtr) *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewIntObj +#ifdef 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. */ { return Tcl_DbNewLongObj((long)intValue, "unknown", 0); } @@ -1904,8 +2388,8 @@ 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; @@ -1932,13 +2416,14 @@ Tcl_NewIntObj(intValue) *---------------------------------------------------------------------- */ +#undef Tcl_SetIntObj 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. */ { if (Tcl_IsShared(objPtr)) { - Tcl_Panic("Tcl_SetIntObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); } TclSetIntObj(objPtr, intValue); @@ -1971,50 +2456,31 @@ Tcl_SetIntObj(objPtr, intValue) */ 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 } /* @@ -2026,156 +2492,21 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr) * 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(interp, objPtr) - 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) { - CONST char *s = "integer value too large to represent"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SetIntOrWideFromAny -- - * - * 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 -SetIntOrWideFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ +SetIntFromAny( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - char *string, *end; - int length; - register char *p; - unsigned long newLong; - int isNegative = 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. We parse the leading space and sign ourselves so we - * can tell the difference between apparently positive and negative - * values. - */ - - errno = 0; - for (; isspace(UCHAR(*p)) ; p++) { /* INTL: ISO space. */ - /* Empty loop body. */ - } - if (*p == '-') { - isNegative = 1; - p++; - } else if (*p == '+') { - p++; - } - if (!isdigit(UCHAR(*p))) { - badInteger: - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected integer but got \"", -1); - TclAppendLimitedToObj(msg, string, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - TclCheckBadOctal(interp, string); - } - return TCL_ERROR; - } - newLong = strtoul(p, &end, 0); - if (end == p) { - goto badInteger; - } - - /* - * 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 (errno == ERANGE) { - if (interp != NULL) { - CONST char *s = "integer value too large to represent"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); - } - return TCL_ERROR; - } - - /* - * 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. - */ - - TclFreeIntRep(objPtr); -#ifndef TCL_WIDE_INT_IS_LONG - /* - * If the resulting integer will exceed the range of a long, put it into a - * wide instead. (Tcl Bug #868489) - */ + long l; - if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1) - || (!isNegative && newLong > LONG_MAX)) { - objPtr->internalRep.wideValue = - (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong); - objPtr->typePtr = &tclWideIntType; - } else -#endif - { - objPtr->internalRep.longValue = - (isNegative ? -(long)newLong : (long)newLong); - objPtr->typePtr = &tclIntType; - } - return TCL_OK; + return TclGetLongFromObj(interp, objPtr, &l); } /* @@ -2183,8 +2514,8 @@ 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 + * 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: @@ -2198,16 +2529,16 @@ SetIntOrWideFromAny(interp, objPtr) */ 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->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } @@ -2218,7 +2549,7 @@ UpdateStringOfInt(objPtr) * * 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. + * 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 @@ -2245,8 +2576,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); @@ -2255,8 +2586,8 @@ 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; @@ -2273,7 +2604,7 @@ Tcl_NewLongObj(longValue) * * 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 + * 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. @@ -2285,7 +2616,7 @@ Tcl_NewLongObj(longValue) * 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 @@ -2301,12 +2632,12 @@ Tcl_NewLongObj(longValue) #ifdef TCL_MEM_DEBUG Tcl_Obj * -Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the new +Tcl_DbNewLongObj( + 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 + 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; @@ -2322,12 +2653,12 @@ 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 +Tcl_DbNewLongObj( + 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 + 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); @@ -2353,13 +2684,13 @@ Tcl_DbNewLongObj(longValue, file, line) */ 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. */ { if (Tcl_IsShared(objPtr)) { - Tcl_Panic("Tcl_SetLongObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } TclSetLongObj(objPtr, longValue); @@ -2387,156 +2718,100 @@ 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. - */ + 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 { + Tcl_WideInt w = objPtr->internalRep.wideValue; + + if (w >= -(Tcl_WideInt)(ULONG_MAX) + && w <= (Tcl_WideInt)(ULONG_MAX)) { + *longPtr = Tcl_WideAsLong(w); + return TCL_OK; + } + goto tooLarge; + } +#endif + if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; } - } -#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. - * - *---------------------------------------------------------------------- - */ + if (objPtr->typePtr == &tclBignumType) { + /* + * Must check for those bignum values that can fit in a long, even + * when auto-narrowing is enabled. Only those values in the signed + * long range get auto-narrowed to tclIntType, while all the + * values in the unsigned long range will fit in a long. + */ -static int -SetWideIntFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ + 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 TCL_WIDE_INT_IS_LONG - 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. - */ - - errno = 0; - newWide = strtoull(p, &end, 0); - if (end == p) { - badInteger: - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected integer but got \"", -1); - TclAppendLimitedToObj(msg, string, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - TclCheckBadOctal(interp, string); - } - 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; - } + tooLarge: +#endif + if (interp != NULL) { + const char *s = "integer value too large to represent"; + Tcl_Obj *msg = Tcl_NewStringObj(s, -1); - if (errno == ERANGE) { - if (interp != NULL) { - CONST char *s = "integer value too large to represent"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); + Tcl_SetObjResult(interp, msg); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + } + return TCL_ERROR; } - return TCL_ERROR; - } - /* - * 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. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.wideValue = newWide; -#else - if (TCL_ERROR == SetIntFromAny(interp, objPtr)) { - return TCL_ERROR; - } -#endif - objPtr->typePtr = &tclWideIntType; - return TCL_OK; + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- * * UpdateStringOfWideInt -- * - * Update the string representation for a wide integer object. Note: - * This 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. @@ -2548,10 +2823,9 @@ SetWideIntFromAny(interp, objPtr) *---------------------------------------------------------------------- */ -#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; @@ -2566,11 +2840,11 @@ UpdateStringOfWideInt(objPtr) sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); - objPtr->bytes = ckalloc((unsigned) len + 1); + objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } -#endif /* TCL_WIDE_INT_IS_LONG */ +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -2579,7 +2853,7 @@ 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 @@ -2601,9 +2875,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); } @@ -2611,13 +2886,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; - TclNewWideIntObj(objPtr, wideValue); + TclNewObj(objPtr); + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2629,7 +2906,7 @@ Tcl_NewWideIntObj(wideValue) * * 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 + * 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. @@ -2641,7 +2918,7 @@ Tcl_NewWideIntObj(wideValue) * 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 @@ -2657,36 +2934,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); } @@ -2711,16 +2985,29 @@ Tcl_DbNewWideIntObj(wideValue, file, line) */ 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. */ { if (Tcl_IsShared(objPtr)) { - Tcl_Panic("Tcl_SetWideIntObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - TclSetWideIntObj(objPtr, wideValue); + if ((wideValue >= (Tcl_WideInt) LONG_MIN) + && (wideValue <= (Tcl_WideInt) LONG_MAX)) { + TclSetLongObj(objPtr, (long) wideValue); + } else { +#ifndef TCL_WIDE_INT_IS_LONG + TclSetWideIntObj(objPtr, wideValue); +#else + mp_int big; + + TclBNInitBignumFromWideInt(&big, wideValue); + Tcl_SetBignumObj(objPtr, &big); +#endif + } } /* @@ -2745,198 +3032,158 @@ 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 TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } +#endif + if (objPtr->typePtr == &tclIntType) { + *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + } + return TCL_ERROR; + } + if (objPtr->typePtr == &tclBignumType) { + /* + * Must check for those bignum values that can fit in a + * Tcl_WideInt, even when auto-narrowing is enabled. + */ - if (objPtr->typePtr == &tclWideIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } - result = SetWideIntFromAny(interp, objPtr); - if (result == TCL_OK) { - *wideIntPtr = objPtr->internalRep.wideValue; - } - return result; + 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) { + const char *s = "integer value too large to represent"; + Tcl_Obj *msg = Tcl_NewStringObj(s, -1); + + Tcl_SetObjResult(interp, msg); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- * - * FreeBignum -- + * SetWideIntFromAny -- * - * This procedure frees the internal rep of a bignum. + * Attempts to force the internal representation for a Tcl object to + * tclWideIntType, specifically. * * Results: - * None. + * 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 void -FreeBignum(Tcl_Obj *objPtr) +static int +SetWideIntFromAny( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - mp_int toFree; /* Bignum to free */ - - UNPACK_BIGNUM(objPtr, toFree); - mp_clear(&toFree); + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- * - * DupBignum -- + * FreeBignum -- * - * This procedure duplicates the internal rep of a bignum. + * This function frees the internal rep of a bignum. * * Results: * None. * - * Side effects: - * The destination object receies a copy of the source object - * *---------------------------------------------------------------------- */ static void -DupBignum(srcPtr, copyPtr) - Tcl_Obj* srcPtr; - Tcl_Obj* copyPtr; +FreeBignum( + Tcl_Obj *objPtr) { - mp_int bignumVal; - mp_int bignumCopy; + mp_int toFree; /* Bignum to free */ - copyPtr->typePtr = &tclBignumType; - UNPACK_BIGNUM(srcPtr, bignumVal); - if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { - Tcl_Panic("initialization failure in DupBignum"); + UNPACK_BIGNUM(objPtr, toFree); + mp_clear(&toFree); + if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) { + ckfree(objPtr->internalRep.ptrAndLongRep.ptr); } - PACK_BIGNUM(bignumVal, copyPtr); + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * - * SetBignumFromAny -- + * DupBignum -- * - * This procedure interprets a Tcl_Obj as a bignum and sets the internal - * representation accordingly. + * This function duplicates the internal rep of a bignum. * * Results: - * Returns a standard Tcl status. If conversion fails, an error message - * is left in the interpreter result. + * None. * * Side effects: - * The bignum internal representation is packed into the object. + * The destination object receies a copy of the source object * *---------------------------------------------------------------------- */ -static int -SetBignumFromAny(interp, objPtr) - Tcl_Interp* interp; - Tcl_Obj* objPtr; +static void +DupBignum( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) { - CONST char* stringVal; - CONST char* p; - int length; - int signum = MP_ZPOS; - int radix = 10; - int status; mp_int bignumVal; + mp_int bignumCopy; - if (objPtr->typePtr == &tclIntType) { - - /* - * If the number already contains an integer, simply widen it to a - * bignum. - */ - - TclBNInitBignumFromLong(&bignumVal, objPtr->internalRep.longValue); - } else { - - /* - * The number doesn't contain an integer. Convert its string rep to a - * bignum, handling 0XXX and 0xXXX notation - */ - - stringVal = Tcl_GetStringFromObj(objPtr, &length); - p = stringVal; - - /* - * Pull off the signum - */ - - if (*p == '+') { - ++p; - } else if (*p == '-') { - ++p; - signum = MP_NEG; - } - - /* - * Handle octal and hexadecimal - */ - - if (*p == '0') { - ++p; - if (*p == 'x' || *p == 'X') { - ++p; - radix = 16; - } else { - --p; - radix = 8; - } - } - - /* Convert the value */ - - if (mp_init(&bignumVal) != MP_OKAY) { - Tcl_Panic("initialization failure in SetBignumFromAny"); - } - status = mp_read_radix(&bignumVal, p, radix); - switch (status) { - case MP_MEM: - Tcl_Panic("out of memory in SetBignumFromAny"); - case MP_OKAY: - break; - default: - if (interp != NULL) { - Tcl_Obj* msg = Tcl_NewStringObj( - "expected integer but got \"", -1); - TclAppendLimitedToObj(msg, stringVal, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - TclCheckBadOctal(interp, stringVal); - } - mp_clear(&bignumVal); - return TCL_ERROR; - } - - /* Conversion to bignum succeeded. Make sure that everything fits. */ - - if (bignumVal.alloc > 0x7fff) { - Tcl_Obj* msg = - Tcl_NewStringObj("integer value too large to represent",-1); - Tcl_SetObjResult(interp, msg); - mp_clear(&bignumVal); - return TCL_ERROR; - } + copyPtr->typePtr = &tclBignumType; + UNPACK_BIGNUM(srcPtr, bignumVal); + if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { + Tcl_Panic("initialization failure in DupBignum"); } - - /* - * Conversion succeeded. Clean up the old internal rep and store the new - * one. - */ - - TclFreeIntRep(objPtr); - bignumVal.sign = signum; - PACK_BIGNUM(bignumVal, objPtr); - objPtr->typePtr = &tclBignumType; - return TCL_OK; + PACK_BIGNUM(bignumCopy, copyPtr); } /* @@ -2944,7 +3191,7 @@ SetBignumFromAny(interp, objPtr) * * UpdateStringOfBignum -- * - * This procedure updates the string representation of a bignum object. + * This function updates the string representation of a bignum object. * * Results: * None. @@ -2954,29 +3201,46 @@ SetBignumFromAny(interp, objPtr) * 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 procedure is called. + * if the string rep is still valid at the time this function is called. + * + *---------------------------------------------------------------------- */ static void -UpdateStringOfBignum(Tcl_Obj* objPtr) +UpdateStringOfBignum( + Tcl_Obj *objPtr) { mp_int bignumVal; int size; int status; - char* stringVal; + char *stringVal; UNPACK_BIGNUM(objPtr, bignumVal); status = mp_radix_size(&bignumVal, 10, &size); if (status != MP_OKAY) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } - stringVal = Tcl_Alloc((size_t) size); + if (size == 3) { + /* + * 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. + */ + + Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); + } + stringVal = ckalloc(size); status = mp_toradix_n(&bignumVal, stringVal, 10, size); if (status != MP_OKAY) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing null byte */ + objPtr->length = size - 1; /* size includes a trailing NUL byte. */ } /* @@ -2997,26 +3261,22 @@ UpdateStringOfBignum(Tcl_Obj* objPtr) #ifdef TCL_MEM_DEBUG #undef Tcl_NewBignumObj -Tcl_Obj* -Tcl_NewBignumObj(mp_int* bignumValue) + +Tcl_Obj * +Tcl_NewBignumObj( + mp_int *bignumValue) { return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); } #else Tcl_Obj * -Tcl_NewBignumObj(mp_int* bignumValue) +Tcl_NewBignumObj( + mp_int *bignumValue) { - Tcl_Obj* objPtr; + Tcl_Obj *objPtr; TclNewObj(objPtr); - PACK_BIGNUM(*bignumValue, objPtr); - objPtr->typePtr=&tclBignumType; - objPtr->bytes = NULL; - - /* Clear with mp_init; mp_clear would overwrite the digit array. */ - - mp_init(bignumValue); - + Tcl_SetBignumObj(objPtr, bignumValue); return objPtr; } #endif @@ -3026,9 +3286,9 @@ Tcl_NewBignumObj(mp_int* bignumValue) * * Tcl_DbNewBignumObj -- * - * This procedure 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. + * 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. @@ -3040,26 +3300,24 @@ Tcl_NewBignumObj(mp_int* bignumValue) */ #ifdef TCL_MEM_DEBUG -Tcl_Obj* -Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) +Tcl_Obj * +Tcl_DbNewBignumObj( + mp_int *bignumValue, + const char *file, + int line) { - Tcl_Obj* objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - PACK_BIGNUM(*bignumValue, objPtr); - objPtr->typePtr = &tclBignumType; - objPtr->bytes = NULL; - - /* Clear with mp_init; mp_clear would overwrite the digit array. */ - - mp_init(bignumValue); - + Tcl_SetBignumObj(objPtr, bignumValue); return objPtr; } #else -Tcl_Obj* -Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) +Tcl_Obj * +Tcl_DbNewBignumObj( + mp_int *bignumValue, + const char *file, + int line) { return Tcl_NewBignumObj(bignumValue); } @@ -3068,44 +3326,141 @@ Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) /* *---------------------------------------------------------------------- * + * 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 TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + TclBNInitBignumFromWideInt(bignumValue, + objPtr->internalRep.wideValue); + return TCL_OK; + } +#endif + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetBignumFromObj -- * - * This procedure retrieves a 'bignum' value from a Tcl object, - * converting the object if necessary. + * 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' + * 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. The raw value of the object is - * returned, and Tcl owns that memory, so the caller should NOT invoke - * mp_clear afterwards. + * 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. */ + Tcl_Interp *interp, /* Tcl interpreter for error reporting */ + Tcl_Obj *objPtr, /* Object to read */ + mp_int *bignumValue) /* Returned bignum value. */ { - mp_int temp; + 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. + * + *---------------------------------------------------------------------- + */ - if (objPtr->typePtr != &tclBignumType) { - if (SetBignumFromAny(interp, objPtr) != TCL_OK) { - return TCL_ERROR; - } - } - UNPACK_BIGNUM(objPtr, temp); - mp_init_copy(bignumValue, &temp); - return TCL_OK; +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); } /* @@ -3113,13 +3468,13 @@ Tcl_GetBignumFromObj( * * Tcl_SetBignumObj -- * - * This procedure sets the value of a Tcl_Obj to a large integer. + * 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 + * Object value is stored. The bignum value is cleared, since ownership * has transferred to Tcl. * *---------------------------------------------------------------------- @@ -3127,20 +3482,168 @@ Tcl_GetBignumFromObj( void Tcl_SetBignumObj( - Tcl_Obj* objPtr, /* Object to set */ - mp_int* bignumValue) /* Value to store */ + Tcl_Obj *objPtr, /* Object to set */ + mp_int *bignumValue) /* Value to store */ { if (Tcl_IsShared(objPtr)) { - Tcl_Panic("Tcl_SetBignumObj called with shared object"); + 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 TCL_WIDE_INT_IS_LONG + 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); +} + +/* + *---------------------------------------------------------------------- + * + * TclSetBignumIntRep -- + * + * Install a bignum into the internal representation of an object. + * + * Results: + * None. + * + * Side effects: + * Object internal representation is updated and object type is set. The + * bignum value is cleared, since ownership has transferred to the + * object. + * + *---------------------------------------------------------------------- + */ + +void +TclSetBignumIntRep( + Tcl_Obj *objPtr, + mp_int *bignumValue) +{ objPtr->typePtr = &tclBignumType; PACK_BIGNUM(*bignumValue, objPtr); - Tcl_InvalidateStringRep(objPtr); - /* Clear the value with mp_init; mp_clear overwrites the digit array. */ + /* + * Clear the mp_int value. + * + * Don't call mp_clear() because it would free the digit array we just + * packed into the Tcl_Obj. + */ + + bignumValue->dp = NULL; + bignumValue->alloc = bignumValue->used = 0; + bignumValue->sign = MP_NEG; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetNumberFromObj -- + * + * Extracts a number (of any possible numeric type) from an object. + * + * Results: + * Whether the extraction worked. The type is stored in the variable + * referred to by the typePtr argument, and a pointer to the + * representation is stored in the variable referred to by the + * clientDataPtr. + * + * Side effects: + * Can allocate thread-specific data for handling the copy-out space for + * bignums; this space is shared within a thread. + * + *---------------------------------------------------------------------- + */ - mp_init(bignumValue); +int +TclGetNumberFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + ClientData *clientDataPtr, + int *typePtr) +{ + do { + if (objPtr->typePtr == &tclDoubleType) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { + *typePtr = TCL_NUMBER_NAN; + } else { + *typePtr = TCL_NUMBER_DOUBLE; + } + *clientDataPtr = &objPtr->internalRep.doubleValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclIntType) { + *typePtr = TCL_NUMBER_LONG; + *clientDataPtr = &objPtr->internalRep.longValue; + return TCL_OK; + } +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + *typePtr = TCL_NUMBER_WIDE; + *clientDataPtr = &objPtr->internalRep.wideValue; + return TCL_OK; + } +#endif + if (objPtr->typePtr == &tclBignumType) { + static Tcl_ThreadDataKey bignumKey; + mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, + (int) sizeof(mp_int)); + + UNPACK_BIGNUM(objPtr, *bigPtr); + *typePtr = TCL_NUMBER_BIG; + *clientDataPtr = bigPtr; + return TCL_OK; + } + } while (TCL_OK == + TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); + return TCL_ERROR; } /* @@ -3148,11 +3651,11 @@ Tcl_SetBignumObj( * * Tcl_DbIncrRefCount -- * - * 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. 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 + * When TCL_MEM_DEBUG is not defined, this function just increments the * reference count of the object. * * Results: @@ -3165,19 +3668,19 @@ Tcl_SetBignumObj( */ void -Tcl_DbIncrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are registering a reference +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 - * procedure; used for debugging. */ - int line; /* Line number in the source file; used for + const char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); - Tcl_Panic("Trying to increment refCount of previously disposed object."); + Tcl_Panic("incrementing refCount of previously disposed object"); } # ifdef TCL_THREADS @@ -3188,23 +3691,21 @@ Tcl_DbIncrRefCount(objPtr, file, line) */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; - tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to incr ref count of ", - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "incr ref count"); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ ++(objPtr)->refCount; } @@ -3213,11 +3714,11 @@ Tcl_DbIncrRefCount(objPtr, file, line) * * Tcl_DbDecrRefCount -- * - * 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. 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 + * When TCL_MEM_DEBUG is not defined, this function just decrements the * reference count of the object. * * Results: @@ -3230,19 +3731,19 @@ 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 + const char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); - Tcl_Panic("Trying to decrement refCount of previously disposed object."); + Tcl_Panic("decrementing refCount of previously disposed object"); } # ifdef TCL_THREADS @@ -3253,28 +3754,36 @@ Tcl_DbDecrRefCount(objPtr, file, line) */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; - tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to decr ref count of ", - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "decr ref count"); } - /* If the Tcl_Obj is going to be deleted, remove the entry */ - if ((((objPtr)->refCount) - 1) <= 0) { + /* + * 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(objData); + } + Tcl_DeleteHashEntry(hPtr); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ + if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); } @@ -3285,11 +3794,11 @@ Tcl_DbDecrRefCount(objPtr, file, line) * * Tcl_DbIsShared -- * - * 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 tests whether the object has a ref count * greater than one. * - * When TCL_MEM_DEBUG is not defined, this procedure just tests if the + * When TCL_MEM_DEBUG is not defined, this function just tests if the * object has a ref count greater than one. * * Results: @@ -3302,18 +3811,18 @@ 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 +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); - Tcl_Panic("Trying to check whether previously disposed object is shared."); + Tcl_Panic("checking whether previously disposed object is shared"); } # ifdef TCL_THREADS @@ -3324,22 +3833,21 @@ Tcl_DbIsShared(objPtr, file, line) */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; + if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to check shared status of", - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "check shared status"); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -3351,7 +3859,7 @@ Tcl_DbIsShared(objPtr, file, line) tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); -#endif +#endif /* TCL_COMPILE_STATS */ return ((objPtr)->refCount > 1); } @@ -3375,8 +3883,8 @@ Tcl_DbIsShared(objPtr, file, line) */ void -Tcl_InitObjHashTable(tablePtr) - register Tcl_HashTable *tablePtr; +Tcl_InitObjHashTable( + register Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied * by the caller. */ { @@ -3401,16 +3909,16 @@ 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; + Tcl_Obj *objPtr = keyPtr; + Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry)); - hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); - hPtr->key.oneWordValue = (char *) objPtr; + hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); + hPtr->clientData = NULL; return hPtr; } @@ -3418,7 +3926,7 @@ AllocObjEntry(tablePtr, keyPtr) /* *---------------------------------------------------------------------- * - * CompareObjKeys -- + * TclCompareObjKeys -- * * Compares two Tcl_Obj * keys. * @@ -3432,14 +3940,14 @@ 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 *objPtr1 = keyPtr; Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; - register CONST char *p1, *p2; + register const char *p1, *p2; register int l1, l2; /* @@ -3481,7 +3989,7 @@ CompareObjKeys(keyPtr, hPtr) /* *---------------------------------------------------------------------- * - * FreeObjEntry -- + * TclFreeObjEntry -- * * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key. * @@ -3494,20 +4002,20 @@ 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); + ckfree(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. @@ -3522,35 +4030,55 @@ 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; + Tcl_Obj *objPtr = keyPtr; + int length; + const char *string = TclGetStringFromObj(objPtr, &length); 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 + * 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. + * multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings. + * + * Note that this function is very weak against malicious strings; it's + * very easy to generate multiple keys that have the same hashcode. On the + * other hand, that hardly ever actually occurs and this function *is* + * very cheap, even by comparison with industry-standard hashes like FNV. + * If real strength of hash is required though, use a custom hash based on + * Bob Jenkins's lookup3(), but be aware that it's significantly slower. + * Tcl does not use that level of strength because it typically does not + * need it (and some of the aspects of that strength are genuinely + * unnecessary given the rest of Tcl's hash machinery, and the fact that + * we do not either transfer hashes to another machine, use them as a true + * substitute for equality, or attempt to minimize work in rebuilding the + * hash table). + * + * See also HashStringKey in tclHash.c. + * See also HashString in tclLiteral.c. + * + * See [tcl-Feature Request #2958832] */ - for (i=0 ; i<length ; i++) { - result += (result << 3) + string[i]; + if (length > 0) { + result = UCHAR(*string); + while (--length) { + result += (result << 3) + UCHAR(*++string); + } } return result; } @@ -3568,103 +4096,73 @@ HashObjKey(tablePtr, keyPtr) * * Side effects: * May update the internal representation for the object, caching the - * command reference so that the next time this procedure is called with + * 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. + 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; - 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. + * + * 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 = objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { + register Command *cmdPtr = resPtr->cmdPtr; + + if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) + && !(cmdPtr->flags & CMD_IS_DELETED) + && (interp == cmdPtr->nsPtr->interp) + && !(cmdPtr->nsPtr->flags & NS_DYING)) { + register Namespace *refNsPtr = (Namespace *) + TclGetCurrentNamespace(interp); + + if ((resPtr->refNsPtr == NULL) + || ((refNsPtr == resPtr->refNsPtr) + && (resPtr->refNsId == refNsPtr->nsId) + && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) { + return (Tcl_Command) cmdPtr; + } + } } /* - * 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. + * OK, must create a new internal representation (or fail) as any cache we + * had is invalid one way or another. */ - 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 = NULL; - } + if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) { + return 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; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); } /* @@ -3682,69 +4180,59 @@ Tcl_GetCommandFromObj(interp, objPtr) * 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 - * TclExecuteByteCode has a chance to recognize that it was deleted. + * TclNRExecuteByteCode 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 + register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a * CmdName object. */ - Command *cmdPtr; /* Points to Command structure that the + Command *cmdPtr) /* Points to Command structure that the * CmdName object should refer to. */ { Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Namespace *currNsPtr; - CallFrame *savedFramePtr; - char *name; + const char *name; if (objPtr->typePtr == &tclCmdNameType) { return; } - /* - * 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] (Copied over from Tcl_GetCommandFromObj) - */ + cmdPtr->refCount++; + resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; - savedFramePtr = iPtr->varFramePtr; - name = Tcl_GetString(objPtr); + name = TclGetString(objPtr); if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = NULL; - } + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ - /* - * Get the current namespace. - */ + resPtr->refNsPtr = NULL; + } else { + /* + * 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; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr1 = resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; - - iPtr->varFramePtr = savedFramePtr; } /* @@ -3769,16 +4257,15 @@ TclSetCmdNameObj(interp, objPtr, cmdPtr) */ 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 = - (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL) { /* - * Decrement the reference count of the ResolvedCmdName structure. If + * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. */ @@ -3791,10 +4278,12 @@ FreeCmdNameInternalRep(objPtr) */ Command *cmdPtr = resPtr->cmdPtr; - TclCleanupCommand(cmdPtr); - ckfree((char *) resPtr); + + TclCleanupCommandMacro(cmdPtr); + ckfree(resPtr); } } + objPtr->typePtr = NULL; } /* @@ -3818,14 +4307,13 @@ FreeCmdNameInternalRep(objPtr) */ 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 = srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; if (resPtr != NULL) { resPtr->refCount++; @@ -3855,24 +4343,18 @@ DupCmdNameInternalRep(srcPtr, copyPtr) */ 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; + const char *name; register Command *cmdPtr; Namespace *currNsPtr; register ResolvedCmdName *resPtr; - /* - * Get "objPtr"s string representation. Make it up-to-date if necessary. - */ - - name = objPtr->bytes; - if (name == NULL) { - name = Tcl_GetString(objPtr); + if (interp == NULL) { + return TCL_ERROR; } /* @@ -3883,43 +4365,128 @@ 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. - */ + name = TclGetString(objPtr); + cmdPtr = (Command *) + Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; + /* + * Free the old internalRep before setting the new one. Do this after + * getting the string rep to allow the conversion code (in particular, + * Tcl_GetStringFromObj) to use that old internalRep. + */ + + if (cmdPtr) { + cmdPtr->refCount++; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) + && resPtr && (resPtr->refCount == 1)) { + /* + * Reuse the old ResolvedCmdName struct instead of freeing it + */ + + Command *oldCmdPtr = resPtr->cmdPtr; + + if (--oldCmdPtr->refCount == 0) { + TclCleanupCommandMacro(oldCmdPtr); + } } else { - currNsPtr = iPtr->globalNsPtr; + TclFreeIntRep(objPtr); + resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ - 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; + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } } else { - resPtr = NULL; /* no command named "name" was found */ + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RepresentationCmd -- + * + * Implementation of the "tcl::unsupported::representation" command. + * + * Results: + * Reports the current representation (Tcl_Obj type) of its argument. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RepresentationCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + char ptrBuffer[2*TCL_INTEGER_SPACE+6]; + Tcl_Obj *descObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; } /* - * 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. + * Value is a bignum with a refcount of 14, object pointer at 0x12345678, + * internal representation 0x45671234:0x98765432, string representation + * "1872361827361287" */ - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; + sprintf(ptrBuffer, "%p", (void *) objv[1]); + descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," + " object pointer at %s", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, ptrBuffer); + + if (objv[1]->typePtr) { + sprintf(ptrBuffer, "%p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + Tcl_AppendPrintfToObj(descObj, ", internal representation %s", + ptrBuffer); + } + + if (objv[1]->bytes) { + Tcl_AppendToObj(descObj, ", string representation \"", -1); + Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, + 16, "..."); + Tcl_AppendToObj(descObj, "\"", -1); + } else { + Tcl_AppendToObj(descObj, ", no string representation", -1); + } + + Tcl_SetObjResult(interp, descObj); return TCL_OK; } @@ -3928,5 +4495,7 @@ SetCmdNameFromAny(interp, objPtr) * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ |