Index: .project ================================================================== --- .project +++ .project @@ -1,8 +1,8 @@ - tcl8.7 + tcl8 DELETED compat/float.h Index: compat/float.h ================================================================== --- compat/float.h +++ /dev/null @@ -1,14 +0,0 @@ -/* - * float.h -- - * - * This is a dummy header file to #include in Tcl when there - * is no float.h in /usr/include. Right now this file is empty: - * Tcl contains #ifdefs to deal with the lack of definitions; - * all it needs is for the #include statement to work. - * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ Index: doc/Object.3 ================================================================== --- doc/Object.3 +++ doc/Object.3 @@ -255,11 +255,11 @@ .PP The \fBincr\fR command first gets an integer from \fIx\fR's value by calling \fBTcl_GetIntFromObj\fR. This procedure checks whether the value is already an integer value. Since it is not, it converts the value -by setting the value's \fIinternalRep.longValue\fR member +by setting the value's internal representation to the integer \fB123\fR and setting the value's \fItypePtr\fR to point to the integer Tcl_ObjType structure. Both representations are now valid. \fBincr\fR increments the value's integer internal representation Index: doc/SaveResult.3 ================================================================== --- doc/SaveResult.3 +++ doc/SaveResult.3 @@ -52,13 +52,13 @@ state is to be restored. So long as one of the latter two routines is called, Tcl will take care of memory management. .PP The second triplet stores the snapshot of only the interpreter result (not its complete state) in memory allocated by the caller. -These routines are passed a pointer to a \fBTcl_SavedResult\fR structure +These routines are passed a pointer to \fBTcl_SavedResult\fR that is used to store enough information to restore the interpreter result. -This structure can be allocated on the stack of the calling +\fBTcl_SavedResult\fR can be allocated on the stack of the calling procedure. These routines do not save the state of any error information in the interpreter (e.g. the \fB\-errorcode\fR or \fB\-errorinfo\fR return options, when an error is in progress). .PP Because the routines \fBTcl_SaveInterpState\fR, Index: doc/ToUpper.3 ================================================================== --- doc/ToUpper.3 +++ doc/ToUpper.3 @@ -31,11 +31,11 @@ int \fBTcl_UtfToTitle\fR(\fIstr\fR) .SH ARGUMENTS .AS char *str in/out .AP int ch in -The Tcl_UniChar to be converted. +The Unicode character to be converted. .AP char *str in/out Pointer to UTF-8 string to be converted in place. .BE .SH DESCRIPTION Index: doc/UniCharIsAlpha.3 ================================================================== --- doc/UniCharIsAlpha.3 +++ doc/UniCharIsAlpha.3 @@ -46,23 +46,20 @@ int \fBTcl_UniCharIsWordChar\fR(\fIch\fR) .SH ARGUMENTS .AS int ch .AP int ch in -The Tcl_UniChar to be examined. +The Unicode character to be examined. .BE .SH DESCRIPTION .PP -All of the routines described examine Tcl_UniChars and return a +All of the routines described examine Unicode characters and return a boolean value. A non-zero return value means that the character does belong to the character class associated with the called routine. The rest of this document just describes the character classes associated with the various routines. -.PP -Note: A Tcl_UniChar is a Unicode character represented as an unsigned, -fixed-size quantity. .SH "CHARACTER CLASSES" .PP \fBTcl_UniCharIsAlnum\fR tests if the character is an alphanumeric Unicode character. .PP Index: doc/Utf.3 ================================================================== --- doc/Utf.3 +++ doc/Utf.3 @@ -75,11 +75,11 @@ .AS "const Tcl_UniChar" *uniPattern in/out .AP char *buf out Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer. .AP int ch in -The Tcl_UniChar to be converted or examined. +The Unicode character to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP "const char" *src in Pointer to a UTF-8 string. .AP "const char" *cs in Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -467,11 +467,10 @@ CONST84_RETURN char *Tcl_ErrnoMsg(int err) } declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) } -# This is obsolete, use Tcl_FSEvalFile declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } declare 131 { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) @@ -778,12 +777,11 @@ int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Obsolete -declare 220 { +declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 { int Tcl_ServiceAll(void) } @@ -866,12 +864,11 @@ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } declare 245 { int Tcl_StringMatch(const char *str, const char *pattern) } -# Obsolete -declare 246 { +declare 246 {deprecated {}} { int Tcl_TellOld(Tcl_Channel chan) } declare 247 { int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) @@ -943,14 +940,14 @@ int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -declare 267 { +declare 267 {deprecated {see TIP #422}} { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } -declare 268 { +declare 268 {deprecated {see TIP #422}} { void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) } declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } @@ -974,20 +971,20 @@ # TIP #268: The internally used new Require function is in slot 573. declare 274 { CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } -declare 275 { +declare 275 {deprecated {see TIP #422}} { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) } -declare 276 { +declare 276 {deprecated {see TIP #422}} { int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) } declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 { +declare 278 {deprecated {see TIP #422}} { TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) } declare 279 { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) } @@ -2331,13 +2328,30 @@ Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData) } -# ----- BASELINE -- FOR -- 8.7.0 ----- # +# TIP #445 +declare 632 { + void Tcl_FreeIntRep(Tcl_Obj *objPtr) +} +declare 633 { + char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, + unsigned int numBytes) +} +declare 634 { + Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) +} +declare 635 { + void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, + const Tcl_ObjIntRep *irPtr) +} +declare 636 { + int Tcl_HasStringRep(Tcl_Obj *objPtr) +} - +# ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## # Define the platform specific public Tcl interface. These functions are only # available on the designated platform. Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -795,10 +795,33 @@ /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ } Tcl_ObjType; +/* + * The following structure stores an internal representation (intrep) for + * a Tcl value. An intrep is associated with an Tcl_ObjType when both + * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern + * the handling of the intrep. + */ + +typedef union Tcl_ObjIntRep { /* The internal representation: */ + long longValue; /* - an long integer value. */ + double doubleValue; /* - a double-precision floating value. */ + void *otherValuePtr; /* - another, type-specific value, */ + /* not used internally any more. */ + Tcl_WideInt wideValue; /* - an integer value >= 64bits */ + struct { /* - internal rep as two pointers. */ + void *ptr1; + void *ptr2; + } twoPtrValue; + struct { /* - internal rep as a pointer and a long, */ + void *ptr; /* not used internally any more. */ + unsigned long value; + } ptrAndLongRep; +} Tcl_ObjIntRep; + /* * One of the following structures exists for each object in the Tcl system. * An object stores a value as either a string, some internal representation, * or both. */ @@ -820,31 +843,11 @@ * including the terminating null. */ const Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ - union { /* The internal representation: */ - long longValue; /* - an long integer value. */ - double doubleValue; /* - a double-precision floating value. */ - void *otherValuePtr; /* - another, type-specific value, not used - * internally any more. */ - Tcl_WideInt wideValue; /* - a long long value. */ - struct { /* - internal rep as two pointers. - * Many uses in Tcl, including a bignum's - * tightly packed fields, where the alloc, - * used and signum flags are packed into - * ptr2 with everything else hung off - * ptr1. */ - void *ptr1; - void *ptr2; - } twoPtrValue; - struct { /* - internal rep as a pointer and a long, - * not used internally any more. */ - void *ptr; - unsigned long value; - } ptrAndLongRep; - } internalRep; + Tcl_ObjIntRep internalRep; /* The internal representation: */ } Tcl_Obj; /* * Macros to increment and decrement a Tcl_Obj's reference count, and to test * whether an object is shared (i.e. has reference count > 1). Note: clients @@ -1342,12 +1345,12 @@ */ typedef struct { void *next; /* Search position for underlying hash * table. */ - int epoch; /* Epoch marker for dictionary being searched, - * or -1 if search has terminated. */ + unsigned int epoch; /* Epoch marker for dictionary being searched, + * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; /* *---------------------------------------------------------------------------- @@ -2407,18 +2410,31 @@ int exact, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); #ifdef USE_TCL_STUBS -#define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, version, \ +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ TCL_STUB_MAGIC) #else -#define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#endif +#else +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#else +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#endif #endif /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] Index: generic/tclAssembly.c ================================================================== --- generic/tclAssembly.c +++ generic/tclAssembly.c @@ -30,10 +30,11 @@ */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" +#include /* * Structure that represents a range of instructions in the bytecode. */ @@ -269,19 +270,16 @@ Tcl_Obj *objPtr); static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, const TalInstDesc*); static int DefineLabel(AssemblyEnv* envPtr, const char* label); static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); -static void DupAssembleCodeInternalRep(Tcl_Obj* src, - Tcl_Obj* dest); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); static int FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); -static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); @@ -315,10 +313,13 @@ BasicBlock**, int*); /* * Tcl_ObjType that describes bytecode emitted by the assembler. */ + +static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep; +static Tcl_DupInternalRepProc DupAssembleCodeInternalRep; static const Tcl_ObjType assembleCodeType = { "assemblecode", FreeAssembleCodeInternalRep, /* freeIntRepProc */ DupAssembleCodeInternalRep, /* dupIntRepProc */ @@ -845,19 +846,19 @@ * names in the bytecode resolve */ int status; /* Status return from Tcl_AssembleCode */ const char* source; /* String representation of the source code */ int sourceLen; /* Length of the source code in bytes */ - /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - if (objPtr->typePtr == &assembleCodeType) { + ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + + if (codePtr) { namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == namespacePtr) && (codePtr->nsEpoch == namespacePtr->resolverEpoch) && (codePtr->localCachePtr @@ -867,11 +868,11 @@ /* * Not valid, so free it and regenerate. */ - TclFreeIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL); } /* * Set up the compilation environment, and assemble the code. */ @@ -4329,11 +4330,14 @@ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + + ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + assert(codePtr != NULL); TclReleaseByteCode(codePtr); } /* Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -116,10 +116,12 @@ static Tcl_ObjCmdProc ExprDoubleFunc; static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprMaxFunc; +static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; @@ -319,10 +321,12 @@ { "hypot", ExprBinaryFunc, (ClientData) hypot }, { "int", ExprIntFunc, NULL }, { "isqrt", ExprIsqrtFunc, NULL }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "max", ExprMaxFunc, NULL }, + { "min", ExprMinFunc, NULL }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, { "sin", ExprUnaryFunc, (ClientData) sin }, { "sinh", ExprUnaryFunc, (ClientData) sinh }, @@ -2096,17 +2100,17 @@ tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (isNew || deleted) { + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } /* An existing command conflicts. Try to delete it.. */ cmdPtr = Tcl_GetHashValue(hPtr); /* @@ -2243,68 +2247,86 @@ * the global namespace. */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc) + Tcl_CmdDeleteProc *deleteProc /* If not NULL, gives a function to call when * this command is deleted. */ +) { Interp *iPtr = (Interp *) interp; - ImportRef *oldRefPtr = NULL; Namespace *nsPtr; - Command *cmdPtr; - Tcl_HashEntry *hPtr; const char *tail; - int isNew = 0, deleted = 0; - ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new commands; * it's not safe to muck with the interpreter anymore. */ - return (Tcl_Command) NULL; } + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + Namespace *dummy1, *dummy2; + + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, + proc, clientData, deleteProc); +} + +Tcl_Command +TclCreateObjCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, /* Name of command, without any namespace components */ + Tcl_Namespace *namespace, /* The namespace to create the command in */ + Tcl_ObjCmdProc *proc, /* Object-based function to associate with + * name. */ + ClientData clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc + /* If not NULL, gives a function to call when + * this command is deleted. */ +) { + int deleted = 0, isNew = 0; + Command *cmdPtr; + ImportRef *oldRefPtr = NULL; + ImportedCmdData *dataPtr; + Tcl_HashEntry *hPtr; + Namespace *nsPtr = (Namespace *) namespace; /* * If the command name we seek to create already exists, we need to * delete that first. That can be tricky in the presence of traces. * Loop until we no longer find an existing command in the way, or * until we've deleted one command and that didn't finish the job. */ - while (1) { - /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. - */ - - if (strstr(cmdName, "::") != NULL) { - Namespace *dummy1, *dummy2; - - TclGetNamespaceForQualName(interp, cmdName, NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { - return (Tcl_Command) NULL; - } - } else { - nsPtr = iPtr->globalNsPtr; - tail = cmdName; - } - - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - - if (isNew || deleted) { + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); + + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } + /* An existing command conflicts. Try to delete it.. */ cmdPtr = Tcl_GetHashValue(hPtr); /* @@ -2333,21 +2355,26 @@ cmdPtr->refCount++; if (cmdPtr->importRefPtr) { cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; } + + /* Make sure namespace doesn't get deallocated. */ + cmdPtr->nsPtr->refCount++; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + nsPtr = (Namespace *) TclEnsureNamespace(interp, + (Tcl_Namespace *)cmdPtr->nsPtr); + TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; } TclCleanupCommandMacro(cmdPtr); deleted = 1; } - if (!isNew) { /* * If the deletion callback recreated the command, just throw away * the new command (if we try to delete it again, we could get * stuck in an infinite loop). @@ -2365,11 +2392,11 @@ * Without invalidating a possible CmdName literal here explicitly, * such literals keep being reused while pointing to overhauled * commands. */ - TclInvalidateCmdLiteral(interp, tail, nsPtr); + TclInvalidateCmdLiteral(interp, cmdName, nsPtr); /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -3568,13 +3595,18 @@ for (j = 1, k = 0; j < objc; ++j, ++k) { /* TODO: Convert to TclGetNumberFromObj? */ valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN - if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { - d = valuePtr->internalRep.doubleValue; - result = TCL_OK; + if (result != TCL_OK) { + const Tcl_ObjIntRep *irPtr + = Tcl_FetchIntRep(valuePtr, &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + result = TCL_OK; + } } #endif if (result != TCL_OK) { /* * We have a non-numeric argument. @@ -5843,11 +5875,11 @@ * guaranteed to have been generated dynamically: bail out, this cannot * have a usable absolute location. _Do not touch_ the information the set * up by the caller. It knows better than us. */ - if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { + if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) { return; } /* * First look for location information recorded in the argument @@ -7120,13 +7152,17 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -7156,13 +7192,17 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -7292,13 +7332,17 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -7335,14 +7379,18 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - d = objv[1]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -7395,25 +7443,33 @@ MathFuncWrongNumArgs(interp, 3, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - d1 = objv[1]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d1 = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { - d2 = objv[2]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d2 = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -7446,18 +7502,20 @@ long l = *((const long *) ptr); if (l > (long)0) { goto unChanged; } else if (l == (long)0) { - const char *string = objv[1]->bytes; - if (string) { - while (*string != '0') { - if (*string == '-') { + if (TclHasStringRep(objv[1])) { + int numBytes; + const char *bytes = TclGetStringFromObj(objv[1], &numBytes); + + while (numBytes) { + if (*bytes == '-') { Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); return TCL_OK; } - string++; + bytes++; numBytes--; } } goto unChanged; } else if (l == LONG_MIN) { TclInitBignumFromLong(&big, l); @@ -7565,11 +7623,11 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (objv[1]->typePtr == &tclDoubleType) { + if (Tcl_FetchIntRep(objv[1], &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } #endif return TCL_ERROR; @@ -7696,10 +7754,75 @@ Tcl_DecrRefCount(objPtr); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; } + +/* + * Common implmentation of max() and min(). + */ +static int +ExprMaxMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv, /* Actual parameter vector. */ + int op) /* Comparison direction */ +{ + Tcl_Obj *res; + double d; + int type, i; + ClientData ptr; + + if (objc < 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + res = objv[1]; + for (i = 1; i < objc; i++) { + if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[i], &d); + return TCL_ERROR; + } + if (TclCompareTwoNumbers(objv[i], res) == op) { + res = objv[i]; + } + } + + Tcl_SetObjResult(interp, res); + return TCL_OK; +} + +static int +ExprMaxFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT); +} + +static int +ExprMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT); +} static int ExprRandFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the @@ -7720,11 +7843,11 @@ if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; /* - * To ensure different seeds in different threads (bug #416643), + * To ensure different seeds in different threads (bug #416643), * take into consideration the thread this interp is running in. */ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); @@ -8182,10 +8305,26 @@ * this command is deleted. */ { Command *cmdPtr = (Command *) Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); + cmdPtr->nreProc = nreProc; + return (Tcl_Command) cmdPtr; +} + +Tcl_Command +TclNRCreateCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc) { + Command *cmdPtr = (Command *) + TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); + cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; } /**************************************************************************** @@ -8970,48 +9109,35 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr; CoroutineData *corPtr; - const char *fullName, *procName; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_DString ds; + const char *procName, *simpleName; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); return TCL_ERROR; } - /* - * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have - * something in tclUtil.c to find the FQ name. - */ - - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, inNsPtr, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } /* @@ -9019,20 +9145,13 @@ * struct and create the corresponding command. */ corPtr = ckalloc(sizeof(CoroutineData)); - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); - Tcl_DStringFree(&ds); + cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, + (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, + corPtr, DeleteCoroutine); corPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; /* Index: generic/tclBinary.c ================================================================== --- generic/tclBinary.c +++ generic/tclBinary.c @@ -13,10 +13,11 @@ #include "tclInt.h" #include "tommath.h" #include +#include /* * The following constants are used by GetFormatSpec to indicate various * special conditions in the parsing of a format specifier. */ @@ -54,13 +55,16 @@ * Prototypes for local procedures defined in this file: */ static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); +static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, int *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); static int SetByteArrayFromAny(Tcl_Interp *interp, @@ -244,12 +248,12 @@ * over which bytearray values can be useful in the meanwhile. */ static const Tcl_ObjType properByteArrayType = { "bytearray", - FreeByteArrayInternalRep, - DupByteArrayInternalRep, + FreeProperByteArrayInternalRep, + DupProperByteArrayInternalRep, UpdateStringOfByteArray, NULL }; const Tcl_ObjType tclByteArrayType = { @@ -266,31 +270,30 @@ * the byte array to enable growing and shrinking of the ByteArray object with * fewer mallocs. */ typedef struct ByteArray { - int used; /* The number of bytes used in the byte + unsigned int used; /* The number of bytes used in the byte * array. */ - int allocated; /* The amount of space actually allocated + unsigned int allocated; /* The amount of space actually allocated * minus 1 byte. */ unsigned char bytes[1]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ ((unsigned) (TclOffset(ByteArray, bytes) + (len))) -#define GET_BYTEARRAY(objPtr) \ - ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_BYTEARRAY(objPtr, baPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) +#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) +#define SET_BYTEARRAY(irPtr, baPtr) \ + (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) int TclIsPureByteArray( Tcl_Obj * objPtr) { - return (objPtr->typePtr == &properByteArrayType); + return (NULL != Tcl_FetchIntRep(objPtr, &properByteArrayType)); } /* *---------------------------------------------------------------------- * @@ -401,15 +404,15 @@ value. May be NULL even if length > 0. */ int length) /* Length of the array of bytes, which must be >= 0. */ { ByteArray *byteArrayPtr; + Tcl_ObjIntRep ir; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); } - TclFreeIntRep(objPtr); TclInvalidateStringRep(objPtr); if (length < 0) { length = 0; } @@ -418,12 +421,13 @@ byteArrayPtr->allocated = length; if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &properByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(&ir, byteArrayPtr); + + Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir); } /* *---------------------------------------------------------------------- * @@ -447,21 +451,28 @@ Tcl_Obj *objPtr, /* The ByteArray object. */ int *lengthPtr) /* If non-NULL, filled with length of the * array of bytes in the ByteArray object. */ { ByteArray *baPtr; + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + } + } } - baPtr = GET_BYTEARRAY(objPtr); + baPtr = GET_BYTEARRAY(irPtr); if (lengthPtr != NULL) { *lengthPtr = baPtr->used; } - return (unsigned char *) baPtr->bytes; + return baPtr->bytes; } /* *---------------------------------------------------------------------- * @@ -488,27 +499,40 @@ Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr; + unsigned newLength; + Tcl_ObjIntRep *irPtr; + + assert(length >= 0); + newLength = (unsigned int)length; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + } + } } - byteArrayPtr = GET_BYTEARRAY(objPtr); - if (length > byteArrayPtr->allocated) { - byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); - byteArrayPtr->allocated = length; - SET_BYTEARRAY(objPtr, byteArrayPtr); + byteArrayPtr = GET_BYTEARRAY(irPtr); + if (newLength > byteArrayPtr->allocated) { + byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); + byteArrayPtr->allocated = newLength; + SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - byteArrayPtr->used = length; + byteArrayPtr->used = newLength; return byteArrayPtr->bytes; } /* *---------------------------------------------------------------------- @@ -534,36 +558,37 @@ size_t length; int improper = 0; const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; - Tcl_UniChar ch = 0; + Tcl_ObjIntRep ir; - if (objPtr->typePtr == &properByteArrayType) { + if (Tcl_FetchIntRep(objPtr, &properByteArrayType)) { return TCL_OK; } - if (objPtr->typePtr == &tclByteArrayType) { + if (Tcl_FetchIntRep(objPtr, &tclByteArrayType)) { return TCL_OK; } src = TclGetString(objPtr); length = objPtr->length; srcEnd = src + length; byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + Tcl_UniChar ch = 0; src += TclUtfToUniChar(src, &ch); improper = improper || (ch > 255); *dst++ = UCHAR(ch); } byteArrayPtr->used = dst - byteArrayPtr->bytes; byteArrayPtr->allocated = length; - TclFreeIntRep(objPtr); - objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(&ir, byteArrayPtr); + Tcl_StoreIntRep(objPtr, + improper ? &tclByteArrayType : &properByteArrayType, &ir); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -584,12 +609,18 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_BYTEARRAY(objPtr)); - objPtr->typePtr = NULL; + ckfree(GET_BYTEARRAY(Tcl_FetchIntRep(objPtr, &tclByteArrayType))); +} + +static void +FreeProperByteArrayInternalRep( + Tcl_Obj *objPtr) /* Object with internal rep to free. */ +{ + ckfree(GET_BYTEARRAY(Tcl_FetchIntRep(objPtr, &properByteArrayType))); } /* *---------------------------------------------------------------------- * @@ -610,87 +641,98 @@ static void DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - int length; + unsigned int length; + ByteArray *srcArrayPtr, *copyArrayPtr; + Tcl_ObjIntRep ir; + + srcArrayPtr = GET_BYTEARRAY(Tcl_FetchIntRep(srcPtr, &tclByteArrayType)); + length = srcArrayPtr->used; + + copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr->used = length; + copyArrayPtr->allocated = length; + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); + + SET_BYTEARRAY(&ir, copyArrayPtr); + Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir); +} + +static void +DupProperByteArrayInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ +{ + unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; + Tcl_ObjIntRep ir; - srcArrayPtr = GET_BYTEARRAY(srcPtr); + srcArrayPtr = GET_BYTEARRAY(Tcl_FetchIntRep(srcPtr, &properByteArrayType)); length = srcArrayPtr->used; copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); - SET_BYTEARRAY(copyPtr, copyArrayPtr); - copyPtr->typePtr = srcPtr->typePtr; + SET_BYTEARRAY(&ir, copyArrayPtr); + Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir); } /* *---------------------------------------------------------------------- * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. Note: - * This procedure does not invalidate an existing old string rep so - * storage will be lost if this has not already been done. + * Update the string representation for a ByteArray data object. * * Results: * None. * * Side effects: * The object's string is set to a valid string that results from the * ByteArray-to-string conversion. * - * The object becomes a string object -- the internal rep is discarded - * and the typePtr becomes NULL. - * *---------------------------------------------------------------------- */ static void UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - int i, length, size; - unsigned char *src; - char *dst; - ByteArray *byteArrayPtr; - - byteArrayPtr = GET_BYTEARRAY(objPtr); - src = byteArrayPtr->bytes; - length = byteArrayPtr->used; + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); + unsigned char *src = byteArrayPtr->bytes; + unsigned int i, length = byteArrayPtr->used; + unsigned int size = length; /* * How much space will string rep need? */ - size = length; - for (i = 0; i < length && size >= 0; i++) { + for (i = 0; i < length && size <= INT_MAX; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } - if (size < 0) { + if (size > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - dst = ckalloc(size + 1); - objPtr->bytes = dst; - objPtr->length = size; - if (size == length) { - memcpy(dst, src, (size_t) size); - dst[size] = '\0'; + char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); + TclOOM(dst, size); } else { + char *dst = Tcl_InitStringRep(objPtr, NULL, size); + TclOOM(dst, size); for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } - *dst = '\0'; + (void)Tcl_InitStringRep(objPtr, NULL, size); } } /* *---------------------------------------------------------------------- @@ -716,11 +758,12 @@ Tcl_Obj *objPtr, const unsigned char *bytes, int len) { ByteArray *byteArrayPtr; - int needed; + unsigned int length, needed; + Tcl_ObjIntRep *irPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); } if (len < 0) { @@ -729,38 +772,48 @@ } if (len == 0) { /* Append zero bytes is a no-op. */ return; } - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { - SetByteArrayFromAny(NULL, objPtr); + + length = (unsigned int)len; + + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + } + } } - byteArrayPtr = GET_BYTEARRAY(objPtr); + byteArrayPtr = GET_BYTEARRAY(irPtr); - if (len > INT_MAX - byteArrayPtr->used) { + if (length > INT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - needed = byteArrayPtr->used + len; + needed = byteArrayPtr->used + length; /* * If we need to, resize the allocated space in the byte array. */ if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - int attempt; + unsigned int attempt; if (needed <= INT_MAX/2) { /* Try to allocate double the total space that is needed. */ attempt = 2 * needed; ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { /* Try to allocate double the increment that is needed (plus). */ unsigned int limit = INT_MAX - needed; - unsigned int extra = len + TCL_MIN_GROWTH; + unsigned int extra = length + TCL_MIN_GROWTH; int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } @@ -769,17 +822,17 @@ attempt = needed; ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(irPtr, byteArrayPtr); } if (bytes) { - memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); + memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length); } - byteArrayPtr->used += len; + byteArrayPtr->used += length; TclInvalidateStringRep(objPtr); } /* *---------------------------------------------------------------------- @@ -1977,14 +2030,15 @@ * returns TCL_ERROR for NaN, but we can check by comparing the * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(src, &tclDoubleType); + if (irPtr == NULL) { return TCL_ERROR; } - dvalue = src->internalRep.doubleValue; + dvalue = irPtr->doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); return TCL_OK; @@ -1996,14 +2050,15 @@ * returns TCL_ERROR for NaN, but we can check by comparing the * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(src, &tclDoubleType); + if (irPtr == NULL) { return TCL_ERROR; } - dvalue = src->internalRep.doubleValue; + dvalue = irPtr->doubleValue; } /* * Because some compilers will generate floating point exceptions on * an overflow cast (e.g. Borland), we restrict the values to the Index: generic/tclClock.c ================================================================== --- generic/tclClock.c +++ generic/tclClock.c @@ -450,11 +450,11 @@ /* * fields.seconds could be an unsigned number that overflowed. Make sure * that it isn't. */ - if (objv[1]->typePtr == &tclBignumType) { + if (Tcl_FetchIntRep(objv[1], &tclBignumType)) { Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } /* Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -541,13 +541,13 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; - const char *name; + const char *name, *bytes; Proc *procPtr; - Tcl_Obj *bodyPtr, *resultPtr; + int numBytes; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } @@ -568,22 +568,12 @@ * compiler/engine subsystem, we now always return a copy of the string * rep. It is important to return a copy so that later manipulations of * the object do not invalidate the internal rep. */ - bodyPtr = procPtr->bodyPtr; - if (bodyPtr->bytes == NULL) { - /* - * The string rep might not be valid if the procedure has never been - * run before. [Bug #545644] - */ - - TclGetString(bodyPtr); - } - resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); - - Tcl_SetObjResult(interp, resultPtr); + bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes); + Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2943,11 +2933,11 @@ Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = strcmp; + SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", @@ -4261,11 +4251,11 @@ * "lsort" command. */ { int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->collationKey.strValuePtr, + order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -307,11 +307,11 @@ if (offset == 0) { eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; } @@ -1214,17 +1214,26 @@ */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { + int fullchar; len = TclUtfToUniChar(stringPtr, &ch); + fullchar = ch; + +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(stringPtr, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif /* * Assume Tcl_UniChar is an integral type... */ - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch), + hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(fullchar), &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); /* @@ -1592,16 +1601,16 @@ case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { /* TODO */ - if ((objPtr->typePtr == &tclDoubleType) || - (objPtr->typePtr == &tclIntType) || + if (Tcl_FetchIntRep(objPtr, &tclDoubleType) || + Tcl_FetchIntRep(objPtr, &tclIntType) || #ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || + Tcl_FetchIntRep(objPtr, &tclWideIntType) || #endif - (objPtr->typePtr == &tclBignumType)) { + Tcl_FetchIntRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { @@ -1630,15 +1639,15 @@ if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { break; } goto failedIntParse; case STR_IS_ENTIER: - if ((objPtr->typePtr == &tclIntType) || + if (Tcl_FetchIntRep(objPtr, &tclIntType) || #ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || + Tcl_FetchIntRep(objPtr, &tclWideIntType) || #endif - (objPtr->typePtr == &tclBignumType)) { + Tcl_FetchIntRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { @@ -1812,12 +1821,20 @@ } goto str_is_done; } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { + int fullchar; length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { + fullchar = ch; +#if TCL_UTF_MAX == 4 + if (!length2) { + length2 = TclUtfToUniChar(string1, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + if (!chcomp(fullchar)) { result = 0; break; } } } @@ -1905,11 +1922,12 @@ /* * This test is tricky, but has to be that way or you get other strange * inconsistencies (see test string-10.20.1 for illustration why!) */ - if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ + if (!TclHasStringRep(objv[objc-2]) + && Tcl_FetchIntRep(objv[objc-2], &tclDictType)){ int i, done; Tcl_DictSearch search; /* * We know the type exactly, so all dict operations will succeed for @@ -2600,12 +2618,12 @@ */ string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { + } else if (Tcl_FetchIntRep(objv[0], &tclStringType) + && Tcl_FetchIntRep(objv[1], &tclStringType)) { /* * Do a unicode-specific comparison if both of the args are of String * type. In benchmark testing this proved the most efficient check * between the unicode and string comparison operations. */ @@ -2750,12 +2768,12 @@ */ string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { + } else if (Tcl_FetchIntRep(objv[0], &tclStringType) + && Tcl_FetchIntRep(objv[1], &tclStringType)) { /* * Do a unicode-specific comparison if both of the args are of String * type. In benchmark testing this proved the most efficient check * between the unicode and string comparison operations. */ @@ -3528,11 +3546,11 @@ enum options { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = strcmp; + strCmpFn_t strCmpFn = TclUtfCmp; mode = OPT_EXACT; foundmode = 0; indexVarObj = NULL; matchVarObj = NULL; Index: generic/tclCompExpr.c ================================================================== --- generic/tclCompExpr.c +++ generic/tclCompExpr.c @@ -2474,15 +2474,17 @@ /* * Don't generate a string rep, but if we have one * already, then use it to share via the literal table. */ - if (objPtr->bytes) { + if (TclHasStringRep(objPtr)) { Tcl_Obj *tableValue; + int numBytes; + const char *bytes + = Tcl_GetStringFromObj(objPtr, &numBytes); - index = TclRegisterLiteral(envPtr, objPtr->bytes, - objPtr->length, 0); + index = TclRegisterLiteral(envPtr, bytes, numBytes, 0); tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { /* * Same intrep surgery as for OT_LITERAL. Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -723,17 +723,18 @@ FreeSubstCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ }; +#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 /* * Helper macros. */ #define TclIncrUInt4AtPtr(ptr, delta) \ - TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)); + TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)) /* *---------------------------------------------------------------------- * * TclSetByteCodeFromAny -- @@ -972,11 +973,14 @@ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + assert(codePtr != NULL); TclReleaseByteCode(codePtr); } /* @@ -1302,25 +1306,27 @@ int flags) { Interp *iPtr = (Interp *) interp; ByteCode *codePtr = NULL; - if (objPtr->typePtr == &substCodeType) { + ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + + if (codePtr != NULL) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; - if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) + if (flags != PTR2INT(SubstFlags(objPtr)) || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - TclFreeIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &substCodeType, NULL); + codePtr = NULL; } } - if (objPtr->typePtr != &substCodeType) { + if (codePtr == NULL) { CompileEnv compEnv; int numBytes; const char *bytes = TclGetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ @@ -1330,12 +1336,11 @@ TclEmitOpcode(INST_DONE, &compEnv); codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); TclFreeCompileEnv(&compEnv); - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags); + SubstFlags(objPtr) = INT2PTR(flags); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } #ifdef TCL_COMPILE_DEBUG @@ -1370,11 +1375,14 @@ static void FreeSubstCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + register ByteCode *codePtr; + + ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + assert(codePtr != NULL); TclReleaseByteCode(codePtr); } static void @@ -2910,13 +2918,11 @@ /* * Free the old internal rep then convert the object to a bytecode object * by making its internal rep point to the just compiled ByteCode. */ - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; - objPtr->typePtr = typePtr; + ByteCodeSetIntRep(objPtr, typePtr, codePtr); return codePtr; } /* *---------------------------------------------------------------------- Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -512,10 +512,27 @@ #ifdef TCL_COMPILE_STATS Tcl_Time createTime; /* Absolute time when the ByteCode was * created. */ #endif /* TCL_COMPILE_STATS */ } ByteCode; + +#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (codePtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), (typePtr), &ir); \ + } while (0) + + + +#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), (typePtr)); \ + (codePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) /* * Opcodes for the Tcl bytecode instructions. These must correspond to the * entries in the table of instruction descriptions, tclInstructionTable, in * tclCompile.c. Also, the order and number of the expression opcodes (e.g., Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -667,11 +667,12 @@ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ -EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +TCL_DEPRECATED("") +int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ EXTERN int Tcl_ServiceEvent(int flags); /* 223 */ @@ -739,11 +740,12 @@ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 245 */ EXTERN int Tcl_StringMatch(const char *str, const char *pattern); /* 246 */ -EXTERN int Tcl_TellOld(Tcl_Channel chan); +TCL_DEPRECATED("") +int Tcl_TellOld(Tcl_Channel chan); /* 247 */ EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ @@ -810,14 +812,16 @@ /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ -EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList); /* 268 */ -EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, @@ -836,18 +840,21 @@ /* 274 */ EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact); /* 275 */ -EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList); /* 276 */ -EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +TCL_DEPRECATED("see TIP #422") +int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* 278 */ -EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); +TCL_DEPRECATED("see TIP #422") +TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); /* 280 */ EXTERN void Tcl_InitMemory(Tcl_Interp *interp); @@ -1829,10 +1836,24 @@ EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); +/* 632 */ +EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); +/* 633 */ +EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, + unsigned int numBytes); +/* 634 */ +EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr); +/* 635 */ +EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr, + const Tcl_ObjIntRep *irPtr); +/* 636 */ +EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -2084,11 +2105,11 @@ void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ - int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ + TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */ @@ -2110,11 +2131,11 @@ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ - int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ @@ -2131,22 +2152,22 @@ ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ - void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ - void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ - int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ + TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ + TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */ @@ -2496,10 +2517,15 @@ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ + void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 632 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 633 */ + Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 634 */ + void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 635 */ + int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 636 */ } TclStubs; extern const TclStubs *tclStubsPtr; #ifdef __cplusplus @@ -3790,10 +3816,20 @@ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ #define Tcl_OpenTcpServerEx \ (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ +#define Tcl_FreeIntRep \ + (tclStubsPtr->tcl_FreeIntRep) /* 632 */ +#define Tcl_InitStringRep \ + (tclStubsPtr->tcl_InitStringRep) /* 633 */ +#define Tcl_FetchIntRep \ + (tclStubsPtr->tcl_FetchIntRep) /* 634 */ +#define Tcl_StoreIntRep \ + (tclStubsPtr->tcl_StoreIntRep) /* 635 */ +#define Tcl_HasStringRep \ + (tclStubsPtr->tcl_HasStringRep) /* 636 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ Index: generic/tclDictObj.c ================================================================== --- generic/tclDictObj.c +++ generic/tclDictObj.c @@ -10,10 +10,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" +#include /* * Forward declaration. */ struct Dict; @@ -139,24 +140,17 @@ * created. */ ChainEntry *entryChainTail; /* Other end of linked list of all entries in * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - int epoch; /* Epoch counter */ + unsigned int epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested * dictionaries. */ } Dict; -/* - * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this - * must be assignable as well as readable. - */ - -#define DICT(dictObj) (*((Dict **)&(dictObj)->internalRep.twoPtrValue.ptr1)) - /* * The structure below defines the dictionary object type by means of * functions that can be invoked by generic object code. */ @@ -165,10 +159,25 @@ FreeDictInternalRep, /* freeIntRepProc */ DupDictInternalRep, /* dupIntRepProc */ UpdateStringOfDict, /* updateStringProc */ SetDictFromAny /* setFromAnyProc */ }; + +#define DictSetIntRep(objPtr, dictRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (dictRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \ + } while (0) + +#define DictGetIntRep(objPtr, dictRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclDictType); \ + (dictRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) /* * The type of the specially adapted version of the Tcl_Obj*-containing hash * table defined in the tclObj.c code. This version differs in that it * allocates a bit more space in each hash entry in order to hold the pointers @@ -361,13 +370,14 @@ static void DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = DICT(srcPtr); - Dict *newDict = ckalloc(sizeof(Dict)); + Dict *oldDict, *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; + + DictGetIntRep(srcPtr, oldDict); /* * Copy values across from the old hash table. */ @@ -388,21 +398,19 @@ /* * Initialise other fields. */ - newDict->epoch = 0; + newDict->epoch = 1; newDict->chain = NULL; newDict->refCount = 1; /* * Store in the object. */ - DICT(copyPtr) = newDict; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclDictType; + DictSetIntRep(copyPtr, newDict); } /* *---------------------------------------------------------------------- * @@ -423,16 +431,17 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = DICT(dictPtr); + Dict *dict; + + DictGetIntRep(dictPtr, dict); if (dict->refCount-- <= 1) { DeleteDict(dict); } - dictPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -485,44 +494,46 @@ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = DICT(dictPtr); +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; + Dict *dict; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; const char *elem; char *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * This field is the most useful one in the whole hash structure, and it * is not exposed by any API function... */ - int numElems = dict->table.numEntries * 2; + int numElems; + + DictGetIntRep(dictPtr, dict); + + assert (dict != NULL); + + numElems = dict->table.numEntries * 2; /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - dictPtr->bytes = &tclEmptyString; - dictPtr->length = 0; + Tcl_InitStringRep(dictPtr, NULL, 0); return; } /* * Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (numElems > maxFlags) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; inextPtr) { /* * Assume that cPtr is never NULL since we know the number of array * elements already. @@ -551,13 +562,12 @@ /* * Pass 2: copy into string rep buffer. */ - dictPtr->length = bytesNeeded - 1; - dictPtr->bytes = ckalloc(bytesNeeded); - dst = dictPtr->bytes; + dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); + TclOOM(dst, bytesNeeded); for (i=0,cPtr=dict->entryChainHead; inextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); @@ -567,11 +577,11 @@ valuePtr = Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } - dictPtr->bytes[dictPtr->length] = '\0'; + (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); if (flagPtr != localFlags) { ckfree(flagPtr); } } @@ -611,11 +621,11 @@ * Since lists and dictionaries have very closely-related string * representations (i.e. the same parsing code) we can safely special-case * the conversion from lists to dictionaries. */ - if (objPtr->typePtr == &tclListType) { + if (Tcl_FetchIntRep(objPtr, &tclListType)) { int objc, i; Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -666,14 +676,18 @@ if (literal) { TclNewStringObj(keyPtr, elemStart, elemSize); } else { /* Avoid double copy */ + char *dst; + TclNewObj(keyPtr); - keyPtr->bytes = ckalloc((unsigned) elemSize + 1); - keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, - keyPtr->bytes); + Tcl_InvalidateStringRep(keyPtr); + dst = Tcl_InitStringRep(keyPtr, NULL, elemSize); + TclOOM(dst, elemSize); /* Consider error */ + (void)Tcl_InitStringRep(keyPtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, dst)); } if (TclFindDictElement(interp, nextElem, (limit - nextElem), &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { TclDecrRefCount(keyPtr); @@ -682,14 +696,18 @@ if (literal) { TclNewStringObj(valuePtr, elemStart, elemSize); } else { /* Avoid double copy */ + char *dst; + TclNewObj(valuePtr); - valuePtr->bytes = ckalloc((unsigned) elemSize + 1); - valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, - valuePtr->bytes); + Tcl_InvalidateStringRep(valuePtr); + dst = Tcl_InitStringRep(valuePtr, NULL, elemSize); + TclOOM(dst, elemSize); /* Consider error */ + (void)Tcl_InitStringRep(valuePtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, dst)); } /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, keyPtr, &isNew); if (!isNew) { @@ -707,17 +725,14 @@ * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ - TclFreeIntRep(objPtr); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(objPtr) = dict; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclDictType; + DictSetIntRep(objPtr, dict); return TCL_OK; missingValue: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -727,10 +742,27 @@ errorInFindDictElement: DeleteChainTable(dict); ckfree(dict); return TCL_ERROR; } + +static Dict * +GetDictFromObj( + Tcl_Interp *interp, + Tcl_Obj *dictPtr) +{ + Dict *dict; + + DictGetIntRep(dictPtr, dict); + if (dict == NULL) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + DictGetIntRep(dictPtr, dict); + } + return dict; +} /* *---------------------------------------------------------------------- * * TclTraceDictPath -- @@ -771,15 +803,17 @@ int flags) { Dict *dict, *newDict; int i; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; + DictGetIntRep(dictPtr, dict); + if (dict == NULL) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + DictGetIntRep(dictPtr, dict); } - dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } for (i=0 ; itypePtr != &tclDictType - && SetDictFromAny(interp, tmpObj) != TCL_OK) { - return NULL; + + DictGetIntRep(tmpObj, newDict); + + if (newDict == NULL) { + if (SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; + } } } - newDict = DICT(tmpObj); + DictGetIntRep(tmpObj, newDict); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); tmpObj = Tcl_DuplicateObj(tmpObj); Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = DICT(tmpObj); + DictGetIntRep(tmpObj, newDict); } newDict->chain = dictPtr; } dict = newDict; @@ -860,21 +898,28 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = DICT(dictObj); + Dict *dict; + + DictGetIntRep(dictObj, dict); + assert( dict != NULL); do { + dict->refCount++; TclInvalidateStringRep(dictObj); + TclFreeIntRep(dictObj); + DictSetIntRep(dictObj, dict); + dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; - dict = DICT(dictObj); + DictGetIntRep(dictObj, dict); } while (dict != NULL); } /* *---------------------------------------------------------------------- @@ -908,20 +953,20 @@ if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } - dict = DICT(dictPtr); + TclInvalidateStringRep(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); + dict->refCount++; + TclFreeIntRep(dictPtr) + DictSetIntRep(dictPtr, dict); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); @@ -959,17 +1004,16 @@ Tcl_Obj **valuePtrPtr) { Dict *dict; Tcl_HashEntry *hPtr; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { *valuePtrPtr = NULL; return TCL_ERROR; } - dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; } else { *valuePtrPtr = Tcl_GetHashValue(hPtr); @@ -1006,20 +1050,17 @@ if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); dict->epoch++; } return TCL_OK; } @@ -1047,16 +1088,15 @@ Tcl_Obj *dictPtr, int *sizePtr) { Dict *dict; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } /* @@ -1099,19 +1139,18 @@ * otherwise. */ { Dict *dict; ChainEntry *cPtr; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { - searchPtr->epoch = -1; + searchPtr->epoch = 0; *donePtr = 1; } else { *donePtr = 0; searchPtr->dictionaryPtr = (Tcl_Dict) dict; searchPtr->epoch = dict->epoch; @@ -1168,11 +1207,11 @@ /* * If the searh is done; we do no work. */ - if (searchPtr->epoch == -1) { + if (!searchPtr->epoch) { *donePtr = 1; return; } /* @@ -1225,12 +1264,12 @@ Tcl_DictObjDone( Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; - if (searchPtr->epoch != -1) { - searchPtr->epoch = -1; + if (searchPtr->epoch) { + searchPtr->epoch = 0; dict = (Dict *) searchPtr->dictionaryPtr; if (dict->refCount-- <= 1) { DeleteDict(dict); } } @@ -1278,11 +1317,12 @@ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); if (dictPtr == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); + DictGetIntRep(dictPtr, dict); + assert(dict != NULL); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); @@ -1335,11 +1375,12 @@ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); if (dictPtr == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); + DictGetIntRep(dictPtr, dict); + assert(dict != NULL); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; } @@ -1378,16 +1419,14 @@ TclNewObj(dictPtr); TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(dictPtr) = dict; - dictPtr->internalRep.twoPtrValue.ptr2 = NULL; - dictPtr->typePtr = &tclDictType; + DictSetIntRep(dictPtr, dict); return dictPtr; #endif } /* @@ -1428,16 +1467,14 @@ TclDbNewObj(dictPtr, file, line); TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(dictPtr) = dict; - dictPtr->internalRep.twoPtrValue.ptr2 = NULL; - dictPtr->typePtr = &tclDictType; + DictSetIntRep(dictPtr, dict); return dictPtr; #else /* !TCL_MEM_DEBUG */ return Tcl_NewDictObj(); #endif } @@ -1619,20 +1656,17 @@ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?"); return TCL_ERROR; } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + if (GetDictFromObj(interp, dictPtr) == NULL) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); for (i=2 ; itypePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + if (GetDictFromObj(interp, dictPtr) == NULL) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); for (i=2 ; itypePtr != &tclDictType - && SetDictFromAny(interp, targetObj) != TCL_OK) { + if (GetDictFromObj(interp, targetObj) == NULL) { return TCL_ERROR; } if (objc == 2) { /* @@ -1814,12 +1844,11 @@ * A direct check that we have a dictionary. We don't start the iteration * yet because that might allocate memory or set locks that we do not * need. [Bug 1705778, leak K04] */ - if (objv[1]->typePtr != &tclDictType - && SetDictFromAny(interp, objv[1]) != TCL_OK) { + if (GetDictFromObj(interp, objv[1]) == NULL) { return TCL_ERROR; } if (objc == 3) { pattern = TclGetString(objv[2]); @@ -2022,25 +2051,22 @@ ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { - Tcl_Obj *dictPtr; Dict *dict; char *statsStr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); return TCL_ERROR; } - dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, objv[1]); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); ckfree(statsStr); return TCL_OK; @@ -2097,16 +2123,15 @@ /* * A little internals surgery to avoid copying a string rep that will * soon be no good. */ - char *saved = dictPtr->bytes; Tcl_Obj *oldPtr = dictPtr; - dictPtr->bytes = NULL; - dictPtr = Tcl_DuplicateObj(dictPtr); - oldPtr->bytes = saved; + TclNewObj(dictPtr); + TclInvalidateStringRep(dictPtr); + DupDictInternalRep(oldPtr, dictPtr); } if (valuePtr == NULL) { /* * Key not in dictionary. Create new key with increment as value. */ @@ -2239,11 +2264,11 @@ } } if (allocatedValue) { Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); - } else if (dictPtr->bytes != NULL) { + } else { TclInvalidateStringRep(dictPtr); } resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); Index: generic/tclDisassemble.c ================================================================== --- generic/tclDisassemble.c +++ generic/tclDisassemble.c @@ -36,24 +36,33 @@ /* * The structure below defines an instruction name Tcl object to allow * reporting of inner contexts in errorstack without string allocation. */ -static const Tcl_ObjType tclInstNameType = { +static const Tcl_ObjType instNameType = { "instname", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ }; -/* - * How to get the bytecode out of a Tcl_Obj. - */ +#define InstNameSetIntRep(objPtr, inst) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.longValue = (inst); \ + Tcl_StoreIntRep((objPtr), &instNameType, &ir); \ + } while (0) -#define BYTECODE(objPtr) \ - ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) +#define InstNameGetIntRep(objPtr, inst) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &instNameType); \ + assert(irPtr != NULL); \ + (inst) = irPtr->longValue; \ + } while (0) + /* *---------------------------------------------------------------------- * * GetLocationInformation -- @@ -243,17 +252,21 @@ static Tcl_Obj * DisassembleByteCodeObj( Tcl_Interp *interp, Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr = BYTECODE(objPtr); + ByteCode *codePtr; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; - Interp *iPtr = (Interp *) *codePtr->interpHandle; + Interp *iPtr; Tcl_Obj *bufferObj, *fileObj; + + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + + iPtr = (Interp *) *codePtr->interpHandle; TclNewObj(bufferObj); if (codePtr->refCount <= 0) { return bufferObj; /* Already freed. */ } @@ -794,13 +807,12 @@ TclNewInstNameObj( unsigned char inst) { Tcl_Obj *objPtr = Tcl_NewObj(); - objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; - objPtr->bytes = NULL; + TclInvalidateStringRep(objPtr); + InstNameSetIntRep(objPtr, (long) inst); return objPtr; } /* @@ -815,24 +827,26 @@ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { - int inst = objPtr->internalRep.longValue; - char *s, buf[20]; - int len; + int inst; + char *dst; + + InstNameGetIntRep(objPtr, inst); if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - sprintf(buf, "inst_%d", inst); - s = buf; + dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); + TclOOM(dst, TCL_INTEGER_SPACE + 5); + sprintf(dst, "inst_%d", inst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + const char *s = tclInstructionTable[inst].name; + int len = strlen(s); + dst = Tcl_InitStringRep(objPtr, s, len); + TclOOM(dst, len); } - len = strlen(s); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, s, len + 1); - objPtr->length = len; } /* *---------------------------------------------------------------------- * @@ -940,16 +954,18 @@ DisassembleByteCodeAsDicts( Tcl_Interp *interp, /* Used for looking up the CmdFrame for the * procedure, if one exists. */ Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ { - ByteCode *codePtr = BYTECODE(objPtr); + ByteCode *codePtr; Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; int codeOffset, codeLength, sourceOffset, sourceLength; int i, val, line; + + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); /* * Get the literals from the bytecode. */ @@ -1284,10 +1300,11 @@ int idx, result; Tcl_Obj *codeObjPtr = NULL; Proc *procPtr = NULL; Tcl_HashEntry *hPtr; Object *oPtr; + ByteCode *codePtr; Method *methodPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "type ..."); return TCL_ERROR; @@ -1302,31 +1319,23 @@ Tcl_Obj *nsObjPtr; Tcl_Namespace *nsPtr; /* * Compile (if uncompiled) and disassemble a lambda term. - * - * WARNING! Pokes inside the lambda objtype. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); return TCL_ERROR; } - if (objv[2]->typePtr == &tclLambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = tclLambdaType.setFromAnyProc(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + + procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr); + if (procPtr == NULL) { + return TCL_ERROR; } memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return result; } cmd.nsPtr = (Namespace *) nsPtr; @@ -1372,12 +1381,13 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "script"); return TCL_ERROR; } - if ((objv[2]->typePtr != &tclByteCodeType) - && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + + if ((NULL == Tcl_FetchIntRep(objv[2], &tclByteCodeType)) && (TCL_OK + != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) { return TCL_ERROR; } codeObjPtr = objv[2]; break; @@ -1573,11 +1583,11 @@ "body not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "METHODTYPE", NULL); return TCL_ERROR; } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + if (NULL == Tcl_FetchIntRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* * Yes, this is ugly, but we need to pass the namespace in to the * compiler in two places. @@ -1601,11 +1611,13 @@ /* * Do the actual disassembly. */ - if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) { + ByteCodeGetIntRep(codeObjPtr, &tclByteCodeType, codePtr); + + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; Index: generic/tclEncoding.c ================================================================== --- generic/tclEncoding.c +++ generic/tclEncoding.c @@ -16,11 +16,11 @@ /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. */ -typedef struct Encoding { +typedef struct { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, * (2) string passed in the Tcl_EncodingType * structure may not be persistent. */ @@ -55,11 +55,11 @@ * table-driven encoding created by LoadTableEncoding(). It maps between * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) * encoding. */ -typedef struct TableEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ char prefixBytes[256]; /* If a byte in the input stream is a lead * byte for a 2-byte sequence, the @@ -89,20 +89,20 @@ * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" * does not necessarily mean that the ESCAPE character is the character used * for switching character sets. */ -typedef struct EscapeSubTable { +typedef struct { unsigned sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ Encoding *encodingPtr; /* Encoding loaded using above name, or NULL * if this sub-encoding has not been needed * yet. */ } EscapeSubTable; -typedef struct EscapeEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ unsigned initLen; /* Length of following string. */ char init[16]; /* String to emit or expect before first char @@ -277,10 +277,25 @@ */ static const Tcl_ObjType encodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; +#define EncodingSetIntRep(objPtr, encoding) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (encoding); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &encodingType, &ir); \ + } while (0) + +#define EncodingGetIntRep(objPtr, encoding) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep ((objPtr), &encodingType); \ + (encoding) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- * * Tcl_GetEncodingFromObj -- @@ -303,21 +318,20 @@ Tcl_GetEncodingFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr) { + Tcl_Encoding encoding; const char *name = TclGetString(objPtr); - if (objPtr->typePtr != &encodingType) { - Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); - + EncodingGetIntRep(objPtr, encoding); + if (encoding == NULL) { + encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = encoding; - objPtr->typePtr = &encodingType; + EncodingSetIntRep(objPtr, encoding); } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; } @@ -333,12 +347,14 @@ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { - Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1); - objPtr->typePtr = NULL; + Tcl_Encoding encoding; + + EncodingGetIntRep(objPtr, encoding); + Tcl_FreeEncoding(encoding); } /* *---------------------------------------------------------------------- * @@ -352,12 +368,12 @@ static void DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); - dupPtr->typePtr = &encodingType; + Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr)); + EncodingSetIntRep(dupPtr, encoding); } /* *---------------------------------------------------------------------- * Index: generic/tclEnsemble.c ================================================================== --- generic/tclEnsemble.c +++ generic/tclEnsemble.c @@ -84,10 +84,25 @@ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; +#define ECRSetIntRep(objPtr, ecRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (ecRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \ + } while (0) + +#define ECRGetIntRep(objPtr, ecRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &ensembleCmdType); \ + (ecRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The internal rep for caching ensemble subcommand lookups and * spell corrections. */ @@ -144,14 +159,16 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; - Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, + *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; Tcl_Command token; Tcl_DictSearch search; Tcl_Obj *listObj; + const char *simpleName; int index, done; if (nsPtr == NULL || nsPtr->flags & NS_DYING) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -193,17 +210,12 @@ return TCL_ERROR; } objv += 2; objc -= 2; - /* - * Work out what name to use for the command to create. If supplied, - * it is either fully specified or relative to the current namespace. - * If not supplied, it is exactly the name of the current namespace. - */ - - name = nsPtr->fullName; + name = nsPtr->name; + cxtPtr = (Namespace *) nsPtr->parentPtr; /* * Parse the option list, applying type checks as we go. Note that we * are not incrementing any reference counts in the objects at this * stage, so the presence of an option multiple times won't cause any @@ -219,10 +231,11 @@ return TCL_ERROR; } switch ((enum EnsCreateOpts) index) { case CRT_CMD: name = TclGetString(objv[1]); + cxtPtr = nsPtr; continue; case CRT_SUBCMDS: if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); @@ -335,19 +348,24 @@ unknownObj = (len > 0 ? objv[1] : NULL); continue; } } + TclGetNamespaceForQualName(interp, name, cxtPtr, + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr, + &simpleName); + /* * Create the ensemble. Note that this might delete another ensemble * linked to the same namespace, so we must be careful. However, we * should be OK because we only link the namespace into the list once * we've created it (and after any deletions have occurred.) */ - token = Tcl_CreateEnsemble(interp, name, NULL, - (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + token = TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); Tcl_SetEnsembleParameterList(interp, token, paramObj); @@ -634,52 +652,42 @@ } /* *---------------------------------------------------------------------- * - * Tcl_CreateEnsemble -- - * - * Create a simple ensemble attached to the given namespace. - * - * Results: - * The token for the command created. - * - * Side effects: - * The ensemble is created and marked for compilation. + * TclCreateEnsembleInNs -- + * + * Like Tcl_CreateEnsemble, but additionally accepts as an argument the + * name of the namespace to create the command in. * *---------------------------------------------------------------------- */ Tcl_Command -Tcl_CreateEnsemble( +TclCreateEnsembleInNs( Tcl_Interp *interp, - const char *name, - Tcl_Namespace *namespacePtr, - int flags) -{ - Namespace *nsPtr = (Namespace *) namespacePtr; - EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig)); - Tcl_Obj *nameObj = NULL; - - if (nsPtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } - - /* - * Make the name of the ensemble into a fully qualified name. This might - * allocate a temporary object. - */ - - if (!(name[0] == ':' && name[1] == ':')) { - nameObj = NewNsObj((Tcl_Namespace *) nsPtr); - if (nsPtr->parentPtr == NULL) { - Tcl_AppendStringsToObj(nameObj, name, NULL); - } else { - Tcl_AppendStringsToObj(nameObj, "::", name, NULL); - } - Tcl_IncrRefCount(nameObj); - name = TclGetString(nameObj); + + const char *name, /* Simple name of command to create (no */ + /* namespace components). */ + Tcl_Namespace /* Name of namespace to create the command in. */ + *nameNsPtr, + Tcl_Namespace + *ensembleNsPtr, /* Name of the namespace for the ensemble. */ + int flags + ) +{ + Namespace *nsPtr = (Namespace *) ensembleNsPtr; + EnsembleConfig *ensemblePtr; + Tcl_Command token; + + ensemblePtr = ckalloc(sizeof(EnsembleConfig)); + token = TclNRCreateCommandInNs(interp, name, + (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd, + NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); + if (token == NULL) { + ckfree(ensemblePtr); + return NULL; } ensemblePtr->nsPtr = nsPtr; ensemblePtr->epoch = 0; Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); @@ -688,13 +696,11 @@ ensemblePtr->subcommandDict = NULL; ensemblePtr->flags = flags; ensemblePtr->numParameters = 0; ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = Tcl_NRCreateCommand(interp, name, - NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, - ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->token = token; ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; /* * Trigger an eventual recomputation of the ensemble command set. Note @@ -707,15 +713,56 @@ if (flags & ENSEMBLE_COMPILE) { ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; } - if (nameObj != NULL) { - TclDecrRefCount(nameObj); - } return ensemblePtr->token; + +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEnsemble + * + * Create a simple ensemble attached to the given namespace. + * + * Deprecated by TclCreateEnsembleInNs. + * + * Value + * + * The token for the command created. + * + * Effect + * The ensemble is created and marked for compilation. + * + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *namespacePtr, + int flags) +{ + Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr, + *actualNsPtr; + const char * simpleName; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, + &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); + return TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); } + /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleSubcommandList -- @@ -1715,14 +1762,14 @@ * Table of subcommands is still valid; therefore there might be a * valid cache of discovered information which we can reuse. Do the * check here, and if we're still valid, we can jump straight to the * part where we do the invocation of the subcommand. */ + EnsembleCmdRep *ensembleCmd; - if (subObj->typePtr==&ensembleCmdType){ - EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; - + ECRGetIntRep(subObj, ensembleCmd); + if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == (Command *)ensemblePtr->token) { prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); Tcl_IncrRefCount(prefixObj); if (ensembleCmd->fix) { @@ -1883,10 +1930,11 @@ * Hand off to the target command. */ TclSkipTailcall(interp); Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: /* @@ -2344,12 +2392,12 @@ Tcl_HashEntry *hPtr, Tcl_Obj *fix) { register EnsembleCmdRep *ensembleCmd; - if (objPtr->typePtr == &ensembleCmdType) { - ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + ECRGetIntRep(objPtr, ensembleCmd); + if (ensembleCmd) { TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } } else { @@ -2356,14 +2404,12 @@ /* * Kill the old internal rep, and replace it with a brand new one of * our own. */ - TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); - objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; - objPtr->typePtr = &ensembleCmdType; + ECRSetIntRep(objPtr, ensembleCmd); } /* * Populate the internal rep. */ @@ -2395,19 +2441,37 @@ * Side effects: * Memory is (eventually) deallocated. * *---------------------------------------------------------------------- */ + +static void +ClearTable( + EnsembleConfig *ensemblePtr) +{ + Tcl_HashTable *hash = &ensemblePtr->subcommandTable; + + if (hash->numEntries != 0) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); + + while (hPtr != NULL) { + Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + ckfree((char *) ensemblePtr->subcommandArrayPtr); + } + Tcl_DeleteHashTable(hash); +} static void DeleteEnsembleConfig( ClientData clientData) { EnsembleConfig *ensemblePtr = clientData; Namespace *nsPtr = ensemblePtr->nsPtr; - Tcl_HashSearch search; - Tcl_HashEntry *hEnt; /* * Unlink from the ensemble chain if it has not been marked as having been * done already. */ @@ -2437,21 +2501,11 @@ /* * Kill the pointer-containing fields. */ - if (ensemblePtr->subcommandTable.numEntries != 0) { - ckfree(ensemblePtr->subcommandArrayPtr); - } - hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); - while (hEnt != NULL) { - Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt); - - Tcl_DecrRefCount(prefixObj); - hEnt = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&ensemblePtr->subcommandTable); + ClearTable(ensemblePtr); if (ensemblePtr->subcmdList != NULL) { Tcl_DecrRefCount(ensemblePtr->subcmdList); } if (ensemblePtr->parameterList != NULL) { Tcl_DecrRefCount(ensemblePtr->parameterList); @@ -2503,104 +2557,105 @@ * the namespace that backs up this * ensemble. */ int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; - - if (hash->numEntries != 0) { - /* - * Remove pre-existing table. - */ - - ckfree(ensemblePtr->subcommandArrayPtr); - hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); - - Tcl_DecrRefCount(prefixObj); - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(hash); - Tcl_InitHashTable(hash, TCL_STRING_KEYS); - } - - /* - * See if we've got an export list. If so, we will only export exactly - * those commands, which may be either implemented by the prefix in the - * subcommandDict or mapped directly onto the namespace's commands. - */ - - if (ensemblePtr->subcmdList != NULL) { - Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; - int subcmdc; - - TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, - &subcmdv); - for (i=0 ; isubcommandDict != NULL) { - Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], - &target); - if (target != NULL) { - Tcl_SetHashValue(hPtr, target); - Tcl_IncrRefCount(target); - continue; - } - } - - /* - * Not there, so map onto the namespace. Note in this case that we - * do not guarantee that the command is actually there; that is - * the programmer's responsibility (or [::unknown] of course). - */ - - cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr); - if (ensemblePtr->nsPtr->parentPtr != NULL) { - Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); - } else { - Tcl_AppendStringsToObj(cmdObj, name, NULL); - } - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } else if (ensemblePtr->subcommandDict != NULL) { - /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. - */ - - Tcl_DictSearch dictSearch; - Tcl_Obj *keyObj, *valueObj; - int done; - - Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, - &keyObj, &valueObj, &done); - while (!done) { - const char *name = TclGetString(keyObj); - - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - Tcl_SetHashValue(hPtr, valueObj); - Tcl_IncrRefCount(valueObj); - Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); - } + Tcl_Obj *mapDict = ensemblePtr->subcommandDict; + Tcl_Obj *subList = ensemblePtr->subcmdList; + + ClearTable(ensemblePtr); + Tcl_InitHashTable(hash, TCL_STRING_KEYS); + + if (subList) { + int subc; + Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; + char *name; + + /* + * There is a list of exactly what subcommands go in the table. + * Must determine the target for each. + */ + + Tcl_ListObjGetElements(NULL, subList, &subc, &subv); + if (subList == mapDict) { + /* + * Strange case where explicit list of subcommands is same value + * as the dict mapping to targets. + */ + + for (i = 0; i < subc; i += 2) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(cmdObj); + } + Tcl_SetHashValue(hPtr, subv[i+1]); + Tcl_IncrRefCount(subv[i+1]); + + name = TclGetString(subv[i+1]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (isNew) { + cmdObj = Tcl_NewStringObj(name, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else { + /* Usual case where we can freely act on the list and dict. */ + + for (i = 0; i < subc; i++) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + continue; + } + + /* Lookup target in the dictionary */ + if (mapDict) { + Tcl_DictObjGet(NULL, mapDict, subv[i], &target); + if (target) { + Tcl_SetHashValue(hPtr, target); + Tcl_IncrRefCount(target); + continue; + } + } + + /* + * target was not in the dictionary so map onto the namespace. + * Note in this case that we do not guarantee that the + * command is actually there; that is the programmer's + * responsibility (or [::unknown] of course). + */ + cmdObj = Tcl_NewStringObj(name, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else if (mapDict) { + /* + * No subcmd list, but we do have a mapping dictionary so we should + * use the keys of that. Convert the dictionary's contents into the + * form required for the ensemble's internal hashtable. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } } else { /* * Discover what commands are actually exported by the namespace. * What we have is an array of patterns and a hash table whose keys * are the command names exported by the namespace (the contents do @@ -2632,15 +2687,11 @@ */ if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; - TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, - ensemblePtr->nsPtr->fullName, - (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); + cmdObj = Tcl_NewStringObj(nsCmdName, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } break; @@ -2752,18 +2803,18 @@ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCmd; + ECRGetIntRep(objPtr, ensembleCmd); TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } ckfree(ensembleCmd); - objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -2785,15 +2836,16 @@ static void DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCmd; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); - copyPtr->typePtr = &ensembleCmdType; - copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; + ECRGetIntRep(objPtr, ensembleCmd); + ECRSetIntRep(copyPtr, ensembleCopy); + ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->token->refCount++; ensembleCopy->fix = ensembleCmd->fix; if (ensembleCopy->fix) { Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -742,12 +742,10 @@ #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); @@ -818,24 +816,26 @@ ReleaseDictIterator( Tcl_Obj *objPtr) { Tcl_DictSearch *searchPtr; Tcl_Obj *dictPtr; + const Tcl_ObjIntRep *irPtr; + + irPtr = Tcl_FetchIntRep(objPtr, &dictIteratorType); + assert(irPtr != NULL); /* * First kill the search, and then release the reference to the dictionary * that we were holding. */ - searchPtr = objPtr->internalRep.twoPtrValue.ptr1; + searchPtr = irPtr->twoPtrValue.ptr1; Tcl_DictObjDone(searchPtr); ckfree(searchPtr); - dictPtr = objPtr->internalRep.twoPtrValue.ptr2; + dictPtr = irPtr->twoPtrValue.ptr2; TclDecrRefCount(dictPtr); - - objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -1331,16 +1331,16 @@ TclStackAlloc( Tcl_Interp *interp, int numBytes) { Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } - + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } void * TclStackRealloc( @@ -1520,23 +1520,27 @@ /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - if (objPtr->typePtr == &exprCodeType) { + + ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + + if (codePtr != NULL) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - TclFreeIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &exprCodeType, NULL); + codePtr = NULL; } } - if (objPtr->typePtr != &exprCodeType) { + + if (codePtr == NULL) { /* * TIP #280: No invoker (yet) - Expression compilation. */ const char *string = TclGetString(objPtr); @@ -1632,11 +1636,13 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + assert(codePtr != NULL); TclReleaseByteCode(codePtr); } /* @@ -1670,11 +1676,12 @@ * If the object is not already of tclByteCodeType, compile it (and reset * the compilation flags in the interpreter; this should be done after any * compilation). Otherwise, check that it is "fresh" enough. */ - if (objPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the * compiled code wrong). The object needs to be recompiled if it was * compiled in/for a different interpreter, or for a different @@ -1688,11 +1695,10 @@ * #def'ed out because [info body] was changed to never return a * bytecode type object, which should obviate us from the extra checks * here. */ - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { @@ -1816,11 +1822,11 @@ iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } return codePtr; @@ -4907,11 +4913,11 @@ /* * Extract the desired list element. */ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && (value2Ptr->typePtr != &tclListType) + && (NULL == Tcl_FetchIntRep(value2Ptr, &tclListType)) && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, &index) == TCL_OK)) { TclDecrRefCount(value2Ptr); tosPtr--; pcAdjustment = 1; @@ -7404,17 +7410,20 @@ Tcl_DecrRefCount(dictPtr); ckfree(searchPtr); TRACE_ERROR(interp); goto gotError; } - TclNewObj(statePtr); - statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; + { + Tcl_ObjIntRep ir; + TclNewObj(statePtr); + ir.twoPtrValue.ptr1 = searchPtr; + ir.twoPtrValue.ptr2 = dictPtr; + Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir); + } varPtr = LOCAL(opnd); if (varPtr->value.objPtr) { - if (varPtr->value.objPtr->typePtr == &dictIteratorType) { + if (Tcl_FetchIntRep(varPtr->value.objPtr, &dictIteratorType)) { Tcl_Panic("mis-issued dictFirst!"); } TclDecrRefCount(varPtr->value.objPtr); } varPtr->value.objPtr = statePtr; @@ -7423,15 +7432,21 @@ case INST_DICT_NEXT: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { - Tcl_Panic("mis-issued dictNext!"); + { + const Tcl_ObjIntRep *irPtr; + + if (statePtr && + (irPtr = Tcl_FetchIntRep(statePtr, &dictIteratorType))) { + searchPtr = irPtr->twoPtrValue.ptr1; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); + } else { + Tcl_Panic("mis-issued dictNext!"); + } } - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { TclNewObj(emptyPtr); PUSH_OBJECT(emptyPtr); PUSH_OBJECT(emptyPtr); @@ -10251,11 +10266,11 @@ strBytesSharedMultX = 0.0; strBytesSharedOnce = 0.0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (entryPtr->objPtr->typePtr == &tclByteCodeType) { + if (NULL != Tcl_FetchIntRep(entryPtr->objPtr, &tclByteCodeType)) { numByteCodeLits++; } (void) TclGetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); Index: generic/tclHash.c ================================================================== --- generic/tclHash.c +++ generic/tclHash.c @@ -983,15 +983,21 @@ static void RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - int oldSize, count, index; - Tcl_HashEntry **oldBuckets; + int count, index, oldSize = tablePtr->numBuckets; + Tcl_HashEntry **oldBuckets = tablePtr->buckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; + + /* Avoid outgrowing capability of the memory allocators */ + if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) { + tablePtr->rebuildSize = INT_MAX; + return; + } if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; @@ -1000,13 +1006,10 @@ typePtr = tablePtr->typePtr; } else { typePtr = &tclArrayHashKeyType; } - oldSize = tablePtr->numBuckets; - oldBuckets = tablePtr->buckets; - /* * Allocate and initialize the new bucket array, and set up hashing * constants for new array size. */ Index: generic/tclIO.c ================================================================== --- generic/tclIO.c +++ generic/tclIO.c @@ -334,10 +334,26 @@ FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; + +#define ChanSetIntRep(objPtr, resPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (resPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (resPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \ + } while (0) + +#define ChanGetIntRep(objPtr, resPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &chanObjType); \ + (resPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) @@ -1509,16 +1525,16 @@ if (interp == NULL) { return TCL_ERROR; } - if (objPtr->typePtr == &chanObjType) { + ChanGetIntRep(objPtr, resPtr); + if (resPtr) { /* * Confirm validity of saved lookup results. */ - resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; statePtr = resPtr->statePtr; if ((resPtr->interp == interp) /* Same interp context */ /* No epoch change in channel since lookup */ && (resPtr->epoch == statePtr->epoch)) { /* @@ -1531,11 +1547,11 @@ chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); if (chan == NULL) { if (resPtr) { - FreeChannelIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &chanObjType, NULL); } return TCL_ERROR; } if (resPtr && resPtr->refCount == 1) { @@ -1542,18 +1558,14 @@ /* * Re-use the ResolvedCmdName struct. */ Tcl_Release((ClientData) resPtr->statePtr); - } else { - TclFreeIntRep(objPtr); - resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; - objPtr->typePtr = &chanObjType; + resPtr->refCount = 0; + ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */ } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; Tcl_Preserve((ClientData) statePtr); resPtr->interp = interp; @@ -9030,10 +9042,11 @@ * be marked busy. * *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) int TclCopyChannelOld( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Channel inChan, /* Channel to read from. */ Tcl_Channel outChan, /* Channel to write to. */ @@ -9041,10 +9054,11 @@ Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ { return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, cmdPtr); } +#endif int TclCopyChannel( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Channel inChan, /* Channel to read from. */ @@ -11190,15 +11204,15 @@ register Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have * an internal rep of type "Channel". */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedChanName *resPtr; - resPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; - copyPtr->typePtr = srcPtr->typePtr; + ChanGetIntRep(srcPtr, resPtr); + assert(resPtr); + ChanSetIntRep(copyPtr, resPtr); } /* *---------------------------------------------------------------------- * @@ -11217,13 +11231,14 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedChanName *resPtr; - objPtr->typePtr = NULL; + ChanGetIntRep(objPtr, resPtr); + assert(resPtr); if (resPtr->refCount-- > 1) { return; } Tcl_Release(resPtr->statePtr); ckfree(resPtr); Index: generic/tclIORTrans.c ================================================================== --- generic/tclIORTrans.c +++ generic/tclIORTrans.c @@ -85,11 +85,11 @@ /* * Structure of the buffer to hold transform results to be consumed by higher * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, * <= allocated. */ } ResultBuffer; @@ -251,11 +251,11 @@ * forward an operation code, the argument details, and reference to results. * The command is assembled in the CT and belongs fully to that thread. No * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if * otherwise (static). */ } ForwardParamBase; @@ -296,11 +296,11 @@ /* * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ ReflectedTransform *rtPtr; /* Channel instance */ ForwardParam *param; /* Packaged arguments and return values, a Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -243,11 +243,11 @@ * combination which was used, and the original and modified filenames, so * that we can correctly undo the entire operation when we want to unload the * code. */ -typedef struct FsDivertLoad { +typedef struct { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; const Tcl_Filesystem *divertedFilesystem; ClientData divertedFileNativeRep; @@ -410,11 +410,10 @@ TclDStringAppendObj(cwdPtr, cwd); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } -/* Obsolete */ int Tcl_EvalFile( Tcl_Interp *interp, /* Interpreter in which to process file. */ const char *fileName) /* Name of file to process. Tilde-substitution * will be performed on this name. */ Index: generic/tclIndexObj.c ================================================================== --- generic/tclIndexObj.c +++ generic/tclIndexObj.c @@ -113,18 +113,22 @@ const char *msg, /* Identifying word to use in error * messages. */ int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { + if (!(flags & INDEX_TEMP_TABLE)) { + /* * See if there is a valid cached result from a previous lookup (doing the * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in * the common case where the result is cached). */ - if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &indexType); + + if (irPtr) { + IndexRep *indexRep = irPtr->twoPtrValue.ptr1; /* * Here's hoping we don't get hit by unfortunate packing constraints * on odd platforms like a Cray PVP... */ @@ -132,10 +136,11 @@ if (indexRep->tablePtr == (void *) tablePtr && indexRep->offset == sizeof(char *)) { *indexPtr = indexRep->index; return TCL_OK; } + } } return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags, indexPtr); } #endif /* TCL_NO_DEPRECATED */ @@ -264,25 +269,29 @@ const char *key, *p1; const char *p2; const char *const *entryPtr; Tcl_Obj *resultPtr; IndexRep *indexRep; + const Tcl_ObjIntRep *irPtr; /* Protect against invalid values, like -1 or 0. */ if (offset < (int)sizeof(char *)) { offset = (int)sizeof(char *); } /* * See if there is a valid cached result from a previous lookup. */ - if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; + if (!(flags & INDEX_TEMP_TABLE)) { + irPtr = Tcl_FetchIntRep(objPtr, &indexType); + if (irPtr) { + indexRep = irPtr->twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; } + } } /* * Lookup the value of the object in the table. Accept unique * abbreviations unless TCL_EXACT is set in flags. @@ -335,21 +344,23 @@ * new internal-rep if at all possible since that is potentially a slow * operation. */ if (!(flags & INDEX_TEMP_TABLE)) { - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; - } else { - TclFreeIntRep(objPtr); - indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.twoPtrValue.ptr1 = indexRep; - objPtr->typePtr = &indexType; - } - indexRep->tablePtr = (void *) tablePtr; - indexRep->offset = offset; - indexRep->index = index; + irPtr = Tcl_FetchIntRep(objPtr, &indexType); + if (irPtr) { + indexRep = irPtr->twoPtrValue.ptr1; + } else { + Tcl_ObjIntRep ir; + + indexRep = ckalloc(sizeof(IndexRep)); + ir.twoPtrValue.ptr1 = indexRep; + Tcl_StoreIntRep(objPtr, &indexType, &ir); + } + indexRep->tablePtr = (void *) tablePtr; + indexRep->offset = offset; + indexRep->index = index; } *indexPtr = index; return TCL_OK; @@ -444,20 +455,14 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; - register char *buf; - register unsigned len; + IndexRep *indexRep = Tcl_FetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1; register const char *indexStr = EXPAND_OF(indexRep); - len = strlen(indexStr); - buf = ckalloc(len + 1); - memcpy(buf, indexStr, len+1); - objPtr->bytes = buf; - objPtr->length = len; + Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); } /* *---------------------------------------------------------------------- * @@ -479,16 +484,18 @@ static void DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_ObjIntRep ir; IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); - memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); - dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; - dupPtr->typePtr = &indexType; + memcpy(dupIndexRep, Tcl_FetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1, + sizeof(IndexRep)); + + ir.twoPtrValue.ptr1 = dupIndexRep; + Tcl_StoreIntRep(dupPtr, &indexType, &ir); } /* *---------------------------------------------------------------------- * @@ -508,11 +515,11 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(objPtr->internalRep.twoPtrValue.ptr1); + ckfree(Tcl_FetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1); objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- @@ -874,11 +881,12 @@ const char *message) /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { Tcl_Obj *objPtr; - int i, len, elemLen, flags; + int i, len, elemLen; + char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; /* * [incr Tcl] does something fairly horrific when generating error @@ -954,14 +962,14 @@ for (i=0 ; itypePtr == &indexType) { - register IndexRep *indexRep = - origObjv[i]->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(origObjv[i], &indexType))) { + register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); } else { elementStr = TclGetStringFromObj(origObjv[i], &elemLen); @@ -1004,13 +1012,14 @@ /* * If the object is an index type use the index table which allows for * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ + const Tcl_ObjIntRep *irPtr; - if (objv[i]->typePtr == &indexType) { - register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(objv[i], &indexType))) { + register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). Index: generic/tclInt.decls ================================================================== --- generic/tclInt.decls +++ generic/tclInt.decls @@ -48,11 +48,11 @@ void TclCleanupCommand(Command *cmdPtr) } declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } -declare 8 { +declare 8 {deprecated {}} { int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } # TclCreatePipeline unofficially exported for use by BLT. @@ -71,11 +71,11 @@ void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr) } declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5 +# Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 { @@ -86,11 +86,11 @@ # void TclExpandParseValue(ParseValue *pvPtr, int needed) # } declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4 +# Removed in 8.4: #declare 17 { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) #} #declare 18 { # int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) @@ -121,11 +121,11 @@ } # Removed in 8.1: # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } -# Removed in 8.5 +# Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) #} declare 28 { @@ -145,11 +145,11 @@ } declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in Tcl 8.5 +# Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} declare 34 { int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -158,11 +158,11 @@ # Removed in 8.4b2: #declare 35 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} -# Removed in 8.6a2 +# Removed in 8.6a2: #declare 36 { # int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) #} declare 37 { int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) @@ -183,11 +183,11 @@ Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 43 { # int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, # int flags) #} declare 44 { @@ -218,11 +218,11 @@ Namespace *nsPtr) } declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 52 { # int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, # int flags) #} declare 53 { @@ -271,11 +271,11 @@ } declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) #} #declare 66 { @@ -311,13 +311,11 @@ unsigned long TclpGetClicks(void) } declare 76 { unsigned long TclpGetSeconds(void) } - -# deprecated -declare 77 { +declare 77 {deprecated {}} { void TclpGetTime(Tcl_Time *time) } # Removed in 8.6: #declare 78 { # int TclpGetTimeZone(unsigned long time) @@ -378,11 +376,11 @@ const char *procName) } declare 93 { void TclProcDeleteProc(ClientData clientData) } -# Removed in Tcl 8.5: +# Removed in 8.5: #declare 94 { # int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, # int argc, const char **argv) #} # Replaced by Tcl_FSStat in 8.4: @@ -417,11 +415,11 @@ } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -declare 104 { +declare 104 {deprecated {}} { int TclSockMinimumBuffersOld(int sock, int size) } # Replaced by Tcl_FSStat in 8.4: #declare 105 { # int TclStat(const char *path, Tcl_StatBuf *buf) @@ -453,30 +451,30 @@ void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 { - Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 { - void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) + void TclDeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst) } declare 116 { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 { - Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 { int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo) @@ -488,32 +486,32 @@ declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 121 { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern) } declare 122 { - Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) + Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 { - Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) } declare 125 { - Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) } declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite) } declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } @@ -530,11 +528,11 @@ Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -declare 133 { +declare 133 {deprecated {}} { struct tm *TclpGetDate(const time_t *time, int useGMT) } # Removed in 8.5 #declare 134 { # size_t TclpStrftime(char *s, size_t maxsize, const char *format, @@ -623,16 +621,14 @@ int status) } declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 158 { +declare 158 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptFileName(const char *filename) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 159 { +declare 159 {deprecated {use public Tcl_GetStartupScript()}} { const char *TclGetStartupScriptFileName(void) } #declare 160 { # int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail, @@ -674,17 +670,14 @@ declare 166 { int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 167 { +declare 167 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptPath(Tcl_Obj *pathPtr) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 168 { +declare 168 {deprecated {use public Tcl_GetStartupScript()}} { Tcl_Obj *TclGetStartupScriptPath(void) } # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) @@ -728,16 +721,15 @@ } declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h too declare 178 { - void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) + void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } declare 179 { - Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) + Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) } # REMOVED # Allocate lists without copying arrays # declare 180 { @@ -746,16 +738,14 @@ #declare 181 { # Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, # const char *file, int line) #} -# TclpGmtime and TclpLocaltime promoted to the generic interface from unix - -declare 182 { +declare 182 {deprecated {}} { struct tm *TclpLocaltime(const time_t *clock) } -declare 183 { +declare 183 {deprecated {}} { struct tm *TclpGmtime(const time_t *clock) } # For the new "Thread Storage" subsystem. @@ -935,14 +925,11 @@ int *newPtr) } declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -declare 236 { +declare 236 {deprecated {use Tcl_BackgroundException}} { void TclBackgroundException(Tcl_Interp *interp, int code) } # TIP #285: Script cancellation support. declare 237 { @@ -1088,11 +1075,11 @@ } # new for 8.4.20+/8.5.12+ Cygwin only declare 10 win { Tcl_DirEntry *TclpReaddir(DIR *dir) } -# Removed in 8.3.1 (for Win32s only) +# Removed in 8.3.1 (for Win32s only): #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} # Pipe channel functions @@ -1138,11 +1125,10 @@ TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# new for 8.4.20+/8.5.12+ declare 21 win { char *TclpInetNtoa(struct in_addr addr) } # removed permanently for 8.4 #declare 21 win { Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -2331,10 +2331,17 @@ * (notably tbcload) require it. */ #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) +/* + * A common panic alert when memory allocation fails. + */ + +#define TclOOM(ptr, size) \ + ((size) && ((ptr)||(Tcl_Panic("unable to alloc %u bytes", (size)),1))) + /* * The following enum values are used to specify the runtime platform setting * of the tclPlatform variable. */ @@ -2405,16 +2412,10 @@ */ #define ListRepPtr(listPtr) \ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) -#define ListSetIntRep(objPtr, listRepPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ - (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ - (listRepPtr)->refCount++, \ - (objPtr)->typePtr = &tclListType - #define ListObjGetElements(listPtr, objc, objv) \ ((objv) = &(ListRepPtr(listPtr)->elements), \ (objc) = ListRepPtr(listPtr)->elemCount) #define ListObjLength(listPtr, len) \ @@ -2719,11 +2720,10 @@ MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; -MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; @@ -2906,25 +2906,40 @@ const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); +MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *nameNamespacePtr, + Tcl_Namespace *ensembleNamespacePtr, + int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); -/* TIP #280 - Modified token based evulation, with line information. */ +/* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -2943,10 +2958,14 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); +Tcl_Namespace * TclEnsureNamespace( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr); + MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); @@ -2969,10 +2988,19 @@ MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); +MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); + MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); @@ -2980,10 +3008,12 @@ Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); +MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, @@ -3143,11 +3173,11 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, - int *flagPtr); + char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -3189,10 +3219,11 @@ int *clNextOuter, const char *outerScript); MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); +MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -4272,11 +4303,11 @@ if ((len) == 0) { \ (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ - memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \ + memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (unsigned) (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } /* @@ -4332,10 +4363,22 @@ ckfree((objPtr)->bytes); \ } \ (objPtr)->bytes = NULL; \ } +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to test whether an object has a + * string representation (or is a 'pure' internal value). + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL) + /* *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C * "prototype" for this macro is: @@ -4416,11 +4459,11 @@ * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0xC0) ? \ + ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* *---------------------------------------------------------------- @@ -4481,11 +4524,11 @@ # define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export export epoch + * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); *---------------------------------------------------------------- */ Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -26,25 +26,25 @@ # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif -/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ -#undef Tcl_CreateNamespace -#undef Tcl_DeleteNamespace -#undef Tcl_AppendExportList -#undef Tcl_Export -#undef Tcl_Import -#undef Tcl_ForgetImport -#undef Tcl_GetCurrentNamespace -#undef Tcl_GetGlobalNamespace -#undef Tcl_FindNamespace -#undef Tcl_FindCommand -#undef Tcl_GetCommandFromObj -#undef Tcl_GetCommandFullName -#undef Tcl_SetStartupScript -#undef Tcl_GetStartupScript +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) +/* Those macro's are especially for Itcl 3.4 compatibility */ +# define tclCreateNamespace tcl_CreateNamespace +# define tclDeleteNamespace tcl_DeleteNamespace +# define tclAppendExportList tcl_AppendExportList +# define tclExport tcl_Export +# define tclImport tcl_Import +# define tclForgetImport tcl_ForgetImport +# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace +# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace +# define tclFindNamespace tcl_FindNamespace +# define tclFindCommand tcl_FindCommand +# define tclGetCommandFromObj tcl_GetCommandFromObj +# define tclGetCommandFullName tcl_GetCommandFullName +#endif /* !defined(TCL_NO_DEPRECATED) */ /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the generic/tclInt.decls script. @@ -73,11 +73,12 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ -EXTERN int TclCopyChannelOld(Tcl_Interp *interp, +TCL_DEPRECATED("") +int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 9 */ EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, @@ -216,11 +217,12 @@ /* 75 */ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ -EXTERN void TclpGetTime(Tcl_Time *time); +TCL_DEPRECATED("") +void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ EXTERN char * TclpRealloc(char *ptr, unsigned int size); @@ -265,11 +267,12 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffersOld(int sock, int size); +TCL_DEPRECATED("") +int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ /* 108 */ EXTERN void TclTeardownNamespace(Namespace *nsPtr); @@ -282,26 +285,26 @@ const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 112 */ -EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, +EXTERN int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 113 */ -EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 114 */ -EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr); /* 115 */ -EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 116 */ -EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, +EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ -EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 118 */ EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); @@ -312,27 +315,27 @@ /* 120 */ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 121 */ -EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, +EXTERN int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 122 */ -EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, +EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 123 */ -EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, +EXTERN void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 124 */ -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); /* 125 */ -EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 127 */ -EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); /* 129 */ EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp, @@ -348,11 +351,12 @@ Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); /* 133 */ -EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT); +TCL_DEPRECATED("") +struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ @@ -399,13 +403,15 @@ int status); /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ -EXTERN void TclSetStartupScriptFileName(const char *filename); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptFileName(const char *filename); /* 159 */ -EXTERN const char * TclGetStartupScriptFileName(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 162 */ @@ -420,13 +426,15 @@ /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 167 */ -EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptPath(Tcl_Obj *pathPtr); /* 168 */ -EXTERN Tcl_Obj * TclGetStartupScriptPath(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, @@ -455,20 +463,22 @@ /* 177 */ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 178 */ -EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr, +EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName); /* 179 */ -EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); +EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ -EXTERN struct tm * TclpLocaltime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpLocaltime(const time_t *clock); /* 183 */ -EXTERN struct tm * TclpGmtime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ @@ -568,11 +578,12 @@ const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ -EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +TCL_DEPRECATED("use Tcl_BackgroundException") +void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ EXTERN int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, @@ -650,11 +661,11 @@ void (*tclAllocateFreeObjects) (void); /* 3 */ void (*reserved4)(void); int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ - int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ + TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ void (*reserved13)(void); @@ -719,11 +730,11 @@ void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ - void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ void (*reserved82)(void); @@ -746,40 +757,40 @@ void (*reserved99)(void); void (*reserved100)(void); CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ - void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ - int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ - Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ - Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ + int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ + Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ - Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ - void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ - Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ - Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ + int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ + Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */ + Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ + int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); void (*reserved137)(void); CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ @@ -800,36 +811,36 @@ Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */ void (*reserved154)(void); void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ - const char * (*tclGetStartupScriptFileName) (void); /* 159 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ - Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */ void (*reserved174)(void); int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ - Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ + void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ + Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ - struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ + TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); void (*reserved187)(void); void (*reserved188)(void); @@ -878,11 +889,11 @@ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ @@ -1086,42 +1097,42 @@ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ #define TclSockMinimumBuffers \ (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -#define Tcl_AppendExportList \ - (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ -#define Tcl_CreateNamespace \ - (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ -#define Tcl_DeleteNamespace \ - (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ -#define Tcl_Export \ - (tclIntStubsPtr->tcl_Export) /* 115 */ -#define Tcl_FindCommand \ - (tclIntStubsPtr->tcl_FindCommand) /* 116 */ -#define Tcl_FindNamespace \ - (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ +#define TclAppendExportList \ + (tclIntStubsPtr->tclAppendExportList) /* 112 */ +#define TclCreateNamespace \ + (tclIntStubsPtr->tclCreateNamespace) /* 113 */ +#define TclDeleteNamespace \ + (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ +#define TclExport \ + (tclIntStubsPtr->tclExport) /* 115 */ +#define TclFindCommand \ + (tclIntStubsPtr->tclFindCommand) /* 116 */ +#define TclFindNamespace \ + (tclIntStubsPtr->tclFindNamespace) /* 117 */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -#define Tcl_ForgetImport \ - (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ -#define Tcl_GetCommandFromObj \ - (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ -#define Tcl_GetCommandFullName \ - (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ -#define Tcl_GetCurrentNamespace \ - (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ -#define Tcl_GetGlobalNamespace \ - (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ +#define TclForgetImport \ + (tclIntStubsPtr->tclForgetImport) /* 121 */ +#define TclGetCommandFromObj \ + (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ +#define TclGetCommandFullName \ + (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ +#define TclGetCurrentNamespace_ \ + (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ +#define TclGetGlobalNamespace_ \ + (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -#define Tcl_Import \ - (tclIntStubsPtr->tcl_Import) /* 127 */ +#define TclImport \ + (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */ #define Tcl_RemoveInterpResolvers \ @@ -1208,14 +1219,14 @@ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -#define Tcl_SetStartupScript \ - (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ -#define Tcl_GetStartupScript \ - (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ +#define TclSetStartupScript \ + (tclIntStubsPtr->tclSetStartupScript) /* 178 */ +#define TclGetStartupScript \ + (tclIntStubsPtr->tclGetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #define TclpLocaltime \ (tclIntStubsPtr->tclpLocaltime) /* 182 */ #define TclpGmtime \ @@ -1348,60 +1359,30 @@ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclGetStartupScriptFileName -#undef TclSetStartupScriptFileName -#undef TclGetStartupScriptPath -#undef TclSetStartupScriptPath -#undef TclBackgroundException - -#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) -# undef Tcl_SetStartupScript -# define Tcl_SetStartupScript \ - (tclStubsPtr->tcl_SetStartupScript) /* 622 */ -# undef Tcl_GetStartupScript -# define Tcl_GetStartupScript \ - (tclStubsPtr->tcl_GetStartupScript) /* 623 */ -# undef Tcl_CreateNamespace -# define Tcl_CreateNamespace \ - (tclStubsPtr->tcl_CreateNamespace) /* 506 */ -# undef Tcl_DeleteNamespace -# define Tcl_DeleteNamespace \ - (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ -# undef Tcl_AppendExportList -# define Tcl_AppendExportList \ - (tclStubsPtr->tcl_AppendExportList) /* 508 */ -# undef Tcl_Export -# define Tcl_Export \ - (tclStubsPtr->tcl_Export) /* 509 */ -# undef Tcl_Import -# define Tcl_Import \ - (tclStubsPtr->tcl_Import) /* 510 */ -# undef Tcl_ForgetImport -# define Tcl_ForgetImport \ - (tclStubsPtr->tcl_ForgetImport) /* 511 */ -# undef Tcl_GetCurrentNamespace -# define Tcl_GetCurrentNamespace \ - (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ -# undef Tcl_GetGlobalNamespace -# define Tcl_GetGlobalNamespace \ - (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ -# undef Tcl_FindNamespace -# define Tcl_FindNamespace \ - (tclStubsPtr->tcl_FindNamespace) /* 514 */ -# undef Tcl_FindCommand -# define Tcl_FindCommand \ - (tclStubsPtr->tcl_FindCommand) /* 515 */ -# undef Tcl_GetCommandFromObj -# define Tcl_GetCommandFromObj \ - (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ -# undef Tcl_GetCommandFullName -# define Tcl_GetCommandFullName \ - (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#if defined(USE_TCL_STUBS) +# undef TclGetStartupScriptFileName +# undef TclSetStartupScriptFileName +# undef TclGetStartupScriptPath +# undef TclSetStartupScriptPath +# undef TclBackgroundException +# undef TclSetStartupScript +# undef TclGetStartupScript +# undef TclCreateNamespace +# undef TclDeleteNamespace +# undef TclAppendExportList +# undef TclExport +# undef TclImport +# undef TclForgetImport +# undef TclGetCurrentNamespace_ +# undef TclGetGlobalNamespace_ +# undef TclFindNamespace +# undef TclFindCommand +# undef TclGetCommandFromObj +# undef TclGetCommandFullName +# undef TclCopyChannelOld +# undef TclSockMinimumBuffersOld #endif -#undef TclCopyChannelOld -#undef TclSockMinimumBuffersOld - #endif /* _TCLINTDECLS */ Index: generic/tclInterp.c ================================================================== --- generic/tclInterp.c +++ generic/tclInterp.c @@ -1821,11 +1821,11 @@ prefc = aliasPtr->objc; prefv = &aliasPtr->objPtr; cmdc = prefc + objc - 1; listPtr = Tcl_NewListObj(cmdc, NULL); - listRep = listPtr->internalRep.twoPtrValue.ptr1; + listRep = ListRepPtr(listPtr); listRep->elemCount = cmdc; cmdv = &listRep->elements; prefv = &aliasPtr->objPtr; memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); @@ -3206,14 +3206,10 @@ * Assume these functions all work. [Bug 2895741] */ (void) Tcl_EvalEx(interp, "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, - "::tcl::mathfunc::min", 0, NULL); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, - "::tcl::mathfunc::max", 0, NULL); } iPtr->flags |= SAFE_INTERP; /* Index: generic/tclLink.c ================================================================== --- generic/tclLink.c +++ generic/tclLink.c @@ -414,20 +414,21 @@ break; case TCL_LINK_DOUBLE: if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { #ifdef ACCEPT_NAN - if (valueObj->typePtr != &tclDoubleType) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(valueObj, &tclDoubleType); + if (irPtr == NULL) { #endif if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have real value"; } #ifdef ACCEPT_NAN } - linkPtr->lastValue.d = valueObj->internalRep.doubleValue; + linkPtr->lastValue.d = irPtr->doubleValue; #endif } LinkedVar(double) = linkPtr->lastValue.d; break; @@ -652,11 +653,11 @@ static Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetInvalidRealFromAny /* setFromAnyProc */ + NULL /* setFromAnyProc */ }; static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { const char *str; Index: generic/tclListObj.c ================================================================== --- generic/tclListObj.c +++ generic/tclListObj.c @@ -10,10 +10,11 @@ * 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 /* * Prototypes for functions defined later in this file: */ @@ -44,10 +45,31 @@ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ SetListFromAny /* setFromAnyProc */ }; +/* Macros to manipulate the List internal rep */ + +#define ListSetIntRep(objPtr, listRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (listRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + (listRepPtr)->refCount++; \ + Tcl_StoreIntRep((objPtr), &tclListType, &ir); \ + } while (0) + +#define ListGetIntRep(objPtr, listRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclListType); \ + (listRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + +#define ListResetIntRep(objPtr, listRepPtr) \ + Tcl_FetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) + #ifndef TCL_MIN_ELEMENT_GROWTH #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) #endif /* @@ -372,12 +394,11 @@ if (objc > 0) { listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { - objPtr->bytes = &tclEmptyString; - objPtr->length = 0; + Tcl_InitStringRep(objPtr, NULL, 0); } } /* *---------------------------------------------------------------------- @@ -405,12 +426,14 @@ Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listPtr) /* List object for which an element array is * to be returned. */ { Tcl_Obj *copyPtr; + List *listRepPtr; - if (listPtr->typePtr != &tclListType) { + ListGetIntRep(listPtr, listRepPtr); + if (NULL == listRepPtr) { if (SetListFromAny(interp, listPtr) != TCL_OK) { return NULL; } } @@ -460,24 +483,27 @@ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); - if (listPtr->bytes == &tclEmptyString) { + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; } @@ -570,24 +596,27 @@ int numElems, numRequired, needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } - if (listPtr->typePtr != &tclListType) { - int result; - if (listPtr->bytes == &tclEmptyString) { + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; needGrow = (numRequired > listRepPtr->maxElemCount); isShared = (listRepPtr->refCount > 1); @@ -679,11 +708,15 @@ memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *)); ckfree(listRepPtr); } listRepPtr = newPtr; } - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; /* * Add objPtr to the end of listPtr's array of element pointers. Increment * the ref count for the (now shared) objPtr. */ @@ -734,24 +767,26 @@ register int index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == &tclEmptyString) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *objPtrPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { *objPtrPtr = (&listRepPtr->elements)[index]; } @@ -787,24 +822,26 @@ register Tcl_Obj *listPtr, /* List object whose #elements to return. */ register int *intPtr) /* The resulting int is stored here. */ { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == &tclEmptyString) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *intPtr = 0; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } /* @@ -860,13 +897,18 @@ int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - if (listPtr->typePtr != &tclListType) { - if (listPtr->bytes == &tclEmptyString) { - if (!objc) { + + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { + if (objc == 0) { return TCL_OK; } Tcl_SetListObj(listPtr, objc, NULL); } else { int result = SetListFromAny(interp, listPtr); @@ -873,10 +915,11 @@ if (result != TCL_OK) { return result; } } + ListGetIntRep(listPtr, listRepPtr); } /* * Note that when count == 0 and objc == 0, this routine is logically a * no-op, removing and adding no elements to the list. However, by flowing @@ -883,11 +926,10 @@ * through this routine anyway, we get the important side effect that the * resulting listPtr is a list in canoncial form. This is important. * Resist any temptation to optimize this case. */ - listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; if (first < 0) { first = 0; @@ -937,11 +979,11 @@ attempt = numRequired; newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); } if (newPtr) { listRepPtr = newPtr; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); elemPtrs = &listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; } } @@ -1010,11 +1052,11 @@ return TCL_ERROR; } } } - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; if (isShared) { @@ -1083,13 +1125,18 @@ */ listRepPtr->elemCount = numRequired; /* - * Invalidate and free any old string representation since it no longer - * reflects the list's internal representation. + * Invalidate and free any old representations that may not agree + * with the revised list's internal representation. */ + + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -1125,18 +1172,20 @@ Tcl_Obj *argPtr) /* Index or index list. */ { int index; /* Index into the list. */ Tcl_Obj *indexListCopy; + List *listRepPtr; /* * Determine whether argPtr designates a list or a single index. We have * to be careful about the order of the checks to avoid repeated * shimmering; see TIP#22 and TIP#33 for the details. */ - if (argPtr->typePtr != &tclListType + ListGetIntRep(argPtr, listRepPtr); + if ((listRepPtr == NULL) && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. */ @@ -1163,23 +1212,16 @@ */ return TclLindexFlat(interp, listPtr, 1, &argPtr); } - if (indexListCopy->typePtr == &tclListType) { - List *listRepPtr = ListRepPtr(indexListCopy); - - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); - } else { - int indexCount = -1; /* Size of the array of list indices. */ - Tcl_Obj **indices = NULL; - /* Array of list indices. */ - - Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices); - listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); - } + ListGetIntRep(indexListCopy, listRepPtr); + + assert(listRepPtr != NULL); + + listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, + &listRepPtr->elements); Tcl_DecrRefCount(indexListCopy); return listPtr; } /* @@ -1310,18 +1352,20 @@ int indexCount = 0; /* Number of indices in the index list. */ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */ Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */ int index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; + List *listRepPtr; /* * Determine whether the index arg designates a list or a single index. * We have to be careful about the order of the checks to avoid repeated * shimmering; see TIP #22 and #23 for details. */ - if (indexArgPtr->typePtr != &tclListType + ListGetIntRep(indexArgPtr, listRepPtr); + if (listRepPtr == NULL && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. */ @@ -1402,10 +1446,11 @@ /* Index args. */ Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ { int index, result, len; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; + Tcl_ObjIntRep *irPtr; /* * If there are no indices, simply return the new value. (Without * indices, [lset] is a synonym for [set]. */ @@ -1532,11 +1577,12 @@ * will need their string reps spoiled. We maintain a list of all * those Tcl_Obj's (via a little intrep surgery) so we can spoil * them at that time. */ - parentList->internalRep.twoPtrValue.ptr2 = chainPtr; + irPtr = Tcl_FetchIntRep(parentList, &tclListType); + irPtr->twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } while (indexCount > 0); /* @@ -1546,26 +1592,36 @@ * string spoiling list of Tcl_Obj's. */ while (chainPtr) { Tcl_Obj *objPtr = chainPtr; - - if (result == TCL_OK) { - /* - * We're going to store valuePtr, so spoil string reps of all - * containing lists. - */ - - TclInvalidateStringRep(objPtr); - } + List *listRepPtr; /* * Clear away our intrep surgery mess. */ - chainPtr = objPtr->internalRep.twoPtrValue.ptr2; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; + irPtr = Tcl_FetchIntRep(objPtr, &tclListType); + listRepPtr = irPtr->twoPtrValue.ptr1; + chainPtr = irPtr->twoPtrValue.ptr2; + + if (result == TCL_OK) { + + /* + * We're going to store valuePtr, so spoil string reps of all + * containing lists. + */ + + listRepPtr->refCount++; + TclFreeIntRep(objPtr); + ListSetIntRep(objPtr, listRepPtr); + listRepPtr->refCount--; + + TclInvalidateStringRep(objPtr); + } else { + irPtr->twoPtrValue.ptr2 = NULL; + } } if (result != TCL_OK) { /* * Error return; message is already in interp. Clean up any excess @@ -1588,12 +1644,12 @@ TclListObjLength(NULL, subListPtr, &len); if (index == len) { Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); + TclInvalidateStringRep(subListPtr); } - TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } /* @@ -1645,14 +1701,17 @@ */ if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - if (listPtr->typePtr != &tclListType) { - int result; + + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == &tclEmptyString) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", NULL); @@ -1661,13 +1720,13 @@ } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; /* * Ensure that the index is in bounds. */ @@ -1706,11 +1765,12 @@ Tcl_IncrRefCount(*dst++); } listRepPtr->refCount--; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; + listRepPtr = newPtr; + ListResetIntRep(listPtr, listRepPtr); } elemPtrs = &listRepPtr->elements; /* * Add a reference to the new list element. @@ -1728,10 +1788,22 @@ * Stash the new object in the list. */ elemPtrs[index] = valuePtr; + /* + * Invalidate outdated intreps. + */ + + ListGetIntRep(listPtr, listRepPtr); + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; + + TclInvalidateStringRep(listPtr); + return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1743,22 +1815,24 @@ * * Results: * None. * * Side effects: - * Frees listPtr's List* internal representation and sets listPtr's - * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all - * element objects, which may free them. + * Frees listPtr's List* internal representation, if no longer shared. + * May decrement the ref counts of element objects, which may free them. * *---------------------------------------------------------------------- */ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - List *listRepPtr = ListRepPtr(listPtr); + List *listRepPtr; + + ListGetIntRep(listPtr, listRepPtr); + assert(listRepPtr != NULL); if (listRepPtr->refCount-- <= 1) { Tcl_Obj **elemPtrs = &listRepPtr->elements; int i, numElems = listRepPtr->elemCount; @@ -1765,12 +1839,10 @@ for (i = 0; i < numElems; i++) { Tcl_DecrRefCount(elemPtrs[i]); } ckfree(listRepPtr); } - - listPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -1791,12 +1863,14 @@ static void DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = ListRepPtr(srcPtr); + List *listRepPtr; + ListGetIntRep(srcPtr, listRepPtr); + assert(listRepPtr != NULL); ListSetIntRep(copyPtr, listRepPtr); } /* *---------------------------------------------------------------------- @@ -1831,11 +1905,11 @@ * more directly. Only do this when there's no existing string rep; if * there is, it is the string rep that's authoritative (because it could * describe duplicate keys). */ - if (objPtr->typePtr == &tclDictType && !objPtr->bytes) { + if (!TclHasStringRep(objPtr) && Tcl_FetchIntRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; /* @@ -1889,14 +1963,16 @@ * Each iteration, parse and store a list element. */ while (nextElem < limit) { const char *elemStart; + char *check; int elemSize, literal; if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { + fail: while (--elemPtrs >= &listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } ckfree(listRepPtr); return TCL_ERROR; @@ -1903,33 +1979,39 @@ } if (elemStart == limit) { break; } - /* TODO: replace panic with error on alloc failure? */ - if (literal) { - TclNewStringObj(*elemPtrs, elemStart, elemSize); - } else { - TclNewObj(*elemPtrs); - (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1); - (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart, - (*elemPtrs)->bytes); + TclNewObj(*elemPtrs); + TclInvalidateStringRep(*elemPtrs); + check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL, + elemSize); + if (elemSize && check == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct list, out of memory", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + goto fail; + } + if (!literal) { + Tcl_InitStringRep(*elemPtrs, NULL, + TclCopyAndCollapse(elemSize, elemStart, check)); } Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; } /* - * Free the old internalRep before setting the new one. We do this as late + * Store the new internalRep. We do this as late * as possible to allow the conversion code, in particular - * Tcl_GetStringFromObj, to use that old internalRep. + * Tcl_GetStringFromObj, to use the old internalRep. */ - TclFreeIntRep(objPtr); ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } /* @@ -1955,18 +2037,23 @@ static void UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { -# define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; - List *listRepPtr = ListRepPtr(listPtr); - int numElems = listRepPtr->elemCount; - int i, length, bytesNeeded = 0; +# define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; + int numElems, i, length, bytesNeeded = 0; const char *elem; char *dst; Tcl_Obj **elemPtrs; + List *listRepPtr; + + ListGetIntRep(listPtr, listRepPtr); + + assert(listRepPtr != NULL); + + numElems = listRepPtr->elemCount; /* * Mark the list as being canonical; although it will now have a string * rep, it is one we derived through proper "canonical" quoting and so * it's known to be free from nasties relating to [concat] and [eval]. @@ -1977,12 +2064,11 @@ /* * Handle empty list case first, so rest of the routine is simpler. */ if (numElems == 0) { - listPtr->bytes = &tclEmptyString; - listPtr->length = 0; + Tcl_InitStringRep(listPtr, NULL, 0); return; } /* * Pass 1: estimate space, gather flags. @@ -1993,11 +2079,11 @@ } else { /* * We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); @@ -2007,26 +2093,25 @@ } } if (bytesNeeded > INT_MAX - numElems + 1) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - bytesNeeded += numElems; + bytesNeeded += numElems - 1; /* * Pass 2: copy into string rep buffer. */ - listPtr->length = bytesNeeded - 1; - listPtr->bytes = ckalloc(bytesNeeded); - dst = listPtr->bytes; + dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded); + TclOOM(dst, bytesNeeded); for (i = 0; i < numElems; i++) { flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } - listPtr->bytes[listPtr->length] = '\0'; + (void) Tcl_InitStringRep(listPtr, NULL, bytesNeeded); if (flagPtr != localFlags) { ckfree(flagPtr); } } Index: generic/tclMain.c ================================================================== --- generic/tclMain.c +++ generic/tclMain.c @@ -264,22 +264,18 @@ * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { - Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1); - Tcl_Close(NULL, c); - Tcl_IncrRefCount(fullNameObj); - if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) { + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } - Tcl_DecrRefCount(fullNameObj); } } Tcl_DStringFree(&temp); } } Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -23,10 +23,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" /* for TclLogCommandInfo visibility */ +#include /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ @@ -151,10 +152,26 @@ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; + +#define NsNameSetIntRep(objPtr, nnPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (nnPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (nnPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \ + } while (0) + +#define NsNameGetIntRep(objPtr, nnPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &nsNameType); \ + (nnPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) /* * Array of values describing how to implement each standard subcommand of the * "namespace" command. */ @@ -2422,10 +2439,39 @@ } /* *---------------------------------------------------------------------- * + * TclEnsureNamespace -- + * + * Provide a namespace that is not deleted. + * + * Value + * + * namespacePtr, if it is not scheduled for deletion, or a pointer to a + * new namespace with the same name otherwise. + * + * Effect + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Namespace * +TclEnsureNamespace( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr) +{ + Namespace *nsPtr = (Namespace *) namespacePtr; + if (!(nsPtr->flags & NS_DYING)) { + return namespacePtr; + } + return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_FindNamespace -- * * Searches for a namespace. * * Results: @@ -2636,11 +2682,11 @@ } } else { Namespace *nsPtr[2]; register int search; - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + TclGetNamespaceForQualName(interp, name, cxtNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the command in the command table of its namespace. Be sure * to check both possible search paths: from the specified namespace @@ -2872,30 +2918,33 @@ Tcl_Obj *objPtr, /* The object to be resolved as the name of a * namespace. */ Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { ResolvedNsName *resNamePtr; - Namespace *nsPtr, *refNsPtr; - if (objPtr->typePtr == &nsNameType) { + NsNameGetIntRep(objPtr, resNamePtr); + if (resNamePtr) { + Namespace *nsPtr, *refNsPtr; + /* * Check that the ResolvedNsName is still valid; avoid letting the ref * cross interps. */ - resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && (!refNsPtr || (refNsPtr == (Namespace *) TclGetCurrentNamespace(interp)))) { *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } + Tcl_StoreIntRep(objPtr, &nsNameType, NULL); } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + NsNameGetIntRep(objPtr, resNamePtr); + assert(resNamePtr != NULL); *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } return TCL_ERROR; } @@ -4661,12 +4710,15 @@ static void FreeNsNameInternalRep( register Tcl_Obj *objPtr) /* nsName object with internal representation * to free. */ { - ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr; + NsNameGetIntRep(objPtr, resNamePtr); + assert(resNamePtr != NULL); + /* * Decrement the reference count of the namespace. If there are no more * references, free it up. */ @@ -4678,11 +4730,10 @@ */ TclNsDecrRefCount(resNamePtr->nsPtr); ckfree(resNamePtr); } - objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -4705,15 +4756,15 @@ static void DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr; - copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - resNamePtr->refCount++; - copyPtr->typePtr = &nsNameType; + NsNameGetIntRep(srcPtr, resNamePtr); + assert(resNamePtr != NULL); + NsNameSetIntRep(copyPtr, resNamePtr); } /* *---------------------------------------------------------------------- * @@ -4753,41 +4804,30 @@ } name = TclGetString(objPtr); TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + + if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + return TCL_ERROR; + } /* * If we found a namespace, then create a new ResolvedNsName structure * that holds a reference to it. */ - if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { - /* - * Our failed lookup proves any previously cached nsName intrep is no - * longer valid. Get rid of it so we no longer waste memory storing - * it, nor time determining its invalidity again and again. - */ - - if (objPtr->typePtr == &nsNameType) { - TclFreeIntRep(objPtr); - } - return TCL_ERROR; - } - nsPtr->refCount++; resNamePtr = ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } - resNamePtr->refCount = 1; - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - objPtr->typePtr = &nsNameType; + resNamePtr->refCount = 0; + NsNameSetIntRep(objPtr, resNamePtr); return TCL_OK; } /* *---------------------------------------------------------------------- Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -2,10 +2,11 @@ * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2017 by Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ @@ -56,11 +57,11 @@ * Function declarations for things defined in this file. */ static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, - const char *nsNameStr); + Namespace *nsPtr, const char *nsNameStr); static void ClearMixins(Class *clsPtr); static void ClearSuperclasses(Class *clsPtr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); @@ -80,11 +81,10 @@ static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static inline void SquelchCachedName(Object *oPtr); -static void SquelchedNsFirst(ClientData clientData); static int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, @@ -378,13 +378,13 @@ * Create the objects at the core of the object system. These need to be * spliced manually. */ fPtr->objectCls = AllocClass(interp, - AllocObject(interp, "::oo::object", NULL)); + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); fPtr->classCls = AllocClass(interp, - AllocObject(interp, "::oo::class", NULL)); + AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; fPtr->objectCls->superclasses.num = 0; ckfree(fPtr->objectCls->superclasses.list); @@ -536,11 +536,12 @@ * ---------------------------------------------------------------------- * * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its - * class's instance list. + * class's instance list. The caller must set the classPtr on the object, + * either to a class or to NULL. * * ---------------------------------------------------------------------- */ static Object * @@ -549,10 +550,12 @@ * object. */ const char *nameStr, /* The name of the object to create, or NULL * if the OO system should pick the object * name itself (equal to the namespace * name). */ + Namespace *nsPtr, /* The namespace to create the object in, + or NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names * a namespace that already exists, the effect * will be the same as if this was NULL. */ @@ -577,12 +580,11 @@ * names using the epoch until such time as a new namespace is actually * created. */ if (nsNameStr != NULL) { - oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = ++fPtr->tsdPtr->nsCount; goto configNamespace; } Tcl_ResetResult(interp); @@ -590,12 +592,11 @@ while (1) { char objName[10 + TCL_INTEGER_SPACE]; sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); - oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; break; } @@ -631,11 +632,11 @@ * Set up a callback to get notification of the deletion of a namespace * when enough of the namespace still remains to execute commands and * access variables in it. [Bug 2950259] */ - ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst; + ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted; /* * Fill in the rest of the non-zero/NULL parts of the structure. */ @@ -650,27 +651,15 @@ * public command (so that the object structures are deleted when the * command is deleted). */ if (!nameStr) { - oPtr->command = Tcl_CreateObjCommand(interp, - oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL); - } else if (nameStr[0] == ':' && nameStr[1] == ':') { - oPtr->command = Tcl_CreateObjCommand(interp, nameStr, - PublicObjectCmd, oPtr, NULL); - } else { - Tcl_DString buffer; - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, - Tcl_GetCurrentNamespace(interp)->fullName, -1); - TclDStringAppendLiteral(&buffer, "::"); - Tcl_DStringAppend(&buffer, nameStr, -1); - oPtr->command = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); - Tcl_DStringFree(&buffer); - } + nameStr = oPtr->namespacePtr->name; + nsPtr = (Namespace *)oPtr->namespacePtr; + } + oPtr->command = TclCreateObjCommandInNs(interp, nameStr, + (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of * abstractions, it is faster and we're inside Tcl here so we're allowed. */ @@ -752,34 +741,10 @@ } /* * ---------------------------------------------------------------------- * - * SquelchedNsFirst -- - * - * This callback is triggered when the object's namespace is deleted by - * any mechanism. It deletes the object's public command if it has not - * already been deleted, so ensuring that destructors get run at an - * appropriate time. [Bug 2950259] - * - * ---------------------------------------------------------------------- - */ - -static void -SquelchedNsFirst( - ClientData clientData) -{ - Object *oPtr = clientData; - - if (oPtr->command) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); - } -} - -/* - * ---------------------------------------------------------------------- - * * ObjectRenamedTrace -- * * This callback is triggered when the object is deleted by any * mechanism. It runs the destructors and arranges for the actual cleanup * of the object's namespace, which in turn triggers cleansing of the @@ -795,12 +760,10 @@ const char *oldName, /* What the object was (last) called. */ const char *newName, /* What it's getting renamed to. (unused) */ int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; - Foundation *fPtr = oPtr->fPtr; - /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. */ @@ -807,92 +770,40 @@ if (flags & TCL_TRACE_RENAME) { SquelchCachedName(oPtr); return; } - /* - * Oh dear, the object really is being deleted. Handle this by running the - * destructors and deleting the object's namespace, which in turn causes - * the real object structures to be deleted. - * - * Note that it is possible for the namespace to be deleted before the - * command. Because of that case, we must take care here to mark the - * command as being deleted so that if we return here we don't run into - * reentrancy problems. - * - * We also do not run destructors on the core class objects when the - * interpreter is being deleted; their incestuous nature causes problems - * in that case when the destructor is partially deleted before the uses - * of it have gone. [Bug 2949397] - */ - - AddRef(oPtr); - AddRef(fPtr->classCls); - AddRef(fPtr->objectCls); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr); - oPtr->command = NULL; - - if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { - CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); - int result; - Tcl_InterpState state; - - oPtr->flags |= DESTRUCTOR_CALLED; - if (contextPtr != NULL) { - contextPtr->callPtr->flags |= DESTRUCTOR; - contextPtr->skip = 0; - state = Tcl_SaveInterpState(interp, TCL_OK); - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, - contextPtr, 0, NULL); - if (result != TCL_OK) { - Tcl_BackgroundException(interp, result); - } - Tcl_RestoreInterpState(interp, state); - TclOODeleteContext(contextPtr); - } - } - - /* - * OK, the destructor's been run. Time to splat the class data (if any) - * and nuke the namespace (which triggers the final crushing of the object - * structure itself). - * - * The class of objects needs some special care; if it is deleted (and - * we're not killing the whole interpreter) we force the delete of the - * class of classes now as well. Due to the incestuous nature of those two - * classes, if one goes the other must too and yet the tangle can - * sometimes not go away automatically; we force it here. [Bug 2962664] - */ - - if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) - && !Deleted(fPtr->classCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); - } - - if (oPtr->classPtr != NULL) { - AddRef(oPtr->classPtr); - ReleaseClassContents(interp, oPtr); - } - /* * The namespace is only deleted if it hasn't already been deleted. [Bug - * 2950259] + * 2950259]. If the namespace has already been deleted, then + * ObjectNamespaceDeleted() has already cleaned up this command. */ - if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { - Tcl_DeleteNamespace(oPtr->namespacePtr); - } - if (oPtr->classPtr) { - DelRef(oPtr->classPtr); - } - DelRef(fPtr->classCls->thisPtr); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->classCls); - DelRef(fPtr->objectCls); - DelRef(oPtr); + if (oPtr->namespacePtr == NULL) { + /* + * ObjectNamespaceDeleted() has already done all the cleanup, but + * detected that the command was in the process of being deleted, and + * left the pointer allocated for us. + */ + DelRef(oPtr); + } else { + if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc == NULL) { + /* + * ObjectNamespaceDeleted() called us, and still has some work to + * do, so we leave the pointer allocated for it to finish, and then + * it will deallocate the pointer. + */ + } else { + Tcl_DeleteNamespace(oPtr->namespacePtr); + /* + * ObjectNamespaceDeleted() doesn't know it was us that just + * called, so it left the pointer allocated. + */ + DelRef(oPtr); + } + } + return; } /* * ---------------------------------------------------------------------- * @@ -960,11 +871,13 @@ { FOREACH_HASH_DECLS; int i; Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; Object *instancePtr; + Method *mPtr; Foundation *fPtr = oPtr->fPtr; + Tcl_Obj *variableObj; /* * Sanity check! */ @@ -998,48 +911,52 @@ AddRef(subclassPtr->thisPtr); } } if (!IsRootClass(oPtr)) { FOREACH(instancePtr, clsPtr->instances) { - int j; - if (instancePtr->selfCls == clsPtr) { - instancePtr->flags |= CLASS_GONE; - } - for(j=0 ; jmixins.num ; j++) { - Class *mixin = instancePtr->mixins.list[j]; - Class *nextMixin = NULL; - if (mixin == clsPtr) { - if (j < instancePtr->mixins.num - 1) { - nextMixin = instancePtr->mixins.list[j+1]; - } - if (j == 0) { - instancePtr->mixins.num = 0; - instancePtr->mixins.list = NULL; - } else { - instancePtr->mixins.list[j-1] = nextMixin; - } - instancePtr->mixins.num -= 1; - } - } - if (instancePtr != NULL && !IsRoot(instancePtr)) { - AddRef(instancePtr); + if (instancePtr != oPtr) { + int j; + if (instancePtr->selfCls == clsPtr) { + instancePtr->flags |= CLASS_GONE; + } + for(j=0 ; jmixins.num ; j++) { + Class *mixin = instancePtr->mixins.list[j]; + Class *nextMixin = NULL; + if (mixin == clsPtr) { + if (j < instancePtr->mixins.num - 1) { + nextMixin = instancePtr->mixins.list[j+1]; + } + if (j == 0) { + instancePtr->mixins.num = 0; + instancePtr->mixins.list = NULL; + } else { + instancePtr->mixins.list[j-1] = nextMixin; + } + instancePtr->mixins.num -= 1; + } + } + if (instancePtr != NULL && !IsRoot(instancePtr)) { + AddRef(instancePtr); + } } } } /* * Squelch classes that this class has been mixed into. */ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (!Deleted(mixinSubclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, - mixinSubclassPtr->thisPtr->command); + if (mixinSubclassPtr != clsPtr) { + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); + } + ClearMixins(mixinSubclassPtr); + DelRef(mixinSubclassPtr->thisPtr); + DelRef(mixinSubclassPtr); } - ClearMixins(mixinSubclassPtr); - DelRef(mixinSubclassPtr->thisPtr); - DelRef(mixinSubclassPtr); } if (clsPtr->mixinSubs.list != NULL) { ckfree(clsPtr->mixinSubs.list); clsPtr->mixinSubs.list = NULL; clsPtr->mixinSubs.num = 0; @@ -1070,23 +987,25 @@ * Squelch instances of this class (includes objects we're mixed into). */ if (!IsRootClass(oPtr)) { FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr == NULL || IsRoot(instancePtr)) { - continue; - } - if (!Deleted(instancePtr)) { - Tcl_DeleteCommandFromToken(interp, instancePtr->command); - /* - * Tcl_DeleteCommandFromToken() may have done to whole - * job for us. Roll back and check again. - */ - i--; - continue; - } - DelRef(instancePtr); + if (instancePtr != oPtr) { + if (instancePtr == NULL || IsRoot(instancePtr)) { + continue; + } + if (!Deleted(instancePtr)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); + /* + * Tcl_DeleteCommandFromToken() may have done to whole + * job for us. Roll back and check again. + */ + i--; + continue; + } + DelRef(instancePtr); + } } } if (clsPtr->instances.list != NULL) { ckfree(clsPtr->instances.list); clsPtr->instances.list = NULL; @@ -1151,10 +1070,34 @@ } Tcl_DeleteHashTable(clsPtr->metadataPtr); ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } + + ClearMixins(clsPtr); + ClearSuperclasses(clsPtr); + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODelMethodRef(clsPtr->constructorPtr); + TclOODelMethodRef(clsPtr->destructorPtr); + + FOREACH(variableObj, clsPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(clsPtr->variables.list); + } + + /* Tell oPtr that it's class is gone so that it doesn't try to remove + * itself from it's classe's list of instances + */ + oPtr->flags |= CLASS_GONE; + DelRef(clsPtr); + } /* * ---------------------------------------------------------------------- * @@ -1172,35 +1115,75 @@ ObjectNamespaceDeleted( ClientData clientData) /* Pointer to the class whose namespace is * being deleted. */ { Object *oPtr = clientData; + Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; - Class *clsPtr = oPtr->classPtr, *mixinPtr; + Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - int deleteAlreadyInProgress = 0, i; + Tcl_Interp *interp = oPtr->fPtr->interp; + int finished = 0, i; + + + AddRef(fPtr->classCls); + AddRef(fPtr->objectCls); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr); + + /* + * We do not run destructors on the core class objects when the + * interpreter is being deleted; their incestuous nature causes problems + * in that case when the destructor is partially deleted before the uses + * of it have gone. [Bug 2949397] + */ + + if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + int result; + + Tcl_InterpState state; + + oPtr->flags |= DESTRUCTOR_CALLED; + if (contextPtr != NULL) { + contextPtr->callPtr->flags |= DESTRUCTOR; + contextPtr->skip = 0; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, + contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundException(interp, result); + } + Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); + } + } /* * Instruct everyone to no longer use any allocated fields of the object. - * Also delete the commands that refer to the object at this point (if - * they still exist) because otherwise their references to the object - * point into freed memory, allowing crashes. - */ - - if (oPtr->command) { - if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { - /* - * Namespace deletion must have been triggered by a trace on command - * deletion , meaning that ObjectRenamedTrace() is eventually going - * to be called . - */ - deleteAlreadyInProgress = 1; - } - + * Also delete the command that refers to the object at this point (if + * it still exists) because otherwise its pointer to the object + * points into freed memory. + */ + + if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { + /* + * Something has already started the command deletion process. We can + * go ahead and clean up the the namespace, + */ + } else { + /* + * The namespace must have been deleted directly. Delete the command + * as well. + */ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + finished = 1; } + oPtr->command = NULL; + if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } /* @@ -1211,11 +1194,11 @@ if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); } FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr) { + if (mixinPtr && mixinPtr != oPtr->classPtr) { TclOORemoveFromInstances(oPtr, mixinPtr); } } if (i) { ckfree(oPtr->mixins.list); @@ -1260,81 +1243,55 @@ ckfree(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } /* - * If this was a class, there's additional deletion work to do. + * Because an object can be a class that is an instance of itself, the + * A class object's class structure should only be cleaned after most of + * the cleanup on the object is done. + */ + + + /* + * The class of objects needs some special care; if it is deleted (and + * we're not killing the whole interpreter) we force the delete of the + * class of classes now as well. Due to the incestuous nature of those two + * classes, if one goes the other must too and yet the tangle can + * sometimes not go away automatically; we force it here. [Bug 2962664] */ - - if (clsPtr != NULL) { - Tcl_ObjectMetadataType *metadataTypePtr; - ClientData value; - - if (clsPtr->metadataPtr != NULL) { - FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { - metadataTypePtr->deleteProc(value); - } - Tcl_DeleteHashTable(clsPtr->metadataPtr); - ckfree(clsPtr->metadataPtr); - clsPtr->metadataPtr = NULL; - } - - FOREACH(filterObj, clsPtr->filters) { - TclDecrRefCount(filterObj); - } - if (i) { - ckfree(clsPtr->filters.list); - clsPtr->filters.num = 0; - } - - ClearMixins(clsPtr); - - ClearSuperclasses(clsPtr); - - if (clsPtr->subclasses.list) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.list = NULL; - clsPtr->subclasses.num = 0; - } - if (clsPtr->instances.list) { - ckfree(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - } - if (clsPtr->mixinSubs.list) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.list = NULL; - clsPtr->mixinSubs.num = 0; - } - - FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashTable(&clsPtr->classMethods); - TclOODelMethodRef(clsPtr->constructorPtr); - TclOODelMethodRef(clsPtr->destructorPtr); - - FOREACH(variableObj, clsPtr->variables) { - TclDecrRefCount(variableObj); - } - if (i) { - ckfree(clsPtr->variables.list); - } - - DelRef(clsPtr); - } + if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) + && !Deleted(fPtr->classCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + } + + if (oPtr->classPtr != NULL) { + ReleaseClassContents(interp, oPtr); + } + /* * Delete the object structure itself. */ - if (deleteAlreadyInProgress) { - oPtr->classPtr = NULL; - oPtr->namespacePtr = NULL; - } else { + oPtr->classPtr = NULL; + oPtr->namespacePtr = NULL; + + DelRef(fPtr->classCls->thisPtr); + DelRef(fPtr->objectCls->thisPtr); + DelRef(fPtr->classCls); + DelRef(fPtr->objectCls); + if (finished) { + /* + * ObjectRenamedTrace called us, and not the other way around. + */ DelRef(oPtr); + } else { + /* + * ObjectRenamedTrace will call DelRef(oPtr). + */ } + return; } /* * ---------------------------------------------------------------------- @@ -1424,11 +1381,11 @@ */ void TclOORemoveFromSubclasses( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { int i; Class *subclsPtr; @@ -1495,11 +1452,11 @@ */ void TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { int i; Class *subclsPtr; @@ -1569,11 +1526,11 @@ AllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the * class. */ Object *useThisObj) /* Object that is to act as the class * representation, or NULL if a new object - * (with automatic name) is to be used. */ + * with automatic name is to be used. */ { Foundation *fPtr = GetFoundation(interp); Class *clsPtr = ckalloc(sizeof(Class)); /* @@ -1580,11 +1537,11 @@ * Make an object if we haven't been given one. */ memset(clsPtr, 0, sizeof(Class)); if (useThisObj == NULL) { - clsPtr->thisPtr = AllocObject(interp, NULL, NULL); + clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL); } else { clsPtr->thisPtr = useThisObj; } /* @@ -1641,11 +1598,10 @@ * * Allocate a new instance of an object. * * ---------------------------------------------------------------------- */ - Tcl_Object Tcl_NewObjectInstance( Tcl_Interp *interp, /* Interpreter context. */ Tcl_Class cls, /* Class to create an instance of. */ const char *nameStr, /* Name of object to create, or NULL to ask @@ -1658,56 +1614,19 @@ Tcl_Obj *const *objv, /* Argument list. */ int skip) /* Number of arguments to _not_ pass to the * constructor. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); Object *oPtr; - - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); - return NULL; - } - - /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } - - /* - * Run constructors, except when objc < 0 (a special flag case used for - * object cloning only). + ClientData clientData[4]; + + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) {return NULL;} + + /* + * Run constructors, except when objc < 0, which is a special flag case + * used for object cloning only. */ if (objc >= 0) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); @@ -1730,40 +1649,20 @@ if (isRoot) { TclResetRewriteEnsemble(interp, 1); } - /* - * It's an error if the object was whacked in the constructor. - * Force this if it isn't already an error (don't want to lose - * errors by accident...) [Bug 2903011] - */ - - if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "object deleted in constructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); - result = TCL_ERROR; - } - TclOODeleteContext(contextPtr); - if (result != TCL_OK) { - Tcl_DiscardInterpState(state); - - /* - * Take care to not delete a deleted object; that would be - * bad. [Bug 2903011] Also take care to make sure that we have - * the name of the command before we delete it. [Bug - * 9dd1bd7a74] - */ - - if (!Deleted(oPtr)) { - (void) TclOOObjectName(interp, oPtr); - Tcl_DeleteCommandFromToken(interp, oPtr->command); - } + clientData[0] = contextPtr; + clientData[1] = oPtr; + clientData[2] = state; + clientData[3] = &oPtr; + + AddRef(oPtr); + result = FinalizeAlloc(clientData, interp, result); + if (result != TCL_OK) { return NULL; } - Tcl_RestoreInterpState(interp, state); } } return (Tcl_Object) oPtr; } @@ -1784,54 +1683,16 @@ * constructor. */ Tcl_Object *objectPtr) /* Place to write the object reference upon * successful allocation. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); CallContext *contextPtr; Tcl_InterpState state; Object *oPtr; - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); - return TCL_ERROR; - } - - /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) {return TCL_ERROR;} /* * Run constructors, except when objc < 0 (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ @@ -1849,11 +1710,11 @@ state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } @@ -1866,10 +1727,87 @@ TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); return TclOOInvokeContext(contextPtr, interp, objc, objv); } + + +Object * +TclNewObjectInstanceCommon( + Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr) +{ + Tcl_HashEntry *hPtr; + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + const char *simpleName = NULL; + Namespace *nsPtr = NULL, *dummy, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); + int isNew; + + if (nameStr) { + TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN, + &nsPtr, &dummy, &dummy, &simpleName); + + /* + * Disallow creation of an object over an existing command. + */ + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); + if (isNew) { + /* Just kidding */ + Tcl_DeleteHashEntry(hPtr); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return NULL; + } + } + + /* + * Create the object. + */ + + /* + * The command for the object could have the same name as the command + * associated with classPtr, so protect the structure from deallocation + * here. + */ + AddRef(classPtr); + + oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); + DelRef(classPtr); + oPtr->selfCls = classPtr; + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the AllocClass + * function splices the structure into the object, so we don't have + * to. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = classPtr; + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; + } + return oPtr; +} + + static int FinalizeAlloc( ClientData data[], Tcl_Interp *interp, @@ -1879,13 +1817,12 @@ Object *oPtr = data[1]; Tcl_InterpState state = data[2]; Tcl_Object *objectPtr = data[3]; /* - * It's an error if the object was whacked in the constructor. Force this - * if it isn't already an error (don't want to lose errors by accident...) - * [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. + * Don't want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object deleted in constructor", -1)); Index: generic/tclOOCall.c ================================================================== --- generic/tclOOCall.c +++ generic/tclOOCall.c @@ -13,10 +13,11 @@ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" +#include /* * Structure containing a CallContext and any other values needed only during * the construction of the CallContext. */ @@ -88,10 +89,11 @@ FreeMethodNameRep, DupMethodNameRep, NULL, NULL }; + /* * ---------------------------------------------------------------------- * * TclOODeleteContext -- @@ -177,15 +179,16 @@ static inline void StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { + Tcl_ObjIntRep ir; + callPtr->refCount++; TclGetString(objPtr); - TclFreeIntRep(objPtr); - objPtr->typePtr = &methodNameType; - objPtr->internalRep.twoPtrValue.ptr1 = callPtr; + ir.twoPtrValue.ptr1 = callPtr; + Tcl_StoreIntRep(objPtr, &methodNameType, &ir); } void TclOOStashContext( Tcl_Obj *objPtr, @@ -208,25 +211,20 @@ static void DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; - - dstPtr->typePtr = &methodNameType; - dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; - callPtr->refCount++; + StashCallChain(dstPtr, + Tcl_FetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1); } static void FreeMethodNameRep( Tcl_Obj *objPtr) { - register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; - - TclOODeleteChain(callPtr); - objPtr->typePtr = NULL; + TclOODeleteChain( + Tcl_FetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1); } /* * ---------------------------------------------------------------------- * @@ -996,19 +994,20 @@ * of the cache. This is made a bit more complex by the fact that * there are multiple different layers of cache (in the Tcl_Obj, in * the object, and in the class). */ + const Tcl_ObjIntRep *irPtr; const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); - if (cacheInThisObj->typePtr == &methodNameType) { - callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(cacheInThisObj, &methodNameType))) { + callPtr = irPtr->twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } - FreeMethodNameRep(cacheInThisObj); + Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL); } if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache != NULL) { hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache, Index: generic/tclOOInt.h ================================================================== --- generic/tclOOInt.h +++ generic/tclOOInt.h @@ -493,10 +493,14 @@ MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip, Tcl_Object *objectPtr); +MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); Index: generic/tclOOMethod.c ================================================================== --- generic/tclOOMethod.c +++ generic/tclOOMethod.c @@ -789,10 +789,11 @@ { Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; register int result; const char *namePtr; CallFrame **framePtrPtr = &fdPtr->framePtr; + ByteCode *codePtr; /* * Compute basic information on the basis of the type of method it is. */ @@ -854,14 +855,12 @@ * that we have bytecode, but also that it remains valid. Note that we set * the namespace of the code here directly; this is a hack, but the * alternative is *so* slow... */ - if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = - pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; - + ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr) { codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); if (result != TCL_OK) { @@ -1313,11 +1312,11 @@ * bound references to instance variables are removed. [Bug 3609693] */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); Tcl_GetString(bodyObj); - TclFreeIntRep(bodyObj); + Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* * Create the actual copy of the method record, manufacturing a new proc * record. */ @@ -1542,13 +1541,11 @@ Method *mPtr) { if (mPtr->typePtr == &procMethodType) { ProcedureMethod *pmPtr = mPtr->clientData; - if (pmPtr->procPtr->bodyPtr->bytes == NULL) { - (void) Tcl_GetString(pmPtr->procPtr->bodyPtr); - } + (void) TclGetString(pmPtr->procPtr->bodyPtr); return pmPtr->procPtr->bodyPtr; } return NULL; } Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -15,10 +15,11 @@ */ #include "tclInt.h" #include "tommath.h" #include +#include /* * Table of all object types. */ @@ -393,11 +394,10 @@ 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); @@ -1057,13 +1057,12 @@ * function; used for debugging. */ register int line) /* Line number in the source file; used for * debugging. */ { objPtr->refCount = 0; - objPtr->bytes = &tclEmptyString; - objPtr->length = 0; objPtr->typePtr = NULL; + TclInitStringRep(objPtr, NULL, 0); #ifdef TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. @@ -1696,10 +1695,95 @@ } /* *---------------------------------------------------------------------- * + * Tcl_InitStringRep -- + * + * This function is called in several configurations to provide all + * the tools needed to set an object's string representation. The + * function is determined by the arguments. + * + * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0) + * Invalid call -- panic! + * + * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0 + * Allocation only - allocate space for (numBytes+1) chars. + * store in objPtr->bytes and return. Also sets + * objPtr->length to 0 and objPtr->bytes[0] to NUL. + * + * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0 + * Allocate and copy. bytes is assumed to point to chars to + * copy into the string rep. objPtr->length = numBytes. Allocate + * array of (numBytes + 1) chars. store in objPtr->bytes. Copy + * numBytes chars from bytes to objPtr->bytes; Set + * objPtr->bytes[numBytes] to NUL and return objPtr->bytes. + * Caller must guarantee there are numBytes chars at bytes to + * be copied. + * + * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0 + * Truncate. Set objPtr->length to numBytes and + * objPr->bytes[numBytes] to NUL. Caller has to guarantee + * that a prior allocating call allocated enough bytes for + * this to be valid. Return objPtr->bytes. + * + * Caller is expected to ascertain that the bytes copied into + * the string rep make up complete valid UTF-8 characters. + * + * Results: + * A pointer to the string rep of objPtr. + * + * Side effects: + * As described above. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_InitStringRep( + Tcl_Obj *objPtr, /* Object whose string rep is to be set */ + const char *bytes, + unsigned int numBytes) +{ + assert(objPtr->bytes == NULL || bytes == NULL); + + if (numBytes > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + /* Allocate */ + if (objPtr->bytes == NULL) { + /* Allocate only as empty - extend later if bytes copied */ + objPtr->length = 0; + if (numBytes) { + objPtr->bytes = attemptckalloc(numBytes + 1); + if (objPtr->bytes == NULL) { + return NULL; + } + if (bytes) { + /* Copy */ + memcpy(objPtr->bytes, bytes, numBytes); + objPtr->length = (int) numBytes; + } + } else { + TclInitStringRep(objPtr, NULL, 0); + } + } else { + /* objPtr->bytes != NULL bytes == NULL - Truncate */ + objPtr->bytes = ckrealloc(objPtr->bytes, numBytes + 1); + objPtr->length = (int)numBytes; + } + + /* Terminate */ + objPtr->bytes[objPtr->length] = '\0'; + + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_InvalidateStringRep -- * * This function is called to invalidate an object's string * representation. * @@ -1718,10 +1802,127 @@ register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_HasStringRep -- + * + * This function reports whether object has a string representation. + * + * Results: + * Boolean. + *---------------------------------------------------------------------- + */ + +int +Tcl_HasStringRep( + Tcl_Obj *objPtr) /* Object to test */ +{ + return TclHasStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StoreIntRep -- + * + * This function is called to set the object's internal + * representation to match a particular type. + * + * It is the caller's responsibility to guarantee that + * the value of the submitted IntRep is in agreement with + * the value of any existing string rep. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StoreIntRep( + Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ + const Tcl_ObjType *typePtr, /* New type for the object */ + const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ +{ + /* Clear out any existing IntRep ( "shimmer" ) */ + TclFreeIntRep(objPtr); + + /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ + if (irPtr) { + /* Copy the new IntRep into place */ + objPtr->internalRep = *irPtr; + + /* Set the type to match */ + objPtr->typePtr = typePtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FetchIntRep -- + * + * This function is called to retrieve the object's internal + * representation matching a requested type, if any. + * + * Results: + * A read-only pointer to the associated Tcl_ObjIntRep, or + * NULL if no such internal representation exists. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +Tcl_ObjIntRep * +Tcl_FetchIntRep( + Tcl_Obj *objPtr, /* Object to fetch from. */ + const Tcl_ObjType *typePtr) /* Requested type */ +{ + /* If objPtr type doesn't match request, nothing can be fetched */ + if (objPtr->typePtr != typePtr) { + return NULL; + } + + /* Type match! objPtr IntRep is the one sought. */ + return &(objPtr->internalRep); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FreeIntRep -- + * + * This function is called to free an object's internal representation. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets typePtr field to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeIntRep( + Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ +{ + TclFreeIntRep(objPtr); +} /* *---------------------------------------------------------------------- * * Tcl_NewBooleanObj -- @@ -1806,10 +2007,11 @@ * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.longValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; @@ -2200,10 +2402,11 @@ * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; objPtr->typePtr = &tclDoubleType; return objPtr; @@ -2366,19 +2569,16 @@ 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; + char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); + + TclOOM(dst, TCL_DOUBLE_SPACE + 1); + + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } /* *---------------------------------------------------------------------- * @@ -2564,18 +2764,15 @@ 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; + char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); + + TclOOM(dst, TCL_INTEGER_SPACE + 1); + (void) Tcl_InitStringRep(objPtr, NULL, + TclFormatInt(dst, objPtr->internalRep.longValue)); } /* *---------------------------------------------------------------------- * @@ -2675,10 +2872,11 @@ * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep */ objPtr->bytes = NULL; objPtr->internalRep.longValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; @@ -2859,26 +3057,24 @@ 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; + char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 2); + + TclOOM(dst, TCL_INTEGER_SPACE + 3); /* * 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; + sprintf(dst, "%" TCL_LL_MODIFIER "d", objPtr->internalRep.wideValue); + + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } #endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3244,16 +3440,14 @@ 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) { + if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size < 2) { /* * mp_radix_size() returns < 2 when more than INT_MAX bytes would be @@ -3264,17 +3458,18 @@ * 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) { + + stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1); + + TclOOM(stringVal, size); + if (MP_OKAY != mp_toradix_n(&bignumVal, stringVal, 10, size)) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing NUL byte. */ + (void) Tcl_InitStringRep(objPtr, NULL, size - 1); } /* *---------------------------------------------------------------------- * @@ -3390,15 +3585,21 @@ UNPACK_BIGNUM(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { UNPACK_BIGNUM(objPtr, *bignumValue); + /* Optimized TclFreeIntRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; + /* + * TODO: If objPtr has a string rep, this leaves + * it undisturbed. Not clear that's proper. Pure + * bignum values are converted to empty string. + */ if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, &tclEmptyString, 0); + TclInitStringRep(objPtr, NULL, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { Index: generic/tclPathObj.c ================================================================== --- generic/tclPathObj.c +++ generic/tclPathObj.c @@ -34,11 +34,11 @@ /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ -static const Tcl_ObjType tclFsPathType = { +static const Tcl_ObjType fsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ SetFsPathFromAny /* setFromAnyProc */ @@ -49,23 +49,18 @@ * * Internal representation of a Tcl_Obj of "path" type. This can be used to * represent relative or absolute paths, and has certain optimisations when * used to represent paths which are already normalized and absolute. * - * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular - * reference to the container Tcl_Obj of this FsPath. - * * There are two cases, with the first being the most common: * * (i) flags == 0, => Ordinary path. * - * translatedPathPtr contains the translated path (which may be a circular - * reference to the object itself). If it is NULL then the path is pure - * normalized (and the normPathPtr will be a circular reference). cwdPtr is - * null for an absolute path, and non-null for a relative path (unless the cwd - * has never been set, in which case the cwdPtr may also be null for a - * relative path). + * translatedPathPtr contains the translated path. If it is NULL then the path + * is pure normalized. cwdPtr is null for an absolute path, and non-null for a + * relative path (unless the cwd has never been set, in which case the cwdPtr + * may also be null for a relative path). * * (ii) flags != 0, => Special path, see TclNewFSPathObj * * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir * and normPathPtr is the $tail. @@ -77,15 +72,11 @@ * is NULL, then this is a pure normalized, * absolute path object, in which the parent * Tcl_Obj's string rep is already both * translated and normalized. */ Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or - * ~user sequences. If the Tcl_Obj containing - * this FsPath is already normalized, this may - * be a circular reference back to the - * container. If that is NOT the case, we have - * a refCount on the object. */ + * ~user sequences. */ Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points * to the cwd object used for this path. We * have a refCount on the object. */ int flags; /* Flags to describe interpretation - see * below. */ @@ -108,13 +99,18 @@ /* * Define some macros to give us convenient access to path-object specific * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) +#define PATHOBJ(pathPtr) ((FsPath *) (Tcl_FetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \ + } while (0) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* *--------------------------------------------------------------------------- * @@ -562,11 +558,13 @@ TclPathPart( Tcl_Interp *interp, /* Used for error reporting */ Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { - if (pathPtr->typePtr == &tclFsPathType) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + + if (irPtr) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { switch (portion) { case TCL_PATH_DIRNAME: { @@ -862,10 +860,11 @@ assert ( elements > 0 ); if (elements == 2) { Tcl_Obj *elt = objv[0]; + Tcl_ObjIntRep *eltIr = Tcl_FetchIntRep(elt, &fsPathType); /* * This is a special case where we can be much more efficient, where * we are joining a single relative path onto an object that is * already of path type. The 'TclNewFSPathObj' call below creates an @@ -875,11 +874,11 @@ * * Bugfix [a47641a0]. TclNewFSPathObj requires first argument * to be an absolute path. Added a check for that elt is absolute. */ - if ((elt->typePtr == &tclFsPathType) + if ((eltIr) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { Tcl_Obj *tailObj = objv[1]; Tcl_PathType type = TclGetPathType(tailObj, NULL, NULL, NULL); @@ -1152,10 +1151,12 @@ Tcl_Interp *interp, /* Interpreter in which to store error message * (if necessary). */ Tcl_Obj *pathPtr) /* Object to convert to a valid, current path * type. */ { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + /* * While it is bad practice to examine an object's type directly, this is * actually the best thing to do here. The reason is that if we are * converting this object to FsPath type for the first time, we don't need * to worry whether the 'cwd' has changed. On the other hand, if this @@ -1162,43 +1163,20 @@ * object is already of FsPath type, and is a relative path, we do have to * worry about the cwd. If the cwd has changed, we must recompute the * path. */ - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { return TCL_OK; } - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); } return SetFsPathFromAny(interp, pathPtr); - - /* - * We used to have more complex code here: - * - * FsPath *fsPathPtr = PATHOBJ(pathPtr); - * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { - * return TCL_OK; - * } else { - * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - * return TCL_OK; - * } else { - * if (pathPtr->bytes == NULL) { - * UpdateStringOfFsPath(pathPtr); - * } - * FreeFsPathInternalRep(pathPtr); - * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); - * } - * } - * - * But we no longer believe this is necessary. - */ } /* * Helper function for normalization. */ @@ -1326,13 +1304,11 @@ fsPathPtr->fsPtr = NULL; fsPathPtr->filesystemEpoch = 0; SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; - pathPtr->typePtr = &tclFsPathType; - pathPtr->bytes = NULL; - pathPtr->length = 0; + TclInvalidateStringRep(pathPtr); /* * Look for path components made up of only "." * This is overly conservative analysis to keep simple. It may mark some * things as needing more aggressive normalization that don't actually @@ -1428,12 +1404,13 @@ Tcl_Obj *pathPtr, /* The path we have. */ Tcl_Obj *cwdPtr) /* Make it relative to this. */ { int cwdLen, len; const char *tempStr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { return fsPathPtr->normPathPtr; } @@ -1496,33 +1473,14 @@ MakePathFromNormalized( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr) /* The object to convert. */ { FsPath *fsPathPtr; - - if (pathPtr->typePtr == &tclFsPathType) { - return TCL_OK; - } - - /* - * Free old representation - */ - - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't find object string representation", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", - NULL); - } - return TCL_ERROR; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - TclFreeIntRep(pathPtr); + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + + if (irPtr) { + return TCL_OK; } fsPathPtr = ckalloc(sizeof(FsPath)); /* @@ -1529,24 +1487,19 @@ * It's a pure normalized absolute path. */ fsPathPtr->translatedPathPtr = NULL; - /* - * Circular reference by design. - */ - - fsPathPtr->normPathPtr = pathPtr; + Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; /* Remember the epoch under which we decided pathPtr was normalized */ fsPathPtr->filesystemEpoch = TclFSEpoch(); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return TCL_OK; } /* @@ -1593,37 +1546,23 @@ /* * Free old representation; shouldn't normally be any, but best to be * safe. */ - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - return NULL; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - TclFreeIntRep(pathPtr); - } - + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - /* - * Circular reference, by design. - */ - - fsPathPtr->normPathPtr = pathPtr; + Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsPtr = fromFilesystem; fsPathPtr->filesystemEpoch = TclFSEpoch(); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return pathPtr; } /* @@ -1666,24 +1605,26 @@ * translated result we need, and can store it for future use. */ Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, srcFsPathPtr->cwdPtr); + Tcl_ObjIntRep *translatedCwdIrPtr; + if (translatedCwdPtr == NULL) { return NULL; } retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, &srcFsPathPtr->normPathPtr); - srcFsPathPtr->translatedPathPtr = retObj; - if (translatedCwdPtr->typePtr == &tclFsPathType) { + Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj); + translatedCwdIrPtr = Tcl_FetchIntRep(translatedCwdPtr, &fsPathType); + if (translatedCwdIrPtr) { srcFsPathPtr->filesystemEpoch = PATHOBJ(translatedCwdPtr)->filesystemEpoch; } else { srcFsPathPtr->filesystemEpoch = 0; } - Tcl_IncrRefCount(retObj); Tcl_DecrRefCount(translatedCwdPtr); } else { /* * It is a pure absolute, normalized path object. This is * something like being a 'pure list'. The object's string, @@ -1789,13 +1730,11 @@ dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); if (dir == NULL) { return NULL; } /* TODO: Figure out why this is needed. */ - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } + TclGetString(pathPtr); TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { @@ -1807,11 +1746,10 @@ /* * We now own a reference on both 'dir' and 'copy' */ (void) TclGetStringFromObj(dir, &cwdLen); - cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* Normalize the combined string. */ if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) { /* @@ -1829,26 +1767,26 @@ /* * ... but in most cases where we join a trouble free tail to a * normalized head, we can more efficiently normalize the combined * path by passing over only the unnormalized tail portion. When * this is sufficient, prior developers claim this should be much - * faster. We use 'cwdLen-1' so that we are already pointing at + * faster. We use 'cwdLen' so that we are already pointing at * the dir-separator that we know about. The normalization code * will actually start off directly after that separator. */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1); + TclFSNormalizeToUniquePath(interp, copy, cwdLen); } /* Now we need to construct the new path object. */ if (pathType == TCL_PATH_RELATIVE) { Tcl_Obj *origDir = fsPathPtr->cwdPtr; /* * NOTE: here we are (dangerously?) assuming that origDir points - * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The + * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); * above that set the pathType value should have established that, * but it's far less clear on what basis we know there's been no * shimmering since then. */ @@ -1862,10 +1800,11 @@ fsPathPtr->normPathPtr = copy; /* * That's our reference to copy used. */ + copy = NULL; TclDecrRefCount(dir); TclDecrRefCount(origDir); } else { TclDecrRefCount(fsPathPtr->cwdPtr); @@ -1874,11 +1813,11 @@ fsPathPtr->normPathPtr = copy; /* * That's our reference to copy used. */ - + copy = NULL; TclDecrRefCount(dir); } PATHFLAGS(pathPtr) = 0; } @@ -1886,14 +1825,12 @@ * Ensure cwd hasn't changed. */ if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } fsPathPtr = PATHOBJ(pathPtr); } else if (fsPathPtr->normPathPtr == NULL) { @@ -1915,11 +1852,10 @@ Tcl_IncrRefCount(fsPathPtr->normPathPtr); } } if (fsPathPtr->normPathPtr == NULL) { Tcl_Obj *useThisCwd = NULL; - int pureNormalized = 1; /* * Since normPathPtr is NULL, but this is a valid path object, we know * that the translatedPathPtr cannot be NULL. */ @@ -1965,11 +1901,10 @@ if (useThisCwd == NULL) { return NULL; } - pureNormalized = 0; Tcl_DecrRefCount(absolutePath); absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); /* @@ -1985,48 +1920,24 @@ absolutePath = TclWinVolumeRelativeNormalize(interp, path, &useThisCwd); if (absolutePath == NULL) { return NULL; } - pureNormalized = 0; #endif /* _WIN32 */ } } /* * Already has refCount incremented. */ + if (fsPathPtr->normPathPtr) { + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + } fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath); - /* - * Check if path is pure normalized (this can only be the case if it - * is an absolute path). - */ - - if (pureNormalized) { - int normPathLen, pathLen; - const char *normPath; - - path = TclGetStringFromObj(pathPtr, &pathLen); - normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen); - if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) { - /* - * The path was already normalized. Get rid of the duplicate. - */ - - TclDecrRefCount(fsPathPtr->normPathPtr); - - /* - * We do *not* increment the refCount for this circular - * reference. - */ - - fsPathPtr->normPathPtr = pathPtr; - } - } if (useThisCwd != NULL) { /* * We just need to free an object we allocated above for relative * paths (this was returned by Tcl_FSJoinToPath above), and then * of course store the cwd. @@ -2168,12 +2079,13 @@ TclFSEnsureEpochOk( Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr) { FsPath *srcFsPathPtr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr != &tclFsPathType) { + if (irPtr == NULL) { return TCL_OK; } srcFsPathPtr = PATHOBJ(pathPtr); @@ -2185,14 +2097,12 @@ if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) { /* * We have to discard the stale representation and recalculate it. */ - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } srcFsPathPtr = PATHOBJ(pathPtr); } @@ -2228,16 +2138,17 @@ Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr, ClientData clientData) { FsPath *srcFsPathPtr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);; /* * Make sure pathPtr is of the correct type. */ - if (pathPtr->typePtr != &tclFsPathType) { + if (irPtr == NULL) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } } @@ -2331,12 +2242,13 @@ { int len; FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { return TCL_OK; } /* * First step is to translate the filename. This is similar to @@ -2475,12 +2387,14 @@ */ fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = transPtr; - if (transPtr != pathPtr) { + if (fsPathPtr->translatedPathPtr != NULL) { Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + } + if (transPtr != pathPtr) { /* Redo translation when $env(HOME) changes */ fsPathPtr->filesystemEpoch = TclFSEpoch(); } else { fsPathPtr->filesystemEpoch = 0; } @@ -2487,18 +2401,12 @@ fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; - /* - * Free old representation before installing our new one. - */ - - TclFreeIntRep(pathPtr); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return TCL_OK; } static void FreeFsPathInternalRep( @@ -2517,10 +2425,11 @@ } fsPathPtr->normPathPtr = NULL; } if (fsPathPtr->cwdPtr != NULL) { TclDecrRefCount(fsPathPtr->cwdPtr); + fsPathPtr->cwdPtr = NULL; } if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) { Tcl_FSFreeInternalRepProc *freeProc = fsPathPtr->fsPtr->freeInternalRepProc; @@ -2529,11 +2438,10 @@ fsPathPtr->nativePathPtr = NULL; } } ckfree(fsPathPtr); - pathPtr->typePtr = NULL; } static void DupFsPathInternalRep( Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */ @@ -2542,28 +2450,18 @@ FsPath *srcFsPathPtr = PATHOBJ(srcPtr); FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath)); SETPATHOBJ(copyPtr, copyFsPathPtr); - if (srcFsPathPtr->translatedPathPtr == srcPtr) { - /* Cycle in src -> make cycle in copy. */ - copyFsPathPtr->translatedPathPtr = copyPtr; - } else { - copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); - } - } - - if (srcFsPathPtr->normPathPtr == srcPtr) { - /* Cycle in src -> make cycle in copy. */ - copyFsPathPtr->normPathPtr = copyPtr; - } else { - copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); - } + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + if (copyFsPathPtr->translatedPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); + } + + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); } copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; if (copyFsPathPtr->cwdPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); @@ -2585,12 +2483,10 @@ } else { copyFsPathPtr->nativePathPtr = NULL; } copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; - - copyPtr->typePtr = &tclFsPathType; } /* *--------------------------------------------------------------------------- * @@ -2618,15 +2514,19 @@ if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); } copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); + if (Tcl_IsShared(copy)) { + copy = Tcl_DuplicateObj(copy); + } + Tcl_IncrRefCount(copy); + /* Steal copy's string rep */ pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - copy->bytes = &tclEmptyString; - copy->length = 0; + TclInitStringRep(copy, NULL, 0); TclDecrRefCount(copy); } /* *--------------------------------------------------------------------------- @@ -2652,18 +2552,20 @@ int TclNativePathInFilesystem( Tcl_Obj *pathPtr, ClientData *clientDataPtr) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + /* * A special case is required to handle the empty path "". This is a valid * path (i.e. the user should be able to do 'file exists ""' without * throwing an error), but equally the path doesn't exist. Those are the * semantics of Tcl (at present anyway), so we have to abide by them here. */ - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". */ @@ -2674,11 +2576,11 @@ * Otherwise there is no way this path can be empty. */ } else { /* * It is somewhat unusual to reach this code path without the object - * being of tclFsPathType. However, we do our best to deal with the + * being of fsPathType. However, we do our best to deal with the * situation. */ int len; Index: generic/tclPkg.c ================================================================== --- generic/tclPkg.c +++ generic/tclPkg.c @@ -416,11 +416,11 @@ void *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion; + char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ int availStable, code, satisfies, pass; char *script, *pkgVersionI; Tcl_DString command; @@ -464,10 +464,11 @@ */ bestPtr = NULL; bestStablePtr = NULL; bestVersion = NULL; + bestStableVersion = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { @@ -478,63 +479,85 @@ */ continue; } - if (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); - - /* - * Note: Use internal reps! - */ - - if (res <= 0) { - /* - * The version of the package sought is not as good as the - * currently selected version. Ignore it. - */ - - ckfree(availVersion); - availVersion = NULL; - continue; - } - } - - /* - * We have found a version which is better than our max. - */ - + /* Check satisfaction of requirements before considering the current version further. */ if (reqc > 0) { - /* Check satisfaction of requirements. */ - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { ckfree(availVersion); availVersion = NULL; continue; } } - bestPtr = availPtr; - - if (bestVersion != NULL) { - ckfree(bestVersion); - } - bestVersion = availVersion; - - /* - * If this new best version is stable then it also has to be - * better than the max stable version found so far. - */ - - if (availStable) { + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + + if (res > 0) { + /* + * The version of the package sought is better than the + * currently selected version. + */ + goto newbest; + } + } else { + newbest: + /* We have found a version which is better than our max. */ + + bestPtr = availPtr; + CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); + } + + if (!availStable) { + ckfree(availVersion); + availVersion = NULL; + continue; + } + + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + + if (res > 0) { + /* + * This stable version of the package sought is better + * than the currently selected stable version. + */ + goto newstable; + } + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - } + + ckfree(availVersion); + availVersion = NULL; + } /* end for */ + + /* + * Clean up memorized internal reps, if any. + */ if (bestVersion != NULL) { ckfree(bestVersion); + bestVersion = NULL; + } + + if (bestStableVersion != NULL) { + ckfree(bestStableVersion); + bestStableVersion = NULL; } /* * Now choose a version among the two best. For 'latest' we simply * take (actually keep) the best. For 'stable' we take the best Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -13,10 +13,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" +#include /* * Variables that are part of the [apply] command implementation and which * have to be passed to the other side of the NRE call. */ @@ -65,10 +66,26 @@ * instead. */ NULL /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ }; +#define ProcSetIntRep(objPtr, procPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (procPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \ + } while (0) + +#define ProcGetIntRep(objPtr, procPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclProcBodyType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The [upvar]/[uplevel] level reference type. Uses the longValue field * to remember the integer value of a parsed # format. * * Uses the default behaviour throughout, and never disposes of the string @@ -87,17 +104,35 @@ * Internally, ptr1 is a pointer to a Proc instance that is not bound to a * command name, and ptr2 is a pointer to the namespace that the Proc instance * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ -const Tcl_ObjType tclLambdaType = { +static const Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; + +#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = (nsObjPtr); \ + Tcl_IncrRefCount((nsObjPtr)); \ + Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \ + } while (0) + +#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &lambdaType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- * * Tcl_ProcObjCmd -- @@ -122,15 +157,14 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - const char *fullName; - const char *procName, *procArgs, *procBody; + const char *procName; + const char *simpleName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; - Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } @@ -139,66 +173,43 @@ * Determine the namespace where the procedure should reside. Unless the * command name includes namespace qualifiers, this will be the current * namespace. */ - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } /* * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3], &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, simpleName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } - /* - * Now create a command for the procedure. This will initially be in the - * current namespace unless the procedure's name included namespace - * qualifiers. To create the new command in the right namespace, we - * generate a fully qualified name for it. - */ - - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, - TclNRInterpProc, procPtr, TclProcDeleteProc); - Tcl_DStringFree(&ds); + cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, + TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); /* * Now initialize the new procedure's cmdPtr field. This will be used * later when the procedure is called to determine what namespace the * procedure will run in. This will be different than the current @@ -316,11 +327,11 @@ * - could be enhanced to handle also non-empty bodies that contain only * comments; however, parsing the body will slow down the compilation * of all procs whose argument list is just _args_ */ - if (objv[3]->typePtr == &tclProcBodyType) { + if (Tcl_FetchIntRep(objv[3], &tclProcBodyType)) { goto done; } procArgs = TclGetString(objv[2]); @@ -391,20 +402,21 @@ Tcl_Obj *argsPtr, /* Description of arguments. */ Tcl_Obj *bodyPtr, /* Command body. */ Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - const char **argArray = NULL; - register Proc *procPtr; - int i, length, result, numArgs; - const char *args, *bytes, *p; + register Proc *procPtr = NULL; + int i, result, numArgs, plen; + const char *bytes, *argname, *argnamei; + char argnamelast; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; - if (bodyPtr->typePtr == &tclProcBodyType) { + ProcGetIntRep(bodyPtr, procPtr); + if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to * unshare it (as a matter of fact, it is bad to unshare it, because * there may be no source code). @@ -413,11 +425,10 @@ * rather, we use what is in the body object. We increment the ref * count of the Proc struct since the command (soon to be created) * will be holding a reference to it. */ - procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; } else { /* @@ -434,10 +445,11 @@ * identical. Note that we don't use Tcl_DuplicateObj since we would * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); @@ -471,16 +483,13 @@ /* * Break up the argument list into argument specifiers, then process each * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = TclGetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } if (precompiled) { @@ -500,77 +509,74 @@ } for (i = 0; i < numArgs; i++) { int fieldCount, nameLength; size_t valueLength; - const char **fieldValues; + Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many fields in argument specifier \"%s\"", - argArray[i])); + errorObj = Tcl_NewStringObj( + "too many fields in argument specifier \"", -1); + Tcl_AppendObjToObj(errorObj, argArray[i]); + Tcl_AppendToObj(errorObj, "\"", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); + if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - nameLength = strlen(fieldValues[0]); + nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); + valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), + fieldValues[1]->length); } else { valueLength = 0; } /* * Check that the formal parameter name is a scalar. */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* We have an array element. */ + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + argnamei = argname; + argnamelast = argname[plen-1]; + while (plen--) { + if (argnamei[0] == '(') { + if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is not a simple name", - fieldValues[0])); - ckfree(fieldValues); + } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { + errorObj = Tcl_NewStringObj("formal parameter \"", -1); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - p++; + argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { /* * Compare the parsed argument with the stored one. Note that the @@ -582,19 +588,18 @@ * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) + || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } @@ -605,16 +610,17 @@ if (localPtr->defValuePtr != NULL) { const char *tmpPtr = TclGetString(localPtr->defValuePtr); size_t tmpLength = localPtr->defValuePtr->length; if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); + Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { + errorObj = Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"" ,procName); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" has " + "default value inconsistent with precompiled body", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } } @@ -630,44 +636,40 @@ /* * Allocate an entry in the runtime procedure frame's array of * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; + localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length); localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); + localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } } - - ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree(argArray); return TCL_OK; procError: if (precompiled) { procPtr->refCount--; @@ -684,13 +686,10 @@ ckfree(localPtr); } ckfree(procPtr); } - if (argArray != NULL) { - ckfree(argArray); - } return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -803,10 +802,11 @@ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; + const Tcl_ObjIntRep *irPtr; const char *name = NULL; /* * Parse object to figure out which level number to go to. */ @@ -823,20 +823,21 @@ /* Do nothing */ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) && (level >= 0)) { level = curLevel - level; result = 1; - } else if (objPtr->typePtr == &levelReferenceType) { - level = (int) objPtr->internalRep.longValue; + } else if ((irPtr = Tcl_FetchIntRep(objPtr, &levelReferenceType))) { + level = irPtr->longValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.longValue = level; + Tcl_ObjIntRep ir; + + ir.longValue = level; + Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir); result = 1; } else { result = -1; } } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ @@ -1154,14 +1155,14 @@ Var *varPtr = framePtr->compiledLocals; Tcl_Obj *bodyPtr; ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; - if (bodyPtr->typePtr != &tclByteCodeType) { + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + if (codePtr == NULL) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { InitLocalCache(framePtr->procPtr) ; } @@ -1320,19 +1321,21 @@ static void InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; Tcl_Obj **namePtr; Var *varPtr; LocalCache *localCachePtr; CompiledLocal *localPtr; int new; + + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); /* * Cache the names and initial values of local variables; store the * cache in both the framePtr for this execution and in the codePtr * for future calls. @@ -1397,14 +1400,16 @@ int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; + + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); /* * Make sure that the local cache of variable names and initial values has * been initialised properly . */ @@ -1576,11 +1581,12 @@ * slots for the procedure's non-argument local variables. Note that * compiling the body might increase procPtr->numCompiledLocals if new * local variables are found while compiling. */ - if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { Interp *iPtr = (Interp *) interp; /* * When we've got bytecode, this is the check for validity. That is, * the bytecode must be for the right interpreter (no cross-leaks!), @@ -1588,11 +1594,10 @@ * is up-to-date), the namespace must match (so variable handling * is right) and the resolverEpoch must match (so that new shadowed * commands and/or resolver changes are considered). */ - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { goto doCompilation; @@ -1786,11 +1791,11 @@ /* * Invoke the commands in the procedure's body. */ procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); } @@ -1920,11 +1925,13 @@ const char *description, /* string describing this body of code. */ const char *procName) /* Name of this procedure. */ { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); /* * If necessary, compile the procedure's body. The compiler will allocate * frame slots for the procedure's non-argument local variables. If the * ByteCode already exists, make sure it hasn't been invalidated by @@ -1936,11 +1943,11 @@ * * Precompiled procedure bodies, however, are immutable and therefore they * are not recompiled, even if things have changed. */ - if (bodyPtr->typePtr == &tclByteCodeType) { + if (codePtr != NULL) { if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { return TCL_OK; @@ -1955,15 +1962,16 @@ return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - TclFreeIntRep(bodyPtr); + Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL); + codePtr = NULL; } } - if (bodyPtr->typePtr != &tclByteCodeType) { + if (codePtr == NULL) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* @@ -2308,14 +2316,11 @@ return NULL; } TclNewObj(objPtr); if (objPtr) { - objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - - procPtr->refCount++; + ProcSetIntRep(objPtr, procPtr); } return objPtr; } @@ -2339,15 +2344,14 @@ static void ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + ProcGetIntRep(srcPtr, procPtr); - dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; - procPtr->refCount++; + ProcSetIntRep(dupPtr, procPtr); } /* *---------------------------------------------------------------------- * @@ -2369,11 +2373,13 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + + ProcGetIntRep(objPtr, procPtr); if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } } @@ -2395,34 +2401,36 @@ static void DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; - copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); procPtr->refCount++; - Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &tclLambdaType; + + LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); } static void FreeLambdaInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); if (procPtr->refCount-- == 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); - objPtr->typePtr = NULL; } static int SetLambdaFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ @@ -2439,11 +2447,11 @@ return TCL_ERROR; } /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to tclLambdaType. + * length is not 2, then it cannot be converted to lambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2580,25 +2588,46 @@ } else { nsObjPtr = objv[2]; } } - Tcl_IncrRefCount(nsObjPtr); - /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to tclLambdaType. + * conversion to lambdaType. */ - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &tclLambdaType; + LambdaSetIntRep(objPtr, procPtr, nsObjPtr); return TCL_OK; } + +Proc * +TclGetLambdaFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Obj **nsObjPtrPtr) +{ + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + + if (procPtr == NULL) { + if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { + return NULL; + } + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + } + + assert(procPtr != NULL); + if (procPtr->iPtr != (Interp *)interp) { + return NULL; + } + + *nsObjPtrPtr = nsObjPtr; + return procPtr; +} /* *---------------------------------------------------------------------- * * Tcl_ApplyObjCmd -- @@ -2630,11 +2659,10 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; int result; Tcl_Namespace *nsPtr; ApplyExtraData *extraPtr; @@ -2648,28 +2676,21 @@ * Set lambdaPtr, convert it to tclLambdaType in the current interp if * necessary. */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &tclLambdaType) { - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; - } - - if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { - result = SetLambdaFromAny(interp, lambdaPtr); - if (result != TCL_OK) { - return result; - } - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr); + + if (procPtr == NULL) { + return TCL_ERROR; } /* - * Find the namespace where this lambda should run, and push a call frame - * for that namespace. Note that TclObjInterpProc() will pop it. + * Push a call frame for the lambda namespace. + * Note that TclObjInterpProc() will pop it. */ - nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return TCL_ERROR; } Index: generic/tclRegexp.c ================================================================== --- generic/tclRegexp.c +++ generic/tclRegexp.c @@ -11,10 +11,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclRegexp.h" +#include /* *---------------------------------------------------------------------- * The routines in this file use Henry Spencer's regular expression package * contained in the following additional source files: @@ -105,10 +106,27 @@ FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; + +#define RegexpSetIntRep(objPtr, rePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (rePtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (rePtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \ + } while (0) + +#define RegexpGetIntRep(objPtr, rePtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclRegexpType); \ + (rePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- * * Tcl_RegExpCompile -- @@ -578,40 +596,21 @@ { int length; TclRegexp *regexpPtr; const char *pattern; - /* - * This is OK because we only actually interpret this value properly as a - * TclRegexp* when the type is tclRegexpType. - */ - - regexpPtr = objPtr->internalRep.twoPtrValue.ptr1; - - if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { + RegexpGetIntRep(objPtr, regexpPtr); + + if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); if (regexpPtr == NULL) { return NULL; } - /* - * Add a reference to the regexp so it will persist even if it is - * pushed out of the current thread's regexp cache. This reference - * will be removed when the object's internal rep is freed. - */ - - regexpPtr->refCount++; - - /* - * Free the old representation and set our type. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr; - objPtr->typePtr = &tclRegexpType; + RegexpSetIntRep(objPtr, regexpPtr); } return (Tcl_RegExp) regexpPtr; } /* @@ -754,20 +753,23 @@ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { - TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1; + TclRegexp *regexpRepPtr; + + RegexpGetIntRep(objPtr, regexpRepPtr); + + assert(regexpRepPtr != NULL); /* * If this is the last reference to the regexp, free it. */ if (regexpRepPtr->refCount-- <= 1) { FreeRegexp(regexpRepPtr); } - objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -788,15 +790,17 @@ static void DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1; + TclRegexp *regexpPtr; + + RegexpGetIntRep(srcPtr, regexpPtr); + + assert(regexpPtr != NULL); - regexpPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->typePtr = &tclRegexpType; + RegexpSetIntRep(copyPtr, regexpPtr); } /* *---------------------------------------------------------------------- * Index: generic/tclScan.c ================================================================== --- generic/tclScan.c +++ generic/tclScan.c @@ -883,13 +883,21 @@ case 'c': /* * Scan a single Unicode character. */ - string += TclUtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); + i = (int)sch; +#if TCL_UTF_MAX == 4 + if (!offset) { + offset = TclUtfToUniChar(string, &sch); + i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); + } +#endif + string += offset; if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj((int)sch); + objPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } break; @@ -982,12 +990,14 @@ string = end; } else { double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN - if (objPtr->typePtr == &tclDoubleType) { - dvalue = objPtr->internalRep.doubleValue; + const Tcl_ObjIntRep *irPtr + = Tcl_FetchIntRep(objPtr, &tclDoubleType); + if (irPtr) { + dvalue = irPtr->doubleValue; } else #endif { Tcl_DecrRefCount(objPtr); goto done; Index: generic/tclStringObj.c ================================================================== --- generic/tclStringObj.c +++ generic/tclStringObj.c @@ -416,16 +416,20 @@ /* 0 bytes -> 0 chars; 1 byte -> 1 char */ return objPtr->length; } /* - * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the get-length operation. + * Optimize the case where we're really dealing with a bytearray object; + * we don't need to convert to a string to perform the get-length operation. + * + * NOTE that we do not need the bytearray to be "pure". A ByteArray value + * with a string rep cannot be trusted to represent the same value as the + * string rep, but it *can* be trusted to have the same character length + * as the string rep, which is all this routine cares about. */ - if (TclIsPureByteArray(objPtr)) { + if (objPtr->typePtr == &tclByteArrayType) { int length; (void) Tcl_GetByteArrayFromObj(objPtr, &length); return length; } @@ -1867,32 +1871,32 @@ #endif } } else if (ch == 'I') { if ((format[1] == '6') && (format[2] == '4')) { format += (step + 2); - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif } else if ((format[1] == '3') && (format[2] == '2')) { format += (step + 2); - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } else { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } } else if ((ch == 't') || (ch == 'z')) { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG if (sizeof(size_t) > sizeof(int)) { useWide = 1; } #endif } else if ((ch == 'q') ||(ch == 'j')) { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif } @@ -3240,44 +3244,48 @@ try++; } return -1; } + /* + * Check if we have two strings of single-byte characters. If we have, we + * can use strstr() to do the search. Note that we can sometimes have + * multibyte characters when the string could be minimally represented + * using single byte characters; we can't assume that a mismatch here + * means no match. + */ + lh = Tcl_GetCharLength(haystack); - if (haystack->bytes && (lh == haystack->length)) { - /* haystack is all single-byte chars */ - - if (needle->bytes && (ln == needle->length)) { - /* needle is also all single-byte chars */ - char *found = strstr(haystack->bytes + start, needle->bytes); - - if (found) { - return (found - haystack->bytes); - } else { - return -1; - } - } else { - /* - * Cannot find substring with a multi-byte char inside - * a string with no multi-byte chars. - */ + if (haystack->bytes && (lh == haystack->length) && needle->bytes + && (ln == needle->length)) { + /* + * Both haystack and needle are all single-byte chars. + */ + + char *found = strstr(haystack->bytes + start, needle->bytes); + + if (found) { + return (found - haystack->bytes); + } else { return -1; } } else { + /* + * Do the search on the unicode representation for simplicity. + */ + Tcl_UniChar *try, *end, *uh; Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); uh = Tcl_GetUnicodeFromObj(haystack, &lh); end = uh + lh; - try = uh + start; - while (try + ln <= end) { - if ((*try == *un) - && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { + for (try = uh + start; try + ln <= end; try++) { + if ((*try == *un) && (0 == + memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { return (try - uh); } - try++; } return -1; } } @@ -3456,11 +3464,10 @@ /* * Create a non-empty, pure unicode value, so we can coax * Tcl_SetObjLength into growing the unicode rep buffer. */ - ch = 0; objPtr = Tcl_NewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); while (--src >= from) { *to++ = *src; @@ -3559,11 +3566,11 @@ int numBytes, int numAppendChars) { String *stringPtr = GET_STRING(objPtr); int needed, numOrigChars = 0; - Tcl_UniChar *dst; + Tcl_UniChar *dst, unichar = 0; if (stringPtr->hasUnicode) { numOrigChars = stringPtr->numChars; } if (numAppendChars == -1) { @@ -3582,11 +3589,12 @@ stringPtr->numChars = needed; } else { numAppendChars = 0; } for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { - bytes += TclUtfToUniChar(bytes, dst); + bytes += TclUtfToUniChar(bytes, &unichar); + *dst = unichar; } *dst = 0; } /* @@ -3744,11 +3752,11 @@ */ stringPtr->allocated = 0; if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, &tclEmptyString, 0); + TclInitStringRep(objPtr, NULL, 0); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); } } Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -364,10 +364,30 @@ # undef Tcl_GlobalEvalObj # define Tcl_GlobalEvalObj 0 # define TclBackgroundException 0 # undef TclpReaddir # define TclpReaddir 0 +# define TclSetStartupScript 0 +# define TclGetStartupScript 0 +# define TclCreateNamespace 0 +# define TclDeleteNamespace 0 +# define TclAppendExportList 0 +# define TclExport 0 +# define TclImport 0 +# define TclForgetImport 0 +# define TclGetCurrentNamespace_ 0 +# define TclGetGlobalNamespace_ 0 +# define TclFindNamespace 0 +# define TclFindCommand 0 +# define TclGetCommandFromObj 0 +# define TclGetCommandFullName 0 +# define TclCopyChannelOld 0 +# define Tcl_AppendResultVA 0 +# define Tcl_AppendStringsToObjVA 0 +# define Tcl_SetErrorCodeVA 0 +# define Tcl_PanicVA 0 +# define Tcl_VarEvalVA 0 # undef TclpGetDate # define TclpGetDate 0 # undef TclpLocaltime # define TclpLocaltime 0 # undef TclpGmtime @@ -376,10 +396,24 @@ # define TclpGmtime_unix 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld # define TclBackgroundException Tcl_BackgroundException +# define TclSetStartupScript Tcl_SetStartupScript +# define TclGetStartupScript Tcl_GetStartupScript +# define TclCreateNamespace Tcl_CreateNamespace +# define TclDeleteNamespace Tcl_DeleteNamespace +# define TclAppendExportList Tcl_AppendExportList +# define TclExport Tcl_Export +# define TclImport Tcl_Import +# define TclForgetImport Tcl_ForgetImport +# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace +# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace +# define TclFindNamespace Tcl_FindNamespace +# define TclFindCommand Tcl_FindCommand +# define TclGetCommandFromObj Tcl_GetCommandFromObj +# define TclGetCommandFullName Tcl_GetCommandFullName # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime static int seekOld( @@ -528,26 +562,26 @@ 0, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - Tcl_AppendExportList, /* 112 */ - Tcl_CreateNamespace, /* 113 */ - Tcl_DeleteNamespace, /* 114 */ - Tcl_Export, /* 115 */ - Tcl_FindCommand, /* 116 */ - Tcl_FindNamespace, /* 117 */ + TclAppendExportList, /* 112 */ + TclCreateNamespace, /* 113 */ + TclDeleteNamespace, /* 114 */ + TclExport, /* 115 */ + TclFindCommand, /* 116 */ + TclFindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - Tcl_ForgetImport, /* 121 */ - Tcl_GetCommandFromObj, /* 122 */ - Tcl_GetCommandFullName, /* 123 */ - Tcl_GetCurrentNamespace, /* 124 */ - Tcl_GetGlobalNamespace, /* 125 */ + TclForgetImport, /* 121 */ + TclGetCommandFromObj, /* 122 */ + TclGetCommandFullName, /* 123 */ + TclGetCurrentNamespace_, /* 124 */ + TclGetGlobalNamespace_, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - Tcl_Import, /* 127 */ + TclImport, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ TclpHasSockets, /* 132 */ @@ -594,12 +628,12 @@ TclUniCharMatch, /* 173 */ 0, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - Tcl_SetStartupScript, /* 178 */ - Tcl_GetStartupScript, /* 179 */ + TclSetStartupScript, /* 178 */ + TclGetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ TclpLocaltime, /* 182 */ TclpGmtime, /* 183 */ 0, /* 184 */ @@ -1534,8 +1568,13 @@ Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ Tcl_OpenTcpServerEx, /* 631 */ + Tcl_FreeIntRep, /* 632 */ + Tcl_InitStringRep, /* 633 */ + Tcl_FetchIntRep, /* 634 */ + Tcl_StoreIntRep, /* 635 */ + Tcl_HasStringRep, /* 636 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -421,10 +421,16 @@ static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; static int TestNumUtfCharsCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestFindFirstCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestFindLastCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -690,10 +696,14 @@ NULL, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testnumutfchars", TestNumUtfCharsCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfindfirst", + TestFindFirstCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfindlast", + TestFindLastCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, @@ -6882,10 +6892,54 @@ len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); } return TCL_OK; } + +/* + * Used to check correct operation of Tcl_UtfFindFirst + */ + +static int +TestFindFirstCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 1) { + int len = -1; + + if (objc > 2) { + (void) Tcl_GetIntFromObj(interp, objv[2], &len); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1)); + } + return TCL_OK; +} + +/* + * Used to check correct operation of Tcl_UtfFindLast + */ + +static int +TestFindLastCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 1) { + int len = -1; + + if (objc > 2) { + (void) Tcl_GetIntFromObj(interp, objv[2], &len); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1)); + } + return TCL_OK; +} #if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * @@ -7167,21 +7221,15 @@ emptyPtr = Tcl_NewObj(); list1Ptr = Tcl_NewStringObj("foo bar sum", -1); Tcl_ListObjLength(NULL, list1Ptr, &len); - if (list1Ptr->bytes != NULL) { - ckfree(list1Ptr->bytes); - list1Ptr->bytes = NULL; - } + Tcl_InvalidateStringRep(list1Ptr); list2Ptr = Tcl_NewStringObj("eeny meeny", -1); Tcl_ListObjLength(NULL, list2Ptr, &len); - if (list2Ptr->bytes != NULL) { - ckfree(list2Ptr->bytes); - list2Ptr->bytes = NULL; - } + Tcl_InvalidateStringRep(list2Ptr); /* * Verify that concat'ing a list obj with one or more empty strings does * return a fresh Tcl_Obj (see also [Bug 2055782]). */ Index: generic/tclTimer.c ================================================================== --- generic/tclTimer.c +++ generic/tclTimer.c @@ -787,11 +787,11 @@ Tcl_WideInt ms = 0; /* Number of milliseconds to wait */ Tcl_Time wakeup; AfterInfo *afterPtr; AfterAssocData *assocPtr; int length; - int index; + int index = -1; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL }; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); @@ -816,19 +816,13 @@ /* * First lets see if the command was passed a number as the first argument. */ - if (objv[1]->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG - || objv[1]->typePtr == &tclWideIntType -#endif - || objv[1]->typePtr == &tclBignumType - || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, - &index) != TCL_OK)) { - index = -1; - if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) + != TCL_OK) { const char *arg = Tcl_GetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be" " cancel, idle, info, or an integer", arg)); Index: generic/tclUtf.c ================================================================== --- generic/tclUtf.c +++ generic/tclUtf.c @@ -92,11 +92,11 @@ *--------------------------------------------------------------------------- */ int TclUtfCount( - int ch) /* The Tcl_UniChar whose size is returned. */ + int ch) /* The Unicode character whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { return 1; } if (ch <= 0x7FF) { @@ -396,11 +396,11 @@ * strlen(). */ Tcl_DString *dsPtr) /* Unicode representation of string is * appended to this previously initialized * DString. */ { - Tcl_UniChar ch, *w, *wString; + Tcl_UniChar ch = 0, *w, *wString; const char *p, *end; int oldLength; if (length < 0) { length = strlen(src); @@ -520,17 +520,17 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfFindFirst -- * - * Returns a pointer to the first occurance of the given Tcl_UniChar in - * the NULL-terminated UTF-8 string. The NULL terminator is considered + * Returns a pointer to the first occurance of the given Unicode character + * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, the - * return value is NULL. + * As above. If the Unicode character does not exist in the given string, + * the return value is NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -537,18 +537,25 @@ */ const char * Tcl_UtfFindFirst( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Tcl_UniChar to search for. */ + int ch) /* The Unicode character to search for. */ { - int len; + int len, fullchar; Tcl_UniChar find = 0; while (1) { len = TclUtfToUniChar(src, &find); - if (find == ch) { + fullchar = find; +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(src, &find); + fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; + } +#endif + if (fullchar == ch) { return src; } if (*src == '\0') { return NULL; } @@ -559,16 +566,16 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfFindLast -- * - * Returns a pointer to the last occurance of the given Tcl_UniChar in - * the NULL-terminated UTF-8 string. The NULL terminator is considered + * Returns a pointer to the last occurance of the given Unicode character + * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, the + * As above. If the Unicode character does not exist in the given string, the * return value is NULL. * * Side effects: * None. * @@ -576,20 +583,27 @@ */ const char * Tcl_UtfFindLast( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Tcl_UniChar to search for. */ + int ch) /* The Unicode character to search for. */ { - int len; + int len, fullchar; Tcl_UniChar find = 0; const char *last; last = NULL; while (1) { len = TclUtfToUniChar(src, &find); - if (find == ch) { + fullchar = find; +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(src, &find); + fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; + } +#endif + if (fullchar == ch) { last = src; } if (*src == '\0') { break; } @@ -685,11 +699,11 @@ /* *--------------------------------------------------------------------------- * * Tcl_UniCharAtIndex -- * - * Returns the Unicode character represented at the specified character + * Returns the Tcl_UniChar represented at the specified character * (not byte) position in the UTF-8 string. * * Results: * As above. * @@ -704,12 +718,11 @@ register const char *src, /* The UTF-8 string to dereference. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; - while (index >= 0) { - index--; + while (index-- >= 0) { src += TclUtfToUniChar(src, &ch); } return ch; } @@ -735,12 +748,11 @@ register const char *src, /* The UTF-8 string. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; - while (index > 0) { - index--; + while (index-- > 0) { src += TclUtfToUniChar(src, &ch); } return src; } @@ -1051,10 +1063,20 @@ */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif return (ch1 - ch2); } } return 0; } @@ -1082,33 +1104,90 @@ const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ unsigned long numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; + while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. * This should be called only when both strings are of * at least n chars long (no need for \0 check) */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return (ch1 - ch2); } } } return 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfCmp -- + * + * Compare UTF chars of string cs to string ct case sensitively. + * Replacement for strcmp in Tcl core, in places where UTF-8 should + * be handled. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUtfCmp( + const char *cs, /* UTF string to compare to ct. */ + const char *ct) /* UTF string cs is compared to. */ +{ + Tcl_UniChar ch1 = 0, ch2 = 0; + + while (*cs && *ct) { + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif + return ch1 - ch2; + } + } + return UCHAR(*cs) - UCHAR(*ct); +} + /* *---------------------------------------------------------------------- * - * Tcl_UtfNcasecmp -- + * TclUtfCasecmp -- * * Compare UTF chars of string cs to string ct case insensitively. * Replacement for strcasecmp in Tcl core, in places where UTF-8 should * be handled. * @@ -1124,16 +1203,26 @@ int TclUtfCasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct) /* UTF string cs is compared to. */ { - while (*cs && *ct) { - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; + while (*cs && *ct) { cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return ch1 - ch2; } Index: generic/tclUtil.c ================================================================== --- generic/tclUtil.c +++ generic/tclUtil.c @@ -106,13 +106,12 @@ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); -static int SetEndOffsetFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); +static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue, + int *indexPtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); @@ -121,16 +120,16 @@ * represents a list index in the form, "end-offset". It is used as a * performance optimization in TclGetIntForIndex. The internal rep is an * integer, so no memory management is required for it. */ -const Tcl_ObjType tclEndOffsetType = { +static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfEndOffset, /* updateStringProc */ - SetEndOffsetFromAny + NULL, /* updateStringProc */ + NULL }; /* * * STRING REPRESENTATION OF LISTS * * * * @@ -972,11 +971,11 @@ const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - int flags = CONVERT_ANY; + char flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; return numBytes; } @@ -1013,11 +1012,11 @@ int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ - int *flagPtr) /* Where to store information to guide + char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { const char *p = src; int nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something @@ -1382,13 +1381,13 @@ /* * No matter what the caller demands, empty string must be braced! */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { - src = &tclEmptyString; - length = 0; - conversion = CONVERT_BRACE; + p[0] = '{'; + p[1] = '}'; + return 2; } /* * Escape leading hash as needed and requested. */ @@ -1545,15 +1544,14 @@ char * Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * Handle empty list case first, so logic of the general case can be * simpler. */ @@ -1568,26 +1566,12 @@ * Pass 1: estimate space, gather flags. */ if (argc <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (argc > maxFlags) { - /* - * We cannot allocate a large enough flag array to format this list in - * one pass. We could imagine converting this routine to a multi-pass - * implementation, but for sizeof(int) == 4, the limit is a max of - * 2^30 list elements and since each element is at least one byte - * formatted, and requires one byte space between it and the next one, - * that a minimum space requirement of 2^31 bytes, which is already - * INT_MAX. If we tried to format a list of > maxFlags elements, we're - * just going to overflow the size limits on the formatted string - * anyway, so just issue that same panic early. - */ - - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(argc * sizeof(int)); + flagPtr = ckalloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); if (bytesNeeded < 0) { @@ -1678,10 +1662,11 @@ const char *trim, /* String of trim characters... */ int numTrim) /* ...and its length in bytes */ { const char *p = bytes + numBytes; int pInc; + Tcl_UniChar ch1 = 0, ch2 = 0; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimRight works only on null-terminated strings"); } @@ -1696,11 +1681,10 @@ /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; const char *q = trim; int bytesLeft = numTrim; p = Tcl_UtfPrev(p, bytes); pInc = TclUtfToUniChar(p, &ch1); @@ -1708,11 +1692,10 @@ /* * Inner loop: scan trim string for match to current character. */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } @@ -1758,10 +1741,11 @@ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ int numTrim) /* ...and its length in bytes */ { const char *p = bytes; + Tcl_UniChar ch1 = 0, ch2 = 0; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimLeft works only on null-terminated strings"); } @@ -1776,21 +1760,19 @@ /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; /* * Inner loop: scan trim string for match to current character. */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } @@ -1975,11 +1957,11 @@ } if (i == objc) { resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (objPtr->bytes && objPtr->length == 0) { + if (!TclListObjIsCanonical(objPtr)) { continue; } if (resPtr) { if (TCL_OK != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { /* Abandon ship! */ @@ -2120,11 +2102,11 @@ * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; const char *pstart = pattern; - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; while (1) { p = *pattern; /* @@ -2230,11 +2212,11 @@ * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { - Tcl_UniChar startChar, endChar; + Tcl_UniChar startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { ch1 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); @@ -2715,11 +2697,11 @@ const char *element) /* String to append. Must be * null-terminated. */ { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); - int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; + char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; int newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); /* * Allocate a larger buffer for the string if the current one isn't large @@ -3590,17 +3572,11 @@ if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { return TCL_OK; } - if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { - /* - * If the object is already an offset from the end of the list, or can - * be converted to one, use it. - */ - - *indexPtr = endValue + objPtr->internalRep.longValue; + if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) { return TCL_OK; } bytes = TclGetString(objPtr); length = objPtr->length; @@ -3663,138 +3639,57 @@ } /* *---------------------------------------------------------------------- * - * UpdateStringOfEndOffset -- - * - * Update the string rep of a Tcl object holding an "end-offset" - * expression. - * - * Results: - * None. - * - * Side effects: - * Stores a valid string in the object's string rep. - * - * This function does NOT free any earlier string rep. If it is called on an - * object that already has a valid string rep, it will leak memory. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfEndOffset( - register Tcl_Obj *objPtr) -{ - char buffer[TCL_INTEGER_SPACE + 5]; - register int len = 3; - - memcpy(buffer, "end", 4); - if (objPtr->internalRep.longValue != 0) { - buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); - } - objPtr->bytes = ckalloc((unsigned) len+1); - memcpy(objPtr->bytes, buffer, (unsigned) len+1); - objPtr->length = len; -} - -/* - *---------------------------------------------------------------------- - * - * SetEndOffsetFromAny -- + * GetEndOffsetFromObj -- * * Look for a string of the form "end[+-]offset" and convert it to an * internal representation holding the offset. * * Results: - * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. + * Tcl return code. * * Side effects: - * If interp is not NULL, stores an error message in the interpreter - * result. + * May store a Tcl_ObjType. * *---------------------------------------------------------------------- */ static int -SetEndOffsetFromAny( - Tcl_Interp *interp, /* Tcl interpreter or NULL */ - Tcl_Obj *objPtr) /* Pointer to the object to parse */ -{ - int offset; /* Offset in the "end-offset" expression */ - register const char *bytes; /* String rep of the object */ - int length; /* Length of the object's string rep */ - - /* - * If it's already the right type, we're fine. - */ - - if (objPtr->typePtr == &tclEndOffsetType) { - return TCL_OK; - } - - /* - * Check for a string rep of the right form. - */ - - bytes = TclGetStringFromObj(objPtr, &length); - if ((*bytes != 'e') || (strncmp(bytes, "end", - (size_t)((length > 3) ? 3 : length)) != 0)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); - } - return TCL_ERROR; - } - - /* - * Convert the string rep. - */ - - if (length <= 3) { - offset = 0; - } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { - /* - * This is our limited string expression evaluator. Pass everything - * after "end-" to Tcl_GetInt, then reverse for offset. - */ - - if (TclIsSpaceProc(bytes[4])) { - goto badIndexFormat; - } - if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { - return TCL_ERROR; - } - if (bytes[3] == '-') { - offset = -offset; - } - } else { - /* - * Conversion failed. Report the error. - */ - - badIndexFormat: - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); - } - return TCL_ERROR; - } - - /* - * The conversion succeeded. Free the old internal rep and set the new - * one. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = offset; - objPtr->typePtr = &tclEndOffsetType; - +GetEndOffsetFromObj( + Tcl_Obj *objPtr, /* Pointer to the object to parse */ + int endValue, /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + int *indexPtr) /* Location filled in with an integer + * representing an index. */ +{ + const Tcl_ObjIntRep *irPtr; + + while (NULL == (irPtr = Tcl_FetchIntRep(objPtr, &endOffsetType))) { + Tcl_ObjIntRep ir; + int length, offset = 0; + const char *bytes = TclGetStringFromObj(objPtr, &length); + + if ((length == 4) || (*bytes != 'e') || (strncmp(bytes, "end", + (size_t)((length > 3) ? 3 : length)) != 0)) { + return TCL_ERROR; + } + if (length > 4) { + if (((bytes[3] != '-') && (bytes[3] != '+')) + || (TclIsSpaceProc(bytes[4])) + || (TCL_OK != Tcl_GetInt(NULL, bytes+4, &offset))) { + return TCL_ERROR; + } + if (bytes[3] == '-') { + offset = -offset; + } + } + ir.longValue = offset; + Tcl_StoreIntRep(objPtr, &endOffsetType, &ir); + } + *indexPtr = endValue + irPtr->longValue; return TCL_OK; } /* *---------------------------------------------------------------------- Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -224,14 +224,53 @@ static const Tcl_ObjType localVarNameType = { "localVarName", FreeLocalVarName, DupLocalVarName, NULL, NULL }; -static const Tcl_ObjType tclParsedVarNameType = { +#define LocalSetIntRep(objPtr, index, namePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + Tcl_Obj *ptr = (namePtr); \ + if (ptr) {Tcl_IncrRefCount(ptr);} \ + ir.twoPtrValue.ptr1 = ptr; \ + ir.twoPtrValue.ptr2 = INT2PTR(index); \ + Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \ + } while (0) + +#define LocalGetIntRep(objPtr, index, name) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &localVarNameType); \ + (name) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \ + } while (0) + +static const Tcl_ObjType parsedVarNameType = { "parsedVarName", FreeParsedVarName, DupParsedVarName, NULL, NULL }; + +#define ParsedSetIntRep(objPtr, arrayPtr, elem) \ + do { \ + Tcl_ObjIntRep ir; \ + Tcl_Obj *ptr1 = (arrayPtr); \ + Tcl_Obj *ptr2 = (elem); \ + if (ptr1) {Tcl_IncrRefCount(ptr1);} \ + if (ptr2) {Tcl_IncrRefCount(ptr2);} \ + ir.twoPtrValue.ptr1 = ptr1; \ + ir.twoPtrValue.ptr2 = ptr2; \ + Tcl_StoreIntRep((objPtr), &parsedVarNameType, &ir); \ + } while (0) + +#define ParsedGetIntRep(objPtr, parsed, array, elem) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &parsedVarNameType); \ + (parsed) = (irPtr != NULL); \ + (array) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (elem) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) Var * TclVarHashCreateVar( TclVarHashTable *tablePtr, @@ -415,13 +454,12 @@ * a variable that has been unset but it only being kept in existence (if * VAR_UNDEFINED) by a trace. * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 - * are 1. The object part1Ptr is converted to one of localVarNameType, - * tclNsVarNameType or tclParsedVarNameType and caches as much of the - * lookup as it can. + * are 1. The object part1Ptr is converted to one of localVarNameType + * or parsedVarNameType and caches as much of the lookup as it can. * When createPart1 is 1, callers must IncrRefCount part1Ptr if they * plan to DecrRefCount it. * *---------------------------------------------------------------------- */ @@ -504,27 +542,26 @@ CallFrame *varFramePtr = iPtr->varFramePtr; register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ const char *errMsg = NULL; int index, parsed = 0; - const Tcl_ObjType *typePtr = part1Ptr->typePtr; + + int localIndex; + Tcl_Obj *namePtr, *arrayPtr, *elem; *arrayPtrPtr = NULL; - if (typePtr == &localVarNameType) { - int localIndex; - - localVarNameTypeHandling: - localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2); + restart: + LocalGetIntRep(part1Ptr, localIndex, namePtr); + if (localIndex >= 0) { if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { /* * Use the cached index if the names coincide. */ - Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1; Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || (namePtr && (checkNamePtr == namePtr))) { varPtr = (Var *) &(varFramePtr->compiledLocals[localIndex]); @@ -533,16 +570,15 @@ } goto doneParsing; } /* - * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed - * parts. + * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts. */ - if (typePtr == &tclParsedVarNameType) { - if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { + ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem); + if (parsed && arrayPtr) { if (part2Ptr != NULL) { /* * ERROR: part1Ptr is already an array element, cannot specify * a part2. */ @@ -552,18 +588,13 @@ noSuchVar, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); } return NULL; } - part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2; - part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; - typePtr = part1Ptr->typePtr; - if (typePtr == &localVarNameType) { - goto localVarNameTypeHandling; - } - } - parsed = 1; + part2Ptr = elem; + part1Ptr = arrayPtr; + goto restart; } if (!parsed) { /* @@ -576,12 +607,10 @@ if (len > 1 && (part1[len - 1] == ')')) { const char *part2 = strchr(part1, '('); if (part2) { - Tcl_Obj *arrayPtr; - if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, needArray, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", @@ -591,17 +620,11 @@ } arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); part2Ptr = Tcl_NewStringObj(part2 + 1, len - (part2 - part1) - 2); - TclFreeIntRep(part1Ptr); - - Tcl_IncrRefCount(arrayPtr); - part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr; - Tcl_IncrRefCount(part2Ptr); - part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr; - part1Ptr->typePtr = &tclParsedVarNameType; + ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr); part1Ptr = arrayPtr; } } } @@ -625,37 +648,46 @@ /* * Cache the newly found variable if possible. */ - TclFreeIntRep(part1Ptr); if (index >= 0) { /* * An indexed local variable. */ Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); - part1Ptr->typePtr = &localVarNameType; - if (part1Ptr != cachedNamePtr) { - part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr; - Tcl_IncrRefCount(cachedNamePtr); - if (cachedNamePtr->typePtr != &localVarNameType - || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) { - TclFreeIntRep(cachedNamePtr); - } + if (part1Ptr == cachedNamePtr) { + cachedNamePtr = NULL; } else { - part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + /* + * [80304238ac] Trickiness here. We will store and incr the + * refcount on cachedNamePtr. Trouble is that it's possible + * (see test var-22.1) for cachedNamePtr to have an intrep + * that contains a stored and refcounted part1Ptr. This + * would be a reference cycle which leads to a memory leak. + * + * The solution here is to wipe away all intrep(s) in + * cachedNamePtr and leave it as string only. This is + * radical and destructive, so a better idea would be welcome. + */ + TclFreeIntRep(cachedNamePtr); + + /* + * Now go ahead and convert it the the "localVarName" type, + * since we suspect at least some use of the value as a + * varname and we want to resolve it quickly. + */ + LocalSetIntRep(cachedNamePtr, index, NULL); } - part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index); + LocalSetIntRep(part1Ptr, index, cachedNamePtr); } else { /* * At least mark part1Ptr as already parsed. */ - part1Ptr->typePtr = &tclParsedVarNameType; - part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; - part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; + ParsedSetIntRep(part1Ptr, NULL, NULL); } donePart1: while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -5510,34 +5542,34 @@ static void FreeLocalVarName( Tcl_Obj *objPtr) { - Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1; + int index; + Tcl_Obj *namePtr; + LocalGetIntRep(objPtr, index, namePtr); + + index++; /* Compiler warning bait. */ if (namePtr) { Tcl_DecrRefCount(namePtr); } - objPtr->typePtr = NULL; } static void DupLocalVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1; + int index; + Tcl_Obj *namePtr; + LocalGetIntRep(srcPtr, index, namePtr); if (!namePtr) { namePtr = srcPtr; } - dupPtr->internalRep.twoPtrValue.ptr1 = namePtr; - Tcl_IncrRefCount(namePtr); - - dupPtr->internalRep.twoPtrValue.ptr2 = - srcPtr->internalRep.twoPtrValue.ptr2; - dupPtr->typePtr = &localVarNameType; + LocalSetIntRep(dupPtr, index, namePtr); } /* * parsedVarName - * @@ -5549,36 +5581,34 @@ static void FreeParsedVarName( Tcl_Obj *objPtr) { - register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2; + register Tcl_Obj *arrayPtr, *elem; + int parsed; + ParsedGetIntRep(objPtr, parsed, arrayPtr, elem); + + parsed++; /* Silence compiler. */ if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); TclDecrRefCount(elem); } - objPtr->typePtr = NULL; } static void DupParsedVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2; - - if (arrayPtr != NULL) { - Tcl_IncrRefCount(arrayPtr); - Tcl_IncrRefCount(elem); - } - - dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; - dupPtr->internalRep.twoPtrValue.ptr2 = elem; - dupPtr->typePtr = &tclParsedVarNameType; + register Tcl_Obj *arrayPtr, *elem; + int parsed; + + ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem); + + parsed++; /* Silence compiler. */ + ParsedSetIntRep(dupPtr, arrayPtr, elem); } /* *---------------------------------------------------------------------- * Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -71,47 +71,10 @@ if {$Dir ni $Path} { lappend Path $Dir encoding dirs $Path } } - - # TIP #255 min and max functions - namespace eval mathfunc { - proc min {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"min\"" - } - set val Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg < $val} {set val $arg} - } - return $val - } - proc max {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"max\"" - } - set val -Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg > $val} {set val $arg} - } - return $val - } - namespace export min max - } } namespace eval tcl::Pkg {} # Windows specific end of initialization Index: library/opt/optparse.tcl ================================================================== --- library/opt/optparse.tcl +++ library/opt/optparse.tcl @@ -6,14 +6,14 @@ # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely # on it. If your code does rely on this package you # may directly incorporate this code into your application. -package require Tcl 8.2 +package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. -package provide opt 0.4.6 +package provide opt 0.4.7 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ Index: library/opt/pkgIndex.tcl ================================================================== --- library/opt/pkgIndex.tcl +++ library/opt/pkgIndex.tcl @@ -6,7 +6,7 @@ # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]] Index: library/tcltest/pkgIndex.tcl ================================================================== --- library/tcltest/pkgIndex.tcl +++ library/tcltest/pkgIndex.tcl @@ -6,7 +6,7 @@ # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.4.0 [list source [file join $dir tcltest.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] Index: library/tcltest/tcltest.tcl ================================================================== --- library/tcltest/tcltest.tcl +++ library/tcltest/tcltest.tcl @@ -20,11 +20,11 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.4.0 + variable Version 2.4.1 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] # yourself. You don't need tcltest to wrap it for you. variable version [package provide Tcl] Index: macosx/tclMacOSXFCmd.c ================================================================== --- macosx/tclMacOSXFCmd.c +++ macosx/tclMacOSXFCmd.c @@ -690,28 +690,32 @@ static void UpdateStringOfOSType( register Tcl_Obj *objPtr) /* OSType object whose string rep to * update. */ { - char string[5]; + const int size = TCL_UTF_MAX * 4; + char *dst = Tcl_InitStringRep(objPtr, NULL, size); OSType osType = (OSType) objPtr->internalRep.longValue; - Tcl_DString ds; - Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); - unsigned len; - - string[0] = (char) (osType >> 24); - string[1] = (char) (osType >> 16); - string[2] = (char) (osType >> 8); - string[3] = (char) (osType); - string[4] = '\0'; - Tcl_ExternalToUtfDString(encoding, string, -1, &ds); - len = (unsigned) Tcl_DStringLength(&ds) + 1; - objPtr->bytes = ckalloc(len); - memcpy(objPtr->bytes, Tcl_DStringValue(&ds), len); - objPtr->length = Tcl_DStringLength(&ds); - Tcl_DStringFree(&ds); + int written = 0; + Tcl_Encoding encoding; + char src[5]; + + TclOOM(dst, size); + + src[0] = (char) (osType >> 24); + src[1] = (char) (osType >> 16); + src[2] = (char) (osType >> 8); + src[3] = (char) (osType); + src[4] = '\0'; + + encoding = Tcl_GetEncoding(NULL, "macRoman"); + Tcl_ExternalToUtf(NULL, encoding, src, -1, /* flags */ 0, + /* statePtr */ NULL, dst, size, /* srcReadPtr */ NULL, + /* dstWrotePtr */ &written, /* dstCharsPtr */ NULL); Tcl_FreeEncoding(encoding); + + (void)Tcl_InitStringRep(objPtr, NULL, written); } /* * Local Variables: * mode: c Index: tests/cmdIL.test ================================================================== --- tests/cmdIL.test +++ tests/cmdIL.test @@ -17,10 +17,11 @@ catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort } -result {wrong # args: should be "lsort ?-option value ...? list"} test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body { @@ -145,10 +146,22 @@ lsort -stride 2 -index {0 1} { {{c o d e} 54321} {{b l a h} 94729} {{b i g} 12345} {{d e m o} 34512} } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} +test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii -nocase [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { + lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { + lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup { Index: tests/expr-old.test ================================================================== --- tests/expr-old.test +++ tests/expr-old.test @@ -1157,40 +1157,52 @@ } -result 0 test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {too few arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {too few arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] test expr-old-40.5 {min math function} -body { expr {min("a", 0)} } -returnCodes error -match glob -result * test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} } -result 0 test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {too few arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {too few arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] test expr-old-41.5 {max math function} -body { expr {max("a", 0)} } -returnCodes error -match glob -result * test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { puts "Warning: this machine contains a defective Pentium processor" Index: tests/fileSystem.test ================================================================== --- tests/fileSystem.test +++ tests/fileSystem.test @@ -375,10 +375,26 @@ test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body { set x //foo file normalize $x file join $x } -result /foo +test filesystem-1.53 {[Bug 3559678] - normalize when tail is empty} { + string match */ [file normalize [lindex [glob -dir [pwd] {{}}] 0]] +} 0 +test filesystem-1.54 {[Bug ce3a211dcb] - normalize when tail is empty} -setup { + set save [pwd] + cd [set home [makeDirectory ce3a211dcb]] + makeDirectory A $home + cd [lindex [glob */] 0] +} -body { + string match */A [pwd] +} -cleanup { + cd $home + removeDirectory A $home + cd $save + removeDirectory ce3a211dcb +} -result 1 test filesystem-2.0 {new native path} {unix} { foreach f [lsort [glob -nocomplain /usr/bin/c*]] { catch {file readlink $f} } Index: tests/interp.test ================================================================== --- tests/interp.test +++ tests/interp.test @@ -1845,11 +1845,11 @@ lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a alias bar {} lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a -} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] +} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { catch {interp delete a} } -body { interp create a Index: tests/namespace.test ================================================================== --- tests/namespace.test +++ tests/namespace.test @@ -1782,12 +1782,15 @@ namespace ensemble create } list [ns x0 z] [ns x1] [ns x2] [ns x3] } -cleanup { namespace delete ns -} -result {{1 ::ns::x0::z} 1 2 3} -test namespace-42.8 {ensembles: [Bug 1670091]} -setup { +} -result {{1 z} 1 2 3} +test namespace-42.8 { + ensembles: [Bug 1670091], panic due to pointer to a deallocated List + struct. +} -setup { proc demo args {} variable target [list [namespace which demo] x] proc trial args {variable target; string length $target} trace add execution demo enter [namespace code trial] namespace ensemble create -command foo -map [list bar $target] @@ -1798,10 +1801,38 @@ rename demo {} rename trial {} rename foo {} } -result {} +test namespace-42.9 { + ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a + deallocated List struct. +} -setup { + namespace eval n {namespace ensemble create} + set lst [dict create one ::two] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name*} + +test namespace-42.10 { + ensembles: [Bug 4f6a1ebd64] segmentation fault due to pointer to a + deallocated List struct (this time with duplicate of one in "dict"). +} -setup { + namespace eval n {namespace ensemble create} + set lst [list one ::two one ::three] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name *three*} + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* proc x1 {} {format 1} proc x2 {} {format 2} @@ -1918,11 +1949,11 @@ namespace ensemble create -command foobar -subcommands {foobarcget foobarconfigure} } -body { foobar foobarcon } -cleanup { rename foobar {} -} -returnCodes error -result {invalid command name "::foobarconfigure"} +} -returnCodes error -result {invalid command name "foobarconfigure"} test namespace-44.6 {ensemble: errors} -returnCodes error -body { namespace ensemble create gorp } -result {wrong # args: should be "namespace ensemble create ?option value ...?"} test namespace-45.1 {ensemble: introspection} { @@ -2082,11 +2113,11 @@ lappend result [catch {ns a b c} msg] $msg lappend result [catch {ns b c d} msg] $msg lappend result [catch {ns c d e} msg] $msg lappend result [catch {ns Magic foo bar spong wibble} msg] $msg list $result [lsort [info commands ::ns::*]] $log [namespace delete ns] -} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}} +} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}} test namespace-47.2 {ensemble: unknown handler} { namespace eval ns { namespace export {[a-z]*} proc Magic {ensemble subcmd args} { error foobar @@ -3181,11 +3212,11 @@ } -result\ {0 0\ 1 {wrong # args: should be "ns z1 x a1"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ - 1 {wrong # args: should be "::ns::x::z0"}\ + 1 {wrong # args: should be "z0"}\ 0 {1 v}\ 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} test namespace-53.11 {ensembles: nested rewrite} -setup { namespace eval ns { @@ -3265,10 +3296,22 @@ } finally { namespace delete ::testing } } } {::testing::abc::def ::testing::abc::ghi} + +test namespace-56.4 {bug 16fe1b5807: names starting with ":"} { +namespace eval : { + namespace ensemble create + namespace export * + proc p1 {} { + return 16fe1b5807 + } +} + +: p1 +} 16fe1b5807 # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} Index: tests/obj.test ================================================================== --- tests/obj.test +++ tests/obj.test @@ -28,11 +28,10 @@ foreach {t} { bytearray bytecode cmdName dict - end-offset regexp string } { set first [string first $t [testobj types]] set r [expr {$r && ($first != -1)}] @@ -50,19 +49,10 @@ lappend result [testobj convert 1 bytearray] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} -test obj-3.1 {Tcl_ConvertToType error} testobj { - list [testdoubleobj set 1 12.34] \ - [catch {testobj convert 1 end-offset} msg] \ - $msg -} {12.34 1 {bad index "12.34": must be end?[+-]integer?}} -test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { - list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg -} {{} 1 {bad index "": must be end?[+-]integer?}} - test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] lappend result [testobj type 1] @@ -548,48 +538,10 @@ lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} - -test obj-31.1 {regenerate string rep of "end"} testobj { - testobj freeallvars - teststringobj set 1 end - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end -test obj-31.2 {regenerate string rep of "end-1"} testobj { - testobj freeallvars - teststringobj set 1 end-0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-1 -test obj-31.3 {regenerate string rep of "end--1"} testobj { - testobj freeallvars - teststringobj set 1 end--0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--1 -test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end-0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-2147483647 -test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end--0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483647 -test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { - testobj freeallvars - teststringobj set 1 end--0x80000000 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483648 - test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } Index: tests/oo.test ================================================================== --- tests/oo.test +++ tests/oo.test @@ -126,10 +126,13 @@ while executing \"oo::define oo::object method missingArgs\"" test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} +test oo-1.4.1 {fully-qualified nested name} -body { + oo::object create ::one::two::three +} -result {::one::two::three} test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} test oo-1.5.1 {basic test of OO functionality} -setup { oo::object create aninstance @@ -1496,24 +1499,26 @@ } done test oo-11.6 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances -} { +} -body { oo::class create obj1 ::oo::define obj1 {self mixin [self]} ::oo::copy obj1 obj2 ::oo::objdefine obj2 {mixin [self]} ::oo::copy obj2 obj3 - trace add command obj3 delete [list obj3 dying] + rename obj3 {} rename obj2 {} # No segmentation fault return done -} done +} -cleanup { + rename obj1 {} +} -result done test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject oo::define Aclass { @@ -3862,10 +3867,35 @@ E create e1 list [lsort [info class methods E -all]] [lsort [info object methods e1 -all]] } -cleanup { base destroy } -result {{c d e} {c d e}} +test oo-35.6 { + Bug : teardown of an object that is a class that is an instance of itself +} -setup { + oo::class create obj + + oo::copy obj obj1 obj1 + oo::objdefine obj1 { + mixin obj1 obj + } + oo::copy obj1 obj2 + oo::objdefine obj2 { + mixin obj2 obj1 + } +} -body { + rename obj2 {} + rename obj1 {} + # doesn't crash + return done +} -cleanup { + rename obj {} +} -result done + + + + test oo-36.1 {TIP #470: introspection within oo::define} { oo::define oo::object self } ::oo::object test oo-36.2 {TIP #470: introspection within oo::define} -setup { oo::class create Cls Index: tests/package.test ================================================================== --- tests/package.test +++ tests/package.test @@ -18,22 +18,23 @@ } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -testConstraint testpreferstable [llength [info commands testpreferstable]] - # Do all this in a slave interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoSlaveInterpreter $i {*}$argv +load {} Tcltest $i interp eval $i { namespace import -force ::tcltest::* -package forget {*}[package names] +#package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" + +testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create } -returnCodes error -match glob -result {wrong # args: should be "*"} test package-1.2 {pkg::create gives error on bad args} -body { @@ -137,51 +138,51 @@ } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.4} test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.5} test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {3.5 2.1 2.3} { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.2 - return $x + set x } -result {2.3} test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require -exact t 2.3 - return $x + set x } -result {2.3} test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.1 - return $x + set x } -result {2.4} test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { package forget t } -returnCodes error -body { package unknown {} @@ -236,11 +237,11 @@ package forget t set x xxx } -body { package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" package require t 1.2 - return $x + set x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t set x xxx } -body { @@ -254,11 +255,11 @@ foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i" } package unknown pkgUnknown package require -exact t 1.5 - return $x + set x } -cleanup { package unknown {} } -result {t 1.5-1.5} test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t @@ -281,11 +282,11 @@ global x set x $args package provide [lindex $args 0] 2.0 } package require {a b} - return $x + set x } -cleanup { package unknown {} } -result {{a b} 0-} test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup { package forget t @@ -573,73 +574,119 @@ package require -exact demo 1.2 } -returnCodes error -cleanup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + interp create child + load {} Tcltest child + child eval { testpreferstable package forget t set x xxx + } } -body { + child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x + } +} -cleanup { + interp delete child } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx } -body { foreach i {1.2b1 1.2 1.3a2 1.3} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx } -body { foreach i {1.2b1 1.2 1.3 1.3a2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} +test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + testpreferstable + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.1} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + set x +} -result {1.1} + test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + } +} -cleanup { + interp delete child +} -result {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package forget foo -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] set result {} + } } -body { + child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] + } +} -cleanup { + interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} package forget set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] + } +} -cleanup { + interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 package ifneeded a 1 "I should have been forgotten" package forget no-such-package a @@ -654,32 +701,59 @@ package ifneeded a b c d } -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] -} {{} {}} + } +} -cleanup { + interp delete child +} -result {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] + } +} -cleanup { + interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t } -body { package ifneeded t 1.4 "script for t 1.4" @@ -688,22 +762,35 @@ list [package ifneeded t 1.2] [package versions t] } -result {{second script} {1.4 1.2 3.1}} test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] + } +} -cleanup { + interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide } -returnCodes error -result {wrong # args: should be "package provide package ?version?"} test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body { @@ -1237,15 +1324,13 @@ } finally { interp delete $ip } } -test package-13.0 {package prefer defaults} -constraints testpreferstable -setup { - testpreferstable -} -body { +test package-13.0 {package prefer defaults} -body { prefer -} -result stable +} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer } -cleanup { unset -nocomplain ::env(TCL_PKG_PREFER_LATEST) @@ -1258,27 +1343,29 @@ package prefer foo } -result {bad preference "foo": must be latest or stable} test package-15.0 {set, keep} -constraints testpreferstable -setup { testpreferstable -} -body {package prefer stable} -result stable +} -body {package prefer} -result stable test package-15.1 {set stable, keep} -constraints testpreferstable -setup { testpreferstable -} -body {prefer stable} -result {stable stable} +} -body {package prefer stable} -result stable test package-15.2 {set latest, change} -constraints testpreferstable -setup { testpreferstable -} -body {prefer latest} -result {stable latest} +} -body {package prefer latest} -result latest test package-15.3 {set latest, keep} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest latest -} -result {stable latest latest} + package prefer latest + package prefer latest +} -result latest test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest stable -} -result {stable latest latest} + package prefer latest + package prefer stable +} -result latest rename prefer {} set auto_path $oldPath package unknown $oldPkgUnknown Index: tests/safe.test ================================================================== --- tests/safe.test +++ tests/safe.test @@ -72,11 +72,11 @@ } -body { interp create a -safe lsort [a aliases] } -cleanup { interp delete a -} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} +} -result {clock} test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} interp create a -safe } -body { Index: tests/split.test ================================================================== --- tests/split.test +++ tests/split.test @@ -68,10 +68,13 @@ split "12,34,56," {,} } {12 34 56 {}} test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} +test split-1.15 {basic split commands} -body { + split "a\U01f4a9b" {} +} -result "a \U01f4a9 b" test split-2.1 {split errors} { list [catch split msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}} test split-2.2 {split errors} { Index: tests/string.test ================================================================== --- tests/string.test +++ tests/string.test @@ -26,10 +26,15 @@ testConstraint testindexobj [expr {[info commands testindexobj] != {}}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +proc representationpoke s { + set r [::tcl::unsupported::representation $s] + list [lindex $r 3] [string match {*, string representation "*"} $r] +} + test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { list [catch {string} msg] $msg @@ -222,10 +227,17 @@ # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. set uchar \u057e ;# character with two-byte encoding in utf-8 string first % %#$uchar$uchar#$uchar$uchar#% 3 } 8 +test string-4.16 {string first, normal string vs pure unicode string} { + set s hello + regexp ll $s m + # Representation checks are canaries + list [representationpoke $s] [representationpoke $m] \ + [string first $m $s] +} {{string 1} {string 0} 2} test string-5.1 {string index} { list [catch {string index} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} test string-5.2 {string index} { @@ -1683,44 +1695,44 @@ set x abc set y de string reverse $x$y } edcba test string-24.5 {string reverse command - shared unicode string} { - set x abcde\udead + set x abcde\ud0ad string reverse $x -} \udeadedcba +} \ud0adedcba test string-24.6 {string reverse command - unshared string} { set x abc - set y de\udead + set y de\ud0ad string reverse $x$y -} \udeadedcba +} \ud0adedcba test string-24.7 {string reverse command - simple case} { string reverse a } a test string-24.8 {string reverse command - simple case} { - string reverse \udead -} \udead + string reverse \ud0ad +} \ud0ad test string-24.9 {string reverse command - simple case} { string reverse {} } {} test string-24.10 {string reverse command - corner case} { - set x \ubeef\udead + set x \ubeef\ud0ad string reverse $x -} \udead\ubeef +} \ud0ad\ubeef test string-24.11 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string reverse $x$y -} \udead\ubeef +} \ud0ad\ubeef test string-24.12 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string is ascii [string reverse $x$y] } 0 test string-24.13 {string reverse command - pure Unicode string} { - string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5] -} \udead\ubeef\udead\ubeef\udead + string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5] +} \ud0ad\ubeef\ud0ad\ubeef\ud0ad test string-24.14 {string reverse command - pure bytearray} { binary scan [string reverse [binary format H* 010203]] H* x set x } 030201 test string-24.15 {string reverse command - pure bytearray} { @@ -2040,17 +2052,15 @@ } -cleanup { unset e f } -body { tcl::unsupported::representation [string cat $e $f $e $f [list x]] } -match glob -result {*no string representation} - - - + # cleanup rename MemStress {} catch {rename foo {}} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/stringObj.test ================================================================== --- tests/stringObj.test +++ tests/stringObj.test @@ -478,14 +478,17 @@ } fooo test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo - if {[testConstraint testobj]} { testobj freeallvars } # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: Index: tests/utf.test ================================================================== --- tests/utf.test +++ tests/utf.test @@ -66,14 +66,14 @@ test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { string length [testbytestring "\xE4\xb9\x8e"] } {1} test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF0\x90\x80\x80"] -} -result {1} +} -result {2} test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF4\x8F\xBF\xBF"] -} -result {1} +} -result {2} test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { string length [testbytestring "\xF0\x8F\xBF\xBF"] } {4} test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring { string length [testbytestring "\xF4\x90\x80\x80"] @@ -84,10 +84,13 @@ test utf-3.1 {Tcl_UtfCharComplete} { } {} testConstraint testnumutfchars [llength [info commands testnumutfchars]] +testConstraint testfindfirst [llength [info commands testfindfirst]] +testConstraint testfindlast [llength [info commands testfindlast]] + test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" } {0} test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC2\xA2"] @@ -116,12 +119,16 @@ } {2} test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\x00"] 2 } {2} -test utf-5.1 {Tcl_UtfFindFirsts} { -} {} +test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} { + testfindfirst [testbytestring "abcbc"] 98 +} {bcbc} +test utf-5.1 {Tcl_UtfFindLast} {testfindlast testbytestring} { + testfindlast [testbytestring "abcbc"] 98 +} {bc} test utf-6.1 {Tcl_UtfNext} { } {} test utf-7.1 {Tcl_UtfPrev} { Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -855,12 +855,12 @@ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; - @echo "Installing package tcltest 2.4.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.0.tm; + @echo "Installing package tcltest 2.4.1 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; Index: unix/configure ================================================================== --- unix/configure +++ unix/configure @@ -3730,30 +3730,10 @@ if test $tcl_cv_dirent_h = no; then $as_echo "#define NO_DIRENT_H 1" >>confdefs.h fi - - ac_fn_c_check_header_mongrel "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default" -if test "x$ac_cv_header_float_h" = xyes; then : - -else - -$as_echo "#define NO_FLOAT_H 1" >>confdefs.h - -fi - - - ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" -if test "x$ac_cv_header_values_h" = xyes; then : - -else - -$as_echo "#define NO_VALUES_H 1" >>confdefs.h - -fi - ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default" if test "x$ac_cv_header_stdlib_h" = xyes; then : tcl_ok=1 else @@ -5317,11 +5297,11 @@ ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5 $as_echo_n "checking for inet_ntoa in -lnetwork... " >&6; } if ${ac_cv_lib_network_inet_ntoa+:} false; then : @@ -5639,11 +5619,11 @@ # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings # when you inline the string and math operations. Turn this off to # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" if test $doRpath = yes; then : @@ -5726,11 +5706,11 @@ ;; *) SHLIB_CFLAGS="-fpic" ;; esac - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" if test $doRpath = yes; then : @@ -5753,11 +5733,11 @@ TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" if test $doRpath = yes; then : Index: unix/tcl.m4 ================================================================== --- unix/tcl.m4 +++ unix/tcl.m4 @@ -1248,11 +1248,11 @@ ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" AC_CHECK_LIB(network, inet_ntoa, [LIBS="$LIBS -lnetwork"]) ;; HP-UX-*.11.*) @@ -1392,11 +1392,11 @@ # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings # when you inline the string and math operations. Turn this off to # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) @@ -1442,11 +1442,11 @@ ;; *) SHLIB_CFLAGS="-fpic" ;; esac - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) @@ -1465,11 +1465,11 @@ TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" AS_IF([test $doRpath = yes], [ @@ -2038,11 +2038,10 @@ # # Results: # # Defines some of the following vars: # NO_DIRENT_H -# NO_VALUES_H # NO_STDLIB_H # NO_STRING_H # NO_SYS_WAIT_H # NO_DLFCN_H # HAVE_SYS_PARAM_H @@ -2076,12 +2075,10 @@ if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi - AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])]) - AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) if test $tcl_ok = 0; then Index: unix/tclConfig.h.in ================================================================== --- unix/tclConfig.h.in +++ unix/tclConfig.h.in @@ -293,13 +293,10 @@ #undef NO_DLFCN_H /* Do we have fd_set? */ #undef NO_FD_SET -/* Do we have ? */ -#undef NO_FLOAT_H - /* Do we have fstatfs()? */ #undef NO_FSTATFS /* Do we have gettimeofday()? */ #undef NO_GETTOD @@ -332,13 +329,10 @@ #undef NO_UNAME /* Do we have a usable 'union wait'? */ #undef NO_UNION_WAIT -/* Do we have ? */ -#undef NO_VALUES_H - /* Do we have wait3() */ #undef NO_WAIT3 /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT Index: unix/tclUnixPort.h ================================================================== --- unix/tclUnixPort.h +++ unix/tclUnixPort.h @@ -179,17 +179,11 @@ * for an alternative definition. If no other alternative is available we use * a reasonable guess. *--------------------------------------------------------------------------- */ -#ifndef NO_FLOAT_H -# include -#else -#ifndef NO_VALUES_H -# include -#endif -#endif +#include #ifndef FLT_MAX # ifdef MAXFLOAT # define FLT_MAX MAXFLOAT # else Index: unix/tclUnixSock.c ================================================================== --- unix/tclUnixSock.c +++ unix/tclUnixSock.c @@ -251,13 +251,10 @@ native = hp->h_name; } else { native = u.nodename; } } - if (native == NULL) { - native = &tclEmptyString; - } #else /* !NO_UNAME */ /* * Uname doesn't exist; try gethostname instead. * * There is no portable macro for the maximum length of host names @@ -282,13 +279,19 @@ native = buffer; } #endif /* NO_UNAME */ *encodingPtr = Tcl_GetEncoding(NULL, NULL); - *lengthPtr = strlen(native); - *valuePtr = ckalloc(*lengthPtr + 1); - memcpy(*valuePtr, native, *lengthPtr + 1); + if (native) { + *lengthPtr = strlen(native); + *valuePtr = ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, native, *lengthPtr + 1); + } else { + *lengthPtr = 0; + *valuePtr = ckalloc(1); + *valuePtr[0] = '\0'; + } } /* * ---------------------------------------------------------------------- * Index: unix/tclUnixThrd.c ================================================================== --- unix/tclUnixThrd.c +++ unix/tclUnixThrd.c @@ -13,15 +13,17 @@ #include "tclInt.h" #ifdef TCL_THREADS +#ifndef TCL_NO_DEPRECATED typedef struct { char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; +#endif /* * masterLock is used to serialize creation of mutexes, condition variables, * and thread local storage. This is the only place that can count on the * ability to statically initialize the mutex. Index: win/tcl.dsp ================================================================== --- win/tcl.dsp +++ win/tcl.dsp @@ -148,14 +148,10 @@ # End Source File # Begin Source File SOURCE=..\compat\fixstrtod.c # End Source File -# Begin Source File - -SOURCE=..\compat\float.h -# End Source File # Begin Source File SOURCE=..\compat\gettod.c # End Source File # Begin Source File Index: win/tcl.hpj.in ================================================================== --- win/tcl.hpj.in +++ win/tcl.hpj.in @@ -3,13 +3,13 @@ [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl86.cnt +CNT=tcl87.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl86.hlp +HLP=tcl87.hlp [FILES] tcl.rtf [WINDOWS] Index: win/tclWinError.c ================================================================== --- win/tclWinError.c +++ win/tclWinError.c @@ -28,11 +28,11 @@ ENOMEM, /* ERROR_INVALID_BLOCK 9 */ E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */ ENOEXEC, /* ERROR_BAD_FORMAT 11 */ EACCES, /* ERROR_INVALID_ACCESS 12 */ EINVAL, /* ERROR_INVALID_DATA 13 */ - EFAULT, /* ERROR_OUT_OF_MEMORY 14 */ + ENOMEM, /* ERROR_OUT_OF_MEMORY 14 */ ENOENT, /* ERROR_INVALID_DRIVE 15 */ EACCES, /* ERROR_CURRENT_DIRECTORY 16 */ EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */ ENOENT, /* ERROR_NO_MORE_FILES 18 */ EROFS, /* ERROR_WRITE_PROTECT 19 */ Index: win/tclWinSerial.c ================================================================== --- win/tclWinSerial.c +++ win/tclWinSerial.c @@ -1736,11 +1736,11 @@ */ dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { - Tcl_UniChar character; + Tcl_UniChar character = 0; int charLen; charLen = Tcl_UtfToUniChar(argv[0], &character); if (argv[0][charLen]) { goto badXchar; Index: win/tclWinThrd.c ================================================================== --- win/tclWinThrd.c +++ win/tclWinThrd.c @@ -11,12 +11,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" -#include - /* Workaround for mingw versions which don't provide this in float.h */ #ifndef _MCW_EM # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */