From da96c5304100d70d932bcb73796c068d7e416cae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Mar 2019 20:39:42 +0000 Subject: Even better support for -DTCL_UTF_MAX=6. Ongoing improvements (TIP being planned) --- doc/source.n | 2 +- generic/tcl.decls | 13 +++-- generic/tcl.h | 2 +- generic/tclDecls.h | 39 ++++++++++---- generic/tclEncoding.c | 138 +++++++++++++++++++++++++++++++++++++++++++++---- generic/tclInt.h | 8 +-- generic/tclStringObj.c | 6 +-- generic/tclStubInit.c | 29 +++++++++-- generic/tclUtf.c | 10 ++-- tests/chanio.test | 4 +- tests/encoding.test | 23 ++++++--- tests/io.test | 4 +- tests/ioCmd.test | 8 +-- tests/source.test | 4 +- win/tclWin32Dll.c | 4 +- win/tclWinFile.c | 8 +-- 16 files changed, 236 insertions(+), 66 deletions(-) diff --git a/doc/source.n b/doc/source.n index 3fc001e..353b8fb 100644 --- a/doc/source.n +++ b/doc/source.n @@ -43,7 +43,7 @@ or which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP -A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, unicode). +A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, utf-16, ucs-2). .PP The \fB\-encoding\fR option is used to specify the encoding of the data stored in \fIfileName\fR. When the \fB\-encoding\fR option diff --git a/generic/tcl.decls b/generic/tcl.decls index 5b3afeb..7ceb8c0 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1339,7 +1339,7 @@ declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars) + Tcl_Obj *Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars) } declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, @@ -1352,7 +1352,7 @@ declare 381 { int Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } declare 382 {deprecated {No longer in use, changed to macro}} { - Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) + unsigned short *Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 { Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) @@ -1542,7 +1542,7 @@ declare 433 { # introduced in 8.4a3 declare 434 { - Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) + unsigned short *Tcl_GetUtf16FromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf @@ -2379,6 +2379,13 @@ declare 643 { int Tcl_IsShared(Tcl_Obj *objPtr) } +declare 644 { + int *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) +} +declare 645 { + Tcl_Obj *Tcl_NewUnicodeObj(const int *unicode, int numChars) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index c287a84..27cf7c3 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2160,7 +2160,7 @@ typedef struct Tcl_EncodingType { * XXX: string rep that Tcl_UniChar represents. Changing the size * XXX: of Tcl_UniChar is /not/ supported. */ -typedef unsigned int Tcl_UniChar; +typedef int Tcl_UniChar; #else typedef unsigned short Tcl_UniChar; #endif diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 865c960..6f1a956 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1139,7 +1139,7 @@ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ -EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, +EXTERN Tcl_Obj * Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, @@ -1150,7 +1150,7 @@ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index); /* 382 */ TCL_DEPRECATED("No longer in use, changed to macro") -Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); +unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ @@ -1295,8 +1295,7 @@ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ -EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, - int *lengthPtr); +EXTERN unsigned short * Tcl_GetUtf16FromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ TCL_DEPRECATED("") int Tcl_GetMathFuncInfo(Tcl_Interp *interp, @@ -1896,6 +1895,11 @@ EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr); /* 643 */ EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); +/* 644 */ +EXTERN int * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, + int *lengthPtr); +/* 645 */ +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const int *unicode, int numChars); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2309,11 +2313,11 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ + Tcl_Obj * (*tcl_NewUtf16Obj) (const unsigned short *unicode, int numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ @@ -2365,7 +2369,7 @@ typedef struct TclStubs { char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ - Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ + unsigned short * (*tcl_GetUtf16FromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ @@ -2575,6 +2579,8 @@ typedef struct TclStubs { void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ + int * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 644 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const int *unicode, int numChars); /* 645 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3361,8 +3367,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RegExpExecObj) /* 376 */ #define Tcl_RegExpGetInfo \ (tclStubsPtr->tcl_RegExpGetInfo) /* 377 */ -#define Tcl_NewUnicodeObj \ - (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ +#define Tcl_NewUtf16Obj \ + (tclStubsPtr->tcl_NewUtf16Obj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ @@ -3473,8 +3479,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ -#define Tcl_GetUnicodeFromObj \ - (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ +#define Tcl_GetUtf16FromObj \ + (tclStubsPtr->tcl_GetUtf16FromObj) /* 434 */ #define Tcl_GetMathFuncInfo \ (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ #define Tcl_ListMathFuncs \ @@ -3893,6 +3899,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ +#define Tcl_GetUnicodeFromObj \ + (tclStubsPtr->tcl_GetUnicodeFromObj) /* 644 */ +#define Tcl_NewUnicodeObj \ + (tclStubsPtr->tcl_NewUnicodeObj) /* 645 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4074,6 +4084,13 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_BackgroundError #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) +#if TCL_UTF_MAX <= 4 +# undef Tcl_GetUnicodeFromObj +# define Tcl_GetUnicodeFromObj Tcl_GetUtf16FromObj +# undef Tcl_NewUnicodeObj +# define Tcl_NewUnicodeObj Tcl_NewUtf16Obj +#endif + /* * Deprecated Tcl procedures: */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 7eb73e8..74e7513 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -234,12 +234,17 @@ static int TableToUtfProc(ClientData clientData, const char *src, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static size_t unilen(const char *src); -static int UniCharToUtfProc(ClientData clientData, +static int Utf16ToUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static int UtfToUniCharProc(ClientData clientData, +static int UtfToUtf16Proc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int UtfToUcs2Proc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, @@ -595,14 +600,27 @@ TclInitEncodingSubsystem(void) type.clientData = NULL; Tcl_CreateEncoding(&type); - type.encodingName = "unicode"; - type.toUtfProc = UniCharToUtfProc; - type.fromUtfProc = UtfToUniCharProc; + type.encodingName = "ucs-2"; + type.toUtfProc = Utf16ToUtfProc; + type.fromUtfProc = UtfToUcs2Proc; type.freeProc = NULL; type.nullSize = 2; type.clientData = NULL; Tcl_CreateEncoding(&type); + type.encodingName = "utf-16"; + type.toUtfProc = Utf16ToUtfProc; + type.fromUtfProc = UtfToUtf16Proc; + type.freeProc = NULL; + type.nullSize = 2; + type.clientData = NULL; + Tcl_CreateEncoding(&type); + +#ifndef TCL_NO_DEPRECATED + type.encodingName = "unicode"; + Tcl_CreateEncoding(&type); +#endif + /* * Need the iso8859-1 encoding in order to process binary data, so force * it to always be embedded. Note that this encoding *must* be a proper @@ -2401,9 +2419,9 @@ UtfToUtfProc( /* *------------------------------------------------------------------------- * - * UniCharToUtfProc -- + * Utf16ToUtfProc -- * - * Convert from Unicode to UTF-8. + * Convert from UTF-16 to UTF-8. * * Results: * Returns TCL_OK if conversion was successful. @@ -2415,7 +2433,7 @@ UtfToUtfProc( */ static int -UniCharToUtfProc( +Utf16ToUtfProc( ClientData clientData, /* Not used. */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ @@ -2491,9 +2509,9 @@ UniCharToUtfProc( /* *------------------------------------------------------------------------- * - * UtfToUniCharProc -- + * UtfToUtf16Proc -- * - * Convert from UTF-8 to Unicode. + * Convert from UTF-8 to UTF-16. * * Results: * Returns TCL_OK if conversion was successful. @@ -2505,7 +2523,7 @@ UniCharToUtfProc( */ static int -UtfToUniCharProc( +UtfToUtf16Proc( ClientData clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ @@ -2612,6 +2630,104 @@ UtfToUniCharProc( /* *------------------------------------------------------------------------- * + * UtfToUcs2Proc -- + * + * Convert from UTF-8 to UCS-2. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UtfToUcs2Proc( + ClientData clientData, /* TableEncodingData that specifies + * encoding. */ + const char *src, /* Source string in UTF-8. */ + int srcLen, /* Source string length in bytes. */ + int flags, /* Conversion control flags. */ + Tcl_EncodingState *statePtr,/* Place for conversion routine to store state + * information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst, /* Output buffer in which converted string is + * stored. */ + int dstLen, /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr, /* Filled with the number of bytes from the + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ + int *dstWrotePtr, /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr) /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; + int result, numChars, len; + Tcl_UniChar ch = 0; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - sizeof(Tcl_UniChar); + + result = TCL_OK; + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + src += (len = TclUtfToUniChar(src, &ch)); + if ((ch >= 0xD800) && (len < 3)) { + src += TclUtfToUniChar(src, &ch); + ch = 0xFFFD; + } + + /* + * Need to handle this in a way that won't cause misalignment by + * casting dst to a Tcl_UniChar. [Bug 1122671] + */ + +#ifdef WORDS_BIGENDIAN + *dst++ = (ch >> 8); + *dst++ = (ch & 0xFF); +#else + *dst++ = (ch & 0xFF); + *dst++ = (ch >> 8); +#endif + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * * TableToUtfProc -- * * Convert from the encoding specified by the TableEncodingData into diff --git a/generic/tclInt.h b/generic/tclInt.h index beb7a35..0db08f9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3243,14 +3243,14 @@ MODULE_SCOPE void TclRegisterCommandTypeName( const char *nameStr); #if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) MODULE_SCOPE int TclUtfToWChar(const char *src, WCHAR *chPtr); -MODULE_SCOPE char * TclWCharToUtfDString(const WCHAR *uniStr, +MODULE_SCOPE char * Tcl_Utf16ToUtfDString(const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); -MODULE_SCOPE WCHAR * TclUtfToWCharDString(const char *src, +MODULE_SCOPE unsigned short * Tcl_UtfToUtf16DString(const char *src, int length, Tcl_DString *dsPtr); #else # define TclUtfToWChar TclUtfToUniChar -# define TclWCharToUtfDString Tcl_UniCharToUtfDString -# define TclUtfToWCharDString Tcl_UtfToUniCharDString +# define Tcl_Utf16ToUtfDString Tcl_UniCharToUtfDString +# define Tcl_UtfToUtf16DString Tcl_UtfToUniCharDString #endif MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index ee0a3c3..6cbf5e7 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -606,14 +606,14 @@ Tcl_GetUniChar( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && (TCL_UTF_MAX<=4) #undef Tcl_GetUnicode -Tcl_UniChar * +unsigned short * Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string * for. */ { - return Tcl_GetUnicodeFromObj(objPtr, NULL); + return Tcl_GetUtf16FromObj(objPtr, NULL); } #endif /* TCL_NO_DEPRECATED */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e67d976..3cafbc0 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -59,6 +59,24 @@ #undef TclStaticPackage #undef Tcl_BackgroundError #define TclStaticPackage Tcl_StaticPackage +#undef Tcl_GetUnicodeFromObj +#undef Tcl_NewUnicodeObj + +static void uniCodePanic() { +#if TCL_UTF_MAX <= 4 + Tcl_Panic("This extension is compiled with -DTCL_UTF_MAX=6, but Tcl is compiled with -DTCL_UTF_MAX=4"); +#else + Tcl_Panic("This extension is compiled with -DTCL_UTF_MAX=4, but Tcl is compiled with -DTCL_UTF_MAX=6"); +#endif +} +#if TCL_UTF_MAX <= 4 +# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, int *)) uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, int)) uniCodePanic +#else +# define Tcl_GetUtf16FromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic +# define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *)) uniCodePanic +# define Tcl_NewUtf16Obj (Tcl_Obj *(*)(const unsigned short *, int)) uniCodePanic +#endif /* See bug 510001: TclSockMinimumBuffers needs plat imp */ #if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 @@ -244,7 +262,7 @@ Tcl_WinUtfToTChar( if (!string) { return NULL; } - return (char *)TclUtfToWCharDString(string, len, dsPtr); + return (char *)Tcl_UtfToUtf16DString(string, len, dsPtr); } char * @@ -262,7 +280,7 @@ Tcl_WinTCharToUtf( } else { len /= 2; } - return TclWCharToUtfDString((const WCHAR *)string, len, dsPtr); + return Tcl_Utf16ToUtfDString((const WCHAR *)string, len, dsPtr); } #if defined(TCL_WIDE_INT_IS_LONG) @@ -410,7 +428,6 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig # define Tcl_SetExitProc 0 # define Tcl_SetPanicProc 0 # define Tcl_FindExecutable 0 -# define Tcl_GetUnicode 0 # define TclOldFreeObj 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld @@ -1345,7 +1362,7 @@ const TclStubs tclStubs = { Tcl_UniCharIsPunct, /* 375 */ Tcl_RegExpExecObj, /* 376 */ Tcl_RegExpGetInfo, /* 377 */ - Tcl_NewUnicodeObj, /* 378 */ + Tcl_NewUtf16Obj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ Tcl_GetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ @@ -1401,7 +1418,7 @@ const TclStubs tclStubs = { Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ - Tcl_GetUnicodeFromObj, /* 434 */ + Tcl_GetUtf16FromObj, /* 434 */ Tcl_GetMathFuncInfo, /* 435 */ Tcl_ListMathFuncs, /* 436 */ Tcl_SubstObj, /* 437 */ @@ -1611,6 +1628,8 @@ const TclStubs tclStubs = { Tcl_IncrRefCount, /* 641 */ Tcl_DecrRefCount, /* 642 */ Tcl_IsShared, /* 643 */ + Tcl_GetUnicodeFromObj, /* 644 */ + Tcl_NewUnicodeObj, /* 645 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index b5d8824..cea0875 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -268,14 +268,14 @@ Tcl_UniCharToUtfDString( #if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) char * -TclWCharToUtfDString( - const WCHAR *uniStr, /* WCHAR string to convert to UTF-8. */ +Tcl_Utf16ToUtfDString( + const unsigned short *uniStr, /* WCHAR string to convert to UTF-8. */ int uniLength, /* Length of WCHAR string in Tcl_UniChars * (must be >= 0). */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { - const WCHAR *w, *wEnd; + const unsigned short *w, *wEnd; char *p, *string; int oldLength, len = 1; @@ -636,8 +636,8 @@ Tcl_UtfToUniCharDString( } #if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) -WCHAR * -TclUtfToWCharDString( +unsigned short * +Tcl_UtfToUtf16DString( const char *src, /* UTF-8 string to convert to Unicode. */ int length, /* Length of UTF-8 string in bytes, or -1 for * strlen(). */ diff --git a/tests/chanio.test b/tests/chanio.test index 9dc9e7c..1439fe4 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -888,7 +888,7 @@ test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup # Tcl_ExternalToUtf() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none - chan configure $f -encoding unicode + chan configure $f -encoding utf-16 chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 chan gets $f @@ -1129,7 +1129,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { chan event $f read [namespace code { lappend x [chan gets $f line] $line [testchannel inputbuffered $f] }] - chan configure $f -encoding unicode -buffersize 16 -blocking 0 + chan configure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] chan configure $f -translation auto -encoding ascii -blocking 1 # here diff --git a/tests/encoding.test b/tests/encoding.test index 4736928..da34f03 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -322,18 +322,29 @@ test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { set z } c080 -test encoding-16.1 {UnicodeToUtfProc} -body { - set val [encoding convertfrom unicode NN] +test encoding-16.1 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 NN] list $val [format %x [scan $val %c]] } -result "\u4e4e 4e4e" -test encoding-16.2 {UnicodeToUtfProc} -body { - set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"] +test encoding-16.2 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 "\xd8\xd8\xdc\xdc"] + list $val [format %x [scan $val %c]] +} -result "\U460dc 460dc" +test encoding-16.3 {Ucs2ToUtfProc} -body { + set val [encoding convertfrom ucs-2 NN] + list $val [format %x [scan $val %c]] +} -result "\u4e4e 4e4e" +test encoding-16.4 {Ucs2ToUtfProc} -body { + set val [encoding convertfrom ucs-2 "\xd8\xd8\xdc\xdc"] list $val [format %x [scan $val %c]] } -result "\U460dc 460dc" -test encoding-17.1 {UtfToUnicodeProc} -body { - encoding convertto unicode "\U460dc" +test encoding-17.1 {UtfToUtf16Proc} -body { + encoding convertto utf-16 "\U460dc" } -result "\xd8\xd8\xdc\xdc" +test encoding-17.2 {UtfToUcs2Proc} -body { + encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460dc"] +} -result "\ufffd" test encoding-18.1 {TableToUtfProc} { } {} diff --git a/tests/io.test b/tests/io.test index d42f59e..905f822 100644 --- a/tests/io.test +++ b/tests/io.test @@ -918,7 +918,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio test set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none - fconfigure $f -encoding unicode + fconfigure $f -encoding utf-16 puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" fconfigure $f -buffersize 16 gets $f @@ -1162,7 +1162,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha variable x lappend x [gets $f line] $line [testchannel inputbuffered $f] } - fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] fconfigure $f -translation auto -encoding ascii -blocking 1 # here diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 68bc542..dc6d1d3 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -231,22 +231,22 @@ test iocmd-8.6 {fconfigure command} { test iocmd-8.7 {fconfigure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding unicode + fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 set x [fconfigure $f1] close $f1 set x -} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} +} {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf} test iocmd-8.8 {fconfigure command} { file delete $path(test1) set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ - -eofchar {} -encoding unicode + -eofchar {} -encoding utf-16 set x "" lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] close $f1 set x -} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} +} {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}} test iocmd-8.9 {fconfigure command} { file delete $path(test1) set f1 [open $path(test1) w] diff --git a/tests/source.test b/tests/source.test index 8b146d3..c6cccd6 100644 --- a/tests/source.test +++ b/tests/source.test @@ -240,12 +240,12 @@ test source-7.2 {source -encoding test} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding unicode + fconfigure $f -encoding utf-16 puts $f "set symbol(square-root) \u221A; set x correct" close $f } -body { set x unset - source -encoding unicode $sourcefile + source -encoding utf-16 $sourcefile set x } -cleanup { removeFile source.file diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 36205e1..f5809e8 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -475,7 +475,7 @@ Tcl_WinUtfToTChar( if (!string) { return NULL; } - return TclUtfToWCharDString(string, len, dsPtr); + return (WCHAR *) Tcl_UtfToUtf16DString(string, len, dsPtr); } char * @@ -495,7 +495,7 @@ Tcl_WinTCharToUtf( } else { len /= 2; } - return TclWCharToUtfDString((unsigned short *)string, len, dsPtr); + return Tcl_Utf16ToUtfDString(string, len, dsPtr); } /* diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 3524a16..e5dd484 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1465,14 +1465,14 @@ TclpGetUserHome( Tcl_DStringFree(&ds); } else { Tcl_DStringInit(&ds); - wName = TclUtfToWCharDString(domain + 1, -1, &ds); + wName = Tcl_UtfToUtf16DString(domain + 1, -1, &ds); rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain); Tcl_DStringFree(&ds); nameLen = domain - name; } if (rc == 0) { Tcl_DStringInit(&ds); - wName = TclUtfToWCharDString(name, nameLen, &ds); + wName = Tcl_UtfToUtf16DString(name, nameLen, &ds); while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { /* * user does not exists - if domain was not specified, @@ -1490,14 +1490,14 @@ TclpGetUserHome( wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { size = lstrlenW(wHomeDir); - TclWCharToUtfDString(wHomeDir, size, bufferPtr); + Tcl_Utf16ToUtfDString(wHomeDir, size, bufferPtr); } else { /* * User exists but has no home dir. Return * "{GetProfilesDirectory}/". */ GetProfilesDirectoryW(buf, &size); - TclWCharToUtfDString(buf, size-1, bufferPtr); + Tcl_Utf16ToUtfDString(buf, size-1, bufferPtr); Tcl_DStringAppend(bufferPtr, "/", 1); Tcl_DStringAppend(bufferPtr, name, nameLen); } -- cgit v0.12 From 6d0e92b89ee6d83f8255334bf2f2a7c23e19c009 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 17 Mar 2019 22:01:42 +0000 Subject: More WIP. Seems to be *almost* working. --- generic/tcl.decls | 74 ++++++---- generic/tclDecls.h | 152 ++++++++++++++------- generic/tclInt.h | 11 -- generic/tclStringObj.c | 2 +- generic/tclStubInit.c | 44 ++++-- generic/tclUtf.c | 362 +++++++++++++++++++++++++++++++++++++------------ generic/tclUtil.c | 2 +- 7 files changed, 460 insertions(+), 187 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 6187cfc..2c21b91 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1197,9 +1197,9 @@ declare 334 { declare 335 { int Tcl_UtfToTitle(char *src) } -#declare 336 { -# int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr) -#} +declare 336 { + int Tcl_UtfToUtf16(const char *src, unsigned short *chPtr) +} declare 337 { int Tcl_UtfToUpper(char *src) } @@ -1245,21 +1245,21 @@ declare 350 { declare 351 { int Tcl_UniCharIsWordChar(int ch) } -#declare 352 { -# int Tcl_UniCharLen(const Tcl_UniChar *uniStr) -#} -#declare 353 { -# int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# unsigned long numChars) -#} -#declare 354 { -# char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, -# int uniLength, Tcl_DString *dsPtr) -#} -#declare 355 { -# Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src, -# int length, Tcl_DString *dsPtr) -#} +declare 352 { + int Tcl_Utf16Len(const unsigned short *uniStr) +} +declare 353 { + int Tcl_Utf16Ncmp(const unsigned short *ucs, const unsigned short *uct, + unsigned long numChars) +} +declare 354 { + char *Tcl_Utf16ToUtfDString(const unsigned short *uniStr, + int uniLength, Tcl_DString *dsPtr) +} +declare 355 { + unsigned short *Tcl_UtfToUtf16DString(const char *src, + int length, Tcl_DString *dsPtr) +} declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) @@ -1342,7 +1342,7 @@ declare 378 { Tcl_Obj *Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars) } declare 379 { - void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + void Tcl_SetUtf16Obj(Tcl_Obj *objPtr, const unsigned short *unicode, int numChars) } declare 380 { @@ -1358,7 +1358,7 @@ declare 383 { Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 { - void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + void Tcl_AppendUtf16ToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length) } declare 385 { @@ -1484,12 +1484,12 @@ declare 418 { int Tcl_IsChannelExisting(const char *channelName) } declare 419 { - int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, + int Tcl_Utf16Ncasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars) } declare 420 { - int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, - const Tcl_UniChar *uniPattern, int nocase) + int Tcl_Utf16CaseMatch(const unsigned short *uniStr, + const unsigned short *uniPattern, int nocase) } declare 421 { Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) @@ -2387,23 +2387,39 @@ declare 645 { Tcl_Obj *Tcl_NewUnicodeObj(const int *unicode, int numChars) } declare 646 { - int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr) + int Tcl_UtfToUniChar(const char *src, int *chPtr) } declare 647 { - int Tcl_UniCharLen(const Tcl_UniChar *uniStr) + int Tcl_UniCharLen(const int *uniStr) } declare 648 { - int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, + int Tcl_UniCharNcmp(const int *ucs, const int *uct, unsigned long numChars) } declare 649 { - char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, - int uniLength, Tcl_DString *dsPtr) + int Tcl_UniCharNcasecmp(const int *ucs, const int *uct, + unsigned long numChars) } declare 650 { - Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src, + char *Tcl_UniCharToUtfDString(const int *uniStr, + int uniLength, Tcl_DString *dsPtr) +} +declare 651 { + int *Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr) } +declare 652 { + int Tcl_UniCharCaseMatch(const int *uniStr, + const int *uniPattern, int nocase) +} +declare 653 { + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, + int length) +} +declare 654 { + void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const int *unicode, + int numChars) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b9f710f..f0d0b4c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1025,7 +1025,9 @@ EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, EXTERN int Tcl_UtfToLower(char *src); /* 335 */ EXTERN int Tcl_UtfToTitle(char *src); -/* Slot 336 is reserved */ +/* 336 */ +EXTERN int Tcl_UtfToUtf16(const char *src, + unsigned short *chPtr); /* 337 */ EXTERN int Tcl_UtfToUpper(char *src); /* 338 */ @@ -1059,10 +1061,18 @@ EXTERN int Tcl_UniCharIsSpace(int ch); EXTERN int Tcl_UniCharIsUpper(int ch); /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); -/* Slot 352 is reserved */ -/* Slot 353 is reserved */ -/* Slot 354 is reserved */ -/* Slot 355 is reserved */ +/* 352 */ +EXTERN int Tcl_Utf16Len(const unsigned short *uniStr); +/* 353 */ +EXTERN int Tcl_Utf16Ncmp(const unsigned short *ucs, + const unsigned short *uct, + unsigned long numChars); +/* 354 */ +EXTERN char * Tcl_Utf16ToUtfDString(const unsigned short *uniStr, + int uniLength, Tcl_DString *dsPtr); +/* 355 */ +EXTERN unsigned short * Tcl_UtfToUtf16DString(const char *src, int length, + Tcl_DString *dsPtr); /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); @@ -1133,8 +1143,8 @@ EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, EXTERN Tcl_Obj * Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars); /* 379 */ -EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, int numChars); +EXTERN void Tcl_SetUtf16Obj(Tcl_Obj *objPtr, + const unsigned short *unicode, int numChars); /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ @@ -1145,8 +1155,8 @@ unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ -EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, int length); +EXTERN void Tcl_AppendUtf16ToObj(Tcl_Obj *objPtr, + const unsigned short *unicode, int length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); @@ -1239,12 +1249,12 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ -EXTERN int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, +EXTERN int Tcl_Utf16Ncasecmp(const unsigned short *ucs, + const unsigned short *uct, unsigned long numChars); /* 420 */ -EXTERN int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, - const Tcl_UniChar *uniPattern, int nocase); +EXTERN int Tcl_Utf16CaseMatch(const unsigned short *uniStr, + const unsigned short *uniPattern, int nocase); /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key); @@ -1892,19 +1902,30 @@ EXTERN int * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, /* 645 */ EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const int *unicode, int numChars); /* 646 */ -EXTERN int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr); +EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); /* 647 */ -EXTERN int Tcl_UniCharLen(const Tcl_UniChar *uniStr); +EXTERN int Tcl_UniCharLen(const int *uniStr); /* 648 */ -EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, +EXTERN int Tcl_UniCharNcmp(const int *ucs, const int *uct, unsigned long numChars); /* 649 */ -EXTERN char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, - int uniLength, Tcl_DString *dsPtr); +EXTERN int Tcl_UniCharNcasecmp(const int *ucs, const int *uct, + unsigned long numChars); /* 650 */ -EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, +EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, + int uniLength, Tcl_DString *dsPtr); +/* 651 */ +EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); +/* 652 */ +EXTERN int Tcl_UniCharCaseMatch(const int *uniStr, + const int *uniPattern, int nocase); +/* 653 */ +EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, + const int *unicode, int length); +/* 654 */ +EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, + const int *unicode, int numChars); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2276,7 +2297,7 @@ typedef struct TclStubs { char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ int (*tcl_UtfToTitle) (char *src); /* 335 */ - void (*reserved336)(void); + int (*tcl_UtfToUtf16) (const char *src, unsigned short *chPtr); /* 336 */ int (*tcl_UtfToUpper) (char *src); /* 337 */ int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ @@ -2292,10 +2313,10 @@ typedef struct TclStubs { int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ - void (*reserved352)(void); - void (*reserved353)(void); - void (*reserved354)(void); - void (*reserved355)(void); + int (*tcl_Utf16Len) (const unsigned short *uniStr); /* 352 */ + int (*tcl_Utf16Ncmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ + char * (*tcl_Utf16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ + unsigned short * (*tcl_UtfToUtf16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ @@ -2319,12 +2340,12 @@ typedef struct TclStubs { int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ Tcl_Obj * (*tcl_NewUtf16Obj) (const unsigned short *unicode, int numChars); /* 378 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ + void (*tcl_SetUtf16Obj) (Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ - void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ + void (*tcl_AppendUtf16ToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ @@ -2359,8 +2380,8 @@ typedef struct TclStubs { void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */ - int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */ + int (*tcl_Utf16Ncasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ + int (*tcl_Utf16CaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ @@ -2586,11 +2607,15 @@ typedef struct TclStubs { int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ int * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 644 */ Tcl_Obj * (*tcl_NewUnicodeObj) (const int *unicode, int numChars); /* 645 */ - int (*tcl_UtfToUniChar) (const char *src, Tcl_UniChar *chPtr); /* 646 */ - int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 647 */ - int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 648 */ - char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 649 */ - Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 650 */ + int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ + int (*tcl_UniCharLen) (const int *uniStr); /* 647 */ + int (*tcl_UniCharNcmp) (const int *ucs, const int *uct, unsigned long numChars); /* 648 */ + int (*tcl_UniCharNcasecmp) (const int *ucs, const int *uct, unsigned long numChars); /* 649 */ + char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 650 */ + int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 651 */ + int (*tcl_UniCharCaseMatch) (const int *uniStr, const int *uniPattern, int nocase); /* 652 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const int *unicode, int length); /* 653 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const int *unicode, int numChars); /* 654 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3293,7 +3318,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UtfToLower) /* 334 */ #define Tcl_UtfToTitle \ (tclStubsPtr->tcl_UtfToTitle) /* 335 */ -/* Slot 336 is reserved */ +#define Tcl_UtfToUtf16 \ + (tclStubsPtr->tcl_UtfToUtf16) /* 336 */ #define Tcl_UtfToUpper \ (tclStubsPtr->tcl_UtfToUpper) /* 337 */ #define Tcl_WriteChars \ @@ -3324,10 +3350,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ -/* Slot 352 is reserved */ -/* Slot 353 is reserved */ -/* Slot 354 is reserved */ -/* Slot 355 is reserved */ +#define Tcl_Utf16Len \ + (tclStubsPtr->tcl_Utf16Len) /* 352 */ +#define Tcl_Utf16Ncmp \ + (tclStubsPtr->tcl_Utf16Ncmp) /* 353 */ +#define Tcl_Utf16ToUtfDString \ + (tclStubsPtr->tcl_Utf16ToUtfDString) /* 354 */ +#define Tcl_UtfToUtf16DString \ + (tclStubsPtr->tcl_UtfToUtf16DString) /* 355 */ #define Tcl_GetRegExpFromObj \ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ #define Tcl_EvalTokens \ @@ -3374,8 +3404,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RegExpGetInfo) /* 377 */ #define Tcl_NewUtf16Obj \ (tclStubsPtr->tcl_NewUtf16Obj) /* 378 */ -#define Tcl_SetUnicodeObj \ - (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ +#define Tcl_SetUtf16Obj \ + (tclStubsPtr->tcl_SetUtf16Obj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ @@ -3384,8 +3414,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetUnicode) /* 382 */ #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 383 */ -#define Tcl_AppendUnicodeToObj \ - (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ +#define Tcl_AppendUtf16ToObj \ + (tclStubsPtr->tcl_AppendUtf16ToObj) /* 384 */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ #define Tcl_SetNotifier \ @@ -3454,10 +3484,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ -#define Tcl_UniCharNcasecmp \ - (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ -#define Tcl_UniCharCaseMatch \ - (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ +#define Tcl_Utf16Ncasecmp \ + (tclStubsPtr->tcl_Utf16Ncasecmp) /* 419 */ +#define Tcl_Utf16CaseMatch \ + (tclStubsPtr->tcl_Utf16CaseMatch) /* 420 */ #define Tcl_FindHashEntry \ (tclStubsPtr->tcl_FindHashEntry) /* 421 */ #define Tcl_CreateHashEntry \ @@ -3914,10 +3944,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharLen) /* 647 */ #define Tcl_UniCharNcmp \ (tclStubsPtr->tcl_UniCharNcmp) /* 648 */ +#define Tcl_UniCharNcasecmp \ + (tclStubsPtr->tcl_UniCharNcasecmp) /* 649 */ #define Tcl_UniCharToUtfDString \ - (tclStubsPtr->tcl_UniCharToUtfDString) /* 649 */ + (tclStubsPtr->tcl_UniCharToUtfDString) /* 650 */ #define Tcl_UtfToUniCharDString \ - (tclStubsPtr->tcl_UtfToUniCharDString) /* 650 */ + (tclStubsPtr->tcl_UtfToUniCharDString) /* 651 */ +#define Tcl_UniCharCaseMatch \ + (tclStubsPtr->tcl_UniCharCaseMatch) /* 652 */ +#define Tcl_AppendUnicodeToObj \ + (tclStubsPtr->tcl_AppendUnicodeToObj) /* 653 */ +#define Tcl_SetUnicodeObj \ + (tclStubsPtr->tcl_SetUnicodeObj) /* 654 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4104,6 +4142,22 @@ extern const TclStubs *tclStubsPtr; # define Tcl_GetUnicodeFromObj Tcl_GetUtf16FromObj # undef Tcl_NewUnicodeObj # define Tcl_NewUnicodeObj Tcl_NewUtf16Obj +# undef Tcl_SetUnicodeObj +# define Tcl_SetUnicodeObj Tcl_SetUtf16Obj +# undef Tcl_AppendUnicodeToObj +# define Tcl_AppendUnicodeToObj Tcl_AppendUtf16ToObj +# undef Tcl_UniCharToUtfDString +# define Tcl_UniCharToUtfDString Tcl_Utf16ToUtfDString +# undef Tcl_UtfToUniCharDString +# define Tcl_UtfToUniCharDString Tcl_UtfToUtf16DString +# undef Tcl_UtfToUniChar +# define Tcl_UtfToUniChar Tcl_UtfToUtf16 +# undef Tcl_UniCharNcmp +# define Tcl_UniCharNcmp Tcl_Utf16Ncmp +# undef Tcl_UniCharNcasecmp +# define Tcl_UniCharNcasecmp Tcl_Utf16Ncasecmp +# undef Tcl_UniCharCaseMatch +# define Tcl_UniCharCaseMatch Tcl_Utf16CaseMatch #endif /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 99a2a58..37f4795 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3240,17 +3240,6 @@ MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); -#if (TCL_UTF_MAX > 3) && (defined(__CYGWIN__) || defined(_WIN32)) -MODULE_SCOPE int TclUtfToUtf16(const char *src, unsigned short *chPtr); -MODULE_SCOPE char * Tcl_Utf16ToUtfDString(const unsigned short *uniStr, - int uniLength, Tcl_DString *dsPtr); -MODULE_SCOPE unsigned short * Tcl_UtfToUtf16DString(const char *src, - int length, Tcl_DString *dsPtr); -#else -# define TclUtfToUtf16 TclUtfToUniChar -# define Tcl_Utf16ToUtfDString Tcl_UniCharToUtfDString -# define Tcl_UtfToUtf16DString Tcl_UtfToUniCharDString -#endif 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); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 205db00..46bd26f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -613,7 +613,7 @@ Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string * for. */ { - return Tcl_GetUtf16FromObj(objPtr, NULL); + return Tcl_GetUnicodeFromObj(objPtr, NULL); } #endif /* TCL_NO_DEPRECATED */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b85c360..ca26e8d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -62,6 +62,14 @@ #define TclStaticPackage Tcl_StaticPackage #undef Tcl_GetUnicodeFromObj #undef Tcl_NewUnicodeObj +#undef Tcl_SetUnicodeObj +#undef Tcl_UniCharToUtfDString +#undef Tcl_UtfToUniCharDString +#undef Tcl_UtfToUniChar +#undef Tcl_UniCharNcmp +#undef Tcl_UniCharNcasecmp +#undef Tcl_UniCharCaseMatch +#undef Tcl_AppendUnicodeToObj static void uniCodePanic() { #if TCL_UTF_MAX == 3 @@ -70,13 +78,21 @@ static void uniCodePanic() { Tcl_Panic("This extension is compiled with -DTCL_UTF_MAX==3, but Tcl is compiled with -DTCL_UTF_MAX>3"); #endif } + #if TCL_UTF_MAX == 3 +#ifdef TCL_NO_DEPRECATED +# define Tcl_GetUnicode 0 +#endif # define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, int *)) uniCodePanic # define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, int)) uniCodePanic +# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *,const int *, int)) uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const int *, int)) uniCodePanic #else -# define Tcl_GetUtf16FromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic # define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *)) uniCodePanic +# define Tcl_GetUtf16FromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic # define Tcl_NewUtf16Obj (Tcl_Obj *(*)(const unsigned short *, int)) uniCodePanic +# define Tcl_SetUtf16Obj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic +# define Tcl_AppendUtf16ToObj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic #endif /* See bug 510001: TclSockMinimumBuffers needs plat imp */ @@ -1335,7 +1351,7 @@ const TclStubs tclStubs = { Tcl_UtfToExternalDString, /* 333 */ Tcl_UtfToLower, /* 334 */ Tcl_UtfToTitle, /* 335 */ - 0, /* 336 */ + Tcl_UtfToUtf16, /* 336 */ Tcl_UtfToUpper, /* 337 */ Tcl_WriteChars, /* 338 */ Tcl_WriteObj, /* 339 */ @@ -1351,10 +1367,10 @@ const TclStubs tclStubs = { Tcl_UniCharIsSpace, /* 349 */ Tcl_UniCharIsUpper, /* 350 */ Tcl_UniCharIsWordChar, /* 351 */ - 0, /* 352 */ - 0, /* 353 */ - 0, /* 354 */ - 0, /* 355 */ + Tcl_Utf16Len, /* 352 */ + Tcl_Utf16Ncmp, /* 353 */ + Tcl_Utf16ToUtfDString, /* 354 */ + Tcl_UtfToUtf16DString, /* 355 */ Tcl_GetRegExpFromObj, /* 356 */ Tcl_EvalTokens, /* 357 */ Tcl_FreeParse, /* 358 */ @@ -1378,12 +1394,12 @@ const TclStubs tclStubs = { Tcl_RegExpExecObj, /* 376 */ Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUtf16Obj, /* 378 */ - Tcl_SetUnicodeObj, /* 379 */ + Tcl_SetUtf16Obj, /* 379 */ Tcl_GetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ Tcl_GetUnicode, /* 382 */ Tcl_GetRange, /* 383 */ - Tcl_AppendUnicodeToObj, /* 384 */ + Tcl_AppendUtf16ToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ @@ -1418,8 +1434,8 @@ const TclStubs tclStubs = { Tcl_SpliceChannel, /* 416 */ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ - Tcl_UniCharNcasecmp, /* 419 */ - Tcl_UniCharCaseMatch, /* 420 */ + Tcl_Utf16Ncasecmp, /* 419 */ + Tcl_Utf16CaseMatch, /* 420 */ Tcl_FindHashEntry, /* 421 */ Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ @@ -1648,8 +1664,12 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharLen, /* 647 */ Tcl_UniCharNcmp, /* 648 */ - Tcl_UniCharToUtfDString, /* 649 */ - Tcl_UtfToUniCharDString, /* 650 */ + Tcl_UniCharNcasecmp, /* 649 */ + Tcl_UniCharToUtfDString, /* 650 */ + Tcl_UtfToUniCharDString, /* 651 */ + Tcl_UniCharCaseMatch, /* 652 */ + Tcl_AppendUnicodeToObj, /* 653 */ + Tcl_SetUnicodeObj, /* 654 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index ff8f6bd..c5a2ca5 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -223,17 +223,17 @@ three: *--------------------------------------------------------------------------- */ +#undef Tcl_UniCharToUtfDString char * Tcl_UniCharToUtfDString( - const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */ - int uniLength, /* Length of Unicode string in Tcl_UniChars - * (must be >= 0). */ + const int *uniStr, /* Unicode string to convert to UTF-8. */ + int uniLength, /* Length of Unicode string (must be >= 0). */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { - const Tcl_UniChar *w, *wEnd; + const int *w, *wEnd; char *p, *string; - int oldLength, len = 1; + int oldLength; /* * UTF-8 string length in bytes will be <= Unicode string length * 4. @@ -246,27 +246,14 @@ Tcl_UniCharToUtfDString( p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { - if (!len && ((*w & 0xFC00) != 0xDC00)) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } - len = Tcl_UniCharToUtf(*w, p); - p += len; - if ((*w >= 0xD800) && (len < 3)) { - len = 0; /* Indication that high surrogate was found */ - } + p += Tcl_UniCharToUtf(*w, p); w++; } - if (!len) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; } -#if (TCL_UTF_MAX > 3) && (defined(__CYGWIN__) || defined(_WIN32)) char * Tcl_Utf16ToUtfDString( const unsigned short *uniStr, /* Utf-16 string to convert to UTF-8. */ @@ -279,11 +266,11 @@ Tcl_Utf16ToUtfDString( int oldLength, len = 1; /* - * UTF-8 string length in bytes will be <= Unicode string length * 4. + * UTF-8 string length in bytes will be <= Utf16 string length * 3. */ oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); + Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 3); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; @@ -308,7 +295,6 @@ Tcl_Utf16ToUtfDString( return string; } -#endif /* *--------------------------------------------------------------------------- * @@ -351,13 +337,14 @@ static const unsigned short cp1252[32] = { 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; +#undef Tcl_UtfToUniChar int Tcl_UtfToUniChar( - register const char *src, /* The UTF-8 string. */ - register Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by + const char *src, /* The UTF-8 string. */ + int *chPtr)/* Filled with the Unicode represented by * the UTF-8 string. */ { - Tcl_UniChar byte; + int byte; /* * Unroll 1 to 4 byte UTF-8 sequences. @@ -373,20 +360,6 @@ Tcl_UtfToUniChar( * characters representing themselves. */ -#if TCL_UTF_MAX == 3 - /* If *chPtr contains a high surrogate (produced by a previous - * Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation - * bytes, then we must produce a follow-up low surrogate. We only - * do that if the high surrogate matches the bits we encounter. - */ - if ((byte >= 0x80) - && (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC)) - && ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80)) - && ((src[2] & 0xC0) == 0x80)) { - *chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00; - return 3; - } -#endif if ((unsigned)(byte-0x80) < (unsigned)0x20) { *chPtr = cp1252[byte-0x80]; } else { @@ -432,23 +405,11 @@ Tcl_UtfToUniChar( /* * Four-byte-character lead byte followed by three trail bytes. */ -#if TCL_UTF_MAX == 3 - Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2) - | ((src[2] & 0x3F) >> 4)) - 0x40; - if (high >= 0x400) { - /* out of range, < 0x10000 or > 0x10ffff */ - } else { - /* produce high surrogate, advance source pointer */ - *chPtr = 0xD800 + high; - return 1; - } -#else *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)); if (((unsigned)(*chPtr) - 0x10000) <= 0xFFFFF) { return 4; } -#endif } /* @@ -461,9 +422,8 @@ Tcl_UtfToUniChar( return 1; } -#if (TCL_UTF_MAX > 3) && (defined(__CYGWIN__) || defined(_WIN32)) int -TclUtfToUtf16( +Tcl_UtfToUtf16( const char *src, /* The UTF-8 string. */ unsigned short *chPtr)/* Filled with the Utf-16 representation of * the UTF-8 string. */ @@ -561,7 +521,6 @@ TclUtfToUtf16( *chPtr = byte; return 1; } -#endif /* *--------------------------------------------------------------------------- @@ -581,7 +540,8 @@ TclUtfToUtf16( *--------------------------------------------------------------------------- */ -Tcl_UniChar * +#undef Tcl_UtfToUniCharDString +int * Tcl_UtfToUniCharDString( const char *src, /* UTF-8 string to convert to Unicode. */ int length, /* Length of UTF-8 string in bytes, or -1 for @@ -590,7 +550,7 @@ Tcl_UtfToUniCharDString( * appended to this previously initialized * DString. */ { - Tcl_UniChar ch = 0, *w, *wString; + int ch = 0, *w, *wString; const char *p, *end; int oldLength; @@ -606,8 +566,8 @@ Tcl_UtfToUniCharDString( oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, - oldLength + (int) ((length + 1) * sizeof(Tcl_UniChar))); - wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); + oldLength + (int) ((length + 1) * sizeof(int))); + wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; p = src; @@ -634,7 +594,6 @@ Tcl_UtfToUniCharDString( return wString; } -#if (TCL_UTF_MAX > 3) && (defined(__CYGWIN__) || defined(_WIN32)) unsigned short * Tcl_UtfToUtf16DString( const char *src, /* UTF-8 string to convert to Unicode. */ @@ -667,13 +626,13 @@ Tcl_UtfToUtf16DString( p = src; end = src + length - 4; while (p < end) { - p += TclUtfToUtf16(p, &ch); + p += Tcl_UtfToUtf16(p, &ch); *w++ = ch; } end += 4; while (p < end) { if (Tcl_UtfCharComplete(p, end-p)) { - p += TclUtfToUtf16(p, &ch); + p += Tcl_UtfToUtf16(p, &ch); } else if (((UCHAR(*p)-0x80)) < 0x20) { ch = cp1252[UCHAR(*p++)-0x80]; } else { @@ -687,7 +646,6 @@ Tcl_UtfToUtf16DString( return wString; } -#endif /* *--------------------------------------------------------------------------- * @@ -734,6 +692,13 @@ Tcl_UtfCharComplete( *--------------------------------------------------------------------------- */ +#if TCL_UTF_MAX == 3 +# undef Tcl_UtfToUniChar +# define Tcl_UtfToUniChar Tcl_UtfToUtf16 +# undef Tcl_UniCharLen +# define Tcl_UniCharLen Tcl_Utf16Len +#endif + int Tcl_NumUtfChars( register const char *src, /* The UTF-8 string to measure. */ @@ -1671,9 +1636,10 @@ Tcl_UniCharToTitle( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharLen int Tcl_UniCharLen( - const Tcl_UniChar *uniStr) /* Unicode string to find length of. */ + const int *uniStr) /* Unicode string to find length of. */ { int len = 0; @@ -1684,6 +1650,19 @@ Tcl_UniCharLen( return len; } +int +Tcl_Utf16Len( + const unsigned short *utf16Str) /* Unicode string to find length of. */ +{ + int len = 0; + + while (*utf16Str != '\0') { + len++; + utf16Str++; + } + return len; +} + /* *---------------------------------------------------------------------- * @@ -1701,10 +1680,11 @@ Tcl_UniCharLen( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharNcmp int Tcl_UniCharNcmp( - const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ - const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ + const int *ucs, /* Unicode string to compare to uct. */ + const int *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN @@ -1712,7 +1692,7 @@ Tcl_UniCharNcmp( * We are definitely on a big-endian machine; memcmp() is safe */ - return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); + return memcmp(ucs, uct, numChars*sizeof(int)); #else /* !WORDS_BIGENDIAN */ /* @@ -1727,7 +1707,34 @@ Tcl_UniCharNcmp( return 0; #endif /* WORDS_BIGENDIAN */ } - + +int +Tcl_Utf16Ncmp( + const unsigned short *ucs, /* Unicode string to compare to uct. */ + const unsigned short *uct, /* Unicode string ucs is compared to. */ + unsigned long numChars) /* Number of unichars to compare. */ +{ +#ifdef WORDS_BIGENDIAN + /* + * We are definitely on a big-endian machine; memcmp() is safe + */ + + return memcmp(ucs, uct, numChars*sizeof(unsigned short)); + +#else /* !WORDS_BIGENDIAN */ + /* + * We can't simply call memcmp() because that is not lexically correct. + */ + + for ( ; numChars != 0; ucs++, uct++, numChars--) { + if (*ucs != *uct) { + return (*ucs - *uct); + } + } + return 0; +#endif /* WORDS_BIGENDIAN */ +} + /* *---------------------------------------------------------------------- * @@ -1746,16 +1753,17 @@ Tcl_UniCharNcmp( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharNcasecmp int Tcl_UniCharNcasecmp( - const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ - const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ + const int *ucs, /* Unicode string to compare to uct. */ + const int *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { - Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); - Tcl_UniChar lct = Tcl_UniCharToLower(*uct); + int lcs = Tcl_UniCharToLower(*ucs); + int lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { return (lcs - lct); @@ -1764,7 +1772,25 @@ Tcl_UniCharNcasecmp( } return 0; } - +int +Tcl_Utf16Ncasecmp( + const unsigned short *ucs, /* Utf16 string to compare to uct. */ + const unsigned short *uct, /* Utf16 string ucs is compared to. */ + unsigned long numChars) /* Number of Utf16 characters to compare. */ +{ + for ( ; numChars != 0; numChars--, ucs++, uct++) { + if (*ucs != *uct) { + int lcs = Tcl_UniCharToLower(*ucs); + int lct = Tcl_UniCharToLower(*uct); + + if (lcs != lct) { + return (lcs - lct); + } + } + } + return 0; +} + /* *---------------------------------------------------------------------- * @@ -2097,15 +2123,16 @@ Tcl_UniCharIsWordChar( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharCaseMatch int Tcl_UniCharCaseMatch( - const Tcl_UniChar *uniStr, /* Unicode String. */ - const Tcl_UniChar *uniPattern, + const int *uniStr, /* Unicode String. */ + const int *uniPattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { - Tcl_UniChar ch1 = 0, p; + int ch1 = 0, p; while (1) { p = *uniPattern; @@ -2156,7 +2183,7 @@ Tcl_UniCharCaseMatch( if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*uniStr && (p != *uniStr) - && (p != (Tcl_UniChar)Tcl_UniCharToLower(*uniStr))) { + && (p != Tcl_UniCharToLower(*uniStr))) { uniStr++; } } else { @@ -2193,16 +2220,16 @@ Tcl_UniCharCaseMatch( */ if (p == '[') { - Tcl_UniChar startChar, endChar; + int startChar, endChar; uniPattern++; - ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniStr) : *uniStr); + ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); uniStr++; while (1) { if ((*uniPattern == ']') || (*uniPattern == 0)) { return 0; } - startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern) + startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (*uniPattern == '-') { @@ -2210,7 +2237,7 @@ Tcl_UniCharCaseMatch( if (*uniPattern == 0) { return 0; } - endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern) + endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (((startChar <= ch1) && (ch1 <= endChar)) @@ -2264,6 +2291,173 @@ Tcl_UniCharCaseMatch( } } +int +Tcl_Utf16CaseMatch( + const unsigned short *uniStr, /* Unicode String. */ + const unsigned short *uniPattern, + /* Pattern, which may contain special + * characters. */ + int nocase) /* 0 for case sensitive, 1 for insensitive */ +{ + unsigned short ch1 = 0, p; + + while (1) { + p = *uniPattern; + + /* + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. + */ + + if (p == 0) { + return (*uniStr == 0); + } + if ((*uniStr == 0) && (p != '*')) { + return 0; + } + + /* + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by skipping all the characters up to the + * next matching one in the pattern, and then calling ourselves + * recursively for each postfix of string, until either we match or we + * reach the end of the string. + */ + + if (p == '*') { + /* + * Skip all successive *'s in the pattern + */ + + while (*(++uniPattern) == '*') { + /* empty body */ + } + p = *uniPattern; + if (p == 0) { + return 1; + } + if (nocase) { + p = Tcl_UniCharToLower(p); + } + while (1) { + /* + * Optimization for matching - cruise through the string + * quickly if the next char in the pattern isn't a special + * character + */ + + if ((p != '[') && (p != '?') && (p != '\\')) { + if (nocase) { + while (*uniStr && (p != *uniStr) + && (p != Tcl_UniCharToLower(*uniStr))) { + uniStr++; + } + } else { + while (*uniStr && (p != *uniStr)) { + uniStr++; + } + } + } + if (Tcl_Utf16CaseMatch(uniStr, uniPattern, nocase)) { + return 1; + } + if (*uniStr == 0) { + return 0; + } + uniStr++; + } + } + + /* + * Check for a "?" as the next pattern character. It matches any + * single character. + */ + + if (p == '?') { + uniPattern++; + uniStr++; + continue; + } + + /* + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). + */ + + if (p == '[') { + unsigned short startChar, endChar; + + uniPattern++; + ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); + uniStr++; + while (1) { + if ((*uniPattern == ']') || (*uniPattern == 0)) { + return 0; + } + startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); + uniPattern++; + if (*uniPattern == '-') { + uniPattern++; + if (*uniPattern == 0) { + return 0; + } + endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); + uniPattern++; + if (((startChar <= ch1) && (ch1 <= endChar)) + || ((endChar <= ch1) && (ch1 <= startChar))) { + /* + * Matches ranges of form [a-z] or [z-a]. + */ + break; + } + } else if (startChar == ch1) { + break; + } + } + while (*uniPattern != ']') { + if (*uniPattern == 0) { + uniPattern--; + break; + } + uniPattern++; + } + uniPattern++; + continue; + } + + /* + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. + */ + + if (p == '\\') { + if (*(++uniPattern) == '\0') { + return 0; + } + } + + /* + * There's no special character. Just make sure that the next bytes of + * each string match. + */ + + if (nocase) { + if (Tcl_UniCharToLower(*uniStr) != + Tcl_UniCharToLower(*uniPattern)) { + return 0; + } + } else if (*uniStr != *uniPattern) { + return 0; + } + uniStr++; + uniPattern++; + } +} + /* *---------------------------------------------------------------------- * @@ -2348,7 +2542,7 @@ TclUniCharMatch( if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while ((string < stringEnd) && (p != *string) - && (p != (Tcl_UniChar)Tcl_UniCharToLower(*string))) { + && (p != Tcl_UniCharToLower(*string))) { string++; } } else { @@ -2389,20 +2583,20 @@ TclUniCharMatch( Tcl_UniChar ch1, startChar, endChar; pattern++; - ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*string) : *string); + ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string); string++; while (1) { if ((*pattern == ']') || (pattern == patternEnd)) { return 0; } - startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) : *pattern); + startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); pattern++; if (*pattern == '-') { pattern++; if (pattern == patternEnd) { return 0; } - endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) + endChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); pattern++; if (((startChar <= ch1) && (ch1 <= endChar)) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0788aed..e432560 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2302,7 +2302,7 @@ Tcl_StringCaseMatch( if (nocase) { while (*str) { charLen = TclUtfToUniChar(str, &ch1); - if (ch2==ch1 || ch2==(Tcl_UniChar)Tcl_UniCharToLower(ch1)) { + if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { break; } str += charLen; -- cgit v0.12 From 0c863ddec8f39d1afec9b67d4e899e4489d6f46e Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 10 May 2019 20:30:41 +0000 Subject: Start of TIP 543 implementation. --- doc/TraceVar.3 | 2 +- generic/tcl.h | 4 ++++ generic/tclTrace.c | 6 ++++-- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index 19cb467..e481985 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -95,7 +95,7 @@ Invoke \fIproc\fR whenever an attempt is made to modify the variable. Invoke \fIproc\fR whenever the variable is unset. A variable may be unset either explicitly by an \fBunset\fR command, or implicitly when a procedure returns (its local variables are -automatically unset) or when the interpreter is deleted (all +automatically unset) or when the interpreter or namespace is deleted (all variables are automatically unset). .TP \fBTCL_TRACE_ARRAY\fR diff --git a/generic/tcl.h b/generic/tcl.h index e34a609..d76b334 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1031,7 +1031,11 @@ typedef struct Tcl_DString { #define TCL_TRACE_WRITES 0x20 #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TCL_INTERP_DESTROYED 0x100 +#endif + #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 #ifndef TCL_REMOVE_OBSOLETE_TRACES diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 20fa7e7..8662d70 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -79,8 +79,7 @@ typedef struct { * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly * by the command being traced, not because of * an internal trace. - * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also be used - * in command execution traces. + * The flag 'TCL_TRACE_DESTROYED' may also be used in command execution traces. */ #define TCL_TRACE_ENTER_DURING_EXEC 4 @@ -2565,6 +2564,9 @@ TclObjCallVarTraces( leaveErrMsg); } +#undef TCL_INTERP_DESTROYED +#define TCL_INTERP_DESTROYED 0x100 + int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ -- cgit v0.12 From d063a23455c0d66176444ee46ce756685f57da85 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 May 2019 07:32:37 +0000 Subject: More WIP: eliminate all usage of (platform-specific) Tcl_WinTCharToUtf()/Tcl_WinUtfToTChar() to its proposed portable replacements: Tcl_Utf16ToUtfDString()/Tcl_UtfToUtf16DString() This allows for Tcl_WinTCharToUtf()/Tcl_WinUtfToTChar() to be declared deprecated. --- doc/Utf.3 | 22 +----- generic/tcl.decls | 51 ++++++------- generic/tcl.h | 2 +- generic/tclCmdMZ.c | 72 +++++++++--------- generic/tclDecls.h | 198 ++++++++++++++++++++++++------------------------- generic/tclExecute.c | 20 ++--- generic/tclIOSock.c | 3 +- generic/tclInt.h | 2 +- generic/tclMain.c | 5 +- generic/tclRegexp.c | 2 +- generic/tclStringObj.c | 54 +++++++------- generic/tclStubInit.c | 98 ++++++++++++------------ generic/tclTestObj.c | 34 +-------- generic/tclUtf.c | 56 +++++++------- generic/tclUtil.c | 4 +- generic/tclZipfs.c | 3 +- tests/stringObj.test | 16 ---- win/tclWin32Dll.c | 4 +- win/tclWinDde.c | 173 +++++++++++++++++++++++------------------- win/tclWinFCmd.c | 36 ++++++--- win/tclWinFile.c | 47 ++++++++---- win/tclWinInit.c | 4 +- win/tclWinLoad.c | 3 +- win/tclWinPipe.c | 21 ++++-- win/tclWinReg.c | 97 +++++++++++++----------- win/tclWinSerial.c | 3 +- win/tclWinSock.c | 4 +- 27 files changed, 519 insertions(+), 515 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index f082e22..235584a 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToUtf16, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Utf16ToUtfDString, Tcl_UtfToUtf16DString, Tcl_UniCharLen, Tcl_Utf16Len, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_Utf16Ncmp, Tcl_Utf16Ncasecmp, Tcl_UniCharCaseMatch, Tcl_Utf16CaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings +Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToUtf16, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Utf16ToUtfDString, Tcl_UtfToUtf16DString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings .SH SYNOPSIS .nf \fB#include \fR @@ -40,27 +40,15 @@ int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int -\fBTcl_Utf16Len\fR(\fIutf16Str\fR) -.sp -int \fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR) .sp int -\fBTcl_Utf16Ncmp\fR(\fIutf16s, tf16t, numChars\fR) -.sp -int -\fBTcl_Utf16Ncasecmp\fR(\fIutf16s, utf16t, numChars\fR) -.sp -int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) .sp int -\fBTcl_Utf16CaseMatch\fR(\fIutf16Str, utf16Pattern, nocase\fR) -.sp -int \fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR) .sp int @@ -129,8 +117,7 @@ A null-terminated utf-16 string. The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. .AP int uniLength in -The length of the Unicode string in characters. Must be greater than or -equal to 0. +The length of the Unicode string in characters. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "unsigned long" numChars in @@ -219,11 +206,6 @@ is the Unicode case insensitive version. a Unicode pattern, and a boolean value specifying whether the match should be case sensitive and returns whether the string matches the pattern. .PP -\fBTcl_Utf16CaseMatch\fR is the utf-16 equivalent to -\fBTcl_StringCaseMatch\fR. It accepts a null-terminated utf-16 string, -a utf-16 pattern, and a boolean value specifying whether the match should -be case sensitive and returns whether the string matches the pattern. -.PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters to compare. (Both strings are assumed to be at least \fInumChars\fR diff --git a/generic/tcl.decls b/generic/tcl.decls index 2c1e801..a93f957 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1245,11 +1245,11 @@ declare 350 { declare 351 { int Tcl_UniCharIsWordChar(int ch) } -declare 352 { - int Tcl_Utf16Len(const unsigned short *uniStr) +declare 352 {deprecated {Use Tcl_GetCharLength}} { + int Tcl_UniCharLen(const unsigned short *uniStr) } declare 353 { - int Tcl_Utf16Ncmp(const unsigned short *ucs, const unsigned short *uct, + int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars) } declare 354 { @@ -1339,10 +1339,10 @@ declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, int numChars) } declare 379 { - void Tcl_SetUtf16Obj(Tcl_Obj *objPtr, const unsigned short *unicode, + void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, int numChars) } declare 380 { @@ -1358,7 +1358,7 @@ declare 383 { Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 { - void Tcl_AppendUtf16ToObj(Tcl_Obj *objPtr, const unsigned short *unicode, + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length) } declare 385 { @@ -1484,11 +1484,11 @@ declare 418 { int Tcl_IsChannelExisting(const char *channelName) } declare 419 { - int Tcl_Utf16Ncasecmp(const unsigned short *ucs, const unsigned short *uct, + int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars) } declare 420 { - int Tcl_Utf16CaseMatch(const unsigned short *uniStr, + int Tcl_UniCharCaseMatch(const unsigned short *uniStr, const unsigned short *uniPattern, int nocase) } declare 421 { @@ -1542,7 +1542,7 @@ declare 433 { # introduced in 8.4a3 declare 434 { - unsigned short *Tcl_GetUtf16FromObj(Tcl_Obj *objPtr, int *lengthPtr) + unsigned short *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf @@ -2387,43 +2387,40 @@ declare 644 { # TIP #542 declare 646 { - void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const int *unicode, - int numChars) + int Tcl_UtfToUniChar(const char *src, int *chPtr) } declare 647 { - Tcl_Obj *Tcl_NewUnicodeObj(const int *unicode, int numChars) + char *Tcl_UniCharToUtfDString(const int *uniStr, + int uniLength, Tcl_DString *dsPtr) } declare 648 { - int *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) + int *Tcl_UtfToUniCharDString(const char *src, + int length, Tcl_DString *dsPtr) } declare 649 { - void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, - int length) + void TclSetUnicodeObj(Tcl_Obj *objPtr, const int *unicode, + int numChars) } declare 650 { - int Tcl_UtfToUniChar(const char *src, int *chPtr) + Tcl_Obj *TclNewUnicodeObj(const int *unicode, int numChars) } declare 651 { - char *Tcl_UniCharToUtfDString(const int *uniStr, - int uniLength, Tcl_DString *dsPtr) + int *TclGetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 652 { - int *Tcl_UtfToUniCharDString(const char *src, - int length, Tcl_DString *dsPtr) + void TclAppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, + int length) } declare 653 { - int Tcl_UniCharLen(const int *uniStr) + int Tcl_Utf32Ncmp(const int *ucs, const int *uct, + unsigned long numChars) } declare 654 { - int Tcl_UniCharNcmp(const int *ucs, const int *uct, + int Tcl_Utf32Ncasecmp(const int *ucs, const int *uct, unsigned long numChars) } declare 655 { - int Tcl_UniCharNcasecmp(const int *ucs, const int *uct, - unsigned long numChars) -} -declare 656 { - int Tcl_UniCharCaseMatch(const int *uniStr, + int Tcl_Utf32CaseMatch(const int *uniStr, const int *uniPattern, int nocase) } diff --git a/generic/tcl.h b/generic/tcl.h index d689011..e716aae 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2144,7 +2144,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 3 +#define TCL_UTF_MAX 4 #endif /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 15ea989..f6936e0 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -604,11 +604,11 @@ Tcl_RegsubObjCmd( numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); - strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; + strCmpFn = nocase ? Tcl_Utf32Ncasecmp : Tcl_Utf32Ncmp; - wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); - wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); - wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); + wsrc = TclGetUnicodeFromObj(objv[0], &slen); + wstring = TclGetUnicodeFromObj(objv[1], &wlen); + wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen); wend = wstring + wlen - (slen ? slen - 1 : 0); result = TCL_OK; @@ -619,11 +619,11 @@ Tcl_RegsubObjCmd( */ if (wstring < wend) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { - Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); - Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); + TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); + TclAppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; @@ -636,18 +636,18 @@ Tcl_RegsubObjCmd( (slen==1 || (strCmpFn(wstring, wsrc, (unsigned long) slen) == 0))) { if (numMatches == 0) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { - Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); + TclAppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; - Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } @@ -699,14 +699,14 @@ Tcl_RegsubObjCmd( } else { objPtr = objv[1]; } - wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + wstring = TclGetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } if (!command) { - wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen); } result = TCL_OK; @@ -742,7 +742,7 @@ Tcl_RegsubObjCmd( break; } if (numMatches == 0) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); if (offset > 0) { /* @@ -750,7 +750,7 @@ Tcl_RegsubObjCmd( * specified. */ - Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); + TclAppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; @@ -763,7 +763,7 @@ Tcl_RegsubObjCmd( Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); + TclAppendUnicodeToObj(resultPtr, wstring + offset, start); /* * In command-prefix mode, the substitutions are added as quoted @@ -785,7 +785,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { - args[idx + numParts] = Tcl_NewUnicodeObj( + args[idx + numParts] = TclNewUnicodeObj( wstring + offset + subStart, subEnd - subStart); } else { args[idx + numParts] = Tcl_NewObj(); @@ -826,7 +826,7 @@ Tcl_RegsubObjCmd( * the user code. */ - wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + wstring = TclGetUnicodeFromObj(objPtr, &wlen); offset += end; if (end == 0 || start == end) { @@ -838,7 +838,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -867,7 +867,7 @@ Tcl_RegsubObjCmd( idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; @@ -881,7 +881,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } @@ -889,7 +889,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { - Tcl_AppendUnicodeToObj(resultPtr, + TclAppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } @@ -901,7 +901,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { @@ -911,7 +911,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { @@ -923,7 +923,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -948,7 +948,7 @@ Tcl_RegsubObjCmd( resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); + TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, @@ -2080,7 +2080,7 @@ StringMapCmd( } else { sourceObj = objv[objc-1]; } - ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); + ustring1 = TclGetUnicodeFromObj(sourceObj, &length1); if (length1 == 0) { /* * Empty input string, just stop now. @@ -2090,13 +2090,13 @@ StringMapCmd( } end = ustring1 + length1; - strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + strCmpFn = (nocase ? Tcl_Utf32Ncasecmp : Tcl_Utf32Ncmp); /* * Force result to be Unicode */ - resultPtr = Tcl_NewUnicodeObj(ustring1, 0); + resultPtr = TclNewUnicodeObj(ustring1, 0); if (mapElemc == 2) { /* @@ -2109,7 +2109,7 @@ StringMapCmd( int mapLen, u2lc; Tcl_UniChar *mapString; - ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); + ustring2 = TclGetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; if ((length2 > length1) || (length2 == 0)) { /* @@ -2118,7 +2118,7 @@ StringMapCmd( ustring1 = end; } else { - mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); + mapString = TclGetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || @@ -2126,14 +2126,14 @@ StringMapCmd( (length2==1 || strCmpFn(ustring1, ustring2, (unsigned long) length2) == 0)) { if (p != ustring1) { - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + TclAppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); + TclAppendUnicodeToObj(resultPtr, mapString, mapLen); } } } @@ -2154,7 +2154,7 @@ StringMapCmd( u2lc = TclStackAlloc(interp, mapElemc * sizeof(int)); } for (index = 0; index < mapElemc; index++) { - mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], + mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index], mapLens+index); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); @@ -2178,7 +2178,7 @@ StringMapCmd( * Put the skipped chars onto the result first. */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + TclAppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; @@ -2194,7 +2194,7 @@ StringMapCmd( * Append the map value to the unicode string. */ - Tcl_AppendUnicodeToObj(resultPtr, + TclAppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } @@ -2211,7 +2211,7 @@ StringMapCmd( * Put the rest of the unmapped chars onto result. */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + TclAppendUnicodeToObj(resultPtr, p, ustring1 - p); } Tcl_SetObjResult(interp, resultPtr); done: diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 65b7b0a..16bf942 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1063,9 +1063,10 @@ EXTERN int Tcl_UniCharIsUpper(int ch); /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ -EXTERN int Tcl_Utf16Len(const unsigned short *uniStr); +TCL_DEPRECATED("Use Tcl_GetCharLength") +int Tcl_UniCharLen(const unsigned short *uniStr); /* 353 */ -EXTERN int Tcl_Utf16Ncmp(const unsigned short *ucs, +EXTERN int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 354 */ @@ -1141,10 +1142,10 @@ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ -EXTERN Tcl_Obj * Tcl_NewUtf16Obj(const unsigned short *unicode, +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const unsigned short *unicode, int numChars); /* 379 */ -EXTERN void Tcl_SetUtf16Obj(Tcl_Obj *objPtr, +EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); @@ -1156,7 +1157,7 @@ unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ -EXTERN void Tcl_AppendUtf16ToObj(Tcl_Obj *objPtr, +EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, @@ -1250,11 +1251,11 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ -EXTERN int Tcl_Utf16Ncasecmp(const unsigned short *ucs, +EXTERN int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 420 */ -EXTERN int Tcl_Utf16CaseMatch(const unsigned short *uniStr, +EXTERN int Tcl_UniCharCaseMatch(const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, @@ -1297,7 +1298,8 @@ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ -EXTERN unsigned short * Tcl_GetUtf16FromObj(Tcl_Obj *objPtr, int *lengthPtr); +EXTERN unsigned short * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, + int *lengthPtr); /* 435 */ TCL_DEPRECATED("") int Tcl_GetMathFuncInfo(Tcl_Interp *interp, @@ -1903,34 +1905,31 @@ EXTERN int Tcl_LinkArray(Tcl_Interp *interp, int size); /* Slot 645 is reserved */ /* 646 */ -EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const int *unicode, int numChars); +EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); /* 647 */ -EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const int *unicode, int numChars); +EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, + int uniLength, Tcl_DString *dsPtr); /* 648 */ -EXTERN int * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, - int *lengthPtr); +EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, + Tcl_DString *dsPtr); /* 649 */ -EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const int *unicode, int length); +EXTERN void TclSetUnicodeObj(Tcl_Obj *objPtr, const int *unicode, + int numChars); /* 650 */ -EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); +EXTERN Tcl_Obj * TclNewUnicodeObj(const int *unicode, int numChars); /* 651 */ -EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, - int uniLength, Tcl_DString *dsPtr); +EXTERN int * TclGetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 652 */ -EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, - Tcl_DString *dsPtr); +EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, + const int *unicode, int length); /* 653 */ -EXTERN int Tcl_UniCharLen(const int *uniStr); +EXTERN int Tcl_Utf32Ncmp(const int *ucs, const int *uct, + unsigned long numChars); /* 654 */ -EXTERN int Tcl_UniCharNcmp(const int *ucs, const int *uct, +EXTERN int Tcl_Utf32Ncasecmp(const int *ucs, const int *uct, unsigned long numChars); /* 655 */ -EXTERN int Tcl_UniCharNcasecmp(const int *ucs, const int *uct, - unsigned long numChars); -/* 656 */ -EXTERN int Tcl_UniCharCaseMatch(const int *uniStr, +EXTERN int Tcl_Utf32CaseMatch(const int *uniStr, const int *uniPattern, int nocase); typedef struct { @@ -2319,8 +2318,8 @@ typedef struct TclStubs { int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ - int (*tcl_Utf16Len) (const unsigned short *uniStr); /* 352 */ - int (*tcl_Utf16Ncmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ + TCL_DEPRECATED_API("Use Tcl_GetCharLength") int (*tcl_UniCharLen) (const unsigned short *uniStr); /* 352 */ + int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ char * (*tcl_Utf16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToUtf16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ @@ -2345,13 +2344,13 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUtf16Obj) (const unsigned short *unicode, int numChars); /* 378 */ - void (*tcl_SetUtf16Obj) (Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 379 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned short *unicode, int numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ - void (*tcl_AppendUtf16ToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 384 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ @@ -2386,8 +2385,8 @@ typedef struct TclStubs { void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - int (*tcl_Utf16Ncasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ - int (*tcl_Utf16CaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ + int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ + int (*tcl_UniCharCaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ @@ -2401,7 +2400,7 @@ typedef struct TclStubs { char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ - unsigned short * (*tcl_GetUtf16FromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ + unsigned short * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ @@ -2613,17 +2612,16 @@ typedef struct TclStubs { int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */ void (*reserved645)(void); - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const int *unicode, int numChars); /* 646 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const int *unicode, int numChars); /* 647 */ - int * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 648 */ - void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const int *unicode, int length); /* 649 */ - int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 650 */ - char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 651 */ - int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 652 */ - int (*tcl_UniCharLen) (const int *uniStr); /* 653 */ - int (*tcl_UniCharNcmp) (const int *ucs, const int *uct, unsigned long numChars); /* 654 */ - int (*tcl_UniCharNcasecmp) (const int *ucs, const int *uct, unsigned long numChars); /* 655 */ - int (*tcl_UniCharCaseMatch) (const int *uniStr, const int *uniPattern, int nocase); /* 656 */ + int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ + char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */ + int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */ + void (*tclSetUnicodeObj) (Tcl_Obj *objPtr, const int *unicode, int numChars); /* 649 */ + Tcl_Obj * (*tclNewUnicodeObj) (const int *unicode, int numChars); /* 650 */ + int * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 651 */ + void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const int *unicode, int length); /* 652 */ + int (*tcl_Utf32Ncmp) (const int *ucs, const int *uct, unsigned long numChars); /* 653 */ + int (*tcl_Utf32Ncasecmp) (const int *ucs, const int *uct, unsigned long numChars); /* 654 */ + int (*tcl_Utf32CaseMatch) (const int *uniStr, const int *uniPattern, int nocase); /* 655 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3358,10 +3356,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ -#define Tcl_Utf16Len \ - (tclStubsPtr->tcl_Utf16Len) /* 352 */ -#define Tcl_Utf16Ncmp \ - (tclStubsPtr->tcl_Utf16Ncmp) /* 353 */ +#define Tcl_UniCharLen \ + (tclStubsPtr->tcl_UniCharLen) /* 352 */ +#define Tcl_UniCharNcmp \ + (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ #define Tcl_Utf16ToUtfDString \ (tclStubsPtr->tcl_Utf16ToUtfDString) /* 354 */ #define Tcl_UtfToUtf16DString \ @@ -3410,10 +3408,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RegExpExecObj) /* 376 */ #define Tcl_RegExpGetInfo \ (tclStubsPtr->tcl_RegExpGetInfo) /* 377 */ -#define Tcl_NewUtf16Obj \ - (tclStubsPtr->tcl_NewUtf16Obj) /* 378 */ -#define Tcl_SetUtf16Obj \ - (tclStubsPtr->tcl_SetUtf16Obj) /* 379 */ +#define Tcl_NewUnicodeObj \ + (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ +#define Tcl_SetUnicodeObj \ + (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ @@ -3422,8 +3420,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetUnicode) /* 382 */ #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 383 */ -#define Tcl_AppendUtf16ToObj \ - (tclStubsPtr->tcl_AppendUtf16ToObj) /* 384 */ +#define Tcl_AppendUnicodeToObj \ + (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ #define Tcl_SetNotifier \ @@ -3492,10 +3490,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ -#define Tcl_Utf16Ncasecmp \ - (tclStubsPtr->tcl_Utf16Ncasecmp) /* 419 */ -#define Tcl_Utf16CaseMatch \ - (tclStubsPtr->tcl_Utf16CaseMatch) /* 420 */ +#define Tcl_UniCharNcasecmp \ + (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ +#define Tcl_UniCharCaseMatch \ + (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ #define Tcl_FindHashEntry \ (tclStubsPtr->tcl_FindHashEntry) /* 421 */ #define Tcl_CreateHashEntry \ @@ -3522,8 +3520,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ -#define Tcl_GetUtf16FromObj \ - (tclStubsPtr->tcl_GetUtf16FromObj) /* 434 */ +#define Tcl_GetUnicodeFromObj \ + (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ #define Tcl_GetMathFuncInfo \ (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ #define Tcl_ListMathFuncs \ @@ -3945,28 +3943,26 @@ extern const TclStubs *tclStubsPtr; #define Tcl_LinkArray \ (tclStubsPtr->tcl_LinkArray) /* 644 */ /* Slot 645 is reserved */ -#define Tcl_SetUnicodeObj \ - (tclStubsPtr->tcl_SetUnicodeObj) /* 646 */ -#define Tcl_NewUnicodeObj \ - (tclStubsPtr->tcl_NewUnicodeObj) /* 647 */ -#define Tcl_GetUnicodeFromObj \ - (tclStubsPtr->tcl_GetUnicodeFromObj) /* 648 */ -#define Tcl_AppendUnicodeToObj \ - (tclStubsPtr->tcl_AppendUnicodeToObj) /* 649 */ #define Tcl_UtfToUniChar \ - (tclStubsPtr->tcl_UtfToUniChar) /* 650 */ + (tclStubsPtr->tcl_UtfToUniChar) /* 646 */ #define Tcl_UniCharToUtfDString \ - (tclStubsPtr->tcl_UniCharToUtfDString) /* 651 */ + (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ - (tclStubsPtr->tcl_UtfToUniCharDString) /* 652 */ -#define Tcl_UniCharLen \ - (tclStubsPtr->tcl_UniCharLen) /* 653 */ -#define Tcl_UniCharNcmp \ - (tclStubsPtr->tcl_UniCharNcmp) /* 654 */ -#define Tcl_UniCharNcasecmp \ - (tclStubsPtr->tcl_UniCharNcasecmp) /* 655 */ -#define Tcl_UniCharCaseMatch \ - (tclStubsPtr->tcl_UniCharCaseMatch) /* 656 */ + (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ +#define TclSetUnicodeObj \ + (tclStubsPtr->tclSetUnicodeObj) /* 649 */ +#define TclNewUnicodeObj \ + (tclStubsPtr->tclNewUnicodeObj) /* 650 */ +#define TclGetUnicodeFromObj \ + (tclStubsPtr->tclGetUnicodeFromObj) /* 651 */ +#define TclAppendUnicodeToObj \ + (tclStubsPtr->tclAppendUnicodeToObj) /* 652 */ +#define Tcl_Utf32Ncmp \ + (tclStubsPtr->tcl_Utf32Ncmp) /* 653 */ +#define Tcl_Utf32Ncasecmp \ + (tclStubsPtr->tcl_Utf32Ncasecmp) /* 654 */ +#define Tcl_Utf32CaseMatch \ + (tclStubsPtr->tcl_Utf32CaseMatch) /* 655 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4105,10 +4101,10 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetLongFromObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj -# undef Tcl_UniCharNcmp +# undef Tcl_Utf32Ncmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp -# undef Tcl_UniCharNcasecmp +# undef Tcl_Utf32Ncasecmp # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ @@ -4124,13 +4120,13 @@ extern const TclStubs *tclStubsPtr; if (result == TCL_OK) *ptr = (long)intValue; return result; } -# define Tcl_UniCharNcmp(ucs,uct,n) \ +# define Tcl_Utf32Ncmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n)) # define Tcl_UtfNcmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n)) # define Tcl_UtfNcasecmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) -# define Tcl_UniCharNcasecmp(ucs,uct,n) \ +# define Tcl_Utf32Ncasecmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) # endif #endif @@ -4146,33 +4142,37 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_SetLongObj #define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) #undef Tcl_GetUnicode -#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) +#define Tcl_GetUnicode(objPtr) TclGetUnicodeFromObj((objPtr), NULL) #undef Tcl_BackgroundError #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) #undef Tcl_StringMatch #define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) #if TCL_UTF_MAX == 3 -# undef Tcl_GetUnicodeFromObj -# define Tcl_GetUnicodeFromObj Tcl_GetUtf16FromObj -# undef Tcl_NewUnicodeObj -# define Tcl_NewUnicodeObj Tcl_NewUtf16Obj -# undef Tcl_SetUnicodeObj -# define Tcl_SetUnicodeObj Tcl_SetUtf16Obj -# undef Tcl_AppendUnicodeToObj -# define Tcl_AppendUnicodeToObj Tcl_AppendUtf16ToObj +# undef TclGetUnicodeFromObj +# define TclGetUnicodeFromObj Tcl_GetUnicodeFromObj +# undef TclNewUnicodeObj +# define TclNewUnicodeObj Tcl_NewUnicodeObj +# undef TclSetUnicodeObj +# define TclSetUnicodeObj Tcl_SetUnicodeObj +# undef TclAppendUnicodeToObj +# define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj # undef Tcl_UniCharToUtfDString # define Tcl_UniCharToUtfDString Tcl_Utf16ToUtfDString # undef Tcl_UtfToUniCharDString # define Tcl_UtfToUniCharDString Tcl_UtfToUtf16DString # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToUtf16 -# undef Tcl_UniCharNcmp -# define Tcl_UniCharNcmp Tcl_Utf16Ncmp -# undef Tcl_UniCharNcasecmp -# define Tcl_UniCharNcasecmp Tcl_Utf16Ncasecmp -# undef Tcl_UniCharCaseMatch -# define Tcl_UniCharCaseMatch Tcl_Utf16CaseMatch +# undef Tcl_Utf32Ncmp +# define Tcl_Utf32Ncmp Tcl_UniCharNcmp +# undef Tcl_Utf32Ncasecmp +# define Tcl_Utf32Ncasecmp Tcl_UniCharNcasecmp +# undef Tcl_Utf32CaseMatch +# define Tcl_Utf32CaseMatch Tcl_UniCharCaseMatch +#endif + +#if TCL_UTF_MAX > 3 || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# undef Tcl_UniCharLen #endif /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ed4fdd7..c31ab79 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5391,12 +5391,12 @@ TEBCresume( objResultPtr = value3Ptr; goto doneStringMap; } - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); if (length == 0) { objResultPtr = valuePtr; goto doneStringMap; } - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); if (length2 > length || length2 == 0) { objResultPtr = valuePtr; goto doneStringMap; @@ -5408,9 +5408,9 @@ TEBCresume( } goto doneStringMap; } - ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); + ustring3 = TclGetUnicodeFromObj(value3Ptr, &length3); - objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); + objResultPtr = TclNewUnicodeObj(ustring1, 0); p = ustring1; end = ustring1 + length; for (; ustring1 < end; ustring1++) { @@ -5418,14 +5418,14 @@ TEBCresume( memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) == 0)) { if (p != ustring1) { - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); + TclAppendUnicodeToObj(objResultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); + TclAppendUnicodeToObj(objResultPtr, ustring3, length3); } } if (p != ustring1) { @@ -5433,7 +5433,7 @@ TEBCresume( * Put the rest of the unmapped chars onto result. */ - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); + TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p); } doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", @@ -5461,7 +5461,7 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, O2S(valuePtr))); - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); match = 1; if (length > 0) { end = ustring1 + length; @@ -5490,8 +5490,8 @@ TEBCresume( || TclHasIntRep(value2Ptr, &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); + ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); match = TclUniCharMatch(ustring1, length, ustring2, length2, nocase); } else if (TclIsPureByteArray(valuePtr) && !nocase) { diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 12e2900..32ed015 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -34,7 +34,8 @@ gai_strerror( } else { tsdPtr->initialized = 1; } - Tcl_WinTCharToUtf(gai_strerrorW(code), -1, &tsdPtr->errorMsg); + Tcl_DStringInit(&tsdPtr->errorMsg); + Tcl_Utf16ToUtfDString(gai_strerrorW(code), -1, &tsdPtr->errorMsg); return Tcl_DStringValue(&tsdPtr->errorMsg); } #endif diff --git a/generic/tclInt.h b/generic/tclInt.h index b6db913..fb35fc1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4687,7 +4687,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #ifdef WORDS_BIGENDIAN # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ -# define TclUniCharNcmp Tcl_UniCharNcmp +# define TclUniCharNcmp Tcl_Utf32Ncmp #endif /* WORDS_BIGENDIAN */ /* diff --git a/generic/tclMain.c b/generic/tclMain.c index f7a4cf8..ad039b6 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -60,7 +60,7 @@ */ #if defined(UNICODE) && (TCL_UTF_MAX == 3) -# define NewNativeObj Tcl_NewUnicodeObj +# define NewNativeObj TclNewUnicodeObj #else /* !UNICODE || (TCL_UTF_MAX > 3) */ static inline Tcl_Obj * NewNativeObj( @@ -73,7 +73,8 @@ NewNativeObj( if (length > 0) { length *= sizeof(WCHAR); } - Tcl_WinTCharToUtf(string, length, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(string, length, &ds); #else Tcl_ExternalToUtfDString(NULL, (char *) string, length, &ds); #endif diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 804b117..5a8c558 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -482,7 +482,7 @@ Tcl_RegExpExecObj( regexpPtr->string = NULL; regexpPtr->objPtr = textObj; - udata = Tcl_GetUnicodeFromObj(textObj, &length); + udata = TclGetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d5edaf3..76d875c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -354,7 +354,7 @@ Tcl_DbNewStringObj( /* *--------------------------------------------------------------------------- * - * Tcl_NewUnicodeObj -- + * TclNewUnicodeObj -- * * This function is creates a new String object and initializes it from * the given Unicode String. If the Utf String is the same size as the @@ -371,7 +371,7 @@ Tcl_DbNewStringObj( */ Tcl_Obj * -Tcl_NewUnicodeObj( +TclNewUnicodeObj( const Tcl_UniChar *unicode, /* The unicode string used to initialize the * new object. */ int numChars) /* Number of characters in the unicode @@ -613,7 +613,7 @@ Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string * for. */ { - return Tcl_GetUnicodeFromObj(objPtr, NULL); + return TclGetUnicodeFromObj(objPtr, NULL); } #endif /* TCL_NO_DEPRECATED */ @@ -637,7 +637,7 @@ Tcl_GetUnicode( */ Tcl_UniChar * -Tcl_GetUnicodeFromObj( +TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ int *lengthPtr) /* If non-NULL, the location where the string @@ -764,7 +764,7 @@ Tcl_GetRange( ++last; } #endif - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); + return TclNewUnicodeObj(stringPtr->unicode + first, last - first + 1); } /* @@ -1057,7 +1057,7 @@ Tcl_AttemptSetObjLength( */ void -Tcl_SetUnicodeObj( +TclSetUnicodeObj( Tcl_Obj *objPtr, /* The object to set the string of. */ const Tcl_UniChar *unicode, /* The unicode string used to initialize the * object. */ @@ -1249,7 +1249,7 @@ Tcl_AppendToObj( */ void -Tcl_AppendUnicodeToObj( +TclAppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The unicode string to append to the * object. */ @@ -1393,7 +1393,7 @@ Tcl_AppendObjToObj( if (TclHasIntRep(appendObjPtr, &tclStringType)) { Tcl_UniChar *unicode = - Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); + TclGetUnicodeFromObj(appendObjPtr, &numChars); AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); } else { @@ -2873,7 +2873,7 @@ TclStringRepeat( Tcl_GetByteArrayFromObj(objPtr, &length); } else if (unichar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ - Tcl_GetUnicodeFromObj(objPtr, &length); + TclGetUnicodeFromObj(objPtr, &length); } else { /* Result will be concat of string reps. Pre-size it. */ Tcl_GetStringFromObj(objPtr, &length); @@ -2913,7 +2913,7 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); + objResultPtr = TclNewUnicodeObj(Tcl_GetUnicode(objPtr), length); } else { TclInvalidateStringRep(objPtr); objResultPtr = objPtr; @@ -2934,7 +2934,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + TclAppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), (count - done) * length); } else { /* @@ -3091,7 +3091,7 @@ TclStringCat( if ((objPtr->bytes == NULL) || (objPtr->length)) { int numChars; - Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ + TclGetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ if (numChars) { last = objc - oc; if (length == 0) { @@ -3241,7 +3241,7 @@ TclStringCat( objResultPtr = *objv++; objc--; /* Ugly interface! Force resize of the unicode array. */ - Tcl_GetUnicodeFromObj(objResultPtr, &start); + TclGetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { @@ -3258,7 +3258,7 @@ TclStringCat( Tcl_UniChar ch = 0; /* Ugly interface! No scheme to init array size. */ - objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ + objResultPtr = TclNewUnicodeObj(&ch, 0); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { Tcl_DecrRefCount(objResultPtr); if (interp) { @@ -3277,7 +3277,7 @@ TclStringCat( if ((objPtr->bytes == NULL) || (objPtr->length)) { int more; - Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more); + Tcl_UniChar *src = TclGetUnicodeFromObj(objPtr, &more); memcpy(dst, src, more * sizeof(Tcl_UniChar)); dst += more; } @@ -3400,9 +3400,9 @@ TclStringCmp( */ if (nocase) { - s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); - s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; + s1 = (char *) TclGetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = (memCmpFn_t)Tcl_Utf32Ncasecmp; } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); @@ -3427,7 +3427,7 @@ TclStringCmp( s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); } else { - memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + memCmpFn = (memCmpFn_t) Tcl_Utf32Ncmp; } } } @@ -3611,9 +3611,9 @@ TclStringFirst( { Tcl_UniChar *try, *end, *uh; - Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + Tcl_UniChar *un = TclGetUnicodeFromObj(needle, &ln); - uh = Tcl_GetUnicodeFromObj(haystack, &lh); + uh = TclGetUnicodeFromObj(haystack, &lh); if ((lh < ln) || (start > lh - ln)) { /* Don't start the loop if there cannot be a valid answer */ return -1; @@ -3690,8 +3690,8 @@ TclStringLast( } { - Tcl_UniChar *try, *uh = Tcl_GetUnicodeFromObj(haystack, &lh); - Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + Tcl_UniChar *try, *uh = TclGetUnicodeFromObj(haystack, &lh); + Tcl_UniChar *un = TclGetUnicodeFromObj(needle, &ln); if (last >= lh) { last = lh - 1; @@ -3789,7 +3789,7 @@ TclStringReverse( * Tcl_SetObjLength into growing the unicode rep buffer. */ - objPtr = Tcl_NewUnicodeObj(&ch, 1); + objPtr = TclNewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); while (--src >= from) { @@ -3987,16 +3987,16 @@ TclStringReplace( /* The traditional implementation... */ { int numChars; - Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); + Tcl_UniChar *ustring = TclGetUnicodeFromObj(objPtr, &numChars); /* TODO: Is there an in-place option worth pursuing here? */ - result = Tcl_NewUnicodeObj(ustring, first); + result = TclNewUnicodeObj(ustring, first); if (insertPtr) { Tcl_AppendObjToObj(result, insertPtr); } if (first + count < numChars) { - Tcl_AppendUnicodeToObj(result, ustring + first + count, + TclAppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e11c641..5900257 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -60,16 +60,16 @@ #undef TclBNInitBignumFromLong #undef Tcl_BackgroundError #define TclStaticPackage Tcl_StaticPackage -#undef Tcl_GetUnicodeFromObj -#undef Tcl_NewUnicodeObj -#undef Tcl_SetUnicodeObj +#undef TclGetUnicodeFromObj +#undef TclNewUnicodeObj +#undef TclSetUnicodeObj #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar -#undef Tcl_UniCharNcmp -#undef Tcl_UniCharNcasecmp -#undef Tcl_UniCharCaseMatch -#undef Tcl_AppendUnicodeToObj +#undef Tcl_Utf32Ncmp +#undef Tcl_Utf32Ncasecmp +#undef Tcl_Utf32CaseMatch +#undef TclAppendUnicodeToObj static void uniCodePanic() { #if TCL_UTF_MAX == 3 @@ -80,25 +80,24 @@ static void uniCodePanic() { } #if TCL_UTF_MAX == 3 -# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, int *)) uniCodePanic -# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, int)) uniCodePanic -# define Tcl_SetUnicodeObj (void (*)(Tcl_Obj *,const int *, int)) uniCodePanic -# define Tcl_AppendUnicodeToObj (void (*)(Tcl_Obj *, const int *, int)) uniCodePanic +# define TclGetUnicodeFromObj (int *(*)(Tcl_Obj *, int *)) uniCodePanic +# define TclNewUnicodeObj (Tcl_Obj *(*)(const int *, int)) uniCodePanic +# define TclSetUnicodeObj (void (*)(Tcl_Obj *,const int *, int)) uniCodePanic +# define TclAppendUnicodeToObj (void (*)(Tcl_Obj *, const int *, int)) uniCodePanic # define Tcl_UtfToUniChar (int (*)(const char *, int *)) uniCodePanic # define Tcl_UniCharToUtfDString (char *(*)(const int *, int, Tcl_DString *)) uniCodePanic # define Tcl_UtfToUniCharDString (int *(*)(const char *, int, Tcl_DString *)) uniCodePanic -# define Tcl_UniCharCaseMatch (int (*)(const int *, const int *, int)) uniCodePanic -# define Tcl_UniCharLen (int (*)(const int *)) uniCodePanic -# define Tcl_UniCharNcmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic -# define Tcl_UniCharNcasecmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic +# define Tcl_Utf32CaseMatch (int (*)(const int *, const int *, int)) uniCodePanic +# define Tcl_Utf32Ncmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic +# define Tcl_Utf32Ncasecmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic #else #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *)) uniCodePanic # endif -# define Tcl_GetUtf16FromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic -# define Tcl_NewUtf16Obj (Tcl_Obj *(*)(const unsigned short *, int)) uniCodePanic -# define Tcl_SetUtf16Obj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic -# define Tcl_AppendUtf16ToObj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic +# define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int)) uniCodePanic +# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic #endif /* See bug 510001: TclSockMinimumBuffers needs plat imp */ @@ -303,9 +302,7 @@ Tcl_WinTCharToUtf( if (!string) { return NULL; } - if (len < 0) { - len = wcslen((wchar_t *)string); - } else { + if (len > 0) { len /= 2; } return Tcl_Utf16ToUtfDString((const unsigned short *)string, len, dsPtr); @@ -359,22 +356,22 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp #if TCL_UTF_MAX > 3 static int uniCharNcmp(const int *ucs, const int *uct, unsigned int n){ - return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); + return Tcl_Utf32Ncmp(ucs, uct, (unsigned long)n); } -#define Tcl_UniCharNcmp (int(*)(const int*,const int*,unsigned long))uniCharNcmp +#define Tcl_Utf32Ncmp (int(*)(const int*,const int*,unsigned long))uniCharNcmp static int uniCharNcasecmp(const int *ucs, const int *uct, unsigned int n){ - return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); + return Tcl_Utf32Ncasecmp(ucs, uct, (unsigned long)n); } -#define Tcl_UniCharNcasecmp (int(*)(const int*,const int*,unsigned long))uniCharNcasecmp +#define Tcl_Utf32Ncasecmp (int(*)(const int*,const int*,unsigned long))uniCharNcasecmp #else static int utf16Ncmp(const unsigned short *ucs, const unsigned short *uct, unsigned int n){ - return Tcl_Utf16Ncmp(ucs, uct, (unsigned long)n); + return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } -#define Tcl_Utf16Ncmp (int(*)(const unsigned short*,const unsigned short*,unsigned long))utf16Ncmp +#define Tcl_UniCharNcmp (int(*)(const unsigned short*,const unsigned short*,unsigned long))utf16Ncmp static int utf16Ncasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned int n){ - return Tcl_Utf16Ncasecmp(ucs, uct, (unsigned long)n); + return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); } -#define Tcl_Utf16Ncasecmp (int(*)(const unsigned short*,const unsigned short*,unsigned long))utf16Ncasecmp +#define Tcl_UniCharNcasecmp (int(*)(const unsigned short*,const unsigned short*,unsigned long))utf16Ncasecmp #endif #endif /* TCL_WIDE_INT_IS_LONG */ @@ -522,6 +519,10 @@ tellOld( } #endif /* !TCL_NO_DEPRECATED */ +#if TCL_UTF_MAX > 3 || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define Tcl_UniCharLen 0 +#endif + /* * WARNING: The contents of this file is automatically generated by the * tools/genStubs.tcl script. Any modifications to the function declarations @@ -1390,8 +1391,8 @@ const TclStubs tclStubs = { Tcl_UniCharIsSpace, /* 349 */ Tcl_UniCharIsUpper, /* 350 */ Tcl_UniCharIsWordChar, /* 351 */ - Tcl_Utf16Len, /* 352 */ - Tcl_Utf16Ncmp, /* 353 */ + Tcl_UniCharLen, /* 352 */ + Tcl_UniCharNcmp, /* 353 */ Tcl_Utf16ToUtfDString, /* 354 */ Tcl_UtfToUtf16DString, /* 355 */ Tcl_GetRegExpFromObj, /* 356 */ @@ -1416,13 +1417,13 @@ const TclStubs tclStubs = { Tcl_UniCharIsPunct, /* 375 */ Tcl_RegExpExecObj, /* 376 */ Tcl_RegExpGetInfo, /* 377 */ - Tcl_NewUtf16Obj, /* 378 */ - Tcl_SetUtf16Obj, /* 379 */ + Tcl_NewUnicodeObj, /* 378 */ + Tcl_SetUnicodeObj, /* 379 */ Tcl_GetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ Tcl_GetUnicode, /* 382 */ Tcl_GetRange, /* 383 */ - Tcl_AppendUtf16ToObj, /* 384 */ + Tcl_AppendUnicodeToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ @@ -1457,8 +1458,8 @@ const TclStubs tclStubs = { Tcl_SpliceChannel, /* 416 */ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ - Tcl_Utf16Ncasecmp, /* 419 */ - Tcl_Utf16CaseMatch, /* 420 */ + Tcl_UniCharNcasecmp, /* 419 */ + Tcl_UniCharCaseMatch, /* 420 */ Tcl_FindHashEntry, /* 421 */ Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ @@ -1472,7 +1473,7 @@ const TclStubs tclStubs = { Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ - Tcl_GetUtf16FromObj, /* 434 */ + Tcl_GetUnicodeFromObj, /* 434 */ Tcl_GetMathFuncInfo, /* 435 */ Tcl_ListMathFuncs, /* 436 */ Tcl_SubstObj, /* 437 */ @@ -1684,17 +1685,16 @@ const TclStubs tclStubs = { Tcl_IsShared, /* 643 */ Tcl_LinkArray, /* 644 */ 0, /* 645 */ - Tcl_SetUnicodeObj, /* 646 */ - Tcl_NewUnicodeObj, /* 647 */ - Tcl_GetUnicodeFromObj, /* 648 */ - Tcl_AppendUnicodeToObj, /* 649 */ - Tcl_UtfToUniChar, /* 650 */ - Tcl_UniCharToUtfDString, /* 651 */ - Tcl_UtfToUniCharDString, /* 652 */ - Tcl_UniCharLen, /* 653 */ - Tcl_UniCharNcmp, /* 654 */ - Tcl_UniCharNcasecmp, /* 655 */ - Tcl_UniCharCaseMatch, /* 656 */ + Tcl_UtfToUniChar, /* 646 */ + Tcl_UniCharToUtfDString, /* 647 */ + Tcl_UtfToUniCharDString, /* 648 */ + TclSetUnicodeObj, /* 649 */ + TclNewUnicodeObj, /* 650 */ + TclGetUnicodeFromObj, /* 651 */ + TclAppendUnicodeToObj, /* 652 */ + Tcl_Utf32Ncmp, /* 653 */ + Tcl_Utf32Ncasecmp, /* 654 */ + Tcl_Utf32CaseMatch, /* 655 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a289e32..9bab1e9 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1170,7 +1170,6 @@ TeststringobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *unicode; int varIndex, option, i, length; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; @@ -1179,7 +1178,7 @@ TeststringobjCmd( static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", "set", "set2", "setlength", "maxchars", "getunicode", - "appendself", "appendself2", NULL + "appendself", NULL }; if (objc < 3) { @@ -1381,37 +1380,6 @@ TeststringobjCmd( Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; - case 12: /* appendself2 */ - if (objc != 4) { - goto wrongNumArgs; - } - if (varPtr[varIndex] == NULL) { - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); - } - - /* - * If the object bound to variable "varIndex" is shared, we must - * "copy on write" and append to a copy of the object. - */ - - if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); - } - - unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); - - if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { - return TCL_ERROR; - } - if ((i < 0) || (i > length)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "index value out of range", -1)); - return TCL_ERROR; - } - - Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); - Tcl_SetObjResult(interp, varPtr[varIndex]); - break; } return TCL_OK; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 380db95..1beadec 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -225,7 +225,7 @@ three: char * Tcl_UniCharToUtfDString( const int *uniStr, /* Unicode string to convert to UTF-8. */ - int uniLength, /* Length of Unicode string (must be >= 0). */ + int uniLength, /* Length of Unicode string. */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { @@ -237,6 +237,14 @@ Tcl_UniCharToUtfDString( * UTF-8 string length in bytes will be <= Unicode string length * 4. */ + if (uniLength < 0) { + uniLength = 0; + w = uniStr; + while (*w != '\0') { + uniLength++; + w++; + } + } oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); string = Tcl_DStringValue(dsPtr) + oldLength; @@ -256,7 +264,7 @@ Tcl_UniCharToUtfDString( char * Tcl_Utf16ToUtfDString( const unsigned short *uniStr, /* Utf-16 string to convert to UTF-8. */ - int uniLength, /* Length of Utf-16 string (must be >= 0). */ + int uniLength, /* Length of Utf-16 string. */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { @@ -268,6 +276,15 @@ Tcl_Utf16ToUtfDString( * UTF-8 string length in bytes will be <= Utf16 string length * 3. */ + if (uniLength < 0) { + + uniLength = 0; + w = uniStr; + while (*w != '\0') { + uniLength++; + w++; + } + } oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 3); string = Tcl_DStringValue(dsPtr) + oldLength; @@ -692,8 +709,6 @@ Tcl_UtfCharComplete( #if TCL_UTF_MAX == 3 # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToUtf16 -# undef Tcl_UniCharLen -# define Tcl_UniCharLen Tcl_Utf16Len #endif int @@ -1633,23 +1648,9 @@ Tcl_UniCharToTitle( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX == 3 && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 int Tcl_UniCharLen( - const int *uniStr) /* Unicode string to find length of. */ -{ - int len = 0; - - while (*uniStr != '\0') { - len++; - uniStr++; - } - return len; -} -#endif /* TCL_UTF_MAX > 3 */ - -int -Tcl_Utf16Len( const unsigned short *utf16Str) /* Unicode string to find length of. */ { int len = 0; @@ -1660,6 +1661,7 @@ Tcl_Utf16Len( } return len; } +#endif /* TCL_UTF_MAX == 3 && !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- @@ -1680,7 +1682,7 @@ Tcl_Utf16Len( #if TCL_UTF_MAX > 3 int -Tcl_UniCharNcmp( +Tcl_Utf32Ncmp( const int *ucs, /* Unicode string to compare to uct. */ const int *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ @@ -1708,7 +1710,7 @@ Tcl_UniCharNcmp( #endif /* TCL_UTF_MAX > 3 */ int -Tcl_Utf16Ncmp( +Tcl_UniCharNcmp( const unsigned short *ucs, /* Unicode string to compare to uct. */ const unsigned short *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ @@ -1754,7 +1756,7 @@ Tcl_Utf16Ncmp( #if TCL_UTF_MAX > 3 int -Tcl_UniCharNcasecmp( +Tcl_Utf32Ncasecmp( const int *ucs, /* Unicode string to compare to uct. */ const int *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ @@ -1774,7 +1776,7 @@ Tcl_UniCharNcasecmp( #endif /* TCL_UTF_MAX > 3 */ int -Tcl_Utf16Ncasecmp( +Tcl_UniCharNcasecmp( const unsigned short *ucs, /* Utf16 string to compare to uct. */ const unsigned short *uct, /* Utf16 string ucs is compared to. */ unsigned long numChars) /* Number of Utf16 characters to compare. */ @@ -2126,7 +2128,7 @@ Tcl_UniCharIsWordChar( #if TCL_UTF_MAX > 3 int -Tcl_UniCharCaseMatch( +Tcl_Utf32CaseMatch( const int *uniStr, /* Unicode String. */ const int *uniPattern, /* Pattern, which may contain special @@ -2193,7 +2195,7 @@ Tcl_UniCharCaseMatch( } } } - if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { + if (Tcl_Utf32CaseMatch(uniStr, uniPattern, nocase)) { return 1; } if (*uniStr == 0) { @@ -2294,7 +2296,7 @@ Tcl_UniCharCaseMatch( #endif /* TCL_UTF_MAX > 3 */ int -Tcl_Utf16CaseMatch( +Tcl_UniCharCaseMatch( const unsigned short *uniStr, /* Unicode String. */ const unsigned short *uniPattern, /* Pattern, which may contain special @@ -2361,7 +2363,7 @@ Tcl_Utf16CaseMatch( } } } - if (Tcl_Utf16CaseMatch(uniStr, uniPattern, nocase)) { + if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { return 1; } if (*uniStr == 0) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index c333e63..218df5d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2663,8 +2663,8 @@ TclStringMatchObj( if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; - udata = Tcl_GetUnicodeFromObj(strObj, &length); - uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); + udata = TclGetUnicodeFromObj(strObj, &length); + uptn = TclGetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) && !flags) { diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 3d1941c..776f795 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4930,7 +4930,8 @@ TclZipfs_AppHook( #ifdef _WIN32 Tcl_DString ds; - archive = Tcl_WinTCharToUtf((*argvPtr)[1], -1, &ds); + Tcl_DStringInit(&ds); + archive = Tcl_Utf16ToUtfDString((*argvPtr)[1], -1, &ds); #else /* !_WIN32 */ archive = (*argvPtr)[1]; #endif /* _WIN32 */ diff --git a/tests/stringObj.test b/tests/stringObj.test index a78b5f8..769486a 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -464,22 +464,6 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo -test stringObj-15.5 {Tcl_Append*ToObj: self appends} testobj { - teststringobj set 1 foo - teststringobj appendself2 1 0 -} foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} testobj { - teststringobj set 1 foo - teststringobj appendself2 1 1 -} foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} testobj { - teststringobj set 1 foo - teststringobj appendself2 1 2 -} 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 diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index f5809e8..ac2e02b 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -490,9 +490,7 @@ Tcl_WinTCharToUtf( if (!string) { return NULL; } - if (len < 0) { - len = wcslen((WCHAR *)string); - } else { + if (len > 0) { len /= 2; } return Tcl_Utf16ToUtfDString(string, len, dsPtr); diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 27ddfc8..efa94b2 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -34,7 +34,7 @@ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ - TCHAR *name; /* Interpreter's name (malloc-ed). */ + WCHAR *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; @@ -101,7 +101,7 @@ static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); static int DdeGetServicesList(Tcl_Interp *interp, - const TCHAR *serviceName, const TCHAR *topicName); + const WCHAR *serviceName, const WCHAR *topicName); static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2); @@ -111,7 +111,7 @@ static void DeleteProc(ClientData clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, - const TCHAR *name, HCONV *ddeConvPtr); + const WCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -159,7 +159,7 @@ int Dde_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, "8.1", 0)) { + if (!Tcl_InitStubs(interp, "8.7-", 0)) { return TCL_ERROR; } @@ -283,10 +283,10 @@ Initialize(void) *---------------------------------------------------------------------- */ -static const TCHAR * +static const WCHAR * DdeSetServerName( Tcl_Interp *interp, - const TCHAR *name, /* The name that will be used to refer to the + const WCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int flags, /* DDE_FLAG_FORCE or 0 */ @@ -296,7 +296,7 @@ DdeSetServerName( int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; - const TCHAR *actualName; + const WCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -355,8 +355,9 @@ DdeSetServerName( &srvPtrPtr); } if (r != TCL_OK) { - Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); - OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); + Tcl_DStringInit(&dString); + Tcl_UtfToUtf16DString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString); + OutputDebugString((WCHAR *) Tcl_DStringValue(&dString)); Tcl_DStringFree(&dString); return NULL; } @@ -374,13 +375,13 @@ DdeSetServerName( lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { - Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); - Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); + Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(WCHAR)); + Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(WCHAR)); offset = Tcl_DStringLength(&dString); - Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); - actualName = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, offset + sizeof(WCHAR) * TCL_INTEGER_SPACE); + actualName = (WCHAR *) Tcl_DStringValue(&dString); } - _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), + _sntprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset), TCL_INTEGER_SPACE, TEXT("%d"), suffix); } @@ -393,8 +394,9 @@ DdeSetServerName( Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); - if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { + Tcl_DStringInit(&ds); + Tcl_UtfToUtf16DString(Tcl_GetString(namePtr), -1, &ds); + if (_tcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); break; @@ -410,7 +412,7 @@ DdeSetServerName( riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); + riPtr->name = (WCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(WCHAR)); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; if (riPtr->handlerPtr != NULL) { @@ -633,7 +635,7 @@ DdeServerProc( Tcl_DString dString; size_t len; DWORD dlen; - TCHAR *utilString; + WCHAR *utilString; Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; @@ -649,8 +651,8 @@ DdeServerProc( len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINUNICODE); @@ -674,8 +676,8 @@ DdeServerProc( len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; @@ -743,8 +745,8 @@ DdeServerProc( len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); Tcl_DStringInit(&dsBuf); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { @@ -752,9 +754,10 @@ DdeServerProc( Tcl_GetString(convPtr->returnPackagePtr); len = convPtr->returnPackagePtr->length; if (uFmt != CF_TEXT) { - Tcl_WinUtfToTChar(returnString, len, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToUtf16DString(returnString, len, &dsBuf); returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); @@ -765,7 +768,8 @@ DdeServerProc( Tcl_DString ds; Tcl_Obj *variableObjPtr; - Tcl_WinTCharToUtf(utilString, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(utilString, -1, &ds); variableObjPtr = Tcl_GetVar2Ex( convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); @@ -773,9 +777,10 @@ DdeServerProc( returnString = Tcl_GetString(variableObjPtr); len = variableObjPtr->length; if (uFmt != CF_TEXT) { - Tcl_WinUtfToTChar(returnString, len, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToUtf16DString(returnString, len, &dsBuf); returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, @@ -818,16 +823,18 @@ DdeServerProc( Tcl_DStringInit(&dString); Tcl_DStringInit(&ds2); len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); - Tcl_WinTCharToUtf(utilString, -1, &ds); - utilString = (TCHAR *) DdeAccessData(hData, &len2); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(utilString, -1, &ds); + utilString = (WCHAR *) DdeAccessData(hData, &len2); len = len2; if (uFmt != CF_TEXT) { - Tcl_WinTCharToUtf(utilString, -1, &ds2); - utilString = (TCHAR *) Tcl_DStringValue(&ds2); + Tcl_DStringInit(&ds2); + Tcl_Utf16ToUtfDString(utilString, -1, &ds2); + utilString = (WCHAR *) Tcl_DStringValue(&ds2); } variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); @@ -862,7 +869,7 @@ DdeServerProc( return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (TCHAR *) DdeAccessData(hData, &dlen); + utilString = (WCHAR *) DdeAccessData(hData, &dlen); string = (char *) utilString; if (!dlen) { /* Empty binary array. */ @@ -877,7 +884,8 @@ DdeServerProc( /* unicode */ Tcl_DString dsBuf; - Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_Utf16ToUtfDString(utilString, (dlen>>1) - 1, &dsBuf); ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); @@ -993,7 +1001,7 @@ DdeExitProc( static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - const TCHAR *name, /* The connection to use. */ + const WCHAR *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; @@ -1010,7 +1018,8 @@ MakeDdeConnection( if (interp != NULL) { Tcl_DString dString; - Tcl_WinTCharToUtf(name, -1, &dString); + Tcl_DStringInit(&dString); + Tcl_Utf16ToUtfDString(name, -1, &dString); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no registered server named \"%s\"", Tcl_DStringValue(&dString))); Tcl_DStringFree(&dString); @@ -1048,8 +1057,8 @@ DdeCreateClient( DdeEnumServices *es) { WNDCLASSEX wc; - static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); - static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); + static const WCHAR *szDdeClientClassName = TEXT("TclEval client class"); + static const WCHAR *szDdeClientWindowName = TEXT("TclEval client window"); memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); @@ -1104,7 +1113,7 @@ DdeServicesOnAck( ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); DdeEnumServices *es; - TCHAR sz[255]; + WCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 @@ -1119,11 +1128,13 @@ DdeServicesOnAck( Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomName(service, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_DStringInit(&dString); + Tcl_Utf16ToUtfDString(sz, -1, &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); GlobalGetAtomName(topic, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_DStringInit(&dString); + Tcl_Utf16ToUtfDString(sz, -1, &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); @@ -1172,8 +1183,8 @@ DdeEnumWindowsCallback( static int DdeGetServicesList( Tcl_Interp *interp, - const TCHAR *serviceName, - const TCHAR *topicName) + const WCHAR *serviceName, + const WCHAR *topicName) { DdeEnumServices es; @@ -1302,7 +1313,7 @@ DdeObjCmd( HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; - const TCHAR *serviceName = NULL, *topicName = NULL; + const WCHAR *serviceName = NULL, *topicName = NULL; const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; @@ -1462,9 +1473,10 @@ DdeObjCmd( const char *src = Tcl_GetString(objv[firstArg]); length = objv[firstArg]->length; - Tcl_WinUtfToTChar(src, length, &serviceBuf); - serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf); - length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR); + Tcl_DStringInit(&serviceBuf); + Tcl_UtfToUtf16DString(src, length, &serviceBuf); + serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf); + length = Tcl_DStringLength(&serviceBuf) / sizeof(WCHAR); } else { length = 0; } @@ -1480,8 +1492,9 @@ DdeObjCmd( const char *src = Tcl_GetString(objv[firstArg + 1]); length = objv[firstArg + 1]->length; - topicName = Tcl_WinUtfToTChar(src, length, &topicBuf); - length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR); + Tcl_DStringInit(&topicBuf); + topicName = Tcl_UtfToUtf16DString(src, length, &topicBuf); + length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR); if (length == 0) { topicName = NULL; } else { @@ -1497,7 +1510,8 @@ DdeObjCmd( if (serviceName != NULL) { Tcl_DString dsBuf; - Tcl_WinTCharToUtf(serviceName, -1, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_Utf16ToUtfDString(serviceName, -1, &dsBuf); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf))); Tcl_DStringFree(&dsBuf); @@ -1520,9 +1534,10 @@ DdeObjCmd( src = Tcl_GetString(objv[firstArg + 2]); dataLength = objv[firstArg + 2]->length; - dataString = (const TCHAR *) - Tcl_WinUtfToTChar(src, dataLength, &dsBuf); - dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + Tcl_DStringInit(&dsBuf); + dataString = (const WCHAR *) + Tcl_UtfToUtf16DString(src, dataLength, &dsBuf); + dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } if (dataLength + 1 < 2) { @@ -1568,13 +1583,14 @@ DdeObjCmd( break; } case DDE_REQUEST: { - const TCHAR *itemString; + const WCHAR *itemString; const char *src; src = Tcl_GetString(objv[firstArg + 2]); length = objv[firstArg + 2]->length; - itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); - length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); + Tcl_DStringInit(&itemBuf); + itemString = Tcl_UtfToUtf16DString(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, @@ -1602,7 +1618,7 @@ DdeObjCmd( result = TCL_ERROR; } else { DWORD tmp; - TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp); + WCHAR *dataString = (WCHAR *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = @@ -1610,11 +1626,12 @@ DdeObjCmd( } else { Tcl_DString dsBuf; - if ((tmp >= sizeof(TCHAR)) - && !dataString[tmp / sizeof(TCHAR) - 1]) { - tmp -= sizeof(TCHAR); + if ((tmp >= sizeof(WCHAR)) + && !dataString[tmp / sizeof(WCHAR) - 1]) { + tmp -= sizeof(WCHAR); } - Tcl_WinTCharToUtf(dataString, tmp, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_Utf16ToUtfDString(dataString, tmp>>1, &dsBuf); returnObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); @@ -1633,14 +1650,15 @@ DdeObjCmd( } case DDE_POKE: { Tcl_DString dsBuf; - const TCHAR *itemString; + const WCHAR *itemString; BYTE *dataString; const char *src; src = Tcl_GetString(objv[firstArg + 2]); length = objv[firstArg + 2]->length; - itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); - length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); + Tcl_DStringInit(&itemBuf); + itemString = Tcl_UtfToUtf16DString(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", -1)); @@ -1656,9 +1674,10 @@ DdeObjCmd( const char *data = Tcl_GetString(objv[firstArg + 3]); length = objv[firstArg + 3]->length; + Tcl_DStringInit(&dsBuf); dataString = (BYTE *) - Tcl_WinUtfToTChar(data, length, &dsBuf); - length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + Tcl_UtfToUtf16DString(data, length, &dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); @@ -1820,9 +1839,10 @@ DdeObjCmd( objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetString(objPtr); length = objPtr->length; - Tcl_WinUtfToTChar(string, length, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToUtf16DString(string, length, &dsBuf); string = Tcl_DStringValue(&dsBuf); - length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, (DWORD) length, 0, 0, CF_UNICODETEXT, 0); Tcl_DStringFree(&dsBuf); @@ -1854,7 +1874,7 @@ DdeObjCmd( if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; - TCHAR *ddeDataString; + WCHAR *ddeDataString; /* * The return handle has a two or four element list in it. The @@ -1866,12 +1886,13 @@ DdeObjCmd( */ length = DdeGetData(ddeData, NULL, 0, 0); - ddeDataString = (TCHAR *) Tcl_Alloc(length); + ddeDataString = (WCHAR *) Tcl_Alloc(length); DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); - if (length > sizeof(TCHAR)) { - length -= sizeof(TCHAR); + if (length > sizeof(WCHAR)) { + length -= sizeof(WCHAR); } - Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_Utf16ToUtfDString(ddeDataString, length>>1, &dsBuf); resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 14bb252..e8863dc 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -328,8 +328,10 @@ DoRenameFile( CharLower(nativeSrcPath); CharLower(nativeDstPath); - src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString); - dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString); + Tcl_DStringInit(&srcString); + Tcl_DStringInit(&dstString); + src = Tcl_Utf16ToUtfDString(nativeSrcPath, -1, &srcString); + dst = Tcl_Utf16ToUtfDString(nativeDstPath, -1, &dstString); /* * Check whether the destination path is actually inside the @@ -911,8 +913,10 @@ TclpObjCopyDirectory( return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString); - Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString); + Tcl_DStringInit(&srcString); + Tcl_DStringInit(&dstString); + Tcl_UtfToUtf16DString(Tcl_GetString(normSrcPtr), -1, &srcString); + Tcl_UtfToUtf16DString(Tcl_GetString(normDestPtr), -1, &dstString); ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); @@ -984,7 +988,8 @@ TclpObjRemoveDirectory( if (normPtr == NULL) { return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); + Tcl_DStringInit(&native); + Tcl_UtfToUtf16DString(Tcl_GetString(normPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { @@ -1109,7 +1114,10 @@ DoRemoveJustDirectory( end: if (errorPtr != NULL) { - char *p = Tcl_WinTCharToUtf(nativePath, -1, errorPtr); + char *p; + + Tcl_DStringInit(errorPtr); + p = Tcl_Utf16ToUtfDString(nativePath, -1, errorPtr); for (; *p; ++p) { if (*p == '\\') *p = '/'; } @@ -1323,7 +1331,8 @@ TraverseWinTree( if (nativeErrfile != NULL) { TclWinConvertError(GetLastError()); if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_Utf16ToUtfDString(nativeErrfile, -1, errorPtr); } result = TCL_ERROR; } @@ -1388,7 +1397,8 @@ TraversalCopy( */ if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_Utf16ToUtfDString(nativeDst, -1, errorPtr); } return TCL_ERROR; } @@ -1443,7 +1453,8 @@ TraversalDelete( } if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_Utf16ToUtfDString(nativeSrc, -1, errorPtr); } return TCL_ERROR; } @@ -1651,7 +1662,8 @@ ConvertFileNameFormat( */ tempString = TclGetStringFromObj(tempPath, &length); - nativeName = Tcl_WinUtfToTChar(tempString, length, &ds); + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToUtf16DString(tempString, length, &ds); Tcl_DecrRefCount(tempPath); handle = FindFirstFile(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { @@ -1688,7 +1700,7 @@ ConvertFileNameFormat( } /* - * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying + * Purify reports a extraneous UMR in Tcl_Utf16ToUtfDString() trying * to dereference nativeName as a Unicode string. I have proven to * myself that purify is wrong by running the following example * when nativeName == data.w.cAlternateFileName and noting that @@ -1700,7 +1712,7 @@ ConvertFileNameFormat( */ Tcl_DStringInit(&dsTemp); - Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); + Tcl_Utf16ToUtfDString(nativeName, -1, &dsTemp); Tcl_DStringFree(&ds); /* diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 0b5da4f..2550fde 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -634,10 +634,11 @@ WinReadLinkDirectory( } } - Tcl_WinTCharToUtf( + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString( reparseBuffer->MountPointReparseBuffer.PathBuffer, reparseBuffer->MountPointReparseBuffer - .SubstituteNameLength, &ds); + .SubstituteNameLength>>1, &ds); copy = Tcl_DStringValue(&ds)+offset; len = Tcl_DStringLength(&ds)-offset; @@ -1023,7 +1024,8 @@ TclpMatchInDirectory( dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); } - native = Tcl_WinUtfToTChar(dirName, -1, &ds); + Tcl_DStringInit(&ds); + native = Tcl_UtfToUtf16DString(dirName, -1, &ds); if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { handle = FindFirstFile(native, &data); } else { @@ -1096,7 +1098,8 @@ TclpMatchInDirectory( native = data.cFileName; attr = data.dwFileAttributes; - utfname = Tcl_WinTCharToUtf(native, -1, &ds); + Tcl_DStringInit(&ds); + utfname = Tcl_Utf16ToUtfDString(native, -1, &ds); if (!matchSpecialDots) { /* @@ -1982,7 +1985,8 @@ TclpGetCwd( && (native[2] == '\\') && (native[3] == '\\')) { native += 2; } - Tcl_WinTCharToUtf(native, -1, bufferPtr); + Tcl_DStringInit(bufferPtr); + Tcl_Utf16ToUtfDString(native, -1, bufferPtr); /* * Convert to forward slashes for easier use in scripts. @@ -2190,7 +2194,8 @@ NativeDev( const char *fullPath; GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart); - fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds); + Tcl_DStringInit(&ds); + fullPath = Tcl_Utf16ToUtfDString(nativeFullPath, -1, &ds); if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { const char *p; @@ -2211,7 +2216,8 @@ NativeDev( } else { p++; } - nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); + Tcl_DStringInit(&volString); + nativeVol = Tcl_UtfToUtf16DString(fullPath, p - fullPath, &volString); dw = (DWORD) -1; GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); @@ -2491,7 +2497,8 @@ TclpFilesystemPathType( } else { Tcl_DString ds; - Tcl_WinTCharToUtf(volType, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(volType, -1, &ds); return TclDStringToObj(&ds); } #undef VOL_BUF_SIZE @@ -2561,7 +2568,10 @@ TclpObjNormalizePath( */ WIN32_FILE_ATTRIBUTE_DATA data; - const WCHAR *nativePath = Tcl_WinUtfToTChar(path, + const WCHAR *nativePath; + + Tcl_DStringInit(&ds); + nativePath = Tcl_UtfToUtf16DString(path, currentPathEndPosition - path, &ds); if (GetFileAttributesEx(nativePath, @@ -2763,11 +2773,14 @@ TclpObjNormalizePath( if (1) { WCHAR wpath[MAX_PATH]; - const WCHAR *nativePath = - Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds); - DWORD wpathlen = GetLongPathNameProc(nativePath, - (WCHAR *) wpath, MAX_PATH); + const WCHAR *nativePath; + DWORD wpathlen; + Tcl_DStringInit(&ds); + nativePath = + Tcl_UtfToUtf16DString(path, lastValidPathEnd - path, &ds); + wpathlen = GetLongPathNameProc(nativePath, + (WCHAR *) wpath, MAX_PATH); /* * We have to make the drive letter uppercase. */ @@ -2794,8 +2807,9 @@ TclpObjNormalizePath( * native encoding, so we have to convert it to Utf. */ - Tcl_WinTCharToUtf((const WCHAR *) Tcl_DStringValue(&dsNorm), - Tcl_DStringLength(&dsNorm), &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString((const WCHAR *) Tcl_DStringValue(&dsNorm), + Tcl_DStringLength(&dsNorm)>>1, &ds); nextCheckpoint = Tcl_DStringLength(&ds); if (*lastValidPathEnd != 0) { /* @@ -2970,7 +2984,8 @@ TclpNativeToNormalized( int len; char *copy, *p; - Tcl_WinTCharToUtf((const WCHAR *) clientData, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString((const WCHAR *) clientData, -1, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index f4c6e06..4219963 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -476,8 +476,8 @@ TclpGetUserName( return NULL; } cchUserNameLen--; - cchUserNameLen *= sizeof(WCHAR); - Tcl_WinTCharToUtf(szUserName, cchUserNameLen, bufferPtr); + Tcl_DStringInit(bufferPtr); + Tcl_Utf16ToUtfDString(szUserName, cchUserNameLen, bufferPtr); } return Tcl_DStringValue(bufferPtr); } diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 69263e9..d0ab6e4 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -95,7 +95,8 @@ TclpDlopen( firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); - nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToUtf16DString(Tcl_GetString(pathPtr), -1, &ds); hInstance = LoadLibraryEx(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index a001816..c382e23 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -577,7 +577,8 @@ TclpOpenFile( break; } - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); + Tcl_DStringInit(&ds); + nativePath = Tcl_UtfToUtf16DString(path, -1, &ds); /* * If the file is not being created, use the existing file attributes. @@ -1290,7 +1291,8 @@ ApplicationType( for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { Tcl_DStringSetLength(&nameBuf, nameLen); Tcl_DStringAppend(&nameBuf, extensions[i], -1); - nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToUtf16DString(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); found = SearchPath(NULL, nativeName, NULL, MAX_PATH, nativeFullPath, &rest); @@ -1308,7 +1310,8 @@ ApplicationType( if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { continue; } - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + Tcl_DStringInit(&ds); + strcpy(fullName, Tcl_Utf16ToUtfDString(nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); @@ -1399,7 +1402,8 @@ ApplicationType( */ GetShortPathName(nativeFullPath, nativeFullPath, MAX_PATH); - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + Tcl_DStringInit(&ds); + strcpy(fullName, Tcl_Utf16ToUtfDString(nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); } return applType; @@ -1727,7 +1731,8 @@ BuildCommandLine( } } Tcl_DStringFree(linePtr); - Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr); + Tcl_DStringInit(linePtr); + Tcl_UtfToUtf16DString(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr); Tcl_DStringFree(&ds); } @@ -3209,7 +3214,8 @@ TclpOpenTemporaryFile( if (basenameObj) { const char *string = TclGetStringFromObj(basenameObj, &length); - Tcl_WinUtfToTChar(string, length, &buf); + Tcl_DStringInit(&buf); + Tcl_UtfToUtf16DString(string, length, &buf); memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); namePtr += Tcl_DStringLength(&buf); Tcl_DStringFree(&buf); @@ -3229,7 +3235,8 @@ TclpOpenTemporaryFile( sprintf(number, "%d.TMP", counter); counter = (unsigned short) (counter + 1); - Tcl_WinUtfToTChar(number, strlen(number), &buf); + Tcl_DStringInit(&buf); + Tcl_UtfToUtf16DString(number, strlen(number), &buf); Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf) + 1); memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); diff --git a/win/tclWinReg.c b/win/tclWinReg.c index f93a553..27d02b4 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -116,7 +116,7 @@ static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, - const TCHAR * pKeyName, REGSAM mode); + const WCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -168,7 +168,7 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { return TCL_ERROR; } @@ -415,7 +415,7 @@ DeleteKey( REGSAM mode) /* Mode flags to pass. */ { char *tail, *buffer, *hostName, *keyName; - const TCHAR *nativeTail; + const WCHAR *nativeTail; HKEY rootKey, subkey; DWORD result; Tcl_DString buf; @@ -468,7 +468,8 @@ DeleteKey( * Now we recursively delete the key and everything below it. */ - nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); + Tcl_DStringInit(&buf); + nativeTail = Tcl_UtfToUtf16DString(tail, -1, &buf); result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); @@ -524,8 +525,9 @@ DeleteValue( } valueName = Tcl_GetString(valueNameObj); - Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); - result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); + Tcl_DStringInit(&ds); + Tcl_UtfToUtf16DString(valueName, valueNameObj->length, &ds); + result = RegDeleteValue(key, (const WCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -568,7 +570,7 @@ GetKeyNames( { const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH]; + WCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ @@ -613,7 +615,8 @@ GetKeyNames( } break; } - name = Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); + Tcl_DStringInit(&ds); + name = Tcl_Utf16ToUtfDString(buffer, bufSize, &ds); if (pattern && !Tcl_StringMatch(name, pattern)) { Tcl_DStringFree(&ds); continue; @@ -663,7 +666,7 @@ GetType( DWORD result, type; Tcl_DString ds; const char *valueName; - const TCHAR *nativeValue; + const WCHAR *nativeValue; /* * Attempt to open the key for reading. @@ -679,7 +682,8 @@ GetType( */ valueName = Tcl_GetString(valueNameObj); - nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); + Tcl_DStringInit(&ds); + nativeValue = Tcl_UtfToUtf16DString(valueName, valueNameObj->length, &ds); result = RegQueryValueEx(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); @@ -732,7 +736,7 @@ GetValue( { HKEY key; const char *valueName; - const TCHAR *nativeValue; + const WCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; @@ -757,10 +761,11 @@ GetValue( Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); - length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; + length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1; valueName = Tcl_GetString(valueNameObj); - nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf); + Tcl_DStringInit(&buf); + nativeValue = Tcl_UtfToUtf16DString(valueName, valueNameObj->length, &buf); result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -771,8 +776,8 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); - Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); + length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR)); + Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR)); result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } @@ -811,7 +816,8 @@ GetValue( while ((p < end) && *((WCHAR *) p) != 0) { WCHAR *wp; - Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); + Tcl_DStringInit(&buf); + Tcl_Utf16ToUtfDString((WCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); @@ -823,7 +829,8 @@ GetValue( } Tcl_SetObjResult(interp, resultPtr); } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); + Tcl_DStringInit(&buf); + Tcl_Utf16ToUtfDString((WCHAR *) Tcl_DStringValue(&data), -1, &buf); Tcl_DStringResult(interp, &buf); } else { /* @@ -880,7 +887,7 @@ GetValueNames( resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); index = 0; result = TCL_OK; @@ -897,12 +904,11 @@ GetValueNames( */ size = MAX_KEY_LENGTH; - while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), + while (RegEnumValue(key,index, (WCHAR *)Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { - size *= sizeof(TCHAR); - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, - &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString((WCHAR *) Tcl_DStringValue(&buffer), size, &ds); name = Tcl_DStringValue(&ds); if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, @@ -1008,8 +1014,9 @@ OpenSubKey( */ if (hostName) { - hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); - result = RegConnectRegistry((TCHAR *)hostName, rootKey, + Tcl_DStringInit(&buf); + hostName = (char *) Tcl_UtfToUtf16DString(hostName, -1, &buf); + result = RegConnectRegistry((WCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { @@ -1023,12 +1030,13 @@ OpenSubKey( */ if (keyName) { - keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + Tcl_DStringInit(&buf); + keyName = (char *) Tcl_UtfToUtf16DString(keyName, -1, &buf); } if (flags & REG_CREATE) { DWORD create; - result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, + result = RegCreateKeyEx(rootKey, (WCHAR *)keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); } else if (rootKey == HKEY_PERFORMANCE_DATA) { /* @@ -1039,7 +1047,7 @@ OpenSubKey( *keyPtr = HKEY_PERFORMANCE_DATA; result = ERROR_SUCCESS; } else { - result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, + result = RegOpenKeyEx(rootKey, (WCHAR *)keyName, 0, mode, keyPtr); } if (keyName) { @@ -1159,7 +1167,7 @@ ParseKeyName( static DWORD RecursiveDeleteKey( HKEY startKey, /* Parent of key to be deleted. */ - const TCHAR *keyName, /* Name of key to be deleted in external + const WCHAR *keyName, /* Name of key to be deleted in external * encoding, not UTF. */ REGSAM mode) /* Mode flags to pass. */ { @@ -1185,7 +1193,7 @@ RecursiveDeleteKey( } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); mode = saveMode; while (result == ERROR_SUCCESS) { @@ -1194,7 +1202,7 @@ RecursiveDeleteKey( */ size = MAX_KEY_LENGTH; - result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), + result = RegEnumKeyEx(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { /* @@ -1219,7 +1227,7 @@ RecursiveDeleteKey( break; } else if (result == ERROR_SUCCESS) { result = RecursiveDeleteKey(hKey, - (const TCHAR *) Tcl_DStringValue(&subkey), mode); + (const WCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1275,7 +1283,8 @@ SetValue( } valueName = Tcl_GetString(valueNameObj); - valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf); + Tcl_DStringInit(&nameBuf); + valueName = (char *) Tcl_UtfToUtf16DString(valueName, valueNameObj->length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; @@ -1287,7 +1296,7 @@ SetValue( } value = ConvertDWORD((DWORD) type, (DWORD) value); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueEx(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1319,9 +1328,10 @@ SetValue( Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } - Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, + Tcl_DStringInit(&buf); + Tcl_UtfToUtf16DString(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueEx(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); @@ -1330,7 +1340,8 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetString(dataObj); - data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf); + Tcl_DStringInit(&buf); + data = (char *) Tcl_UtfToUtf16DString(data, dataObj->length, &buf); /* * Include the null in the length, padding if needed for WCHAR. @@ -1338,7 +1349,7 @@ SetValue( Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueEx(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); } else { @@ -1350,7 +1361,7 @@ SetValue( */ data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueEx(key, (WCHAR *) valueName, 0, (DWORD) type, data, (DWORD) bytelength); } @@ -1410,7 +1421,8 @@ BroadcastValue( } str = Tcl_GetString(objv[0]); - wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds); + Tcl_DStringInit(&ds); + wstr = (WCHAR *) Tcl_UtfToUtf16DString(str, objv[0]->length, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } @@ -1454,7 +1466,7 @@ AppendSystemError( DWORD error) /* Result code from error. */ { int length; - TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; + WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; Tcl_DString ds; @@ -1465,7 +1477,7 @@ AppendSystemError( } length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) tMsgPtrPtr, 0, NULL); if (length == 0) { sprintf(msgBuf, "unknown error: %ld", error); @@ -1473,7 +1485,8 @@ AppendSystemError( } else { char *msgPtr; - Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(tMsgPtr, -1, &ds); LocalFree(tMsgPtr); msgPtr = Tcl_DStringValue(&ds); diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 635ea57..41ddbb7 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1669,7 +1669,8 @@ SerialSetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { goto getStateFailed; } - native = Tcl_WinUtfToTChar(value, -1, &ds); + Tcl_DStringInit(&ds); + native = Tcl_UtfToUtf16DString(value, -1, &ds); result = BuildCommDCB(native, &dcb); Tcl_DStringFree(&ds); diff --git a/win/tclWinSock.c b/win/tclWinSock.c index d52edc3..a61328a 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -367,15 +367,15 @@ InitializeHostName( DWORD length = MAX_COMPUTERNAME_LENGTH + 1; Tcl_DString ds; + Tcl_DStringInit(&ds); if (GetComputerName(tbuf, &length) != 0) { /* * Convert string from native to UTF then change to lowercase. */ - Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); + Tcl_UtfToLower(Tcl_Utf16ToUtfDString(tbuf, -1, &ds)); } else { - Tcl_DStringInit(&ds); if (TclpHasSockets(NULL) == TCL_OK) { /* * The buffer size of 256 is recommended by the MSDN page that -- cgit v0.12 From 58260d444e3b5a71fb5d06645d34f42e80d013bf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 May 2019 21:50:14 +0000 Subject: More simplifications, taking deprecations into account --- generic/tcl.decls | 27 ++---- generic/tcl.h | 2 +- generic/tclCmdMZ.c | 4 +- generic/tclDecls.h | 53 ++++------- generic/tclInt.h | 2 +- generic/tclStringObj.c | 4 +- generic/tclStubInit.c | 20 ++--- generic/tclUtf.c | 237 +++---------------------------------------------- 8 files changed, 46 insertions(+), 303 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index a93f957..38c5206 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1248,8 +1248,8 @@ declare 351 { declare 352 {deprecated {Use Tcl_GetCharLength}} { int Tcl_UniCharLen(const unsigned short *uniStr) } -declare 353 { - int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, +declare 353 {deprecated {Use Tcl_UtfNcmp}} { + int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars) } declare 354 { @@ -1483,13 +1483,13 @@ declare 417 { declare 418 { int Tcl_IsChannelExisting(const char *channelName) } -declare 419 { - int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, +declare 419 {deprecated {Use Tcl_UtfNcasecmp}} { + int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars) } -declare 420 { - int Tcl_UniCharCaseMatch(const unsigned short *uniStr, - const unsigned short *uniPattern, int nocase) +declare 420 {deprecated {Use Tcl_StringCaseMatch}} { + int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, + const Tcl_UniChar *uniPattern, int nocase) } declare 421 { Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) @@ -2411,19 +2411,6 @@ declare 652 { void TclAppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, int length) } -declare 653 { - int Tcl_Utf32Ncmp(const int *ucs, const int *uct, - unsigned long numChars) -} -declare 654 { - int Tcl_Utf32Ncasecmp(const int *ucs, const int *uct, - unsigned long numChars) -} -declare 655 { - int Tcl_Utf32CaseMatch(const int *uniStr, - const int *uniPattern, int nocase) -} - # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tcl.h b/generic/tcl.h index e716aae..d689011 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2144,7 +2144,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 4 +#define TCL_UTF_MAX 3 #endif /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index e478276..0a42a9a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -604,7 +604,7 @@ Tcl_RegsubObjCmd( numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); - strCmpFn = nocase ? Tcl_Utf32Ncasecmp : Tcl_Utf32Ncmp; + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; wsrc = TclGetUnicodeFromObj(objv[0], &slen); wstring = TclGetUnicodeFromObj(objv[1], &wlen); @@ -2090,7 +2090,7 @@ StringMapCmd( } end = ustring1 + length1; - strCmpFn = (nocase ? Tcl_Utf32Ncasecmp : Tcl_Utf32Ncmp); + strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); /* * Force result to be Unicode diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 16bf942..05398d4 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1066,8 +1066,9 @@ EXTERN int Tcl_UniCharIsWordChar(int ch); TCL_DEPRECATED("Use Tcl_GetCharLength") int Tcl_UniCharLen(const unsigned short *uniStr); /* 353 */ -EXTERN int Tcl_UniCharNcmp(const unsigned short *ucs, - const unsigned short *uct, +TCL_DEPRECATED("Use Tcl_UtfNcmp") +int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, + const Tcl_UniChar *uct, unsigned long numChars); /* 354 */ EXTERN char * Tcl_Utf16ToUtfDString(const unsigned short *uniStr, @@ -1251,12 +1252,14 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ -EXTERN int Tcl_UniCharNcasecmp(const unsigned short *ucs, - const unsigned short *uct, +TCL_DEPRECATED("Use Tcl_UtfNcasecmp") +int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, + const Tcl_UniChar *uct, unsigned long numChars); /* 420 */ -EXTERN int Tcl_UniCharCaseMatch(const unsigned short *uniStr, - const unsigned short *uniPattern, int nocase); +TCL_DEPRECATED("Use Tcl_StringCaseMatch") +int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, + const Tcl_UniChar *uniPattern, int nocase); /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key); @@ -1922,15 +1925,6 @@ EXTERN int * TclGetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 652 */ EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, int length); -/* 653 */ -EXTERN int Tcl_Utf32Ncmp(const int *ucs, const int *uct, - unsigned long numChars); -/* 654 */ -EXTERN int Tcl_Utf32Ncasecmp(const int *ucs, const int *uct, - unsigned long numChars); -/* 655 */ -EXTERN int Tcl_Utf32CaseMatch(const int *uniStr, - const int *uniPattern, int nocase); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2319,7 +2313,7 @@ typedef struct TclStubs { int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ TCL_DEPRECATED_API("Use Tcl_GetCharLength") int (*tcl_UniCharLen) (const unsigned short *uniStr); /* 352 */ - int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ + TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */ char * (*tcl_Utf16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToUtf16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ @@ -2385,8 +2379,8 @@ typedef struct TclStubs { void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ - int (*tcl_UniCharCaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ + TCL_DEPRECATED_API("Use Tcl_UtfNcasecmp") int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */ + TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */ Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ @@ -2619,9 +2613,6 @@ typedef struct TclStubs { Tcl_Obj * (*tclNewUnicodeObj) (const int *unicode, int numChars); /* 650 */ int * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 651 */ void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const int *unicode, int length); /* 652 */ - int (*tcl_Utf32Ncmp) (const int *ucs, const int *uct, unsigned long numChars); /* 653 */ - int (*tcl_Utf32Ncasecmp) (const int *ucs, const int *uct, unsigned long numChars); /* 654 */ - int (*tcl_Utf32CaseMatch) (const int *uniStr, const int *uniPattern, int nocase); /* 655 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3957,12 +3948,6 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclGetUnicodeFromObj) /* 651 */ #define TclAppendUnicodeToObj \ (tclStubsPtr->tclAppendUnicodeToObj) /* 652 */ -#define Tcl_Utf32Ncmp \ - (tclStubsPtr->tcl_Utf32Ncmp) /* 653 */ -#define Tcl_Utf32Ncasecmp \ - (tclStubsPtr->tcl_Utf32Ncasecmp) /* 654 */ -#define Tcl_Utf32CaseMatch \ - (tclStubsPtr->tcl_Utf32CaseMatch) /* 655 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4101,10 +4086,10 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetLongFromObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj -# undef Tcl_Utf32Ncmp +# undef Tcl_UniCharNcmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp -# undef Tcl_Utf32Ncasecmp +# undef Tcl_UniCharNcasecmp # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ @@ -4120,13 +4105,13 @@ extern const TclStubs *tclStubsPtr; if (result == TCL_OK) *ptr = (long)intValue; return result; } -# define Tcl_Utf32Ncmp(ucs,uct,n) \ +# define Tcl_UniCharNcmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n)) # define Tcl_UtfNcmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n)) # define Tcl_UtfNcasecmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) -# define Tcl_Utf32Ncasecmp(ucs,uct,n) \ +# define Tcl_UniCharNcasecmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) # endif #endif @@ -4163,12 +4148,6 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniCharDString Tcl_UtfToUtf16DString # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToUtf16 -# undef Tcl_Utf32Ncmp -# define Tcl_Utf32Ncmp Tcl_UniCharNcmp -# undef Tcl_Utf32Ncasecmp -# define Tcl_Utf32Ncasecmp Tcl_UniCharNcasecmp -# undef Tcl_Utf32CaseMatch -# define Tcl_Utf32CaseMatch Tcl_UniCharCaseMatch #endif #if TCL_UTF_MAX > 3 || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 diff --git a/generic/tclInt.h b/generic/tclInt.h index fb35fc1..b6db913 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4687,7 +4687,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #ifdef WORDS_BIGENDIAN # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ -# define TclUniCharNcmp Tcl_Utf32Ncmp +# define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 76d875c..5a29477 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3402,7 +3402,7 @@ TclStringCmp( if (nocase) { s1 = (char *) TclGetUnicodeFromObj(value1Ptr, &s1len); s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)Tcl_Utf32Ncasecmp; + memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); @@ -3427,7 +3427,7 @@ TclStringCmp( s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); } else { - memCmpFn = (memCmpFn_t) Tcl_Utf32Ncmp; + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; } } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5900257..9dded47 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -66,9 +66,6 @@ #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar -#undef Tcl_Utf32Ncmp -#undef Tcl_Utf32Ncasecmp -#undef Tcl_Utf32CaseMatch #undef TclAppendUnicodeToObj static void uniCodePanic() { @@ -87,9 +84,6 @@ static void uniCodePanic() { # define Tcl_UtfToUniChar (int (*)(const char *, int *)) uniCodePanic # define Tcl_UniCharToUtfDString (char *(*)(const int *, int, Tcl_DString *)) uniCodePanic # define Tcl_UtfToUniCharDString (int *(*)(const char *, int, Tcl_DString *)) uniCodePanic -# define Tcl_Utf32CaseMatch (int (*)(const int *, const int *, int)) uniCodePanic -# define Tcl_Utf32Ncmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic -# define Tcl_Utf32Ncasecmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic #else #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *)) uniCodePanic @@ -356,13 +350,13 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp #if TCL_UTF_MAX > 3 static int uniCharNcmp(const int *ucs, const int *uct, unsigned int n){ - return Tcl_Utf32Ncmp(ucs, uct, (unsigned long)n); + return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } -#define Tcl_Utf32Ncmp (int(*)(const int*,const int*,unsigned long))uniCharNcmp +#define Tcl_UniCharNcmp (int(*)(const int*,const int*,unsigned long))uniCharNcmp static int uniCharNcasecmp(const int *ucs, const int *uct, unsigned int n){ - return Tcl_Utf32Ncasecmp(ucs, uct, (unsigned long)n); + return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); } -#define Tcl_Utf32Ncasecmp (int(*)(const int*,const int*,unsigned long))uniCharNcasecmp +#define Tcl_UniCharNcasecmp (int(*)(const int*,const int*,unsigned long))uniCharNcasecmp #else static int utf16Ncmp(const unsigned short *ucs, const unsigned short *uct, unsigned int n){ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); @@ -520,7 +514,10 @@ tellOld( #endif /* !TCL_NO_DEPRECATED */ #if TCL_UTF_MAX > 3 || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define Tcl_UniCharCaseMatch 0 # define Tcl_UniCharLen 0 +# define XTcl_UniCharNcmp 0 +# define XTcl_UniCharNcasecmp 0 #endif /* @@ -1692,9 +1689,6 @@ const TclStubs tclStubs = { TclNewUnicodeObj, /* 650 */ TclGetUnicodeFromObj, /* 651 */ TclAppendUnicodeToObj, /* 652 */ - Tcl_Utf32Ncmp, /* 653 */ - Tcl_Utf32Ncasecmp, /* 654 */ - Tcl_Utf32CaseMatch, /* 655 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 1beadec..b194c1b 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1680,39 +1680,10 @@ Tcl_UniCharLen( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX > 3 -int -Tcl_Utf32Ncmp( - const int *ucs, /* Unicode string to compare to uct. */ - const int *uct, /* Unicode string ucs is compared to. */ - unsigned long numChars) /* Number of unichars to compare. */ -{ -#ifdef WORDS_BIGENDIAN - /* - * We are definitely on a big-endian machine; memcmp() is safe - */ - - return memcmp(ucs, uct, numChars*sizeof(int)); - -#else /* !WORDS_BIGENDIAN */ - /* - * We can't simply call memcmp() because that is not lexically correct. - */ - - for ( ; numChars != 0; ucs++, uct++, numChars--) { - if (*ucs != *uct) { - return (*ucs - *uct); - } - } - return 0; -#endif /* WORDS_BIGENDIAN */ -} -#endif /* TCL_UTF_MAX > 3 */ - int Tcl_UniCharNcmp( - const unsigned short *ucs, /* Unicode string to compare to uct. */ - const unsigned short *uct, /* Unicode string ucs is compared to. */ + const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ + const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN @@ -1754,31 +1725,10 @@ Tcl_UniCharNcmp( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX > 3 -int -Tcl_Utf32Ncasecmp( - const int *ucs, /* Unicode string to compare to uct. */ - const int *uct, /* Unicode string ucs is compared to. */ - unsigned long numChars) /* Number of unichars to compare. */ -{ - for ( ; numChars != 0; numChars--, ucs++, uct++) { - if (*ucs != *uct) { - int lcs = Tcl_UniCharToLower(*ucs); - int lct = Tcl_UniCharToLower(*uct); - - if (lcs != lct) { - return (lcs - lct); - } - } - } - return 0; -} -#endif /* TCL_UTF_MAX > 3 */ - int Tcl_UniCharNcasecmp( - const unsigned short *ucs, /* Utf16 string to compare to uct. */ - const unsigned short *uct, /* Utf16 string ucs is compared to. */ + const Tcl_UniChar *ucs, /* Utf16 string to compare to uct. */ + const Tcl_UniChar *uct, /* Utf16 string ucs is compared to. */ unsigned long numChars) /* Number of Utf16 characters to compare. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { @@ -2126,184 +2076,16 @@ Tcl_UniCharIsWordChar( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX > 3 -int -Tcl_Utf32CaseMatch( - const int *uniStr, /* Unicode String. */ - const int *uniPattern, - /* Pattern, which may contain special - * characters. */ - int nocase) /* 0 for case sensitive, 1 for insensitive */ -{ - int ch1 = 0, p; - - while (1) { - p = *uniPattern; - - /* - * See if we're at the end of both the pattern and the string. If so, - * we succeeded. If we're at the end of the pattern but not at the end - * of the string, we failed. - */ - - if (p == 0) { - return (*uniStr == 0); - } - if ((*uniStr == 0) && (p != '*')) { - return 0; - } - - /* - * Check for a "*" as the next pattern character. It matches any - * substring. We handle this by skipping all the characters up to the - * next matching one in the pattern, and then calling ourselves - * recursively for each postfix of string, until either we match or we - * reach the end of the string. - */ - - if (p == '*') { - /* - * Skip all successive *'s in the pattern - */ - - while (*(++uniPattern) == '*') { - /* empty body */ - } - p = *uniPattern; - if (p == 0) { - return 1; - } - if (nocase) { - p = Tcl_UniCharToLower(p); - } - while (1) { - /* - * Optimization for matching - cruise through the string - * quickly if the next char in the pattern isn't a special - * character - */ - - if ((p != '[') && (p != '?') && (p != '\\')) { - if (nocase) { - while (*uniStr && (p != *uniStr) - && (p != Tcl_UniCharToLower(*uniStr))) { - uniStr++; - } - } else { - while (*uniStr && (p != *uniStr)) { - uniStr++; - } - } - } - if (Tcl_Utf32CaseMatch(uniStr, uniPattern, nocase)) { - return 1; - } - if (*uniStr == 0) { - return 0; - } - uniStr++; - } - } - - /* - * Check for a "?" as the next pattern character. It matches any - * single character. - */ - - if (p == '?') { - uniPattern++; - uniStr++; - continue; - } - - /* - * Check for a "[" as the next pattern character. It is followed by a - * list of characters that are acceptable, or by a range (two - * characters separated by "-"). - */ - - if (p == '[') { - int startChar, endChar; - - uniPattern++; - ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); - uniStr++; - while (1) { - if ((*uniPattern == ']') || (*uniPattern == 0)) { - return 0; - } - startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) - : *uniPattern); - uniPattern++; - if (*uniPattern == '-') { - uniPattern++; - if (*uniPattern == 0) { - return 0; - } - endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) - : *uniPattern); - uniPattern++; - if (((startChar <= ch1) && (ch1 <= endChar)) - || ((endChar <= ch1) && (ch1 <= startChar))) { - /* - * Matches ranges of form [a-z] or [z-a]. - */ - break; - } - } else if (startChar == ch1) { - break; - } - } - while (*uniPattern != ']') { - if (*uniPattern == 0) { - uniPattern--; - break; - } - uniPattern++; - } - uniPattern++; - continue; - } - - /* - * If the next pattern character is '\', just strip off the '\' so we - * do exact matching on the character that follows. - */ - - if (p == '\\') { - if (*(++uniPattern) == '\0') { - return 0; - } - } - - /* - * There's no special character. Just make sure that the next bytes of - * each string match. - */ - - if (nocase) { - if (Tcl_UniCharToLower(*uniStr) != - Tcl_UniCharToLower(*uniPattern)) { - return 0; - } - } else if (*uniStr != *uniPattern) { - return 0; - } - uniStr++; - uniPattern++; - } -} -#endif /* TCL_UTF_MAX > 3 */ - +#if !defined(TCL_NO_DEPRECATED) && TCL_UTF_MAX == 3 && TCL_MAJOR_VERSION < 9 int Tcl_UniCharCaseMatch( - const unsigned short *uniStr, /* Unicode String. */ - const unsigned short *uniPattern, + const Tcl_UniChar *uniStr, /* Unicode String. */ + const Tcl_UniChar *uniPattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { - unsigned short ch1 = 0, p; + Tcl_UniChar ch1 = 0, p; while (1) { p = *uniPattern; @@ -2391,7 +2173,7 @@ Tcl_UniCharCaseMatch( */ if (p == '[') { - unsigned short startChar, endChar; + Tcl_UniChar startChar, endChar; uniPattern++; ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); @@ -2461,6 +2243,7 @@ Tcl_UniCharCaseMatch( uniPattern++; } } +#endif /* defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- -- cgit v0.12 From 203f7657fe5533ba1cf4e8fac23cc5155cf13f4a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Aug 2019 21:47:01 +0000 Subject: wrong length in tclMain.c, and wrong #endif --- generic/tclMain.c | 3 --- generic/tclPlatDecls.h | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index ce0d6df..276922f 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -70,9 +70,6 @@ NewNativeObj( Tcl_DString ds; #ifdef UNICODE - if (length > 0) { - length *= sizeof(WCHAR); - } Tcl_DStringInit(&ds); Tcl_Char16ToUtfDString(string, length, &ds); #else diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index d1e0b9c..c4b01d0 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -128,6 +128,6 @@ extern const TclPlatStubs *tclPlatStubsPtr; #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (char *)Tcl_Char16ToUtfDString((string), ((((len) + 2) >> 1) - 1), (dsPtr))) -#endif#endif +#endif #endif #endif /* _TCLPLATDECLS */ -- cgit v0.12 From 972ac8cc9d03192665f5f6eaaf49fc1b7c97d109 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Aug 2019 21:55:52 +0000 Subject: Protect Tcl_AToB() functions against NULL input --- generic/tclUtf.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index ec9000b..d48a51e 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -237,6 +237,9 @@ Tcl_UniCharToUtfDString( * UTF-8 string length in bytes will be <= Unicode string length * 4. */ + if (uniStr == NULL) { + return NULL; + } if (uniLength < 0) { uniLength = 0; w = uniStr; @@ -276,6 +279,9 @@ Tcl_Char16ToUtfDString( * UTF-8 string length in bytes will be <= Utf16 string length * 3. */ + if (uniStr == NULL) { + return NULL; + } if (uniLength < 0) { uniLength = 0; @@ -571,6 +577,9 @@ Tcl_UtfToUniCharDString( const char *p, *end; int oldLength; + if (src == NULL) { + return NULL; + } if (length < 0) { length = strlen(src); } @@ -623,6 +632,9 @@ Tcl_UtfToChar16DString( const char *p, *end; int oldLength; + if (src == NULL) { + return NULL; + } if (length < 0) { length = strlen(src); } -- cgit v0.12 From 92c04315ff11b03e5364e616f3d5efc0a5144d24 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 Aug 2019 20:47:01 +0000 Subject: Forgot some changes from tip-548 --- win/tclWin32Dll.c | 2 +- win/tclWinReg.c | 4 ++-- win/tclWinSerial.c | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 668412f..2b05bf3 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -463,7 +463,7 @@ TclWinDriveLetterForVolMountPoint( *--------------------------------------------------------------------------- */ -#if (TCL_UTF_MAX == 3) && !defined(TCL_NO_DEPRECATED) +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #undef Tcl_WinUtfToTChar WCHAR * Tcl_WinUtfToTChar( diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 02c8367..73208b9 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -228,7 +228,7 @@ Registry_Unload( * Delete the originally registered command. */ - cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); if (cmd != NULL) { Tcl_DeleteCommandFromToken(interp, cmd); } @@ -257,7 +257,7 @@ static void DeleteCmd( ClientData clientData) { - Tcl_Interp *interp = clientData; + Tcl_Interp *interp = (Tcl_Interp *)clientData; Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 4411e89..d6fa567 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -2152,7 +2152,7 @@ SerialGetOptionProc( Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) { - char buf[4]; + char buf[TCL_UTF_MAX]; valid = 1; if (!GetCommState(infoPtr->handle, &dcb)) { -- cgit v0.12 From 4b48c76e1c40761ebe4173552178854265fb50c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 Aug 2019 20:49:50 +0000 Subject: default TCL_UTF_MAX should still be 3 --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index 8f796cc..1c3115d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2144,7 +2144,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 4 +#define TCL_UTF_MAX 3 #endif /* -- cgit v0.12 From 29db2a676191a091fee12e255a0d990ecae20397 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Nov 2019 14:40:54 +0000 Subject: Some code cleanup. Build with zlib dll on Win32 when using makefile.vc (shared-build only) --- generic/tclIO.c | 6 +++--- generic/tclStringObj.c | 2 +- generic/tclZipfs.c | 2 +- win/makefile.vc | 20 +++++++++++++++++++- win/rules.vc | 6 +++--- 5 files changed, 27 insertions(+), 9 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 36b3fad..643b8f1 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4712,14 +4712,14 @@ Tcl_GetsObj( * Skip the raw bytes that make up the '\n'. */ - char tmp[TCL_UTF_MAX]; int rawRead; + char tmp[TCL_UTF_MAX]; bufPtr = gs.bufPtr; Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), gs.rawRead, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &gs.state, tmp, - TCL_UTF_MAX, &rawRead, NULL, NULL); + sizeof(tmp), &rawRead, NULL, NULL); bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; @@ -6282,7 +6282,7 @@ ReadChars( Tcl_ExternalToUtf(NULL, encoding, src, srcLen, (statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE), - &statePtr->inputEncodingState, buffer, TCL_UTF_MAX + 1, + &statePtr->inputEncodingState, buffer, sizeof(buffer), &read, &decoded, &count); if (count == 2) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 072b642..fdfac99 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2613,7 +2613,7 @@ AppendPrintfToObjVA( end = q; } - q = bytes + TCL_UTF_MAX; + q = bytes + 4; while ((bytes < end) && (bytes < q) && ((*bytes & 0xC0) == 0x80)) { bytes++; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index f6b6711..393db5c 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3178,7 +3178,7 @@ TclZipfs_TclLibrary(void) #ifdef _WIN32 HMODULE hModule; WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char dllName[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char dllName[(MAX_PATH + LIBRARY_SIZE) * 3]; #endif /* _WIN32 */ /* diff --git a/win/makefile.vc b/win/makefile.vc index 44597a3..ab0e4b5 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -303,6 +303,7 @@ COREOBJS = \ $(TMP_DIR)\tclZipfs.obj \ $(TMP_DIR)\tclZlib.obj +!if $(STATIC_BUILD) ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ $(TMP_DIR)\compress.obj \ @@ -315,6 +316,9 @@ ZLIBOBJS = \ $(TMP_DIR)\trees.obj \ $(TMP_DIR)\uncompr.obj \ $(TMP_DIR)\zutil.obj +!else +ZLIBOBJS = $(OUT_DIR)\zdll.lib +!endif TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_add.obj \ @@ -446,7 +450,7 @@ TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs core: setup $(TCLLIB) $(TCLSTUBLIB) shell: setup $(TCLSH) -dlls: setup $(TCLREGLIB) $(TCLDDELIB) +dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll all: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs tcltest: setup $(TCLTEST) dlls install: install-binaries install-libraries install-docs install-pkgs @@ -519,6 +523,19 @@ $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) $(_VC_MANIFEST_EMBED_DLL) !endif +!if "$(MACHINE)" == "AMD64" +$(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win64\zlib1.dll + $(COPY) $(COMPATDIR)\zlib\win64\zlib1.dll $(OUT_DIR)\zlib1.dll +$(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win64\zdll.lib + $(COPY) $(COMPATDIR)\zlib\win64\zdll.lib $(OUT_DIR)\zdll.lib +!else +$(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win32\zlib1.dll + $(COPY) $(COMPATDIR)\zlib\win32\zlib1.dll $(OUT_DIR)\zlib1.dll +$(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win32\zdll.lib + $(COPY) $(COMPATDIR)\zlib\win32\zdll.lib $(OUT_DIR)\zdll.lib +!endif + + pkgs: @for /d %d in ($(PKGSDIR)\*) do \ @if exist "%~fd\win\makefile.vc" ( \ @@ -871,6 +888,7 @@ install-binaries: @$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\" !endif @$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\" + @$(CPY) "$(OUT_DIR)\zlib1.dll" "$(BIN_INSTALL_DIR)\" !if exist($(TCLSH)) @echo Installing $(TCLSHNAME) @$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\" diff --git a/win/rules.vc b/win/rules.vc index c35e3c6..e0225a2 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1190,8 +1190,8 @@ tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" !endif # $(DOING_TK) || $(NEED_TK) # Various output paths -PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX:t=).lib -PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX:t=).$(EXT) +PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib @@ -1493,7 +1493,7 @@ RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ /DCOMMAVERSION=$(DOTVERSION:.=,),0 \ /DDOTVERSION=\"$(DOTVERSION)\" \ /DVERSION=\"$(VERSION)\" \ - /DSUFX=\"$(SUFX:t=)\" \ + /DSUFX=\"$(SUFX)\" \ /DPROJECT=\"$(PROJECT)\" \ /DPRJLIBNAME=\"$(PRJLIBNAME)\" -- cgit v0.12 From f8474f319cd5f760b58a607747e8c5d35443db8d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 11 Dec 2019 12:41:00 +0000 Subject: Implement "panic" as described in the TIP --- generic/tcl.h | 17 ++++++----------- generic/tclStubInit.c | 32 ++++++++++++++++++++++++-------- 2 files changed, 30 insertions(+), 19 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 8521041..1a70ae4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2106,12 +2106,11 @@ typedef struct Tcl_EncodingType { /* * The maximum number of bytes that are necessary to represent a single - * Unicode character in UTF-8. The valid values are 4 and 6 - * (or perhaps 1 if we want to support a non-unicode enabled core). If 4, - * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, + * Unicode character in UTF-8. The valid values are 3 and 4 + * (or perhaps 1 if we want to support a non-unicode enabled core). If 3, + * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode - * is the default and recommended mode. UCS-4 is experimental and not - * recommended. It works for the core, but most extensions expect UCS-2. + * is the default and recommended mode. */ #ifndef TCL_UTF_MAX @@ -2126,12 +2125,8 @@ typedef struct Tcl_EncodingType { #if TCL_UTF_MAX > 3 /* * int isn't 100% accurate as it should be a strict 4-byte value - * (perhaps wchar_t). 64-bit systems may have troubles. The size of this - * value must be reflected correctly in regcustom.h and - * in tclEncoding.c. - * XXX: Tcl is currently UCS-2 and planning UTF-16 for the Unicode - * XXX: string rep that Tcl_UniChar represents. Changing the size - * XXX: of Tcl_UniChar is /not/ supported. + * (perhaps wchar_t). ILP64/SILP64 systems may have troubles. The + * size of this value must be reflected correctly in regcustom.h. */ typedef int Tcl_UniChar; #else diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c489608..e1fe23d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -71,6 +71,21 @@ #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar +#if TCL_UTF_MAX > 3 +static void uniCodePanic() { + Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX); +} +# define Tcl_GetUnicode (int *(*)(Tcl_Obj *)) uniCodePanic +# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, Tcl_UniChar *)) uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, Tcl_UniChar)) uniCodePanic +# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int)) uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int)) uniCodePanic +# define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long)) uniCodePanic +# define Tcl_UniCharCaseMatch (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, int)) uniCodePanic +# define Tcl_UniCharLen (int(*)(const Tcl_UniChar *)) uniCodePanic +# define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long)) uniCodePanic +#endif + #undef TclBN_mp_tc_and #undef TclBN_mp_tc_or #undef TclBN_mp_tc_xor @@ -409,10 +424,16 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ return result; } #define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj +#if TCL_UTF_MAX < 4 static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } #define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcmp +static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ + return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); +} +#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp +#endif static int utfNcmp(const char *s1, const char *s2, unsigned int n){ return Tcl_UtfNcmp(s1, s2, (unsigned long)n); } @@ -421,10 +442,6 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n); } #define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp -static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ - return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); -} -#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp #endif /* TCL_WIDE_INT_IS_LONG */ @@ -519,15 +536,14 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig # define Tcl_SetExitProc 0 # define Tcl_SetPanicProc 0 # define Tcl_FindExecutable 0 -# define Tcl_GetUnicodeFromObj 0 # define Tcl_GetUnicode 0 +#if TCL_UTF_MAX < 4 # define Tcl_AppendUnicodeToObj 0 -# define Tcl_NewUnicodeObj 0 -# define Tcl_SetUnicodeObj 0 -# define Tcl_UniCharNcasecmp 0 # define Tcl_UniCharCaseMatch 0 # define Tcl_UniCharLen 0 +# define Tcl_UniCharNcasecmp 0 # define Tcl_UniCharNcmp 0 +#endif # undef Tcl_StringMatch # define Tcl_StringMatch 0 # define TclBN_reverse 0 -- cgit v0.12 From e3f42b0c1afa79ffc4221e09f7eba2845a66f3ae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 12 Dec 2019 08:23:58 +0000 Subject: Little doc tweak --- doc/Utf.3 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index b2a8389..09e6420 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -153,13 +153,12 @@ case-insensitive (1). .SH DESCRIPTION .PP These routines convert between UTF-8 strings and Unicode/Utf-16 characters. -An Unicode character represented as an unsigned, fixed-size -quantity. A UTF-8 character is a Unicode character represented as -a varying-length sequence of up to \fBTCL_UTF_MAX\fR bytes. A multibyte UTF-8 -sequence consists of a lead byte followed by some number of trail bytes. +A UTF-8 character is a Unicode character represented as a varying-length +sequence of up to \fB4\fR bytes. A multibyte UTF-8 sequence +consists of a lead byte followed by some number of trail bytes. .PP -\fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to -represent one Unicode character in the UTF-8 representation. +\fBTCL_UTF_MAX\fR is the maximum number of bytes that \fBTcl_UtfToUniChar\fR +can consume in a single call. .PP \fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored -- cgit v0.12 From 88e4842dfe272fa62dafad30ca1f11b396f06d71 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 Dec 2019 23:14:53 +0000 Subject: Put back 4 test-cases as they were in core-8-branch, but only for TCL_UTF_MAX=3 --- generic/tclTestObj.c | 35 ++++++++++++++++++++++++++++++++++- tests/stringObj.test | 17 +++++++++++++++++ 2 files changed, 51 insertions(+), 1 deletion(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 1446f86..e616433 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1174,6 +1174,7 @@ TeststringobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_UniChar *unicode; int varIndex, option, i, length; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; @@ -1181,7 +1182,8 @@ TeststringobjCmd( Tcl_Obj **varPtr; static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", - "set", "set2", "setlength", "maxchars", "appendself", NULL + "set", "set2", "setlength", "maxchars", "appendself", + "appendself2", NULL }; if (objc < 3) { @@ -1377,6 +1379,37 @@ TeststringobjCmd( Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; + case 11: /* appendself2 */ + if (objc != 4) { + goto wrongNumArgs; + } + if (varPtr[varIndex] == NULL) { + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); + } + + /* + * If the object bound to variable "varIndex" is shared, we must + * "copy on write" and append to a copy of the object. + */ + + if (Tcl_IsShared(varPtr[varIndex])) { + SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + } + + unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); + + if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { + return TCL_ERROR; + } + if ((i < 0) || (i > length)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "index value out of range", -1)); + return TCL_ERROR; + } + + Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; } return TCL_OK; diff --git a/tests/stringObj.test b/tests/stringObj.test index cc9d123..8b10897 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -23,6 +23,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] +testConstraint tip389 [expr {[string length \U010000] == 2}] test stringObj-1.1 {string type registration} testobj { set t [testobj types] @@ -464,6 +465,22 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo +test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389} { + teststringobj set 1 foo + teststringobj appendself2 1 0 +} foofoo +test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389} { + teststringobj set 1 foo + teststringobj appendself2 1 1 +} foooo +test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389} { + teststringobj set 1 foo + teststringobj appendself2 1 2 +} fooo +test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389} { + teststringobj set 1 foo + teststringobj appendself2 1 3 +} foo if {[testConstraint testobj]} { testobj freeallvars -- cgit v0.12 From 3254602d80de090afe1a7caebeb7dd7a6d42d3f2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 24 Dec 2019 14:23:42 +0000 Subject: Attempt to improve support for external libtommath --- unix/configure | 430 +++++++++++++++++++++++++++--------------------------- unix/configure.ac | 88 +++++------ 2 files changed, 259 insertions(+), 259 deletions(-) diff --git a/unix/configure b/unix/configure index 74b7343..8d79cc3 100755 --- a/unix/configure +++ b/unix/configure @@ -675,6 +675,12 @@ ZIP_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD DTRACE +TOMMATH_INCLUDE +TOMMATH_SRCS +TOMMATH_OBJS +ZLIB_INCLUDE +ZLIB_SRCS +ZLIB_OBJS LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_STUB_LIB @@ -705,12 +711,6 @@ TCL_LIBS LIBOBJS AR RANLIB -TOMMATH_INCLUDE -TOMMATH_SRCS -TOMMATH_OBJS -ZLIB_INCLUDE -ZLIB_SRCS -ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP @@ -771,7 +771,6 @@ enable_man_compression enable_man_suffix with_encoding enable_shared -with_system_libtommath enable_64bit enable_64bit_vis enable_rpath @@ -780,6 +779,7 @@ enable_load enable_symbols enable_langinfo enable_dll_unloading +with_system_libtommath with_tzdata enable_dtrace enable_zipfs @@ -4552,214 +4552,6 @@ if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' fi -#------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" -if test "x$ac_cv_header_zlib_h" = xyes; then : - - ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include -" -if test "x$ac_cv_type_gz_header" = xyes; then : - -else - zlib_ok=no -fi - -else - - zlib_ok=no -fi - - -if test $zlib_ok = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 -$as_echo_n "checking for library containing deflateSetHeader... " >&6; } -if ${ac_cv_search_deflateSetHeader+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char deflateSetHeader (); -int -main () -{ -return deflateSetHeader (); - ; - return 0; -} -_ACEOF -for ac_lib in '' z; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_deflateSetHeader=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_deflateSetHeader+:} false; then : - break -fi -done -if ${ac_cv_search_deflateSetHeader+:} false; then : - -else - ac_cv_search_deflateSetHeader=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 -$as_echo "$ac_cv_search_deflateSetHeader" >&6; } -ac_res=$ac_cv_search_deflateSetHeader -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -else - - zlib_ok=no - -fi - -fi -if test $zlib_ok = no; then : - - ZLIB_OBJS=\${ZLIB_OBJS} - - ZLIB_SRCS=\${ZLIB_SRCS} - - ZLIB_INCLUDE=-I\${ZLIB_DIR} - - -fi - -$as_echo "#define HAVE_ZLIB 1" >>confdefs.h - - -#------------------------------------------------------------------------ -# Add stuff for libtommath - -libtommath_ok=yes - -# Check whether --with-system-libtommath was given. -if test "${with_system_libtommath+set}" = set; then : - withval=$with_system_libtommath; libtommath_ok=${withval} -fi - -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then - ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" -if test "x$ac_cv_header_tommath_h" = xyes; then : - - ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include -" -if test "x$ac_cv_type_mp_int" = xyes; then : - -else - libtommath_ok=no -fi - -else - - libtommath_ok=no -fi - - - if test $libtommath_ok = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing mp_log_u32" >&5 -$as_echo_n "checking for library containing mp_log_u32... " >&6; } -if ${ac_cv_search_mp_log_u32+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char mp_log_u32 (); -int -main () -{ -return mp_log_u32 (); - ; - return 0; -} -_ACEOF -for ac_lib in '' tommath; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_mp_log_u32=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_mp_log_u32+:} false; then : - break -fi -done -if ${ac_cv_search_mp_log_u32+:} false; then : - -else - ac_cv_search_mp_log_u32=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_mp_log_u32" >&5 -$as_echo "$ac_cv_search_mp_log_u32" >&6; } -ac_res=$ac_cv_search_mp_log_u32 -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -else - - libtommath_ok=no - -fi - -fi -fi -if test $libtommath_ok = yes; then : - - -$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h - - -else - - TOMMATH_OBJS=\${TOMMATH_OBJS} - - TOMMATH_SRCS=\${TOMMATH_SRCS} - - TOMMATH_INCLUDE=-I\${TOMMATH_DIR} - - -fi - #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -10003,6 +9795,214 @@ fi $as_echo "$tcl_ok" >&6; } #------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" +if test "x$ac_cv_header_zlib_h" = xyes; then : + + ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include +" +if test "x$ac_cv_type_gz_header" = xyes; then : + +else + zlib_ok=no +fi + +else + + zlib_ok=no +fi + + +if test $zlib_ok = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 +$as_echo_n "checking for library containing deflateSetHeader... " >&6; } +if ${ac_cv_search_deflateSetHeader+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_func_search_save_LIBS=$LIBS +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char deflateSetHeader (); +int +main () +{ +return deflateSetHeader (); + ; + return 0; +} +_ACEOF +for ac_lib in '' z; do + if test -z "$ac_lib"; then + ac_res="none required" + else + ac_res=-l$ac_lib + LIBS="-l$ac_lib $ac_func_search_save_LIBS" + fi + if ac_fn_c_try_link "$LINENO"; then : + ac_cv_search_deflateSetHeader=$ac_res +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + if ${ac_cv_search_deflateSetHeader+:} false; then : + break +fi +done +if ${ac_cv_search_deflateSetHeader+:} false; then : + +else + ac_cv_search_deflateSetHeader=no +fi +rm conftest.$ac_ext +LIBS=$ac_func_search_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 +$as_echo "$ac_cv_search_deflateSetHeader" >&6; } +ac_res=$ac_cv_search_deflateSetHeader +if test "$ac_res" != no; then : + test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" + +else + + zlib_ok=no + +fi + +fi +if test $zlib_ok = no; then : + + ZLIB_OBJS=\${ZLIB_OBJS} + + ZLIB_SRCS=\${ZLIB_SRCS} + + ZLIB_INCLUDE=-I\${ZLIB_DIR} + + +fi + +$as_echo "#define HAVE_ZLIB 1" >>confdefs.h + + +#------------------------------------------------------------------------ +# Add stuff for libtommath + +libtommath_ok=yes + +# Check whether --with-system-libtommath was given. +if test "${with_system_libtommath+set}" = set; then : + withval=$with_system_libtommath; libtommath_ok=${withval} +fi + +if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then + ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" +if test "x$ac_cv_header_tommath_h" = xyes; then : + + ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include +" +if test "x$ac_cv_type_mp_int" = xyes; then : + +else + libtommath_ok=no +fi + +else + + libtommath_ok=no +fi + + + if test $libtommath_ok = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing mp_log_u32" >&5 +$as_echo_n "checking for library containing mp_log_u32... " >&6; } +if ${ac_cv_search_mp_log_u32+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_func_search_save_LIBS=$LIBS +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char mp_log_u32 (); +int +main () +{ +return mp_log_u32 (); + ; + return 0; +} +_ACEOF +for ac_lib in '' tommath; do + if test -z "$ac_lib"; then + ac_res="none required" + else + ac_res=-l$ac_lib + LIBS="-l$ac_lib $ac_func_search_save_LIBS" + fi + if ac_fn_c_try_link "$LINENO"; then : + ac_cv_search_mp_log_u32=$ac_res +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + if ${ac_cv_search_mp_log_u32+:} false; then : + break +fi +done +if ${ac_cv_search_mp_log_u32+:} false; then : + +else + ac_cv_search_mp_log_u32=no +fi +rm conftest.$ac_ext +LIBS=$ac_func_search_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_mp_log_u32" >&5 +$as_echo "$ac_cv_search_mp_log_u32" >&6; } +ac_res=$ac_cv_search_mp_log_u32 +if test "$ac_res" != no; then : + test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" + +else + + libtommath_ok=no + +fi + +fi +fi +if test $libtommath_ok = yes; then : + + +$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h + + +else + + TOMMATH_OBJS=\${TOMMATH_OBJS} + + TOMMATH_SRCS=\${TOMMATH_SRCS} + + TOMMATH_INCLUDE=-I\${TOMMATH_DIR} + + +fi + +#------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can # be overridden on the configure command line either way. diff --git a/unix/configure.ac b/unix/configure.ac index a5cb12b..23eaad0 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -148,50 +148,6 @@ if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' fi -#------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -AC_CHECK_HEADER([zlib.h],[ - AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ - zlib_ok=no]) -AS_IF([test $zlib_ok = yes], [ - AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ - zlib_ok=no - ])]) -AS_IF([test $zlib_ok = no], [ - AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) - AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) - AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) -]) -AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) - -#------------------------------------------------------------------------ -# Add stuff for libtommath - -libtommath_ok=yes -AC_ARG_WITH(system-libtommath, -AC_HELP_STRING([--with-system-libtommath], - [use external libtommath (default: true if available, false otherwise)]), - libtommath_ok=${withval}) -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then - AC_CHECK_HEADER([tommath.h],[ - AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ - libtommath_ok=no]) - AS_IF([test $libtommath_ok = yes], [ - AC_SEARCH_LIBS([mp_log_u32],[tommath],[],[ - libtommath_ok=no - ])]) -fi -AS_IF([test $libtommath_ok = yes], [ - AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) -], [ - AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}]) - AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}]) - AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}]) -]) - #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -700,6 +656,50 @@ fi AC_MSG_RESULT([$tcl_ok]) #------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +AC_CHECK_HEADER([zlib.h],[ + AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ + zlib_ok=no]) +AS_IF([test $zlib_ok = yes], [ + AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ + zlib_ok=no + ])]) +AS_IF([test $zlib_ok = no], [ + AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) + AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) + AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) +]) +AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) + +#------------------------------------------------------------------------ +# Add stuff for libtommath + +libtommath_ok=yes +AC_ARG_WITH(system-libtommath, +AC_HELP_STRING([--with-system-libtommath], + [use external libtommath (default: true if available, false otherwise)]), + libtommath_ok=${withval}) +if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then + AC_CHECK_HEADER([tommath.h],[ + AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ + libtommath_ok=no]) + AS_IF([test $libtommath_ok = yes], [ + AC_SEARCH_LIBS([mp_log_u32],[tommath],[],[ + libtommath_ok=no + ])]) +fi +AS_IF([test $libtommath_ok = yes], [ + AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) +], [ + AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}]) + AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}]) + AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}]) +]) + +#------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can # be overridden on the configure command line either way. -- cgit v0.12 From 54aabbf0531d892183d72597647df8e780d6deac Mon Sep 17 00:00:00 2001 From: gahr Date: Fri, 27 Dec 2019 12:11:38 +0000 Subject: Use AC_CHECK_LIB and put ltommath in MATH_LIBS to avoid polluting LIBS --- unix/configure.ac | 87 +++++++++++++++++++++++++++---------------------------- 1 file changed, 43 insertions(+), 44 deletions(-) diff --git a/unix/configure.ac b/unix/configure.ac index 23eaad0..b2370b7 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -148,6 +148,49 @@ if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' fi +#------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +AC_CHECK_HEADER([zlib.h],[ + AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ + zlib_ok=no]) +AS_IF([test $zlib_ok = yes], [ + AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ + zlib_ok=no + ])]) +AS_IF([test $zlib_ok = no], [ + AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) + AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) + AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) +]) +AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) + +#------------------------------------------------------------------------ +# Add stuff for libtommath + +libtommath_ok=yes +AC_ARG_WITH(system-libtommath, +AC_HELP_STRING([--with-system-libtommath], + [use external libtommath (default: true if available, false otherwise)]), + libtommath_ok=${withval}) +if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then + AC_CHECK_HEADER([tommath.h],[ + AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ + libtommath_ok=no]) + AS_IF([test $libtommath_ok = yes], [ + AC_CHECK_LIB([tommath],[mp_log_u32],[MATH_LIBS="$MATH_LIBS -ltommath"],[ + libtommath_ok=no])]) +fi +AS_IF([test $libtommath_ok = yes], [ + AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) +], [ + AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}]) + AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}]) + AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}]) +]) + #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -656,50 +699,6 @@ fi AC_MSG_RESULT([$tcl_ok]) #------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -AC_CHECK_HEADER([zlib.h],[ - AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ - zlib_ok=no]) -AS_IF([test $zlib_ok = yes], [ - AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ - zlib_ok=no - ])]) -AS_IF([test $zlib_ok = no], [ - AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) - AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) - AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) -]) -AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) - -#------------------------------------------------------------------------ -# Add stuff for libtommath - -libtommath_ok=yes -AC_ARG_WITH(system-libtommath, -AC_HELP_STRING([--with-system-libtommath], - [use external libtommath (default: true if available, false otherwise)]), - libtommath_ok=${withval}) -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then - AC_CHECK_HEADER([tommath.h],[ - AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ - libtommath_ok=no]) - AS_IF([test $libtommath_ok = yes], [ - AC_SEARCH_LIBS([mp_log_u32],[tommath],[],[ - libtommath_ok=no - ])]) -fi -AS_IF([test $libtommath_ok = yes], [ - AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) -], [ - AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}]) - AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}]) - AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}]) -]) - -#------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can # be overridden on the configure command line either way. -- cgit v0.12 From 70b0310ff768715978d48ea90453e846d989d559 Mon Sep 17 00:00:00 2001 From: gahr Date: Fri, 27 Dec 2019 12:12:15 +0000 Subject: Make sure LDFLAGS are propagated to MAKE_LIB --- unix/tcl.m4 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index e90ff7b..0d0716b 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1385,7 +1385,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - LDFLAGS="" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) @@ -1822,7 +1821,7 @@ dnl # preprocessing tests use only CPPFLAGS. AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS} ${LDFLAGS}' AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" -- cgit v0.12 From a5fd8b5d9c7e499c5fd12e6837e292c30d58a426 Mon Sep 17 00:00:00 2001 From: gahr Date: Fri, 27 Dec 2019 12:13:15 +0000 Subject: Regenerate configure --- unix/configure | 416 +++++++++++++++++++++++++++------------------------------ 1 file changed, 199 insertions(+), 217 deletions(-) diff --git a/unix/configure b/unix/configure index 8d79cc3..0321050 100755 --- a/unix/configure +++ b/unix/configure @@ -675,12 +675,6 @@ ZIP_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD DTRACE -TOMMATH_INCLUDE -TOMMATH_SRCS -TOMMATH_OBJS -ZLIB_INCLUDE -ZLIB_SRCS -ZLIB_OBJS LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_STUB_LIB @@ -711,6 +705,12 @@ TCL_LIBS LIBOBJS AR RANLIB +TOMMATH_INCLUDE +TOMMATH_SRCS +TOMMATH_OBJS +ZLIB_INCLUDE +ZLIB_SRCS +ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP @@ -771,6 +771,7 @@ enable_man_compression enable_man_suffix with_encoding enable_shared +with_system_libtommath enable_64bit enable_64bit_vis enable_rpath @@ -779,7 +780,6 @@ enable_load enable_symbols enable_langinfo enable_dll_unloading -with_system_libtommath with_tzdata enable_dtrace enable_zipfs @@ -4552,6 +4552,197 @@ if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' fi +#------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" +if test "x$ac_cv_header_zlib_h" = xyes; then : + + ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include +" +if test "x$ac_cv_type_gz_header" = xyes; then : + +else + zlib_ok=no +fi + +else + + zlib_ok=no +fi + + +if test $zlib_ok = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 +$as_echo_n "checking for library containing deflateSetHeader... " >&6; } +if ${ac_cv_search_deflateSetHeader+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_func_search_save_LIBS=$LIBS +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char deflateSetHeader (); +int +main () +{ +return deflateSetHeader (); + ; + return 0; +} +_ACEOF +for ac_lib in '' z; do + if test -z "$ac_lib"; then + ac_res="none required" + else + ac_res=-l$ac_lib + LIBS="-l$ac_lib $ac_func_search_save_LIBS" + fi + if ac_fn_c_try_link "$LINENO"; then : + ac_cv_search_deflateSetHeader=$ac_res +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + if ${ac_cv_search_deflateSetHeader+:} false; then : + break +fi +done +if ${ac_cv_search_deflateSetHeader+:} false; then : + +else + ac_cv_search_deflateSetHeader=no +fi +rm conftest.$ac_ext +LIBS=$ac_func_search_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 +$as_echo "$ac_cv_search_deflateSetHeader" >&6; } +ac_res=$ac_cv_search_deflateSetHeader +if test "$ac_res" != no; then : + test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" + +else + + zlib_ok=no + +fi + +fi +if test $zlib_ok = no; then : + + ZLIB_OBJS=\${ZLIB_OBJS} + + ZLIB_SRCS=\${ZLIB_SRCS} + + ZLIB_INCLUDE=-I\${ZLIB_DIR} + + +fi + +$as_echo "#define HAVE_ZLIB 1" >>confdefs.h + + +#------------------------------------------------------------------------ +# Add stuff for libtommath + +libtommath_ok=yes + +# Check whether --with-system-libtommath was given. +if test "${with_system_libtommath+set}" = set; then : + withval=$with_system_libtommath; libtommath_ok=${withval} +fi + +if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then + ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" +if test "x$ac_cv_header_tommath_h" = xyes; then : + + ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include +" +if test "x$ac_cv_type_mp_int" = xyes; then : + +else + libtommath_ok=no +fi + +else + + libtommath_ok=no +fi + + + if test $libtommath_ok = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mp_log_u32 in -ltommath" >&5 +$as_echo_n "checking for mp_log_u32 in -ltommath... " >&6; } +if ${ac_cv_lib_tommath_mp_log_u32+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ltommath $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char mp_log_u32 (); +int +main () +{ +return mp_log_u32 (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_tommath_mp_log_u32=yes +else + ac_cv_lib_tommath_mp_log_u32=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tommath_mp_log_u32" >&5 +$as_echo "$ac_cv_lib_tommath_mp_log_u32" >&6; } +if test "x$ac_cv_lib_tommath_mp_log_u32" = xyes; then : + MATH_LIBS="$MATH_LIBS -ltommath" +else + + libtommath_ok=no +fi + +fi +fi +if test $libtommath_ok = yes; then : + + +$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h + + +else + + TOMMATH_OBJS=\${TOMMATH_OBJS} + + TOMMATH_SRCS=\${TOMMATH_SRCS} + + TOMMATH_INCLUDE=-I\${TOMMATH_DIR} + + +fi + #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -5637,7 +5828,6 @@ fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - LDFLAGS="" if test $doRpath = yes; then : CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' @@ -6393,7 +6583,7 @@ fi if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then : LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS} ${LDFLAGS}' if test "${SHLIB_SUFFIX}" = ".dll"; then : INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' @@ -9795,214 +9985,6 @@ fi $as_echo "$tcl_ok" >&6; } #------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" -if test "x$ac_cv_header_zlib_h" = xyes; then : - - ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include -" -if test "x$ac_cv_type_gz_header" = xyes; then : - -else - zlib_ok=no -fi - -else - - zlib_ok=no -fi - - -if test $zlib_ok = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 -$as_echo_n "checking for library containing deflateSetHeader... " >&6; } -if ${ac_cv_search_deflateSetHeader+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char deflateSetHeader (); -int -main () -{ -return deflateSetHeader (); - ; - return 0; -} -_ACEOF -for ac_lib in '' z; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_deflateSetHeader=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_deflateSetHeader+:} false; then : - break -fi -done -if ${ac_cv_search_deflateSetHeader+:} false; then : - -else - ac_cv_search_deflateSetHeader=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 -$as_echo "$ac_cv_search_deflateSetHeader" >&6; } -ac_res=$ac_cv_search_deflateSetHeader -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -else - - zlib_ok=no - -fi - -fi -if test $zlib_ok = no; then : - - ZLIB_OBJS=\${ZLIB_OBJS} - - ZLIB_SRCS=\${ZLIB_SRCS} - - ZLIB_INCLUDE=-I\${ZLIB_DIR} - - -fi - -$as_echo "#define HAVE_ZLIB 1" >>confdefs.h - - -#------------------------------------------------------------------------ -# Add stuff for libtommath - -libtommath_ok=yes - -# Check whether --with-system-libtommath was given. -if test "${with_system_libtommath+set}" = set; then : - withval=$with_system_libtommath; libtommath_ok=${withval} -fi - -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then - ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" -if test "x$ac_cv_header_tommath_h" = xyes; then : - - ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include -" -if test "x$ac_cv_type_mp_int" = xyes; then : - -else - libtommath_ok=no -fi - -else - - libtommath_ok=no -fi - - - if test $libtommath_ok = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing mp_log_u32" >&5 -$as_echo_n "checking for library containing mp_log_u32... " >&6; } -if ${ac_cv_search_mp_log_u32+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char mp_log_u32 (); -int -main () -{ -return mp_log_u32 (); - ; - return 0; -} -_ACEOF -for ac_lib in '' tommath; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_mp_log_u32=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_mp_log_u32+:} false; then : - break -fi -done -if ${ac_cv_search_mp_log_u32+:} false; then : - -else - ac_cv_search_mp_log_u32=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_mp_log_u32" >&5 -$as_echo "$ac_cv_search_mp_log_u32" >&6; } -ac_res=$ac_cv_search_mp_log_u32 -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -else - - libtommath_ok=no - -fi - -fi -fi -if test $libtommath_ok = yes; then : - - -$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h - - -else - - TOMMATH_OBJS=\${TOMMATH_OBJS} - - TOMMATH_SRCS=\${TOMMATH_SRCS} - - TOMMATH_INCLUDE=-I\${TOMMATH_DIR} - - -fi - -#------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can # be overridden on the configure command line either way. -- cgit v0.12 From 61ddd431cab6fcc9de99b5bcf22b95934a1d95cb Mon Sep 17 00:00:00 2001 From: gahr Date: Fri, 27 Dec 2019 12:53:48 +0000 Subject: Include LDFLAGS in TCL_LIB, since that's where MATH_LIBS come in --- unix/configure | 4 ++-- unix/tcl.m4 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/configure b/unix/configure index 0321050..6ce6281 100755 --- a/unix/configure +++ b/unix/configure @@ -6583,7 +6583,7 @@ fi if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then : LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS} ${LDFLAGS}' + MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' if test "${SHLIB_SUFFIX}" = ".dll"; then : INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' @@ -6629,7 +6629,7 @@ fi # it is already set when tclConfig.sh had been loaded by Tk. if test "x${TCL_LIBS}" = x; then : - TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}" + TCL_LIBS="${DL_LIBS} ${LIBS} ${LDFLAGS} ${MATH_LIBS}" fi diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 0d0716b..3758a10 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1821,7 +1821,7 @@ dnl # preprocessing tests use only CPPFLAGS. AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS} ${LDFLAGS}' + MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" @@ -1851,7 +1851,7 @@ dnl # preprocessing tests use only CPPFLAGS. # The trick here is that we don't want to change the value of TCL_LIBS if # it is already set when tclConfig.sh had been loaded by Tk. AS_IF([test "x${TCL_LIBS}" = x], [ - TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"]) + TCL_LIBS="${DL_LIBS} ${LIBS} ${LDFLAGS} ${MATH_LIBS}"]) AC_SUBST(TCL_LIBS) # See if the compiler supports casting to a union type. -- cgit v0.12 From 54e9b9d2b392b33e0a518fe3cfc55598f63cd51b Mon Sep 17 00:00:00 2001 From: gahr Date: Mon, 30 Dec 2019 13:48:44 +0000 Subject: Fix equality check, reported by Emiliano --- unix/configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/configure.ac b/unix/configure.ac index b2370b7..b893d1a 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -175,7 +175,7 @@ AC_ARG_WITH(system-libtommath, AC_HELP_STRING([--with-system-libtommath], [use external libtommath (default: true if available, false otherwise)]), libtommath_ok=${withval}) -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then +if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then AC_CHECK_HEADER([tommath.h],[ AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ libtommath_ok=no]) -- cgit v0.12 From c24a2bec0132d005fae4d4f47ebeba49d1a7f9cd Mon Sep 17 00:00:00 2001 From: gahr Date: Mon, 30 Dec 2019 13:49:39 +0000 Subject: Regenerate configure --- unix/configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/configure b/unix/configure index 6ce6281..4a5ebe6 100755 --- a/unix/configure +++ b/unix/configure @@ -4661,7 +4661,7 @@ if test "${with_system_libtommath+set}" = set; then : withval=$with_system_libtommath; libtommath_ok=${withval} fi -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then +if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" if test "x$ac_cv_header_tommath_h" = xyes; then : -- cgit v0.12 From 3b3abe0ce145a48c4426746f839aa29867e5991b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Jan 2020 11:53:03 +0000 Subject: Code cleanup (mostly comments, backported from 8.6). --- generic/tclStrToD.c | 2075 ++++++++++++++++++++++++++------------------------- 1 file changed, 1040 insertions(+), 1035 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 60429c4..4359829 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1,6 +1,4 @@ /* - *---------------------------------------------------------------------- - * * tclStrToD.c -- * * This file contains a collection of procedures for managing conversions @@ -13,23 +11,15 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - *---------------------------------------------------------------------- */ #include "tclInt.h" #include "tommath.h" +#include #include -/* - * Older MSVC has no copysign function, but it's available at least since - * MSVC++ 12.0 (that is Visual Studio 2013). - */ - -#if (defined(_MSC_VER) && (_MSC_VER < 1800)) -inline static double -copysign(double a, double b) { - return _copysign(a, b); -} +#ifdef _WIN32 +#define copysign _copysign #endif /* @@ -74,24 +64,25 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); #endif /* - * MIPS floating-point units need special settings in control registers - * to use gradual underflow as we expect. This fix is for the MIPSpro - * compiler. + * MIPS floating-point units need special settings in control registers to use + * gradual underflow as we expect. This fix is for the MIPSpro compiler. */ + #if defined(__sgi) && defined(_COMPILER_VERSION) #include #endif + /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa -# define NAN_START 0x7ff4 -# define NAN_MASK (((Tcl_WideUInt) 1) << 50) +# define NAN_START 0x7ff4 +# define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else -# define NAN_START 0x7ff8 -# define NAN_MASK (((Tcl_WideUInt) 1) << 51) +# define NAN_START 0x7ff8 +# define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* @@ -105,45 +96,44 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); #define TWO_OVER_3LOG10 0.28952965460216784 #define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 -/* Definitions of the parts of an IEEE754-format floating point number */ - -#define SIGN_BIT 0x80000000 - /* Mask for the sign bit in the first - * word of a double */ -#define EXP_MASK 0x7ff00000 - /* Mask for the exponent field in the - * first word of a double */ -#define EXP_SHIFT 20 - /* Shift count to make the exponent an - * integer */ -#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) - /* Hidden 1 bit for the significand */ -#define HI_ORDER_SIG_MASK 0x000fffff +/* + * Definitions of the parts of an IEEE754-format floating point number. + */ + +#define SIGN_BIT 0x80000000 + /* Mask for the sign bit in the first word of + * a double. */ +#define EXP_MASK 0x7ff00000 + /* Mask for the exponent field in the first + * word of a double. */ +#define EXP_SHIFT 20 /* Shift count to make the exponent an + * integer. */ +#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) + /* Hidden 1 bit for the significand. */ +#define HI_ORDER_SIG_MASK 0x000fffff /* Mask for the high-order part of the * significand in the first word of a - * double */ -#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ - | 0xffffffff) + * double. */ +#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ + | 0xffffffff) /* Mask for the 52-bit significand. */ -#define FP_PRECISION 53 - /* Number of bits of significand plus the - * hidden bit */ -#define EXPONENT_BIAS 0x3ff - /* Bias of the exponent 0 */ - -/* Derived quantities */ - -#define TEN_PMAX 22 - /* floor(FP_PRECISION*log(2)/log(5)) */ -#define QUICK_MAX 14 - /* floor((FP_PRECISION-1)*log(2)/log(10)) - 1 */ -#define BLETCH 0x10 - /* Highest power of two that is greater than - * DBL_MAX_10_EXP, divided by 16 */ -#define DIGIT_GROUP 8 - /* floor(MP_DIGIT_BIT*log(2)/log(10)) */ - -/* Union used to dismantle floating point numbers. */ +#define FP_PRECISION 53 /* Number of bits of significand plus the + * hidden bit. */ +#define EXPONENT_BIAS 0x3ff /* Bias of the exponent 0. */ + +/* + * Derived quantities. + */ + +#define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */ +#define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */ +#define BLETCH 0x10 /* Highest power of two that is greater than + * DBL_MAX_10_EXP, divided by 16. */ +#define DIGIT_GROUP 8 /* floor(MP_DIGIT_BIT*log(2)/log(10)) */ + +/* + * Union used to dismantle floating point numbers. + */ typedef union Double { struct { @@ -174,7 +164,7 @@ static int log2FLT_RADIX; /* Logarithm of the floating point radix. */ static int mantBits; /* Number of bits in a double's significand */ static mp_int pow5[9]; /* Table of powers of 5**(2**n), up to * 5**256 */ -static double tiny = 0.0; /* The smallest representable double */ +static double tiny = 0.0; /* The smallest representable double. */ static int maxDigits; /* The maximum number of digits to the left of * the decimal point of a double. */ static int minDigits; /* The maximum number of digits to the right @@ -196,10 +186,12 @@ static int n770_fp; /* Flag is 1 on Nokia N770 floating point. * reversed: if big-endian is 7654 3210, * and little-endian is 0123 4567, * then Nokia's FP is 4567 0123; - * little-endian within the 32-bit words - * but big-endian between them. */ + * little-endian within the 32-bit words but + * big-endian between them. */ -/* Table of powers of 5 that are small enough to fit in an mp_digit. */ +/* + * Table of powers of 5 that are small enough to fit in an mp_digit. + */ static const mp_digit dpow5[13] = { 1, 5, 25, 125, @@ -208,7 +200,10 @@ static const mp_digit dpow5[13] = { 244140625 }; -/* Table of powers: pow5_13[n] = 5**(13*2**(n+1)) */ +/* + * Table of powers: pow5_13[n] = 5**(13*2**(n+1)) + */ + static mp_int pow5_13[5]; /* Table of powers: 5**13, 5**26, 5**52, * 5**104, 5**208 */ static const double tens[] = { @@ -285,60 +280,62 @@ static double MakeLowPrecisionDouble(int signum, static double MakeNaN(int signum, Tcl_WideUInt tag); static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); -static void MulPow5(mp_int*, unsigned, mp_int*); -static int NormalizeRightward(Tcl_WideUInt*); +static void MulPow5(mp_int *, unsigned, mp_int *); +static int NormalizeRightward(Tcl_WideUInt *); static int RequiredPrecision(Tcl_WideUInt); -static void DoubleToExpAndSig(double, Tcl_WideUInt*, int*, int*); -static void TakeAbsoluteValue(Double*, int*); -static char* FormatInfAndNaN(Double*, int*, char**); -static char* FormatZero(int*, char**); +static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, + int *); +static void TakeAbsoluteValue(Double *, int *); +static char * FormatInfAndNaN(Double *, int *, char **); +static char * FormatZero(int *, char **); static int ApproximateLog10(Tcl_WideUInt, int, int); -static int BetterLog10(double, int, int*); -static void ComputeScale(int, int, int*, int*, int*, int*); -static void SetPrecisionLimits(int, int, int*, int*, int*, int*); -static char* BumpUp(char*, char*, int*); -static int AdjustRange(double*, int); -static char* ShorteningQuickFormat(double, int, int, double, - char*, int*); -static char* StrictQuickFormat(double, int, int, double, - char*, int*); -static char* QuickConversion(double, int, int, int, int, int, int, - int*, char**); -static void CastOutPowersOf2(int*, int*, int*); -static char* ShorteningInt64Conversion(Double*, int, Tcl_WideUInt, +static int BetterLog10(double, int, int *); +static void ComputeScale(int, int, int *, int *, int *, int *); +static void SetPrecisionLimits(int, int, int *, int *, int *, + int *); +static char * BumpUp(char *, char *, int *); +static int AdjustRange(double *, int); +static char * ShorteningQuickFormat(double, int, int, double, + char *, int *); +static char * StrictQuickFormat(double, int, int, double, + char *, int *); +static char * QuickConversion(double, int, int, int, int, int, int, + int *, char **); +static void CastOutPowersOf2(int *, int *, int *); +static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, - int, int, int*, char**); -static char* StrictInt64Conversion(Double*, int, Tcl_WideUInt, + int, int, int *, char **); +static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, - int, int, int*, char**); -static int ShouldBankerRoundUpPowD(mp_int*, int, int); -static int ShouldBankerRoundUpToNextPowD(mp_int*, mp_int*, - int, int, int, mp_int*); -static char* ShorteningBignumConversionPowD(Double* dPtr, + int, int, int *, char **); +static int ShouldBankerRoundUpPowD(mp_int *, int, int); +static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, + int, int, int, mp_int *); +static char * ShorteningBignumConversionPowD(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int b5, int m2plus, int m2minus, int m5, int sd, int k, int len, - int ilim, int ilim1, int* decpt, - char** endPtr); -static char* StrictBignumConversionPowD(Double* dPtr, int convType, + int ilim, int ilim1, int *decpt, + char **endPtr); +static char * StrictBignumConversionPowD(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int b5, int sd, int k, int len, - int ilim, int ilim1, int* decpt, - char** endPtr); -static int ShouldBankerRoundUp(mp_int*, mp_int*, int); -static int ShouldBankerRoundUpToNext(mp_int*, mp_int*, mp_int*, - int, int, mp_int*); -static char* ShorteningBignumConversion(Double* dPtr, int convType, + int ilim, int ilim1, int *decpt, + char **endPtr); +static int ShouldBankerRoundUp(mp_int *, mp_int *, int); +static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, + mp_int *, int, int, mp_int *); +static char * ShorteningBignumConversion(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int m2plus, int m2minus, int s2, int s5, int k, int len, - int ilim, int ilim1, int* decpt, - char** endPtr); -static char* StrictBignumConversion(Double* dPtr, int convType, + int ilim, int ilim1, int *decpt, + char **endPtr); +static char * StrictBignumConversion(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int s2, int s5, int k, int len, - int ilim, int ilim1, int* decpt, - char** endPtr); + int ilim, int ilim1, int *decpt, + char **endPtr); static double BignumToBiasedFrExp(mp_int *big, int *machexp); static double Pow10TimesFrExp(int exponent, double fraction, int *machexp); @@ -372,14 +369,14 @@ static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); * - TCL_PARSE_SCAN_PREFIXES: ignore the prefixes 0b and 0o that are * not part of the [scan] command's vocabulary. Use only in * combination with TCL_PARSE_INTEGER_ONLY. - * - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether + * - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether * or not a prefix is present that would lead to octal parsing. * Use only in combination with TCL_PARSE_INTEGER_ONLY. - * - TCL_PARSE_HEXADECIMAL_ONLY: parse only in the hexadecimal format, + * - TCL_PARSE_HEXADECIMAL_ONLY: parse only in the hexadecimal format, * whether or not a prefix is present that would lead to * hexadecimal parsing. Use only in combination with * TCL_PARSE_INTEGER_ONLY. - * - TCL_PARSE_DECIMAL_ONLY: parse only in the decimal format, no + * - TCL_PARSE_DECIMAL_ONLY: parse only in the decimal format, no * matter whether a 0 prefix would normally force a different * base. * - TCL_PARSE_NO_WHITESPACE: reject any leading/trailing whitespace @@ -473,38 +470,38 @@ TclParseNumber( } state = INITIAL; enum State acceptState = INITIAL; - int signum = 0; /* Sign of the number being parsed */ + int signum = 0; /* Sign of the number being parsed. */ Tcl_WideUInt significandWide = 0; /* Significand of the number being parsed (if - * no overflow) */ + * no overflow). */ mp_int significandBig; /* Significand of the number being parsed (if - * it overflows significandWide) */ - int significandOverflow = 0;/* Flag==1 iff significandBig is used */ + * it overflows significandWide). */ + int significandOverflow = 0;/* Flag==1 iff significandBig is used. */ Tcl_WideUInt octalSignificandWide = 0; /* Significand of an octal number; needed * because we don't know whether a number with * a leading zero is octal or decimal until - * we've scanned forward to a '.' or 'e' */ + * we've scanned forward to a '.' or 'e'. */ mp_int octalSignificandBig; /* Significand of octal number once - * octalSignificandWide overflows */ + * octalSignificandWide overflows. */ int octalSignificandOverflow = 0; - /* Flag==1 if octalSignificandBig is used */ + /* Flag==1 if octalSignificandBig is used. */ int numSigDigs = 0; /* Number of significant digits in the decimal - * significand */ + * significand. */ int numTrailZeros = 0; /* Number of trailing zeroes at the current * point in the parse. */ int numDigitsAfterDp = 0; /* Number of digits scanned after the decimal - * point */ + * point. */ int exponentSignum = 0; /* Signum of the exponent of a floating point - * number */ - long exponent = 0; /* Exponent of a floating point number */ - const char *p; /* Pointer to next character to scan */ - size_t len; /* Number of characters remaining after p */ + * number. */ + long exponent = 0; /* Exponent of a floating point number. */ + const char *p; /* Pointer to next character to scan. */ + size_t len; /* Number of characters remaining after p. */ const char *acceptPoint; /* Pointer to position after last character in - * an acceptable number */ + * an acceptable number. */ size_t acceptLen; /* Number of characters following that * point. */ - int status = TCL_OK; /* Status to return to caller */ + int status = TCL_OK; /* Status to return to caller. */ char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ @@ -592,9 +589,9 @@ TclParseNumber( case ZERO: /* * Scanned a leading zero (perhaps with a + or -). Acceptable - * inputs are digits, period, X, b, and E. If 8 or 9 is encountered, - * the number can't be octal. This state and the OCTAL state - * differ only in whether they recognize 'X' and 'b'. + * inputs are digits, period, X, b, and E. If 8 or 9 is + * encountered, the number can't be octal. This state and the + * OCTAL state differ only in whether they recognize 'X' and 'b'. */ acceptState = state; @@ -1150,9 +1147,9 @@ TclParseNumber( case sNA: case sNANPAREN: case sNANHEX: +#endif Tcl_Panic("TclParseNumber: bad acceptState %d parsing '%s'", acceptState, bytes); -#endif case BINARY: shift = numTrailZeros; if (!significandOverflow && significandWide != 0 && @@ -1193,7 +1190,7 @@ TclParseNumber( case OCTAL: /* - * Returning an octal integer. Final scaling step + * Returning an octal integer. Final scaling step. */ shift = 3 * numTrailZeros; @@ -1314,7 +1311,7 @@ TclParseNumber( * At this point exponent>=0, so the following calculation * cannot underflow. */ - exponent = - exponent; + exponent = -exponent; } /* @@ -1370,7 +1367,7 @@ TclParseNumber( break; #endif case INITIAL: - /* This case only to silence compiler warning */ + /* This case only to silence compiler warning. */ Tcl_Panic("TclParseNumber: state INITIAL can't happen here"); } } @@ -1442,7 +1439,7 @@ AccumulateDecimalDigit( Tcl_WideUInt w; /* - * Try wide multiplication first + * Try wide multiplication first. */ if (!bignumFlag) { @@ -1455,10 +1452,10 @@ AccumulateDecimalDigit( *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide - || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { + || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { /* - * Wide multiplication will overflow. Expand the - * number to a bignum and fall through into the bignum case. + * Wide multiplication will overflow. Expand the number to a + * bignum and fall through into the bignum case. */ TclBNInitBignumFromWideUInt(bignumRepPtr, w); @@ -1466,6 +1463,7 @@ AccumulateDecimalDigit( /* * Wide multiplication. */ + *wideRepPtr = w * pow10_wide[numZeros+1] + digit; return 0; } @@ -1537,8 +1535,8 @@ MakeLowPrecisionDouble( int numSigDigs, /* Number of digits in the significand */ long exponent) /* Power of ten */ { - double retval; /* Value of the number */ - mp_int significandBig; /* Significand expressed as a bignum */ + double retval; /* Value of the number. */ + mp_int significandBig; /* Significand expressed as a bignum. */ /* * With gcc on x86, the floating point rounding mode is double-extended. @@ -1574,10 +1572,12 @@ MakeLowPrecisionDouble( * without special handling. */ - retval = (double)(Tcl_WideInt)significand * pow10vals[exponent]; + retval = (double) + ((Tcl_WideInt)significand * pow10vals[exponent]); goto returnValue; } else { int diff = QUICK_MAX - numSigDigs; + if (exponent-diff <= mmaxpow) { /* * 10**exponent is not an exact integer, but @@ -1586,8 +1586,8 @@ MakeLowPrecisionDouble( * with only one roundoff. */ - volatile double factor = - (double)(Tcl_WideInt)significand * pow10vals[diff]; + volatile double factor = (double) + ((Tcl_WideInt)significand * pow10vals[diff]); retval = factor * pow10vals[exponent-diff]; goto returnValue; } @@ -1600,7 +1600,8 @@ MakeLowPrecisionDouble( * only one rounding. */ - retval = (double)(Tcl_WideInt)significand / pow10vals[-exponent]; + retval = (double) + ((Tcl_WideInt)significand / pow10vals[-exponent]); goto returnValue; } } @@ -1665,7 +1666,7 @@ MakeHighPrecisionDouble( long exponent) /* Power of 10 by which to multiply */ { double retval; - int machexp; /* Machine exponent of a power of 10 */ + int machexp; /* Machine exponent of a power of 10. */ /* * With gcc on x86, the floating point rounding mode is double-extended. @@ -1717,9 +1718,9 @@ MakeHighPrecisionDouble( goto returnValue; } retval = SafeLdExp(retval, machexp); - if (tiny == 0.0) { - tiny = SafeLdExp(1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits); - } + if (tiny == 0.0) { + tiny = SafeLdExp(1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits); + } if (retval < tiny) { retval = tiny; } @@ -1769,8 +1770,8 @@ MakeHighPrecisionDouble( #ifdef IEEE_FLOATING_POINT static double MakeNaN( - int signum, /* Sign bit (1=negative, 0=nonnegative */ - Tcl_WideUInt tags) /* Tag bits to put in the NaN */ + int signum, /* Sign bit (1=negative, 0=nonnegative. */ + Tcl_WideUInt tags) /* Tag bits to put in the NaN. */ { union { Tcl_WideUInt iv; @@ -1808,28 +1809,28 @@ MakeNaN( static double RefineApproximation( - double approxResult, /* Approximate result of conversion */ - mp_int *exactSignificand, /* Integer significand */ - int exponent) /* Power of 10 to multiply by significand */ + double approxResult, /* Approximate result of conversion. */ + mp_int *exactSignificand, /* Integer significand. */ + int exponent) /* Power of 10 to multiply by significand. */ { int M2, M5; /* Powers of 2 and of 5 needed to put the * decimal and binary numbers over a common * denominator. */ - double significand; /* Sigificand of the binary number */ - int binExponent; /* Exponent of the binary number */ + double significand; /* Sigificand of the binary number. */ + int binExponent; /* Exponent of the binary number. */ int msb; /* Most significant bit position of an - * intermediate result */ + * intermediate result. */ int nDigits; /* Number of mp_digit's in an intermediate - * result */ + * result. */ mp_int twoMv; /* Approx binary value expressed as an exact - * integer scaled by the multiplier 2M */ + * integer scaled by the multiplier 2M. */ mp_int twoMd; /* Exact decimal value expressed as an exact - * integer scaled by the multiplier 2M */ - int scale; /* Scale factor for M */ - int multiplier; /* Power of two to scale M */ + * integer scaled by the multiplier 2M. */ + int scale; /* Scale factor for M. */ + int multiplier; /* Power of two to scale M. */ double num, den; /* Numerator and denominator of the correction - * term */ - double quot; /* Correction term */ + * term. */ + double quot; /* Correction term. */ double minincr; /* Lower bound on the absolute value of the * correction term. */ int roundToEven = 0; /* Flag == TRUE if we need to invoke @@ -1877,8 +1878,8 @@ RefineApproximation( M5 = 0; } else { M5 = -exponent; - if ((M5-1) > M2) { - M2 = M5-1; + if (M5 - 1 > M2) { + M2 = M5 - 1; } } @@ -1913,7 +1914,7 @@ RefineApproximation( mp_init_copy(&twoMd, exactSignificand); for (i=0; i<=8; ++i) { - if ((M5+exponent) & (1 << i)) { + if ((M5 + exponent) & (1 << i)) { mp_mul(&twoMd, pow5+i, &twoMd); } } @@ -1957,8 +1958,8 @@ RefineApproximation( /* * If the error is less than 1/2 ULP, there's no correction to make. */ - mp_clear(&twoMd); - mp_clear(&twoMv); + mp_clear(&twoMd); + mp_clear(&twoMv); return approxResult; case MP_EQ: /* @@ -1981,8 +1982,8 @@ RefineApproximation( rteSignificand = frexp(approxResult, &rteExponent); rteSigWide = (Tcl_WideInt) ldexp(rteSignificand, FP_PRECISION); if ((rteSigWide & 1) == 0) { - mp_clear(&twoMd); - mp_clear(&twoMv); + mp_clear(&twoMd); + mp_clear(&twoMv); return approxResult; } } @@ -2021,26 +2022,28 @@ RefineApproximation( } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * MultPow5 -- * * Multiply a bignum by a power of 5. * * Side effects: - * Stores base*5**n in result + * Stores base*5**n in result. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static void -MulPow5(mp_int* base, /* Number to multiply */ - unsigned n, /* Power of 5 to multiply by */ - mp_int* result) /* Place to store the result */ +static inline void +MulPow5( + mp_int *base, /* Number to multiply. */ + unsigned n, /* Power of 5 to multiply by. */ + mp_int *result) /* Place to store the result. */ { - mp_int* p = base; + mp_int *p = base; int n13 = n / 13; int r = n % 13; + if (r != 0) { mp_mul_d(p, dpow5[r], result); p = result; @@ -2058,14 +2061,14 @@ MulPow5(mp_int* base, /* Number to multiply */ mp_copy(p, result); } } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * NormalizeRightward -- * - * Shifts a number rightward until it is odd (that is, until the - * least significant bit is nonzero. + * Shifts a number rightward until it is odd (that is, until the least + * significant bit is nonzero. * * Results: * Returns the number of bit positions by which the number was shifted. @@ -2073,15 +2076,16 @@ MulPow5(mp_int* base, /* Number to multiply */ * Side effects: * Shifts the number in place; *wPtr is replaced by the shifted number. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static int -NormalizeRightward(Tcl_WideUInt* wPtr) - /* INOUT: Number to shift */ +static inline int +NormalizeRightward( + Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */ { int rv = 0; Tcl_WideUInt w = *wPtr; + if (!(w & (Tcl_WideUInt) 0xffffffff)) { w >>= 32; rv += 32; } @@ -2103,27 +2107,28 @@ NormalizeRightward(Tcl_WideUInt* wPtr) *wPtr = w; return rv; } - + /* - *-----------------------------------------------------------------------------0 + *---------------------------------------------------------------------- * * RequiredPrecision -- * * Determines the number of bits needed to hold an intger. * * Results: - * Returns the position of the most significant bit (0 - 63). - * Returns 0 if the number is zero. + * Returns the position of the most significant bit (0 - 63). Returns 0 + * if the number is zero. * - *---------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ static int -RequiredPrecision(Tcl_WideUInt w) - /* Number to interrogate */ +RequiredPrecision( + Tcl_WideUInt w) /* Number to interrogate. */ { int rv; unsigned long wi; + if (w & ((Tcl_WideUInt) 0xffffffff << 32)) { wi = (unsigned long) (w >> 32); rv = 32; } else { @@ -2149,38 +2154,40 @@ RequiredPrecision(Tcl_WideUInt w) } return rv; } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * DoubleToExpAndSig -- * * Separates a 'double' into exponent and significand. * * Side effects: - * Stores the significand in '*significand' and the exponent in - * '*expon' so that dv == significand * 2.0**expon, and significand - * is odd. Also stores the position of the leftmost 1-bit in 'significand' - * in 'bits'. + * Stores the significand in '*significand' and the exponent in '*expon' + * so that dv == significand * 2.0**expon, and significand is odd. Also + * stores the position of the leftmost 1-bit in 'significand' in 'bits'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static void -DoubleToExpAndSig(double dv, /* Number to convert */ - Tcl_WideUInt* significand, - /* OUTPUT: Significand of the number */ - int* expon, /* OUTPUT: Exponent to multiply the number by */ - int* bits) /* OUTPUT: Number of significant bits */ +static inline void +DoubleToExpAndSig( + double dv, /* Number to convert. */ + Tcl_WideUInt *significand, /* OUTPUT: Significand of the number. */ + int *expon, /* OUTPUT: Exponent to multiply the number + * by. */ + int *bits) /* OUTPUT: Number of significant bits. */ { - Double d; /* Number being converted */ - Tcl_WideUInt z; /* Significand under construction */ - int de; /* Exponent of the number */ - int k; /* Bit count */ + Double d; /* Number being converted. */ + Tcl_WideUInt z; /* Significand under construction. */ + int de; /* Exponent of the number. */ + int k; /* Bit count. */ d.d = dv; - /* Extract exponent and significand */ + /* + * Extract exponent and significand. + */ de = (d.w.word0 & EXP_MASK) >> EXP_SHIFT; z = d.q & SIG_MASK; @@ -2196,24 +2203,25 @@ DoubleToExpAndSig(double dv, /* Number to convert */ } *significand = z; } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TakeAbsoluteValue -- * * Takes the absolute value of a 'double' including 0, Inf and NaN * * Side effects: - * The 'double' in *d is replaced with its absolute value. The - * signum is stored in 'sign': 1 for negative, 0 for nonnegative. + * The 'double' in *d is replaced with its absolute value. The signum is + * stored in 'sign': 1 for negative, 0 for nonnegative. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static void -TakeAbsoluteValue(Double* d, /* Number to replace with absolute value */ - int* sign) /* Place to put the signum */ +static inline void +TakeAbsoluteValue( + Double *d, /* Number to replace with absolute value. */ + int *sign) /* Place to put the signum. */ { if (d->w.word0 & SIGN_BIT) { *sign = 1; @@ -2222,32 +2230,33 @@ TakeAbsoluteValue(Double* d, /* Number to replace with absolute value */ *sign = 0; } } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * FormatInfAndNaN -- * * Bailout for formatting infinities and Not-A-Number. * * Results: - * Returns one of the strings 'Infinity' and 'NaN'. + * Returns one of the strings 'Infinity' and 'NaN'. The string returned + * must be freed by the caller using 'ckfree'. * * Side effects: - * Stores 9999 in *decpt, and sets '*endPtr' to designate the - * terminating NUL byte of the string if 'endPtr' is not NULL. - * - * The string returned must be freed by the caller using 'ckfree'. + * Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating + * NUL byte of the string if 'endPtr' is not NULL. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -FormatInfAndNaN(Double* d, /* Exceptional number to format */ - int* decpt, /* Decimal point to set to a bogus value */ - char** endPtr) /* Pointer to the end of the formatted data */ +static inline char * +FormatInfAndNaN( + Double *d, /* Exceptional number to format. */ + int *decpt, /* Decimal point to set to a bogus value. */ + char **endPtr) /* Pointer to the end of the formatted data */ { - char* retval; + char *retval; + *decpt = 9999; if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { retval = ckalloc(9); @@ -2264,9 +2273,9 @@ FormatInfAndNaN(Double* d, /* Exceptional number to format */ } return retval; } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * FormatZero -- * @@ -2279,14 +2288,16 @@ FormatInfAndNaN(Double* d, /* Exceptional number to format */ * Stores 1 in '*decpt' and puts a pointer to the NUL byte terminating * the string in '*endPtr' if 'endPtr' is not NULL. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -FormatZero(int* decpt, /* Location of the decimal point */ - char** endPtr) /* Pointer to the end of the formatted data */ +static inline char * +FormatZero( + int *decpt, /* Location of the decimal point. */ + char **endPtr) /* Pointer to the end of the formatted data */ { - char* retval = ckalloc(2); + char *retval = ckalloc(2); + strcpy(retval, "0"); if (endPtr) { *endPtr = retval+1; @@ -2294,31 +2305,31 @@ FormatZero(int* decpt, /* Location of the decimal point */ *decpt = 0; return retval; } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ApproximateLog10 -- * - * Computes a two-term Taylor series approximation to the common - * log of a number, and computes the number's binary log. + * Computes a two-term Taylor series approximation to the common log of a + * number, and computes the number's binary log. * * Results: - * Return an approximation to floor(log10(bw*2**be)) that is either - * exact or 1 too high. + * Return an approximation to floor(log10(bw*2**be)) that is either exact + * or 1 too high. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static int -ApproximateLog10(Tcl_WideUInt bw, - /* Integer significand of the number */ - int be, /* Power of two to scale bw */ - int bbits) /* Number of bits of precision in bw */ +static inline int +ApproximateLog10( + Tcl_WideUInt bw, /* Integer significand of the number. */ + int be, /* Power of two to scale bw. */ + int bbits) /* Number of bits of precision in bw. */ { - int i; /* Log base 2 of the number */ + int i; /* Log base 2 of the number. */ int k; /* Floor(Log base 10 of the number) */ - double ds; /* Mantissa of the number */ + double ds; /* Mantissa of the number. */ Double d2; /* @@ -2332,17 +2343,16 @@ ApproximateLog10(Tcl_WideUInt bw, d2.w.word0 |= (EXPONENT_BIAS) << EXP_SHIFT; i = be + bbits - 1; ds = (d2.d - 1.5) * TWO_OVER_3LOG10 - + LOG10_3HALVES_PLUS_FUDGE - + LOG10_2 * i; + + LOG10_3HALVES_PLUS_FUDGE + LOG10_2 * i; k = (int) ds; if (k > ds) { --k; } return k; } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * BetterLog10 -- * @@ -2350,24 +2360,27 @@ ApproximateLog10(Tcl_WideUInt bw, * 1 .. 10**(TEN_PMAX)-1 * * Side effects: - * Sets k_check to 0 if the new result is known to be exact, and to - * 1 if it may still be one too high. + * Sets k_check to 0 if the new result is known to be exact, and to 1 if + * it may still be one too high. * * Results: - * Returns the improved approximation to log10(d) + * Returns the improved approximation to log10(d). * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static int -BetterLog10(double d, /* Original number to format */ - int k, /* Characteristic(Log base 10) of the number */ - int* k_check) /* Flag == 1 if k is inexact */ +static inline int +BetterLog10( + double d, /* Original number to format. */ + int k, /* Characteristic(Log base 10) of the + * number. */ + int *k_check) /* Flag == 1 if k is inexact. */ { /* - * Performance hack. If k is in the range 0..TEN_PMAX, then we can - * use a powers-of-ten table to check it. + * Performance hack. If k is in the range 0..TEN_PMAX, then we can use a + * powers-of-ten table to check it. */ + if (k >= 0 && k <= TEN_PMAX) { if (d < tens[k]) { k--; @@ -2378,40 +2391,41 @@ BetterLog10(double d, /* Original number to format */ } return k; } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ComputeScale -- * * Prepares to format a floating-point number as decimal. * * Parameters: - * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i. - * The significand of x requires bbits bits to represent. + * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i. The + * significand of x requires bbits bits to represent. * * Results: * Determines integers b2, b5, s2, s5 so that sig*2**b2*5**b5/2**s2*2**s5 - * exactly represents the value of the x/10**k. This value will lie - * in the range [1 .. 10), and allows for computing successive digits - * by multiplying sig%10 by 10. + * exactly represents the value of the x/10**k. This value will lie in + * the range [1 .. 10), and allows for computing successive digits by + * multiplying sig%10 by 10. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static void -ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */ - int k, /* Characteristic of log10(number) */ - int* b2, /* OUTPUT: Power of 2 in the numerator */ - int* b5, /* OUTPUT: Power of 5 in the numerator */ - int* s2, /* OUTPUT: Power of 2 in the denominator */ - int* s5) /* OUTPUT: Power of 5 in the denominator */ +static inline void +ComputeScale( + int be, /* Exponent part of number: d = bw * 2**be. */ + int k, /* Characteristic of log10(number). */ + int *b2, /* OUTPUT: Power of 2 in the numerator. */ + int *b5, /* OUTPUT: Power of 5 in the numerator. */ + int *s2, /* OUTPUT: Power of 2 in the denominator. */ + int *s5) /* OUTPUT: Power of 5 in the denominator. */ { - /* - * Scale numerator and denominator powers of 2 so that the - * input binary number is the ratio of integers + * Scale numerator and denominator powers of 2 so that the input binary + * number is the ratio of integers. */ + if (be <= 0) { *b2 = 0; *s2 = -be; @@ -2421,9 +2435,10 @@ ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */ } /* - * Scale numerator and denominator so that the output decimal number - * is the ratio of integers + * Scale numerator and denominator so that the output decimal number is + * the ratio of integers. */ + if (k >= 0) { *b5 = 0; *s5 = k; @@ -2436,49 +2451,45 @@ ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * SetPrecisionLimits -- * - * Determines how many digits of significance should be computed - * (and, hence, how much memory need be allocated) for formatting a - * floating point number. + * Determines how many digits of significance should be computed (and, + * hence, how much memory need be allocated) for formatting a floating + * point number. * * Given that 'k' is floor(log10(x)): - * if 'shortest' format is used, there will be at most 18 digits in the result. + * if 'shortest' format is used, there will be at most 18 digits in the + * result. * if 'F' format is used, there will be at most 'ndigits' + k + 1 digits * if 'E' format is used, there will be exactly 'ndigits' digits. * * Side effects: - * Adjusts '*ndigitsPtr' to have a valid value. - * Stores the maximum memory allocation needed in *iPtr. - * Sets '*iLimPtr' to the limiting number of digits to convert if k - * has been guessed correctly, and '*iLim1Ptr' to the limiting number - * of digits to convert if k has been guessed to be one too high. + * Adjusts '*ndigitsPtr' to have a valid value. Stores the maximum memory + * allocation needed in *iPtr. Sets '*iLimPtr' to the limiting number of + * digits to convert if k has been guessed correctly, and '*iLim1Ptr' to + * the limiting number of digits to convert if k has been guessed to be + * one too high. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static void -SetPrecisionLimits(int convType, - /* Type of conversion: - * TCL_DD_SHORTEST - * TCL_DD_STEELE0 - * TCL_DD_E_FMT - * TCL_DD_F_FMT */ - int k, /* Floor(log10(number to convert)) */ - int* ndigitsPtr, - /* IN/OUT: Number of digits requested - * (Will be adjusted if needed) */ - int* iPtr, /* OUT: Maximum number of digits - * to return */ - int *iLimPtr,/* OUT: Number of digits of significance - * if the bignum method is used.*/ - int *iLim1Ptr) - /* OUT: Number of digits of significance - * if the quick method is used. */ +static inline void +SetPrecisionLimits( + int convType, /* Type of conversion: TCL_DD_SHORTEST, + * TCL_DD_STEELE0, TCL_DD_E_FMT, + * TCL_DD_F_FMT. */ + int k, /* Floor(log10(number to convert)) */ + int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be + * adjusted if needed). */ + int *iPtr, /* OUT: Maximum number of digits to return. */ + int *iLimPtr, /* OUT: Number of digits of significance if + * the bignum method is used.*/ + int *iLim1Ptr) /* OUT: Number of digits of significance if + * the quick method is used. */ { - switch(convType) { + switch (convType) { case TCL_DD_SHORTEST0: case TCL_DD_STEELE0: *iLimPtr = *iLim1Ptr = -1; @@ -2506,31 +2517,31 @@ SetPrecisionLimits(int convType, Tcl_Panic("impossible conversion type in TclDoubleDigits"); } } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * BumpUp -- * - * Increases a string of digits ending in a series of nines to - * designate the next higher number. xxxxb9999... -> xxxx(b+1)0000... + * Increases a string of digits ending in a series of nines to designate + * the next higher number. xxxxb9999... -> xxxx(b+1)0000... * * Results: * Returns a pointer to the end of the adjusted string. * * Side effects: - * In the case that the string consists solely of '999999', sets it - * to "1" and moves the decimal point (*kPtr) one place to the right. + * In the case that the string consists solely of '999999', sets it to + * "1" and moves the decimal point (*kPtr) one place to the right. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ - -inline static char* -BumpUp(char* s, /* Cursor pointing one past the end of the - * string */ - char* retval, /* Start of the string of digits */ - int* kPtr) /* Position of the decimal point */ +static inline char * +BumpUp( + char *s, /* Cursor pointing one past the end of the + * string. */ + char *retval, /* Start of the string of digits. */ + int *kPtr) /* Position of the decimal point. */ { while (*--s == '9') { if (s == retval) { @@ -2545,27 +2556,28 @@ BumpUp(char* s, /* Cursor pointing one past the end of the } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * AdjustRange -- * - * Rescales a 'double' in preparation for formatting it using the - * 'quick' double-to-string method. + * Rescales a 'double' in preparation for formatting it using the 'quick' + * double-to-string method. * * Results: - * Returns the precision that has been lost in the prescaling as - * a count of units in the least significant place. + * Returns the precision that has been lost in the prescaling as a count + * of units in the least significant place. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static int -AdjustRange(double* dPtr, /* INOUT: Number to adjust */ - int k) /* IN: floor(log10(d)) */ +static inline int +AdjustRange( + double *dPtr, /* INOUT: Number to adjust. */ + int k) /* IN: floor(log10(d)) */ { int ieps; /* Number of roundoff errors that have - * accumulated */ - double d = *dPtr; /* Number to adjust */ + * accumulated. */ + double d = *dPtr; /* Number to adjust. */ double ds; int i, j, j1; @@ -2575,6 +2587,7 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */ /* * The number must be reduced to bring it into range. */ + ds = tens[k & 0xf]; j = k >> 4; if (j & BLETCH) { @@ -2593,8 +2606,9 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */ d /= ds; } else if ((j1 = -k) != 0) { /* - * The number must be increased to bring it into range + * The number must be increased to bring it into range. */ + d *= tens[j1 & 0xf]; i = 0; for (j = j1>>4; j; j>>=1) { @@ -2611,52 +2625,52 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShorteningQuickFormat -- * - * Returns a 'quick' format of a double precision number to a string - * of digits, preferring a shorter string of digits if the shorter - * string is still within 1/2 ulp of the number. + * Returns a 'quick' format of a double precision number to a string of + * digits, preferring a shorter string of digits if the shorter string is + * still within 1/2 ulp of the number. * * Results: - * Returns the string of digits. Returns NULL if the 'quick' method - * fails and the bignum method must be used. + * Returns the string of digits. Returns NULL if the 'quick' method fails + * and the bignum method must be used. * * Side effects: * Stores the position of the decimal point at '*kPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -ShorteningQuickFormat(double d, /* Number to convert */ - int k, /* floor(log10(d)) */ - int ilim, /* Number of significant digits to return */ - double eps, - /* Estimated roundoff error */ - char* retval, - /* Buffer to receive the digit string */ - int* kPtr) - /* Pointer to stash the position of - * the decimal point */ +static inline char * +ShorteningQuickFormat( + double d, /* Number to convert. */ + int k, /* floor(log10(d)) */ + int ilim, /* Number of significant digits to return. */ + double eps, /* Estimated roundoff error. */ + char *retval, /* Buffer to receive the digit string. */ + int *kPtr) /* Pointer to stash the position of the + * decimal point. */ { - char* s = retval; /* Cursor in the return value */ - int digit; /* Current digit */ + char *s = retval; /* Cursor in the return value. */ + int digit; /* Current digit. */ int i; eps = 0.5 / tens[ilim-1] - eps; i = 0; for (;;) { - /* Convert a digit */ + /* + * Convert a digit. + */ digit = (int) d; d -= digit; *s++ = '0' + digit; /* - * Truncate the conversion if the string of digits is within - * 1/2 ulp of the actual value. + * Truncate the conversion if the string of digits is within 1/2 ulp + * of the actual value. */ if (d < eps) { @@ -2670,7 +2684,7 @@ ShorteningQuickFormat(double d, /* Number to convert */ /* * Bail out if the conversion fails to converge to a sufficiently - * precise value + * precise value. */ if (++i >= ilim) { @@ -2687,40 +2701,44 @@ ShorteningQuickFormat(double d, /* Number to convert */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * StrictQuickFormat -- * - * Convert a double precision number of a string of a precise number - * of digits, using the 'quick' double precision method. + * Convert a double precision number of a string of a precise number of + * digits, using the 'quick' double precision method. * * Results: - * Returns the digit string, or NULL if the bignum method must be - * used to do the formatting. + * Returns the digit string, or NULL if the bignum method must be used to + * do the formatting. * * Side effects: * Stores the position of the decimal point in '*kPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -StrictQuickFormat(double d, /* Number to convert */ - int k, /* floor(log10(d)) */ - int ilim, /* Number of significant digits to return */ - double eps, /* Estimated roundoff error */ - char* retval, /* Start of the digit string */ - int* kPtr) /* Pointer to stash the position of - * the decimal point */ +static inline char * +StrictQuickFormat( + double d, /* Number to convert. */ + int k, /* floor(log10(d)) */ + int ilim, /* Number of significant digits to return. */ + double eps, /* Estimated roundoff error. */ + char *retval, /* Start of the digit string. */ + int *kPtr) /* Pointer to stash the position of the + * decimal point. */ { - char* s = retval; /* Cursor in the return value */ - int digit; /* Current digit of the answer */ + char *s = retval; /* Cursor in the return value. */ + int digit; /* Current digit of the answer. */ int i; eps *= tens[ilim-1]; i = 1; for (;;) { - /* Extract a digit */ + /* + * Extract a digit. + */ + digit = (int) d; d -= digit; if (d == 0.0) { @@ -2729,9 +2747,10 @@ StrictQuickFormat(double d, /* Number to convert */ *s++ = '0' + digit; /* - * When the given digit count is reached, handle trailing strings - * of 0 and 9. + * When the given digit count is reached, handle trailing strings of 0 + * and 9. */ + if (i == ilim) { if (d > 0.5 + eps) { *kPtr = k; @@ -2748,14 +2767,17 @@ StrictQuickFormat(double d, /* Number to convert */ } } - /* Advance to the next digit */ + /* + * Advance to the next digit. + */ + ++i; d *= 10.0; } } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * QuickConversion -- * @@ -2764,44 +2786,48 @@ StrictQuickFormat(double d, /* Number to convert */ * therefore be used for the intermediate results. * * Results: - * Returns the converted string, or NULL if the bignum method must - * be used. + * Returns the converted string, or NULL if the bignum method must be + * used. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -QuickConversion(double e, /* Number to format */ - int k, /* floor(log10(d)), approximately */ - int k_check, /* 0 if k is exact, 1 if it may be too high */ - int flags, /* Flags passed to dtoa: +static inline char * +QuickConversion( + double e, /* Number to format. */ + int k, /* floor(log10(d)), approximately. */ + int k_check, /* 0 if k is exact, 1 if it may be too high */ + int flags, /* Flags passed to dtoa: * TCL_DD_SHORTEN_FLAG */ - int len, /* Length of the return value */ - int ilim, /* Number of digits to store */ - int ilim1, /* Number of digits to store if we - * musguessed k */ - int* decpt, /* OUTPUT: Location of the decimal point */ - char** endPtr) /* OUTPUT: Pointer to the terminal null byte */ + int len, /* Length of the return value. */ + int ilim, /* Number of digits to store. */ + int ilim1, /* Number of digits to store if we misguessed + * k. */ + int *decpt, /* OUTPUT: Location of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the terminal null + * byte. */ { int ieps; /* Number of 1-ulp roundoff errors that have - * accumulated in the calculation*/ - Double eps; /* Estimated roundoff error */ - char* retval; /* Returned string */ - char* end; /* Pointer to the terminal null byte in the - * returned string */ + * accumulated in the calculation. */ + Double eps; /* Estimated roundoff error. */ + char *retval; /* Returned string. */ + char *end; /* Pointer to the terminal null byte in the + * returned string. */ volatile double d; /* Workaround for a bug in mingw gcc 3.4.5 */ /* - * Bring d into the range [1 .. 10) + * Bring d into the range [1 .. 10). */ + ieps = AdjustRange(&e, k); d = e; /* - * If the guessed value of k didn't get d into range, adjust it - * by one. If that leaves us outside the range in which quick format - * is accurate, bail out. + * If the guessed value of k didn't get d into range, adjust it by one. If + * that leaves us outside the range in which quick format is accurate, + * bail out. */ + if (k_check && d < 1. && ilim > 0) { if (ilim1 < 0) { return NULL; @@ -2813,15 +2839,16 @@ QuickConversion(double e, /* Number to format */ } /* - * Compute estimated roundoff error + * Compute estimated roundoff error. */ + eps.d = ieps * d + 7.; eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT; /* - * Handle the peculiar case where the result has no significant - * digits. + * Handle the peculiar case where the result has no significant digits. */ + retval = ckalloc(len + 1); if (ilim == 0) { d -= 5.; @@ -2838,7 +2865,9 @@ QuickConversion(double e, /* Number to format */ } } - /* Format the digit string */ + /* + * Format the digit string. + */ if (flags & TCL_DD_SHORTEN_FLAG) { end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt); @@ -2857,106 +2886,99 @@ QuickConversion(double e, /* Number to format */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * CastOutPowersOf2 -- * - * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers - * of 2 from numerator and denominator in preparation for the 'bignum' - * method of floating point conversion. + * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers of 2 + * from numerator and denominator in preparation for the 'bignum' method + * of floating point conversion. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static void -CastOutPowersOf2(int* b2, /* Power of 2 to multiply the significand */ - int* m2, /* Power of 2 to multiply 1/2 ulp */ - int* s2) /* Power of 2 to multiply the common - * denominator */ +static inline void +CastOutPowersOf2( + int *b2, /* Power of 2 to multiply the significand. */ + int *m2, /* Power of 2 to multiply 1/2 ulp. */ + int *s2) /* Power of 2 to multiply the common + * denominator. */ { int i; + if (*m2 > 0 && *s2 > 0) { /* Find the smallest power of 2 in the - * numerator */ - if (*m2 < *s2) { /* Find the lowest common denominatorr */ + * numerator. */ + if (*m2 < *s2) { /* Find the lowest common denominator. */ i = *m2; } else { i = *s2; } - *b2 -= i; /* Reduce to lowest terms */ + *b2 -= i; /* Reduce to lowest terms. */ *m2 -= i; *s2 -= i; } } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShorteningInt64Conversion -- * - * Converts a double-precision number to the shortest string of - * digits that reconverts exactly to the given number, or to - * 'ilim' digits if that will yield a shorter result. The numerator and - * denominator in David Gay's conversion algorithm are known to fit - * in Tcl_WideUInt, giving considerably faster arithmetic than mp_int's. + * Converts a double-precision number to the shortest string of digits + * that reconverts exactly to the given number, or to 'ilim' digits if + * that will yield a shorter result. The numerator and denominator in + * David Gay's conversion algorithm are known to fit in Tcl_WideUInt, + * giving considerably faster arithmetic than mp_int's. * * Results: - * Returns the string of significant decimal digits, in newly - * allocated memory + * Returns the string of significant decimal digits, in newly allocated + * memory * * Side effects: - * Stores the location of the decimal point in '*decpt' and the - * location of the terminal null byte in '*endPtr'. + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -ShorteningInt64Conversion(Double* dPtr, - /* Original number to convert */ - int convType, - /* Type of conversion (shortest, Steele, - E format, F format) */ - Tcl_WideUInt bw, - /* Integer significand */ - int b2, int b5, - /* Scale factor for the significand - * in the numerator */ - int m2plus, int m2minus, int m5, - /* Scale factors for 1/2 ulp in - * the numerator (will be different if - * bw == 1 */ - int s2, int s5, - /* Scale factors for the denominator */ - int k, - /* Number of output digits before the decimal - * point */ - int len, - /* Number of digits to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Position of the terminal '\0' - * at the end of the returned string */ +static inline char * +ShorteningInt64Conversion( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int m2plus, int m2minus, int m5, + /* Scale factors for 1/2 ulp in the numerator + * (will be different if bw == 1. */ + int s2, int s5, /* Scale factors for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ { - - char* retval = ckalloc(len + 1); - /* Output buffer */ + char *retval = ckalloc(len + 1); + /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; - /* Numerator of the fraction being converted */ + /* Numerator of the fraction being + * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; /* Denominator of the fraction being - * converted */ - Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result - * is within roundoff of being exact */ - int digit; /* Current output digit */ - char* s = retval; /* Cursor in the output buffer */ - int i; /* Current position in the output buffer */ + * converted. */ + Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result is + * within roundoff of being exact. */ + int digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Current position in the output buffer. */ - /* Adjust if the logarithm was guessed wrong */ + /* + * Adjust if the logarithm was guessed wrong. + */ if (b < S) { b = 10 * b; @@ -2965,12 +2987,16 @@ ShorteningInt64Conversion(Double* dPtr, --k; } - /* Compute roundoff ranges */ + /* + * Compute roundoff ranges. + */ mplus = wuipow5[m5] << m2plus; mminus = wuipow5[m5] << m2minus; - /* Loop through the digits */ + /* + * Loop through the digits. + */ i = 1; for (;;) { @@ -2984,17 +3010,15 @@ ShorteningInt64Conversion(Double* dPtr, * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ - if (b < mplus - || (b == mplus - && convType != TCL_DD_STEELE0 - && (dPtr->w.word1 & 1) == 0)) { + + if (b < mplus || (b == mplus + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* - * Make sure we shouldn't be rounding *up* instead, - * in case the next number above is closer + * Make sure we shouldn't be rounding *up* instead, in case the + * next number above is closer. */ - if (2 * b > S - || (2 * b == S - && (digit & 1) != 0)) { + + if (2 * b > S || (2 * b == S && (digit & 1) != 0)) { ++digit; if (digit == 10) { *s++ = '9'; @@ -3003,7 +3027,9 @@ ShorteningInt64Conversion(Double* dPtr, } } - /* Stash the current digit */ + /* + * Stash the current digit. + */ *s++ = '0' + digit; break; @@ -3013,10 +3039,9 @@ ShorteningInt64Conversion(Double* dPtr, * Does one plus the current digit put us within roundoff of the * number? */ - if (b > S - mminus - || (b == S - mminus - && convType != TCL_DD_STEELE0 - && (dPtr->w.word1 & 1) == 0)) { + + if (b > S - mminus || (b == S - mminus + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); @@ -3030,16 +3055,18 @@ ShorteningInt64Conversion(Double* dPtr, /* * Have we converted all the requested digits? */ + *s++ = '0' + digit; if (i == ilim) { - if (2*b > S - || (2*b == S && (digit & 1) != 0)) { + if (2*b > S || (2*b == S && (digit & 1) != 0)) { s = BumpUp(s, retval, &k); } break; } - /* Advance to the next digit */ + /* + * Advance to the next digit. + */ b = 10 * b; mplus = 10 * mplus; @@ -3051,6 +3078,7 @@ ShorteningInt64Conversion(Double* dPtr, * Endgame - store the location of the decimal point and the end of the * string. */ + *s = '\0'; *decpt = k; if (endPtr) { @@ -3060,69 +3088,61 @@ ShorteningInt64Conversion(Double* dPtr, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * StrictInt64Conversion -- * - * Converts a double-precision number to a fixed-length string of - * 'ilim' digits that reconverts exactly to the given number. - * ('ilim' should be replaced with 'ilim1' in the case where - * log10(d) has been overestimated). The numerator and - * denominator in David Gay's conversion algorithm are known to fit - * in Tcl_WideUInt, giving considerably faster arithmetic than mp_int's. + * Converts a double-precision number to a fixed-length string of 'ilim' + * digits that reconverts exactly to the given number. ('ilim' should be + * replaced with 'ilim1' in the case where log10(d) has been + * overestimated). The numerator and denominator in David Gay's + * conversion algorithm are known to fit in Tcl_WideUInt, giving + * considerably faster arithmetic than mp_int's. * * Results: - * Returns the string of significant decimal digits, in newly - * allocated memory + * Returns the string of significant decimal digits, in newly allocated + * memory * * Side effects: - * Stores the location of the decimal point in '*decpt' and the - * location of the terminal null byte in '*endPtr'. + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -StrictInt64Conversion(Double* dPtr, - /* Original number to convert */ - int convType, - /* Type of conversion (shortest, Steele, - E format, F format) */ - Tcl_WideUInt bw, - /* Integer significand */ - int b2, int b5, - /* Scale factor for the significand - * in the numerator */ - int s2, int s5, - /* Scale factors for the denominator */ - int k, - /* Number of output digits before the decimal - * point */ - int len, - /* Number of digits to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Position of the terminal '\0' - * at the end of the returned string */ +static inline char * +StrictInt64Conversion( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int s2, int s5, /* Scale factors for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ { - - char* retval = ckalloc(len + 1); - /* Output buffer */ + char *retval = ckalloc(len + 1); + /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; - /* Numerator of the fraction being converted */ + /* Numerator of the fraction being + * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; /* Denominator of the fraction being - * converted */ - int digit; /* Current output digit */ - char* s = retval; /* Cursor in the output buffer */ - int i; /* Current position in the output buffer */ + * converted. */ + int digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Current position in the output buffer. */ - /* Adjust if the logarithm was guessed wrong */ + /* + * Adjust if the logarithm was guessed wrong. + */ if (b < S) { b = 10 * b; @@ -3130,7 +3150,9 @@ StrictInt64Conversion(Double* dPtr, --k; } - /* Loop through the digits */ + /* + * Loop through the digits. + */ i = 1; for (;;) { @@ -3143,10 +3165,10 @@ StrictInt64Conversion(Double* dPtr, /* * Have we converted all the requested digits? */ + *s++ = '0' + digit; if (i == ilim) { - if (2*b > S - || (2*b == S && (digit & 1) != 0)) { + if (2*b > S || (2*b == S && (digit & 1) != 0)) { s = BumpUp(s, retval, &k); } else { while (*--s == '0') { @@ -3157,7 +3179,9 @@ StrictInt64Conversion(Double* dPtr, break; } - /* Advance to the next digit */ + /* + * Advance to the next digit. + */ b = 10 * b; ++i; @@ -3167,6 +3191,7 @@ StrictInt64Conversion(Double* dPtr, * Endgame - store the location of the decimal point and the end of the * string. */ + *s = '\0'; *decpt = k; if (endPtr) { @@ -3176,30 +3201,30 @@ StrictInt64Conversion(Double* dPtr, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShouldBankerRoundUpPowD -- * - * Test whether bankers' rounding should round a digit up. Assumption - * is made that the denominator of the fraction being tested is - * a power of 2**MP_DIGIT_BIT. + * Test whether bankers' rounding should round a digit up. Assumption is + * made that the denominator of the fraction being tested is a power of + * 2**MP_DIGIT_BIT. * * Results: - * Returns 1 iff the fraction is more than 1/2, or if the fraction - * is exactly 1/2 and the digit is odd. + * Returns 1 iff the fraction is more than 1/2, or if the fraction is + * exactly 1/2 and the digit is odd. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static int -ShouldBankerRoundUpPowD(mp_int* b, - /* Numerator of the fraction */ - int sd, /* Denominator is 2**(sd*MP_DIGIT_BIT) */ - int isodd) - /* 1 if the digit is odd, 0 if even */ +static inline int +ShouldBankerRoundUpPowD( + mp_int *b, /* Numerator of the fraction. */ + int sd, /* Denominator is 2**(sd*MP_DIGIT_BIT). */ + int isodd) /* 1 if the digit is odd, 0 if even. */ { int i; - static const mp_digit topbit = (1<<(MP_DIGIT_BIT-1)); + static const mp_digit topbit = ((mp_digit)1) << (MP_DIGIT_BIT - 1); + if (b->used < sd || (b->dp[sd-1] & topbit) == 0) { return 0; } @@ -3219,41 +3244,37 @@ ShouldBankerRoundUpPowD(mp_int* b, * * ShouldBankerRoundUpToNextPowD -- * - * Tests whether bankers' rounding will round down in the - * "denominator is a power of 2**MP_DIGIT" case. + * Tests whether bankers' rounding will round down in the "denominator is + * a power of 2**MP_DIGIT" case. * * Results: * Returns 1 if the rounding will be performed - which increases the * digit by one - and 0 otherwise. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static int -ShouldBankerRoundUpToNextPowD(mp_int* b, - /* Numerator of the fraction */ - mp_int* m, - /* Numerator of the rounding tolerance */ - int sd, - /* Common denominator is 2**(sd*MP_DIGIT_BIT) */ - int convType, - /* Conversion type: STEELE defeats - * round-to-even (Not sure why one wants to - * do this; I copied it from Gay) FIXME */ - int isodd, - /* 1 if the integer significand is odd */ - mp_int* temp) - /* Work area for the calculation */ +static inline int +ShouldBankerRoundUpToNextPowD( + mp_int *b, /* Numerator of the fraction. */ + mp_int *m, /* Numerator of the rounding tolerance. */ + int sd, /* Common denominator is 2**(sd*MP_DIGIT_BIT). */ + int convType, /* Conversion type: STEELE defeats + * round-to-even (not sure why one wants to do + * this; I copied it from Gay). FIXME */ + int isodd, /* 1 if the integer significand is odd. */ + mp_int *temp) /* Work area for the calculation. */ { int i; /* - * Compare B and S-m -- which is the same as comparing B+m and S -- - * which we do by computing b+m and doing a bitwhack compare against + * Compare B and S-m - which is the same as comparing B+m and S - which we + * do by computing b+m and doing a bitwhack compare against * 2**(MP_DIGIT_BIT*sd) */ + mp_add(b, m, temp); - if (temp->used <= sd) { /* too few digits to be > S */ + if (temp->used <= sd) { /* Too few digits to be > s */ return 0; } if (temp->used > sd+1 || temp->dp[sd] > 1) { @@ -3261,81 +3282,70 @@ ShouldBankerRoundUpToNextPowD(mp_int* b, return 1; } for (i = sd-1; i >= 0; --i) { - /* check for ==s */ + /* Check for ==s */ if (temp->dp[i] != 0) { /* > s */ return 1; } } if (convType == TCL_DD_STEELE0) { - /* biased rounding */ + /* Biased rounding. */ return 0; } return isodd; } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShorteningBignumConversionPowD -- * - * Converts a double-precision number to the shortest string of - * digits that reconverts exactly to the given number, or to - * 'ilim' digits if that will yield a shorter result. The denominator - * in David Gay's conversion algorithm is known to be a power of - * 2**MP_DIGIT_BIT, and hence the division in the main loop may be replaced - * by a digit shift and mask. + * Converts a double-precision number to the shortest string of digits + * that reconverts exactly to the given number, or to 'ilim' digits if + * that will yield a shorter result. The denominator in David Gay's + * conversion algorithm is known to be a power of 2**MP_DIGIT_BIT, and hence + * the division in the main loop may be replaced by a digit shift and + * mask. * * Results: - * Returns the string of significant decimal digits, in newly - * allocated memory + * Returns the string of significant decimal digits, in newly allocated + * memory * * Side effects: - * Stores the location of the decimal point in '*decpt' and the - * location of the terminal null byte in '*endPtr'. + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -ShorteningBignumConversionPowD(Double* dPtr, - /* Original number to convert */ - int convType, - /* Type of conversion (shortest, Steele, - E format, F format) */ - Tcl_WideUInt bw, - /* Integer significand */ - int b2, int b5, - /* Scale factor for the significand - * in the numerator */ - int m2plus, int m2minus, int m5, - /* Scale factors for 1/2 ulp in - * the numerator (will be different if - * bw == 1 */ - int sd, - /* Scale factor for the denominator */ - int k, - /* Number of output digits before the decimal - * point */ - int len, - /* Number of digits to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Position of the terminal '\0' - * at the end of the returned string */ +static inline char * +ShorteningBignumConversionPowD( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int m2plus, int m2minus, int m5, + /* Scale factors for 1/2 ulp in the numerator + * (will be different if bw == 1). */ + int sd, /* Scale factor for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ { - - char* retval = ckalloc(len + 1); - /* Output buffer */ - mp_int b; /* Numerator of the fraction being converted */ - mp_int mplus, mminus; /* Bounds for roundoff */ - mp_digit digit; /* Current output digit */ - char* s = retval; /* Cursor in the output buffer */ - int i; /* Index in the output buffer */ + char *retval = ckalloc(len + 1); + /* Output buffer. */ + mp_int b; /* Numerator of the fraction being + * converted. */ + mp_int mplus, mminus; /* Bounds for roundoff. */ + mp_digit digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Index in the output buffer. */ mp_int temp; int r1; @@ -3349,7 +3359,9 @@ ShorteningBignumConversionPowD(Double* dPtr, MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); - /* Adjust if the logarithm was guessed wrong */ + /* + * Adjust if the logarithm was guessed wrong. + */ if (b.used <= sd) { mp_mul_d(&b, 10, &b); @@ -3371,8 +3383,10 @@ ShorteningBignumConversionPowD(Double* dPtr, } mp_init(&temp); - /* Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT) - * by mp_digit extraction */ + /* + * Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT) + * by mp_digit extraction. + */ i = 0; for (;;) { @@ -3392,14 +3406,13 @@ ShorteningBignumConversionPowD(Double* dPtr, */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); - if (r1 == MP_LT - || (r1 == MP_EQ - && convType != TCL_DD_STEELE0 - && (dPtr->w.word1 & 1) == 0)) { + if (r1 == MP_LT || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* - * Make sure we shouldn't be rounding *up* instead, - * in case the next number above is closer + * Make sure we shouldn't be rounding *up* instead, in case the + * next number above is closer. */ + if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { ++digit; if (digit == 10) { @@ -3409,7 +3422,9 @@ ShorteningBignumConversionPowD(Double* dPtr, } } - /* Stash the last digit */ + /* + * Stash the last digit. + */ *s++ = '0' + digit; break; @@ -3420,9 +3435,8 @@ ShorteningBignumConversionPowD(Double* dPtr, * number? */ - if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, - convType, dPtr->w.word1 & 1, - &temp)) { + if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType, + dPtr->w.word1 & 1, &temp)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); @@ -3436,6 +3450,7 @@ ShorteningBignumConversionPowD(Double* dPtr, /* * Have we converted all the requested digits? */ + *s++ = '0' + digit; if (i == ilim) { if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { @@ -3444,7 +3459,9 @@ ShorteningBignumConversionPowD(Double* dPtr, break; } - /* Advance to the next digit */ + /* + * Advance to the next digit. + */ mp_mul_d(&b, 10, &b); mp_mul_d(&mminus, 10, &mminus); @@ -3458,6 +3475,7 @@ ShorteningBignumConversionPowD(Double* dPtr, * Endgame - store the location of the decimal point and the end of the * string. */ + if (m2plus > m2minus) { mp_clear(&mplus); } @@ -3471,62 +3489,52 @@ ShorteningBignumConversionPowD(Double* dPtr, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * StrictBignumConversionPowD -- * - * Converts a double-precision number to a fixed-lengt string of - * 'ilim' digits (or 'ilim1' if log10(d) has been overestimated.) - * The denominator in David Gay's conversion algorithm is known to - * be a power of 2**MP_DIGIT_BIT, and hence the division in the main - * loop may be replaced by a digit shift and mask. + * Converts a double-precision number to a fixed-lengt string of 'ilim' + * digits (or 'ilim1' if log10(d) has been overestimated). The + * denominator in David Gay's conversion algorithm is known to be a power + * of 2**MP_DIGIT_BIT, and hence the division in the main loop may be + * replaced by a digit shift and mask. * * Results: - * Returns the string of significant decimal digits, in newly - * allocated memory. + * Returns the string of significant decimal digits, in newly allocated + * memory. * * Side effects: - * Stores the location of the decimal point in '*decpt' and the - * location of the terminal null byte in '*endPtr'. + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -StrictBignumConversionPowD(Double* dPtr, - /* Original number to convert */ - int convType, - /* Type of conversion (shortest, Steele, - E format, F format) */ - Tcl_WideUInt bw, - /* Integer significand */ - int b2, int b5, - /* Scale factor for the significand - * in the numerator */ - int sd, - /* Scale factor for the denominator */ - int k, - /* Number of output digits before the decimal - * point */ - int len, - /* Number of digits to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Position of the terminal '\0' - * at the end of the returned string */ +static inline char * +StrictBignumConversionPowD( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int sd, /* Scale factor for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ { - - char* retval = ckalloc(len + 1); - /* Output buffer */ - mp_int b; /* Numerator of the fraction being converted */ - mp_digit digit; /* Current output digit */ - char* s = retval; /* Cursor in the output buffer */ - int i; /* Index in the output buffer */ + char *retval = ckalloc(len + 1); + /* Output buffer. */ + mp_int b; /* Numerator of the fraction being + * converted. */ + mp_digit digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Index in the output buffer. */ mp_int temp; /* @@ -3537,7 +3545,9 @@ StrictBignumConversionPowD(Double* dPtr, MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); - /* Adjust if the logarithm was guessed wrong */ + /* + * Adjust if the logarithm was guessed wrong. + */ if (b.used <= sd) { mp_mul_d(&b, 10, &b); @@ -3548,7 +3558,7 @@ StrictBignumConversionPowD(Double* dPtr, /* * Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT) - * by mp_digit extraction + * by mp_digit extraction. */ i = 1; @@ -3560,12 +3570,14 @@ StrictBignumConversionPowD(Double* dPtr, if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } - --b.used; mp_clamp(&b); + --b.used; + mp_clamp(&b); } /* * Have we converted all the requested digits? */ + *s++ = '0' + digit; if (i == ilim) { if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { @@ -3579,7 +3591,9 @@ StrictBignumConversionPowD(Double* dPtr, break; } - /* Advance to the next digit */ + /* + * Advance to the next digit. + */ mp_mul_d(&b, 10, &b); ++i; @@ -3589,6 +3603,7 @@ StrictBignumConversionPowD(Double* dPtr, * Endgame - store the location of the decimal point and the end of the * string. */ + mp_clear_multi(&b, &temp, NULL); *s = '\0'; *decpt = k; @@ -3599,7 +3614,7 @@ StrictBignumConversionPowD(Double* dPtr, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShouldBankerRoundUp -- * @@ -3609,17 +3624,18 @@ StrictBignumConversionPowD(Double* dPtr, * Results: * Returns 1 if the number needs to be rounded up, 0 otherwise. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static int -ShouldBankerRoundUp(mp_int* twor, - /* 2x the remainder from thd division that - * produced the last digit */ - mp_int* S, /* Denominator */ - int isodd) /* Flag == 1 if the last digit is odd */ +static inline int +ShouldBankerRoundUp( + mp_int *twor, /* 2x the remainder from thd division that + * produced the last digit. */ + mp_int *S, /* Denominator. */ + int isodd) /* Flag == 1 if the last digit is odd. */ { int r = mp_cmp_mag(twor, S); + switch (r) { case MP_LT: return 0; @@ -3633,38 +3649,37 @@ ShouldBankerRoundUp(mp_int* twor, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShouldBankerRoundUpToNext -- * - * Tests whether the remainder is great enough to force rounding - * to the next higher digit. + * Tests whether the remainder is great enough to force rounding to the + * next higher digit. * * Results: * Returns 1 if the number should be rounded up, 0 otherwise. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static int -ShouldBankerRoundUpToNext(mp_int* b, - /* Remainder from the division that produced +static inline int +ShouldBankerRoundUpToNext( + mp_int *b, /* Remainder from the division that produced * the last digit. */ - mp_int* m, - /* Numerator of the rounding tolerance */ - mp_int* S, - /* Denominator */ - int convType, - /* Conversion type: STEELE0 defeats - * round-to-even. (Not sure why one would - * want this; I coped it from Gay. FIXME */ - int isodd, - /* 1 if the integer significand is odd */ - mp_int* temp) - /* Work area needed for the calculation */ + mp_int *m, /* Numerator of the rounding tolerance. */ + mp_int *S, /* Denominator. */ + int convType, /* Conversion type: STEELE0 defeats + * round-to-even. (Not sure why one would want + * this; I coped it from Gay). FIXME */ + int isodd, /* 1 if the integer significand is odd. */ + mp_int *temp) /* Work area needed for the calculation. */ { int r; - /* Compare b and S-m: this is the same as comparing B+m and S. */ + + /* + * Compare b and S-m: this is the same as comparing B+m and S. + */ + mp_add(b, m, temp); r = mp_cmp_mag(temp, S); switch(r) { @@ -3684,7 +3699,7 @@ ShouldBankerRoundUpToNext(mp_int* b, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShorteningBignumConversion -- * @@ -3695,49 +3710,38 @@ ShouldBankerRoundUpToNext(mp_int* b, * Returns the string of digits. * * Side effects: - * Stores the position of the decimal point in *decpt. - * Stores a pointer to the end of the number in *endPtr. + * Stores the position of the decimal point in *decpt. Stores a pointer + * to the end of the number in *endPtr. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -ShorteningBignumConversion(Double* dPtr, - /* Original number being converted */ - int convType, - /* Conversion type */ - Tcl_WideUInt bw, - /* Integer significand and exponent */ - int b2, - /* Scale factor for the significand */ - int m2plus, int m2minus, - /* Scale factors for 1/2 ulp in numerator */ - int s2, int s5, - /* Scale factors for denominator */ - int k, - /* Guessed position of the decimal point */ - int len, - /* Size of the digit buffer to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Pointer to the end of the number */ +static inline char * +ShorteningBignumConversion( + Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ + Tcl_WideUInt bw, /* Integer significand and exponent. */ + int b2, /* Scale factor for the significand. */ + int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */ + int s2, int s5, /* Scale factors for denominator. */ + int k, /* Guessed position of the decimal point. */ + int len, /* Size of the digit buffer to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char* retval = ckalloc(len+1); - /* Buffer of digits to return */ - char* s = retval; /* Cursor in the return value */ - mp_int b; /* Numerator of the result */ - mp_int mminus; /* 1/2 ulp below the result */ - mp_int mplus; /* 1/2 ulp above the result */ - mp_int S; /* Denominator of the result */ - mp_int dig; /* Current digit of the result */ - int digit; /* Current digit of the result */ - mp_int temp; /* Work area */ - int minit = 1; /* Fudge factor for when we misguess k */ + char *retval = ckalloc(len+1); + /* Buffer of digits to return. */ + char *s = retval; /* Cursor in the return value. */ + mp_int b; /* Numerator of the result. */ + mp_int mminus; /* 1/2 ulp below the result. */ + mp_int mplus; /* 1/2 ulp above the result. */ + mp_int S; /* Denominator of the result. */ + mp_int dig; /* Current digit of the result. */ + int digit; /* Current digit of the result. */ + mp_int temp; /* Work area. */ + int minit = 1; /* Fudge factor for when we misguess k. */ int i; int r1; @@ -3752,8 +3756,7 @@ ShorteningBignumConversion(Double* dPtr, MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* - * Handle the case where we guess the position of the decimal point - * wrong. + * Handle the case where we guess the position of the decimal point wrong. */ if (mp_cmp_mag(&b, &S) == MP_LT) { @@ -3763,7 +3766,9 @@ ShorteningBignumConversion(Double* dPtr, --k; } - /* mminus = 2**m2minus * 5**m5 */ + /* + * mminus = 2**m2minus * 5**m5 + */ mp_init_set(&mminus, minit); mp_mul_2d(&mminus, m2minus, &mminus); @@ -3773,7 +3778,9 @@ ShorteningBignumConversion(Double* dPtr, } mp_init(&temp); - /* Loop through the digits */ + /* + * Loop through the digits. + */ mp_init(&dig); i = 1; @@ -3790,10 +3797,8 @@ ShorteningBignumConversion(Double* dPtr, */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); - if (r1 == MP_LT - || (r1 == MP_EQ - && convType != TCL_DD_STEELE0 - && (dPtr->w.word1 & 1) == 0)) { + if (r1 == MP_LT || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { ++digit; @@ -3808,12 +3813,12 @@ ShorteningBignumConversion(Double* dPtr, } /* - * Does the current digit leave us with a remainder large enough - * to commit to rounding up to the next higher digit? + * Does the current digit leave us with a remainder large enough to + * commit to rounding up to the next higher digit? */ if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType, - dPtr->w.word1 & 1, &temp)) { + dPtr->w.word1 & 1, &temp)) { ++digit; if (digit == 10) { *s++ = '9'; @@ -3824,7 +3829,9 @@ ShorteningBignumConversion(Double* dPtr, break; } - /* Have we converted all the requested digits? */ + /* + * Have we converted all the requested digits? + */ *s++ = '0' + digit; if (i == ilim) { @@ -3835,11 +3842,15 @@ ShorteningBignumConversion(Double* dPtr, break; } - /* Advance to the next digit */ + /* + * Advance to the next digit. + */ if (s5 > 0) { + /* + * Can possibly shorten the denominator. + */ - /* Can possibly shorten the denominator */ mp_mul_2d(&b, 1, &b); mp_mul_2d(&mminus, 1, &mminus); if (m2plus > m2minus) { @@ -3847,13 +3858,14 @@ ShorteningBignumConversion(Double* dPtr, } mp_div_d(&S, 5, &S, NULL); --s5; + /* - * IDEA: It might possibly be a win to fall back to - * int64 arithmetic here if S < 2**64/10. But it's - * a win only for a fairly narrow range of magnitudes - * so perhaps not worth bothering. We already know that - * we shorten the denominator by at least 1 mp_digit, perhaps - * 2. as we do the conversion for 17 digits of significance. + * IDEA: It might possibly be a win to fall back to int64_t + * arithmetic here if S < 2**64/10. But it's a win only for + * a fairly narrow range of magnitudes so perhaps not worth + * bothering. We already know that we shorten the + * denominator by at least 1 mp_digit, perhaps 2, as we do + * the conversion for 17 digits of significance. * Possible savings: * 10**26 1 trip through loop before fallback possible * 10**27 1 trip @@ -3872,7 +3884,7 @@ ShorteningBignumConversion(Double* dPtr, * 10**40 14 trips * 10**41 15 trips * 10**42 16 trips - * thereafter no gain. + * thereafter no gain. */ } else { mp_mul_d(&b, 10, &b); @@ -3885,11 +3897,11 @@ ShorteningBignumConversion(Double* dPtr, ++i; } - /* * Endgame - store the location of the decimal point and the end of the * string. */ + if (m2plus > m2minus) { mp_clear(&mplus); } @@ -3900,57 +3912,49 @@ ShorteningBignumConversion(Double* dPtr, *endPtr = s; } return retval; - } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * StrictBignumConversion -- * - * Convert a floating point number to a fixed-length digit string - * using the multiprecision method. + * Convert a floating point number to a fixed-length digit string using + * the multiprecision method. * * Results: * Returns the string of digits. * * Side effects: - * Stores the position of the decimal point in *decpt. - * Stores a pointer to the end of the number in *endPtr. + * Stores the position of the decimal point in *decpt. Stores a pointer + * to the end of the number in *endPtr. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -StrictBignumConversion(Double* dPtr, - /* Original number being converted */ - int convType, - /* Conversion type */ - Tcl_WideUInt bw, - /* Integer significand and exponent */ - int b2, /* Scale factor for the significand */ - int s2, int s5, - /* Scale factors for denominator */ - int k, /* Guessed position of the decimal point */ - int len, /* Size of the digit buffer to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Pointer to the end of the number */ +static inline char * +StrictBignumConversion( + Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ + Tcl_WideUInt bw, /* Integer significand and exponent. */ + int b2, /* Scale factor for the significand. */ + int s2, int s5, /* Scale factors for denominator. */ + int k, /* Guessed position of the decimal point. */ + int len, /* Size of the digit buffer to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char* retval = ckalloc(len+1); - /* Buffer of digits to return */ - char* s = retval; /* Cursor in the return value */ - mp_int b; /* Numerator of the result */ - mp_int S; /* Denominator of the result */ - mp_int dig; /* Current digit of the result */ - int digit; /* Current digit of the result */ - mp_int temp; /* Work area */ - int g; /* Size of the current digit groun */ + char *retval = ckalloc(len+1); + /* Buffer of digits to return. */ + char *s = retval; /* Cursor in the return value. */ + mp_int b; /* Numerator of the result. */ + mp_int S; /* Denominator of the result. */ + mp_int dig; /* Current digit of the result. */ + int digit; /* Current digit of the result. */ + mp_int temp; /* Work area. */ + int g; /* Size of the current digit ground. */ int i, j; /* @@ -3965,8 +3969,7 @@ StrictBignumConversion(Double* dPtr, MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* - * Handle the case where we guess the position of the decimal point - * wrong. + * Handle the case where we guess the position of the decimal point wrong. */ if (mp_cmp_mag(&b, &S) == MP_LT) { @@ -3975,7 +3978,9 @@ StrictBignumConversion(Double* dPtr, --k; } - /* Convert the leading digit */ + /* + * Convert the leading digit. + */ i = 0; mp_div(&b, &S, &dig, &b); @@ -3984,7 +3989,9 @@ StrictBignumConversion(Double* dPtr, } digit = dig.dp[0]; - /* Is a single digit all that was requested? */ + /* + * Is a single digit all that was requested? + */ *s++ = '0' + digit; if (++i >= ilim) { @@ -3993,10 +4000,10 @@ StrictBignumConversion(Double* dPtr, s = BumpUp(s, retval, &k); } } else { - for (;;) { - - /* Shift by a group of digits. */ + /* + * Shift by a group of digits. + */ g = ilim - i; if (g > DIGIT_GROUP) { @@ -4015,18 +4022,17 @@ StrictBignumConversion(Double* dPtr, mp_mul_2d(&b, g, &b); /* - * As with the shortening bignum conversion, it's possible at - * this point that we will have reduced the denominator to - * less than 2**64/10, at which point it would be possible to - * fall back to to int64 arithmetic. But the potential payoff - * is tremendously less - unless we're working in F format - - * because we know that three groups of digits will always - * suffice for %#.17e, the longest format that doesn't introduce - * empty precision. + * As with the shortening bignum conversion, it's possible at this + * point that we will have reduced the denominator to less than + * 2**64/10, at which point it would be possible to fall back to + * to int64_t arithmetic. But the potential payoff is tremendously + * less - unless we're working in F format - because we know that + * three groups of digits will always suffice for %#.17e, the + * longest format that doesn't introduce empty precision. + * + * Extract the next group of digits. */ - /* Extract the next group of digits */ - mp_div(&b, &S, &dig, &b); if (dig.used > 1) { Tcl_Panic("wrong digit!"); @@ -4034,6 +4040,7 @@ StrictBignumConversion(Double* dPtr, digit = dig.dp[0]; for (j = g-1; j >= 0; --j) { int t = itens[j]; + *s++ = digit / t + '0'; digit %= t; } @@ -4059,6 +4066,7 @@ StrictBignumConversion(Double* dPtr, * Endgame - store the location of the decimal point and the end of the * string. */ + mp_clear_multi(&b, &S, &temp, &dig, NULL); *s = '\0'; *decpt = k; @@ -4066,117 +4074,118 @@ StrictBignumConversion(Double* dPtr, *endPtr = s; } return retval; - } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclDoubleDigits -- * - * Core of Tcl's conversion of double-precision floating point numbers - * to decimal. + * Core of Tcl's conversion of double-precision floating point numbers to + * decimal. * * Results: * Returns a newly-allocated string of digits. * * Side effects: * Sets *decpt to the index of the character in the string before the - * place that the decimal point should go. If 'endPtr' is not NULL, - * sets endPtr to point to the terminating '\0' byte of the string. - * Sets *sign to 1 if a minus sign should be printed with the number, - * or 0 if a plus sign (or no sign) should appear. + * place that the decimal point should go. If 'endPtr' is not NULL, sets + * endPtr to point to the terminating '\0' byte of the string. Sets *sign + * to 1 if a minus sign should be printed with the number, or 0 if a plus + * sign (or no sign) should appear. * * This function is a service routine that produces the string of digits * for floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: - * TCL_DD_SHORTEST - This is the default for floating point conversion - * if ::tcl_precision is 0. It constructs the shortest string - * of digits that will reconvert to the given number when scanned. + * TCL_DD_SHORTEST - This is the default for floating point conversion if + * ::tcl_precision is 0. It constructs the shortest string of + * digits that will reconvert to the given number when scanned. * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. - * TCL_DD_STEELE - This value is not recommended and may be removed - * in the future. It follows the conversion algorithm outlined - * in "How to Print Floating-Point Numbers Accurately" by - * Guy L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, - * pp. 112-126]. This rule has the effect of rendering 1e23 - * as 9.9999999999999999e22 - which is a 'better' approximation - * in the sense that it will reconvert correctly even if - * a subsequent input conversion is 'round up' or 'round down' + * TCL_DD_STEELE - This value is not recommended and may be removed in + * the future. It follows the conversion algorithm outlined in + * "How to Print Floating-Point Numbers Accurately" by Guy + * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, + * pp. 112-126]. This rule has the effect of rendering 1e23 as + * 9.9999999999999999e22 - which is a 'better' approximation in + * the sense that it will reconvert correctly even if a + * subsequent input conversion is 'round up' or 'round down' * rather than 'round to nearest', but is surprising otherwise. - * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e - * format conversion (or for default floating->string if - * tcl_precision is not 0). It constructs a string of at most - * 'ndigits' digits, choosing the one that is closest to the - * given number (and resolving ties with 'round to even'). - * It is allowed to return fewer than 'ndigits' if the number - * converts exactly; if the TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG - * is supplied instead, it also returns fewer digits if the - * shorter string will still reconvert to the given input number. - * In any case, strings of trailing zeroes are suppressed. - * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f - * format conversion. It requests that conversion proceed until + * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format + * conversion (or for default floating->string if tcl_precision + * is not 0). It constructs a string of at most 'ndigits' digits, + * choosing the one that is closest to the given number (and + * resolving ties with 'round to even'). It is allowed to return + * fewer than 'ndigits' if the number converts exactly; if the + * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it + * also returns fewer digits if the shorter string will still + * reconvert without loss to the given input number. In any case, + * strings of trailing zeroes are suppressed. + * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f format + * conversion. It requests that conversion proceed until * 'ndigits' digits after the decimal point have been converted. * It is possible for this format to result in a zero-length - * string if the number is sufficiently small. Again, it - * is permissible for TCL_DD_F_FORMAT to return fewer digits - * for a number that converts exactly, and changing the - * argument to TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow - * the routine also to return fewer digits if the shorter string - * will still reconvert without loss to the given input number. - * Strings of trailing zeroes are suppressed. - * - * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag - * requires all calculations to be done in exact arithmetic. Normally, - * E and F format with fewer than about 14 digits will be done with - * a quick floating point approximation and fall back on the exact - * arithmetic only if the input number is close enough to the - * midpoint between two decimal strings that more precision is needed - * to resolve which string is correct. + * string if the number is sufficiently small. Again, it is + * permissible for TCL_DD_F_FORMAT to return fewer digits for a + * number that converts exactly, and changing the argument to + * TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow the routine + * also to return fewer digits if the shorter string will still + * reconvert without loss to the given input number. Strings of + * trailing zeroes are suppressed. + * + * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag requires + * all calculations to be done in exact arithmetic. Normally, E and F + * format with fewer than about 14 digits will be done with a quick + * floating point approximation and fall back on the exact arithmetic + * only if the input number is close enough to the midpoint between two + * decimal strings that more precision is needed to resolve which string + * is correct. * * The value stored in the 'decpt' argument on return may be negative - * (indicating that the decimal point falls to the left of the string) - * or greater than the length of the string. In addition, the value -9999 - * is used as a sentinel to indicate that the string is one of the special - * values "Infinity" and "NaN", and that no decimal point should be inserted. + * (indicating that the decimal point falls to the left of the string) or + * greater than the length of the string. In addition, the value -9999 is used + * as a sentinel to indicate that the string is one of the special values + * "Infinity" and "NaN", and that no decimal point should be inserted. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -char* -TclDoubleDigits(double dv, /* Number to convert */ - int ndigits, /* Number of digits requested */ - int flags, /* Conversion flags */ - int* decpt, /* OUTPUT: Position of the decimal point */ - int* sign, /* OUTPUT: 1 if the result is negative */ - char** endPtr) /* OUTPUT: If not NULL, receives a pointer - * to one character beyond the end - * of the returned string */ + +char * +TclDoubleDigits( + double dv, /* Number to convert. */ + int ndigits, /* Number of digits requested. */ + int flags, /* Conversion flags. */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + int *sign, /* OUTPUT: 1 if the result is negative. */ + char **endPtr) /* OUTPUT: If not NULL, receives a pointer to + * one character beyond the end of the + * returned string. */ { int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK); - /* Type of conversion being performed - * TCL_DD_SHORTEST0 - * TCL_DD_STEELE0 - * TCL_DD_E_FORMAT - * TCL_DD_F_FORMAT */ - Double d; /* Union for deconstructing doubles */ - Tcl_WideUInt bw; /* Integer significand */ + /* Type of conversion being performed: + * TCL_DD_SHORTEST0, TCL_DD_STEELE0, + * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */ + Double d; /* Union for deconstructing doubles. */ + Tcl_WideUInt bw; /* Integer significand. */ int be; /* Power of 2 by which b must be multiplied */ - int bbits; /* Number of bits needed to represent b */ + int bbits; /* Number of bits needed to represent b. */ int denorm; /* Flag == 1 iff the input number was - * denormalized */ - int k; /* Estimate of floor(log10(d)) */ - int k_check; /* Flag == 1 if d is near enough to a - * power of ten that k must be checked */ + * denormalized. */ + int k; /* Estimate of floor(log10(d)). */ + int k_check; /* Flag == 1 if d is near enough to a power of + * ten that k must be checked. */ int b2, b5, s2, s5; /* Powers of 2 and 5 in the numerator and - * denominator of intermediate results */ - int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number - * to convert if log10(d) has been - * overestimated */ - char* retval; /* Return value from this function */ + * denominator of intermediate results. */ + int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number to + * convert if log10(d) has been + * overestimated. */ + char *retval; /* Return value from this function. */ int i = -1; - /* Put the input number into a union for bit-whacking */ + /* + * Put the input number into a union for bit-whacking. + */ d.d = dv; @@ -4195,10 +4204,10 @@ TclDoubleDigits(double dv, /* Number to convert */ /* * Unpack the floating point into a wide integer and an exponent. - * Determine the number of bits that the big integer requires, and - * compute a quick approximation (which may be one too high) of - * ceil(log10(d.d)). + * Determine the number of bits that the big integer requires, and compute + * a quick approximation (which may be one too high) of ceil(log10(d.d)). */ + denorm = ((d.w.word0 & EXP_MASK) == 0); DoubleToExpAndSig(d.d, &bw, &be, &bbits); k = ApproximateLog10(bw, be, bbits); @@ -4208,58 +4217,57 @@ TclDoubleDigits(double dv, /* Number to convert */ * d is the number to convert. * bw are significand and exponent: d == bw*2**be, * bbits is the length of bw: 2**bbits-1 <= bw < 2**bbits - * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0 - * if we know that k is exactly ceil(log10(d)) and 1 if we need to - * check. + * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0 if we + * know that k is exactly ceil(log10(d)) and 1 if we need to check. * We want a rational number * r = b * 10**(1-k) = bw * 2**b2 * 5**b5 / (2**s2 / 5**s5), * with b2, b5, s2, s5 >= 0. Note that the most significant decimal - * digit is floor(r) and that successive digits can be obtained - * by setting r <- 10*floor(r) (or b <= 10 * (b % S)). - * Find appropriate b2, b5, s2, s5. + * digit is floor(r) and that successive digits can be obtained by + * setting r <- 10*floor(r) (or b <= 10 * (b % S)). Find appropriate + * b2, b5, s2, s5. */ ComputeScale(be, k, &b2, &b5, &s2, &s5); /* - * Correct an incorrect caller-supplied 'ndigits'. - * Also determine: + * Correct an incorrect caller-supplied 'ndigits'. Also determine: * i = The maximum number of decimal digits that will be returned in the * formatted string. This is k + 1 + ndigits for F format, 18 for - * shortest and Steele, and ndigits for E format. - * ilim = The number of significant digits to convert if - * k has been guessed correctly. This is -1 for shortest and Steele - * (which stop when all significance has been lost), 'ndigits' - * for E format, and 'k + 1 + ndigits' for F format. - * ilim1 = The minimum number of significant digits to convert if - * k has been guessed 1 too high. This, too, is -1 for shortest - * and Steele, and 'ndigits' for E format, but it's 'ndigits-1' - * for F format. + * shortest and Steele, and ndigits for E format. + * ilim = The number of significant digits to convert if k has been + * guessed correctly. This is -1 for shortest and Steele (which + * stop when all significance has been lost), 'ndigits' for E + * format, and 'k + 1 + ndigits' for F format. + * ilim1 = The minimum number of significant digits to convert if k has + * been guessed 1 too high. This, too, is -1 for shortest and + * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F + * format. */ SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1); /* - * Try to do low-precision conversion in floating point rather - * than resorting to expensive multiprecision arithmetic + * Try to do low-precision conversion in floating point rather than + * resorting to expensive multiprecision arithmetic. */ + if (ilim >= 0 && ilim <= QUICK_MAX && !(flags & TCL_DD_NO_QUICK)) { - if ((retval = QuickConversion(d.d, k, k_check, flags, - i, ilim, ilim1, - decpt, endPtr)) != NULL) { + retval = QuickConversion(d.d, k, k_check, flags, i, ilim, ilim1, + decpt, endPtr); + if (retval != NULL) { return retval; } } /* - * For shortening conversions, determine the upper and lower bounds - * for the remainder at which we can stop. - * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the - * high side, and - * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the - * low side. - * We may need to increase s2 to put m2plus, m2minus, b2 over a - * common denominator. + * For shortening conversions, determine the upper and lower bounds for + * the remainder at which we can stop. + * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the high + * side, and + * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the low + * side. + * We may need to increase s2 to put m2plus, m2minus, b2 over a common + * denominator. */ if (flags & TCL_DD_SHORTEN_FLAG) { @@ -4269,10 +4277,10 @@ TclDoubleDigits(double dv, /* Number to convert */ int len = i; /* - * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) - * is 1/2 unit in the least significant place of the floating - * point number. + * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) is 1/2 unit + * in the least significant place of the floating point number. */ + if (denorm) { i = be + EXPONENT_BIAS + (FP_PRECISION-1); } else { @@ -4283,14 +4291,16 @@ TclDoubleDigits(double dv, /* Number to convert */ /* * Reduce the fractions to lowest terms, since the above calculation - * may have left excess powers of 2 in numerator and denominator + * may have left excess powers of 2 in numerator and denominator. */ + CastOutPowersOf2(&b2, &m2minus, &s2); /* * In the special case where bw==1, the nearest floating point number * to it on the low side is 1/4 ulp below it. Adjust accordingly. */ + m2plus = m2minus; if (!denorm && bw == 1) { ++b2; @@ -4298,60 +4308,56 @@ TclDoubleDigits(double dv, /* Number to convert */ ++m2plus; } - if (s5+1 < N_LOG2POW5 - && s2+1 + log2pow5[s5+1] <= 64) { + if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { /* - * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit - * word, then all our intermediate calculations can be done - * using exact 64-bit arithmetic with no need for expensive - * multiprecision operations. (This will be true for all numbers - * in the range [1.0e-3 .. 1.0e+24]). + * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, + * then all our intermediate calculations can be done using exact + * 64-bit arithmetic with no need for expensive multiprecision + * operations. (This will be true for all numbers in the range + * [1.0e-3 .. 1.0e+24]). */ - return ShorteningInt64Conversion(&d, convType, bw, b2, b5, - m2plus, m2minus, m5, - s2, s5, k, len, ilim, ilim1, - decpt, endPtr); + return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus, + m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* - * The denominator is a power of 2, so we can replace division - * by digit shifts. First we round up s2 to a multiple of - * MP_DIGIT_BIT, and adjust m2 and b2 accordingly. Then we launch - * into a version of the comparison that's specialized for - * the 'power of mp_digit in the denominator' case. + * The denominator is a power of 2, so we can replace division by + * digit shifts. First we round up s2 to a multiple of MP_DIGIT_BIT, + * and adjust m2 and b2 accordingly. Then we launch into a version + * of the comparison that's specialized for the 'power of mp_digit + * in the denominator' case. */ + if (s2 % MP_DIGIT_BIT != 0) { int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT); + b2 += delta; m2plus += delta; m2minus += delta; s2 += delta; } return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5, - m2plus, m2minus, m5, - s2/MP_DIGIT_BIT, k, len, - ilim, ilim1, decpt, endPtr); + m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1, + decpt, endPtr); } else { - /* - * Alas, there's no helpful special case; use full-up - * bignum arithmetic for the conversion + * Alas, there's no helpful special case; use full-up bignum + * arithmetic for the conversion. */ - return ShorteningBignumConversion(&d, convType, bw, - b2, m2plus, m2minus, - s2, s5, k, len, - ilim, ilim1, decpt, endPtr); - + return ShorteningBignumConversion(&d, convType, bw, b2, m2plus, + m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } - } else { - - /* Non-shortening conversion */ + /* + * Non-shortening conversion. + */ int len = i; - /* Reduce numerator and denominator to lowest terms */ + /* + * Reduce numerator and denominator to lowest terms. + */ if (b2 >= s2 && s2 > 0) { b2 -= s2; s2 = 0; @@ -4359,48 +4365,46 @@ TclDoubleDigits(double dv, /* Number to convert */ s2 -= b2; b2 = 0; } - if (s5+1 < N_LOG2POW5 - && s2+1 + log2pow5[s5+1] <= 64) { + if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { /* - * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit - * word, then all our intermediate calculations can be done - * using exact 64-bit arithmetic with no need for expensive - * multiprecision operations. + * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, + * then all our intermediate calculations can be done using exact + * 64-bit arithmetic with no need for expensive multiprecision + * operations. */ - return StrictInt64Conversion(&d, convType, bw, b2, b5, - s2, s5, k, len, ilim, ilim1, - decpt, endPtr); - + return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k, + len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* - * The denominator is a power of 2, so we can replace division - * by digit shifts. First we round up s2 to a multiple of - * MP_DIGIT_BIT, and adjust m2 and b2 accordingly. Then we launch - * into a version of the comparison that's specialized for - * the 'power of mp_digit in the denominator' case. + * The denominator is a power of 2, so we can replace division by + * digit shifts. First we round up s2 to a multiple of MP_DIGIT_BIT, + * and adjust m2 and b2 accordingly. Then we launch into a version + * of the comparison that's specialized for the 'power of mp_digit + * in the denominator' case. */ + if (s2 % MP_DIGIT_BIT != 0) { int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT); + b2 += delta; s2 += delta; } return StrictBignumConversionPowD(&d, convType, bw, b2, b5, - s2/MP_DIGIT_BIT, k, len, - ilim, ilim1, decpt, endPtr); + s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* - * There are no helpful special cases, but at least we know - * in advance how many digits we will convert. We can run the - * conversion in steps of DIGIT_GROUP digits, so as to - * have many fewer mp_int divisions. + * There are no helpful special cases, but at least we know in + * advance how many digits we will convert. We can run the + * conversion in steps of DIGIT_GROUP digits, so as to have many + * fewer mp_int divisions. */ - return StrictBignumConversion(&d, convType, bw, b2, s2, s5, - k, len, ilim, ilim1, decpt, endPtr); + + return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k, + len, ilim, ilim1, decpt, endPtr); } } } - /* *---------------------------------------------------------------------- @@ -4428,14 +4432,12 @@ TclInitDoubleConversion(void) int x; Tcl_WideUInt u; double d; - #ifdef IEEE_FLOATING_POINT union { double dv; Tcl_WideUInt iv; } bitwhack; #endif - #if defined(__sgi) && defined(_COMPILER_VERSION) union fpc_csr mipsCR; @@ -4460,8 +4462,8 @@ TclInitDoubleConversion(void) pow10_wide[i] = u; /* - * Determine how many bits of precision a double has, and how many - * decimal digits that represents. + * Determine how many bits of precision a double has, and how many decimal + * digits that represents. */ if (frexp((double) FLT_RADIX, &log2FLT_RADIX) != 0.5) { @@ -4472,8 +4474,8 @@ TclInitDoubleConversion(void) d = 1.0; /* - * Initialize a table of powers of ten that can be exactly represented - * in a double. + * Initialize a table of powers of ten that can be exactly represented in + * a double. */ x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log(5.0)); @@ -4562,6 +4564,9 @@ TclFinalizeDoubleConversion(void) for (i=0; i<9; ++i) { mp_clear(pow5 + i); } + for (i=0; i < 5; ++i) { + mp_clear(pow5_13 + i); + } } /* @@ -4584,9 +4589,9 @@ TclFinalizeDoubleConversion(void) int Tcl_InitBignumFromDouble( - Tcl_Interp *interp, /* For error message */ - double d, /* Number to convert */ - mp_int *b) /* Place to store the result */ + Tcl_Interp *interp, /* For error message. */ + double d, /* Number to convert. */ + mp_int *b) /* Place to store the result. */ { double fract; int expt; @@ -4736,9 +4741,9 @@ TclBignumToDouble( return r; } } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclCeil -- * @@ -4748,7 +4753,7 @@ TclBignumToDouble( * Results: * Returns the floating point number. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ double @@ -4793,19 +4798,19 @@ TclCeil( mp_clear(&b); return r; } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclFloor -- * - * Computes the largest floating point number less than or equal to - * the mp_int argument. + * Computes the largest floating point number less than or equal to the + * mp_int argument. * * Results: * Returns the floating point value. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ double @@ -4866,8 +4871,8 @@ TclFloor( static double BignumToBiasedFrExp( - mp_int *a, /* Integer to convert */ - int *machexp) /* Power of two */ + mp_int *a, /* Integer to convert. */ + int *machexp) /* Power of two. */ { mp_int b; int bits; @@ -4931,8 +4936,8 @@ BignumToBiasedFrExp( static double Pow10TimesFrExp( - int exponent, /* Power of 10 to multiply by */ - double fraction, /* Significand of multiplicand */ + int exponent, /* Power of 10 to multiply by. */ + double fraction, /* Significand of multiplicand. */ int *machexp) /* On input, exponent of multiplicand. On * output, exponent of result. */ { @@ -4942,7 +4947,7 @@ Pow10TimesFrExp( if (exponent > 0) { /* - * Multiply by 10**exponent + * Multiply by 10**exponent. */ retval = frexp(retval * pow10vals[exponent&0xf], &j); @@ -4955,7 +4960,7 @@ Pow10TimesFrExp( } } else if (exponent < 0) { /* - * Divide by 10**-exponent + * Divide by 10**-exponent. */ retval = frexp(retval / pow10vals[(-exponent) & 0xf], &j); @@ -5064,15 +5069,15 @@ TclFormatNaN( * * Nokia770Twiddle -- * - * Transpose the two words of a number for Nokia 770 floating - * point handling. + * Transpose the two words of a number for Nokia 770 floating point + * handling. * *---------------------------------------------------------------------- */ static Tcl_WideUInt Nokia770Twiddle( - Tcl_WideUInt w) /* Number to transpose */ + Tcl_WideUInt w) /* Number to transpose. */ { return (((w >> 32) & 0xffffffff) | (w << 32)); } @@ -5082,8 +5087,8 @@ Nokia770Twiddle( * * TclNokia770Doubles -- * - * Transpose the two words of a number for Nokia 770 floating - * point handling. + * Transpose the two words of a number for Nokia 770 floating point + * handling. * *---------------------------------------------------------------------- */ -- cgit v0.12 From 0215962576d4b65e97c72d5077e7a1f945e25963 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Jan 2020 14:23:06 +0000 Subject: Revise documentation that refers to direct access to interp->result. --- doc/CrtSlave.3 | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/doc/CrtSlave.3 b/doc/CrtSlave.3 index ac681bc..b8ac421 100644 --- a/doc/CrtSlave.3 +++ b/doc/CrtSlave.3 @@ -119,7 +119,7 @@ in a hierarchical relationship, and the management of aliases, commands that when invoked in one interpreter execute a command in another interpreter. The return value for those procedures that return an \fBint\fR is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned -then the \fBresult\fR field of the interpreter contains an error message. +then the interpreter's result contains an error message. .PP \fBTcl_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR. It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which @@ -158,12 +158,12 @@ If no such slave interpreter exists, \fBNULL\fR is returned. \fIinterp\fR. If \fIinterp\fR has no master (it is a top-level interpreter) then \fBNULL\fR is returned. .PP -\fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR -to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; +\fBTcl_GetInterpPath\fR stores in the result of \fIaskingInterp\fR +the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else -\fBTCL_ERROR\fR is returned and the \fIresult\fR field in -\fIaskingInterp\fR contains the error message. +\fBTCL_ERROR\fR is returned and an error message is stored as the +result of \fIaskingInterp\fR. .PP \fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in \fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR @@ -198,33 +198,33 @@ the set of hidden commands to the set of exposed commands, putting it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden -command, or the operation will return \fBTCL_ERROR\fR and leave an error -message in the \fIresult\fR field in \fIinterp\fR. +command, or the operation will return \fBTCL_ERROR\fR and +leave an error message as the result of \fIinterp\fR. If an exposed command named \fIcmdName\fR already exists, -the operation returns \fBTCL_ERROR\fR and leaves an error message in the -value result of \fIinterp\fR. +the operation returns \fBTCL_ERROR\fR and leaves an error message as +the result of \fIinterp\fR. If the operation succeeds, it returns \fBTCL_OK\fR. -After executing this command, attempts to use \fIcmdName\fR in a call to -\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will again succeed. +After executing this command, attempts to use \fIcmdName\fR in any +script evaluation mechanism will again succeed. .PP \fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of exposed commands to the set of hidden commands, under the name \fIhiddenCmdName\fR. \fICmdName\fR must be the name of an existing exposed command, or the operation will return \fBTCL_ERROR\fR and leave an error -message in the value result of \fIinterp\fR. +message as the result of \fIinterp\fR. Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and -leave an error message in the value result of \fIinterp\fR. +leave an error message as the result of \fIinterp\fR. The \fICmdName\fR will be looked up in the global namespace, and not relative to the current namespace, even if the current namespace is not the global one. If a hidden command whose name is \fIhiddenCmdName\fR already -exists, the operation also returns \fBTCL_ERROR\fR and the \fIresult\fR -field in \fIinterp\fR contains an error message. +exists, the operation also returns \fBTCL_ERROR\fR and an error +message is left as the result of \fIinterp\fR. If the operation succeeds, it returns \fBTCL_OK\fR. -After executing this command, attempts to use \fIcmdName\fR in a call to -\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will fail. +After executing this command, attempts to use \fIcmdName\fR in +any script evaluation mechanism will fail. .PP For a description of the Tcl interface to multiple interpreters, see \fIinterp(n)\fR. -- cgit v0.12 From 780f4393966ac11b20908b77d1671119f66b63a8 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Jan 2020 16:53:25 +0000 Subject: Remove another mention of interp->result. --- doc/CrtChannel.3 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 6ef94b5..929b1b8 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -648,8 +648,8 @@ It should call \fBTcl_BadChannelOption\fR which itself returns unrecognized. If \fInewValue\fR specifies a value for the option that is not supported or if a system call error occurs, -the function should leave an error message in the -\fIresult\fR field of \fIinterp\fR if \fIinterp\fR is not NULL. The +the function should leave an error message in the result +of \fIinterp\fR if \fIinterp\fR is not NULL. The function should also call \fBTcl_SetErrno\fR to store an appropriate POSIX error code. .PP -- cgit v0.12 From d1f6dc44aae5f6e19c8acafcfd9fbb2998589f73 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Jan 2020 21:39:12 +0000 Subject: s/in stead/instead/ --- doc/Panic.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Panic.3 b/doc/Panic.3 index af86665..5f4763f 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -50,7 +50,7 @@ In a freshly loaded Tcl library, \fBTcl_Panic\fR prints the formatted error message to the standard error file of the process, and then calls \fBabort\fR to terminate the process. \fBTcl_Panic\fR does not return. On Windows, when a debugger is running, the formatted error -message is sent to the debugger in stead. If the windows executable +message is sent to the debugger instead. If the windows executable does not have a stderr channel (e.g. \fBwish.exe\fR), then a system dialog box is used to display the panic message. .PP -- cgit v0.12 From 8ef7bd41b66cc77db4b4f07d09ed1faf96ab43c8 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Jan 2020 22:25:36 +0000 Subject: Improvements to doc changes from TIPs 422 and 512. --- doc/AddErrInfo.3 | 3 +++ doc/Eval.3 | 3 ++- doc/Panic.3 | 9 +++++---- doc/SetResult.3 | 2 ++ doc/StaticPkg.3 | 2 +- doc/StringObj.3 | 4 +++- doc/Tcl_Main.3 | 2 +- 7 files changed, 17 insertions(+), 8 deletions(-) diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index 0b59349..5b0fe5a 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -247,6 +247,9 @@ record instead of a value. Otherwise, it is similar to .PP \fBTcl_SetErrorCodeVA\fR is the same as \fBTcl_SetErrorCode\fR except that instead of taking a variable number of arguments it takes an argument list. +Interfaces using argument lists have been found to be nonportable in practice. +This function is deprecated and will be removed in Tcl 9.0. + .PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full diff --git a/doc/Eval.3 b/doc/Eval.3 index f7c6976..1abe6f2 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -156,7 +156,8 @@ of arguments. \fBTcl_VarEval\fR is now deprecated. .PP \fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that instead of taking a variable number of arguments it takes an argument -list. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated. +list. Interfaces using argument lists have been found to be nonportable +in practice. This function is deprecated and will be removed in Tcl 9.0. .SH "FLAG BITS" .PP diff --git a/doc/Panic.3 b/doc/Panic.3 index f3f8043..53b84da 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -86,6 +86,9 @@ The typical use of \fBTcl_SetPanicProc\fR arranges for the error message to be displayed or reported in a manner more suitable for the application or the platform. .PP +\fBTcl_SetPanicProc\fR can not be used in stub-enabled extensions. Its symbol +entry in the stub table is deprecated and it will be removed in Tcl 9.0. +.PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called by any extension or application that wishes to abort the process and @@ -93,11 +96,9 @@ have a panic message displayed the same way that panic messages from Tcl will be displayed. .PP \fBTcl_PanicVA\fR is the same as \fBTcl_Panic\fR except that instead of -taking a variable number of arguments it takes an argument list. This +taking a variable number of arguments it takes an argument list. Interfaces +using argument lists have been found to be nonportable in practice. This function is deprecated and will be removed in Tcl 9.0. -.PP -This function can not be used in stub-enabled extensions. Its symbol -entry in the stub table is deprecated and it will be removed in Tcl 9.0. .SH "SEE ALSO" abort(3), printf(3), exec(n), format(n) .SH KEYWORDS diff --git a/doc/SetResult.3 b/doc/SetResult.3 index a640956..1622290 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -145,6 +145,8 @@ call; the last argument in the list must be a NULL pointer. .PP \fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that instead of taking a variable number of arguments it takes an argument list. +Interfaces using argument lists have been found to be nonportable in practice. +This function is deprecated and will be removed in Tcl 9.0. .PP \fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR to \fItargetInterp\fR. The two interpreters must have been created in the diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3 index 8d04cd1..b22edcc 100644 --- a/doc/StaticPkg.3 +++ b/doc/StaticPkg.3 @@ -65,7 +65,7 @@ error message. The result or error from the initialization procedure will be returned as the result of the \fBload\fR command that caused the initialization procedure to be invoked. .PP -This function can not be used in stub-enabled extensions. Its symbol +\fBTcl_StaticPackage\fR can not be used in stub-enabled extensions. Its symbol entry in the stub table is deprecated and it will be removed in Tcl 9.0. .SH KEYWORDS initialization procedure, package, static linking diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 12fc413..2b665cc 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -249,7 +249,9 @@ must be a NULL pointer to indicate the end of the list. .PP \fBTcl_AppendStringsToObjVA\fR is the same as \fBTcl_AppendStringsToObj\fR except that instead of taking a variable number of arguments it takes an -argument list. +argument list. Interfaces using argument lists have been found to be +nonportable in practice. This function is deprecated and will be removed +in Tcl 9.0. .PP \fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR except that it imposes a limit on how many bytes are appended. diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 816dfeb..dc4f45f 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -190,7 +190,7 @@ procedure (if any) returns. In non-interactive mode, after procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .PP -This function can not be used in stub-enabled extensions. +\fBTcl_Main\fR can not be used in stub-enabled extensions. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) -- cgit v0.12 From cc211af4eafca77e7d1ede7371c88c6d6fc44a80 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Jan 2020 09:20:57 +0000 Subject: Start handling WUR (Warn Unused Result) in all tommath calls. WIP, not complete yet. --- generic/tclBasic.c | 37 ++++++++--- generic/tclExecute.c | 181 ++++++++++++++++++++++++++++++++++----------------- generic/tclObj.c | 25 ++++--- generic/tclStrToD.c | 127 +++++++++++++++++++++++------------- generic/tclTestObj.c | 14 ++-- 5 files changed, 260 insertions(+), 124 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b216e05..9f650d6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7675,10 +7675,16 @@ ExprIsqrtFunc( Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d))); } else { mp_int root; + mp_err err; - mp_init(&root); - mp_sqrt(&big, &root); + err = mp_init(&root); + if (err == MP_OKAY) { + err = mp_sqrt(&big, &root); + } mp_clear(&big); + if (err != MP_OKAY) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root)); } return TCL_OK; @@ -7724,10 +7730,17 @@ ExprSqrtFunc( if ((d >= 0.0) && TclIsInfinite(d) && (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) { mp_int root; + mp_err err; - mp_init(&root); - mp_sqrt(&big, &root); + err = mp_init(&root); + if (err == MP_OKAY) { + err = mp_sqrt(&big, &root); + } mp_clear(&big); + if (err != MP_OKAY) { + mp_clear(&root); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); mp_clear(&root); } else { @@ -7893,7 +7906,9 @@ ExprAbsFunc( } goto unChanged; } else if (l == WIDE_MIN) { - mp_init_i64(&big, l); + if (mp_init_i64(&big, l) != MP_OKAY) { + return TCL_ERROR; + } goto tooLarge; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); @@ -7924,7 +7939,9 @@ ExprAbsFunc( if (mp_isneg((const mp_int *) ptr)) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: - (void)mp_neg(&big, &big); + if (mp_neg(&big, &big) != MP_OKAY) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { unChanged: @@ -8260,15 +8277,19 @@ ExprRoundFunc( } if ((intPart >= (double)max) || (intPart <= (double)min)) { mp_int big; + mp_err err = MP_OKAY; if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) { /* Infinity */ return TCL_ERROR; } if (fractPart <= -0.5) { - mp_sub_d(&big, 1, &big); + err = mp_sub_d(&big, 1, &big); } else if (fractPart >= 0.5) { - mp_add_d(&big, 1, &big); + err = mp_add_d(&big, 1, &big); + } + if (err != MP_OKAY) { + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8bc83cc..3d75d97 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -652,6 +652,7 @@ static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); #define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) #define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) #define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3) +#define OUT_OF_MEMORY ((Tcl_Obj *) -4) /* * Declarations for local procedures to this file: @@ -1796,6 +1797,7 @@ TclIncrObj( ClientData ptr1, ptr2; int type1, type2; mp_int value, incr; + mp_err err; if (Tcl_IsShared(valuePtr)) { Tcl_Panic("%s called with shared object", "TclIncrObj"); @@ -1854,8 +1856,11 @@ TclIncrObj( Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); - mp_add(&value, &incr, &value); + err = mp_add(&value, &incr, &value); mp_clear(&incr); + if (err != MP_OKAY) { + return TCL_ERROR; + } Tcl_SetBignumObj(valuePtr, &value); return TCL_OK; } @@ -6149,6 +6154,9 @@ TEBCresume( } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { TRACE_ERROR(interp); goto gotError; + } else if (objResultPtr == OUT_OF_MEMORY) { + TRACE_APPEND(("OUT OF MEMORY\n")); + goto outOfMemory; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); @@ -7593,6 +7601,13 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; + outOfMemory: + Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", NULL); + CACHE_STACK_INFO(); + goto gotError; + /* * Exponentiation of zero by negative number in an expression. Control * only reaches this point by "goto exponOfZero". @@ -8032,6 +8047,7 @@ ExecuteExtendedBinaryMathOp( Tcl_Obj *objResultPtr; int invalid, zero; long shift; + mp_err err; (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); @@ -8093,9 +8109,14 @@ ExecuteExtendedBinaryMathOp( * Arguments are opposite sign; remainder is sum. */ - mp_init_i64(&big1, w1); - mp_add(&big2, &big1, &big2); - mp_clear(&big1); + err = mp_init_i64(&big1, w1); + if (err == MP_OKAY) { + err = mp_add(&big2, &big1, &big2); + mp_clear(&big1); + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } BIG_RESULT(&big2); } @@ -8108,21 +8129,30 @@ ExecuteExtendedBinaryMathOp( } Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); + err = mp_init_multi(&bigResult, &bigRemainder, NULL); + if (err == MP_OKAY) { + err = mp_div(&big1, &big2, &bigResult, &bigRemainder); + } if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* * Convert to Tcl's integer division rules. */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); + err = mp_sub_d(&bigResult, 1, &bigResult); + if (err == MP_OKAY) { + err = mp_add(&bigRemainder, &big2, &bigRemainder); + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } } - mp_copy(&bigRemainder, &bigResult); + err = mp_copy(&bigRemainder, &bigResult); mp_clear(&bigRemainder); mp_clear(&big1); mp_clear(&big2); + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } BIG_RESULT(&bigResult); case INST_LSHIFT: @@ -8248,11 +8278,16 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - mp_init(&bigResult); - if (opcode == INST_LSHIFT) { - mp_mul_2d(&big1, shift, &bigResult); - } else { - mp_signed_rsh(&big1, shift, &bigResult); + err = mp_init(&bigResult); + if (err == MP_OKAY) { + if (opcode == INST_LSHIFT) { + err = mp_mul_2d(&big1, shift, &bigResult); + } else { + err = mp_signed_rsh(&big1, shift, &bigResult); + } + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; } mp_clear(&big1); BIG_RESULT(&bigResult); @@ -8265,20 +8300,25 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); + err = mp_init(&bigResult); - switch (opcode) { - case INST_BITAND: - mp_and(&big1, &big2, &bigResult); - break; + if (err == MP_OKAY) { + switch (opcode) { + case INST_BITAND: + err = mp_and(&big1, &big2, &bigResult); + break; - case INST_BITOR: - mp_or(&big1, &big2, &bigResult); - break; + case INST_BITOR: + err = mp_or(&big1, &big2, &bigResult); + break; - case INST_BITXOR: - mp_xor(&big1, &big2, &bigResult); - break; + case INST_BITXOR: + err = mp_xor(&big1, &big2, &bigResult); + break; + } + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; } mp_clear(&big1); @@ -8341,8 +8381,8 @@ ExecuteExtendedBinaryMathOp( } else { Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); negativeExponent = mp_isneg(&big2); - mp_mod_2d(&big2, 1, &big2); - oddExponent = !mp_iszero(&big2); + err = mp_mod_2d(&big2, 1, &big2); + oddExponent = (err == MP_OKAY) && !mp_iszero(&big2); mp_clear(&big2); } @@ -8499,8 +8539,13 @@ ExecuteExtendedBinaryMathOp( return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - mp_init(&bigResult); - mp_expt_u32(&big1, (unsigned int)w2, &bigResult); + err = mp_init(&bigResult); + if (err == MP_OKAY) { + err = mp_expt_u32(&big1, (unsigned int)w2, &bigResult); + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } mp_clear(&big1); BIG_RESULT(&bigResult); } @@ -8647,38 +8692,44 @@ ExecuteExtendedBinaryMathOp( overflowBasic: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); + err = mp_init(&bigResult); + if (err == MP_OKAY) { switch (opcode) { case INST_ADD: - mp_add(&big1, &big2, &bigResult); - break; + err = mp_add(&big1, &big2, &bigResult); + break; case INST_SUB: - mp_sub(&big1, &big2, &bigResult); - break; + err = mp_sub(&big1, &big2, &bigResult); + break; case INST_MULT: - mp_mul(&big1, &big2, &bigResult); - break; + err = mp_mul(&big1, &big2, &bigResult); + break; case INST_DIV: - if (mp_iszero(&big2)) { - mp_clear(&big1); - mp_clear(&big2); - mp_clear(&bigResult); - return DIVIDED_BY_ZERO; - } - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - /* TODO: internals intrusion */ - if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { - /* - * Convert to Tcl's integer division rules. - */ + if (mp_iszero(&big2)) { + mp_clear(&big1); + mp_clear(&big2); + mp_clear(&bigResult); + return DIVIDED_BY_ZERO; + } + err = mp_init(&bigRemainder); + if (err == MP_OKAY) { + err = mp_div(&big1, &big2, &bigResult, &bigRemainder); + } + /* TODO: internals intrusion */ + if (!mp_iszero(&bigRemainder) + && (bigRemainder.sign != big2.sign)) { + /* + * Convert to Tcl's integer division rules. + */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); + err = mp_sub_d(&bigResult, 1, &bigResult); + if (err == MP_OKAY) { + err = mp_add(&bigRemainder, &big2, &bigRemainder); + } + } + mp_clear(&bigRemainder); + break; } - mp_clear(&bigRemainder); - break; } mp_clear(&big1); mp_clear(&big2); @@ -8699,6 +8750,7 @@ ExecuteExtendedUnaryMathOp( Tcl_WideInt w; mp_int big; Tcl_Obj *objResultPtr; + mp_err err = MP_OKAY; (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); @@ -8710,8 +8762,13 @@ ExecuteExtendedUnaryMathOp( } Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ - (void)mp_neg(&big, &big); - mp_sub_d(&big, 1, &big); + err = mp_neg(&big, &big); + if (err == MP_OKAY) { + err = mp_sub_d(&big, 1, &big); + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } BIG_RESULT(&big); case INST_UMINUS: switch (type) { @@ -8722,12 +8779,18 @@ ExecuteExtendedUnaryMathOp( if (w != WIDE_MIN) { WIDE_RESULT(-w); } - mp_init_i64(&big, w); + err = mp_init_i64(&big, w); + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } break; default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } - (void)mp_neg(&big, &big); + err = mp_neg(&big, &big); + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } BIG_RESULT(&big); } diff --git a/generic/tclObj.c b/generic/tclObj.c index eb9334e..ea1360f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -182,10 +182,7 @@ static Tcl_ThreadDataKey pendingObjDataKey; *temp = bignum; \ (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ - } else { \ - if ((bignum).alloc > 0x7fff) { \ - mp_shrink(&(bignum)); \ - } \ + } else if (((bignum).alloc <= 0x7fff) || (mp_shrink(&(bignum))) == MP_OKAY) { \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (bignum).dp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ | ((bignum).alloc << 15) | ((bignum).used)); \ @@ -3338,14 +3335,20 @@ TclGetWideBitsFromObj( } if (objPtr->typePtr == &tclBignumType) { mp_int big; + mp_err err; Tcl_WideUInt value = 0, scratch; size_t numBytes; unsigned char *bytes = (unsigned char *) &scratch; Tcl_GetBignumFromObj(NULL, objPtr, &big); - mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); - mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); + err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); + if (err == MP_OKAY) { + err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); + } + if (err != MP_OKAY) { + return TCL_ERROR; + } while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } @@ -3585,7 +3588,9 @@ GetBignumFromObj( mp_int temp; TclUnpackBignum(objPtr, temp); - mp_init_copy(bignumValue, &temp); + if (mp_init_copy(bignumValue, &temp) != MP_OKAY) { + return TCL_ERROR; + } } else { TclUnpackBignum(objPtr, *bignumValue); /* Optimized TclFreeIntRep */ @@ -3604,8 +3609,10 @@ GetBignumFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - mp_init_i64(bignumValue, - objPtr->internalRep.wideValue); + if (mp_init_i64(bignumValue, + objPtr->internalRep.wideValue) != MP_OKAY) { + return TCL_ERROR; + } return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 8939fa0..94e06ce 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -534,6 +534,7 @@ TclParseNumber( * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ int explicitOctal = 0; + mp_err err = MP_OKAY; #define ALL_BITS ((Tcl_WideUInt)-1) #define MOST_BITS (ALL_BITS >> 1) @@ -716,7 +717,7 @@ TclParseNumber( || (octalSignificandWide > ((Tcl_WideUInt)-1 >> shift)))) { octalSignificandOverflow = 1; - mp_init_u64(&octalSignificandBig, + err = mp_init_u64(&octalSignificandBig, octalSignificandWide); } } @@ -724,10 +725,17 @@ TclParseNumber( octalSignificandWide = (octalSignificandWide << shift) + (c - '0'); } else { - mp_mul_2d(&octalSignificandBig, shift, - &octalSignificandBig); - mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'), - &octalSignificandBig); + if (err == MP_OKAY) { + err = mp_mul_2d(&octalSignificandBig, shift, + &octalSignificandBig); + } + if (err == MP_OKAY) { + err = mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'), + &octalSignificandBig); + } + } + if (err != MP_OKAY) { + return TCL_ERROR; } } if (numSigDigs != 0) { @@ -833,17 +841,22 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > ((Tcl_WideUInt)-1 >> shift))) { significandOverflow = 1; - mp_init_u64(&significandBig, + err = mp_init_u64(&significandBig, significandWide); } } if (!significandOverflow) { significandWide = (significandWide << shift) + d; - } else { - mp_mul_2d(&significandBig, shift, &significandBig); - mp_add_d(&significandBig, (mp_digit) d, &significandBig); + } else if (err == MP_OKAY) { + err = mp_mul_2d(&significandBig, shift, &significandBig); + if (err == MP_OKAY) { + mp_add_d(&significandBig, (mp_digit) d, &significandBig); + } } } + if (err != MP_OKAY) { + return TCL_ERROR; + } numTrailZeros = 0; state = HEXADECIMAL; break; @@ -4557,6 +4570,7 @@ Tcl_InitBignumFromDouble( { double fract; int expt; + mp_err err; /* * Infinite values can't convert to bignum. @@ -4574,19 +4588,24 @@ Tcl_InitBignumFromDouble( fract = frexp(d, &expt); if (expt <= 0) { - mp_init(b); + err = mp_init(b); mp_zero(b); } else { Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); int shift = expt - mantBits; - mp_init_i64(b, w); - if (shift < 0) { - mp_div_2d(b, -shift, b, NULL); + err = mp_init_i64(b, w); + if (err != MP_OKAY) { + /* just skip */ + } else if (shift < 0) { + err = mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { - mp_mul_2d(b, shift, b); + err = mp_mul_2d(b, shift, b); } } + if (err != MP_OKAY) { + return TCL_ERROR; + } return TCL_OK; } @@ -4612,6 +4631,7 @@ TclBignumToDouble( mp_int b; int bits, shift, i, lsb; double r; + mp_err err; /* @@ -4640,11 +4660,13 @@ TclBignumToDouble( * 'rounded to even'. */ - mp_init(&b); - if (shift == 0) { - mp_copy(a, &b); + err = mp_init(&b); + if (err != MP_OKAY) { + /* just skip */ + } else if (shift == 0) { + err = mp_copy(a, &b); } else if (shift > 0) { - mp_mul_2d(a, shift, &b); + err = mp_mul_2d(a, shift, &b); } else if (shift < 0) { lsb = mp_cnt_lsb(a); if (lsb == -1-shift) { @@ -4653,12 +4675,12 @@ TclBignumToDouble( * Round to even */ - mp_div_2d(a, -shift, &b, NULL); - if (mp_isodd(&b)) { + err = mp_div_2d(a, -shift, &b, NULL); + if ((err == MP_OKAY) && mp_isodd(&b)) { if (mp_isneg(&b)) { - mp_sub_d(&b, 1, &b); + err = mp_sub_d(&b, 1, &b); } else { - mp_add_d(&b, 1, &b); + err = mp_add_d(&b, 1, &b); } } } else { @@ -4667,13 +4689,15 @@ TclBignumToDouble( * Ordinary rounding */ - mp_div_2d(a, -1-shift, &b, NULL); - if (mp_isneg(&b)) { - mp_sub_d(&b, 1, &b); + err = mp_div_2d(a, -1-shift, &b, NULL); + if (err != MP_OKAY) { + /* just skip */ + } else if (mp_isneg(&b)) { + err = mp_sub_d(&b, 1, &b); } else { - mp_add_d(&b, 1, &b); + err = mp_add_d(&b, 1, &b); } - mp_div_2d(&b, 1, &b, NULL); + err = mp_div_2d(&b, 1, &b, NULL); } } @@ -4681,8 +4705,11 @@ TclBignumToDouble( * Accumulate the result, one mp_digit at a time. */ + if (err != MP_OKAY) { + return 0.0; + } r = 0.0; - for (i=b.used-1 ; i>=0 ; --i) { + for (i = b.used-1; i>=0; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } mp_clear(&b); @@ -4724,10 +4751,11 @@ TclCeil( { double r = 0.0; mp_int b; + mp_err err; - mp_init(&b); - if (mp_isneg(a)) { - mp_neg(a, &b); + err = mp_init(&b); + if ((err == MP_OKAY) && mp_isneg(a)) { + err = mp_neg(a, &b); r = -TclFloor(&b); } else { int bits = mp_count_bits(a); @@ -4737,19 +4765,26 @@ TclCeil( } else { int i, exact = 1, shift = mantBits - bits; - if (shift > 0) { - mp_mul_2d(a, shift, &b); + if (err != MP_OKAY) { + /* just skip */ + } else if (shift > 0) { + err = mp_mul_2d(a, shift, &b); } else if (shift < 0) { mp_int d; - mp_init(&d); - mp_div_2d(a, -shift, &b, &d); + err = mp_init(&d); + if (err == MP_OKAY) { + err = mp_div_2d(a, -shift, &b, &d); + } exact = mp_iszero(&d); mp_clear(&d); } else { - mp_copy(a, &b); + err = mp_copy(a, &b); + } + if ((err == MP_OKAY) && !exact) { + err = mp_add_d(&b, 1, &b); } - if (!exact) { - mp_add_d(&b, 1, &b); + if (err != MP_OKAY) { + return 0.0; } for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; @@ -4781,10 +4816,11 @@ TclFloor( { double r = 0.0; mp_int b; + mp_err err; - mp_init(&b); - if (mp_isneg(a)) { - mp_neg(a, &b); + err = mp_init(&b); + if ((err == MP_OKAY) && mp_isneg(a)) { + err = mp_neg(a, &b); r = -TclCeil(&b); } else { int bits = mp_count_bits(a); @@ -4795,11 +4831,14 @@ TclFloor( int i, shift = mantBits - bits; if (shift > 0) { - mp_mul_2d(a, shift, &b); + err = mp_mul_2d(a, shift, &b); } else if (shift < 0) { - mp_div_2d(a, -shift, &b, NULL); + err = mp_div_2d(a, -shift, &b, NULL); } else { - mp_copy(a, &b); + err = mp_copy(a, &b); + } + if (err != MP_OKAY) { + return 0.0; } for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index e616433..0faf9a8 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -281,7 +281,8 @@ TestbignumobjCmd( } break; - case BIGNUM_ISEVEN: + case BIGNUM_ISEVEN: { + mp_err err; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; @@ -293,13 +294,18 @@ TestbignumobjCmd( &bignumValue) != TCL_OK) { return TCL_ERROR; } + err = mp_mod_2d(&bignumValue, 1, &bignumValue); + if (err == MP_OKAY && !mp_iszero(&bignumValue)) { + err = MP_ERR; + } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], !mp_isodd(&bignumValue)); + Tcl_SetIntObj(varPtr[varIndex], err == MP_OKAY); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(!mp_isodd(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(err == MP_OKAY)); } mp_clear(&bignumValue); - break; + } + break; case BIGNUM_RADIXSIZE: if (objc != 3) { -- cgit v0.12 From f608fa90db6aa15217b86bf87e9d3c9358373195 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Jan 2020 09:27:09 +0000 Subject: Put "-ltommath" in $MATH_LIBS in stead of $LIBS, so it won't be used by other checks in the configure script. Suggested by Pietro Cerutti. --- unix/configure | 49 ++++++++++++++++--------------------------------- unix/configure.ac | 5 ++--- 2 files changed, 18 insertions(+), 36 deletions(-) diff --git a/unix/configure b/unix/configure index 04f1dbc..1098ba8 100755 --- a/unix/configure +++ b/unix/configure @@ -4681,12 +4681,13 @@ fi if test $libtommath_ok = yes; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing mp_log_u32" >&5 -$as_echo_n "checking for library containing mp_log_u32... " >&6; } -if ${ac_cv_search_mp_log_u32+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mp_log_u32 in -ltommath" >&5 +$as_echo_n "checking for mp_log_u32 in -ltommath... " >&6; } +if ${ac_cv_lib_tommath_mp_log_u32+:} false; then : $as_echo_n "(cached) " >&6 else - ac_func_search_save_LIBS=$LIBS + ac_check_lib_save_LIBS=$LIBS +LIBS="-ltommath $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -4705,40 +4706,22 @@ return mp_log_u32 (); return 0; } _ACEOF -for ac_lib in '' tommath; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_mp_log_u32=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_mp_log_u32+:} false; then : - break -fi -done -if ${ac_cv_search_mp_log_u32+:} false; then : - +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_tommath_mp_log_u32=yes else - ac_cv_search_mp_log_u32=no + ac_cv_lib_tommath_mp_log_u32=no fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_mp_log_u32" >&5 -$as_echo "$ac_cv_search_mp_log_u32" >&6; } -ac_res=$ac_cv_search_mp_log_u32 -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tommath_mp_log_u32" >&5 +$as_echo "$ac_cv_lib_tommath_mp_log_u32" >&6; } +if test "x$ac_cv_lib_tommath_mp_log_u32" = xyes; then : + MATH_LIBS="$MATH_LIBS -ltommath" else - libtommath_ok=no - + libtommath_ok=no fi fi diff --git a/unix/configure.ac b/unix/configure.ac index f0ba688..b893d1a 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -180,9 +180,8 @@ if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ libtommath_ok=no]) AS_IF([test $libtommath_ok = yes], [ - AC_SEARCH_LIBS([mp_log_u32],[tommath],[],[ - libtommath_ok=no - ])]) + AC_CHECK_LIB([tommath],[mp_log_u32],[MATH_LIBS="$MATH_LIBS -ltommath"],[ + libtommath_ok=no])]) fi AS_IF([test $libtommath_ok = yes], [ AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) -- cgit v0.12 From 2d27c96b7eebdceae93e88adf3ca88ebbc6efab5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Jan 2020 15:18:36 +0000 Subject: tommath_private.h : Remove special C4146 handling: already done in tclWinPort.h too. tcl.pc.in: Make sure that libtommath >= 1.2.0 --- libtommath/tommath_private.h | 4 ---- unix/tcl.pc.in | 2 +- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/libtommath/tommath_private.h b/libtommath/tommath_private.h index 072d603..5123f53 100644 --- a/libtommath/tommath_private.h +++ b/libtommath/tommath_private.h @@ -276,10 +276,6 @@ MP_DEPRECATED(s_mp_reverse) void bn_reverse(unsigned char *s, int len); MP_ZERO_DIGITS(a->dp + a->used, a->alloc - a->used); \ } -#ifdef _MSC_VER -/* Prevent false positive: unary minus operator applied to unsigned type, result still unsigned */ -#pragma warning(disable: 4146) -#endif #define MP_SET_SIGNED(name, uname, type, utype) \ void name(mp_int * a, type b) \ { \ diff --git a/unix/tcl.pc.in b/unix/tcl.pc.in index ca932d2..a343707 100644 --- a/unix/tcl.pc.in +++ b/unix/tcl.pc.in @@ -11,7 +11,7 @@ Name: Tool Command Language Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses. URL: http://www.tcl.tk/ Version: @TCL_VERSION@@TCL_PATCH_LEVEL@ -Requires.private: zlib >= 1.2.3 +Requires.private: zlib >= 1.2.3, libtommath >= 1.2.0 Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@ Libs.private: @TCL_LIBS@ Cflags: -I${includedir} -- cgit v0.12 From f3070aa2fc9c742281213b21139e15bc9516c018 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jan 2020 10:00:03 +0000 Subject: Silence some gcc-9 compiler warnings. --- generic/tclIOUtil.c | 4 ++-- generic/tclStubInit.c | 18 +++++++++--------- unix/tclUnixThrd.c | 4 ++-- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 4235c3e..7c2c478 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -184,7 +184,7 @@ const Tcl_Filesystem tclNativeFilesystem = { TclpObjCopyDirectory, TclpObjLstat, /* Needs casts since we're using version_2. */ - (Tcl_FSLoadFileProc *) TclpDlopen, + (Tcl_FSLoadFileProc *)(void *) TclpDlopen, (Tcl_FSGetCwdProc *) TclpGetNativeCwd, TclpObjChdir }; @@ -3244,7 +3244,7 @@ Tcl_LoadFile( } if (fsPtr->loadFileProc != NULL) { - int retVal = ((Tcl_FSLoadFileProc2 *)(fsPtr->loadFileProc)) + int retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc)) (interp, pathPtr, handlePtr, &unloadProcPtr, flags); if (retVal == TCL_OK) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index aae02ba..553fa98 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -358,7 +358,7 @@ Tcl_WinTCharToUtf( * signature. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ -#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj) +#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))(void *)dbNewLongObj) static Tcl_Obj *dbNewLongObj( int intValue, const char *file, @@ -377,9 +377,9 @@ static Tcl_Obj *dbNewLongObj( return Tcl_NewIntObj(intValue); #endif } -#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj -#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj -#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj +#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetIntFromObj +#define Tcl_NewLongObj (Tcl_Obj*(*)(long))(void *)Tcl_NewIntObj +#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))(void *)Tcl_SetIntObj static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ long longValue; int result = Tcl_ExprLong(interp, expr, &longValue); @@ -415,23 +415,23 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } -#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcmp +#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcmp static int utfNcmp(const char *s1, const char *s2, unsigned int n){ return Tcl_UtfNcmp(s1, s2, (unsigned long)n); } -#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))utfNcmp +#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcmp static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n); } -#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp +#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcasecmp static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); } -#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp +#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcasecmp static int formatInt(char *buffer, int n){ return TclFormatInt(buffer, (long)n); } -#define TclFormatInt (int(*)(char *, long))formatInt +#define TclFormatInt (int(*)(char *, long))(void *)formatInt #endif diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 0609230..ef8e737 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -119,9 +119,9 @@ TclpThreadCreate( } if (pthread_create(&theThread, &attr, - (void * (*)(void *))proc, (void *)clientData) && + (void * (*)(void *))(void *)proc, (void *)clientData) && pthread_create(&theThread, NULL, - (void * (*)(void *))proc, (void *)clientData)) { + (void * (*)(void *))(void *)proc, (void *)clientData)) { result = TCL_ERROR; } else { *idPtr = (Tcl_ThreadId)theThread; -- cgit v0.12 From 997e0f35053f350509dbfe16b32af27264622c5e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jan 2020 10:01:30 +0000 Subject: Fix [0b9332722a]: Support utf-8 on Windows console --- win/tclWinInit.c | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/win/tclWinInit.c b/win/tclWinInit.c index cb13b20..02471a6 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -510,10 +510,16 @@ const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { + UINT acp = GetACP(); + Tcl_DStringInit(bufPtr); - Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE); - wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); - Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); + if (acp == CP_UTF8) { + Tcl_DStringAppend(bufPtr, "utf-8", 5); + } else { + Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE); + wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); + Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); + } return Tcl_DStringValue(bufPtr); } -- cgit v0.12 From 6a4eb9df57b905743efaed8104685a8999f7b4a6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jan 2020 12:17:09 +0000 Subject: =?UTF-8?q?Add=20${LDFLAGS}=20to=20MAKE=5FLIB.=20This=20handles=20?= =?UTF-8?q?the=20possibility=20of=20adding=20LDFLAGS=3D=3F=3F=20on=20the?= =?UTF-8?q?=20"configure"=20commandline.=20Suggested=20by=20Pietro=20Cerut?= =?UTF-8?q?ti.=20Thanks!?= --- unix/configure | 2 +- unix/tcl.m4 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index f48f5a4..8999e28 100755 --- a/unix/configure +++ b/unix/configure @@ -8749,7 +8749,7 @@ fi if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' if test "${SHLIB_SUFFIX}" = ".dll"; then INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' diff --git a/unix/tcl.m4 b/unix/tcl.m4 index de2cfad..a4cdbbd 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2030,7 +2030,7 @@ dnl # preprocessing tests use only CPPFLAGS. AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" -- cgit v0.12 From 46a6094df77d17ee72850329800059e5555f8c01 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jan 2020 15:19:08 +0000 Subject: Fix [cff53cf7d0]: Failed test oo-0.9 in file oo.test in Tcl8.6.10 --- tests/oo.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 77fca68..065c017 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -113,8 +113,8 @@ test oo-0.8 {leak in variable management} -setup { } -result 0 test oo-0.9 {various types of presence of the TclOO package} { list [lsearch -nocase -all -inline [package names] tcloo] \ - [package present TclOO] [package versions TclOO] -} [list TclOO $::oo::patchlevel $::oo::patchlevel] + [package present TclOO] [expr {$::oo::patchlevel in [package versions TclOO]}] +} [list TclOO $::oo::patchlevel 1] test oo-1.1 {basic test of OO functionality: no classes} { set result {} -- cgit v0.12 From 9b0b0dc37dd6a3276ce3b0425e64e1bec8660aec Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 13 Jan 2020 17:00:21 +0000 Subject: Implement TIP 559 (deprecation part). --- generic/tcl.decls | 2 +- generic/tclDecls.h | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 528938d..e033961 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -523,7 +523,7 @@ declare 145 { declare 146 { int Tcl_Flush(Tcl_Channel chan) } -declare 147 { +declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ed1da85..08e46a6 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -478,7 +478,8 @@ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); /* 147 */ -EXTERN void Tcl_FreeResult(Tcl_Interp *interp); +TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult") +void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, @@ -2087,7 +2088,7 @@ typedef struct TclStubs { TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_FindExecutable) (const char *argv0); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ - void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ + TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ -- cgit v0.12 From c6135def08ea1be2a47763a2877362b258cc3b90 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jan 2020 21:46:18 +0000 Subject: Attempt to resolve a conflict between (unmodified) tommath.h and tcl.h in the definition of mp_int. See: [https://github.com/libtom/libtommath/pull/473] --- generic/tcl.decls | 12 ++++++------ generic/tcl.h | 11 ++++++++++- generic/tclDecls.h | 24 ++++++++++++------------ generic/tclInt.h | 12 ++++++------ generic/tclObj.c | 22 ++++++++++++---------- generic/tclStrToD.c | 12 ++++++++---- 6 files changed, 54 insertions(+), 39 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 528938d..df7572b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2009,19 +2009,19 @@ declare 554 { # TIP#237 (arbitrary-precision integers) kbk declare 555 { - Tcl_Obj *Tcl_NewBignumObj(mp_int *value) + Tcl_Obj *Tcl_NewBignumObj(void *value) } declare 556 { - Tcl_Obj *Tcl_DbNewBignumObj(mp_int *value, const char *file, int line) + Tcl_Obj *Tcl_DbNewBignumObj(void *value, const char *file, int line) } declare 557 { - void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value) + void Tcl_SetBignumObj(Tcl_Obj *obj, void *value) } declare 558 { - int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value) + int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value) } declare 559 { - int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value) + int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value) } # TIP #208 ('chan' command) jeffh @@ -2050,7 +2050,7 @@ declare 565 { # TIP #237 (additional conversion functions for bignum support) kbk/dgp declare 566 { int Tcl_InitBignumFromDouble(Tcl_Interp *interp, double initval, - mp_int *toInit) + void *toInit) } # TIP#181 (namespace unknown command) dgp for Neil Madden diff --git a/generic/tcl.h b/generic/tcl.h index 8a81d9e..73d13ad 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2168,9 +2168,16 @@ typedef struct Tcl_Config { typedef void (Tcl_LimitHandlerProc) (ClientData clientData, Tcl_Interp *interp); typedef void (Tcl_LimitHandlerDeleteProc) (ClientData clientData); +#if 0 /* *---------------------------------------------------------------------------- - * Override definitions for libtommath. + * We would like to provide an anonymous structure "mp_int" here, which is + * compatible with libtommath's "mp_int", but without duplicating anything + * from or including here. But the libtommath project + * didn't honor our request. See: + * + * That's why this part is commented out, and we are using (void *) in + * various API's in stead of the more correct (mp_int *). */ #ifndef MP_INT_DECLARED @@ -2178,6 +2185,8 @@ typedef void (Tcl_LimitHandlerDeleteProc) (ClientData clientData); typedef struct mp_int mp_int; #endif +#endif + /* *---------------------------------------------------------------------------- * Definitions needed for Tcl_ParseArgvObj routines. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ed1da85..bbb108f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1644,18 +1644,18 @@ EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr); /* 555 */ -EXTERN Tcl_Obj * Tcl_NewBignumObj(mp_int *value); +EXTERN Tcl_Obj * Tcl_NewBignumObj(void *value); /* 556 */ -EXTERN Tcl_Obj * Tcl_DbNewBignumObj(mp_int *value, const char *file, +EXTERN Tcl_Obj * Tcl_DbNewBignumObj(void *value, const char *file, int line); /* 557 */ -EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value); +EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, void *value); /* 558 */ EXTERN int Tcl_GetBignumFromObj(Tcl_Interp *interp, - Tcl_Obj *obj, mp_int *value); + Tcl_Obj *obj, void *value); /* 559 */ EXTERN int Tcl_TakeBignumFromObj(Tcl_Interp *interp, - Tcl_Obj *obj, mp_int *value); + Tcl_Obj *obj, void *value); /* 560 */ EXTERN int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length); @@ -1674,7 +1674,7 @@ EXTERN void Tcl_SetChannelError(Tcl_Channel chan, Tcl_Obj *msg); EXTERN void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg); /* 566 */ EXTERN int Tcl_InitBignumFromDouble(Tcl_Interp *interp, - double initval, mp_int *toInit); + double initval, void *toInit); /* 567 */ EXTERN Tcl_Obj * Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp, Tcl_Namespace *nsPtr); @@ -2503,18 +2503,18 @@ typedef struct TclStubs { void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, ClientData clientData); /* 552 */ void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, ClientData *clientData); /* 553 */ Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) (const Tcl_ChannelType *chanTypePtr); /* 554 */ - Tcl_Obj * (*tcl_NewBignumObj) (mp_int *value); /* 555 */ - Tcl_Obj * (*tcl_DbNewBignumObj) (mp_int *value, const char *file, int line); /* 556 */ - void (*tcl_SetBignumObj) (Tcl_Obj *obj, mp_int *value); /* 557 */ - int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 558 */ - int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 559 */ + Tcl_Obj * (*tcl_NewBignumObj) (void *value); /* 555 */ + Tcl_Obj * (*tcl_DbNewBignumObj) (void *value, const char *file, int line); /* 556 */ + void (*tcl_SetBignumObj) (Tcl_Obj *obj, void *value); /* 557 */ + int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 558 */ + int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 559 */ int (*tcl_TruncateChannel) (Tcl_Channel chan, Tcl_WideInt length); /* 560 */ Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) (const Tcl_ChannelType *chanTypePtr); /* 561 */ void (*tcl_SetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj *msg); /* 562 */ void (*tcl_GetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj **msg); /* 563 */ void (*tcl_SetChannelError) (Tcl_Channel chan, Tcl_Obj *msg); /* 564 */ void (*tcl_GetChannelError) (Tcl_Channel chan, Tcl_Obj **msg); /* 565 */ - int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, mp_int *toInit); /* 566 */ + int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, void *toInit); /* 566 */ Tcl_Obj * (*tcl_GetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr); /* 567 */ int (*tcl_SetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); /* 568 */ int (*tcl_GetEncodingFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); /* 569 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 8b150db..aa695a5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2914,11 +2914,11 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); -MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); +MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, int strLen, const unsigned char *pattern, int ptnLen, int flags); -MODULE_SCOPE double TclCeil(const mp_int *a); +MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, @@ -3001,7 +3001,7 @@ MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); MODULE_SCOPE void TclFinalizeThreadObjects(void); -MODULE_SCOPE double TclFloor(const mp_int *a); +MODULE_SCOPE double TclFloor(const void *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); @@ -3058,8 +3058,8 @@ MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); -MODULE_SCOPE void TclInitBignumFromWideInt(mp_int *, Tcl_WideInt); -MODULE_SCOPE void TclInitBignumFromWideUInt(mp_int *, Tcl_WideUInt); +MODULE_SCOPE void TclInitBignumFromWideInt(void *, Tcl_WideInt); +MODULE_SCOPE void TclInitBignumFromWideUInt(void *, Tcl_WideUInt); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( @@ -3194,7 +3194,7 @@ MODULE_SCOPE int TclScanElement(const char *string, int length, MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, - mp_int *bignumValue); + void *bignumValue); MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, diff --git a/generic/tclObj.c b/generic/tclObj.c index eb9334e..a5797eb 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3492,14 +3492,14 @@ UpdateStringOfBignum( Tcl_Obj * Tcl_NewBignumObj( - mp_int *bignumValue) + void *bignumValue) { return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); } #else Tcl_Obj * Tcl_NewBignumObj( - mp_int *bignumValue) + void *bignumValue) { Tcl_Obj *objPtr; @@ -3530,7 +3530,7 @@ Tcl_NewBignumObj( #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBignumObj( - mp_int *bignumValue, + void *bignumValue, const char *file, int line) { @@ -3543,7 +3543,7 @@ Tcl_DbNewBignumObj( #else Tcl_Obj * Tcl_DbNewBignumObj( - mp_int *bignumValue, + void *bignumValue, const char *file, int line) { @@ -3651,9 +3651,9 @@ int Tcl_GetBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - mp_int *bignumValue) /* Returned bignum value. */ + void *bignumValue) /* Returned bignum value. */ { - return GetBignumFromObj(interp, objPtr, 1, bignumValue); + return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue); } /* @@ -3686,9 +3686,9 @@ int Tcl_TakeBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - mp_int *bignumValue) /* Returned bignum value. */ + void *bignumValue) /* Returned bignum value. */ { - return GetBignumFromObj(interp, objPtr, 0, bignumValue); + return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue); } /* @@ -3711,12 +3711,13 @@ Tcl_TakeBignumFromObj( void Tcl_SetBignumObj( Tcl_Obj *objPtr, /* Object to set */ - mp_int *bignumValue) /* Value to store */ + void *big) /* Value to store */ { Tcl_WideUInt value = 0; size_t numBytes; Tcl_WideUInt scratch; unsigned char *bytes = (unsigned char *) &scratch; + mp_int *bignumValue = (mp_int *) big; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); @@ -3764,8 +3765,9 @@ Tcl_SetBignumObj( void TclSetBignumIntRep( Tcl_Obj *objPtr, - mp_int *bignumValue) + void *big) { + mp_int *bignumValue = (mp_int *)big; objPtr->typePtr = &tclBignumType; PACK_BIGNUM(*bignumValue, objPtr); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 8939fa0..3c80afc 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -4553,10 +4553,11 @@ int Tcl_InitBignumFromDouble( Tcl_Interp *interp, /* For error message. */ double d, /* Number to convert. */ - mp_int *b) /* Place to store the result. */ + void *big) /* Place to store the result. */ { double fract; int expt; + mp_int *b = (mp_int *)big; /* * Infinite values can't convert to bignum. @@ -4607,11 +4608,12 @@ Tcl_InitBignumFromDouble( double TclBignumToDouble( - const mp_int *a) /* Integer to convert. */ + const void *big) /* Integer to convert. */ { mp_int b; int bits, shift, i, lsb; double r; + const mp_int *a = (const mp_int *)big; /* @@ -4720,10 +4722,11 @@ TclBignumToDouble( double TclCeil( - const mp_int *a) /* Integer to convert. */ + const void *big) /* Integer to convert. */ { double r = 0.0; mp_int b; + const mp_int *a = (const mp_int *)big; mp_init(&b); if (mp_isneg(a)) { @@ -4777,10 +4780,11 @@ TclCeil( double TclFloor( - const mp_int *a) /* Integer to convert. */ + const void *big) /* Integer to convert. */ { double r = 0.0; mp_int b; + const mp_int *a = (const mp_int *)big; mp_init(&b); if (mp_isneg(a)) { -- cgit v0.12 From 939c35f568c60a0b485f9b6d27ef3d0a9ff0fee9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jan 2020 09:09:50 +0000 Subject: A few more "break" statements, so any compiler knows these are no FALLTHROUGH situations. --- generic/tclExecute.c | 41 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 40 insertions(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8bc83cc..0a4d1f0 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -317,12 +317,16 @@ VarHashCreateVar( switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE1: \ NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + break; \ case INST_JUMP_FALSE4: \ NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE4: \ NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -330,6 +334,7 @@ VarHashCreateVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F(0, (cleanup), 1); \ + break; \ } \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ @@ -338,12 +343,16 @@ VarHashCreateVar( switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE1: \ NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + break; \ case INST_JUMP_FALSE4: \ NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE4: \ NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -351,6 +360,7 @@ VarHashCreateVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V(0, (cleanup), 1); \ + break; \ } \ } while (0) #else /* TCL_COMPILE_DEBUG */ @@ -2576,23 +2586,27 @@ TEBCresume( objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); NEXT_INST_F(5, 0, 1); + break; case INST_POP: TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); NEXT_INST_F(1, 0, 0); + break; case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_OVER: opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); + break; case INST_REVERSE: { Tcl_Obj **a, **b; @@ -2623,6 +2637,7 @@ TEBCresume( TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); + break; case INST_CONCAT_STK: /* @@ -2634,6 +2649,7 @@ TEBCresume( objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1)); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(5, opnd, 1); + break; case INST_EXPAND_START: /* @@ -2655,6 +2671,7 @@ TEBCresume( PUSH_TAUX_OBJ(objPtr); TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); NEXT_INST_F(1, 0, 0); + break; case INST_EXPAND_DROP: /* @@ -2672,6 +2689,7 @@ TEBCresume( #endif TRACE(("=> drop %d items\n", objc)); NEXT_INST_V(1, objc, 0); + break; case INST_EXPAND_STKTOP: { int i; @@ -2781,6 +2799,7 @@ TEBCresume( TclNewObj(objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); @@ -4262,12 +4281,14 @@ TEBCresume( TRACE(("%d => new pc %u\n", opnd, (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); + break; case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); + break; { int jmpOffset[2], b; @@ -4431,6 +4452,7 @@ TEBCresume( TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_INFO_LEVEL_ARGS: { int level; CallFrame *framePtr = iPtr->varFramePtr; @@ -4461,6 +4483,7 @@ TEBCresume( objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); + break; } { Tcl_Command cmd, origCmd; @@ -4473,6 +4496,7 @@ TEBCresume( } TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); + break; case INST_ORIGIN_COMMAND: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); @@ -4495,6 +4519,7 @@ TEBCresume( Tcl_GetCommandFullName(interp, origCmd, objResultPtr); TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); NEXT_INST_F(1, 1, 1); + break; } /* @@ -6092,6 +6117,7 @@ TEBCresume( TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); + break; case INST_DIV: if (w2 == 0) { @@ -6231,6 +6257,7 @@ TEBCresume( /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); + break; case TCL_NUMBER_INT: w1 = *((const Tcl_WideInt *) ptr1); if (w1 != WIDE_MIN) { @@ -6253,6 +6280,7 @@ TEBCresume( TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } + break; case INST_UPLUS: case INST_TRY_CVT_TO_NUMERIC: @@ -6356,6 +6384,7 @@ TEBCresume( } TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_BREAK: /* @@ -6751,6 +6780,7 @@ TEBCresume( TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), (int) CURR_DEPTH)); NEXT_INST_F(5, 0, 0); + break; case INST_END_CATCH: catchTop--; @@ -6760,6 +6790,7 @@ TEBCresume( result = TCL_OK; TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); + break; case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); @@ -6773,11 +6804,13 @@ TEBCresume( Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); + break; case INST_PUSH_RETURN_CODE: TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); + break; case INST_PUSH_RETURN_OPTIONS: DECACHE_STACK_INFO(); @@ -6785,6 +6818,7 @@ TEBCresume( CACHE_STACK_INFO(); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_RETURN_CODE_BRANCH: { int code; @@ -6800,6 +6834,7 @@ TEBCresume( } TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); NEXT_INST_F(2*code-1, 1, 0); + break; } /* @@ -6824,6 +6859,7 @@ TEBCresume( } TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); + break; case INST_DICT_EXISTS: { int found; @@ -8823,6 +8859,7 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } + break; case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); @@ -8869,6 +8906,7 @@ TclCompareTwoNumbers( Tcl_InitBignumFromDouble(NULL, d1, &big1); goto bigCompare; } + break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -8905,10 +8943,11 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } + break; default: Tcl_Panic("unexpected number type"); - return TCL_ERROR; } + return TCL_ERROR; } #ifdef TCL_COMPILE_DEBUG -- cgit v0.12 From 9a78221b8d5ba5b146f65bdd50f611fa93aa82c9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Jan 2020 10:07:46 +0000 Subject: A few more "break" statements, so any compiler knows these are no FALLTHROUGH situations. --- generic/tclCompCmdsSZ.c | 1 + generic/tclExecute.c | 76 ++++++++++++++++++++++++++++++++++++++----------- generic/tclInterp.c | 2 ++ generic/tclStrToD.c | 1 + 4 files changed, 63 insertions(+), 17 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 1d59cc6..1ce4582 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -637,6 +637,7 @@ TclCompileStringIsCmd( OP( LNOT); return TCL_OK; } + break; case STR_IS_DOUBLE: { int satisfied, isEmpty; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3c2816c..171515d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -317,12 +317,16 @@ VarHashCreateVar( switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE1: \ NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + break; \ case INST_JUMP_FALSE4: \ NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE4: \ NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -330,6 +334,7 @@ VarHashCreateVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F(0, (cleanup), 1); \ + break; \ } \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ @@ -338,12 +343,16 @@ VarHashCreateVar( switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE1: \ NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + break; \ case INST_JUMP_FALSE4: \ NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE4: \ NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -351,6 +360,7 @@ VarHashCreateVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V(0, (cleanup), 1); \ + break; \ } \ } while (0) #else /* TCL_COMPILE_DEBUG */ @@ -2604,7 +2614,7 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG /* FIXME: What is the right thing to trace? */ { - register int i; + int i; TRACE(("%d [", opnd)); for (i=opnd-1 ; i>=0 ; i--) { @@ -2669,23 +2679,27 @@ TEBCresume( objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); NEXT_INST_F(5, 0, 1); + break; case INST_POP: TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); NEXT_INST_F(1, 0, 0); + break; case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_OVER: opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); + break; case INST_REVERSE: { Tcl_Obj **a, **b; @@ -2702,6 +2716,7 @@ TEBCresume( TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } + break; case INST_STR_CONCAT1: { int appendLen = 0; @@ -2883,6 +2898,7 @@ TEBCresume( PUSH_TAUX_OBJ(objPtr); TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); NEXT_INST_F(1, 0, 0); + break; case INST_EXPAND_DROP: /* @@ -2961,6 +2977,7 @@ TEBCresume( Tcl_DecrRefCount(objPtr); NEXT_INST_F(5, 0, 0); } + break; case INST_EXPR_STK: { ByteCode *newCodePtr; @@ -3008,6 +3025,7 @@ TEBCresume( TclNewObj(objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); @@ -4296,6 +4314,7 @@ TEBCresume( } NEXT_INST_F(5, 0, 0); } + break; /* * End of INST_UNSET instructions. @@ -4516,6 +4535,7 @@ TEBCresume( TRACE_APPEND(("link made\n")); NEXT_INST_F(5, 1, 0); } + break; /* * End of variable linking instructions. @@ -4527,6 +4547,7 @@ TEBCresume( TRACE(("%d => new pc %u\n", opnd, (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); + break; case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); @@ -4589,6 +4610,7 @@ TEBCresume( #endif NEXT_INST_F(jmpOffset[b], 1, 0); } + break; case INST_JUMP_TABLE: { Tcl_HashEntry *hPtr; @@ -4614,6 +4636,7 @@ TEBCresume( NEXT_INST_F(5, 1, 0); } } + break; /* * These two instructions are now redundant: the complete logic of the LOR @@ -4658,6 +4681,7 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); NEXT_INST_F(1, 2, 1); } + break; /* * ----------------------------------------------------------------- @@ -4676,6 +4700,7 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } + break; case INST_COROUTINE_NAME: { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; @@ -4687,14 +4712,16 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } + break; case INST_INFO_LEVEL_NUM: TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_INFO_LEVEL_ARGS: { int level; - register CallFrame *framePtr = iPtr->varFramePtr; - register CallFrame *rootFramePtr = iPtr->rootFramePtr; + CallFrame *framePtr = iPtr->varFramePtr; + CallFrame *rootFramePtr = iPtr->rootFramePtr; TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { @@ -4991,7 +5018,7 @@ TEBCresume( } { - register Method *const mPtr = + Method *const mPtr = contextPtr->callPtr->chain[newDepth].mPtr; return mPtr->typePtr->callProc(mPtr->clientData, interp, @@ -6248,6 +6275,7 @@ TEBCresume( lResult = l1 - l2*lResult; goto longResultOfArithmetic; } + break; case INST_RSHIFT: if (l2 < 0) { @@ -6296,6 +6324,7 @@ TEBCresume( lResult = l1 >> ((int) l2); goto longResultOfArithmetic; } + break; case INST_LSHIFT: if (l2 < 0) { @@ -6504,6 +6533,7 @@ TEBCresume( Tcl_SetWideIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); + break; case INST_DIV: if (l2 == 0) { @@ -6643,6 +6673,7 @@ TEBCresume( /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); + break; case TCL_NUMBER_LONG: l1 = *((const long *) ptr1); if (l1 != LONG_MIN) { @@ -6751,6 +6782,7 @@ TEBCresume( TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } + break; /* * End of numeric operator instructions. @@ -6767,6 +6799,7 @@ TEBCresume( } TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_BREAK: /* @@ -7146,6 +7179,7 @@ TEBCresume( Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); NEXT_INST_F(1, 1, 0); } + break; case INST_BEGIN_CATCH4: /* @@ -7159,6 +7193,7 @@ TEBCresume( TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), (int) CURR_DEPTH)); NEXT_INST_F(5, 0, 0); + break; case INST_END_CATCH: catchTop--; @@ -7168,6 +7203,7 @@ TEBCresume( result = TCL_OK; TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); + break; case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); @@ -7181,11 +7217,13 @@ TEBCresume( Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); + break; case INST_PUSH_RETURN_CODE: TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); + break; case INST_PUSH_RETURN_OPTIONS: DECACHE_STACK_INFO(); @@ -7193,6 +7231,7 @@ TEBCresume( CACHE_STACK_INFO(); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_RETURN_CODE_BRANCH: { int code; @@ -7816,6 +7855,7 @@ TEBCresume( TRACE_APPEND(("OK\n")); NEXT_INST_F(5, 2, 0); } + break; /* * End of dictionary-related instructions. @@ -7849,11 +7889,11 @@ TEBCresume( default: Tcl_Panic("clockRead instruction with unknown clock#"); } - /* TclNewWideObj(objResultPtr, wval); doesn't exist */ objResultPtr = Tcl_NewWideIntObj(wval); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(2, 0, 1); } + break; default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); @@ -8521,7 +8561,7 @@ ExecuteExtendedBinaryMathOp( mp_init(&bigResult); mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); - if ((bigRemainder.used) != 0 && (bigRemainder.sign != big2.sign)) { + if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* * Convert to Tcl's integer division rules. */ @@ -8852,7 +8892,6 @@ ExecuteExtendedBinaryMathOp( type1 = TCL_NUMBER_LONG; goto pwrLongBase; } - break; #endif } if (negativeExponent) { @@ -8861,7 +8900,6 @@ ExecuteExtendedBinaryMathOp( * Integers with magnitude greater than 1 raise to a negative * power yield the answer zero (see TIP 123). */ - return constants[0]; } @@ -9245,7 +9283,7 @@ ExecuteExtendedUnaryMathOp( #endif Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ - mp_neg(&big, &big); + (void)mp_neg(&big, &big); mp_sub_d(&big, 1, &big); BIG_RESULT(&big); case INST_UMINUS: @@ -9271,7 +9309,7 @@ ExecuteExtendedUnaryMathOp( default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } - mp_neg(&big, &big); + (void)mp_neg(&big, &big); BIG_RESULT(&big); } @@ -9377,6 +9415,7 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } + break; #ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: @@ -9407,7 +9446,7 @@ TclCompareTwoNumbers( goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; @@ -9415,6 +9454,7 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } + break; #endif case TCL_NUMBER_DOUBLE: @@ -9462,7 +9502,7 @@ TclCompareTwoNumbers( } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; @@ -9479,6 +9519,7 @@ TclCompareTwoNumbers( Tcl_InitBignumFromDouble(NULL, d1, &big1); goto bigCompare; } + break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -9518,10 +9559,11 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } + break; default: Tcl_Panic("unexpected number type"); - return TCL_ERROR; } + return TCL_ERROR; } #ifdef TCL_COMPILE_DEBUG @@ -9690,12 +9732,12 @@ IllegalExprOperandType( ClientData ptr; int type; const unsigned char opcode = *pc; - const char *description, *operator = "unknown"; + const char *description, *op = "unknown"; if (opcode == INST_EXPON) { - operator = "**"; + op = "**"; } else if (opcode <= INST_LNOT) { - operator = operatorStrings[opcode - INST_LOR]; + op = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { @@ -9719,7 +9761,7 @@ IllegalExprOperandType( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%s\"", description, operator)); + "can't use %s as operand of \"%s\"", description, op)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8a0d653..ac66324 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -987,6 +987,7 @@ NRInterpCmd( return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } } + break; case OPT_MARKTRUSTED: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); @@ -2621,6 +2622,7 @@ NRSlaveCmd( return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); } } + break; case OPT_MARKTRUSTED: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index b9026cd..16eca19 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -841,6 +841,7 @@ TclParseNumber( acceptState = state; acceptPoint = p; acceptLen = len; + /* FALLTHRU */ case ZERO_B: zerob: if (c == '0') { -- cgit v0.12 From d59509dee2c55942e56ff0f8b540d00c78a99b86 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Jan 2020 14:16:48 +0000 Subject: Proposed fix for [8cd2fe7474]: "unload" command Bug (when handling multiple libs) --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index f1bd248..dfa657e 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -871,7 +871,7 @@ Tcl_UnloadObjCmd( for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->pkgPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } -- cgit v0.12 From eb08a10e38e909d85338f6375638efa08bf0c639 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Jan 2020 08:51:38 +0000 Subject: Fix [8cd2fe7474]: "unload" command Bug (when handling multiple libs) --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index ac863b9..2891884 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -834,7 +834,7 @@ Tcl_UnloadObjCmd( for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->pkgPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } -- cgit v0.12 From 35ec25a6cf7c2686aa9b6b972403788937b6f6fd Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 17 Jan 2020 16:12:06 +0000 Subject: closes [5d989f9ba3]: avoid segfault by OOM if too many items to sort (would throw an error instead, and use system alloc for long elementArray due to size_t); added test cases covering that (in child process with limited address space, if "prlimit" available) --- generic/tclCmdIL.c | 22 ++++++++++++++++++++-- tests/cmdIL.test | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+), 2 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b303bb6..630aa70 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3477,6 +3477,7 @@ Tcl_LsortObjCmd( int i, j, index, indices, length, nocase = 0, indexc; int sortMode = SORTMODE_ASCII; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; + size_t elmArrSize; SortElement *elementArray, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ @@ -3494,6 +3495,7 @@ Tcl_LsortObjCmd( * The subList array below holds pointers to temporary lists built during * the merge sort. Element i of the array holds a list of length 2**i. */ +# define MAXCALLOC 1024000 # define NUM_LISTS 30 SortElement *subList[NUM_LISTS+1]; @@ -3699,7 +3701,19 @@ Tcl_LsortObjCmd( * begins sorting it into the sublists as it appears. */ - elementArray = (SortElement *) ckalloc( length * sizeof(SortElement)); + elmArrSize = length * sizeof(SortElement); + if (elmArrSize <= MAXCALLOC) { + elementArray = (SortElement *) ckalloc(elmArrSize); + } else { + elementArray = (SortElement *) malloc(elmArrSize); + } + if (!elementArray) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no enough memory to proccess sort of %d items", length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done; + } for (i=0; i < length; i++){ if (indexc) { @@ -3802,7 +3816,11 @@ Tcl_LsortObjCmd( } done1: - ckfree((char *)elementArray); + if (elmArrSize <= MAXCALLOC) { + ckfree((char *)elementArray); + } else { + free((char *)elementArray); + } done: if (sortMode == SORTMODE_COMMAND) { diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 6fab269..b743b35 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -15,6 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +testConstraint prlimit [expr {[testConstraint macOrUnix] && ![catch { exec prlimit -n }]}] test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { list [catch {lsort} msg] $msg @@ -445,6 +446,38 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } -result 0 -cleanup { rename test_lsort "" } +test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { + # test it in child process (with limited address space): + set pipe {} + if {[catch { + set pipe [open |[list [interpreter]] r+] + exec prlimit -p [pid $pipe] --as=80000000 + } msg]} { + catch {close $pipe} + tcltest::Skip "prlimit: set of limit is impossible, [regsub {^\s*([^\n]*).*$} $msg {\1}]" + } + # if no error (enough memory), or error by list creation - add it as skipped test: + if {![catch { + chan configure $pipe -buffering line + puts $pipe { + # test + set l [lrepeat 4000000 ""] + puts [llength [lsort $l]] + exit + } + set result [read $pipe] + close $pipe + set pipe {} + set result + } result] || [regexp {^(?:list creation failed|unable to alloc)} $result]} { + tcltest::Skip "prlimit: too small or too large AS-limit, result: $result" + } + set result + # expecting error no memory by sort +} -cleanup { + if {$pipe ne ""} { catch { close $pipe } } + unset -nocomplain pipe line result +} -result {no enough memory to proccess sort of 4000000 items} # Compiled version test cmdIL-6.1 {lassign command syntax} -body { -- cgit v0.12 From a3728e6d82a95897084c458b48661f468c14e724 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 17 Jan 2020 16:40:37 +0000 Subject: small amend (skip messages, avoid output on interactive shell) --- tests/cmdIL.test | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/tests/cmdIL.test b/tests/cmdIL.test index b743b35..fabedea 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -454,14 +454,15 @@ test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { exec prlimit -p [pid $pipe] --as=80000000 } msg]} { catch {close $pipe} - tcltest::Skip "prlimit: set of limit is impossible, [regsub {^\s*([^\n]*).*$} $msg {\1}]" + tcltest::Skip "prlimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" } # if no error (enough memory), or error by list creation - add it as skipped test: if {![catch { chan configure $pipe -buffering line puts $pipe { - # test - set l [lrepeat 4000000 ""] + # create list and get length (avoid too long output in interactive shells): + llength [set l [lrepeat 4000000 ""]] + # test OOM: puts [llength [lsort $l]] exit } @@ -470,7 +471,7 @@ test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { set pipe {} set result } result] || [regexp {^(?:list creation failed|unable to alloc)} $result]} { - tcltest::Skip "prlimit: too small or too large AS-limit, result: $result" + tcltest::Skip "prlimit: wrong AS-limit, result: $result" } set result # expecting error no memory by sort -- cgit v0.12 From a3906f4953e88e646a9034649dbeb6db3624c99b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jan 2020 14:35:25 +0000 Subject: Don't deprecate Tcl_NewUnicodeObj/Tcl_SetUnicodeObj/Tcl_GetUnicodeFromObj, since that's not according to TIP #542. (Those are only deprecated when using TCL_UTF_MAX=4, not in the general case) --- generic/tcl.decls | 6 +++--- generic/tclDecls.h | 15 ++++++--------- generic/tclTestObj.c | 8 ++++++++ 3 files changed, 17 insertions(+), 12 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 0587088..5516f89 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1337,10 +1337,10 @@ declare 376 { declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } -declare 378 {deprecated {Use Tcl_UniCharToUtfDString}} { +declare 378 { Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars) } -declare 379 {deprecated {Use Tcl_UniCharToUtfDString}} { +declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars) } @@ -1540,7 +1540,7 @@ declare 433 { } # introduced in 8.4a3 -declare 434 {deprecated {Use Tcl_UtfToUniCharDString}} { +declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 75b9c01..b2b7767 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1143,12 +1143,10 @@ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ -TCL_DEPRECATED("Use Tcl_UniCharToUtfDString") -Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars); /* 379 */ -TCL_DEPRECATED("Use Tcl_UniCharToUtfDString") -void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, +EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); @@ -1304,8 +1302,7 @@ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ -TCL_DEPRECATED("Use Tcl_UtfToUniCharDString") -Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, +EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ TCL_DEPRECATED("") @@ -2334,8 +2331,8 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - TCL_DEPRECATED_API("Use Tcl_UniCharToUtfDString") Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ - TCL_DEPRECATED_API("Use Tcl_UniCharToUtfDString") void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ @@ -2390,7 +2387,7 @@ typedef struct TclStubs { char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ - TCL_DEPRECATED_API("Use Tcl_UtfToUniCharDString") Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ + Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index e616433..ced860e 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -25,6 +25,14 @@ #endif #include "tclStringRep.h" +#ifdef __GNUC__ +/* + * The rest of this file shouldn't warn about deprecated functions; they're + * there because we intend them to be so and know that this file is OK to + * touch those fields. + */ +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif /* * Forward declarations for functions defined later in this file: -- cgit v0.12 From e403afa147df4b621cd59679f6d3ab18e2b00f1f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jan 2020 15:27:47 +0000 Subject: Now that TIP #538 is integrated, make rules.vc work for both 8.6 and 8.7 without changes. --- win/rules.vc | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/win/rules.vc b/win/rules.vc index c0deb2a..5060805 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1323,6 +1323,11 @@ OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD +!elseif $(TCL_VERSION) > 86 +OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH +!if "$(MACHINE)" == "AMD64" +OPTDEFINES = $(OPTDEFINES) /DMP_64BIT +!endif !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED -- cgit v0.12 From 0f71efe445ad4662978569586156bba150cef23c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Jan 2020 08:48:17 +0000 Subject: Don't run stack-3.1 test on OSX, it fail regulary. Don't really bother for Tcl 8.5 any more. --- tests/stack.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/stack.test b/tests/stack.test index 62c3e98..2cc9d47 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -12,6 +12,8 @@ package require tcltest 2 namespace import ::tcltest::* +testConstraint noOsx [expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}] + # Note that a failure in this test results in a crash of the executable. # In order to avoid that, we do a basic check of the current stacksize. # This size can be changed with ulimit (ksh/bash/sh) or limit (csh/tcsh). @@ -68,7 +70,7 @@ test stack-2.1 {maxNestingDepth reached on infinite recursion} -constraints { # Make sure that there is enough stack to run regexp even if we're # close to the recursion limit. [Bug 947070] [Patch 746378] -test stack-3.1 {enough room for regexp near recursion limit} -body { +test stack-3.1 {enough room for regexp near recursion limit} -constraints noOsx -body { # do this in a sub process in case it segfaults exec [interpreter] << { interp recursionlimit {} 10000 -- cgit v0.12 From ad096310ec004ae12fc9509dd5cb891146eb3520 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jan 2020 08:29:26 +0000 Subject: Last unused internal stub entry from 258 to 259. --- generic/tclInt.decls | 31 +++++++++++++++---------------- generic/tclIntDecls.h | 9 ++++++--- generic/tclStubInit.c | 3 ++- 3 files changed, 23 insertions(+), 20 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 2b3b89d..93a436a 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -73,7 +73,7 @@ declare 11 { 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) @@ -88,7 +88,7 @@ declare 14 { 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[]) #} @@ -123,7 +123,7 @@ declare 25 { # 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) @@ -147,7 +147,7 @@ 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) #} @@ -184,9 +184,9 @@ declare 41 { declare 42 { 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 TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 44 { @@ -219,9 +219,9 @@ declare 50 { 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 TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { @@ -272,7 +272,7 @@ 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) @@ -378,9 +378,9 @@ declare 92 { 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 TclProcInterpProc(void *clientData, Tcl_Interp *interp, # int argc, const char **argv) #} # Replaced by Tcl_FSStat in 8.4: @@ -553,7 +553,7 @@ declare 138 { #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, # char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) +# Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr) #} #declare 140 { # int TclLooksLikeInt(const char *bytes, int length) @@ -608,11 +608,11 @@ declare 153 { # moved to tclTest.c (static) in 8.3.2/8.4a2 #declare 154 { -# int TclTestChannelCmd(ClientData clientData, +# int TclTestChannelCmd(void *clientData, # Tcl_Interp *interp, int argc, char **argv) #} #declare 155 { -# int TclTestChannelEventCmd(ClientData clientData, +# int TclTestChannelEventCmd(void *clientData, # Tcl_Interp *interp, int argc, char **argv) #} @@ -945,10 +945,9 @@ declare 249 { int *decpt, int *signum, char **endPtr) } -declare 258 { +declare 259 { void TclUnusedStubEntry(void) } - ############################################################################## diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 6e74d36..fe23e77 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -1064,9 +1064,10 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, /* Slot 255 is reserved */ /* Slot 256 is reserved */ /* Slot 257 is reserved */ +/* Slot 258 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 258 */ +/* 259 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -1332,7 +1333,8 @@ typedef struct TclIntStubs { VOID *reserved255; VOID *reserved256; VOID *reserved257; - void (*tclUnusedStubEntry) (void); /* 258 */ + VOID *reserved258; + void (*tclUnusedStubEntry) (void); /* 259 */ } TclIntStubs; extern TclIntStubs *tclIntStubsPtr; @@ -2070,9 +2072,10 @@ extern TclIntStubs *tclIntStubsPtr; /* Slot 255 is reserved */ /* Slot 256 is reserved */ /* Slot 257 is reserved */ +/* Slot 258 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclIntStubsPtr->tclUnusedStubEntry) /* 258 */ + (tclIntStubsPtr->tclUnusedStubEntry) /* 259 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b78febc..239cf60 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -558,7 +558,8 @@ TclIntStubs tclIntStubs = { NULL, /* 255 */ NULL, /* 256 */ NULL, /* 257 */ - TclUnusedStubEntry, /* 258 */ + NULL, /* 258 */ + TclUnusedStubEntry, /* 259 */ }; TclIntPlatStubs tclIntPlatStubs = { -- cgit v0.12 From 92c8a53689ae3aed2756704c0497352e686c3ae2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jan 2020 12:55:41 +0000 Subject: Better error-handling in some libtommath calls. --- generic/tclBasic.c | 2 +- generic/tclObj.c | 9 ++++++++- generic/tclStrToD.c | 4 ++-- generic/tclTestObj.c | 30 +++++++++++++++--------------- generic/tclTomMathInterface.c | 19 +++++++------------ 5 files changed, 33 insertions(+), 31 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a03f131..68f32c2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7547,7 +7547,7 @@ ExprAbsFunc( if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: - mp_neg(&big, &big); + (void)mp_neg(&big, &big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { unChanged: diff --git a/generic/tclObj.c b/generic/tclObj.c index eca456f..b5d6d84 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3392,7 +3392,14 @@ GetBignumFromObj( mp_int temp; UNPACK_BIGNUM(objPtr, temp); - mp_init_copy(bignumValue, &temp); + if (mp_init_copy(bignumValue, &temp) != MP_OKAY) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to unpack bignum", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } } else { UNPACK_BIGNUM(objPtr, *bignumValue); objPtr->internalRep.twoPtrValue.ptr1 = NULL; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 16eca19..523e0cb 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1283,7 +1283,7 @@ TclParseNumber( } if (octalSignificandOverflow) { if (signum) { - mp_neg(&octalSignificandBig, &octalSignificandBig); + (void)mp_neg(&octalSignificandBig, &octalSignificandBig); } TclSetBignumIntRep(objPtr, &octalSignificandBig); } @@ -1330,7 +1330,7 @@ TclParseNumber( } if (significandOverflow) { if (signum) { - mp_neg(&significandBig, &significandBig); + (void)mp_neg(&significandBig, &significandBig); } TclSetBignumIntRep(objPtr, &significandBig); } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f741714..ba1dda6 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -160,7 +160,7 @@ TestbignumobjCmd( }; int index, varIndex; const char *string; - mp_int bignumValue, newValue; + mp_int bignumValue; Tcl_Obj **varPtr; if (objc < 3) { @@ -233,19 +233,16 @@ TestbignumobjCmd( &bignumValue) != TCL_OK) { return TCL_ERROR; } - if (mp_init(&newValue) != MP_OKAY - || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) { + if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) { mp_clear(&bignumValue); - mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_mul_d", -1)); return TCL_ERROR; } - mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBignumObj(varPtr[varIndex], &newValue); + Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); } break; @@ -261,19 +258,16 @@ TestbignumobjCmd( &bignumValue) != TCL_OK) { return TCL_ERROR; } - if (mp_init(&newValue) != MP_OKAY - || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) { + if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) { mp_clear(&bignumValue); - mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_div_d", -1)); return TCL_ERROR; } - mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBignumObj(varPtr[varIndex], &newValue); + Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); } break; @@ -289,10 +283,16 @@ TestbignumobjCmd( &bignumValue) != TCL_OK) { return TCL_ERROR; } + if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) { + mp_clear(&bignumValue); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("error in mp_mod_2d", -1)); + return TCL_ERROR; + } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], !mp_isodd(&bignumValue)); + Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(!mp_isodd(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 2dc8c2d..21fd238 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -111,7 +111,6 @@ TclBNInitBignumFromLong( mp_int *a, long initVal) { - int status; unsigned long v; mp_digit *p; @@ -119,8 +118,7 @@ TclBNInitBignumFromLong( * Allocate enough memory to hold the largest possible long */ - status = mp_init(a); - if (status != MP_OKAY) { + if (mp_init(a) != MP_OKAY) { Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); } @@ -130,7 +128,7 @@ TclBNInitBignumFromLong( if (initVal < 0) { a->sign = MP_NEG; - v = -initVal; + v = -(unsigned long)initVal; } else { a->sign = MP_ZPOS; v = initVal; @@ -170,12 +168,11 @@ TclBNInitBignumFromWideInt( mp_int *a, /* Bignum to initialize */ Tcl_WideInt v) /* Initial value */ { - if (v < (Tcl_WideInt)0) { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v)); - mp_neg(a, a); - } else { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); + if (v < 0) { + (void)TclBNInitBignumFromWideUInt(a, -(Tcl_WideUInt)v); + return mp_neg(a, a); } + (void)TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); return MP_OKAY; } @@ -200,15 +197,13 @@ TclBNInitBignumFromWideUInt( mp_int *a, /* Bignum to initialize */ Tcl_WideUInt v) /* Initial value */ { - int status; mp_digit *p; /* * Allocate enough memory to hold the largest possible Tcl_WideUInt. */ - status = mp_init(a); - if (status != MP_OKAY) { + if (mp_init(a) != MP_OKAY) { Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); } -- cgit v0.12 From b20939682db9de999efc420072a8d0379a36d6e7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 23 Jan 2020 15:40:08 +0000 Subject: Fix See also links in list commands --- doc/lappend.n | 5 +++-- doc/lassign.n | 4 +++- doc/lindex.n | 5 +++-- doc/linsert.n | 5 +++-- doc/list.n | 6 +++--- doc/llength.n | 5 +++-- doc/lmap.n | 5 ++++- doc/lpop.n | 5 +++-- doc/lrange.n | 5 +++-- doc/lremove.n | 4 +++- doc/lrepeat.n | 4 +++- doc/lreplace.n | 5 +++-- doc/lreverse.n | 5 +++-- doc/lsearch.n | 6 ++++-- doc/lset.n | 5 +++-- doc/lsort.n | 5 +++-- 16 files changed, 50 insertions(+), 29 deletions(-) diff --git a/doc/lappend.n b/doc/lappend.n index 66bea5f..89b6909 100644 --- a/doc/lappend.n +++ b/doc/lappend.n @@ -49,8 +49,9 @@ Using \fBlappend\fR to build up a list of numbers. 1 2 3 4 5 .CE .SH "SEE ALSO" -list(n), lindex(n), linsert(n), llength(n), lset(n), -lsort(n), lrange(n) +list(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS append, element, list, variable .\" Local variables: diff --git a/doc/lassign.n b/doc/lassign.n index 5620de6..67048ba 100644 --- a/doc/lassign.n +++ b/doc/lassign.n @@ -52,7 +52,9 @@ command in many shell languages like this: set ::argv [\fBlassign\fR $::argv argumentToReadOff] .CE .SH "SEE ALSO" -lindex(n), list(n), lrange(n), lset(n), set(n) +list(n), lappend(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS assign, element, list, multiple, set, variable '\"Local Variables: diff --git a/doc/lindex.n b/doc/lindex.n index be4f169..01e0d8b 100644 --- a/doc/lindex.n +++ b/doc/lindex.n @@ -115,8 +115,9 @@ set idx 3 \fI\(-> f\fR .CE .SH "SEE ALSO" -list(n), lappend(n), linsert(n), llength(n), lsearch(n), -lset(n), lsort(n), lrange(n), lreplace(n), +list(n), lappend(n), lassign(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, index, list diff --git a/doc/linsert.n b/doc/linsert.n index 91db726..3179256 100644 --- a/doc/linsert.n +++ b/doc/linsert.n @@ -45,8 +45,9 @@ set newList [\fBlinsert\fR $midList end-1 lazy] set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy] .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), llength(n), lsearch(n), -lset(n), lsort(n), lrange(n), lreplace(n), +list(n), lappend(n), lassign(n), lindex(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, insert, list diff --git a/doc/list.n b/doc/list.n index a182fc8..3fa1975 100644 --- a/doc/list.n +++ b/doc/list.n @@ -46,9 +46,9 @@ while \fBconcat\fR with the same arguments will return \fBa b c d e f {g h}\fR .CE .SH "SEE ALSO" -lappend(n), lindex(n), linsert(n), llength(n), lrange(n), -lrepeat(n), -lreplace(n), lsearch(n), lset(n), lsort(n) +lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, list, quoting '\"Local Variables: diff --git a/doc/llength.n b/doc/llength.n index 7e46064..26824a0 100644 --- a/doc/llength.n +++ b/doc/llength.n @@ -49,8 +49,9 @@ An empty list is not necessarily an empty string: 1,0 .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), lsearch(n), -lset(n), lsort(n), lrange(n), lreplace(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, list, length '\" Local Variables: diff --git a/doc/lmap.n b/doc/lmap.n index 1a7858d..026e9d0 100644 --- a/doc/lmap.n +++ b/doc/lmap.n @@ -77,7 +77,10 @@ set prefix [\fBlmap\fR x $values {expr { # The value of prefix is "8 7 6 5 4" .CE .SH "SEE ALSO" -break(n), continue(n), for(n), foreach(n), while(n) +break(n), continue(n), for(n), foreach(n), while(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS foreach, iteration, list, loop, map '\" Local Variables: diff --git a/doc/lpop.n b/doc/lpop.n index 0ce8ff8..631bc58 100644 --- a/doc/lpop.n +++ b/doc/lpop.n @@ -86,8 +86,9 @@ The indicated value becomes the new value of \fIx\fR. \fI\(-> {{a b} {c d}} {{e f} h}\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lsort(n), lrange(n), lreplace(n), lset(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, index, list, remove, pop, stack, queue diff --git a/doc/lrange.n b/doc/lrange.n index a4fd98b..0d4b261 100644 --- a/doc/lrange.n +++ b/doc/lrange.n @@ -71,8 +71,9 @@ elements to {elements to} .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lremove(n), lreplace(n), lsort(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, list, range, sublist diff --git a/doc/lremove.n b/doc/lremove.n index b947863..59d261b 100644 --- a/doc/lremove.n +++ b/doc/lremove.n @@ -46,7 +46,9 @@ Removing the same element indicated in two different ways: a b d e .CE .SH "SEE ALSO" -list(n), lrange(n), lsearch(n), lsearch(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, list, remove .\" Local variables: diff --git a/doc/lrepeat.n b/doc/lrepeat.n index 4719bfd..2e17f9c 100644 --- a/doc/lrepeat.n +++ b/doc/lrepeat.n @@ -32,7 +32,9 @@ is identical to \fBlist element ...\fR. \fI\(-> {a a} b c {a a} b c {a a} b c\fR .CE .SH "SEE ALSO" -list(n), lappend(n), linsert(n), llength(n), lset(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, index, list '\" Local Variables: diff --git a/doc/lreplace.n b/doc/lreplace.n index 68cddfe..bc9d7ca 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -95,8 +95,9 @@ a b c d e f g h i .CE .VE TIP505 .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lrange(n), lremove(n), lsort(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, list, replace diff --git a/doc/lreverse.n b/doc/lreverse.n index 4c2f762..2ed496a 100644 --- a/doc/lreverse.n +++ b/doc/lreverse.n @@ -25,8 +25,9 @@ input list, \fIlist\fR, except with the elements in the reverse order. \fI\(-> f e {c d} b a\fR .CE .SH "SEE ALSO" -list(n), lsearch(n), lsort(n) - +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, list, reverse '\" Local Variables: diff --git a/doc/lsearch.n b/doc/lsearch.n index 9172d96..f38afc9 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -227,8 +227,10 @@ The same thing for a flattened list: \fI\(-> {a abc b bcd}\fR .CE .SH "SEE ALSO" -foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), -lset(n), lsort(n), lrange(n), lreplace(n), +foreach(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lset(n), lsort(n), string(n) .SH KEYWORDS binary search, linear search, diff --git a/doc/lset.n b/doc/lset.n index e425274..afc721f 100644 --- a/doc/lset.n +++ b/doc/lset.n @@ -136,8 +136,9 @@ The indicated return value also becomes the new value of \fIx\fR. \fI\(-> {{a b} {c d}} {{e f} {j h}}\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lsort(n), lrange(n), lreplace(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lsort(n) string(n) .SH KEYWORDS element, index, list, replace, set diff --git a/doc/lsort.n b/doc/lsort.n index 17a921a..2018e30 100644 --- a/doc/lsort.n +++ b/doc/lsort.n @@ -264,8 +264,9 @@ More complex sorting using a comparison function: {1 dingo} {2 banana} {0x2 carrot} {3 apple} .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lrange(n), lreplace(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n) .SH KEYWORDS element, list, order, sort '\" Local Variables: -- cgit v0.12 From bfed58b030fcbad9ec232ecc48a43e637022e307 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 25 Jan 2020 14:51:08 +0000 Subject: TIP #559 follow-up: Make sure that if Tcl_FreeResult() is used in an extension compiled with -DTCL_NO_DEPRECATED, this results in a link error. Do the same with deprecated funcions from other TIP's. --- generic/tclDecls.h | 15 +++++++++++++++ generic/tclResult.c | 6 ++---- generic/tclStubInit.c | 1 + 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7386347..c487521 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4015,7 +4015,22 @@ extern const TclStubs *tclStubsPtr; #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) #ifdef TCL_NO_DEPRECATED +#undef Tcl_FreeResult +#undef Tcl_AppendResultVA +#undef Tcl_AppendStringsToObjVA +#undef Tcl_SetErrorCodeVA +#undef Tcl_VarEvalVA +#undef Tcl_PanicVA #undef Tcl_GetStringResult +#undef Tcl_GetDefaultEncodingDir +#undef Tcl_SetDefaultEncodingDir +#undef Tcl_UniCharLen +#undef Tcl_UniCharNcmp +#undef Tcl_EvalTokens +#undef Tcl_UniCharNcasecmp +#undef Tcl_UniCharCaseMatch +#undef Tcl_GetMathFuncInfo +#undef Tcl_ListMathFuncs #define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #undef Tcl_Eval #define Tcl_Eval(interp, objPtr) \ diff --git a/generic/tclResult.c b/generic/tclResult.c index 5c2a81f..29c5aac 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -853,7 +853,6 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -883,7 +882,6 @@ Tcl_FreeResult( { Interp *iPtr = (Interp *) interp; -#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -893,10 +891,10 @@ Tcl_FreeResult( iPtr->freeProc = 0; } -#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } - +#endif /* !TCL_NO_DEPRECATED */ + /* *---------------------------------------------------------------------- * diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 493a272..97ef2cc 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -255,6 +255,7 @@ mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) { # define Tcl_NewLongObj 0 # define Tcl_DbNewLongObj 0 # define Tcl_BackgroundError 0 +# define Tcl_FreeResult 0 #else mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) { -- cgit v0.12 From 7c48658c9f808152cc40f5afec9df0cb0b28bffe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 27 Jan 2020 10:31:36 +0000 Subject: =?UTF-8?q?Fix=20install-libraries-zipfs-static=20target:=20On=20W?= =?UTF-8?q?indows=20INSTALL=5FDATA=20makes=20no=20sense.=20Reported=20by?= =?UTF-8?q?=20Ren=C3=A9=20Zaumseil.=20Thanks!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- win/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index 75b6e07..33644cb 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -834,7 +834,7 @@ install-binaries: binaries install-libraries-zipfs-shared: libraries install-libraries-zipfs-static: install-libraries-zipfs-shared - $(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)" + $(COPY) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)" install-libraries: libraries install-tzdata install-msgs @for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \ -- cgit v0.12 From 667676a5510ccdd2fa569d14ebaccada0090393b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 29 Jan 2020 13:02:06 +0000 Subject: Fix compiler warnings on Cygwin when using -DTCL_NO_DEPRECATED Use TCL_CHANNEL_VERSION_5 in stead of TCL_CHANNEL_VERSION_3 in tclZlib.c --- generic/tclStubInit.c | 2 +- generic/tclZlib.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 97ef2cc..6a588a5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -504,7 +504,7 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ return result; } #define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj -#if TCL_UTF_MAX < 4 +#if TCL_UTF_MAX < 4 && !defined(TCL_NO_DEPRECATED) static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 8dbe807..49f1c39 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -204,7 +204,7 @@ static void ZlibTransformTimerRun(void *clientData); static const Tcl_ChannelType zlibChannelType = { "zlib", - TCL_CHANNEL_VERSION_3, + TCL_CHANNEL_VERSION_5, ZlibTransformClose, ZlibTransformInput, ZlibTransformOutput, -- cgit v0.12 From 57321fa4a4c4133d207d8d17123ae0037d162538 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 29 Jan 2020 16:50:56 +0000 Subject: better test covering [5d989f9ba3] - limiting AS considers normal memory usage of process; prepared for new common test-facility (test-with-limit) for resticted execution --- tests/cmdIL.test | 59 +++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 43 insertions(+), 16 deletions(-) diff --git a/tests/cmdIL.test b/tests/cmdIL.test index fabedea..c2b4615 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -446,38 +446,65 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } -result 0 -cleanup { rename test_lsort "" } -test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { - # test it in child process (with limited address space): +proc test-with-limit args { + set body [lindex $args end] + array set in [lrange $args 0 end-1] + # test in child process (with limits): set pipe {} if {[catch { + # start new process: set pipe [open |[list [interpreter]] r+] - exec prlimit -p [pid $pipe] --as=80000000 - } msg]} { + set ppid [pid $pipe] + # create prlimit args: + set args {} + if {[info exists in(-memory)]} { + # with limited address space, so try to retrieve current memory (using ps, vsz is in KB): + if {[catch { + incr in(-memory) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}] + }]} { + # ps failed, use default size 20MB: + incr in(-memory) 20000000 + # + size of locale-archive (may be up to 100MB): + incr in(-memory) [expr { + [file exists /usr/lib/locale/locale-archive] ? [file size /usr/lib/locale/locale-archive] : 0 + }] + } + append args --as=$in(-memory) + } + # apply limits: + exec prlimit -p $ppid {*}$args + } msg opt]} { catch {close $pipe} tcltest::Skip "prlimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" } # if no error (enough memory), or error by list creation - add it as skipped test: - if {![catch { + catch { chan configure $pipe -buffering line - puts $pipe { - # create list and get length (avoid too long output in interactive shells): - llength [set l [lrepeat 4000000 ""]] - # test OOM: - puts [llength [lsort $l]] - exit - } + puts $pipe "puts \[$body\]" + puts $pipe exit set result [read $pipe] close $pipe set pipe {} set result - } result] || [regexp {^(?:list creation failed|unable to alloc)} $result]} { + } result opt + if {$pipe ne ""} { catch { close $pipe } } + return {*}$opt $result +} +test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { + # test it in child process (with limited address space): + if {![catch { + # ca. 80MB extra memory on x64 system would be enough to sort the half (2M) items: + test-with-limit -memory [expr {$tcl_platform(pointerSize)*3 * 2000000 + $tcl_platform(pointerSize)*4000000}] { + # create list and get length (avoid too long output in interactive shells): + llength [set l [lrepeat 4000000 ""]] + # test OOM: + llength [lsort $l] + } + } result] || [regexp {^(?:list creation failed|unable to (?:re)?alloc)} $result]} { tcltest::Skip "prlimit: wrong AS-limit, result: $result" } set result # expecting error no memory by sort -} -cleanup { - if {$pipe ne ""} { catch { close $pipe } } - unset -nocomplain pipe line result } -result {no enough memory to proccess sort of 4000000 items} # Compiled version -- cgit v0.12 From 782689d5eb24cd73d2dfaef376d4412246ec6cfa Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 29 Jan 2020 17:02:16 +0000 Subject: small amend (comments only) --- tests/cmdIL.test | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/cmdIL.test b/tests/cmdIL.test index c2b4615..b57f1ac 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -477,7 +477,7 @@ proc test-with-limit args { catch {close $pipe} tcltest::Skip "prlimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" } - # if no error (enough memory), or error by list creation - add it as skipped test: + # execute body, close process and return: catch { chan configure $pipe -buffering line puts $pipe "puts \[$body\]" @@ -493,13 +493,14 @@ proc test-with-limit args { test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { # test it in child process (with limited address space): if {![catch { - # ca. 80MB extra memory on x64 system would be enough to sort the half (2M) items: + # ca. 80MB extra memory on x64 system would be not enough to sort 4M items (the half 2M only): test-with-limit -memory [expr {$tcl_platform(pointerSize)*3 * 2000000 + $tcl_platform(pointerSize)*4000000}] { # create list and get length (avoid too long output in interactive shells): llength [set l [lrepeat 4000000 ""]] # test OOM: llength [lsort $l] } + # if no error (enough memory), or error by list creation - add it as skipped test: } result] || [regexp {^(?:list creation failed|unable to (?:re)?alloc)} $result]} { tcltest::Skip "prlimit: wrong AS-limit, result: $result" } -- cgit v0.12 From 56f2fc4f042a67bb4211d55850c10c1639795dd6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Jan 2020 13:00:12 +0000 Subject: According to the [https://core.tcl-lang.org/tcl/artifact?udc=1&ln=469-471&name=5ac7827cd282bbda|documentation], close2Proc(...., 0) should operate the same as closeProc(). Fix the UNIX/Windows socket channels to behave like that. --- unix/tclUnixSock.c | 23 ++++++----------------- win/tclWinSock.c | 23 +++++++---------------- 2 files changed, 13 insertions(+), 33 deletions(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 90c72c0..ba36d7b 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -659,30 +659,19 @@ TcpClose2Proc( { TcpState *statePtr = instanceData; int errorCode = 0; - int sd; /* * Shutdown the OS socket handle. */ - - switch(flags) { - case TCL_CLOSE_READ: - sd = SHUT_RD; - break; - case TCL_CLOSE_WRITE: - sd = SHUT_WR; - break; - default: - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "socket close2proc called bidirectionally", -1)); - } - return TCL_ERROR; + if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) { + return TcpCloseProc(instanceData, interp); } - if (shutdown(statePtr->fds.fd,sd) < 0) { + if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->fds.fd, SHUT_RD) < 0)) { + errorCode = errno; + } + if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->fds.fd, SHUT_WR) < 0) && (errorCode != 0)) { errorCode = errno; } - return errorCode; } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index a397a30..565b525 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1069,34 +1069,25 @@ TcpClose2Proc( { TcpState *statePtr = instanceData; int errorCode = 0; - int sd; /* * Shutdown the OS socket handle. */ - switch(flags) { - case TCL_CLOSE_READ: - sd = SD_RECEIVE; - break; - case TCL_CLOSE_WRITE: - sd = SD_SEND; - break; - default: - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "socket close2proc called bidirectionally", -1)); - } - return TCL_ERROR; + if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) { + return TcpCloseProc(instanceData, interp); } /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or * TCL_WRITABLE so this should never be called for a server socket. */ - if (shutdown(statePtr->sockets->fd, sd) == SOCKET_ERROR) { + if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->sockets->fd, SD_SEND) == SOCKET_ERROR) && (errorCode != 0)) { TclWinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); } - return errorCode; } -- cgit v0.12 From ee66478056af217424f2052723fbd89ee0d0f933 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Jan 2020 13:04:12 +0000 Subject: Simplify the use of HaveVersion() in Channel handling. Nothing functional, only code clean-up. --- generic/tclIO.c | 100 ++++++++++++++++---------------------------------- generic/tclIOCmd.c | 2 +- generic/tclIORTrans.c | 38 ++----------------- 3 files changed, 35 insertions(+), 105 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index ff04636..8ea70e7 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -204,8 +204,6 @@ static Tcl_Encoding GetBinaryEncoding(); static void FreeBinaryEncoding(ClientData clientData); static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); -static int HaveVersion(const Tcl_ChannelType *typePtr, - Tcl_ChannelTypeVersion minimumVersion); static void PeekAhead(Channel *chanPtr, char **dstEndPtr, GetsState *gsPtr); static int ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr, @@ -471,9 +469,8 @@ ChanSeek( * type and non-NULL. */ - if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && - chanPtr->typePtr->wideSeekProc != NULL) { - return chanPtr->typePtr->wideSeekProc(chanPtr->instanceData, + if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) { + return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData, offset, mode, errnoPtr); } @@ -482,7 +479,7 @@ ChanSeek( return Tcl_LongAsWide(-1); } - return Tcl_LongAsWide(chanPtr->typePtr->seekProc(chanPtr->instanceData, + return Tcl_LongAsWide(Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData, Tcl_WideAsLong(offset), mode, errnoPtr)); } @@ -4175,7 +4172,7 @@ WillWrite( { int inputBuffered; - if ((chanPtr->typePtr->seekProc != NULL) && + if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){ int ignore; @@ -4194,7 +4191,7 @@ WillRead( Tcl_SetErrno(EINVAL); return -1; } - if ((chanPtr->typePtr->seekProc != NULL) + if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { /* @@ -6933,7 +6930,7 @@ Tcl_Seek( * defined. This means that the channel does not support seeking. */ - if (chanPtr->typePtr->seekProc == NULL) { + if (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) { Tcl_SetErrno(EINVAL); return Tcl_LongAsWide(-1); } @@ -7097,7 +7094,7 @@ Tcl_Tell( * defined. This means that the channel does not support seeking. */ - if (chanPtr->typePtr->seekProc == NULL) { + if (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) { Tcl_SetErrno(EINVAL); return Tcl_LongAsWide(-1); } @@ -10427,49 +10424,15 @@ Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) { - return TCL_CHANNEL_VERSION_2; - } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) { - return TCL_CHANNEL_VERSION_3; - } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_4) { - return TCL_CHANNEL_VERSION_4; - } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_5) { - return TCL_CHANNEL_VERSION_5; - } else { + if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2) + || (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) { /* * In = (PTR2INT(minimumVersion)); + return chanTypePtr->version; } /* @@ -10492,15 +10455,14 @@ Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { - return chanTypePtr->blockModeProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + /* + * The v1 structure had the blockModeProc in a different place. + */ + return (Tcl_DriverBlockModeProc *) chanTypePtr->version; } - /* - * The v1 structure had the blockModeProc in a different place. - */ - - return (Tcl_DriverBlockModeProc *) chanTypePtr->version; + return chanTypePtr->blockModeProc; } /* @@ -10740,10 +10702,10 @@ Tcl_ChannelFlushProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { - return chanTypePtr->flushProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + return NULL; } - return NULL; + return chanTypePtr->flushProc; } /* @@ -10767,10 +10729,10 @@ Tcl_ChannelHandlerProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { - return chanTypePtr->handlerProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + return NULL; } - return NULL; + return chanTypePtr->handlerProc; } /* @@ -10794,10 +10756,10 @@ Tcl_ChannelWideSeekProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) { - return chanTypePtr->wideSeekProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) { + return NULL; } - return NULL; + return chanTypePtr->wideSeekProc; } /* @@ -10822,10 +10784,10 @@ Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) { - return chanTypePtr->threadActionProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) { + return NULL; } - return NULL; + return chanTypePtr->threadActionProc; } /* @@ -11137,10 +11099,10 @@ Tcl_ChannelTruncateProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_5)) { - return chanTypePtr->truncateProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_5) { + return NULL; } - return NULL; + return chanTypePtr->truncateProc; } /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 834f225..af1295f 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -713,7 +713,7 @@ Tcl_CloseObjCmd( /* * Special handling is needed if and only if the channel mode supports * more than the direction to close. Because if the close the last - * direction suppported we can and will go through the regular + * direction supported we can and will go through the regular * process. */ diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index af86ba5..27a938d 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -27,10 +27,6 @@ #define EOK 0 #endif -/* DUPLICATE of HaveVersion() in tclIO.c // TODO - MODULE_SCOPE */ -static int HaveVersion(const Tcl_ChannelType *typePtr, - Tcl_ChannelTypeVersion minimumVersion); - /* * Signatures of all functions used in the C layer of the reflection. */ @@ -1386,16 +1382,15 @@ ReflectSeekWide( * non-NULL... */ - if (HaveVersion(parent->typePtr, TCL_CHANNEL_VERSION_3) && - parent->typePtr->wideSeekProc != NULL) { - curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset, + if (Tcl_ChannelWideSeekProc(parent->typePtr) != NULL) { + curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset, seekMode, errorCodePtr); } else if (offset < Tcl_LongAsWide(LONG_MIN) || offset > Tcl_LongAsWide(LONG_MAX)) { *errorCodePtr = EOVERFLOW; curPos = Tcl_LongAsWide(-1); } else { - curPos = Tcl_LongAsWide(parent->typePtr->seekProc( + curPos = Tcl_LongAsWide(Tcl_ChannelSeekProc(parent->typePtr)( parent->instanceData, Tcl_WideAsLong(offset), seekMode, errorCodePtr)); } @@ -3391,33 +3386,6 @@ TransformLimit( return 1; } -/* DUPLICATE of HaveVersion() in tclIO.c - *---------------------------------------------------------------------- - * - * HaveVersion -- - * - * Return whether a channel type is (at least) of a given version. - * - * Results: - * True if the minimum version is exceeded by the version actually - * present. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -HaveVersion( - const Tcl_ChannelType *chanTypePtr, - Tcl_ChannelTypeVersion minimumVersion) -{ - Tcl_ChannelTypeVersion actualVersion = Tcl_ChannelVersion(chanTypePtr); - - return PTR2INT(actualVersion) >= PTR2INT(minimumVersion); -} - /* * Local Variables: * mode: c -- cgit v0.12 From f58b90fb022b744619f4a7af445bac8a561bde7a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Jan 2020 13:52:58 +0000 Subject: Reset WSAGetLastError()/errno always, even when this error is not reported due to the earlier error. --- unix/tclUnixSock.c | 11 ++++++----- win/tclWinSock.c | 11 ++++++----- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index ba36d7b..a00559a 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -658,7 +658,8 @@ TcpClose2Proc( int flags) /* Flags that indicate which side to close. */ { TcpState *statePtr = instanceData; - int errorCode = 0; + int readError = 0; + int writeError = 0; /* * Shutdown the OS socket handle. @@ -667,12 +668,12 @@ TcpClose2Proc( return TcpCloseProc(instanceData, interp); } if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->fds.fd, SHUT_RD) < 0)) { - errorCode = errno; + readError = errno; } - if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->fds.fd, SHUT_WR) < 0) && (errorCode != 0)) { - errorCode = errno; + if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->fds.fd, SHUT_WR) < 0)) { + writeError = errno; } - return errorCode; + return (readError != 0) ? readError : writeError; } /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 565b525..e52e509 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1068,7 +1068,8 @@ TcpClose2Proc( int flags) /* Flags that indicate which side to close. */ { TcpState *statePtr = instanceData; - int errorCode = 0; + int readError = 0; + int writeError = 0; /* * Shutdown the OS socket handle. @@ -1082,13 +1083,13 @@ TcpClose2Proc( * TCL_WRITABLE so this should never be called for a server socket. */ if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) { TclWinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); + readError = Tcl_GetErrno(); } - if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->sockets->fd, SD_SEND) == SOCKET_ERROR) && (errorCode != 0)) { + if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->sockets->fd, SD_SEND) == SOCKET_ERROR)) { TclWinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); + writeError = Tcl_GetErrno(); } - return errorCode; + return (readError != 0) ? readError : writeError; } /* -- cgit v0.12 From f05d9af86d492cd0b158969b5190ccc651e91db4 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 30 Jan 2020 15:32:51 +0000 Subject: introduces new command and constraint testWithLimit (as include tests/internals.tcl) that can be used to test a code under restricted circumstances (e.g. limited address space) --- library/tcltest/tcltest.tcl | 2 +- tests/cmdIL.test | 75 +++++++---------------------------- tests/internals.tcl | 96 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 112 insertions(+), 61 deletions(-) create mode 100644 tests/internals.tcl diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index e0c925a..1394949 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -970,7 +970,7 @@ proc tcltest::testConstraint {constraint {value ""}} { return $testConstraints($constraint) } # Check for boolean values - if {[catch {expr {$value && $value}} msg]} { + if {[catch {expr {$value && 1}} msg]} { return -code error $msg } if {[limitConstraints] && ($constraint ni $Option(-constraints))} { diff --git a/tests/cmdIL.test b/tests/cmdIL.test index b57f1ac..4a59177 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -15,7 +15,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] -testConstraint prlimit [expr {[testConstraint macOrUnix] && ![catch { exec prlimit -n }]}] +source [file join [file dirname [info script]] internals.tcl] +namespace import -force ::tcltest::internals::* test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { list [catch {lsort} msg] $msg @@ -446,67 +447,21 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } -result 0 -cleanup { rename test_lsort "" } -proc test-with-limit args { - set body [lindex $args end] - array set in [lrange $args 0 end-1] - # test in child process (with limits): - set pipe {} - if {[catch { - # start new process: - set pipe [open |[list [interpreter]] r+] - set ppid [pid $pipe] - # create prlimit args: - set args {} - if {[info exists in(-memory)]} { - # with limited address space, so try to retrieve current memory (using ps, vsz is in KB): - if {[catch { - incr in(-memory) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}] - }]} { - # ps failed, use default size 20MB: - incr in(-memory) 20000000 - # + size of locale-archive (may be up to 100MB): - incr in(-memory) [expr { - [file exists /usr/lib/locale/locale-archive] ? [file size /usr/lib/locale/locale-archive] : 0 - }] - } - append args --as=$in(-memory) - } - # apply limits: - exec prlimit -p $ppid {*}$args - } msg opt]} { - catch {close $pipe} - tcltest::Skip "prlimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" - } - # execute body, close process and return: - catch { - chan configure $pipe -buffering line - puts $pipe "puts \[$body\]" - puts $pipe exit - set result [read $pipe] - close $pipe - set pipe {} - set result - } result opt - if {$pipe ne ""} { catch { close $pipe } } - return {*}$opt $result -} -test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { - # test it in child process (with limited address space): - if {![catch { - # ca. 80MB extra memory on x64 system would be not enough to sort 4M items (the half 2M only): - test-with-limit -memory [expr {$tcl_platform(pointerSize)*3 * 2000000 + $tcl_platform(pointerSize)*4000000}] { - # create list and get length (avoid too long output in interactive shells): - llength [set l [lrepeat 4000000 ""]] - # test OOM: - llength [lsort $l] - } - # if no error (enough memory), or error by list creation - add it as skipped test: - } result] || [regexp {^(?:list creation failed|unable to (?:re)?alloc)} $result]} { - tcltest::Skip "prlimit: wrong AS-limit, result: $result" +test cmdIL-5.7 {lsort memory exhaustion} -constraints {testWithLimit} -body { + # test it in child process (with limited address space) ca. 80MB extra memory + # on x64 system it would be not enough to sort 4M items (the half 2M only), + # warn and skip if no error (enough memory) or error by list creation: + testWithLimit \ + -warn-on-code 0 -warn-on-alloc-error 1 \ + -addmem [expr {$tcl_platform(pointerSize)*4000000 + $tcl_platform(pointerSize)*3*2000000}] \ + { + # create list and get length (avoid too long output in interactive shells): + llength [set l [lrepeat 4000000 ""]] + # test OOM: + llength [lsort $l] } - set result # expecting error no memory by sort -} -result {no enough memory to proccess sort of 4000000 items} +} -returnCodes 1 -result {no enough memory to proccess sort of 4000000 items} # Compiled version test cmdIL-6.1 {lassign command syntax} -body { diff --git a/tests/internals.tcl b/tests/internals.tcl new file mode 100644 index 0000000..6b5bb87 --- /dev/null +++ b/tests/internals.tcl @@ -0,0 +1,96 @@ +# This file contains internal facilities for Tcl tests. +# +# Source this file in the related tests to include from tcl-tests: +# +# source [file join [file dirname [info script]] internals.tcl] +# +# Copyright (c) 2020 Sergey G. Brester (sebres). +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[namespace which -command ::tcltest::internals::scriptpath] eq ""} {namespace eval ::tcltest::internals { + +namespace path ::tcltest + +::tcltest::ConstraintInitializer testWithLimit { expr {[testConstraint macOrUnix] && ![catch { exec prlimit --version }]} } + +# test-with-limit -- +# +# Usage: test-with-limit ?-addmem bytes? ?-maxmem bytes? command +# Options: +# -addmem - set additional memory limit (in bytes) as difference (extra memory needed to run a test) +# -maxmem - set absolute maximum address space limit (in bytes) +# +proc testWithLimit args { + set body [lindex $args end] + array set in [lrange $args 0 end-1] + # test in child process (with limits): + set pipe {} + if {[catch { + # start new process: + set pipe [open |[list [interpreter]] r+] + set ppid [pid $pipe] + # create prlimit args: + set args {} + # with limited address space: + if {[info exists in(-addmem)] || [info exists in(-maxmem)]} { + if {[info exists in(-addmem)]} { + # as differnce to normal usage, so try to retrieve current memory usage: + if {[catch { + # using ps (vsz is in KB): + incr in(-addmem) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}] + }]} { + # ps failed, use default size 20MB: + incr in(-addmem) 20000000 + # + size of locale-archive (may be up to 100MB): + incr in(-addmem) [expr { + [file exists /usr/lib/locale/locale-archive] ? + [file size /usr/lib/locale/locale-archive] : 0 + }] + } + if {![info exists in(-maxmem)]} { + set in(-maxmem) $in(-addmem) + } + set in(-maxmem) [expr { max($in(-addmem), $in(-maxmem)) }] + } + append args --as=$in(-maxmem) + } + # apply limits: + exec prlimit -p $ppid {*}$args + } msg opt]} { + catch {close $pipe} + tcltest::Warn "testWithLimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" + tcltest::Skip testWithLimit + } + # execute body, close process and return: + set ret [catch { + chan configure $pipe -buffering line + puts $pipe "puts \[$body\]" + puts $pipe exit + set result [read $pipe] + close $pipe + set pipe {} + set result + } result opt] + if {$pipe ne ""} { catch { close $pipe } } + if {$ret && [dict get $opt -errorcode] eq "BYPASS-SKIPPED-TEST"} { + return {*}$opt $result + } + if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) ) + || ( $ret && [info exists in(-warn-on-alloc-error)] && $in(-warn-on-alloc-error) + && [regexp {\munable to (?:re)?alloc\M} $result] ) + } { + tcltest::Warn "testWithLimit: wrong limit, result: $result" + tcltest::Skip testWithLimit + } + return {*}$opt $result +} + +# export all routines starting with test +namespace export test* + +# for script path & as mark for loaded +proc scriptpath {} [list return [info script]] + +}}; # end of internals. \ No newline at end of file -- cgit v0.12 From cac60f04fca58ee06fd50a449b658cf8d6dde44f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 31 Jan 2020 07:54:59 +0000 Subject: Add 64-bit seek to the ZipChannel --- generic/tclLink.c | 2 +- generic/tclZipfs.c | 36 ++++++++++++++++++++++++------------ 2 files changed, 25 insertions(+), 13 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index ecb7aa5..35f1cee 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -164,7 +164,7 @@ Tcl_LinkVar( int code; linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, - TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL); + TCL_GLOBAL_ONLY, LinkTraceProc, NULL); if (linkPtr != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable '%s' is already linked", varName)); diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 9aa26d9..0b741b7 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -392,6 +392,8 @@ static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); static int ZipChannelSeek(void *instanceData, long offset, int mode, int *errloc); +static Tcl_WideInt ZipChannelWideSeek(void *instanceData, Tcl_WideInt offset, + int mode, int *errloc); static void ZipChannelWatchChannel(void *instanceData, int mask); static int ZipChannelWrite(void *instanceData, @@ -454,7 +456,7 @@ static Tcl_ChannelType ZipChannelType = { NULL, /* Set blocking mode for raw channel, NULL'able */ NULL, /* Function to flush channel, NULL'able */ NULL, /* Function to handle event, NULL'able */ - NULL, /* Wide seek function, NULL'able */ + ZipChannelWideSeek, /* Wide seek function, NULL'able */ NULL, /* Thread action function, NULL'able */ NULL, /* Truncate function, NULL'able */ }; @@ -1286,7 +1288,7 @@ ZipFSCatalogFilesystem( *zf = *zf0; zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); - Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf); + Tcl_CreateExitHandler(ZipfsExitHandler, zf); zf->mountPointLen = strlen(zf->mountPoint); zf->nameLength = strlen(zipname); zf->name = ckalloc(zf->nameLength + 1); @@ -1852,7 +1854,7 @@ TclZipfs_Unmount( ckfree(z); } ZipFSCloseArchive(interp, zf); - Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf); + Tcl_DeleteExitHandler(ZipfsExitHandler, zf); ckfree(zf); unmounted = 1; done: @@ -3472,7 +3474,7 @@ ZipChannelWrite( /* *------------------------------------------------------------------------- * - * ZipChannelSeek -- + * ZipChannelSeek/ZipChannelWideSeek -- * * This function is called to position file pointer of channel. * @@ -3485,15 +3487,15 @@ ZipChannelWrite( *------------------------------------------------------------------------- */ -static int -ZipChannelSeek( +static Tcl_WideInt +ZipChannelWideSeek( void *instanceData, - long offset, + Tcl_WideInt offset, int mode, int *errloc) { ZipChannel *info = (ZipChannel *) instanceData; - unsigned long end; + size_t end; if (!info->isWriting && (info->isDirectory < 0)) { /* @@ -3525,20 +3527,30 @@ ZipChannelSeek( return -1; } if (info->isWriting) { - if ((unsigned long) offset > info->maxWrite) { + if ((size_t) offset > info->maxWrite) { *errloc = EINVAL; return -1; } - if ((unsigned long) offset > info->numBytes) { + if ((size_t) offset > info->numBytes) { info->numBytes = offset; } - } else if ((unsigned long) offset > end) { + } else if ((size_t) offset > end) { *errloc = EINVAL; return -1; } - info->numRead = (unsigned long) offset; + info->numRead = (size_t) offset; return info->numRead; } + +static int +ZipChannelSeek( + void *instanceData, + long offset, + int mode, + int *errloc) +{ + return ZipChannelWideSeek(instanceData, offset, mode, errloc); +} /* *------------------------------------------------------------------------- -- cgit v0.12 From 4ee1ddaeaabbb6e8c68d9423f302715d07599846 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 2 Feb 2020 16:26:36 +0000 Subject: TclInitBignumFromWide(U)Int is not used any more. --- generic/tclInt.h | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 28cfa50..cddc8ab 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3058,8 +3058,6 @@ MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); -MODULE_SCOPE void TclInitBignumFromWideInt(void *, Tcl_WideInt); -MODULE_SCOPE void TclInitBignumFromWideUInt(void *, Tcl_WideUInt); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( -- cgit v0.12 From 225b4e7cc0a542aea1997329ec38dc9f65e92bbb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Feb 2020 08:28:07 +0000 Subject: It appears that inttypes.h was introduced in Visual Studio 2013 --- win/rules.vc | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 5060805..872b3a0 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1302,11 +1302,8 @@ OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 !else OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1 !endif -!if $(VCVERSION) >= 1700 -OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 -!endif !if $(VCVERSION) >= 1800 -OPTDEFINES = $(OPTDEFINES) /DHAVE_STDBOOL_H=1 +OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 !endif !if $(TCL_MEM_DEBUG) -- cgit v0.12 From 6f55ec4986e85e087da3b208d6d16671048150c4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Feb 2020 11:03:12 +0000 Subject: Clean up some usage of DBGX: It isn't used any more on UNIX --- unix/configure | 3 +-- unix/tcl.m4 | 25 +------------------------ 2 files changed, 2 insertions(+), 26 deletions(-) diff --git a/unix/configure b/unix/configure index 8999e28..28c3616 100755 --- a/unix/configure +++ b/unix/configure @@ -6798,7 +6798,7 @@ fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' + TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a' SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 @@ -8925,7 +8925,6 @@ else tcl_ok=no fi; # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. - DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' diff --git a/unix/tcl.m4 b/unix/tcl.m4 index a4cdbbd..0e02cd6 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -293,10 +293,6 @@ AC_DEFUN([SC_LOAD_TCLCONFIG], [ AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) fi - # eval is required to do the TCL_DBGX substitution - eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" - eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" - # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TCL_LIB_SPEC will be set to the value @@ -330,12 +326,6 @@ AC_DEFUN([SC_LOAD_TCLCONFIG], [ esac fi - # eval is required to do the TCL_DBGX substitution - eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" - eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" - eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\"" - eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\"" - AC_SUBST(TCL_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_BIN_DIR) @@ -376,10 +366,6 @@ AC_DEFUN([SC_LOAD_TKCONFIG], [ AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh]) fi - # eval is required to do the TK_DBGX substitution - eval "TK_LIB_FILE=\"${TK_LIB_FILE}\"" - eval "TK_STUB_LIB_FILE=\"${TK_STUB_LIB_FILE}\"" - # If the TK_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TK_LIB_SPEC will be set to the value @@ -413,12 +399,6 @@ AC_DEFUN([SC_LOAD_TKCONFIG], [ esac fi - # eval is required to do the TK_DBGX substitution - eval "TK_LIB_FLAG=\"${TK_LIB_FLAG}\"" - eval "TK_LIB_SPEC=\"${TK_LIB_SPEC}\"" - eval "TK_STUB_LIB_FLAG=\"${TK_STUB_LIB_FLAG}\"" - eval "TK_STUB_LIB_SPEC=\"${TK_STUB_LIB_SPEC}\"" - AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) @@ -730,8 +710,6 @@ AC_DEFUN([SC_ENABLE_THREADS], [ # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false -# DBGX Formerly used as debug library extension; -# always blank now. #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_SYMBOLS], [ @@ -741,7 +719,6 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ [build with debugging symbols (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. - DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' @@ -1223,7 +1200,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' + TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a' SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" AC_CACHE_CHECK(for Cygwin version of gcc, ac_cv_cygwin, -- cgit v0.12 From b1791f0b92a45956b1f45b4ecba6c8310e4c0273 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Feb 2020 16:40:19 +0000 Subject: (cherry-pick): It appears that inttypes.h was introduced in Visual Studio 2013 --- win/rules.vc | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 5060805..872b3a0 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1302,11 +1302,8 @@ OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 !else OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1 !endif -!if $(VCVERSION) >= 1700 -OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 -!endif !if $(VCVERSION) >= 1800 -OPTDEFINES = $(OPTDEFINES) /DHAVE_STDBOOL_H=1 +OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 !endif !if $(TCL_MEM_DEBUG) -- cgit v0.12 From 2a89abd783b1a6337fc01de4da43f061c2aa4864 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Feb 2020 15:59:38 +0000 Subject: Attempt to fix travis build. See: [https://travis-ci.community/t/vcvarsall-bat-freezes-on-new-1809-based-windows-images/7098] --- .travis.yml | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/.travis.yml b/.travis.yml index 537621c..5a8f24a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -196,8 +196,8 @@ matrix: - cd ${BUILD_DIR} install: [] script: - - cmd.exe /C 'vcvarsall.bat x64 && nmake -f makefile.vc all tcltest' - - cmd.exe /C 'vcvarsall.bat x64 && nmake -f makefile.vc test' + - cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc test - name: "Windows/MSVC/Shared: UTF_MAX=4" os: windows compiler: cl @@ -205,8 +205,8 @@ matrix: before_install: *vcpreinst install: [] script: - - cmd.exe /C 'vcvarsall.bat x64 && nmake OPTS=utfmax -f makefile.vc all tcltest' - - cmd.exe /C 'vcvarsall.bat x64 && nmake OPTS=utfmax -f makefile.vc test' + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc test - name: "Windows/MSVC/Static" os: windows compiler: cl @@ -214,8 +214,8 @@ matrix: before_install: *vcpreinst install: [] script: - - cmd.exe /C 'vcvarsall.bat x64 && nmake OPTS=static,msvcrt -f makefile.vc all tcltest' - - cmd.exe /C 'vcvarsall.bat x64 && nmake OPTS=static,msvcrt -f makefile.vc test' + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test - name: "Windows/MSVC/Debug" os: windows compiler: cl @@ -223,8 +223,8 @@ matrix: before_install: *vcpreinst install: [] script: - - cmd.exe /C 'vcvarsall.bat x64 && nmake OPTS=symbols -f makefile.vc all tcltest' - - cmd.exe /C 'vcvarsall.bat x64 && nmake OPTS=symbols -f makefile.vc test' + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test # Test on Windows with MSVC native (32-bit) - name: "Windows/MSVC-x86/Shared" os: windows @@ -233,8 +233,8 @@ matrix: before_install: *vcpreinst install: [] script: - - cmd.exe /C 'vcvarsall.bat x86 && nmake -f makefile.vc all tcltest' - - cmd.exe /C 'vcvarsall.bat x86 && nmake -f makefile.vc test' + - cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc test - name: "Windows/MSVC-x86/Shared: UTF_MAX=4" os: windows compiler: cl @@ -242,8 +242,8 @@ matrix: before_install: *vcpreinst install: [] script: - - cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=utfmax -f makefile.vc all tcltest' - - cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=utfmax -f makefile.vc test' + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc test - name: "Windows/MSVC-x86/Static" os: windows compiler: cl @@ -251,8 +251,8 @@ matrix: before_install: *vcpreinst install: [] script: - - cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=static,msvcrt -f makefile.vc all tcltest' - - cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=static,msvcrt -f makefile.vc test' + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test - name: "Windows/MSVC-x86/Debug" os: windows compiler: cl @@ -260,8 +260,8 @@ matrix: before_install: *vcpreinst install: [] script: - - cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=symbols -f makefile.vc all tcltest' - - cmd.exe /C 'vcvarsall.bat x86 && nmake OPTS=symbols -f makefile.vc test' + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test # Test on Windows with GCC native - name: "Windows/GCC/Shared" os: windows -- cgit v0.12 From 0f3e54cedbe3cd7dfd47021b43bbd2bf77470266 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Feb 2020 16:38:45 +0000 Subject: Move build from xenial to bionic. Add Xcode11.3 build for MacOS (now that we are on it anyway) --- .travis.yml | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/.travis.yml b/.travis.yml index 5a8f24a..90a08e0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,34 +6,34 @@ matrix: # Testing on Linux with various compilers - name: "Linux/GCC/Shared" os: linux - dist: xenial + dist: bionic compiler: gcc env: - BUILD_DIR=unix - name: "Linux/GCC/Shared: UTF_MAX=4" os: linux - dist: xenial + dist: bionic compiler: gcc env: - BUILD_DIR=unix - CFGOPT=CFLAGS=-DTCL_UTF_MAX=4 - name: "Linux/GCC/Shared: UTF_MAX=6" os: linux - dist: xenial + dist: bionic compiler: gcc env: - BUILD_DIR=unix - CFGOPT=CFLAGS=-DTCL_UTF_MAX=6 - name: "Linux/GCC/Static" os: linux - dist: xenial + dist: bionic compiler: gcc env: - CFGOPT="--disable-shared" - BUILD_DIR=unix - name: "Linux/GCC/Debug" os: linux - dist: xenial + dist: bionic compiler: gcc env: - BUILD_DIR=unix @@ -41,7 +41,7 @@ matrix: # Older versions of GCC... - name: "Linux/GCC 7/Shared" os: linux - dist: xenial + dist: bionic compiler: gcc-7 addons: apt: @@ -53,7 +53,7 @@ matrix: - BUILD_DIR=unix - name: "Linux/GCC 6/Shared" os: linux - dist: xenial + dist: bionic compiler: gcc-6 addons: apt: @@ -65,7 +65,7 @@ matrix: - BUILD_DIR=unix - name: "Linux/GCC 5/Shared" os: linux - dist: xenial + dist: bionic compiler: gcc-5 addons: apt: @@ -77,7 +77,7 @@ matrix: - BUILD_DIR=unix - name: "Linux/GCC 4.9/Shared" os: linux - dist: xenial + dist: bionic compiler: gcc-4.9 addons: apt: @@ -90,33 +90,33 @@ matrix: # Clang - name: "Linux/Clang/Shared" os: linux - dist: xenial + dist: bionic compiler: clang env: - BUILD_DIR=unix - name: "Linux/Clang/Static" os: linux - dist: xenial + dist: bionic compiler: clang env: - CFGOPT="--disable-shared" - BUILD_DIR=unix - name: "Linux/Clang/Debug" os: linux - dist: xenial + dist: bionic compiler: clang env: - BUILD_DIR=unix - CFGOPT="--enable-symbols" # Testing on Mac, various styles - - name: "macOS/Xcode 11/Shared/Unix-like" + - name: "macOS/Xcode 11.3/Shared/Unix-like" os: osx - osx_image: xcode11 + osx_image: xcode11.3 env: - BUILD_DIR=unix - - name: "macOS/Xcode 11/Shared" + - name: "macOS/Xcode 11.3/Shared" os: osx - osx_image: xcode11 + osx_image: xcode11.3 env: - BUILD_DIR=macosx install: [] @@ -124,6 +124,13 @@ matrix: - make all # The styles=develop avoids some weird problems on OSX - make test styles=develop + - name: "macOS/Xcode 11/Shared" + os: osx + osx_image: xcode11 + env: + - BUILD_DIR=macosx + install: [] + script: *mactest - name: "macOS/Xcode 10/Shared" os: osx osx_image: xcode10.3 @@ -149,7 +156,7 @@ matrix: # Doesn't run tests because wine is only an imperfect Windows emulation - name: "Linux-cross-Windows/GCC/Shared/no test" os: linux - dist: xenial + dist: bionic compiler: x86_64-w64-mingw32-gcc addons: apt: @@ -170,7 +177,7 @@ matrix: # Doesn't run tests because wine is only an imperfect Windows emulation - name: "Linux-cross-Windows-32/GCC/Shared/no test" os: linux - dist: xenial + dist: bionic compiler: i686-w64-mingw32-gcc addons: apt: -- cgit v0.12