diff options
36 files changed, 573 insertions, 538 deletions
diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 7ba9e89..29aa98b 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -1,5 +1,11 @@ name: Linux -on: [push] +on: + push: + branches: + - "main" + - "core-8-branch" + tags: + - "core-**" permissions: contents: read jobs: diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index a9345a1..462bd92 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -1,5 +1,11 @@ name: macOS -on: [push] +on: + push: + branches: + - "main" + - "core-8-branch" + tags: + - "core-**" permissions: contents: read jobs: diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 1f75762..5c90701 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -1,5 +1,11 @@ name: Build Binaries -on: [push] +on: + push: + branches: + - "main" + - "core-8-branch" + tags: + - "core-**" permissions: contents: read jobs: diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index ba4e5ba..3809786 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -1,5 +1,11 @@ name: Windows -on: [push] +on: + push: + branches: + - "main" + - "core-8-branch" + tags: + - "core-**" permissions: contents: read env: diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 7ba71eb..4bdde44 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -187,7 +187,7 @@ except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR. typedef int \fBTcl_ObjCmdProc2\fR( void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, - ptrdiff_t \fIobjc\fR, + Tcl_Size \fIobjc\fR, Tcl_Obj *const \fIobjv\fR[]); .CE .PP diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index cfd3303..9f74cbf 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -88,10 +88,10 @@ typedef int \fBTcl_CmdObjTraceProc\fR( typedef int \fBTcl_CmdObjTraceProc2\fR( \fBvoid *\fR \fIclientData\fR, \fBTcl_Interp\fR* \fIinterp\fR, - ptrdiff_t \fIlevel\fR, + Tcl_Size \fIlevel\fR, const char *\fIcommand\fR, \fBTcl_Command\fR \fIcommandToken\fR, - ptrdiff_t \fIobjc\fR, + Tcl_Size \fIobjc\fR, \fBTcl_Obj\fR *const \fIobjv\fR[]); .CE .PP diff --git a/generic/tcl.h b/generic/tcl.h index f540f3e..7acc13b 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -561,7 +561,7 @@ typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, - ptrdiff_t level, const char *command, Tcl_Command commandInfo, ptrdiff_t objc, + Tcl_Size level, const char *command, Tcl_Command commandInfo, Tcl_Size objc, struct Tcl_Obj *const *objv); typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, @@ -586,7 +586,7 @@ typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, - ptrdiff_t objc, struct Tcl_Obj *const *objv); + Tcl_Size objc, struct Tcl_Obj *const *objv); typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); @@ -2018,15 +2018,18 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_CHAR_LIMIT 0x10 /* Internal use bits, do not define bits in this space. See above comment */ #define TCL_ENCODING_INTERNAL_USE_MASK 0xFF00 -/* Reserve top byte for profile values (disjoint, not a mask) */ +/* + * Reserve top byte for profile values (disjoint, not a mask). In case of + * changes, ensure ENCODING_PROFILE_* macros in tclInt.h are modified if + * necessary. + */ #define TCL_ENCODING_PROFILE_TCL8 0x01000000 #define TCL_ENCODING_PROFILE_STRICT 0x02000000 #define TCL_ENCODING_PROFILE_REPLACE 0x03000000 -/* Still being argued - For Tcl9, is the default strict? TODO */ #if TCL_MAJOR_VERSION < 9 #define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8 #else -#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8 /* STRICT? REPLACE? TODO */ +#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8 #endif /* @@ -2392,7 +2395,7 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); TclStubCall((void *)4))(argc, argv, appInitProc, interp) #if !defined(_WIN32) || !defined(UNICODE) #define Tcl_MainEx(argc, argv, appInitProc, interp) \ - (void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + (void)((const char *(*)(Tcl_Size, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ TclStubCall((void *)5))(argc, argv, appInitProc, interp) #endif #define Tcl_StaticLibrary(interp, pkgName, initProc, safeInitProc) \ diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 92d4352..3f980c4 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -1090,52 +1090,6 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) if (bytlen > 0) arithSeriesObjPtr->bytes[bytlen-1] = '\0'; arithSeriesObjPtr->length = bytlen-1; } - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjCopy -- - * - * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C - * level a counterpart of the [lrange $list 0 end] command, while using - * internals details to be as efficient as possible. - * - * Results: - * - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * arithSeries value as *arithSeriesObj does. The returned Tcl_Obj has a - * refCount of zero. If *arithSeriesObj does not hold an arithSeries, - * NULL is returned, and if interp is non-NULL, an error message is - * recorded there. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclArithSeriesObjCopy( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *arithSeriesObj) /* List object for which an element array is - * to be returned. */ -{ - Tcl_Obj *copyPtr; - ArithSeries *arithSeriesRepPtr; - - arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); - if (NULL == arithSeriesRepPtr) { - if (SetArithSeriesFromAny(interp, arithSeriesObj) != TCL_OK) { - /* We know this is going to panic, but it's the message we want */ - return NULL; - } - } - - TclNewObj(copyPtr); - TclInvalidateStringRep(copyPtr); - DupArithSeriesInternalRep(arithSeriesObj, copyPtr); - return copyPtr; -} /* * Local Variables: diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 910532e..4aa241a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2247,7 +2247,7 @@ static int GetListIndexOperand( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ + int* result) /* OUTPUT: encoded index derived from the token */ { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d18ddaf..f87e31c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5387,12 +5387,12 @@ TclEvalEx( expand[objectsUsed] = 1; additionalObjsCount = (numElements ? numElements : 1); - + } else { expand[objectsUsed] = 0; additionalObjsCount = 1; } - + /* Currently max command words in INT_MAX */ if (additionalObjsCount > INT_MAX || objectsNeeded > (INT_MAX - additionalObjsCount)) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index cefd74e..6186ae5 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2809,7 +2809,6 @@ EachloopCmd( /* Values */ if (!TclHasInternalRep(objv[2+i*2], &tclListType) && - ABSTRACTLIST_PROC(objv[2+i*2],dupIntRepProc) && ABSTRACTLIST_PROC(objv[2+i*2],indexProc)) { /* Special case for AbstractList */ statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 926c492..b974c30 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -720,8 +720,8 @@ const Tcl_ObjType tclByteCodeType = { }; /* - * subtCodeType provides the standard type managemnt procedures for the - * substcode type, which represents substiution within a Tcl value. + * substCodeType provides the standard type management procedures for the + * substcode type, which represents substitution within a Tcl value. */ static const Tcl_ObjType substCodeType = { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index f067d92..3ab3de9 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -10,7 +10,6 @@ */ #include "tclInt.h" -#include "tclIO.h" typedef size_t (LengthProc)(const char *src); @@ -200,16 +199,16 @@ static struct TclEncodingProfiles { {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; #define PROFILE_TCL8(flags_) \ - ((CHANNEL_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) \ - || (CHANNEL_PROFILE_GET(flags_) == 0 \ + ((ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) \ + || (ENCODING_PROFILE_GET(flags_) == 0 \ && TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_TCL8)) #define PROFILE_STRICT(flags_) \ - ((CHANNEL_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_STRICT) \ - || (CHANNEL_PROFILE_GET(flags_) == 0 \ + ((ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_STRICT) \ + || (ENCODING_PROFILE_GET(flags_) == 0 \ && TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_STRICT)) #define PROFILE_REPLACE(flags_) \ - ((CHANNEL_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) \ - || (CHANNEL_PROFILE_GET(flags_) == 0 \ + ((ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) \ + || (ENCODING_PROFILE_GET(flags_) == 0 \ && TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_REPLACE)) #define UNICODE_REPLACE_CHAR ((Tcl_UniChar)0xFFFD) @@ -1166,7 +1165,7 @@ Tcl_ExternalToUtfDString( * Tcl_ExternalToUtfDStringEx -- * * Convert a source buffer from the specified encoding into UTF-8. - * The parameter flags controls the behavior, if any of the bytes in + * "flags" controls the behavior if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: * target encoding. It should be composed by OR-ing the following: @@ -2542,7 +2541,7 @@ UtfToUtfProc( memset(dst, 0xff, dstLen); #endif - profile = CHANNEL_PROFILE_GET(flags); + profile = ENCODING_PROFILE_GET(flags); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { @@ -2589,10 +2588,10 @@ UtfToUtfProc( } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* * Incomplete byte sequence. - * Always check before using TclUtfToUCS4. Not doing can so - * cause it run beyond the end of the buffer! If we happen such an - * incomplete char its bytes are made to represent themselves - * unless the user has explicitly asked to be told. + * Always check before using TclUtfToUCS4. Not doing so can cause it + * run beyond the end of the buffer! If we happen on such an incomplete + * char its bytes are made to represent themselves unless the user has + * explicitly asked to be told. */ if (flags & ENCODING_INPUT) { @@ -4642,9 +4641,9 @@ TclEncodingProfileIdToName( int TclEncodingSetProfileFlags(int flags) { if (flags & TCL_ENCODING_STOPONERROR) { - CHANNEL_PROFILE_SET(flags, TCL_ENCODING_PROFILE_STRICT); + ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_STRICT); } else { - int profile = CHANNEL_PROFILE_GET(flags); + int profile = ENCODING_PROFILE_GET(flags); switch (profile) { case TCL_ENCODING_PROFILE_TCL8: case TCL_ENCODING_PROFILE_STRICT: @@ -4652,7 +4651,7 @@ int TclEncodingSetProfileFlags(int flags) break; case 0: /* Unspecified by caller */ default: - CHANNEL_PROFILE_SET(flags, TCL_ENCODING_PROFILE_DEFAULT); + ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_DEFAULT); break; } } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c2cb43b..09597e9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -112,9 +112,8 @@ typedef struct { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ Tcl_Obj **catchTop; /* These fields are used on return TO this */ - Tcl_Obj *auxObjList; /* this level: they record the state when a */ - CmdFrame cmdFrame; /* new codePtr was received for NR */ - /* execution. */ + Tcl_Obj *auxObjList; /* level: they record the state when a new */ + CmdFrame cmdFrame; /* codePtr was received for NR execution. */ Tcl_Obj *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ diff --git a/generic/tclIO.c b/generic/tclIO.c index a7014e2..987f6b9 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1679,11 +1679,11 @@ Tcl_CreateChannel( statePtr->encoding = Tcl_GetEncoding(NULL, name); statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; - CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags, + ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, TCL_ENCODING_PROFILE_DEFAULT); statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; - CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags, + ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, TCL_ENCODING_PROFILE_DEFAULT); /* @@ -4347,7 +4347,7 @@ Write( Tcl_Size saved = 0, total = 0, flushed = 0; char safe[BUFFER_PADDING]; int encodingError = 0; - + if (srcLen) { WillWrite(chanPtr); } @@ -5931,7 +5931,7 @@ DoReadChars( if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR); - /* TODO: We don't need this call? */ + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); Tcl_SetErrno(EILSEQ); return -1; @@ -5948,7 +5948,7 @@ DoReadChars( assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); - /* TODO: We don't need this call? */ + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); return 0; } @@ -5962,7 +5962,7 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - /* TODO: We don't need this call? */ + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); return 0; } @@ -6009,7 +6009,7 @@ DoReadChars( } /* - * If the current buffer is empty recycle it. + * Recycle current buffer if empty. */ bufPtr = statePtr->inQueueHead; @@ -7974,7 +7974,7 @@ Tcl_GetChannelOption( Tcl_DStringAppendElement(dsPtr, "-profile"); } /* Note currently input and output profiles are same */ - profile = CHANNEL_PROFILE_GET(statePtr->inputEncodingFlags); + profile = ENCODING_PROFILE_GET(statePtr->inputEncodingFlags); profileName = TclEncodingProfileIdToName(interp, profile); if (profileName == NULL) { return TCL_ERROR; @@ -8169,11 +8169,11 @@ Tcl_SetChannelOption( if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) { encoding = Tcl_GetEncoding(NULL, "iso8859-1"); - CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags - ,CHANNEL_PROFILE_GET(statePtr->inputEncodingFlags) + ENCODING_PROFILE_SET(statePtr->inputEncodingFlags + ,ENCODING_PROFILE_GET(statePtr->inputEncodingFlags) |TCL_ENCODING_PROFILE_STRICT); - CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags - ,CHANNEL_PROFILE_GET(statePtr->outputEncodingFlags) + ENCODING_PROFILE_SET(statePtr->outputEncodingFlags + ,ENCODING_PROFILE_GET(statePtr->outputEncodingFlags) |TCL_ENCODING_PROFILE_STRICT); } else { encoding = Tcl_GetEncoding(interp, newValue); @@ -8196,12 +8196,12 @@ Tcl_SetChannelOption( Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = encoding; statePtr->inputEncodingState = NULL; - profile = CHANNEL_PROFILE_GET(statePtr->inputEncodingFlags); + profile = ENCODING_PROFILE_GET(statePtr->inputEncodingFlags); statePtr->inputEncodingFlags = TCL_ENCODING_START; - CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags, profile); + ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, profile); statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; - CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags, profile); /* Same as input */ + ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, profile); /* Same as input */ ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR); UpdateInterest(chanPtr); return TCL_OK; @@ -8244,8 +8244,8 @@ Tcl_SetChannelOption( if (TclEncodingProfileNameToId(interp, newValue, &profile) != TCL_OK) { return TCL_ERROR; } - CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags, profile); - CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags, profile); + ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, profile); + ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, profile); ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR); return TCL_OK; } else if (HaveOpt(1, "-translation")) { @@ -8283,11 +8283,11 @@ Tcl_SetChannelOption( statePtr->inEofChar = 0; Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = Tcl_GetEncoding(NULL, "iso8859-1"); - CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags - ,CHANNEL_PROFILE_GET(statePtr->inputEncodingFlags) + ENCODING_PROFILE_SET(statePtr->inputEncodingFlags + ,ENCODING_PROFILE_GET(statePtr->inputEncodingFlags) |TCL_ENCODING_PROFILE_STRICT); - CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags - ,CHANNEL_PROFILE_GET(statePtr->outputEncodingFlags) + ENCODING_PROFILE_SET(statePtr->outputEncodingFlags + ,ENCODING_PROFILE_GET(statePtr->outputEncodingFlags) |TCL_ENCODING_PROFILE_STRICT); } else if (strcmp(readMode, "lf") == 0) { translation = TCL_TRANSLATE_LF; @@ -8338,11 +8338,11 @@ Tcl_SetChannelOption( statePtr->outputTranslation = TCL_TRANSLATE_LF; Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = Tcl_GetEncoding(NULL, "iso8859-1"); - CHANNEL_PROFILE_SET(statePtr->inputEncodingFlags - ,CHANNEL_PROFILE_GET(statePtr->inputEncodingFlags) + ENCODING_PROFILE_SET(statePtr->inputEncodingFlags + ,ENCODING_PROFILE_GET(statePtr->inputEncodingFlags) |TCL_ENCODING_PROFILE_STRICT); - CHANNEL_PROFILE_SET(statePtr->outputEncodingFlags - ,CHANNEL_PROFILE_GET(statePtr->outputEncodingFlags) + ENCODING_PROFILE_SET(statePtr->outputEncodingFlags + ,ENCODING_PROFILE_GET(statePtr->outputEncodingFlags) |TCL_ENCODING_PROFILE_STRICT); } else if (strcmp(writeMode, "lf") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_LF; @@ -10269,8 +10269,8 @@ Lossless( ( toRead == -1 && inStatePtr->encoding == outStatePtr->encoding - && CHANNEL_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 - && CHANNEL_PROFILE_GET(outStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 + && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 + && ENCODING_PROFILE_GET(outStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 ) ); } diff --git a/generic/tclIO.h b/generic/tclIO.h index 6b166b0..145296a 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -288,13 +288,6 @@ typedef struct ChannelState { #define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed. * No further Tcl-level write IO on * the channel is allowed. */ -#define CHANNEL_PROFILE_MASK 0xFF000000 -#define CHANNEL_PROFILE_GET(flags_) ((flags_) & CHANNEL_PROFILE_MASK) -#define CHANNEL_PROFILE_SET(flags_, profile_) \ - do { \ - (flags_) &= ~CHANNEL_PROFILE_MASK; \ - (flags_) |= profile_; \ - } while (0) /* * The length of time to wait between synthetic timer events. Must be zero or diff --git a/generic/tclInt.h b/generic/tclInt.h index fde07c8..34e9383 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2892,6 +2892,22 @@ typedef struct ProcessGlobalValue { #define TCL_PARSE_NO_UNDERSCORE 128 /* Reject underscore digit separator */ + +/* + *---------------------------------------------------------------------- + * Internal convenience macros for manipulating encoding flags. See + * TCL_ENCODING_PROFILE_* in tcl.h + *---------------------------------------------------------------------- + */ + +#define ENCODING_PROFILE_MASK 0xFF000000 +#define ENCODING_PROFILE_GET(flags_) ((flags_) & ENCODING_PROFILE_MASK) +#define ENCODING_PROFILE_SET(flags_, profile_) \ + do { \ + (flags_) &= ~ENCODING_PROFILE_MASK; \ + (flags_) |= profile_; \ + } while (0) + /* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. diff --git a/generic/tclListObj.c b/generic/tclListObj.c index d15a3ed..3c4c4d2 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -39,7 +39,7 @@ #ifdef ENABLE_LIST_ASSERTS -#define LIST_ASSERT(cond_) assert(cond_) /* TODO - is there a Tcl-specific one? */ +#define LIST_ASSERT(cond_) assert(cond_) /* * LIST_INDEX_ASSERT is to catch errors with negative indices and counts * being passed AFTER validation. On Tcl9 length types are unsigned hence @@ -68,8 +68,7 @@ /* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ - LIST_ASSERT((listObj_)->typePtr == &tclListType); - + LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType)) /* * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the @@ -311,12 +310,12 @@ ListSpanMerited( Tcl_Size allocatedStorageLength) /* Length of the currently allocation */ { /* - TODO - - heuristics thresholds need to be determined - - currently, information about the sharing (ref count) of existing - storage is not passed. Perhaps it should be. For example if the - existing storage has a "large" ref count, then it might make sense - to do even a small span. + * Possible optimizations for future consideration + * - heuristic LIST_SPAN_THRESHOLD + * - currently, information about the sharing (ref count) of existing + * storage is not passed. Perhaps it should be. For example if the + * existing storage has a "large" ref count, then it might make sense + * to do even a small span. */ if (length < LIST_SPAN_THRESHOLD) { @@ -777,14 +776,16 @@ ListStoreNew( } if (flags & LISTREP_SPACE_FLAGS) { + /* Caller requests extra space front, back or both */ capacity = ListStoreUpSize(objc); } else { capacity = objc; } storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity)); - if (storePtr == NULL && capacity != objc) { - capacity = objc; /* Try allocating exact size */ + while (storePtr == NULL && (capacity > (objc+1))) { + /* Because of loop condition capacity won't overflow */ + capacity = objc + ((capacity - objc) / 2); storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity)); } if (storePtr == NULL) { @@ -833,7 +834,8 @@ ListStoreNew( * * ListStoreReallocate -- * - * Reallocates the memory for a ListStore. + * Reallocates the memory for a ListStore allocating extra for + * possible future growth. * * Results: * Pointer to the ListStore which may be the same as storePtr or pointer @@ -862,7 +864,7 @@ ListStoreReallocate (ListStore *storePtr, Tcl_Size numSlots) * by half every time. */ while (newStorePtr == NULL && (newCapacity > (numSlots+1))) { - /* Because of loop condition newCapacity can't overflow */ + /* Because of loop condition newCapacity won't overflow */ newCapacity = numSlots + ((newCapacity - numSlots) / 2); newStorePtr = (ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(newCapacity)); @@ -1974,19 +1976,18 @@ int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object to index into. */ - Tcl_Size index, /* Index of element to return. */ + Tcl_Size index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { Tcl_Obj **elemObjs; Tcl_Size numElems; - /* - * TODO - * Unlike the original list code, this does not optimize for lindex'ing - * an empty string when the internal rep is not already a list. On the - * other hand, this code will be faster for the case where the object - * is currently a dict. Benchmark the two cases. - */ + /* Empty string => empty list. Avoid unnecessary shimmering */ + if (listObj->bytes == &tclEmptyString) { + *objPtrPtr = NULL; + return TCL_OK; + } + if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs) != TCL_OK) { return TCL_ERROR; @@ -2031,19 +2032,19 @@ Tcl_ListObjLength( { ListRep listRep; + /* Empty string => empty list. Avoid unnecessary shimmering */ + if (listObj->bytes == &tclEmptyString) { + *lenPtr = 0; + return TCL_OK; + } + Tcl_Size (*lengthProc)(Tcl_Obj *obj) = ABSTRACTLIST_PROC(listObj, lengthProc); if (lengthProc) { *lenPtr = lengthProc(listObj); return TCL_OK; } - /* - * TODO - * Unlike the original list code, this does not optimize for lindex'ing - * an empty string when the internal rep is not already a list. On the - * other hand, this code will be faster for the case where the object - * is currently a dict. Benchmark the two cases. - */ + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { return TCL_ERROR; } @@ -2108,12 +2109,12 @@ Tcl_ListObjReplace( { ListRep listRep; Tcl_Size origListLen; - ptrdiff_t lenChange; - ptrdiff_t leadSegmentLen; - ptrdiff_t tailSegmentLen; + Tcl_Size lenChange; + Tcl_Size leadSegmentLen; + Tcl_Size tailSegmentLen; Tcl_Size numFreeSlots; - ptrdiff_t leadShift; - ptrdiff_t tailShift; + Tcl_Size leadShift; + Tcl_Size tailShift; Tcl_Obj **listObjs; int favor; @@ -2129,8 +2130,6 @@ Tcl_ListObjReplace( if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) return TCL_ERROR; /* Cannot be converted to a list */ - /* TODO - will need modification if Tcl9 sticks to unsigned indices */ - /* Make limits sane */ origListLen = ListRepLength(&listRep); if (first < 0) { @@ -2279,7 +2278,7 @@ Tcl_ListObjReplace( * be an explicit alloc and memmove which would let us redistribute * free space. */ - if ((ptrdiff_t)numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { + if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { /* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14,27,32,41} */ ListStore *newStorePtr = ListStoreReallocate(listRep.storePtr, origListLen + lenChange); @@ -2306,7 +2305,7 @@ Tcl_ListObjReplace( * TODO - for unshared case ONLY, consider a "move" based implementation */ if (ListRepIsShared(&listRep) || /* 3a */ - (ptrdiff_t)numFreeSlots < lenChange || /* 3b */ + numFreeSlots < lenChange || /* 3b */ (origListLen + lenChange) < (listRep.storePtr->numAllocated / 4) /* 3c */ ) { ListRep newRep; @@ -2421,9 +2420,9 @@ Tcl_ListObjReplace( * or need to shift both. In the former case, favor shifting the * smaller segment. */ - ptrdiff_t leadSpace = ListRepNumFreeHead(&listRep); - ptrdiff_t tailSpace = ListRepNumFreeTail(&listRep); - ptrdiff_t finalFreeSpace = leadSpace + tailSpace - lenChange; + Tcl_Size leadSpace = ListRepNumFreeHead(&listRep); + Tcl_Size tailSpace = ListRepNumFreeTail(&listRep); + Tcl_Size finalFreeSpace = leadSpace + tailSpace - lenChange; LIST_ASSERT((leadSpace + tailSpace) >= lenChange); if (leadSpace >= lenChange @@ -2440,7 +2439,7 @@ Tcl_ListObjReplace( * insertions. */ if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) { - ptrdiff_t postShiftLeadSpace = leadSpace - lenChange; + Tcl_Size postShiftLeadSpace = leadSpace - lenChange; if (postShiftLeadSpace > (finalFreeSpace/2)) { Tcl_Size extraShift = postShiftLeadSpace - (finalFreeSpace / 2); leadShift -= extraShift; @@ -2457,7 +2456,7 @@ Tcl_ListObjReplace( * See comments above. This is analogous. */ if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { - ptrdiff_t postShiftTailSpace = tailSpace - lenChange; + Tcl_Size postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { /* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */ Tcl_Size extraShift = postShiftTailSpace - (finalFreeSpace / 2); @@ -2632,7 +2631,7 @@ TclLindexList( /* * The argument is neither an index nor a well-formed list. * Report the error via TclLindexFlat. - * TODO - This is as original. why not directly return an error? + * TODO - This is as original code. why not directly return an error? */ return TclLindexFlat(interp, listObj, 1, &argObj); } @@ -2676,6 +2675,7 @@ TclLindexFlat( Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that * represent the indices in the list. */ { + int status; Tcl_Size i; /* Handle AbstractList as special case */ @@ -2706,24 +2706,13 @@ TclLindexFlat( for (i=0 ; i<indexCount && listObj ; i++) { Tcl_Size index, listLen = 0; - Tcl_Obj **elemPtrs = NULL, *sublistCopy; + Tcl_Obj **elemPtrs = NULL; - /* - * Here we make a private copy of the current sublist, so we avoid any - * shimmering issues that might invalidate the elemPtr array below - * while we are still using it. See test lindex-8.4. - */ - - sublistCopy = TclListObjCopy(interp, listObj); - Tcl_DecrRefCount(listObj); - listObj = NULL; - - if (sublistCopy == NULL) { - /* The sublist is not a list at all => error. */ - break; + status = Tcl_ListObjLength(interp, listObj, &listLen); + if (status != TCL_OK) { + Tcl_DecrRefCount(listObj); + return NULL; } - LIST_ASSERT_TYPE(sublistCopy); - ListObjGetElements(sublistCopy, listLen, elemPtrs); if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1, &index) == TCL_OK) { @@ -2737,20 +2726,43 @@ TclLindexFlat( if (TclGetIntForIndexM( interp, indexArray[i], TCL_SIZE_MAX - 1, &index) != TCL_OK) { - Tcl_DecrRefCount(sublistCopy); + Tcl_DecrRefCount(listObj); return NULL; } } + Tcl_DecrRefCount(listObj); TclNewObj(listObj); + Tcl_IncrRefCount(listObj); } else { + Tcl_Obj *itemObj; + /* + * Must set the internal rep again because it may have been + * changed by TclGetIntForIndexM. See test lindex-8.4. + */ + if (!TclHasInternalRep(listObj, &tclListType)) { + status = SetListFromAny(interp, listObj); + if (status != TCL_OK) { + /* The list is not a list at all => error. */ + Tcl_DecrRefCount(listObj); + return NULL; + } + } + + ListObjGetElements(listObj, listLen, elemPtrs); + /* increment this reference count first before decrementing + * just in case they are the same Tcl_Obj + */ + itemObj = elemPtrs[index]; + Tcl_IncrRefCount(itemObj); + Tcl_DecrRefCount(listObj); /* Extract the pointer to the appropriate element. */ - listObj = elemPtrs[index]; + listObj = itemObj; } - Tcl_IncrRefCount(listObj); + } else { + Tcl_DecrRefCount(listObj); + listObj = NULL; } - Tcl_DecrRefCount(sublistCopy); } - return listObj; } @@ -3595,7 +3607,7 @@ TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace) return NULL; } - ListRepInit(capacity, NULL, 0, &listRep); + ListRepInit(capacity, NULL, LISTREP_PANIC_ON_FAIL, &listRep); ListStore *storePtr = listRep.storePtr; size_t i; diff --git a/generic/tclOO.h b/generic/tclOO.h index 775bd32..524acb9 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -63,7 +63,7 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp, - Tcl_ObjectContext objectContext, ptrdiff_t objc, Tcl_Obj *const *objv); + Tcl_ObjectContext objectContext, Tcl_Size objc, Tcl_Obj *const *objv); typedef void (Tcl_MethodDeleteProc)(void *clientData); typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, void **newClientData); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index c3f6fc2..0e666e9 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -589,12 +589,12 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); /* * A variation where the array is an array of structs. There's no issue with * possible NULLs; every element of the array will be iterated over and the - * varable set to a pointer to each of those elements in turn. - * REQUIRES DECLARATION: Tcl_Size i; + * variable set to a pointer to each of those elements in turn. + * REQUIRES DECLARATION: Tcl_Size i; See [96551aca55] for more FOREACH_STRUCT details. */ #define FOREACH_STRUCT(var,ary) \ - for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++) + if (i=0, (ary).num>0) for(; var=&((ary).list[i]), i<(ary).num; i++) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 63e38bb..d0703b3 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1,29 +1,27 @@ /* * tclStringObj.c -- * - * This file contains functions that implement string operations on Tcl - * objects. Some string operations work with UTF strings and others - * require Unicode format. Functions that require knowledge of the width - * of each character, such as indexing, operate on Unicode data. - * - * A Unicode string is an internationalized string. Conceptually, a - * Unicode string is an array of 16-bit quantities organized as a - * sequence of properly formed UTF-8 characters. There is a one-to-one - * map between Unicode and UTF characters. Because Unicode characters - * have a fixed width, operations such as indexing operate on Unicode - * data. The String object is optimized for the case where each UTF char + * This file contains functions that implement string operations on Tcl + * objects. Some string operations work with UTF-8 encoding forms. + * Functions that require knowledge of the width of each character, + * such as indexing, operate on fixed width encoding forms such as UTF-32. + * + * Conceptually, a string is a sequence of Unicode code points. Internally + * it may be stored in an encoding form such as a modified version of + * UTF-8 or UTF-16 (when TCL_UTF_MAX=3) or UTF-32. + * + * The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of - * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode - * is explicitly called). + * numChars, but we don't store the fixed form encoding (unless + * Tcl_GetUnicode is explicitly called). * - * The String object type stores one or both formats. The default - * behavior is to store UTF. Once Unicode is calculated by a function, it - * is stored in the internal rep for future access (without an additional - * O(n) cost). + * The String object type stores one or both formats. The default + * behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is + * stored in the internal rep for future access (without an additional + * O(n) cost). * * To allow many appends to be done to an object without constantly - * reallocating the space for the string or Unicode representation, we - * allocate double the space for the string or Unicode and use the + * reallocating space, we allocate double the space and use the * internal representation to keep track of how much space is used vs. * allocated. * @@ -2753,12 +2751,16 @@ AppendPrintfToObjVA( break; } + case 'p': + if (sizeof(size_t) == sizeof(Tcl_WideInt)) { + size = 2; + } + /* FALLTHRU */ case 'c': case 'i': case 'u': case 'd': case 'o': - case 'p': case 'x': case 'X': seekingConversion = 0; @@ -3139,8 +3141,7 @@ TclStringCat( { Tcl_Obj *objResultPtr, * const *ov; int binary = 1; - Tcl_Size oc; - Tcl_Size length = 0; + Tcl_Size oc, length = 0; int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0; Tcl_Size first = objc - 1; /* Index of first value possibly not empty */ Tcl_Size last = 0; /* Index of last value possibly not empty */ diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index d0c76cb..768c1ee 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -1,29 +1,12 @@ /* * tclStringRep.h -- * - * This file contains the definition of the Unicode string internal - * representation and macros to access it. + * This file contains the definition of internal representations of a string + * and macros to access it. * - * A Unicode string is an internationalized string. Conceptually, a - * Unicode string is an array of 16-bit quantities organized as a - * sequence of properly formed UTF-8 characters. There is a one-to-one - * map between Unicode and UTF characters. Because Unicode characters - * have a fixed width, operations such as indexing operate on Unicode - * data. The String object is optimized for the case where each UTF char - * in a string is only one byte. In this case, we store the value of - * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode - * is explicitly called). - * - * The String object type stores one or both formats. The default - * behavior is to store UTF. Once Unicode is calculated by a function, it - * is stored in the internal rep for future access (without an additional - * O(n) cost). - * - * To allow many appends to be done to an object without constantly - * reallocating the space for the string or Unicode representation, we - * allocate double the space for the string or Unicode and use the - * internal representation to keep track of how much space is used vs. - * allocated. + * Conceptually, a string is a sequence of Unicode code points. Internally + * it may be stored in an encoding form such as a modified version of UTF-8 + * or UTF-16 (when TCL_UTF_MAX=3) or UTF-32. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. @@ -39,15 +22,10 @@ /* * The following structure is the internal rep for a String object. It keeps * track of how much memory has been used and how much has been allocated for - * the Unicode and UTF string to enable growing and shrinking of the UTF and - * Unicode reps of the String object with fewer mallocs. To optimize string + * the various representations to enable growing and shrinking of + * the String object with fewer mallocs. To optimize string * length and indexing operations, this structure also stores the number of - * characters (same of UTF and Unicode!) once that value has been computed. - * - * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16 - * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This - * can be officially modified by altering the definition of Tcl_UniChar in - * tcl.h, but do not do that unless you are sure what you're doing! + * code points (independent of encoding form) once that value has been computed. */ typedef struct { @@ -57,15 +35,15 @@ typedef struct { * Unicode rep, or that the number of UTF bytes == * the number of chars. */ Tcl_Size allocated; /* The amount of space actually allocated for - * the UTF string (minus 1 byte for the + * the UTF-8 string (minus 1 byte for the * termination char). */ Tcl_Size maxChars; /* Max number of chars that can fit in the * space allocated for the Unicode array. */ int hasUnicode; /* Boolean determining whether the string has - * a Unicode representation. */ - Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size - * of this field depends on the 'maxChars' - * field above. */ + * a Tcl_UniChar representation. */ + Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Tcl_UniChar units. + * The actual size of this field depends on + * the maxChars field above. */ } String; /* Limit on string lengths. The -1 because limit does not include the nul */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 10c9bd2..8c34435 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2815,6 +2815,9 @@ Tcl_DStringSetLength( { Tcl_Size newsize; + if (length < 0) { + length = 0; + } if (length >= dsPtr->spaceAvl) { /* * There are two interesting cases here. In the first case, the user @@ -3803,8 +3806,8 @@ TclIndexEncode( } /* * We passed 2*INT_MAX as the "end value" to GetWideForIndex. The computed - * index will in one of the following ranges that need to be distinguished - * for encoding purposes in the following code. + * index will be in one of the following ranges that need to be + * distinguished for encoding purposes in the following code. * (1) 0:INT_MAX when * (a) objPtr was a pure non-negative numeric value in that range * (b) objPtr was a numeric computation M+/-N with a result in that range @@ -3853,7 +3856,7 @@ TclIndexEncode( * error is raised. On 32-bit systems, indices in that range indicate * the position after the end and so do not raise an error. */ - if ((sizeof(int) != sizeof(size_t)) && + if ((sizeof(int) != sizeof(Tcl_Size)) && (wide > INT_MAX) && (wide < WIDE_MAX-1)) { /* 2(a,b) on 64-bit systems*/ goto rangeerror; @@ -3883,7 +3886,7 @@ TclIndexEncode( * indices in that range indicate the position before the beginning * and so do not raise an error. */ - if ((sizeof(int) != sizeof(size_t)) && + if ((sizeof(int) != sizeof(Tcl_Size)) && (wide > (ENDVALUE - LIST_MAX)) && (wide <= INT_MAX)) { /* 1(c), 4(a,b) on 64-bit systems */ goto rangeerror; diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index a30c8fb..e4604dc 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -640,7 +640,7 @@ SetOSTypeFromAny( int result = TCL_OK; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); - size_t length; + Tcl_Size length; string = Tcl_GetStringFromObj(objPtr, &length); Tcl_UtfToExternalDStringEx(NULL, encoding, string, length, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl index 17f22e9..575c78e 100644 --- a/tests-perf/listPerf.tcl +++ b/tests-perf/listPerf.tcl @@ -3,8 +3,9 @@ # # listPerf.tcl -- # -# This file provides performance tests for list operations. -# +# This file provides performance tests for list operations. Run +# tclsh listPerf.tcl help +# for options. # ------------------------------------------------------------------------ # # See the file "license.terms" for information on usage and redistribution @@ -77,7 +78,9 @@ namespace eval perf::list { break } --* { - error "Unknown option $arg" + puts stderr "Unknown option $arg" + print_usage + exit 1 } default { # Remaining will be passed back to the caller @@ -383,6 +386,8 @@ namespace eval perf::list { comment Create a list from two lists - real test of expansion speed perf measure [list_describe $len "from a {*}list {*}list"] {list {*}$L {*}$L} [list len [expr {$len/2}]] } + + perf destroy } proc lappend_describe {share_mode len num iters} { @@ -1217,7 +1222,7 @@ namespace eval perf::list { set commands [lmap sel $selections { if {$sel eq "help"} { print_usage - continue + exit 0 } set cmd ::perf::list::${sel}_perf if {$cmd ni [info commands ::perf::list::*_perf]} { diff --git a/tests/bigdata.test b/tests/bigdata.test index 794e38d..5eb7b89 100644 --- a/tests/bigdata.test +++ b/tests/bigdata.test @@ -1114,10 +1114,9 @@ bigtestRO concat-bigdata-1 "concat" {4294967296 {0 1 2 3 4} {6 7 0 1 2} {3 4 5 6 test puts-bigdata-1 "puts" -setup { set fpath [makeFile {} bug-0306a5563.data] } -constraints { - bug0306a5563 bigdata } -body { - set fd [open $fpath w] + set fd [open $fpath w] puts -nonewline $fd [testbigdata string 0x80000001] close $fd set fd [open $fpath] @@ -1130,13 +1129,12 @@ test puts-bigdata-1 "puts" -setup { test puts-bigdata-2 "puts" -setup { set fpath [tcltest::makeFile {} bug-0306a5563.data] } -constraints { - bug0306a5563 bigdata } -body { set fd [open $fpath w] set s [testbigdata string 0x7FFFFFFE] - # The character to append in the next line is —, EM DASH, - # code point 0x2014 (decimal 8212, UTF-8 #xE2 #x80 #x94) + # The character to append in the next line is —, EM DASH, + # code point 0x2014 (decimal 8212, UTF-8 #xE2 #x80 #x94) append s \u2014 puts -nonewline $fd $s close $fd diff --git a/tests/chanio.test b/tests/chanio.test index 29ef1e7..e5e74cb 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -1098,7 +1098,7 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" chan close $f set f [open $path(test1)] - chan configure $f -encoding shiftjis + chan configure $f -encoding shiftjis -profile tcl8 lappend x [chan gets $f line] $line lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f] lappend x [chan gets $f line] $line diff --git a/tests/dstring.test b/tests/dstring.test index 23863d0..7c9d9f6 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -418,6 +418,24 @@ test dstring-4.2 {truncation} -constraints testdstring -setup { } -cleanup { testdstring free } -result {{} 0} +test dstring-4.3 {truncation} -constraints testdstring -setup { + testdstring free +} -body { + testdstring append "xwvut" -1 + # Pass a negative length to Tcl_DStringSetLength(); + # if not caught, causing '\0' to be written out-of-bounds, + # try corrupting dsPtr->length which begins + # 2*sizeof(Tcl_Size) bytes before dsPtr->staticSpace[], + # so that the result is -256 (on little endian systems) + # rather than e.g. -8 or -16. + # (sizeof(Tcl_Size) does not seem to be available via Tcl, + # so assume sizeof(Tcl_Size) == sizeof(void*) for Tcl 9.) + testdstring trunc [expr {-2*([package vsatisfies $tcl_version 9.0-] + ? $tcl_platform(pointerSize) : 4)}] + list [testdstring get] [testdstring length] +} -cleanup { + testdstring free +} -result {{} 0} test dstring-5.1 {copying to result} -constraints testdstring -setup { testdstring free diff --git a/tests/encoding.test b/tests/encoding.test index 09f3e42..26ddb69 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -464,7 +464,10 @@ test encoding-15.24 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} { test encoding-15.25 {UtfToUtfProc CESU-8} { encoding convertfrom cesu-8 \x00 } \x00 -test encoding-15.26 {UtfToUtfProc CESU-8} { +test {encoding-15.26 cesu-8 tclnull strict} {UtfToUtfProc CESU-8} { + encoding convertfrom -profile tcl8 cesu-8 \xC0\x80 +} \x00 +test {encoding-15.26 cesu-8 tclnull tcl8} {UtfToUtfProc CESU-8} { encoding convertfrom -profile tcl8 cesu-8 \xC0\x80 } \x00 test encoding-15.27 {UtfToUtfProc -profile strict CESU-8} { @@ -562,24 +565,35 @@ test encoding-16.18 { return done } [namespace current]] } -result done -test encoding-16.19 {Utf16ToUtfProc, bug [d19fe0a5b]} -body { +test {encoding-16.19 strict} {Utf16ToUtfProc, bug [d19fe0a5b]} -body { + encoding convertfrom -profile strict utf-16 "\x41\x41\x41" +} -returnCodes 1 -result {unexpected byte sequence starting at index 2: '\x41'} +test {encoding-16.19 tcl8} {Utf16ToUtfProc, bug [d19fe0a5b]} -body { encoding convertfrom -profile tcl8 utf-16 "\x41\x41\x41" } -result \u4141\uFFFD -test encoding-16.20 {Utf16ToUtfProc, bug [d19fe0a5b]} -constraints deprecated -body { +test encoding-16.20 {utf16ToUtfProc, bug [d19fe0a5b]} \ + -constraints deprecated -body { encoding convertfrom utf-16 "\xD8\xD8" } -result \uD8D8 -test encoding-16.21 {Utf32ToUtfProc, bug [d19fe0a5b]} -body { +test encoding-16.21.tcl8 {Utf32ToUtfProc, bug [d19fe0a5b]} -body { encoding convertfrom -profile tcl8 utf-32 "\x00\x00\x00\x00\x41\x41" } -result \x00\uFFFD +test encoding-16.21.strict {Utf32ToUtfProc, bug [d19fe0a5b]} -body { + encoding convertfrom -profile strict utf-32 "\x00\x00\x00\x00\x41\x41" +} -returnCodes 1 -result {unexpected byte sequence starting at index 4: '\x41'} + test encoding-16.22 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body { encoding convertfrom -profile strict utf-16le \x00\xD8 } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'} test encoding-16.23 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body { encoding convertfrom -profile strict utf-16le \x00\xDC } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'} -test encoding-16.24 {Utf32ToUtfProc} -body { - encoding convertfrom -profile tcl8 utf-32 "\xFF\xFF\xFF\xFF" -} -result \uFFFD +test {encoding-24.4 utf-8 invalid strict} {Parse invalid utf-8, strict} -body { + string length [encoding convertfrom -profile strict utf-8 "\xC0\x80"] +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} +test {encoding-24.4 utf-8 invalid tcl8} {UtfToUtfProc utf-8} { + encoding convertfrom -profile tcl8 utf-8 \xC0\x80 +} \x00 test encoding-16.25 {Utf32ToUtfProc} -body { encoding convertfrom -profile tcl8 utf-32 "\x01\x00\x00\x01" } -result \uFFFD @@ -789,16 +803,19 @@ test encoding-24.10 {Parse valid or invalid utf-8} { test encoding-24.11 {Parse valid or invalid utf-8} { string length [encoding convertfrom -profile tcl8 utf-8 "\xEF\xBF\xBF"] } 1 -test encoding-24.12 {Parse valid or invalid utf-8} -body { +test encoding-24.12 {Parse invalid utf-8} -body { encoding convertfrom -profile strict utf-8 "\xC0\x81" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} -test encoding-24.13 {Parse valid or invalid utf-8} -body { +test encoding-24.13 {Parse invalid utf-8} -body { encoding convertfrom -profile strict utf-8 "\xC1\xBF" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'} -test encoding-24.14 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC2\x80"] +test encoding-24.14 {Parse valid utf-8} { + expr {[encoding convertfrom utf-8 "\xC2\x80"] eq "\u80"} } 1 -test encoding-24.15 {Parse valid or invalid utf-8} -body { +test encoding-24.15.strict {Parse invalid utf-8, -profile strict} -body { + encoding convertfrom -profile strict utf-8 "Z\xE0\x80" +} -returnCodes 1 -result "unexpected byte sequence starting at index 1: '\\xE0'" +test encoding-24.15.tcl8 {Parse invalid utf-8, -profile tcl8} -body { encoding convertfrom -profile tcl8 utf-8 "Z\xE0\x80" } -result Z\xE0\u20AC test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { @@ -855,7 +872,7 @@ test encoding-24.31 {Parse invalid utf-8 with -profile tcl8} -body { test encoding-24.32 {Try to generate invalid utf-8} -body { encoding convertto utf-8 \uFFFF } -result \xEF\xBF\xBF -test encoding-24.33 {Try to generate noncharacter with -profile strict} -body { +test encoding-24.33 {Try to generate invalid utf-8} -body { encoding convertto -profile strict utf-8 \uFFFF } -result \xEF\xBF\xBF test encoding-24.34 {Try to generate invalid utf-8 with -profile tcl8} -body { diff --git a/tests/io.test b/tests/io.test index fb21535..e380146 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1184,7 +1184,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} { puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + fconfigure $f -encoding shiftjis -profile tcl8 set x [list [gets $f line] $line [eof $f]] close $f set x @@ -1539,67 +1539,67 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { } "{} timeout {} timeout 牦 {} eof 0 {}" test io-12.6 {ReadChars: too many chars read} { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat 뻯 20][string repeat . 20]] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat 뻯 20][string repeat . 20]] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 while {![eof $c]} { - read $c 15 + read $c 15 } close $c } {} test io-12.7 {ReadChars: too many chars read [bc5b790099]} { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat 뻯 10]....뻯] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat 뻯 10]....뻯] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 while {![eof $c]} { - read $c 7 + read $c 7 } close $c } {} @@ -1614,7 +1614,7 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 -test io-12.9 {ReadChars: multibyte chars split} -body { +test {io-12.9 profile tcl8} {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1622,18 +1622,34 @@ test io-12.9 {ReadChars: multibyte chars split} -body { set f [open $path(test1)] fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10 set in [read $f] - close $f + read $f scan [string index $in end] %c } -cleanup { catch {close $f} } -result 194 -test io-12.10 {ReadChars: multibyte chars split} -body { +test {io-12.10 strict} {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] - fconfigure $f -encoding utf-8 -buffersize 11 + fconfigure $f -encoding utf-8 -profile strict -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} -cleanup { + catch {close $f} +} -returnCodes 1 -match glob -result {error reading "file*":\ + invalid or incomplete multibyte or wide character} + + +test {io-12.10 tcl8} {ReadChars: multibyte chars split} -body { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xC2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10 set in [read $f] close $f scan [string index $in end] %c @@ -1990,7 +2006,7 @@ test io-14.9 {reuse of stdio special channels} {stdio fileevent} { file delete $path(test1) set f [open $path(script) w] puts $f { - array set path [lindex $argv 0] + array set path [lindex $argv 0] set f [open $path(test1) w] puts $f hello close $f @@ -2337,7 +2353,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \ close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open $path(output) w] close $f @@ -2351,9 +2367,9 @@ test io-27.6 {FlushChannel, async flushing, async close} \ vwait [namespace which -variable counter] } if {$counter == 1000} { - set result "file size only [file size $path(output)]" + set result "file size only [file size $path(output)]" } else { - set result ok + set result ok } } ok @@ -2427,9 +2443,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ vwait [namespace which -variable counter] } if {$counter == 1000} { - set result probably_broken + set result probably_broken } else { - set result ok + set result ok } } ok test io-28.4 Tcl_Close testchannel { @@ -4651,29 +4667,29 @@ test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { } -result {{} {} {} .......} test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) ....... - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] if {$n > 3} {set n 3} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -4685,30 +4701,30 @@ test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { } -result {{} {} {} .......} test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [string repeat \ - [string repeat . 64]\n[string repeat . 25] 2] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - if {$n > 65} {set n 65} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [string repeat \ + [string repeat . 64]\n[string repeat . 25] 2] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 65} {set n 65} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -5429,8 +5445,8 @@ test io-36.3 {Tcl_InputBlocked vs files, short read} { } {0 abc 0 defghijklmnop 0 1} test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} { proc in {f} { - variable l - variable x + variable l + variable x lappend l [read $f 3] if {[eof $f]} {lappend l eof; close $f; set x done} } @@ -5465,8 +5481,8 @@ test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles } {0 abc 0 defghijklmnop 0 1} test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} { proc in {f} { - variable l - variable x + variable l + variable x lappend l [read $f 3] if {[eof $f]} {lappend l eof; close $f; set x done} } @@ -5863,7 +5879,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or set l } {{} auto} test io-39.24 {Tcl_SetChannelOption, server socket is not readable or - writable so we can't change -eofchar or -translation } { + writable so we can't change -eofchar or -translation } { set l [list] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] fconfigure $sock -eofchar D -translation lf @@ -6361,23 +6377,23 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent not test io-46.2 {Tcl event loop vs multiple interpreters} testfevent { testfevent create testfevent cmd { - variable x 0 - after 100 {set x triggered} - vwait [namespace which -variable x] - set x + variable x 0 + after 100 {set x triggered} + vwait [namespace which -variable x] + set x } } {triggered} test io-46.3 {Tcl event loop vs multiple interpreters} testfevent { testfevent create testfevent cmd { - set x 0 - after 10 {lappend x timer} - after 30 - set result $x - update idletasks - lappend result $x - update - lappend result $x + set x 0 + after 10 {lappend x timer} + after 30 + set result $x + update idletasks + lappend result $x + update + lappend result $x } } {0 0 {0 timer}} @@ -6394,7 +6410,7 @@ test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} { lappend x [fileevent $f2 readable] testfevent delete lappend x [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] + [fileevent $f3 readable] close $f close $f2 close $f3 @@ -6410,11 +6426,11 @@ test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} { testfevent share $f2 testfevent share $f3 testfevent cmd "fileevent $f2 readable {script 2} - fileevent $f3 readable {script 3}" + fileevent $f3 readable {script 3}" fileevent $f4 readable {script 4} testfevent delete set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + [fileevent $f3 readable] [fileevent $f4 readable]] close $f close $f2 close $f3 @@ -6432,7 +6448,7 @@ test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} { fileevent $f readable {script 1} fileevent $f2 readable {script 2} testfevent cmd "fileevent $f3 readable {script 3} - fileevent $f4 readable {script 4}" + fileevent $f4 readable {script 4}" testfevent delete set x [list [fileevent $f readable] [fileevent $f2 readable] \ [fileevent $f3 readable] [fileevent $f4 readable]] @@ -6451,8 +6467,8 @@ test io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent $f readable {script 2} fileevent $f2 readable {script 3} set x [list [fileevent $f2 readable] \ - [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] testfevent delete close $f close $f2 @@ -6466,7 +6482,7 @@ test io-47.5 {file events on shared files, deleting file events} {testfevent fil fileevent $f readable {script 2} testfevent cmd "fileevent $f readable {}" set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [fileevent $f readable]] testfevent delete close $f set x @@ -7322,7 +7338,7 @@ test io-52.3 {TclCopyChannel} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7363,7 +7379,7 @@ test io-52.5 {TclCopyChannel, all} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7380,7 +7396,7 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7397,7 +7413,7 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7414,7 +7430,7 @@ test io-52.6 {TclCopyChannel} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7431,7 +7447,7 @@ test io-52.7 {TclCopyChannel} {fcopy} { close $f1 close $f2 if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7985,8 +8001,8 @@ proc doFcopy {in out {bytes 0} {error {}}} { } elseif {[eof $in]} { set fcopyTestDone 0 } else { - # Delay next fcopy to wait for size>0 input bytes - after 100 [list fcopy $in $out -size 1000 \ + # Delay next fcopy to wait for size>0 input bytes + after 100 [list fcopy $in $out -size 1000 \ -command [namespace code [list doFcopy $in $out]]] } } @@ -8001,9 +8017,9 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} { proc Write {count} { puts -nonewline "1234567890" if {[incr count -1]} { - after 10 [list Write $count] + after 10 [list Write $count] } else { - set ::ready 1 + set ::ready 1 } } fconfigure stdout -buffering none @@ -8345,21 +8361,21 @@ test io-53.12.1 { } A test io-53.13 {TclCopyChannel: read error reporting} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - return {initialize finalize watch read} - } - finalize { - return - } - watch {} - read { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch read} + } + finalize { + return + } + watch {} + read { error FAIL - } - } + } + } } set outFile [makeFile {} out] } -body { @@ -8375,21 +8391,21 @@ test io-53.13 {TclCopyChannel: read error reporting} -setup { } -result {error reading "rc*": *} -returnCodes error -match glob test io-53.14 {TclCopyChannel: write error reporting} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - return {initialize finalize watch write} - } - finalize { - return - } - watch {} - write { - error FAIL - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch write} + } + finalize { + return + } + watch {} + write { + error FAIL + } + } } set inFile [makeFile {aaa} in] } -body { @@ -8405,35 +8421,35 @@ test io-53.14 {TclCopyChannel: write error reporting} -setup { } -result {error writing "*": *} -returnCodes error -match glob test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { proc driver {cmd args} { - variable buffer - variable index - variable blocked - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - set blocked($chan) 1 - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) blocked($chan) - return - } - watch {} - read { - if {$blocked($chan)} { - set blocked($chan) [expr {!$blocked($chan)}] - return -code error EAGAIN - } - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 @@ -8449,35 +8465,35 @@ test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { } -result 100 test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { proc driver {cmd args} { - variable buffer - variable index - variable blocked - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - set blocked($chan) 1 - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) blocked($chan) - return - } - watch {} - read { - if {$blocked($chan)} { - set blocked($chan) [expr {!$blocked($chan)}] - return -code error EAGAIN - } - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 -translation lf @@ -8493,29 +8509,29 @@ test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { } -result 100 test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - line\n[string repeat a 100]line\n] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + line\n[string repeat a 100]line\n] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 -translation lf -buffersize 107 diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 1c06ba3..471659a 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -1367,7 +1367,7 @@ test iocmd-24.15 {chan write, EAGAIN means that writing is not allowed at this t test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} + proc foo args {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] note [fconfigure $c] close $c @@ -1376,7 +1376,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} - proc foo {args} {oninit cget cgetall; onfinal; track; return ""} + proc foo args {oninit cget cgetall; onfinal; track; return ""} set c [chan create {r w} foo] note [fconfigure $c] close $c @@ -1385,9 +1385,9 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { } -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} - proc foo {args} { + proc foo args { oninit cget cgetall; onfinal; track - return "-bar foo -snarf x" + return {-bar foo -snarf x} } set c [chan create {r w} foo] note [fconfigure $c] diff --git a/tests/ooUtil.test b/tests/ooUtil.test index c8be9c8..f41c668 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -429,7 +429,7 @@ test ooUtil-5.1 {TIP 478: abstract} -setup { parent destroy } -result {1 1 1 123 456 ::y} -test ooUtil-6.1 {TIP 478: classvarable} -setup { +test ooUtil-6.1 {TIP 478: classvariable} -setup { oo::class create parent } -body { oo::class create xyz { @@ -459,7 +459,7 @@ test ooUtil-6.1 {TIP 478: classvarable} -setup { } -cleanup { parent destroy } -result {{1 2} {1 2} {2 3}} -test ooUtil-6.2 {TIP 478: classvarable error case} -setup { +test ooUtil-6.2 {TIP 478: classvariable error case} -setup { oo::class create parent } -body { oo::class create xyz { @@ -475,7 +475,7 @@ test ooUtil-6.2 {TIP 478: classvarable error case} -setup { } -returnCodes error -cleanup { parent destroy } -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element} -test ooUtil-6.3 {TIP 478: classvarable error case} -setup { +test ooUtil-6.3 {TIP 478: classvariable error case} -setup { oo::class create parent } -body { oo::class create xyz { diff --git a/tests/tailcall.test b/tests/tailcall.test index c9ec674..0016845 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -709,7 +709,7 @@ test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body { } -returnCodes 1 -result {namespace "::ns" not found} test tailcall-bug-784befb0ba {tailcall crash with 254 args} -body { - proc tccrash args {llength $args} + proc tccrash args {llength $args} # Must be EXACTLY 254 for crash proc p {} [list tailcall tccrash {*}[lrepeat 254 x]] p diff --git a/unix/dltest/pkgt.c b/unix/dltest/pkgt.c index 77e21ac..1f326f5 100644 --- a/unix/dltest/pkgt.c +++ b/unix/dltest/pkgt.c @@ -16,10 +16,10 @@ static int TraceProc2 ( void *clientData, Tcl_Interp *interp, - ptrdiff_t level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - ptrdiff_t objc, + Tcl_Size objc, struct Tcl_Obj *const *objv) { (void)clientData; @@ -55,12 +55,12 @@ static int Pkgt_EqObjCmd2( void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - ptrdiff_t objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_WideInt result; const char *str1, *str2; - ptrdiff_t len1, len2; + Tcl_Size len1, len2; (void)dummy; if (objc != 3) { diff --git a/win/tclWinFile.c b/win/tclWinFile.c index bcd0920..cf71974 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -2725,7 +2725,7 @@ TclpObjNormalizePath( sizeof(WCHAR)); Tcl_DStringAppend(&dsNorm, (const char *) nativeName, - (int) (wcslen(nativeName)*sizeof(WCHAR))); + wcslen(nativeName)*sizeof(WCHAR)); } } } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 3732550..1ccb105 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -804,7 +804,7 @@ GetValue( */ length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR)); - Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR)); + Tcl_DStringSetLength(&data, length * sizeof(WCHAR)); result = RegQueryValueExW(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } @@ -865,7 +865,7 @@ GetValue( */ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (BYTE *) Tcl_DStringValue(&data), (int) length)); + (BYTE *) Tcl_DStringValue(&data), length)); } Tcl_DStringFree(&data); return result; @@ -914,7 +914,7 @@ GetValueNames( resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); + Tcl_DStringSetLength(&buffer, MAX_KEY_LENGTH * sizeof(WCHAR)); index = 0; result = TCL_OK; @@ -1221,7 +1221,7 @@ RecursiveDeleteKey( } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); + Tcl_DStringSetLength(&subkey, MAX_KEY_LENGTH * sizeof(WCHAR)); mode = saveMode; while (result == ERROR_SUCCESS) { |