diff options
Diffstat (limited to 'tcl/generic/tclObj.c')
| -rw-r--r-- | tcl/generic/tclObj.c | 1418 |
1 files changed, 1254 insertions, 164 deletions
diff --git a/tcl/generic/tclObj.c b/tcl/generic/tclObj.c index 581c6b0aaa5..6af1b59d002 100644 --- a/tcl/generic/tclObj.c +++ b/tcl/generic/tclObj.c @@ -6,6 +6,7 @@ * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. + * Copyright (c) 2001 by ActiveState Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -14,6 +15,7 @@ */ #include "tclInt.h" +#include "tclCompile.h" #include "tclPort.h" /* @@ -45,18 +47,8 @@ Tcl_Mutex tclObjMutex; * is shared by all new objects allocated by Tcl_NewObj. */ -static char emptyString; -char *tclEmptyStringRep = &emptyString; - -/* - * The number of Tcl objects ever allocated (by Tcl_NewObj) and freed - * (by TclFreeObj). - */ - -#ifdef TCL_COMPILE_STATS -long tclObjsAlloced = 0; -long tclObjsFreed = 0; -#endif /* TCL_COMPILE_STATS */ +char tclEmptyString = '\0'; +char *tclEmptyStringRep = &tclEmptyString; /* * Prototypes for procedures defined later in this file: @@ -71,6 +63,37 @@ static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +#ifndef TCL_WIDE_INT_IS_LONG +static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +#endif + +/* + * Prototypes for the array hash key methods. + */ + +static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, VOID *keyPtr)); +static int CompareObjKeys _ANSI_ARGS_(( + VOID *keyPtr, Tcl_HashEntry *hPtr)); +static void FreeObjEntry _ANSI_ARGS_(( + Tcl_HashEntry *hPtr)); +static unsigned int HashObjKey _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + VOID *keyPtr)); + +/* + * Prototypes for the CommandName object type. + */ + +static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static void FreeCmdNameInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + /* * The structures below defines the Tcl object types defined in this file by @@ -102,6 +125,81 @@ Tcl_ObjType tclIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; + +#ifndef TCL_WIDE_INT_IS_LONG +Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ +}; +#endif + +/* + * The structure below defines the Tcl obj hash key type. + */ +Tcl_HashKeyType tclObjHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + HashObjKey, /* hashKeyProc */ + CompareObjKeys, /* compareKeysProc */ + AllocObjEntry, /* allocEntryProc */ + FreeObjEntry /* freeEntryProc */ +}; + +/* + * The structure below defines the command name Tcl object type by means of + * procedures that can be invoked by generic object code. Objects of this + * type cache the Command pointer that results from looking up command names + * in the command hashtable. Such objects appear as the zeroth ("command + * name") argument in a Tcl command. + */ + +static Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ +}; + + +/* + * Structure containing a cached pointer to a command that is the result + * of resolving the command's name in some namespace. It is the internal + * representation for a cmdName object. It contains the pointer along + * with some information that is used to check the pointer's validity. + */ + +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). */ + 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; + /* *------------------------------------------------------------------------- @@ -133,16 +231,30 @@ TclInitObjSubsystem() Tcl_RegisterObjType(&tclBooleanType); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); + Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_RegisterObjType(&tclWideIntType); +#endif Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclProcBodyType); + Tcl_RegisterObjType(&tclArraySearchType); + Tcl_RegisterObjType(&tclIndexType); + Tcl_RegisterObjType(&tclNsNameType); + Tcl_RegisterObjType(&tclCmdNameType); #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 } @@ -306,7 +418,7 @@ Tcl_AppendAllObjTypes(interp, objPtr) Tcl_ObjType * Tcl_GetObjType(typeName) - char *typeName; /* Name of Tcl object type to look up. */ + CONST char *typeName; /* Name of Tcl object type to look up. */ { register Tcl_HashEntry *hPtr; Tcl_ObjType *typePtr; @@ -404,25 +516,11 @@ Tcl_NewObj() register Tcl_Obj *objPtr; /* - * Allocate the object using the list of free Tcl_Obj structs - * we maintain. + * Use the macro defined in tclInt.h - it will use the + * correct allocator. */ - Tcl_MutexLock(&tclObjMutex); - if (tclFreeObjList == NULL) { - TclAllocateFreeObjects(); - } - objPtr = tclFreeObjList; - tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr; - - objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - objPtr->typePtr = NULL; -#ifdef TCL_COMPILE_STATS - tclObjsAlloced++; -#endif /* TCL_COMPILE_STATS */ - Tcl_MutexUnlock(&tclObjMutex); + TclNewObj(objPtr); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -437,7 +535,7 @@ Tcl_NewObj() * empty string. It is the same as the Tcl_NewObj procedure above * except that it calls Tcl_DbCkalloc directly with the file name and * line number from its caller. This simplifies debugging since then - * the checkmem command will report the correct file name and line + * the [memory active] command will report the correct file name and line * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the @@ -458,7 +556,7 @@ Tcl_NewObj() Tcl_Obj * Tcl_DbNewObj(file, line) - register char *file; /* The name of the source file calling this + register CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ register int line; /* Line number in the source file; used * for debugging. */ @@ -466,29 +564,18 @@ Tcl_DbNewObj(file, line) register Tcl_Obj *objPtr; /* - * If debugging Tcl's memory usage, allocate the object using ckalloc. - * Otherwise, allocate it using the list of free Tcl_Obj structs we - * maintain. + * Use the macro defined in tclInt.h - it will use the + * correct allocator. */ - objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line); - objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - objPtr->typePtr = NULL; -#ifdef TCL_COMPILE_STATS - Tcl_MutexLock(&tclObjMutex); - tclObjsAlloced++; - Tcl_MutexUnlock(&tclObjMutex); -#endif /* TCL_COMPILE_STATS */ + TclDbNewObj(objPtr, file, line); return objPtr; } - #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewObj(file, line) - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -523,23 +610,27 @@ Tcl_DbNewObj(file, line) void TclAllocateFreeObjects() { - Tcl_Obj tmp[2]; - size_t objSizePlusPadding = /* NB: this assumes byte addressing. */ - ((int)(&(tmp[1])) - (int)(&(tmp[0]))); - size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding); + 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. These never do get freed properly. + */ + basePtr = (char *) ckalloc(bytesToAlloc); memset(basePtr, 0, bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; - for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { + for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; prevPtr = objPtr; - objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding); + objPtr++; } tclFreeObjList = prevPtr; } @@ -593,18 +684,22 @@ TclFreeObj(objPtr) * Tcl_Obj structs we maintain. */ +#if defined(TCL_MEM_DEBUG) || defined(PURIFY) Tcl_MutexLock(&tclObjMutex); -#ifdef TCL_MEM_DEBUG ckfree((char *) objPtr); -#else + Tcl_MutexUnlock(&tclObjMutex); +#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + TclThreadFreeObj(objPtr); +#else + Tcl_MutexLock(&tclObjMutex); objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; tclFreeObjList = objPtr; + Tcl_MutexUnlock(&tclObjMutex); #endif /* TCL_MEM_DEBUG */ #ifdef TCL_COMPILE_STATS tclObjsFreed++; #endif /* TCL_COMPILE_STATS */ - Tcl_MutexUnlock(&tclObjMutex); } /* @@ -648,15 +743,7 @@ Tcl_DuplicateObj(objPtr) if (objPtr->bytes == NULL) { dupPtr->bytes = NULL; } else if (objPtr->bytes != tclEmptyStringRep) { - int len = objPtr->length; - - dupPtr->bytes = (char *) ckalloc((unsigned) len+1); - if (len > 0) { - memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes, - (unsigned) len); - } - dupPtr->bytes[len] = '\0'; - dupPtr->length = len; + TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); } if (typePtr != NULL) { @@ -733,24 +820,20 @@ Tcl_GetString(objPtr) char * Tcl_GetStringFromObj(objPtr, lengthPtr) - 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. */ + 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. */ { - if (objPtr->bytes != NULL) { - if (lengthPtr != NULL) { - *lengthPtr = objPtr->length; + if (objPtr->bytes == NULL) { + if (objPtr->typePtr->updateStringProc == NULL) { + panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); } - return objPtr->bytes; + (*objPtr->typePtr->updateStringProc)(objPtr); } - if (objPtr->typePtr->updateStringProc == NULL) { - panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - (*objPtr->typePtr->updateStringProc)(objPtr); if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } @@ -847,9 +930,9 @@ Tcl_NewBooleanObj(boolValue) * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the * same as the Tcl_NewBooleanObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the checkmem command - * will report the correct file name and line number when reporting - * objects that haven't been freed. + * caller. This simplifies debugging since then the [memory active] + * command will report the correct file name and line number when + * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewBooleanObj. @@ -869,7 +952,7 @@ Tcl_NewBooleanObj(boolValue) Tcl_Obj * Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -889,7 +972,7 @@ Tcl_DbNewBooleanObj(boolValue, file, line) Tcl_Obj * Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -965,7 +1048,12 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) { register int result; - result = SetBooleanFromAny(interp, objPtr); + if (objPtr->typePtr == &tclBooleanType) { + result = TCL_OK; + } else { + result = SetBooleanFromAny(interp, objPtr); + } + if (result == TCL_OK) { *boolPtr = (int) objPtr->internalRep.longValue; } @@ -1003,88 +1091,142 @@ SetBooleanFromAny(interp, objPtr) char lowerCase[10]; int newBool, length; register int i; - double dbl; /* * Get the string representation. Make it up-to-date if necessary. */ - + string = Tcl_GetStringFromObj(objPtr, &length); /* - * Copy the string converting its characters to lower case. - */ - - for (i = 0; (i < 9) && (i < length); i++) { - c = string[i]; - /* - * Weed out international characters so we can safely operate - * on single bytes. - */ - - if (c & 0x80) { - goto badBoolean; - } - if (Tcl_UniCharIsUpper(UCHAR(c))) { - c = (char) Tcl_UniCharToLower(UCHAR(c)); - } - lowerCase[i] = c; - } - lowerCase[i] = 0; - - /* - * Parse the string as a boolean. We use an implementation here that - * doesn't report errors in interp if interp is NULL. + * Use the obvious shortcuts for numerical values; if objPtr is not + * of numerical type, parse its string rep. */ - - c = lowerCase[0]; - if ((c == '0') && (lowerCase[1] == '\0')) { - newBool = 0; - } else if ((c == '1') && (lowerCase[1] == '\0')) { - newBool = 1; - } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { - newBool = 1; - } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { - newBool = 0; - } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { - newBool = 1; - } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { - newBool = 0; - } else if ((c == 'o') && (length >= 2)) { - if (strncmp(lowerCase, "on", (size_t) length) == 0) { - newBool = 1; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { - newBool = 0; - } else { - goto badBoolean; - } + + if (objPtr->typePtr == &tclIntType) { + newBool = (objPtr->internalRep.longValue != 0); + } else if (objPtr->typePtr == &tclDoubleType) { + newBool = (objPtr->internalRep.doubleValue != 0.0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (objPtr->typePtr == &tclWideIntType) { + newBool = (objPtr->internalRep.wideValue != Tcl_LongAsWide(0)); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { - /* - * Still might be a string containing the characters representing an - * int or double that wasn't handled above. This would be a string - * like "27" or "1.0" that is non-zero and not "1". Such a string - * whould result in the boolean value true. We try converting to - * double. If that succeeds and the resulting double is non-zero, we - * have a "true". Note that numbers can't have embedded NULLs. + /* + * Copy the string converting its characters to lower case. */ - - dbl = strtod(string, &end); - if (end == string) { - goto badBoolean; + + for (i = 0; (i < 9) && (i < length); i++) { + c = string[i]; + /* + * Weed out international characters so we can safely operate + * on single bytes. + */ + + if (c & 0x80) { + goto badBoolean; + } + if (Tcl_UniCharIsUpper(UCHAR(c))) { + c = (char) Tcl_UniCharToLower(UCHAR(c)); + } + lowerCase[i] = c; } - + lowerCase[i] = 0; + /* - * Make sure the string has no garbage after the end of the double. + * Parse the string as a boolean. We use an implementation here that + * doesn't report errors in interp if interp is NULL. */ - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end != (string+length)) { - goto badBoolean; + c = lowerCase[0]; + if ((c == '0') && (lowerCase[1] == '\0')) { + newBool = 0; + } else if ((c == '1') && (lowerCase[1] == '\0')) { + newBool = 1; + } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { + newBool = 1; + } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { + newBool = 0; + } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { + newBool = 1; + } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { + newBool = 0; + } else if ((c == 'o') && (length >= 2)) { + if (strncmp(lowerCase, "on", (size_t) length) == 0) { + newBool = 1; + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + newBool = 0; + } else { + goto badBoolean; + } + } else { + double dbl; + /* + * Boolean values can be extracted from ints or doubles. Note + * that we don't use strtoul or strtoull here because we don't + * care about what the value is, just whether it is equal to + * zero or not. + */ +#ifdef TCL_WIDE_INT_IS_LONG + newBool = strtol(string, &end, 0); + if (end != string) { + /* + * Make sure the string has no garbage after the end of + * the int. + */ + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end == (string+length)) { + newBool = (newBool != 0); + goto goodBoolean; + } + } +#else /* !TCL_WIDE_INT_IS_LONG */ + Tcl_WideInt wide = strtoll(string, &end, 0); + if (end != string) { + /* + * Make sure the string has no garbage after the end of + * the wide int. + */ + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end == (string+length)) { + newBool = (wide != Tcl_LongAsWide(0)); + goto goodBoolean; + } + } +#endif /* TCL_WIDE_INT_IS_LONG */ + /* + * Still might be a string containing the characters representing an + * int or double that wasn't handled above. This would be a string + * like "27" or "1.0" that is non-zero and not "1". Such a string + * would result in the boolean value true. We try converting to + * double. If that succeeds and the resulting double is non-zero, we + * have a "true". Note that numbers can't have embedded NULLs. + */ + + dbl = strtod(string, &end); + if (end == string) { + goto badBoolean; + } + + /* + * Make sure the string has no garbage after the end of the double. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end != (string+length)) { + goto badBoolean; + } + newBool = (dbl != 0.0); } - newBool = (dbl != 0.0); } /* @@ -1093,6 +1235,7 @@ SetBooleanFromAny(interp, objPtr) * Tcl_GetStringFromObj, to use that old internalRep. */ + goodBoolean: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { oldTypePtr->freeIntRepProc(objPtr); } @@ -1205,9 +1348,9 @@ Tcl_NewDoubleObj(dblValue) * TCL_MEM_DEBUG is defined. It creates new double objects. It is the * same as the Tcl_NewDoubleObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the checkmem command - * will report the correct file name and line number when reporting - * objects that haven't been freed. + * caller. This simplifies debugging since then the [memory active] + * command will report the correct file name and line number when + * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewDoubleObj. @@ -1227,7 +1370,7 @@ Tcl_NewDoubleObj(dblValue) Tcl_Obj * Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -1247,7 +1390,7 @@ Tcl_DbNewDoubleObj(dblValue, file, line) Tcl_Obj * Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -1836,8 +1979,8 @@ Tcl_NewLongObj(longValue) * 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 checkmem command will report the caller's file name and line - * number when reporting objects that haven't been freed. + * the [memory active] command will report the caller's file name and + * line number when reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewLongObj. @@ -1859,7 +2002,7 @@ Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) register long longValue; /* Long integer used to initialize the * new object. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -1880,7 +2023,7 @@ Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) register long longValue; /* Long integer used to initialize the * new object. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -1971,6 +2114,380 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) /* *---------------------------------------------------------------------- * + * SetWideIntFromAny -- + * + * Attempt to generate an integer internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard object Tcl result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If no error occurs, an int is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_WIDE_INT_IS_LONG +static int +SetWideIntFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + int length; + register char *p; + Tcl_WideInt newWide; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Now parse "objPtr"s string as an int. We use an implementation here + * that doesn't report errors in interp if interp is NULL. Note: use + * strtoull instead of strtoll for integer conversions to allow full-size + * unsigned numbers, but don't depend on strtoull to handle sign + * characters; it won't in some implementations. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ + /* Empty loop body. */ + } + if (*p == '-') { + p++; + newWide = -((Tcl_WideInt)strtoull(p, &end, 0)); + } else if (*p == '+') { + p++; + newWide = strtoull(p, &end, 0); + } else { + newWide = strtoull(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to an int. + */ + + char buf[100]; + sprintf(buf, "expected integer but got \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + TclCheckBadOctal(interp, string); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Make sure that the string has no garbage after the end of the int. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO space. */ + end++; + } + if (end != (string+length)) { + goto badInteger; + } + + /* + * The conversion to int succeeded. Free the old internalRep before + * setting the new one. We do this as late as possible to allow the + * conversion code, in particular Tcl_GetStringFromObj, to use that old + * internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.wideValue = newWide; + objPtr->typePtr = &tclWideIntType; + return TCL_OK; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfWideInt -- + * + * Update the string representation for a wide integer object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the wideInt-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_WIDE_INT_IS_LONG +static void +UpdateStringOfWideInt(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE+2]; + register unsigned len; + register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; + + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); + len = strlen(buffer); + objPtr->bytes = ckalloc((unsigned) len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; +} +#endif /* TCL_WIDE_INT_IS_LONG */ + +/* + *---------------------------------------------------------------------- + * + * 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 procedure 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(wideValue) + 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(wideValue) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + return Tcl_NewLongObj(wideValue); +#else + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + return objPtr; +#endif /* TCL_WIDE_INT_IS_LONG */ +} +#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 procedure Tcl_DbNewWideIntObj instead. We + * provide two implementations of Tcl_DbNewWideIntObj so that + * whether the Tcl core is compiled to do memory debugging of the + * core is independent of whether a client requests debugging for + * itself. + * + * 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 procedure 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(wideValue, file, line) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ + CONST char *file; /* The name of the source file + * calling this procedure; used for + * debugging. */ + int line; /* Line number in the source file; + * used for debugging. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + return Tcl_DbNewLongObj(wideValue, file, line); +#else + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + return objPtr; +#endif +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewWideIntObj(wideValue, file, line) + register Tcl_WideInt wideValue; /* Long integer used to initialize + * the new object. */ + CONST char *file; /* The name of the source file + * calling this procedure; used for + * debugging. */ + int line; /* Line number in the source file; + * used for debugging. */ +{ + 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(objPtr, wideValue) + register Tcl_Obj *objPtr; /* Object w. internal rep to init. */ + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the object's value. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + Tcl_SetLongObj(objPtr, wideValue); +#else + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetWideIntObj called with shared object"); + } + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + Tcl_InvalidateStringRep(objPtr); +#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(interp, objPtr, wideIntPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* Object from which to get a wide int. */ + register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + /* + * Next line is type-safe because we only do this when long = Tcl_WideInt + */ + return Tcl_GetLongFromObj(interp, objPtr, wideIntPtr); +#else + register int result; + + if (objPtr->typePtr == &tclWideIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } + result = SetWideIntFromAny(interp, objPtr); + if (result == TCL_OK) { + *wideIntPtr = objPtr->internalRep.wideValue; + } + return result; +#endif +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DbIncrRefCount -- * * This procedure is normally called when debugging: i.e., when @@ -1993,7 +2510,7 @@ void Tcl_DbIncrRefCount(objPtr, file, line) register Tcl_Obj *objPtr; /* The object we are registering a * reference to. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -2033,7 +2550,7 @@ void Tcl_DbDecrRefCount(objPtr, file, line) register Tcl_Obj *objPtr; /* The object we are releasing a reference * to. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -2074,7 +2591,7 @@ Tcl_DbDecrRefCount(objPtr, file, line) int Tcl_DbIsShared(objPtr, file, line) register Tcl_Obj *objPtr; /* The object to test for being shared. */ - char *file; /* The name of the source file calling this + CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ @@ -2086,5 +2603,578 @@ Tcl_DbIsShared(objPtr, file, line) panic("Trying to check whether previously disposed object is shared."); } #endif +#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 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(tablePtr) + 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(tablePtr, keyPtr) + Tcl_HashTable *tablePtr; /* Hash table. */ + VOID *keyPtr; /* Key to store in the hash table entry. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + Tcl_HashEntry *hPtr; + + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); + hPtr->key.oneWordValue = (char *) objPtr; + Tcl_IncrRefCount (objPtr); + + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * CompareObjKeys -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +CompareObjKeys(keyPtr, hPtr) + VOID *keyPtr; /* New key to compare. */ + Tcl_HashEntry *hPtr; /* Existing key to compare. */ +{ + Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; + Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; + register CONST char *p1, *p2; + register int l1, l2; + + /* + * If the object pointers are the same then they match. + */ + if (objPtr1 == objPtr2) { + return 1; + } + + /* + * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being + * in a register. + */ + p1 = Tcl_GetString (objPtr1); + l1 = objPtr1->length; + p2 = Tcl_GetString (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; +} + +/* + *---------------------------------------------------------------------- + * + * FreeObjEntry -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +FreeObjEntry(hPtr) + Tcl_HashEntry *hPtr; /* Hash entry to free. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; + + Tcl_DecrRefCount (objPtr); + ckfree ((char *) hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * HashObjKey -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static unsigned int +HashObjKey(tablePtr, keyPtr) + Tcl_HashTable *tablePtr; /* Hash table. */ + VOID *keyPtr; /* Key from which to compute hash value. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + register CONST char *string; + register int length; + register unsigned int result; + register int c; + + string = Tcl_GetString (objPtr); + length = objPtr->length; + + /* + * 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. + */ + + result = 0; + while (length) { + c = *string; + string++; + length--; + if (length == 0) { + break; + } + result += (result<<3) + c; + } + 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 procedure is + * called with the same object, the command can be found quickly. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_GetCommandFromObj(interp, objPtr) + Tcl_Interp *interp; /* The interpreter in which to resolve the + * 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. */ +{ + Interp *iPtr = (Interp *) interp; + register ResolvedCmdName *resPtr; + register Command *cmdPtr; + Namespace *currNsPtr; + int result; + CallFrame *savedFramePtr; + char *name; + + /* + * If the variable name is fully qualified, do as if the lookup were + * done from the global namespace; this helps avoid repeated lookups + * of fully qualified names. It costs close to nothing, and may be very + * helpful for OO applications which pass along a command name ("this"), + * [Patch 456668] + */ + + savedFramePtr = iPtr->varFramePtr; + name = Tcl_GetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + iPtr->varFramePtr = NULL; + } + + /* + * Get the internal representation, converting to a command type if + * needed. The internal representation is a ResolvedCmdName that points + * to the actual command. + */ + + if (objPtr->typePtr != &tclCmdNameType) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + iPtr->varFramePtr = savedFramePtr; + return (Tcl_Command) NULL; + } + } + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + /* + * Check the context namespace and the namespace epoch of the resolved + * symbol to make sure that it is fresh. If not, then force another + * conversion to the command type, to discard the old rep and create a + * new one. Note that we verify that the namespace id of the context + * namespace is the same as the one we cached; this insures that the + * namespace wasn't deleted and a new one created at the same address + * with the same command epoch. + */ + + cmdPtr = NULL; + if ((resPtr != NULL) + && (resPtr->refNsPtr == currNsPtr) + && (resPtr->refNsId == currNsPtr->nsId) + && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { + cmdPtr = resPtr->cmdPtr; + if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { + cmdPtr = NULL; + } + } + + if (cmdPtr == NULL) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + iPtr->varFramePtr = savedFramePtr; + return (Tcl_Command) NULL; + } + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + if (resPtr != NULL) { + cmdPtr = resPtr->cmdPtr; + } + } + iPtr->varFramePtr = savedFramePtr; + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * 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 + * TclExecuteByteCode has a chance to recognize that it was deleted. + * + *---------------------------------------------------------------------- + */ + +void +TclSetCmdNameObj(interp, objPtr, cmdPtr) + 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; + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + register Namespace *currNsPtr; + + if (oldTypePtr == &tclCmdNameType) { + return; + } + + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 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(objPtr) + register Tcl_Obj *objPtr; /* CmdName object with internal + * representation to free. */ +{ + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + + if (resPtr != NULL) { + /* + * Decrement the reference count of the ResolvedCmdName structure. + * If there are no more uses, free the ResolvedCmdName structure. + */ + + resPtr->refCount--; + if (resPtr->refCount == 0) { + /* + * Now free the cached command, unless it is still in its + * hash table or if there are other references to it + * from other cmdName objects. + */ + + Command *cmdPtr = resPtr->cmdPtr; + TclCleanupCommand(cmdPtr); + ckfree((char *) resPtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * 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(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; + + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 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(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Interp *iPtr = (Interp *) interp; + char *name; + Tcl_Command cmd; + register Command *cmdPtr; + Namespace *currNsPtr; + register ResolvedCmdName *resPtr; + + /* + * Get "objPtr"s string representation. Make it up-to-date if necessary. + */ + + name = objPtr->bytes; + if (name == NULL) { + name = Tcl_GetString(objPtr); + } + + /* + * Find the Command structure, if any, that describes the command called + * "name". Build a ResolvedCmdName that holds a cached pointer to this + * Command, and bump the reference count in the referenced Command + * structure. A Command structure will not be deleted as long as it is + * referenced from a CmdName object. + */ + + cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, + /*flags*/ 0); + cmdPtr = (Command *) cmd; + if (cmdPtr != NULL) { + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + } else { + resPtr = NULL; /* no command named "name" was found */ + } + + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * GetStringFromObj, to use that old internalRep. If no Command + * structure was found, leave NULL as the cached value. + */ + + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + return TCL_OK; +} |