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